Exemple #1
0
/**
 * 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
Exemple #2
0
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
Exemple #3
0
/**
 * 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
Exemple #4
0
/**
 * 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
Exemple #5
0
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
Exemple #6
0
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
Exemple #7
0
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;
}
Exemple #8
0
/**
 * 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
Exemple #9
0
/**
 * 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
Exemple #10
0
/**
 * 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
Exemple #11
0
/**
 * 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
Exemple #12
0
/**
 * 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