Mercurial > pidgin3 / file comparison

comparison: libgaim/plugins/perl/perl.c

libgaim/plugins/perl/perl.c

changeset 14254
77edc7a6191a
parent 14253
b63ebf84c42b
child 14426
8d4f164c4979
equal deleted inserted replaced
14253:b63ebf84c42b 14254:77edc7a6191a
1 /*
2 * gaim
3 *
4 * Copyright (C) 2003 Christian Hammond <chipx86@gnupdate.org>
5 *
6 * This program is free software; you can redistribute it and/or modify
7 * it under the terms of the GNU General Public License as published by
8 * the Free Software Foundation; either version 2 of the License, or
9 * (at your option) any later version.
10 *
11 * This program is distributed in the hope that it will be useful,
12 * but WITHOUT ANY WARRANTY; without even the implied warranty of
13 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 * GNU General Public License for more details.
15 *
16 * You should have received a copy of the GNU General Public License
17 * along with this program; if not, write to the Free Software
18 * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
19 */
20 #ifdef HAVE_CONFIG_H
21 #include <config.h>
22 # ifdef HAVE_LIMITS_H
23 # include <limits.h>
24 # ifndef NAME_MAX
25 # define NAME_MAX _POSIX_NAME_MAX
26 # endif
27 # endif
28 #endif
29
30 #ifdef DEBUG
31 # undef DEBUG
32 #endif
33
34 #undef PACKAGE
35
36 #define group perl_group
37
38 #ifdef _WIN32
39 /* This took me an age to figure out.. without this __declspec(dllimport)
40 * will be ignored.
41 */
42 # define HASATTRIBUTE
43 #endif
44
45 #include <EXTERN.h>
46
47 #ifndef _SEM_SEMUN_UNDEFINED
48 # define HAS_UNION_SEMUN
49 #endif
50
51 #include <perl.h>
52 #include <XSUB.h>
53
54 #ifndef _WIN32
55 # include <sys/mman.h>
56 #endif
57
58 #undef PACKAGE
59
60 #ifndef _WIN32
61 # include <dirent.h>
62 #else
63 /* We're using perl's win32 port of this */
64 # define dirent direct
65 #endif
66
67 #undef group
68
69 /* perl module support */
70 #ifdef OLD_PERL
71 extern void boot_DynaLoader _((CV * cv));
72 #else
73 extern void boot_DynaLoader _((pTHX_ CV * cv)); /* perl is so wacky */
74 #endif
75
76 #undef _
77 #ifdef DEBUG
78 # undef DEBUG
79 #endif
80 #ifdef _WIN32
81 # undef pipe
82 #endif
83
84 #ifdef _WIN32
85 #define _WIN32DEP_H_
86 #endif
87 #include "internal.h"
88 #include "debug.h"
89 #include "plugin.h"
90 #include "signals.h"
91 #include "version.h"
92
93 #include "perl-common.h"
94 #include "perl-handlers.h"
95
96 #define PERL_PLUGIN_ID "core-perl"
97
98 PerlInterpreter *my_perl = NULL;
99
100 static GaimPluginUiInfo ui_info =
101 {
102 gaim_perl_get_plugin_frame,
103 0, /* page_num (Reserved) */
104 NULL /* frame (Reserved) */
105 };
106
107 static GaimGtkPluginUiInfo gtk_ui_info =
108 {
109 gaim_perl_gtk_get_plugin_frame,
110 0 /* page_num (Reserved) */
111 };
112
113 static void
114 #ifdef OLD_PERL
115 xs_init()
116 #else
117 xs_init(pTHX)
118 #endif
119 {
120 char *file = __FILE__;
121
122 /* This one allows dynamic loading of perl modules in perl scripts by
123 * the 'use perlmod;' construction */
124 newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);
125 }
126
127 static void
128 perl_init(void)
129 {
130 /* changed the name of the variable from load_file to perl_definitions
131 * since now it does much more than defining the load_file sub.
132 * Moreover, deplaced the initialisation to the xs_init function.
133 * (TheHobbit) */
134 char *perl_args[] = { "", "-e", "0", "-w" };
135 char perl_definitions[] =
136 {
137 /* We use to function one to load a file the other to execute
138 * the string obtained from the first and holding the file
139 * contents. This allows to have a really local $/ without
140 * introducing temp variables to hold the old value. Just a
141 * question of style:) */
142 "package Gaim::PerlLoader;"
143 "use Symbol;"
144
145 "sub load_file {"
146 "my $f_name=shift;"
147 "local $/=undef;"
148 "open FH,$f_name or return \"__FAILED__\";"
149 "$_=<FH>;"
150 "close FH;"
151 "return $_;"
152 "}"
153
154 "sub destroy_package {"
155 "eval { $_[0]->UNLOAD() if $_[0]->can('UNLOAD'); };"
156 "Symbol::delete_package($_[0]);"
157 "}"
158
159 "sub load_n_eval {"
160 "my ($f_name, $package) = @_;"
161 "destroy_package($package);"
162 "my $strin=load_file($f_name);"
163 "return 2 if($strin eq \"__FAILED__\");"
164 "my $eval = qq{package $package; $strin;};"
165
166 "{"
167 " eval $eval;"
168 "}"
169
170 "if($@) {"
171 /*" #something went wrong\n"*/
172 "die(\"Errors loading file $f_name: $@\");"
173 "}"
174
175 "return 0;"
176 "}"
177 };
178
179 my_perl = perl_alloc();
180 PERL_SET_CONTEXT(my_perl);
181 PL_perl_destruct_level = 1;
182 perl_construct(my_perl);
183 #ifdef DEBUG
184 perl_parse(my_perl, xs_init, 4, perl_args, NULL);
185 #else
186 perl_parse(my_perl, xs_init, 3, perl_args, NULL);
187 #endif
188 #ifdef HAVE_PERL_EVAL_PV
189 eval_pv(perl_definitions, TRUE);
190 #else
191 perl_eval_pv(perl_definitions, TRUE); /* deprecated */
192 #endif
193 perl_run(my_perl);
194 }
195
196 static void
197 perl_end(void)
198 {
199 if (my_perl == NULL)
200 return;
201
202 PL_perl_destruct_level = 1;
203 PERL_SET_CONTEXT(my_perl);
204 perl_eval_pv(
205 "foreach my $lib (@DynaLoader::dl_modules) {"
206 "if ($lib =~ /^Gaim\\b/) {"
207 "$lib .= '::deinit();';"
208 "eval $lib;"
209 "}"
210 "}",
211 TRUE);
212
213 PL_perl_destruct_level = 1;
214 PERL_SET_CONTEXT(my_perl);
215 perl_destruct(my_perl);
216 perl_free(my_perl);
217 my_perl = NULL;
218 }
219
220 void
221 gaim_perl_callXS(void (*subaddr)(pTHX_ CV *cv), CV *cv, SV **mark)
222 {
223 dSP;
224
225 PUSHMARK(mark);
226 (*subaddr)(aTHX_ cv);
227
228 PUTBACK;
229 }
230
231 static gboolean
232 probe_perl_plugin(GaimPlugin *plugin)
233 {
234 /* XXX This would be much faster if I didn't create a new
235 * PerlInterpreter every time I probed a plugin */
236
237 PerlInterpreter *prober = perl_alloc();
238 char *argv[] = {"", plugin->path };
239 gboolean status = TRUE;
240 HV *plugin_info;
241 PERL_SET_CONTEXT(prober);
242 PL_perl_destruct_level = 1;
243 perl_construct(prober);
244
245 perl_parse(prober, xs_init, 2, argv, NULL);
246
247 perl_run(prober);
248
249 plugin_info = perl_get_hv("PLUGIN_INFO", FALSE);
250
251 if (plugin_info == NULL)
252 status = FALSE;
253 else if (!hv_exists(plugin_info, "perl_api_version",
254 strlen("perl_api_version")) ||
255 !hv_exists(plugin_info, "name", strlen("name")) ||
256 !hv_exists(plugin_info, "load", strlen("load"))) {
257 /* Not a valid plugin. */
258
259 status = FALSE;
260 } else {
261 SV **key;
262 int perl_api_ver;
263
264 key = hv_fetch(plugin_info, "perl_api_version",
265 strlen("perl_api_version"), 0);
266
267 perl_api_ver = SvIV(*key);
268
269 if (perl_api_ver != 2)
270 status = FALSE;
271 else {
272 GaimPluginInfo *info;
273 GaimPerlScript *gps;
274 char *basename;
275 STRLEN len;
276
277 gaim_debug(GAIM_DEBUG_INFO, "perl",
278 "Found plugin info\n");
279
280 info = g_new0(GaimPluginInfo, 1);
281 gps = g_new0(GaimPerlScript, 1);
282
283 info->magic = GAIM_PLUGIN_MAGIC;
284 info->major_version = GAIM_MAJOR_VERSION;
285 info->minor_version = GAIM_MINOR_VERSION;
286 info->type = GAIM_PLUGIN_STANDARD;
287
288 info->dependencies = g_list_append(info->dependencies,
289 PERL_PLUGIN_ID);
290
291 gps->plugin = plugin;
292
293 basename = g_path_get_basename(plugin->path);
294 gaim_perl_normalize_script_name(basename);
295 gps->package = g_strdup_printf("Gaim::Script::%s",
296 basename);
297 g_free(basename);
298
299 /* We know this one exists. */
300 key = hv_fetch(plugin_info, "name", strlen("name"), 0);
301 info->name = g_strdup(SvPV(*key, len));
302 /* Set id here in case we don't find one later. */
303 info->id = g_strdup(SvPV(*key, len));
304
305 if ((key = hv_fetch(plugin_info, "GTK_UI",
306 strlen("GTK_UI"), 0)))
307 info->ui_requirement = GAIM_GTK_PLUGIN_TYPE;
308
309 if ((key = hv_fetch(plugin_info, "url",
310 strlen("url"), 0)))
311 info->homepage = g_strdup(SvPV(*key, len));
312
313 if ((key = hv_fetch(plugin_info, "author",
314 strlen("author"), 0)))
315 info->author = g_strdup(SvPV(*key, len));
316
317 if ((key = hv_fetch(plugin_info, "summary",
318 strlen("summary"), 0)))
319 info->summary = g_strdup(SvPV(*key, len));
320
321 if ((key = hv_fetch(plugin_info, "description",
322 strlen("description"), 0)))
323 info->description = g_strdup(SvPV(*key, len));
324
325 if ((key = hv_fetch(plugin_info, "version",
326 strlen("version"), 0)))
327 info->version = g_strdup(SvPV(*key, len));
328
329 /* We know this one exists. */
330 key = hv_fetch(plugin_info, "load", strlen("load"), 0);
331 gps->load_sub = g_strdup_printf("%s::%s", gps->package,
332 SvPV(*key, len));
333
334 if ((key = hv_fetch(plugin_info, "unload",
335 strlen("unload"), 0)))
336 gps->unload_sub = g_strdup_printf("%s::%s",
337 gps->package,
338 SvPV(*key, len));
339
340 if ((key = hv_fetch(plugin_info, "id",
341 strlen("id"), 0))) {
342 g_free(info->id);
343 info->id = g_strdup_printf("perl-%s",
344 SvPV(*key, len));
345 }
346
347 /********************************************************/
348 /* Only one of the next two options should be present */
349 /* */
350 /* prefs_info - Uses non-GUI (read GTK) gaim API calls */
351 /* and creates a GaimPluginPrefInfo type. */
352 /* */
353 /* gtk_prefs_info - Requires gtk2-perl be installed by */
354 /* the user and he must create a */
355 /* GtkWidget the user and he must */
356 /* create a GtkWidget representing the */
357 /* plugin preferences page. */
358 /********************************************************/
359 if ((key = hv_fetch(plugin_info, "prefs_info",
360 strlen("prefs_info"), 0))) {
361 /* key now is the name of the Perl sub that
362 * will create a frame for us */
363 gps->prefs_sub = g_strdup_printf("%s::%s",
364 gps->package,
365 SvPV(*key, len));
366 info->prefs_info = &ui_info;
367 }
368
369 if ((key = hv_fetch(plugin_info, "gtk_prefs_info",
370 strlen("gtk_prefs_info"), 0))) {
371 /* key now is the name of the Perl sub that
372 * will create a frame for us */
373 gps->gtk_prefs_sub = g_strdup_printf("%s::%s",
374 gps->package,
375 SvPV(*key, len));
376 info->ui_info = &gtk_ui_info;
377 }
378
379 if ((key = hv_fetch(plugin_info, "plugin_action_sub",
380 strlen("plugin_action_sub"), 0))) {
381 gps->plugin_action_sub = g_strdup_printf("%s::%s",
382 gps->package,
383 SvPV(*key, len));
384 info->actions = gaim_perl_plugin_actions;
385 }
386
387 plugin->info = info;
388 info->extra_info = gps;
389
390 status = gaim_plugin_register(plugin);
391 }
392 }
393
394 PL_perl_destruct_level = 1;
395 PERL_SET_CONTEXT(prober);
396 perl_destruct(prober);
397 perl_free(prober);
398 return status;
399 }
400
401 static gboolean
402 load_perl_plugin(GaimPlugin *plugin)
403 {
404 GaimPerlScript *gps = (GaimPerlScript *)plugin->info->extra_info;
405 char *atmp[3] = { plugin->path, NULL, NULL };
406
407 if (gps == NULL || gps->load_sub == NULL)
408 return FALSE;
409
410 gaim_debug(GAIM_DEBUG_INFO, "perl", "Loading perl script\n");
411
412 if (my_perl == NULL)
413 perl_init();
414
415 plugin->handle = gps;
416
417 atmp[1] = gps->package;
418
419 PERL_SET_CONTEXT(my_perl);
420 execute_perl("Gaim::PerlLoader::load_n_eval", 2, atmp);
421
422 {
423 dSP;
424 PERL_SET_CONTEXT(my_perl);
425 SPAGAIN;
426 ENTER;
427 SAVETMPS;
428 PUSHMARK(sp);
429 XPUSHs(sv_2mortal(gaim_perl_bless_object(plugin,
430 "Gaim::Plugin")));
431 PUTBACK;
432
433 perl_call_pv(gps->load_sub, G_EVAL | G_SCALAR);
434 SPAGAIN;
435
436 if (SvTRUE(ERRSV)) {
437 STRLEN len;
438
439 gaim_debug(GAIM_DEBUG_ERROR, "perl",
440 "Perl function %s exited abnormally: %s\n",
441 gps->load_sub, SvPV(ERRSV, len));
442 }
443
444 PUTBACK;
445 FREETMPS;
446 LEAVE;
447 }
448
449 return TRUE;
450 }
451
452 static void
453 destroy_package(const char *package)
454 {
455 dSP;
456 PERL_SET_CONTEXT(my_perl);
457 SPAGAIN;
458
459 ENTER;
460 SAVETMPS;
461
462 PUSHMARK(SP);
463 XPUSHs(sv_2mortal(newSVpv(package, strlen(package))));
464 PUTBACK;
465
466 perl_call_pv("Gaim::PerlLoader::destroy_package",
467 G_VOID | G_EVAL | G_DISCARD);
468
469 SPAGAIN;
470
471 PUTBACK;
472 FREETMPS;
473 LEAVE;
474 }
475
476 static gboolean
477 unload_perl_plugin(GaimPlugin *plugin)
478 {
479 GaimPerlScript *gps = (GaimPerlScript *)plugin->info->extra_info;
480
481 if (gps == NULL)
482 return FALSE;
483
484 gaim_debug(GAIM_DEBUG_INFO, "perl", "Unloading perl script\n");
485
486 if (gps->unload_sub != NULL) {
487 dSP;
488 PERL_SET_CONTEXT(my_perl);
489 SPAGAIN;
490 ENTER;
491 SAVETMPS;
492 PUSHMARK(sp);
493 XPUSHs(sv_2mortal(gaim_perl_bless_object(plugin,
494 "Gaim::Plugin")));
495 PUTBACK;
496
497 perl_call_pv(gps->unload_sub, G_EVAL | G_SCALAR);
498 SPAGAIN;
499
500 if (SvTRUE(ERRSV)) {
501 STRLEN len;
502
503 gaim_debug(GAIM_DEBUG_ERROR, "perl",
504 "Perl function %s exited abnormally: %s\n",
505 gps->load_sub, SvPV(ERRSV, len));
506 }
507
508 PUTBACK;
509 FREETMPS;
510 LEAVE;
511 }
512
513 gaim_perl_cmd_clear_for_plugin(plugin);
514 gaim_perl_signal_clear_for_plugin(plugin);
515 gaim_perl_timeout_clear_for_plugin(plugin);
516
517 destroy_package(gps->package);
518
519 return TRUE;
520 }
521
522 static void
523 destroy_perl_plugin(GaimPlugin *plugin)
524 {
525 if (plugin->info != NULL) {
526 GaimPerlScript *gps;
527
528 g_free(plugin->info->name);
529 g_free(plugin->info->version);
530 g_free(plugin->info->summary);
531 g_free(plugin->info->description);
532 g_free(plugin->info->author);
533 g_free(plugin->info->homepage);
534
535 gps = (GaimPerlScript *)plugin->info->extra_info;
536 if (gps != NULL) {
537 g_free(gps->load_sub);
538 g_free(gps->unload_sub);
539 g_free(gps->package);
540 g_free(gps->prefs_sub);
541 g_free(gps->gtk_prefs_sub);
542 g_free(gps);
543 plugin->info->extra_info = NULL;
544 }
545 }
546 }
547
548 static gboolean
549 plugin_load(GaimPlugin *plugin)
550 {
551 return TRUE;
552 }
553
554 static gboolean
555 plugin_unload(GaimPlugin *plugin)
556 {
557 perl_end();
558
559 return TRUE;
560 }
561
562 static GaimPluginLoaderInfo loader_info =
563 {
564 NULL, /**< exts */
565 probe_perl_plugin, /**< probe */
566 load_perl_plugin, /**< load */
567 unload_perl_plugin, /**< unload */
568 destroy_perl_plugin /**< destroy */
569 };
570
571 static GaimPluginInfo info =
572 {
573 GAIM_PLUGIN_MAGIC,
574 GAIM_MAJOR_VERSION,
575 GAIM_MINOR_VERSION,
576 GAIM_PLUGIN_LOADER, /**< type */
577 NULL, /**< ui_requirement */
578 0, /**< flags */
579 NULL, /**< dependencies */
580 GAIM_PRIORITY_DEFAULT, /**< priority */
581
582 PERL_PLUGIN_ID, /**< id */
583 N_("Perl Plugin Loader"), /**< name */
584 VERSION, /**< version */
585 N_("Provides support for loading perl plugins."), /**< summary */
586 N_("Provides support for loading perl plugins."), /**< description */
587 "Christian Hammond <chipx86@gnupdate.org>", /**< author */
588 GAIM_WEBSITE, /**< homepage */
589
590 plugin_load, /**< load */
591 plugin_unload, /**< unload */
592 NULL, /**< destroy */
593
594 NULL, /**< ui_info */
595 &loader_info, /**< extra_info */
596 NULL,
597 NULL
598 };
599
600 static void
601 init_plugin(GaimPlugin *plugin)
602 {
603 loader_info.exts = g_list_append(loader_info.exts, "pl");
604 }
605
606 GAIM_INIT_PLUGIN(perl, init_plugin, info)

Mercurial Repository: pidgin3

mercurial