void dfsch_load_source(dfsch_object_t* env,
char* fname,
int toplevel,
char* source){
dfsch_parser_ctx_t *parser = dfsch_parser_create();
load_thread_info_t* lti = get_load_ti();
load_operation_t this_op;
dfsch_package_t* saved_package = dfsch_get_current_package();
dfsch_parser_callback(parser, load_source_callback, env);
dfsch_parser_set_source(parser, dfsch_make_string_cstr(fname));
dfsch_parser_eval_env(parser, env);
DFSCH_UNWIND {
this_op.fname = fname;
this_op.toplevel = toplevel;
this_op.next = lti->operation;
lti->operation = &this_op;
dfsch_parser_feed(parser, source);
} DFSCH_PROTECT {
lti->operation = this_op.next;
dfsch_set_current_package(saved_package);
} DFSCH_PROTECT_END;
if (dfsch_parser_get_level(parser)!=0){
dfsch_error("Syntax error at end of input",
dfsch_make_string_cstr(fname));
}
}
dfsch_object_t* dfsch_open_file_port(char* filename, char* mode){
FILE* file;
if (mode[0] != 'r' && mode[0] != 'w' && mode[0] != 'a'){ /// XXX
dfsch_error("Invalid file port mode",
dfsch_make_string_cstr(mode));
}
if (mode[1] != 0){
if (mode[1] != '+' && mode[1] != 'b'){
dfsch_error("Invalid file port mode",
dfsch_make_string_cstr(mode));
}
if (mode[2] != 0){
if ((mode[2] != '+' && mode[2] != 'b')
|| (mode[2] == mode[1])
|| (mode[3] != 0)){
dfsch_error("Invalid file port mode",
dfsch_make_string_cstr(mode));
}
}
}
file = fopen(filename, mode);
if (!file){
dfsch_operating_system_error("fopen");
}
return dfsch_make_file_port(file, 1, filename);
}
dfsch_object_t* dfsch_read_scm_stream(FILE* f,
char* name,
dfsch_object_t* eval_env){
char buf[8193];
read_ctx_t ictx;
ssize_t r;
int err=0;
int l=0;
ictx.head = NULL;
dfsch_parser_ctx_t *parser = dfsch_parser_create();
dfsch_parser_callback(parser, read_callback, &ictx);
dfsch_parser_set_source(parser, dfsch_make_string_cstr(name));
dfsch_parser_eval_env(parser, eval_env);
while (fgets(buf, 8192, f)){
dfsch_parser_feed(parser,buf);
}
if (dfsch_parser_get_level(parser)!=0){
dfsch_error("Syntax error at end of input",
dfsch_make_string_cstr(name));
}
return ictx.head;
}
static void rrd_error(char* fun){
dfsch_object_t* c = dfsch_make_condition(RRD_ERROR_TYPE);
dfsch_condition_put_field_cstr(c, "message",
dfsch_make_string_cstr(rrd_get_error()));
dfsch_condition_put_field_cstr(c, "function",
dfsch_make_string_cstr(fun));
pthread_mutex_unlock(&rrd_lock);
dfsch_signal(c);
}
void dfsch_load_so(dfsch_object_t* ctx,
char* so_name,
char* sym_name,
int as_toplevel){
#if defined(__unix__)
void *handle;
dfsch_object_t* (*entry)(dfsch_object_t*, int);
char* err;
err = dlerror();
handle = dlopen(so_name, RTLD_NOW);
err = dlerror();
if (err){
dfsch_error("dlopen() failed", dfsch_make_string_cstr(err));
}
entry = dlsym(handle, sym_name);
err = dlerror();
if (err){
dfsch_error("dlsym() failed", dfsch_make_string_cstr(err));
}
entry(ctx, as_toplevel);
#elif defined(__WIN32__)
HMODULE hModule;
dfsch_object_t* (*entry)(dfsch_object_t*, int);
hModule = LoadLibraryEx(so_name, NULL, 0);
if (!hModule){
/* XXX: This is ugly hack that can be probably solved slightly
* better by SetDllDirectory(). But SetDllDirectory is not
* supported before XP SP1 and also is not present in mingw's
* import library for kernel32.dll.
*/
hModule = LoadLibraryEx(so_name, NULL, LOAD_WITH_ALTERED_SEARCH_PATH);
if (!hModule){
dfsch_error("LoadLibraryEx() failed", NULL);
}
}
entry = GetProcAddress(hModule, sym_name);
if (!entry){
dfsch_error("GetProcAddress() failed", NULL);
}
entry(ctx, as_toplevel);
#else
dfsch_error("Get real operating system!", NULL);
#endif
}
static dfsch_object_t* get_row_as_vector(sqlite3_stmt* stmt){
size_t i;
int n_columns = sqlite3_column_count(stmt);
dfsch_object_t* vec = dfsch_make_vector(n_columns, NULL);
for (i = 0; i < n_columns; i++){
dfsch_object_t* obj;
switch (sqlite3_column_type(stmt, i)){
case SQLITE_INTEGER:
obj = dfsch_make_number_from_int64(sqlite3_column_int64(stmt, i));
break;
case SQLITE_FLOAT:
obj = dfsch_make_number_from_double(sqlite3_column_double(stmt, i));
break;
case SQLITE3_TEXT:
obj = dfsch_make_string_cstr(sqlite3_column_text(stmt, i));
break;
case SQLITE_NULL:
obj = NULL;
break;
default:
{
char* buf = sqlite3_column_blob(stmt, i);
obj = dfsch_make_byte_vector(buf, sqlite3_column_bytes(stmt, i));
}
}
dfsch_vector_set(vec, i, obj);
}
return vec;
}
dfsch_object_t* dfsch_read_scm_fd(int f, char* name, dfsch_object_t* eval_env){
char buf[8193];
read_ctx_t ictx;
ssize_t r;
int err=0;
ictx.head = NULL;
dfsch_parser_ctx_t *parser = dfsch_parser_create();
dfsch_parser_callback(parser, read_callback, &ictx);
dfsch_parser_eval_env(parser, eval_env);
while (!err && (r = read(f, buf, 8192))>0){
buf[r]=0;
err = dfsch_parser_feed(parser,buf);
}
if (r<0){
dfsch_operating_system_error("read");
}
if (dfsch_parser_get_level(parser)!=0){
dfsch_error("Syntax error at end of input",
dfsch_make_string_cstr(name));
}
return ictx.head;
}
static int command_proc(command_context_t* ctx,
Tcl_Interp* interp,
int argc, char** argv){
dfsch_object_t *head;
dfsch_object_t *cur;
dfsch_object_t *res;
int i;
int ret;
head = cur = dfsch_multicons(argc-1);
for(i = 1; i < argc; ++i){
DFSCH_FAST_CAR(cur) = dfsch_make_string_cstr(argv[i]);
cur = DFSCH_FAST_CDR(cur);
}
DFSCH_SCATCH_BEGIN {
res = dfsch_apply(ctx->proc, head);
Tcl_SetResult(interp, dfsch_object_2_string(res, -1, 0),
TCL_VOLATILE);
ret = TCL_OK;
} DFSCH_SCATCH {
ret = TCL_ERROR;
} DFSCH_SCATCH_END;
return ret;
}
DFSCH_DEFINE_PRIMITIVE(inet_xml_unescape, NULL) {
char* str;
DFSCH_STRING_ARG(args, str);
DFSCH_ARG_END(args);
return dfsch_make_string_cstr(dfsch_inet_xml_unescape(str));
}
static dfsch_object_t* convert_info(rrd_info_t * data){
dfsch_object_t* res = dfsch_make_idhash();
while (data) {
dfsch_object_t* val = NULL;
switch (data->type) {
case RD_I_VAL:
val = isnan(data->value.u_val)
? NULL
: dfsch_make_number_from_double(data->value.u_val);
break;
case RD_I_CNT:
val = dfsch_make_number_from_uint64(data->value.u_cnt);
break;
case RD_I_INT:
val = dfsch_make_number_from_long(data->value.u_int);
break;
case RD_I_STR:
val = dfsch_make_string_cstr(data->value.u_str);
break;
case RD_I_BLO:
val = dfsch_make_byte_vector((char *) data->value.u_blo.ptr,
data->value.u_blo.size);
break;
}
dfsch_idhash_set((dfsch_hash_t*)res, dfsch_make_keyword(data->key), val);
data = data->next;
}
return res;
}
DFSCH_DEFINE_PRIMITIVE(http_split_query, NULL) {
char* pos;
char* uri;
DFSCH_STRING_ARG(args, uri);
DFSCH_ARG_END(args);
pos = strchr(uri, '?');
if (!pos) {
return dfsch_list(1,
dfsch_make_string_cstr(uri));
} else {
return dfsch_list(2,
dfsch_make_string_buf(uri, pos-uri),
dfsch_make_string_cstr(pos+1));
}
}
static void regex_compile(regex_t* regex, char* expression, int flags){
int err;
err = regcomp(regex, expression, flags);
if (err != 0){
dfsch_error("regex:error",
dfsch_make_string_cstr(regex_get_error(err, regex)));
}
}
static dfsch_object_t* get_row_as_vector(int n_columns, char**values){
size_t i;
dfsch_object_t* vec = dfsch_make_vector(n_columns, NULL);
for (i = 0; i < n_columns; i++){
dfsch_vector_set(vec, i, dfsch_make_string_cstr(values[i]));
}
return vec;
}
void dfsch_provide(dfsch_object_t* env, char* name){
dfsch_object_t* modules = dfsch_env_get_cstr(env, "*load-modules*");
if (modules == DFSCH_INVALID_OBJECT){
modules = NULL;
}
if (search_modules(modules, name)){
dfsch_error("Module already provided", dfsch_make_string_cstr(name));
}
/*
* there should be define - module list is related to environment, but
* this distinction is in most cases totally irrelevant, because modules
* are mostly loaded into toplevel environment.
*/
dfsch_define_cstr(env, "*load-modules*",
dfsch_cons(dfsch_make_string_cstr(name),
modules));
}
dfsch_object_t* dfsch_tcl_split_list(char* list){
int argc;
char** argv;
int i;
dfsch_object_t* vec;
if (Tcl_SplitList(NULL, list, &argc, &argv) == TCL_ERROR){
dfsch_error("Syntax error", dfsch_make_string_cstr(list));
}
vec = dfsch_make_vector(argc, NULL);
for (i = 0; i < argc; i++){
dfsch_vector_set(vec, i, dfsch_make_string_cstr(argv[i]));
}
Tcl_Free(argv); /* both array and it's strings are in one chunk of heap */
return vec;
}
dfsch_object_t* dfsch_process_close_port(dfsch_object_t* port){
process_port_t* p = DFSCH_ASSERT_INSTANCE(port, DFSCH_PROCESS_PORT_TYPE);
int r;
if (p->open){
p->open = 0;
r = pclose(p->file);
if (r == -1){
dfsch_error("Error while closing process port",
dfsch_make_string_cstr(strerror(errno)));
}
return DFSCH_MAKE_FIXNUM(r);
}
return NULL;
}
DFSCH_DEFINE_PRIMITIVE(iso_format_time, NULL){
char t = ' ';
dfsch_object_t* use_t;
dfsch_object_t* time;
struct tm* tm;
DFSCH_OBJECT_ARG(args, time);
DFSCH_OBJECT_ARG_OPT(args, use_t, NULL);
DFSCH_ARG_END(args);
if (use_t){
t = 'T';
}
tm = dfsch_decoded_time_get_tm(time);
return dfsch_make_string_cstr(saprintf("%04d-%02d-%02d%c%02d:%02d:%02d",
tm->tm_year+1900, tm->tm_mon+1,
tm->tm_mday, t,
tm->tm_hour, tm->tm_min, tm->tm_sec));
}
static dfsch_object_t* spawn_port(dfsch_object_t* klass,
char* cmd_line){
process_port_t* p = dfsch_make_object(klass);
p->cmd_line = cmd_line;
if (klass == DFSCH_PROCESS_INPUT_PORT_TYPE){
p->file = popen(cmd_line, "r");
} else {
p->file = popen(cmd_line, "w");
}
if (!p->file){
dfsch_error("Cannot spawn process",
dfsch_make_string_cstr(strerror(errno)));
}
GC_REGISTER_FINALIZER(p, (GC_finalization_proc)port_finalizer,
NULL, NULL, NULL);
p->open = 1;
return (dfsch_object_t*)p;
}
static void errno_error(char* name, dfsch_object_t* object, int e){
dfsch_error(name, dfsch_list(3,
object,
dfsch_make_number_from_long(e),
dfsch_make_string_cstr(strerror(e))));
}
void dfsch_tcl_error(Tcl_Interp* interp){
dfsch_error("Tcl error",
dfsch_make_string_cstr(Tcl_GetStringResult(interp)));
}
void dfsch_load_extend_path(dfsch_object_t* ctx, char* dir){
dfsch_load_add_module_source(ctx, dfsch_make_string_cstr(dir));
}
void dfsch_load(dfsch_object_t* env, char* name,
dfsch_object_t* path_list,
int as_toplevel){
struct stat st;
dfsch_object_t* path;
char *pathpart;
char *fname;
str_list_t* l;
int i;
for (i = 0; i < sizeof(builtin_modules) / sizeof(builtin_module_t); i++){
if (strcmp(builtin_modules[i].name, name) == 0){
builtin_modules[i].register_proc(env);
return;
}
}
if (path_list){
path = path_list;
} else {
path = dfsch_env_get_cstr(env, "*load-path*");
if (path == DFSCH_INVALID_OBJECT){
path = NULL;
}
}
while (DFSCH_PAIR_P(path)){
dfsch_object_t* pp = DFSCH_FAST_CAR(path);
if (!dfsch_string_p(pp)){
if (dfsch_apply(pp, dfsch_list(2,
env,
dfsch_make_string_cstr(name)))){
return;
}
path = DFSCH_FAST_CDR(path);
continue;
}
l = sl_create();
sl_append(l, dfsch_string_to_cstr(DFSCH_FAST_CAR(path)));
sl_append(l, "/");
sl_append(l, name);
pathpart = sl_value(l);
if (stat(pathpart, &st) == 0){
if (S_ISREG(st.st_mode) || S_ISLNK(st.st_mode)){
for (i = 0; i < sizeof(loaders) / sizeof(module_loader_t); i++){
if (strcmp(pathpart + strlen(pathpart) - strlen(loaders[i].path_ext),
loaders[i].path_ext) == 0){
loaders[i].load(pathpart, env, as_toplevel);
return;
}
}
dfsch_load_scm(env, pathpart, 0);
return;
}
}
for (i = 0; i < sizeof(loaders) / sizeof(module_loader_t); i++){
fname = stracat(pathpart, loaders[i].path_ext);
if (stat(fname, &st) == 0 && (S_ISREG(st.st_mode) ||
S_ISLNK(st.st_mode))){
loaders[i].load(fname, env, as_toplevel);
return;
}
}
path = dfsch_cdr(path);
}
dfsch_error("Module not found", dfsch_make_string_cstr(name));
}