int
scm_file_exists(ScmObj path, bool *rslt)
{
char path_cstr[PATH_MAX];
struct stat st;
ssize_t s;
int r;
scm_assert(scm_string_p(path));
s = scm_string_to_path_cstr(path, path_cstr, sizeof(path_cstr));
if (s < 0) return -1;
SCM_SYSCALL(r, stat(path_cstr, &st));
if (r < 0 && errno != ENOENT) {
/* TODO; change error message */
scm_error("system call error: stat", 0);
return -1;
}
if (rslt != NULL)
*rslt = (r == 0);
return 0;
}
/*
* This gets called if scm_apply throws an error.
*
* We use gh_scm2newstr to convert from Guile string to Scheme string. The
* GH interface is deprecated, but doing it in scm takes more code. We'll
* convert later if we have to.
*/
static SCM
gnm_guile_catcher (void *data, SCM tag, SCM throw_args)
{
char const *header = _("Guile error");
SCM smob;
SCM func;
SCM res;
char *guilestr = NULL;
char *msg;
GnmValue *v;
func = scm_c_eval_string ("gnm:error->string");
if (scm_procedure_p (func)) {
res = scm_apply (func, tag,
scm_cons (throw_args, scm_listofnull));
if (scm_string_p (res))
guilestr = gh_scm2newstr (res, NULL);
}
if (guilestr != NULL) {
char *buf = g_strdup_printf ("%s: %s", header, guilestr);
free (guilestr);
v = value_new_error (NULL, buf);
g_free (buf);
} else {
v = value_new_error (NULL, header);
}
smob = make_new_smob (v);
value_release (v);
return smob;
}
SWIGINTERN char *
SWIG_Guile_scm2newstr(SCM str, size_t *len) {
#define FUNC_NAME "SWIG_Guile_scm2newstr"
size_t l;
SCM_ASSERT (scm_string_p(str), str, 1, FUNC_NAME);
return scm_to_locale_string( str );
#undef FUNC_NAME
}
static ScmObj
scm_make_file_path_if_exists(ScmObj dir, ScmObj name)
{
ScmObj base = SCM_OBJ_INIT, p = SCM_OBJ_INIT, s = SCM_OBJ_NULL;
bool exists;
int r;
SCM_REFSTK_INIT_REG(&dir, &name,
&base, &p, &s);
scm_assert(scm_obj_null_p(dir) || scm_string_p(dir));
scm_assert(scm_string_p(name));
if (scm_obj_null_p(dir)) {
base = name;
}
else {
base = scm_file_path_join(dir, name);
if (scm_obj_null_p(base)) return SCM_OBJ_NULL;
}
s = scm_get_load_suffixes();
if (scm_obj_null_p(s)) return SCM_OBJ_NULL;
for (; scm_pair_p(s); s = scm_cdr(s)) {
p = scm_format_cstr("~a~a", base, scm_car(s));
if (scm_obj_null_p(p)) return SCM_OBJ_NULL;
r = scm_file_exists(p, &exists);
if (r < 0) return SCM_OBJ_NULL;
if (exists)
return p;
}
r = scm_file_exists(base, &exists);
if (r < 0) return SCM_OBJ_NULL;
return (exists ? base : SCM_FALSE_OBJ);
}
static ScmObj
scm_file_path_join(ScmObj path1, ScmObj path2)
{
ScmObj b;
size_t l;
scm_assert(scm_string_p(path1));
scm_assert(scm_string_p(path2));
l = scm_string_length(path1);
if (l == 0)
return path2;
b = scm_string_char_eq_P(path1, l - 1, '/');
if (scm_obj_null_p(b)) return SCM_OBJ_NULL;
if (scm_true_p(b)) {
return scm_format_cstr("~a~a", path1, path2);
}
else {
return scm_format_cstr("~a/~a", path1, path2);
}
}
static SCM scm_bind_key(SCM mod_mask, SCM key, SCM proc)
{
xcb_keysym_t keysym;
if (scm_is_true(scm_number_p(key)))
keysym = scm_to_uint32(key);
else if (scm_is_true(scm_string_p(key))) {
scm_dynwind_begin(0);
char *c_key = scm_to_locale_string(key);
scm_dynwind_free(c_key);
keysym = get_keysym(c_key);
scm_dynwind_end();
}
else
return SCM_UNSPECIFIED;
bind_key(scm_to_uint16(mod_mask), keysym, proc);
return SCM_UNSPECIFIED;
}
void
__test_make_g_db_handle(gdbi_db_handle_t* dbh)
{
if(scm_is_true(scm_string_p(dbh->constr)) == 0)
{
dbh->status = (SCM) scm_cons(scm_from_int(1),
scm_from_locale_string("missing connection string"));
dbh->closed = SCM_BOOL_F;
return;
}
else
{
dbh->status = (SCM) scm_cons(scm_from_int(0),
scm_from_locale_string("test connect ok"));
dbh->closed = SCM_BOOL_T;
}
return;
}
static ScmObj
scm_string_char_eq_P(ScmObj str, size_t idx, int ascii)
{
ScmEncoding *enc;
scm_char_t c;
int r;
scm_assert(scm_string_p(str));
r = scm_string_ref_cchr(str, idx, &c);
if (r < 0) return SCM_OBJ_NULL;
enc = scm_string_encoding(str);
if (scm_enc_cnv_to_ascii(enc, &c) == ascii)
return SCM_TRUE_OBJ;
else
return SCM_FALSE_OBJ;
}
int
scm_delete_file(ScmObj path)
{
char path_cstr[PATH_MAX];
ssize_t s;
int r;
scm_assert(scm_string_p(path));
s = scm_string_to_path_cstr(path, path_cstr, sizeof(path_cstr));
if (s < 0) return -1;
SCM_SYSCALL(r, unlink(path_cstr));
if (r < 0) {
/* TODO; change error message */
scm_file_error("system call error: unlink", 0);
return -1;
}
return 0;
}
int
scm_add_load_suffix(ScmObj sfx)
{
ScmObj suffixes = SCM_OBJ_INIT;
int r;
SCM_REFSTK_INIT_REG(&sfx,
&suffixes);
scm_assert(scm_string_p(sfx));
suffixes = scm_get_load_suffixes();
if (scm_obj_null_p(suffixes)) return -1;
suffixes = scm_cons(sfx, suffixes);
if (scm_obj_null_p(suffixes)) return -1;
r = scm_cached_global_var_set(SCM_CACHED_GV_LOAD_SUFFIXES, suffixes);
if (r < 0) return -1;
return 0;
}
int
scm_add_load_path(ScmObj dir)
{
ScmObj paths = SCM_OBJ_INIT;
int r;
SCM_REFSTK_INIT_REG(&dir,
&paths);
scm_assert(scm_string_p(dir));
paths = scm_get_load_path();
if (scm_obj_null_p(paths)) return -1;
paths = scm_cons(dir, paths);
if (scm_obj_null_p(paths)) return -1;
r = scm_cached_global_var_set(SCM_CACHED_GV_LOAD_PATH, paths);
if (r < 0) return -1;
return 0;
}
static ScmObj
scm_search_load_file_internal(ScmObj name, ScmObj paths)
{
ScmObj lst = SCM_OBJ_INIT, p = SCM_OBJ_INIT;
SCM_REFSTK_INIT_REG(&name, &paths,
&lst, &p);
scm_assert(scm_string_p(name));
scm_assert(scm_nil_p(paths) || scm_pair_p(paths));
for (lst = paths; scm_pair_p(lst); lst = scm_cdr(lst)) {
p = scm_make_file_path_if_exists(scm_car(lst), name);
if (scm_obj_null_p(p)) return SCM_OBJ_NULL;
if (scm_true_p(p))
return p;
}
if (scm_obj_null_p(lst)) return SCM_OBJ_NULL;
return SCM_FALSE_OBJ;
}
ScmObj
scm_search_load_file(ScmObj name)
{
ScmObj paths = SCM_OBJ_INIT, b = SCM_OBJ_INIT;
SCM_REFSTK_INIT_REG(&name,
&paths, &b);
scm_assert(scm_string_p(name));
if (scm_string_length(name) == 0)
return SCM_FALSE_OBJ;
b = scm_use_load_path_P(name);
if (scm_obj_null_p(b)) return SCM_OBJ_NULL;
if (scm_false_p(b))
return scm_make_file_path_if_exists(SCM_OBJ_NULL, name);
paths = scm_get_load_path();
if (scm_obj_null_p(paths)) return SCM_OBJ_NULL;
return scm_search_load_file_internal(name, paths);
}
static ScmObj
scm_use_load_path_P(ScmObj name)
{
ScmObj (*tbl[])(ScmObj) = {
scm_absolute_path_P, scm_starts_with_pairent_dir_or_current_dir_P,
NULL,
};
ScmObj b = SCM_OBJ_INIT;
SCM_REFSTK_INIT_REG(&name,
&b);
scm_assert(scm_string_p(name));
for (size_t i = 0; tbl[i] != NULL; i++) {
b = tbl[i](name);
if (scm_obj_null_p(b)) return SCM_OBJ_NULL;
if (scm_true_p(b))
return SCM_FALSE_OBJ;
}
return SCM_TRUE_OBJ;
}
static SCM
extract_arg (char format_char, SCM arg, void *argp,
const char *func_name, int position)
{
switch (format_char)
{
case 's':
{
char **arg_ptr = (char **) argp;
CHECK_TYPE (gdbscm_is_true (scm_string_p (arg)), arg, position,
func_name, _("string"));
*arg_ptr = gdbscm_scm_to_c_string (arg);
break;
}
case 't':
{
int *arg_ptr = (int *) argp;
/* While in Scheme, anything non-#f is "true", we're strict. */
CHECK_TYPE (gdbscm_is_bool (arg), arg, position, func_name,
_("boolean"));
*arg_ptr = gdbscm_is_true (arg);
break;
}
case 'i':
{
int *arg_ptr = (int *) argp;
CHECK_TYPE (scm_is_signed_integer (arg, INT_MIN, INT_MAX),
arg, position, func_name, _("int"));
*arg_ptr = scm_to_int (arg);
break;
}
case 'u':
{
int *arg_ptr = (int *) argp;
CHECK_TYPE (scm_is_unsigned_integer (arg, 0, UINT_MAX),
arg, position, func_name, _("unsigned int"));
*arg_ptr = scm_to_uint (arg);
break;
}
case 'l':
{
long *arg_ptr = (long *) argp;
CHECK_TYPE (scm_is_signed_integer (arg, LONG_MIN, LONG_MAX),
arg, position, func_name, _("long"));
*arg_ptr = scm_to_long (arg);
break;
}
case 'n':
{
unsigned long *arg_ptr = (unsigned long *) argp;
CHECK_TYPE (scm_is_unsigned_integer (arg, 0, ULONG_MAX),
arg, position, func_name, _("unsigned long"));
*arg_ptr = scm_to_ulong (arg);
break;
}
case 'L':
{
LONGEST *arg_ptr = (LONGEST *) argp;
CHECK_TYPE (scm_is_signed_integer (arg, INT64_MIN, INT64_MAX),
arg, position, func_name, _("LONGEST"));
*arg_ptr = gdbscm_scm_to_longest (arg);
break;
}
case 'U':
{
ULONGEST *arg_ptr = (ULONGEST *) argp;
CHECK_TYPE (scm_is_unsigned_integer (arg, 0, UINT64_MAX),
arg, position, func_name, _("ULONGEST"));
*arg_ptr = gdbscm_scm_to_ulongest (arg);
break;
}
case 'O':
{
SCM *arg_ptr = (SCM *) argp;
*arg_ptr = arg;
break;
}
default:
gdb_assert_not_reached ("invalid argument format character");
}
return SCM_BOOL_F;
}
