Scheme_Object *
scheme_reload (Scheme_Env *env)
{
Scheme_Env *menv = NULL; // The module's environment
// Annotations for the garbage collector
MZ_GC_DECL_REG (2);
MZ_GC_VAR_IN_REG (0, env);
MZ_GC_VAR_IN_REG (1, menv);
MZ_GC_REG ();
// Build the module environment.
menv = scheme_primitive_module (scheme_intern_symbol ("loudbus"),
env);
// Build the procedures
register_function (loudbus_call, "loudbus-call", 2, -1, menv);
register_function (loudbus_import, "loudbus-import", 3, 3, menv);
register_function (loudbus_init, "loudbus-init", 1, 1, menv);
register_function (loudbus_method_info, "loudbus-method-info", 2, 2, menv);
register_function (loudbus_methods, "loudbus-methods", 1, 1, menv);
register_function (loudbus_objects, "loudbus-objects", 1, 1, menv);
register_function (loudbus_proxy, "loudbus-proxy", 3, 3, menv);
register_function (loudbus_services, "loudbus-services", 0, 0, menv);
// And we're done.
scheme_finish_primitive_module (menv);
MZ_GC_UNREG ();
return scheme_void;
} // scheme_reload
/**
* Convert an array of Scheme objects to a GVariant that serves as
* the primary parameter to g_dbus_proxy_call.
*/
static GVariant *
scheme_objects_to_parameter_tuple (gchar *fun,
int arity,
Scheme_Object **objects,
GDBusArgInfo *formals[])
{
int i; // Counter variable
GVariantBuilder *builder;
// Something to let us build tuples
GVariant *result; // The GVariant we build
GVariant *actual; // One actual
builder = g_variant_builder_new (G_VARIANT_TYPE_TUPLE);
// Annotations for garbage collector.
// Since we're converting Scheme_Object values to GVariants, it should
// not be the case that we have an "allocating call". However, I am
// worried that conversion to a string, which requires
// scheme_char_string_to_byte_string_locale, might be considered an
// allocating call. So let's be in the safe side. The sample code suggests
// that we can put an array of GObjects in a single variable (see
// the supplied makeadder3m.c for more details).
MZ_GC_DECL_REG (1);
MZ_GC_VAR_IN_REG (0, objects);
MZ_GC_REG ();
// Process all the parameters
for (i = 0; i < arity; i++)
{
actual = scheme_object_to_parameter (objects[i], formals[i]->signature);
// If we can't convert the parameter, we give up.
if (actual == NULL)
{
// Early exit - Clean up for garbage collection
MZ_GC_UNREG ();
// Get rid of the builder
g_variant_builder_unref (builder);
// And return an arror message.
scheme_wrong_type (fun,
dbus_signature_to_string (formals[i]->signature),
i,
arity,
objects);
} // If we could not convert
// Otherwise, we add the value to the builder and go on
g_variant_builder_add_value (builder, actual);
} // for
// Clean up garbage collection info.
MZ_GC_UNREG ();
// And we're done.
result = g_variant_builder_end (builder);
return result;
} // scheme_objects_to_parameter_tuple
/**
* Call a function, using the proxy, function name, and external name
* stored in prim.
*
* argc/argv give the parameters for the function call.
*/
Scheme_Object *
loudbus_call_with_closure (int argc, Scheme_Object **argv, Scheme_Object *prim)
{
Scheme_Object *wrapped_proxy = NULL;
Scheme_Object *wrapped_dbus_name = NULL;
Scheme_Object *wrapped_external_name = NULL;
Scheme_Object *result = NULL;
LouDBusProxy *proxy = NULL;
gchar *dbus_name;
gchar *external_name;
// Probably too many things are annotated here, but better safe than
// sorry.
MZ_GC_DECL_REG (5);
MZ_GC_VAR_IN_REG (0, argv);
MZ_GC_VAR_IN_REG (1, prim);
MZ_GC_VAR_IN_REG (2, wrapped_proxy);
MZ_GC_VAR_IN_REG (3, wrapped_dbus_name);
MZ_GC_VAR_IN_REG (4, wrapped_external_name);
MZ_GC_REG ();
// Extract information from the closure.
wrapped_proxy = SCHEME_PRIM_CLOSURE_ELS (prim)[0];
wrapped_dbus_name = SCHEME_PRIM_CLOSURE_ELS (prim)[1];
wrapped_external_name = SCHEME_PRIM_CLOSURE_ELS (prim)[2];
dbus_name = scheme_object_to_string (wrapped_dbus_name);
external_name = scheme_object_to_string (wrapped_external_name);
proxy = scheme_object_to_proxy (wrapped_proxy);
// Sanity check
if (proxy == NULL)
{
MZ_GC_UNREG ();
scheme_signal_error ("Could not obtain proxy to call %s.\n",
external_name);
} // if (proxy == NULL)
// And do the dirty work
result = dbus_call_kernel (proxy,
dbus_name, external_name,
argc, argv);
MZ_GC_UNREG ();
return result;
} // loudbus_call_with_closure
/**
* Add one of the procedures that the proxy provides on the D-Bus.
*/
static void
loudbus_add_dbus_proc (Scheme_Env *env,
Scheme_Object *proxy,
gchar *dbus_name,
gchar *external_name,
int arity)
{
Scheme_Object *vals[3];
Scheme_Object *proc;
vals[0] = NULL;
vals[1] = NULL;
vals[2] = NULL;
// Prepare for potential garbage collection during allocating calls
// (e.g., scheme_make_locale_string).
MZ_GC_DECL_REG (3);
MZ_GC_VAR_IN_REG (0, vals[0]);
MZ_GC_VAR_IN_REG (1, vals[1]);
MZ_GC_VAR_IN_REG (2, vals[2]);
MZ_GC_REG ();
// Fill in the closure with the object.
vals[0] = proxy;
vals[1] = scheme_make_locale_string (dbus_name);
vals[2] = scheme_make_locale_string (external_name);
// Build the procedure. Note that we need to duplicate the
// external name because scheme_make_prim_closure_w_arity seems
// to retain a pointer to the string. (At least, it seems that way
// to me.)
proc = scheme_make_prim_closure_w_arity (loudbus_call_with_closure,
3, vals,
g_strdup (external_name),
arity, arity);
// And add it to the environment.
scheme_add_global (external_name, proc, env);
// And update the GC info.
MZ_GC_UNREG ();
} // loudbus_add_dbus_proc
Scheme_Object *
scheme_reload (Scheme_Env *env)
{
Scheme_Env *menv = NULL; // The module's environment
Scheme_Object *proc = NULL; // A Procedure we're adding
// Annotations for the garbage collector
MZ_GC_DECL_REG (2);
MZ_GC_VAR_IN_REG (0, env);
MZ_GC_VAR_IN_REG (1, menv);
MZ_GC_REG ();
// Build the module environment.
menv = scheme_primitive_module (scheme_intern_symbol ("loudbus"),
env);
// Build the procedures
proc = scheme_make_prim_w_arity (loudbus_call, "loudbus-call", 2, -1);
scheme_add_global ("loudbus-call", proc, menv);
proc = scheme_make_prim_w_arity (loudbus_import, "loudbus-import", 3, 3),
scheme_add_global ("loudbus-import", proc, menv);
proc = scheme_make_prim_w_arity (loudbus_init, "loudbus-init", 1, 1),
scheme_add_global ("loudbus-init", proc, menv);
proc = scheme_make_prim_w_arity (loudbus_methods, "loudbus-methods", 1, 1),
scheme_add_global ("loudbus-methods", proc, menv);
proc = scheme_make_prim_w_arity (loudbus_proxy, "loudbus-proxy", 3, 3),
scheme_add_global ("loudbus-proxy", proc, menv);
// And we're done.
scheme_finish_primitive_module (menv);
MZ_GC_UNREG ();
return scheme_void;
} // scheme_reload
Scheme_Object *
scheme_reload (Scheme_Env *env)
{
Scheme_Env *menv = NULL; // The module's environment.
Scheme_Object *proc = NULL; // A procedure that we're adding.
// Annotations for the garbage collector
MZ_GC_DECL_REG (2);
MZ_GC_VAR_IN_REG (0, env);
MZ_GC_VAR_IN_REG (1, menv);
MZ_GC_REG ();
// Build the module environment
menv = scheme_primitive_module (scheme_intern_symbol ("irgb"), env);
// Add the procedures
proc = scheme_make_prim_w_arity (irgb_alpha, "irgb-alpha", 1, 1);
scheme_add_global ("irgb-alpha", proc, menv);
proc = scheme_make_prim_w_arity (irgb_blue, "irgb-blue", 1, 1);
scheme_add_global ("irgb-blue", proc, menv);
proc = scheme_make_prim_w_arity (irgb_green, "irgb-green", 1, 1);
scheme_add_global ("irgb-green", proc, menv);
proc = scheme_make_prim_w_arity (irgb_new, "irgb-new", 3, 3);
scheme_add_global ("irgb-new", proc, menv);
proc = scheme_make_prim_w_arity (irgb_red, "irgb-red", 1, 1);
scheme_add_global ("irgb-red", proc, menv);
proc = scheme_make_prim_w_arity (irgba_new, "irgba-new", 4, 4);
scheme_add_global ("irgba-new", proc, menv);
// Clean up
scheme_finish_primitive_module (menv);
MZ_GC_UNREG ();
// And we're done
return scheme_void;
} // scheme_reload
Scheme_Object *scheme_reload(Scheme_Env *env)
{
Scheme_Object *proc;
/* The MZ_GC... lines are for for 3m, because env is live across an
allocating call. They're not needed for plain old (conservatively
collected) Mzscheme. See makeadder3m.c for more info. */
MZ_GC_DECL_REG(1);
MZ_GC_VAR_IN_REG(0, env);
MZ_GC_REG();
/* Package the C implementation of fmod into a Scheme procedure
value: */
proc = scheme_make_prim_w_arity(sch_fmod, "fmod", 2, 2);
/* Requires at least two args ------^ ^ */
/* Accepts no more than two args ---| */
/* Define `fmod' as a global :*/
scheme_add_global("fmod", proc, env);
MZ_GC_UNREG();
return scheme_void;
}
/**
* Get all of the methods from a louDBus Proxy.
*/
Scheme_Object *
loudbus_methods (int argc, Scheme_Object **argv)
{
Scheme_Object *result = NULL; // The result we're building
Scheme_Object *val = NULL; // One method in the result
GDBusMethodInfo *method; // Information on one method
LouDBusProxy *proxy; // The proxy
int m; // Counter variable for methods
MZ_GC_DECL_REG (2);
MZ_GC_VAR_IN_REG (0, result);
MZ_GC_VAR_IN_REG (1, val);
// Get the proxy
proxy = scheme_object_to_proxy (argv[0]);
if (proxy == NULL)
{
scheme_wrong_type ("loudbus-methods", "LouDBusProxy *", 0, argc, argv);
} // if proxy == NULL
MZ_GC_REG ();
// Build the list.
result = scheme_null;
for (m = g_dbus_interface_info_num_methods (proxy->iinfo) - 1; m >= 0; m--)
{
method = proxy->iinfo->methods[m];
val = scheme_make_locale_string (method->name);
result = scheme_make_pair (val, result);
} // for each method
MZ_GC_UNREG ();
// And we're done.
return result;
} // loudbus_methods
/**
* Convert a GVariant to a Scheme object. Returns NULL if there's a
* problem.
*/
static Scheme_Object *
g_variant_to_scheme_object (GVariant *gv)
{
const GVariantType *type; // The type of the GVariant
const gchar *typestring; // A string that describes the type
int i; // A counter variable
int len; // Length of arrays and tuples
Scheme_Object *lst = NULL; // A list that we build as a result
Scheme_Object *sval = NULL; // One value
Scheme_Object *result = NULL; // One result to return.
// Special case: We'll treat NULL as void.
if (gv == NULL)
{
return scheme_void;
} // if (gv == NULL)
// Get the type
type = g_variant_get_type (gv);
typestring = g_variant_get_type_string (gv);
// ** Handle most of the basic types **
// Integer
if (g_variant_type_equal (type, G_VARIANT_TYPE_INT32))
{
// We don't refer to any Scheme objects across allocating calls,
// so no need for GC code.
int i;
i = g_variant_get_int32 (gv);
result = scheme_make_integer (i);
return result;
} // if it's an integer
// Double
if (g_variant_type_equal (type, G_VARIANT_TYPE_DOUBLE))
{
double d;
d = g_variant_get_double (gv);
result = scheme_make_double (d);
return result;
} // if it's a double
// String
if (g_variant_type_equal (type, G_VARIANT_TYPE_STRING))
{
// We don't refer to any Scheme objects across allocating calls,
// so no need for GC code.
const gchar *str;
str = g_variant_get_string (gv, NULL);
result = scheme_make_locale_string (str);
return result;
} // if it's a string
// ** Handle some special cases **
// We treat arrays of bytes as bytestrings
if (g_strcmp0 (typestring, "ay") == 0)
{
gsize size;
guchar *data;
data = (guchar *) g_variant_get_fixed_array (gv, &size, sizeof (guchar));
return scheme_make_sized_byte_string ((char *) data, size, 1);
} // if it's an array of bytes
// ** Handle the compound types **
// Tuple or Array
if ( (g_variant_type_is_tuple (type))
|| (g_variant_type_is_array (type)) )
{
// Find out how many values to put into the list.
len = g_variant_n_children (gv);
// Here, we are referring to stuff across allocating calls, so we
// need to be careful.
MZ_GC_DECL_REG (2);
MZ_GC_VAR_IN_REG (0, lst);
MZ_GC_VAR_IN_REG (1, sval);
MZ_GC_REG ();
// Start with the empty list.
lst = scheme_null;
// Step through the items, right to left, adding them to the list.
for (i = len-1; i >= 0; i--)
{
sval = g_variant_to_scheme_object (g_variant_get_child_value (gv, i));
lst = scheme_make_pair (sval, lst);
} // for
// Okay, we've made it through the list, now we can clean up.
MZ_GC_UNREG ();
if ((g_variant_type_is_array (type)))
{
//If type is array, convert to vector
scheme_list_to_vector ((char*)lst);
}//If array
// And we're done.
return lst;
} // if it's a tuple or an array
// Unknown. Give up.
scheme_signal_error ("Unknown type %s", typestring);
return scheme_void;
} // g_variant_to_scheme_object
/**
* Create a new proxy.
*/
static Scheme_Object *
loudbus_proxy (int argc, Scheme_Object **argv)
{
gchar *service = NULL; // A string giving the service
gchar *path = NULL; // A string giving the path to the object
gchar *interface = NULL; // A string giving the interface
LouDBusProxy *proxy = NULL; // The proxy we build
Scheme_Object *result = NULL; // The proxy wrapped as a Scheme object
GError *error = NULL; // A place to hold errors
service = scheme_object_to_string (argv[0]);
// Annotations for garbage collection
MZ_GC_DECL_REG (5);
MZ_GC_VAR_IN_REG (0, argv);
MZ_GC_VAR_IN_REG (1, service);
MZ_GC_VAR_IN_REG (2, path);
MZ_GC_VAR_IN_REG (3, interface);
MZ_GC_VAR_IN_REG (4, result);
MZ_GC_REG ();
// Extract parameters
service = scheme_object_to_string (argv[0]);
path = scheme_object_to_string (argv[1]);
interface = scheme_object_to_string (argv[2]);
// Check parameters
if (service == NULL)
{
MZ_GC_UNREG ();
scheme_wrong_type ("loudbus-proxy", "string", 0, argc, argv);
}
if (path == NULL)
{
MZ_GC_UNREG ();
scheme_wrong_type ("loudbus-proxy", "string", 1, argc, argv);
}
if (interface == NULL)
{
MZ_GC_UNREG ();
scheme_wrong_type ("loudbus-proxy", "string", 2, argc, argv);
}
// Do the actual work in building the proxy.
proxy = loudbus_proxy_new (service, path, interface, &error);
if (proxy == NULL)
{
if (error == NULL)
{
MZ_GC_UNREG ();
scheme_signal_error ("loudbus-proxy: "
"Could not create proxy for an unknown reason.");
}
else
{
MZ_GC_UNREG ();
scheme_signal_error ("loudbus-proxy: "
"Could not create proxy because %s",
error->message);
}
} // if (proxy == NULL)
// Wrap the proxy into a Scheme type
result = scheme_make_cptr (proxy, LOUDBUS_PROXY_TAG);
// Log info during development
LOG ("loudbus_proxy: Built proxy %p, Scheme object %p", proxy, result);
// Find out information on what we just built.
SCHEME_LOG ("result is", result);
SCHEME_LOG ("result type is", SCHEME_CPTR_TYPE (result));
// Register the finalizer
scheme_register_finalizer (result, loudbus_proxy_finalize, NULL, NULL, NULL);
// And we're done
MZ_GC_UNREG ();
return result;
} // loudbus_proxy
/**
* Import all of the methods from a LouDBusProxy.
*/
Scheme_Object *
loudbus_import (int argc, Scheme_Object **argv)
{
Scheme_Env *env = NULL; // The environment
GDBusMethodInfo *method; // Information on one method
LouDBusProxy *proxy; // The proxy
int m; // Counter variable for methods
int n; // The total number of methods
int arity; // The arity of a method
gchar *prefix = NULL; // The prefix we use
gchar *external_name; // The name we use in Scheme
int dashes; // Convert underscores to dashes?
// Annotations and other stuff for garbage collection.
MZ_GC_DECL_REG (3);
MZ_GC_VAR_IN_REG (0, argv);
MZ_GC_VAR_IN_REG (1, env);
MZ_GC_VAR_IN_REG (2, prefix);
MZ_GC_REG ();
// Get the proxy
proxy = scheme_object_to_proxy (argv[0]);
if (proxy == NULL)
{
MZ_GC_UNREG ();
scheme_wrong_type ("loudbus-import", "LouDBusProxy *", 0, argc, argv);
} // if (proxy == NULL)
// Get the prefix
prefix = scheme_object_to_string (argv[1]);
if (prefix == NULL)
{
MZ_GC_UNREG ();
scheme_wrong_type ("loudbus-import", "string", 1, argc, argv);
} // if (prefix == NULL)
// Get the flag
if (! SCHEME_BOOLP (argv[2]))
{
MZ_GC_UNREG ();
scheme_wrong_type ("loudbus-import", "Boolean", 2, argc, argv);
} // if (!SCHEME_BOOLB (argv[2])
dashes = SCHEME_TRUEP (argv[2]);
// Get the current environment, since we're mutating it.
env = scheme_get_env (scheme_current_config ());
// Process the methods
n = g_dbus_interface_info_num_methods (proxy->iinfo);
for (m = 0; m < n; m++)
{
method = proxy->iinfo->methods[m];
arity = g_dbus_method_info_num_formals (method);
external_name = g_strdup_printf ("%s%s", prefix, method->name);
if (external_name != NULL)
{
if (dashes)
{
dash_it_all (external_name);
} // if (dashes)
// And add the procedure
LOG ("loudbus-import: adding %s as %s", method->name, external_name);
loudbus_add_dbus_proc (env, argv[0],
method->name, external_name,
arity);
// Clean up
g_free (external_name);
} // if (external_name != NULL)
} // for each method
// And we're done.
MZ_GC_UNREG ();
return scheme_void;
} // loudbus_import
/**
* Convert a GVariant to a Scheme object. Returns NULL if there's a
* problem.
*/
static Scheme_Object *
g_variant_to_scheme_object (GVariant *gv)
{
const GVariantType *type; // The type of the GVariant
int i; // A counter variable
int len; // Length of arrays and tuples
Scheme_Object *lst = NULL; // A list that we build as a result
Scheme_Object *sval = NULL; // One value
Scheme_Object *result = NULL; // One result to return.
// Special case: We'll treat NULL as void.
if (gv == NULL)
{
return scheme_void;
} // if (gv == NULL)
// Get the type
type = g_variant_get_type (gv);
// ** Handle most of the basic types **
// Integer
if (g_variant_type_equal (type, G_VARIANT_TYPE_INT32))
{
// We don't refer to any Scheme objects across allocating calls,
// so no need for GC code.
int i;
i = g_variant_get_int32 (gv);
result = scheme_make_integer (i);
return result;
} // if it's an integer
// String
if (g_variant_type_equal (type, G_VARIANT_TYPE_STRING))
{
// We don't refer to any Scheme objects across allocating calls,
// so no need for GC code.
const gchar *str;
str = g_variant_get_string (gv, NULL);
result = scheme_make_locale_string (str);
return result;
} // if it's a string
// ** Handle the compound types **
// Tuple or Array
if ( (g_variant_type_is_tuple (type))
|| (g_variant_type_is_array (type)) )
{
// Find out how many values to put into the list.
len = g_variant_n_children (gv);
// Here, we are referring to stuff across allocating calls, so we
// need to be careful.
MZ_GC_DECL_REG (2);
MZ_GC_VAR_IN_REG (0, lst);
MZ_GC_VAR_IN_REG (1, sval);
MZ_GC_REG ();
// Start with the empty list.
lst = scheme_null;
// Step through the items, right to left, adding them to the list.
for (i = len-1; i >= 0; i--)
{
sval = g_variant_to_scheme_object (g_variant_get_child_value (gv, i));
lst = scheme_make_pair (sval, lst);
} // for
// Okay, we've made it through the list, now we can clean up.
MZ_GC_UNREG ();
// And we're done.
return lst;
} // if it's a tuple or an array
// Unknown. Give up.
return NULL;
} // g_variant_to_scheme_object