static void init()
{
object_new_count = 0;
object_free_count = 0;
object_true = symbol_intern("#t");
symbol_parent_env = symbol_intern("__parent_env__");
symbol_quote = symbol_intern("quote");
builtin_core_init(&global_env);
builtin_math_init(&global_env);
}
static void
pf_the_page (PFunArgs)
{
char *varname = mhtml_evaluate_string (get_positional_arg (vars, 0));
PAGE *the_page = parser_top_page ();
if (empty_string_p (varname))
{
PAGE *contents = page_copy_page (the_page);
bprintf_insert (page, start, "%s", contents->buffer);
*newstart += contents->bindex;
page_free_page (contents);
}
else
{
Symbol *sym = symbol_remove (varname);
Datablock *block;
symbol_free (sym);
sym = symbol_intern (varname);
block = datablock_create (the_page->buffer, the_page->bindex);
sym->type = symtype_BINARY;
sym->values = (char **)block;
}
xfree (varname);
}
void
slang_open(obj_t *env)
{
static bool_t inited = 0;
if (inited)
return;
else
inited = 1;
obj_t *binding;
langdef_t *iter;
gc_set_enabled(0);
for (iter = specforms; iter->name; ++iter) {
environ_bind(NULL, env, symbol_intern(NULL, iter->name),
specform_wrap(NULL, iter->call));
}
symbol_quasiquote = symbol_intern(NULL, "quasiquote");
symbol_unquote = symbol_intern(NULL, "unquote");
symbol_unquote_splicing = symbol_intern(NULL, "unquote-splicing");
gc_set_enabled(1);
}
void telephony_init()
{
telephony_vt = (vtable*)send(object_vt, s_delegated); // TODO - inherit from VillageBus ?
send(telephony_vt, s_addMethod, s_print, telephony_print);
send(telephony_vt, s_addMethod, s_villagebus_evaluate, telephony_evaluate);
_Telephony = send(telephony_vt, s_allocate, 0);
// register local symbols
s_telephony_sip = (symbol*)symbol_intern(0, _Telephony, L"sip");
s_telephony_callme = (symbol*)symbol_intern(0, _Telephony, L"callme");
send(telephony_vt, s_addMethod, s_telephony_sip, telephony_sip_asterisk);
send(telephony_vt, s_addMethod, s_telephony_callme, telephony_callme);
// global module instance vars
Telephony = (telephony*)send(_Telephony->_vt[-1], s_allocate, sizeof(telephony));
// register module with VillageBus
s_telephony = (symbol*)symbol_intern(0, 0, L"telephony");
fexp* module = (fexp*)send(Fexp, s_new, s_telephony, Telephony);
VillageBus->modules = (fexp*)send(VillageBus->modules, s_fexp_cons, module);
}
void builtin_math_init(pobject *env)
{
cons_assoc_set(env, symbol_intern("*pi*"), gc_add(number_new(M_PI)), 1);
cons_assoc_set(env, symbol_intern("+"), gc_add(cfunc_new(plus)), 1);
cons_assoc_set(env, symbol_intern("-"), gc_add(cfunc_new(minus)), 1);
cons_assoc_set(env, symbol_intern("*"), gc_add(cfunc_new(mult)), 1);
cons_assoc_set(env, symbol_intern("/"), gc_add(cfunc_new(div)), 1);
cons_assoc_set(env, symbol_intern("mod"), gc_add(cfunc_new(mod)), 1);
}
void db_init()
{
db_vt = (vtable*)send(object_vt, s_delegated); // TODO - inherit from VillageBus ?
send(db_vt, s_addMethod, s_print, db_print);
send(db_vt, s_addMethod, s_villagebus_evaluate, db_evaluate);
_DB = send(db_vt, s_allocate, 0);
// register local symbols
s_db_connect = symbol_intern(0, _DB, L"connect");
s_db_close = symbol_intern(0, _DB, L"close");
s_db_keys = (symbol*)symbol_intern(0, _DB, L"keys"); // TODO - symbol_intern should return symbol*
s_db_get = symbol_intern(0, _DB, L"get");
s_db_lrange = symbol_intern(0, _DB, L"lrange");
s_db_getset = symbol_intern(0, _DB, L"set");
s_db_lpush = symbol_intern(0, _DB, L"lpush");
s_db_incr = symbol_intern(0, _DB, L"incr");
s_db_set = symbol_intern(0, _DB, L"_set"); // TODO - don't alias getset to set
s_db_sadd = symbol_intern(0, _DB, L"sadd");
s_db_del = symbol_intern(0, _DB, L"del");
send(db_vt, s_addMethod, s_db_connect, db_connect);
send(db_vt, s_addMethod, s_db_close, db_close);
send(db_vt, s_addMethod, s_db_keys, db_keys);
send(db_vt, s_addMethod, s_db_get, db_get);
send(db_vt, s_addMethod, s_db_lrange, db_lrange);
send(db_vt, s_addMethod, s_db_getset, db_getset);
send(db_vt, s_addMethod, s_db_lpush, db_lpush);
send(db_vt, s_addMethod, s_db_incr, db_incr);
send(db_vt, s_addMethod, s_db_set, db_set);
send(db_vt, s_addMethod, s_db_sadd, db_sadd);
send(db_vt, s_addMethod, s_db_del, db_del);
// global module instance vars
DB = (db*)send(_DB->_vt[-1], s_allocate, sizeof(db));
DB->handle = NULL;
DB->delimiter = (string*)send(String, s_new, L":", 1); // delimiter used for composing redis key names
// register module with VillageBus - TODO lose vb->modules & register directly in vtable perhaps?
s_db = symbol_intern(0, 0, L"db");
fexp* module = (fexp*)send(Fexp, s_new, s_db, DB);
VillageBus->modules = (fexp*)send(VillageBus->modules, s_fexp_cons, module);
}
/* Read the input data from all of the available sources. This means
the environment variables PATH_INFO and QUERY_STRING, the contents
of standard input, if there is any, and the arguments passed into
the CGI program. Nothing is returned, the symbols and values are
simply interned. The program arguments are returned in the item
PROGRAM-ARGUMENTS. */
void
forms_input_data (int argc, char *argv[])
{
register int i;
int content_length = 0;
char *env_item;
char *data_string = (char *)NULL;
int data_string_size = 0, data_string_index = 0;
Symbol *symbol;
Package *package;
posted_variables = symbol_get_package ("POSTED");
/* First, get the program arguments if there are any. */
if (argc != 1)
{
symbol = symbol_intern ("PROGRAM-ARGUMENTS");
symbol->values = (char **)xmalloc (argc * sizeof (char *));
symbol->values_slots = argc;
symbol->values_index = 0;
for (i = 1; i < argc; i++)
symbol->values[symbol->values_index++] = strdup (argv[i]);
symbol->values[symbol->values_index] = (char *)NULL;
}
/* Now get all of the environment variables. */
package = symbol_get_package ("ENV");
for (i = 0; environ != (char **)NULL && environ[i] != (char *)NULL; i++)
{
char *name, *value;
name = strdup (environ[i]);
value = strchr (name, '=');
if (value)
{
*value = '\0';
value++;
value = strdup (value);
}
symbol = symbol_intern_in_package (package, name);
if (value)
{
symbol->values = (char **)xmalloc
((symbol->values_slots = 2) * sizeof (char *));
symbol->values[0] = value;
symbol->values[1] = (char *)NULL;
symbol->values_index = 1;
}
free (name);
}
/* If there is any input available from standard input, then read it
now. */
if (((env_item = getenv ("CONTENT_LENGTH")) != (char *)NULL) &&
((content_length = atoi (env_item)) != 0))
{
int offset = 0;
data_string = (char *)xmalloc (1 + (data_string_size = content_length));
while (content_length != 0)
{
int amount_read =
read (fileno (stdin), data_string + offset, content_length);
if (amount_read == -1)
abort ();
content_length -= amount_read;
offset += amount_read;
}
data_string[offset] = '\0';
data_string_index = offset;
}
/* If any input is coming from QUERY_STRING or PATH_INFO, get it now. */
{
char *names[3] = { "QUERY_STRING", "PATH_INFO", (char *)NULL };
for (i = 0; names[i]; i++)
{
if (((env_item = getenv (names[i])) != (char *)NULL) &&
(*env_item != '\0'))
{
int max_len;
if ((strcmp (names[i], "PATH_INFO") == 0) &&
*env_item == '/')
env_item++;
max_len = data_string_index + strlen (env_item) + 3;
if (max_len > data_string_size)
data_string = (char *)xrealloc
(data_string, (data_string_size = max_len));
if (data_string_index != 0)
data_string[data_string_index++] = '&';
strcpy (data_string + data_string_index, env_item);
data_string_index += strlen (env_item);
data_string[data_string_index] = '\0';
}
}
}
/* DATA_STRING may contain any number of name/value pairs, including
none. If there are any, intern them now. */
if (data_string)
{
package = posted_variables;
forms_parse_data_string (data_string, package);
/* Copy the parsed symbols into the default package. */
{
Package *default_pack =
symbol_get_package_hash (DEFAULT_PACKAGE_NAME, 577);
Symbol **symbols = symbol_package_symbols ("POSTED");
if (symbols != (Symbol **)NULL)
{
for (i = 0; symbols[i] != (Symbol *)NULL; i++)
symbol_copy (symbols[i], default_pack);
}
}
free (data_string);
}
}
void
forms_set_tag_value_in_package (Package *package, char *tag, char *value)
{
register int i, j;
char *name = tag;
int value_index = 0;
int arrayify = 0;
Symbol *symbol;
/* Does this variable ref contain an array indicator? */
for (i = 0; tag[i] != '\0'; i++)
if (tag[i] == '[')
{
/* Find out if this is a real array reference. */
#if MUST_BE_DIGITS
for (j = i + 1; isdigit (tag[j]); j++);
if (tag[j] == ']')
{
if (j == i + 1)
arrayify = 1;
else
value_index = atoi (tag + i + 1);
name = strdup (tag);
name[i] = '\0';
}
#else /* !MUST_BE_DIGITS */
int all_digits = 1;
for (j = i + 1; tag[j] != '\0' && tag[j] != ']'; j++)
if (!isdigit (tag[j]))
all_digits = 0;
if (tag[j] == ']')
{
if (j == i + 1)
arrayify = 1;
else
{
if (all_digits)
value_index = atoi (tag + i + 1);
else
{
char *tv, *nv;
j--;
tv = (char *)xmalloc (1 + (j - i));
strncpy (tv, tag + i + 1, j - i);
tv[j - i] = '\0';
nv = forms_get_tag_value (tv);
if (nv)
value_index = atoi (nv);
free (tv);
}
}
name = strdup (tag);
name[i] = '\0';
}
#endif /* !MUST_BE_DIGITS */
break;
}
/* Get the symbol for this name. */
if (package == (Package *)NULL)
symbol = symbol_intern (name);
else
symbol = symbol_intern_in_package (package, name);
/* If this symbol is readonly, then we cannot manipulate it. */
if (!symbol_get_flag (symbol, sym_READONLY))
{
/* If this symbol is not of type STRING, then delete it. */
if (symbol->type != symtype_STRING)
{
Symbol *r = symbol_remove_in_package (symbol->package, symbol->name);
symbol_free (r);
if (package == (Package *)NULL)
symbol = symbol_intern (name);
else
symbol = symbol_intern_in_package (package, name);
}
/* If the value is empty, then add it as the empty string. */
if (value == (char *)NULL)
value = "";
if (symbol->notifier)
*(symbol->notifier) = 1;
/* If the index to store at is larger than the number of items in the
list, then make a bunch of blank items to fill in the space. */
if (value_index >= symbol->values_index)
{
symbol->values = (char **)xrealloc
(symbol->values,
(symbol->values_slots = 2 + value_index) * sizeof (char *));
while (symbol->values_index <= value_index)
symbol->values[symbol->values_index++] = strdup ("");
symbol->values[symbol->values_index] = (char *)NULL;
}
/* Store the value. If we are supposed to arrayify this variable,
do it now. */
if (arrayify)
{
char **values = (char **)NULL;
int values_index = 0;
int values_slots = 0;
int start = 0;
while (value[start])
{
/* Skip all whitespace between items. */
for (i = start; whitespace (value[i]); i++);
start = i;
if (value[i] == '\0')
break;
for (; value[i] != '\0' && value[i] != '\n'; i++);
if (values_index + 2 > values_slots)
values = (char **)xrealloc
(values, (values_slots += 10) * sizeof (char *));
values[values_index] = (char *)xmalloc (1 + (i - start));
strncpy (values[values_index], value + start, i - start);
values[values_index][i - start] = '\0';
values_index++;
values[values_index] = (char *)NULL;
start = i;
}
free_array (symbol->values);
symbol->values = values;
symbol->values_index = values_index;
symbol->values_slots = values_slots;
}
else
{
if (value_index > -1)
{
free (symbol->values[value_index]);
symbol->values[value_index] = strdup (value);
}
}
symbol_set_modified (symbol);
}
if (name != tag)
free (name);
}
void builtin_core_init(pobject *env)
{
cons_assoc_set(env, symbol_intern("nil"), NIL, 1);
cons_assoc_set(env, symbol_intern("#t"), object_true, 1);
cons_assoc_set(env, symbol_intern("#f"), NIL, 1);
cons_assoc_set(env, symbol_intern("quote"), gc_add(cfunc_new(quote)), 1);
cons_assoc_set(env, symbol_intern("print"), gc_add(cfunc_new(builtin_print)), 1);
cons_assoc_set(env, symbol_intern("println"), gc_add(cfunc_new(builtin_println)), 1);
cons_assoc_set(env, symbol_intern("begin"), gc_add(cfunc_new(begin)), 1);
cons_assoc_set(env, symbol_intern("cond"), gc_add(cfunc_new(cond)), 1);
cons_assoc_set(env, symbol_intern("set!"), gc_add(cfunc_new(set)), 1);
cons_assoc_set(env, symbol_intern("define"), gc_add(cfunc_new(define)), 1);
cons_assoc_set(env, symbol_intern("defmacro"), gc_add(cfunc_new(defmacro)), 1);
cons_assoc_set(env, symbol_intern("macro-expand"), gc_add(cfunc_new(builtin_macro_expand)), 1);
cons_assoc_set(env, symbol_intern("lambda"), gc_add(cfunc_new(lambda)), 1);
cons_assoc_set(env, symbol_intern("macro"), gc_add(cfunc_new(macro)), 1);
cons_assoc_set(env, symbol_intern("apply"), gc_add(cfunc_new(apply)), 1);
cons_assoc_set(env, symbol_intern("car"), gc_add(cfunc_new(car)), 1);
cons_assoc_set(env, symbol_intern("cdr"), gc_add(cfunc_new(cdr)), 1);
cons_assoc_set(env, symbol_intern("cons"), gc_add(cfunc_new(cons)), 1);
cons_assoc_set(env, symbol_intern("collect"), gc_add(cfunc_new(collect)), 1);
cons_assoc_set(env, symbol_intern("="), gc_add(cfunc_new(equal)), 1);
cons_assoc_set(env, symbol_intern(">"), gc_add(cfunc_new(gt)), 1);
}
static void
parse_program_args (int argc, char *argv[])
{
int arg_index = 1;
char *filename = (char *)NULL;
Symbol *program_args = symbol_intern ("mhtml::program-arguments");
progname = argv[0];
pagefunc_set_variable ("mhc::mhc-executatble", progname);
/* Remember the argv array in a symbol reserved for that purpose. */
{
register int i;
Symbol *s = symbol_intern ("mhc::argv");
for (i = 0; i < argc; i++)
symbol_add_value (s, argv[i]);
}
while (arg_index < argc)
{
char *arg = argv[arg_index++];
if (strcasecmp (arg, "--version") == 0)
{
fprintf (stdout, "%s\n", mhtml_version_string);
if (arg_index + 1 >= argc)
exit (0);
}
else if ((strcasecmp (arg, "--set") == 0) && (arg_index + 1 < argc))
{
char *name = argv[arg_index++];
char *value = argv[arg_index++];
pagefunc_set_variable (name, value);
}
else if (!filename && (strcmp (arg, "-z") == 0))
call_bootstrap = 0;
else if (!filename && (strcmp (arg, "--config") == 0))
{
char *config_file = argv[arg_index];
if (config_file == (char *)NULL)
usage ();
else
{
config_page = page_read_template (config_file);
arg_index++;
}
}
else if (!filename && (*arg != '-'))
{
filename = arg;
symbol_add_value (program_args, filename);
pagefunc_set_variable ("mhc::script-name", filename);
}
else if (filename)
symbol_add_value (program_args, arg);
else
usage ();
}
if (!filename)
{
char thisdir[1120];
if (getcwd (thisdir, 1023) < 0)
sprintf (thisdir, ".");
strcat (thisdir, "/*standard-input*");
filename = strdup (thisdir);
if (isatty (fileno (stdin)))
usage ();
else
{
PAGE *page = page_create_page ();
char buffer[1024];
int done = 0;
register int i;
while (!done)
{
for (i = 0; i < 1024; i++) buffer[i] = '\0';
fread (buffer, 1023, 1, stdin);
bprintf (page, "%s", buffer);
if (feof (stdin))
done = 1;
}
input_contents = page;
}
}
else
input_contents = page_read_template (filename);
{
char *temp = pagefunc_get_variable ("mhtml::include-prefix");
if (empty_string_p (temp))
{
temp = strrchr (filename, '/');
if (temp != (char *)NULL)
{
*temp = '\0';
pagefunc_set_variable ("mhtml::include-prefix", filename);
}
else
{
char dir[1024];
temp = getcwd (dir, sizeof (dir));
if (temp != (char *)NULL)
pagefunc_set_variable ("mhtml::include-prefix", dir);
else
pagefunc_set_variable ("mhtml::include-prefix", "/");
}
}
}
}
static void
require_remember_pathname (char *pathname)
{
Symbol *sym = symbol_intern (REQUIRE_LOADED);
symbol_add_value (sym, pathname);
}
