void
scm_assert_foreign_object_type (SCM type, SCM val)
{
if (!SCM_IS_A_P (val, type))
scm_error (scm_arg_type_key, NULL, "Wrong type (expecting ~A): ~S",
scm_list_2 (scm_class_name (type), val), scm_list_1 (val));
}
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;
}
static void
syntax_error (const char* const msg, const SCM form, const SCM expr)
{
SCM msg_string = scm_from_locale_string (msg);
SCM filename = SCM_BOOL_F;
SCM linenr = SCM_BOOL_F;
const char *format;
SCM args;
if (scm_is_pair (form))
{
filename = scm_source_property (form, scm_sym_filename);
linenr = scm_source_property (form, scm_sym_line);
}
if (scm_is_false (filename) && scm_is_false (linenr) && scm_is_pair (expr))
{
filename = scm_source_property (expr, scm_sym_filename);
linenr = scm_source_property (expr, scm_sym_line);
}
if (!SCM_UNBNDP (expr))
{
if (scm_is_true (filename))
{
format = "In file ~S, line ~S: ~A ~S in expression ~S.";
args = scm_list_5 (filename, linenr, msg_string, form, expr);
}
else if (scm_is_true (linenr))
{
format = "In line ~S: ~A ~S in expression ~S.";
args = scm_list_4 (linenr, msg_string, form, expr);
}
else
{
format = "~A ~S in expression ~S.";
args = scm_list_3 (msg_string, form, expr);
}
}
else
{
if (scm_is_true (filename))
{
format = "In file ~S, line ~S: ~A ~S.";
args = scm_list_4 (filename, linenr, msg_string, form);
}
else if (scm_is_true (linenr))
{
format = "In line ~S: ~A ~S.";
args = scm_list_3 (linenr, msg_string, form);
}
else
{
format = "~A ~S.";
args = scm_list_2 (msg_string, form);
}
}
scm_error (syntax_error_key, "memoization", format, args, SCM_BOOL_F);
}
ScmObj
ut_compile(ScmObj exp)
{
ScmObj compile = SCM_OBJ_INIT, args = SCM_OBJ_INIT, val = SCM_OBJ_INIT;
int r;
SCM_REFSTK_INIT_REG(&exp,
&compile, &args, &val);
r = scm_cached_global_var_ref(SCM_CACHED_GV_COMPILE, SCM_CSETTER_L(compile));
if (r < 0) return SCM_OBJ_NULL;
if (scm_obj_null_p(compile)) {
scm_error("unbound variable: compile", 0);
return SCM_OBJ_NULL;
}
args = scm_make_compiler(SCM_OBJ_NULL);
if (scm_obj_null_p(args)) return SCM_OBJ_NULL;
args = scm_list(2, exp, args);
if (scm_obj_null_p(args)) return SCM_OBJ_NULL;
val = scm_vm_apply(scm_current_vm(), compile, args);
if (scm_obj_null_p(val)) return SCM_OBJ_NULL;
return scm_vector_ref(val, 0);
}
void
scm_assert_foreign_object_type (SCM type, SCM val)
{
/* FIXME: Add fast path for when type == struct vtable */
if (!SCM_IS_A_P (val, type))
scm_error (scm_arg_type_key, NULL, "Wrong type (expecting ~A): ~S",
scm_list_2 (scm_class_name (type), val), scm_list_1 (val));
}
static ScmObj
get_proc(const char *name, const char * const *module, size_t n)
{
ScmObj sym = SCM_OBJ_INIT, mod = SCM_OBJ_INIT, mod_name = SCM_OBJ_INIT;
ScmObj proc = SCM_OBJ_INIT, o = SCM_OBJ_INIT;
int r;
SCM_REFSTK_INIT_REG(&sym, &mod, &mod_name,
&proc, &o);
mod_name = SCM_NIL_OBJ;
for (size_t i = n; i > 0; i--) {
o = scm_make_symbol_from_cstr(module[i - 1], SCM_ENC_SRC);
if (scm_obj_null_p(o)) return SCM_OBJ_NULL;
mod_name = scm_cons(o, mod_name);
if (scm_obj_null_p(mod_name)) return SCM_OBJ_NULL;
}
sym = scm_make_symbol_from_cstr(name, SCM_ENC_SRC);
if (scm_obj_null_p(sym)) return SCM_OBJ_NULL;
r = scm_find_module(mod_name, SCM_CSETTER_L(mod));
if (r < 0) return SCM_OBJ_NULL;
if (scm_obj_null_p(mod)) {
scm_error("failed to find module", 1, mod_name);
return SCM_OBJ_NULL;
}
r = scm_refer_global_var_cstr(module, n, name, SCM_CSETTER_L(proc));
if (r < 0) return SCM_OBJ_NULL;
if (scm_obj_null_p(proc)) {
scm_error("unbund variable", 1, sym);
return SCM_OBJ_NULL;
}
return proc;
}
static ScmObj
scm_get_load_path(void)
{
ScmObj paths = SCM_OBJ_INIT;
int r;
SCM_REFSTK_INIT_REG(&paths);
r = scm_cached_global_var_ref(SCM_CACHED_GV_LOAD_PATH, SCM_CSETTER_L(paths));
if (r < 0) return SCM_OBJ_NULL;
if (scm_obj_null_p(paths)) {
scm_error("unbound variable: " SCM_LOAD_PATH_VARIABLE_NAME, 0);
return SCM_OBJ_NULL;
}
return paths;
}
static void scm_resolv_error (const char *subr, SCM bad_value)
{
#ifdef NETDB_INTERNAL
if (h_errno == NETDB_INTERNAL)
{
/* errno supposedly contains a useful value. */
scm_syserror (subr);
}
else
#endif
{
SCM key;
const char *errmsg;
switch (h_errno)
{
case HOST_NOT_FOUND:
key = scm_host_not_found_key;
errmsg = "Unknown host";
break;
case TRY_AGAIN:
key = scm_try_again_key;
errmsg = "Host name lookup failure";
break;
case NO_RECOVERY:
key = scm_no_recovery_key;
errmsg = "Unknown server error";
break;
case NO_DATA:
key = scm_no_data_key;
errmsg = "No address associated with name";
break;
default:
scm_misc_error (subr, "Unknown resolver error", SCM_EOL);
errmsg = NULL;
}
#ifdef HAVE_HSTRERROR
errmsg = (const char *) hstrerror (h_errno);
#endif
scm_error (key, subr, errmsg, SCM_BOOL_F, SCM_EOL);
}
}
static ScmObj
scm_get_load_suffixes(void)
{
ScmObj suffixes = SCM_OBJ_INIT;
int r;
SCM_REFSTK_INIT_REG(&suffixes);
r = scm_cached_global_var_ref(SCM_CACHED_GV_LOAD_SUFFIXES,
SCM_CSETTER_L(suffixes));
if (r < 0) return SCM_OBJ_NULL;
if (scm_obj_null_p(suffixes)) {
scm_error("unbound variable: " SCM_LOAD_SUFFIXES_VARIABLE_NAME, 0);
return SCM_OBJ_NULL;
}
return suffixes;
}
ScmObj
scm_record_new(scm_mem_type_t mtype, ScmObj type, size_t n, ScmObj slots)
{
ScmObj rec = SCM_OBJ_INIT;
scm_assert(scm_recordtype_p(type));
scm_assert(n == 0 || scm_pair_p(slots));
if (sizeof(ScmObj) > SIZE_MAX / n) {
scm_error("failed to make a record: too many fields", 1, type);
return SCM_OBJ_NULL;
}
rec = scm_alloc_mem(&SCM_RECORD_TYPE_INFO, sizeof(ScmObj) * n, mtype);
if (scm_obj_null_p(rec)) return SCM_OBJ_NULL;
if (scm_record_initialize(rec, type, n, slots) < 0)
return SCM_OBJ_NULL;
return rec;
}
SCM cl_easy_init ()
{
CURL *handle;
handle_post_t *hp;
handle = curl_easy_init ();
if (handle == NULL)
{
scm_error (SCM_BOOL_F,
"curl-easy-init",
"initialization failure",
SCM_BOOL_F,
SCM_BOOL_F);
}
hp = scm_malloc (sizeof (handle_post_t));
memset (hp, 0, sizeof (handle_post_t));
hp->handle = handle;
if (0)
{
fprintf (stderr, "Allocating <#handle %p>\n", hp);
fprintf (stderr, "\t handle %p\n", hp->handle);
fprintf (stderr, "\t httppost %p\n", hp->httppost);
fprintf (stderr, "\t httpheader %p\n", hp->httpheader);
fprintf (stderr, "\thttp200aliases %p\n", hp->http200aliases);
fprintf (stderr, "\t mail_rcpt %p\n", hp->mail_rcpt);
fprintf (stderr, "\t quote %p\n", hp->quote);
fprintf (stderr, "\t postquote %p\n", hp->postquote);
fprintf (stderr, "\t prequote %p\n", hp->prequote);
fprintf (stderr, "\t resolve %p\n", hp->resolve);
fprintf (stderr, "\t telnetoptions %p\n", hp->telnetoptions);
fflush (stderr);
}
return _scm_from_handle (hp);
}
SCM
scm_c_value_ref (SCM obj, size_t idx)
{
if (SCM_LIKELY (SCM_VALUESP (obj)))
{
SCM values = scm_struct_ref (obj, SCM_INUM0);
size_t i = idx;
while (SCM_LIKELY (scm_is_pair (values)))
{
if (i == 0)
return SCM_CAR (values);
values = SCM_CDR (values);
i--;
}
}
else if (idx == 0)
return obj;
scm_error (scm_out_of_range_key,
"scm_c_value_ref",
"Too few values in ~S to access index ~S",
scm_list_2 (obj, scm_from_unsigned_integer (idx)),
scm_list_1 (scm_from_unsigned_integer (idx)));
}
int
scm_record_initialize(ScmObj rec, ScmObj type, size_t n, ScmObj slots)
{
ScmObj l = SCM_OBJ_INIT;
scm_assert(scm_record_p(rec));
scm_assert(scm_recordtype_p(type));
scm_assert(n == 0 || scm_pair_p(slots));
SCM_RECORD_SET_TYPE(rec, type);
SCM_RECORD_SET_NR_SLOTS(rec, n);
l = slots;
for (size_t i = 0; i < n; i++) {
if (!scm_pair_p(l)) {
scm_error("failed to make a record: too few arguments", 1, type);
return -1;
}
SCM_RECORD_SET_SLOT(rec, i, scm_car(l));
l = scm_cdr(l);
}
return 0;
}
/* Raise a null pointer dereference error. */
static void
null_pointer_error (const char *func_name)
{
scm_error (sym_null_pointer_error, func_name,
"null pointer dereference", SCM_EOL, SCM_EOL);
}
SCM py2scm(PyObject *value)
{
if (value == Py_None) {
return SCM_UNSPECIFIED;
}
if (PyBool_Check(value)) {
int v = PyObject_IsTrue(value);
if (v == -1)
return NULL;
return scm_from_bool(v);
}
if (PyInt_Check(value)) {
long v = PyInt_AsLong(value);
if (PyErr_Occurred())
return NULL;
return scm_from_long(v);
}
if (PyFloat_Check(value)) {
double v = PyFloat_AsDouble(value);
if (PyErr_Occurred())
return NULL;
return scm_from_double(v);
}
if (PyString_Check(value)) {
const char *s = PyString_AsString(value);
if (s == NULL)
return NULL;
return scm_from_utf8_stringn(s, PyString_Size(value));
}
if (PyUnicode_Check(value)) {
scm_dynwind_begin(0);
PyObject *utf8_str = PyUnicode_AsUTF8String(value);
if (utf8_str == NULL) {
scm_dynwind_end();
return NULL;
}
scm_dynwind_py_decref(utf8_str);
const char *s = PyString_AsString(utf8_str);
if (s == NULL) {
scm_dynwind_end();
return NULL;
}
SCM result = scm_from_utf8_stringn(s, PyString_Size(utf8_str));
scm_dynwind_end();
return result;
}
if (PySequence_Check(value)) {
unsigned int i = PySequence_Size(value);
SCM r = SCM_EOL;
while (i-- > 0) {
PyObject *item = PySequence_GetItem(value, i);
r = scm_cons(py2scm(item), r);
}
return r;
}
if (PyObject_TypeCheck(value, &ProcedureType))
return ((Procedure *)value)->proc;
if (PyCallable_Check(value)) {
SCM gsubr = scm_c_make_gsubr(
"<Python function>", 0, 0, 1, &call_callable);
Py_INCREF(value);
SCM ptr = scm_from_pointer(value, (void (*)(void *))Py_DecRef);
gsubr_alist = scm_acons(gsubr, ptr, gsubr_alist);
return gsubr;
}
char buf[BUFSIZ];
snprintf(buf, BUFSIZ, "Python type \"%.50s\" doesn't have a "
"corresponding Guile type",
value->ob_type->tp_name);
scm_error(scm_from_utf8_symbol("misc-error"), NULL, buf,
SCM_EOL, SCM_EOL);
/* does not return */
fprintf(stderr, "*** scm_error shouldn't have returned ***\n");
return SCM_UNSPECIFIED;
}
SCM DLL_PUBLIC
cl_easy_setopt (SCM handle, SCM option, SCM param, SCM big)
{
handle_post_t *c_handle;
CURLoption c_option;
CURLcode code = CURLE_UNSUPPORTED_PROTOCOL;
SCM_ASSERT (_scm_is_handle (handle), handle, SCM_ARG1, "curl-easy-setopt");
SCM_ASSERT (scm_is_integer (option), option, SCM_ARG2, "curl-easy-setopt");
c_handle = _scm_to_handle (handle);
c_option = (CURLoption) scm_to_int (option);
if (c_option == CURLOPT_POSTFIELDS)
{
if (_scm_can_convert_to_byte_data (param))
{
size_t len;
uint8_t *m = _scm_convert_to_byte_data (param, &len);
free (c_handle->postfields);
c_handle->postfields = m;
curl_easy_setopt (c_handle->handle, CURLOPT_POSTFIELDSIZE, len);
c_handle->postfieldsize = len;
code = curl_easy_setopt (c_handle->handle, CURLOPT_POSTFIELDS, (char *) m);
}
else
scm_error (SCM_BOOL_F, "cl-easy-setopt", "CURLOPT_POSTFIELDS requires 8-bit string or bytevector data",
SCM_BOOL_F, SCM_BOOL_F);
}
else if (c_option == CURLOPT_HTTPHEADER)
{
if (_scm_can_convert_to_slist (param))
{
/* slists require special handling to free them properly, so
they are stored with the Curl handle. */
struct curl_slist *sl = _scm_convert_to_slist (param);
if (c_handle->httpheader)
curl_slist_free_all (c_handle->httpheader);
c_handle->httpheader = sl;
code = curl_easy_setopt (c_handle->handle, CURLOPT_HTTPHEADER, sl);
}
else
scm_error (SCM_BOOL_F, "cl-easy-setopt", "CURLOPT_HTTPHEADER requires a list of strings",
SCM_BOOL_F, SCM_BOOL_F);
}
else if (scm_is_integer (param))
{
if (scm_is_true (big))
code = curl_easy_setopt (c_handle->handle, c_option, scm_to_int64 (param));
else
code = curl_easy_setopt (c_handle->handle, c_option, scm_to_long (param));
}
else if (scm_is_string (param))
{
/* Strings are copied by curl, so they can be freed here. */
char *str;
str = scm_to_locale_string (param);
code = curl_easy_setopt (c_handle->handle, c_option, str);
free (str);
}
else if (_scm_can_convert_to_slist (param))
{
/* slists require special handling to free them properly, so
they are stored with the Curl handle. */
struct curl_slist *sl = _scm_convert_to_slist (param);
int ok = 1;
if (c_option == CURLOPT_HTTP200ALIASES)
{
if (c_handle->http200aliases)
curl_slist_free_all (c_handle->http200aliases);
c_handle->http200aliases = sl;
}
else if (c_option == CURLOPT_MAIL_RCPT)
{
if (c_handle->mail_rcpt)
curl_slist_free_all (c_handle->mail_rcpt);
c_handle->mail_rcpt = sl;
}
else if (c_option == CURLOPT_QUOTE)
{
if (c_handle->quote)
curl_slist_free_all (c_handle->quote);
c_handle->quote = sl;
}
else if (c_option == CURLOPT_POSTQUOTE)
{
if (c_handle->postquote)
curl_slist_free_all (c_handle->postquote);
c_handle->postquote = sl;
}
else if (c_option == CURLOPT_PREQUOTE)
{
if (c_handle->prequote)
curl_slist_free_all (c_handle->prequote);
c_handle->prequote = sl;
}
else if (c_option == CURLOPT_RESOLVE)
{
if (c_handle->resolve)
curl_slist_free_all (c_handle->resolve);
c_handle->resolve = sl;
}
else if (c_option == CURLOPT_TELNETOPTIONS)
{
if (c_handle->telnetoptions)
curl_slist_free_all (c_handle->telnetoptions);
c_handle->telnetoptions = sl;
}
else
{
// Bad slist option
ok = 0;
}
if (ok)
code = curl_easy_setopt (c_handle->handle, c_option, sl);
}
else if (_scm_can_convert_to_httppost (param))
{
if (c_option == CURLOPT_HTTPPOST)
{
struct curl_httppost *p;
p = _scm_convert_to_httppost (param);
free (c_handle->httppost);
c_handle->httppost = p;
code = curl_easy_setopt (c_handle, CURLOPT_HTTPPOST, p);
}
}
else if (scm_is_true (scm_input_port_p (param)))
{
if (c_option == CURLOPT_READDATA)
{
curl_easy_setopt (c_handle->handle, CURLOPT_READFUNCTION, read_callback);
code = curl_easy_setopt (c_handle->handle, CURLOPT_READDATA, SCM2PTR (param));
}
}
else
scm_error (SCM_BOOL_F,
"curl-easy-setopt",
"unimplemented option type",
SCM_BOOL_F,
SCM_BOOL_F);
if (code != CURLE_OK)
scm_error (SCM_BOOL_F,
"curl-easy-setopt",
"bad handle",
SCM_BOOL_F,
SCM_BOOL_F);
return SCM_UNSPECIFIED;
}
static void error_used_before_defined (void)
{
scm_error (scm_unbound_variable_key, NULL,
"Variable used before given a value", SCM_EOL, SCM_BOOL_F);
}
static SCM unbound_variable (const char *func, SCM sym)
{
scm_error (scm_from_latin1_symbol ("unbound-variable"), func,
"Unbound variable: ~S", scm_list_1 (sym), SCM_BOOL_F);
}