plugins/perl-loader/perl-loader.c

   1 #include <EXTERN.h>
   2 #include <perl.h>
   3 #include "perl-gnumeric.h"
   4 #undef _
   5 #define _perl_dirty dirty
   6 #undef dirty
   7
   8 #include <gnumeric-config.h>
   9 #include "perl-loader.h"
  10 #include <gnumeric.h>
  11
  12 #include <application.h>
  13 #include <workbook-view.h>
  14 #include <workbook.h>
  15 #include <sheet.h>
  16 #include <value.h>
  17 #include <expr.h>
  18 #include <gnm-plugin.h>
  19
  20 #include <goffice/goffice.h>
  21 #include <goffice/app/module-plugin-defs.h>
  22 #include <gsf/gsf-impl-utils.h>
  23
  24 #include <glib/gi18n-lib.h>
  25 #include <stdlib.h>
  26
  27 #define TYPE_GNM_PERL_PLUGIN_LOADER     (gnm_perl_plugin_loader_get_type ())
  28 #define GNM_PERL_PLUGIN_LOADER(o)       (G_TYPE_CHECK_INSTANCE_CAST ((o), TYPE_GNM_PERL_PLUGIN_LOADER, GnmPerlPluginLoader))
  29 #define GNM_IS_PERL_PLUGIN_LOADER(o)    (G_TYPE_CHECK_INSTANCE_TYPE ((o), TYPE_GNM_PERL_PLUGIN_LOADER))
  30
  31 #define dirty _perl_dirty
  32 #undef _perl_dirty
  33
  34 extern void xs_init(pTHX);
  35
  36 static PerlInterpreter* gnm_perl_interp;
  37 static PerlInterpreter* my_perl;
  38
  39 typedef struct {
  40         GObject base;
  41         gchar* module_name;
  42 } GnmPerlPluginLoader;
  43 typedef GObjectClass GnmPerlPluginLoaderClass;
  44
  45 static GnmValue*
  46 call_perl_function_args (GnmFuncEvalInfo *ei, GnmValue const * const *args)
  47 {
  48         GnmFunc const *fndef;
  49         gint min_n_args, max_n_args, n_args;
  50         gint i;
  51         gchar *perl_func;
  52         GnmValue* result;
  53         dSP;
  54
  55         fndef = gnm_expr_get_func_def ((GnmExpr *)(ei->func_call));
  56         perl_func = g_strconcat ("func_", fndef->name, NULL);
  57
  58         gnm_func_count_args (fndef, &min_n_args, &max_n_args);
  59         for (n_args = min_n_args; n_args < max_n_args && args[n_args] != NULL; n_args++);
  60
  61         ENTER;
  62         SAVETMPS;
  63         PUSHMARK(SP);
  64         for (i = 0; i < n_args; i++) {
  65                 SV* sv = value2perl (args[i]);
  66                 XPUSHs(sv_2mortal(sv));
  67         }
  68         PUTBACK;
  69         call_pv (perl_func, G_EVAL | G_SCALAR);
  70         SPAGAIN;
  71
  72         if (SvTRUE(ERRSV)) { /* Error handling */
  73                 gchar *errmsg;
  74                 STRLEN n_a;
  75                 errmsg = g_strconcat (_("Perl error: "), SvPV (ERRSV, n_a), NULL);
  76                 POPs;
  77
  78                 result = value_new_error (ei->pos, errmsg);
  79                 g_free (errmsg);
  80         } else {
  81                 result = perl2value (POPs);
  82         }
  83
  84         PUTBACK;
  85         FREETMPS;
  86         LEAVE;
  87
  88         g_free (perl_func);
  89
  90         return result;
  91 }
  92
  93 static void
  94 init_help_consts (void)
  95 {
  96         /* Export our constants as global variables.  */
  97         const struct {
  98                 const char *name;
  99                 int value;
 100         } consts[] = {
 101                 { "GNM_FUNC_HELP_NAME", GNM_FUNC_HELP_NAME },
 102                 { "GNM_FUNC_HELP_ARG", GNM_FUNC_HELP_ARG },
 103                 { "GNM_FUNC_HELP_DESCRIPTION", GNM_FUNC_HELP_DESCRIPTION },
 104                 { "GNM_FUNC_HELP_NOTE", GNM_FUNC_HELP_NOTE },
 105                 { "GNM_FUNC_HELP_EXAMPLES", GNM_FUNC_HELP_EXAMPLES },
 106                 { "GNM_FUNC_HELP_SEEALSO", GNM_FUNC_HELP_SEEALSO },
 107                 { "GNM_FUNC_HELP_EXTREF", GNM_FUNC_HELP_EXTREF },
 108                 { "GNM_FUNC_HELP_EXCEL", GNM_FUNC_HELP_EXCEL },
 109                 { "GNM_FUNC_HELP_ODF", GNM_FUNC_HELP_ODF }
 110         };
 111         unsigned ui;
 112
 113         for (ui = 0; ui < G_N_ELEMENTS (consts); ui++) {
 114                 SV* x = get_sv (consts[ui].name, TRUE);
 115                 sv_setiv (x, consts[ui].value);
 116         }
 117 }
 118
 119 static const char help_template_text[] =
 120   "This Perl function hasn't been documented.";
 121
 122 static const GnmFuncHelp help_template[] = {
 123         { GNM_FUNC_HELP_NAME, NULL },
 124         { GNM_FUNC_HELP_DESCRIPTION, NULL },
 125         { GNM_FUNC_HELP_END }
 126 };
 127
 128 static GnmFuncHelp *
 129 default_gnm_help(const char *name)
 130 {
 131         GnmFuncHelp *help = g_new0 (GnmFuncHelp, 3);
 132         if (help) {
 133                 int i;
 134                 for (i = 0; i < 3; i++)
 135                         help[i] = help_template[i];
 136                 help[0].text = g_strdup_printf ("%s:", name);
 137                 help[1].text = g_strdup (help_template_text);
 138         }
 139         return help;
 140 }
 141
 142 static GnmFuncHelp *
 143 make_gnm_help (const char *name, int count, SV **SP)
 144 {
 145         GnmFuncHelp *help = NULL;
 146         /* We assume that the description is a Perl array of the form
 147            (key, text, key, text, ...). */
 148         int n = count / 2, m = 0, k, type = GNM_FUNC_HELP_END;
 149         GnmFuncHelp *helptmp = g_new0 (GnmFuncHelp, n + 1);
 150         if (count % 2) POPs, count--;
 151         for (k = n; k-- > 0; ) {
 152                 SV *sv = POPs;
 153                 if (SvPOK(sv)) {
 154                         STRLEN size;
 155                         gchar *tmp;
 156                         tmp = SvPV(sv, size);
 157                         helptmp[k].text = g_strndup (tmp, size);
 158                 } else {
 159                         helptmp[k].text = NULL;
 160                 }
 161                 sv = POPs;
 162                 if (SvIOK(sv)) type = SvIV(sv);
 163                 if (helptmp[k].text &&
 164                     type >= GNM_FUNC_HELP_NAME && GNM_FUNC_HELP_ODF) {
 165                         helptmp[k].type = type; m++;
 166                 } else {
 167                         helptmp[k].type = GNM_FUNC_HELP_END;
 168                         if (helptmp[k].text)
 169                                 g_free ((char*)helptmp[k].text);
 170                         helptmp[k].text = NULL;
 171                 }
 172         }
 173         if (m == 0) {
 174                 /* No valid entries. */
 175                 g_free (helptmp);
 176         } else {
 177                 /* Collect all valid entries in a new array. */
 178                 if (n == m) {
 179                         help = helptmp;
 180                 } else {
 181                         int i;
 182                         help = g_new (GnmFuncHelp, m+1);
 183                         for (i = 0, k = 0; k < n; k++)
 184                                 if (helptmp[k].type != GNM_FUNC_HELP_END &&
 185                                     helptmp[k].text)
 186                                         help[i++] = helptmp[k];
 187                         g_free(helptmp);
 188                 }
 189                 help[m].type = GNM_FUNC_HELP_END;
 190                 help[m].text = NULL;
 191         }
 192         if (!help) /* Provide a reasonable default. */
 193                 help = default_gnm_help (name);
 194
 195         gnm_perl_loader_free_later (help);
 196         for (n = 0; help[n].type != GNM_FUNC_HELP_END; n++)
 197                 gnm_perl_loader_free_later (help[n].text);
 198
 199         return help;
 200 }
 201
 202 static gboolean
 203 gplp_func_desc_load (GOPluginService *service,
 204                      char const *name,
 205                      GnmFuncDescriptor *res)
 206 {
 207         char *args[] = { NULL };
 208         gchar *help_perl_func = g_strconcat ("help_", name, NULL);
 209         gchar *desc_perl_func = g_strconcat ("desc_", name, NULL);
 210         GnmFuncHelp *help = NULL;
 211         gchar *arg_spec = NULL;
 212         int count;
 213
 214         dSP;
 215         ENTER;
 216         SAVETMPS;
 217         PUSHMARK(SP);
 218         PUTBACK;
 219         count = call_argv (help_perl_func, G_EVAL | G_ARRAY | G_NOARGS, args);
 220         SPAGAIN;
 221
 222         if (SvTRUE(ERRSV)) { /* Error handling */
 223                 STRLEN n_a;
 224                 g_print ( _("Perl error: %s\n"), SvPV (ERRSV, n_a));
 225                 while (count-- > 0) POPs;
 226         } else {
 227                 help = make_gnm_help(name, count, SP);
 228         }
 229
 230         PUTBACK;
 231         FREETMPS;
 232         LEAVE;
 233
 234         ENTER;
 235         SAVETMPS;
 236         PUSHMARK(SP);
 237         PUTBACK;
 238         call_argv (desc_perl_func, G_EVAL | G_ARRAY | G_NOARGS, args);
 239         SPAGAIN;
 240
 241         if (SvTRUE(ERRSV)) { /* Error handling */
 242                 STRLEN n_a;
 243                 g_print ( _("Perl error: %s\n"), SvPV (ERRSV, n_a));
 244                 POPs;
 245         } else {
 246                 arg_spec = g_strdup (POPp);
 247                 gnm_perl_loader_free_later (arg_spec);
 248         }
 249
 250         PUTBACK;
 251         FREETMPS;
 252         LEAVE;
 253
 254         g_free (help_perl_func);
 255         g_free (desc_perl_func);
 256
 257         res->name = g_strdup(name);
 258         res->arg_spec = arg_spec;
 259
 260         res->help = help;
 261         res->fn_args = NULL;
 262         res->fn_args = &call_perl_function_args;
 263         res->fn_nodes = NULL;
 264         res->linker = NULL;
 265         res->impl_status = GNM_FUNC_IMPL_STATUS_UNIQUE_TO_GNUMERIC;
 266         res->test_status = GNM_FUNC_TEST_STATUS_UNKNOWN;
 267
 268         return TRUE;
 269 }
 270
 271 static void
 272 gplp_set_attributes (GOPluginLoader *loader, GHashTable *attrs, GOErrorInfo **ret_error)
 273 {
 274         GnmPerlPluginLoader *loader_perl = GNM_PERL_PLUGIN_LOADER (loader);
 275
 276         gchar *module_name = NULL;
 277
 278         GO_INIT_RET_ERROR_INFO (ret_error);
 279         module_name = g_hash_table_lookup (attrs, "module_name");
 280         if (module_name) {
 281                 loader_perl->module_name = g_strdup (module_name);
 282         } else {
 283                 *ret_error = go_error_info_new_str (
 284                              _("Module name not given."));
 285         }
 286 }
 287
 288 static void
 289 gplp_load_base (GOPluginLoader *loader, GOErrorInfo **ret_error)
 290 {
 291         char *argv[] = { (char*)"", NULL, NULL, NULL };
 292         char const *arg;
 293         int argc;
 294
 295         arg = go_plugin_get_dir_name (go_plugin_loader_get_plugin (loader));
 296         argv[1] = g_strconcat ("-I", arg, NULL);
 297         argv[2] = g_build_filename (arg, "perl_func.pl", NULL);
 298         argc = 2;
 299
 300         if (g_file_test (argv[2], G_FILE_TEST_EXISTS)) {
 301                 PERL_SYS_INIT3 (&argc, (char ***)&argv, NULL);
 302                 gnm_perl_interp = perl_alloc ();
 303                 perl_construct (gnm_perl_interp);
 304                 perl_parse (gnm_perl_interp, xs_init, 3, argv, NULL);
 305                 my_perl = gnm_perl_interp;
 306                 init_help_consts ();
 307 #ifdef PERL_EXIT_DESTRUCT_END
 308                 PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
 309 #endif
 310         } else {
 311                 *ret_error = go_error_info_new_printf (
 312                              _("perl_func.pl doesn't exist."));
 313         }
 314
 315         g_free (argv[1]);
 316         g_free (argv[2]);
 317 }
 318
 319 static void
 320 gplp_load_service_function_group (GOPluginLoader *loader,
 321                                   GOPluginService *service,
 322                                   GOErrorInfo **ret_error)
 323 {
 324         GnmPluginServiceFunctionGroupCallbacks *cbs;
 325
 326         g_return_if_fail (GNM_IS_PLUGIN_SERVICE_FUNCTION_GROUP (service));
 327
 328         GO_INIT_RET_ERROR_INFO (ret_error);
 329
 330         cbs = go_plugin_service_get_cbs (service);
 331         cbs->func_desc_load = &gplp_func_desc_load;
 332 }
 333
 334 static gboolean
 335 gplp_service_load (GOPluginLoader *l, GOPluginService *s, GOErrorInfo **err)
 336 {
 337         if (GNM_IS_PLUGIN_SERVICE_FUNCTION_GROUP (s))
 338                 gplp_load_service_function_group (l, s, err);
 339         else
 340                 return FALSE;
 341         return TRUE;
 342 }
 343
 344 static gboolean
 345 gplp_service_unload (GOPluginLoader *l, GOPluginService *s, GOErrorInfo **err)
 346 {
 347         if (GNM_IS_PLUGIN_SERVICE_FUNCTION_GROUP (s))
 348                 ;
 349         else
 350                 return FALSE;
 351         return TRUE;
 352 }
 353
 354 static void
 355 gplp_finalize (GObject *obj)
 356 {
 357         GnmPerlPluginLoader *loader_perl = GNM_PERL_PLUGIN_LOADER (obj);
 358
 359         g_free (loader_perl->module_name);
 360         loader_perl->module_name = NULL;
 361
 362         G_OBJECT_CLASS (g_type_class_peek (G_TYPE_OBJECT))->finalize (obj);
 363 }
 364
 365 static void
 366 go_plugin_loader_init (GOPluginLoaderClass *iface)
 367 {
 368         iface->set_attributes           = gplp_set_attributes;
 369         iface->load_base                = gplp_load_base;
 370
 371         iface->service_load             = gplp_service_load;
 372         iface->service_unload           = gplp_service_unload;
 373 }
 374
 375 static void
 376 gplp_class_init (GObjectClass *gobject_class)
 377 {
 378         gobject_class->finalize = gplp_finalize;
 379 }
 380
 381 static void
 382 gplp_init (GnmPerlPluginLoader *loader_perl)
 383 {
 384         g_return_if_fail (GNM_IS_PERL_PLUGIN_LOADER (loader_perl));
 385
 386         loader_perl->module_name = NULL;
 387 }
 388
 389 GSF_DYNAMIC_CLASS_FULL (GnmPerlPluginLoader, gnm_perl_plugin_loader,
 390         NULL, NULL, gplp_class_init, NULL,
 391         gplp_init, G_TYPE_OBJECT, 0,
 392         GSF_INTERFACE_FULL (gnm_perl_plugin_loader_type, go_plugin_loader_init, GO_TYPE_PLUGIN_LOADER))