plugins/guile/plugin.c

   1 /* -*- mode: c; c-basic-offset: 8 -*- */
   2 /*
   3  *
   4  *     Authors: Mark Probst
   5  *              Ariel Rios <ariel@arcavia.com>
   6  *         Copyright Mark Probst, Ariel Rios 2000, 2001
   7  *
   8  * This program is free software; you can redistribute it and/or modify
   9  * it under the terms of the GNU General Public License as published by
  10  * the Free Software Foundation; either version 2, or (at your option)
  11  * any later version.
  12  *
  13  * This program is distributed in the hope that it will be useful,
  14  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  15  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16  * GNU General Public License for more details.
  17  *
  18  * You should have received a copy of the GNU General Public License
  19  * along with this software; see the file COPYING.  If not, write to the
  20  * Free Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
  21  * MA  02110-1301  USA.
  22  */
  23
  24 #include <gnumeric-config.h>
  25 #include <glib/gi18n-lib.h>
  26 #include <gnumeric.h>
  27 #include <glib.h>
  28 #include <assert.h>
  29 #include <stdio.h>
  30 #include <libguile.h>
  31 /* Deprecated, but we want gh_scm2newstr */
  32 #include <guile/gh.h>
  33 #include <gnome.h>
  34
  35 #include <goffice/goffice.h>
  36 #include <gnm-plugin.h>
  37 #include <expr.h>
  38 #include <gutils.h>
  39 #include <func.h>
  40 #include <cell.h>
  41 #include <value.h>
  42 #include <libgnumeric.h>
  43 #include <command-context.h>
  44 #include "guile-support.h"
  45 #include "smob-value.h"
  46
  47 GNM_PLUGIN_MODULE_HEADER;
  48
  49 /* This is damn ugly.
  50  * However, it will get things working again (I hope)
  51  * until someone who actually uses this thing takes
  52  * over maintaing it.
  53  */
  54 static GnmEvalPos const *eval_pos = NULL;
  55
  56 static SCM
  57 scm_gnumeric_funcall (SCM funcname, SCM arglist)
  58 {
  59         int i, num_args;
  60         GnmValue **argvals;
  61         GnmValue *retval;
  62         SCM retsmob;
  63         GnmCellRef cell_ref = { 0, 0, 0, 0 };
  64
  65         SCM_ASSERT (SCM_NIMP (funcname) && SCM_STRINGP (funcname), funcname, SCM_ARG1, "gnumeric-funcall");
  66         SCM_ASSERT (SCM_NFALSEP (scm_list_p (arglist)), arglist, SCM_ARG2, "gnumeric-funcall");
  67
  68         num_args = scm_ilength (arglist);
  69         argvals = g_new (GnmValue *, num_args);
  70         for (i = 0; i < num_args; ++i) {
  71                 argvals[i] = scm_to_value (SCM_CAR (arglist));
  72                 arglist = SCM_CDR (arglist);
  73         }
  74
  75         retval = function_call_with_values (eval_pos, SCM_CHARS (funcname),
  76                                             num_args,argvals);
  77         retsmob = value_to_scm (retval, cell_ref);
  78         value_release (retval);
  79         return retsmob;
  80 }
  81
  82 typedef struct {
  83         SCM function;
  84         SCM args;
  85 } GnmGuileCallRec;
  86
  87 /* This gets called from scm_internal_stack_catch when calling scm_apply. */
  88 static SCM
  89 gnm_guile_helper (void *data)
  90 {
  91         GnmGuileCallRec *ggcr = (GnmGuileCallRec *) data;
  92         return scm_apply_0 (ggcr->function, ggcr->args);
  93 }
  94
  95 /*
  96  * This gets called if scm_apply throws an error.
  97  *
  98  * We use gh_scm2newstr to convert from Guile string to Scheme string. The
  99  * GH interface is deprecated, but doing it in scm takes more code. We'll
 100  * convert later if we have to.
 101  */
 102 static SCM
 103 gnm_guile_catcher (void *data, SCM tag, SCM throw_args)
 104 {
 105         char const *header = _("Guile error");
 106         SCM smob;
 107         SCM func;
 108         SCM res;
 109         char *guilestr = NULL;
 110         char *msg;
 111         GnmValue *v;
 112
 113         func = scm_c_eval_string ("gnm:error->string");
 114         if (scm_procedure_p (func)) {
 115                 res = scm_apply (func, tag,
 116                                  scm_cons (throw_args, scm_listofnull));
 117                 if (scm_string_p (res))
 118                         guilestr = gh_scm2newstr (res, NULL);
 119         }
 120
 121         if (guilestr != NULL) {
 122                 char *buf = g_strdup_printf ("%s: %s", header, guilestr);
 123                 free (guilestr);
 124                 v = value_new_error (NULL, buf);
 125                 g_free (buf);
 126         } else {
 127                 v = value_new_error (NULL, header);
 128         }
 129
 130         smob = make_new_smob (v);
 131         value_release (v);
 132         return smob;
 133 }
 134
 135 static GnmValue*
 136 func_marshal_func (GnmFuncEvalInfo *ei, GnmValue *argv[])
 137 {
 138         GnmFunc const *fndef;
 139         SCM args = SCM_EOL, result, function;
 140         GnmCellRef dummy = { 0, 0, 0, 0 };
 141         GnmEvalPos const *old_eval_pos;
 142         GnmGuileCallRec ggcr;
 143         int i, min, max;
 144
 145         g_return_val_if_fail (ei != NULL, NULL);
 146
 147         fndef = gnm_eval_info_get_func (ei);
 148         gnm_func_count_args (fndef, &min, &max);
 149
 150         function = (SCM) gnm_func_get_user_data (fndef);
 151
 152         for (i = min - 1; i >= 0; --i)
 153                 args = scm_cons (value_to_scm (argv [i], dummy), args);
 154
 155         old_eval_pos  = eval_pos;
 156         eval_pos      = ei->pos;
 157         ggcr.function = function;
 158         ggcr.args     = args;
 159         result        = scm_internal_stack_catch (SCM_BOOL_T,
 160                                                   gnm_guile_helper, &ggcr,
 161                                                   gnm_guile_catcher, NULL);
 162         eval_pos     = old_eval_pos;
 163
 164         return scm_to_value (result);
 165 }
 166
 167 /*
 168  * FIXME: If we clean up at exit, removing the registered functions, we get
 169  * rid of the 'Leaking string [Guile] with ref_count=1' warnings. The way we
 170  * do this for other plugins, including Python, we deactivate the
 171  * plugin. However, it is not possible to finalize Guile.
 172  */
 173 static SCM
 174 scm_register_function (SCM scm_name, SCM scm_args, SCM scm_help, SCM scm_category, SCM scm_function)
 175 {
 176         GnmFunc *fndef;
 177         GnmFuncGroup   *cat;
 178         GnmFuncDescriptor    desc;
 179         char     *help;
 180
 181         SCM_ASSERT (SCM_NIMP (scm_name) && SCM_STRINGP (scm_name), scm_name, SCM_ARG1, "scm_register_function");
 182         SCM_ASSERT (SCM_NIMP (scm_args) && SCM_STRINGP (scm_args), scm_args, SCM_ARG2, "scm_register_function");
 183         SCM_ASSERT (SCM_NIMP (scm_help) && SCM_STRINGP (scm_help), scm_help, SCM_ARG3, "scm_register_function");
 184         SCM_ASSERT (SCM_NIMP (scm_category) && SCM_STRINGP (scm_category),
 185                     scm_category, SCM_ARG4, "scm_register_function");
 186         SCM_ASSERT (scm_procedure_p (scm_function), scm_function, SCM_ARG5, "scm_register_function");
 187
 188         scm_permanent_object (scm_function);
 189
 190         desc.name       = g_strdup (SCM_CHARS (scm_name));
 191         desc.arg_spec   = g_strdup (SCM_CHARS (scm_args));
 192         desc.arg_names  = NULL;
 193         help            = g_strdup (SCM_CHARS (scm_help));
 194         desc.help       = &help;
 195         desc.fn_args    = func_marshal_func;
 196         desc.fn_nodes   = NULL;
 197         desc.linker     = NULL;
 198         desc.unlinker   = NULL;
 199         desc.flags      = 0;
 200         desc.ref_notify = NULL;
 201         desc.impl_status = GNM_FUNC_IMPL_STATUS_UNIQUE_TO_GNUMERIC;
 202         desc.test_status = GNM_FUNC_TEST_STATUS_UNKNOWN;
 203
 204         cat = gnm_func_group_fetch (SCM_CHARS (scm_category), NULL);
 205         fndef = gnm_func_add (cat, &desc, NULL);
 206
 207         gnm_func_set_user_data (fndef, GINT_TO_POINTER (scm_function));
 208
 209         return SCM_UNSPECIFIED;
 210 }
 211
 212 G_MODULE_EXPORT void
 213 go_plugin_init (GOPlugin *p, GOCmdContext *cc)
 214 {
 215         char *name, *dir;
 216
 217         *ret_error = NULL;
 218
 219          scm_init_guile ();
 220
 221         /* Initialize just in case. */
 222         eval_pos = NULL;
 223
 224         init_value_type ();
 225
 226         scm_c_define_gsubr ("gnumeric-funcall", 2, 0, 0, scm_gnumeric_funcall);
 227         scm_c_define_gsubr ("register-function", 5, 0, 0, scm_register_function);
 228
 229         dir = gnm_sys_data_dir ("guile");
 230         name = g_strconcat (dir, "gnumeric_startup.scm", NULL);
 231         scm_apply (scm_c_eval_string ("(lambda (filename)"
 232                                   "  (if (access? filename R_OK)"
 233                                   "    (load filename)"
 234                                   "    (display (string-append \"could not read Guile plug-in init file\" filename \"\n\"))))"),
 235                   scm_cons (scm_makfrom0str (name), SCM_EOL),
 236                   SCM_EOL);
 237         g_free (name);
 238         g_free (dir);
 239         /* Don't try to deactivate the plugin */
 240         gnm_plugin_use_ref (PLUGIN);
 241 }