Mercurial > pidgin3 / file comparison

comparison: libpurple/plugins/perl/perl.c

libpurple/plugins/perl/perl.c

changeset 15435
4b933b06d75e
parent 14779
1b71da367f56
child 15884
4de1981757fc
equal deleted inserted replaced
15434:94dcf9e39d66 15435:4b933b06d75e
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 #ifdef GAIM_GTKPERL
108 static GaimGtkPluginUiInfo gtk_ui_info =
109 {
110 gaim_perl_gtk_get_plugin_frame,
111 0 /* page_num (Reserved) */
112 };
113 #endif
114
115 static void
116 #ifdef OLD_PERL
117 xs_init()
118 #else
119 xs_init(pTHX)
120 #endif
121 {
122 char *file = __FILE__;
123
124 /* This one allows dynamic loading of perl modules in perl scripts by
125 * the 'use perlmod;' construction */
126 newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);
127 }
128
129 static void
130 perl_init(void)
131 {
132 /* changed the name of the variable from load_file to perl_definitions
133 * since now it does much more than defining the load_file sub.
134 * Moreover, deplaced the initialisation to the xs_init function.
135 * (TheHobbit) */
136 char *perl_args[] = { "", "-e", "0", "-w" };
137 char perl_definitions[] =
138 {
139 /* We use to function one to load a file the other to execute
140 * the string obtained from the first and holding the file
141 * contents. This allows to have a really local $/ without
142 * introducing temp variables to hold the old value. Just a
143 * question of style:) */
144 "package Gaim::PerlLoader;"
145 "use Symbol;"
146
147 "sub load_file {"
148 "my $f_name=shift;"
149 "local $/=undef;"
150 "open FH,$f_name or return \"__FAILED__\";"
151 "$_=<FH>;"
152 "close FH;"
153 "return $_;"
154 "}"
155
156 "sub destroy_package {"
157 "eval { $_[0]->UNLOAD() if $_[0]->can('UNLOAD'); };"
158 "Symbol::delete_package($_[0]);"
159 "}"
160
161 "sub load_n_eval {"
162 "my ($f_name, $package) = @_;"
163 "destroy_package($package);"
164 "my $strin=load_file($f_name);"
165 "return 2 if($strin eq \"__FAILED__\");"
166 "my $eval = qq{package $package; $strin;};"
167
168 "{"
169 " eval $eval;"
170 "}"
171
172 "if($@) {"
173 /*" #something went wrong\n"*/
174 "die(\"Errors loading file $f_name: $@\");"
175 "}"
176
177 "return 0;"
178 "}"
179 };
180
181 my_perl = perl_alloc();
182 PERL_SET_CONTEXT(my_perl);
183 PL_perl_destruct_level = 1;
184 perl_construct(my_perl);
185 #ifdef DEBUG
186 perl_parse(my_perl, xs_init, 4, perl_args, NULL);
187 #else
188 perl_parse(my_perl, xs_init, 3, perl_args, NULL);
189 #endif
190 #ifdef HAVE_PERL_EVAL_PV
191 eval_pv(perl_definitions, TRUE);
192 #else
193 perl_eval_pv(perl_definitions, TRUE); /* deprecated */
194 #endif
195 perl_run(my_perl);
196 }
197
198 static void
199 perl_end(void)
200 {
201 if (my_perl == NULL)
202 return;
203
204 PL_perl_destruct_level = 1;
205 PERL_SET_CONTEXT(my_perl);
206 perl_eval_pv(
207 "foreach my $lib (@DynaLoader::dl_modules) {"
208 "if ($lib =~ /^Gaim\\b/) {"
209 "$lib .= '::deinit();';"
210 "eval $lib;"
211 "}"
212 "}",
213 TRUE);
214
215 PL_perl_destruct_level = 1;
216 PERL_SET_CONTEXT(my_perl);
217 perl_destruct(my_perl);
218 perl_free(my_perl);
219 my_perl = NULL;
220 }
221
222 void
223 gaim_perl_callXS(void (*subaddr)(pTHX_ CV *cv), CV *cv, SV **mark)
224 {
225 dSP;
226
227 PUSHMARK(mark);
228 (*subaddr)(aTHX_ cv);
229
230 PUTBACK;
231 }
232
233 static gboolean
234 probe_perl_plugin(GaimPlugin *plugin)
235 {
236 /* XXX This would be much faster if I didn't create a new
237 * PerlInterpreter every time I probed a plugin */
238
239 PerlInterpreter *prober = perl_alloc();
240 char *argv[] = {"", plugin->path };
241 gboolean status = TRUE;
242 HV *plugin_info;
243 PERL_SET_CONTEXT(prober);
244 PL_perl_destruct_level = 1;
245 perl_construct(prober);
246
247 perl_parse(prober, xs_init, 2, argv, NULL);
248
249 perl_run(prober);
250
251 plugin_info = perl_get_hv("PLUGIN_INFO", FALSE);
252
253 if (plugin_info == NULL)
254 status = FALSE;
255 else if (!hv_exists(plugin_info, "perl_api_version",
256 strlen("perl_api_version")) ||
257 !hv_exists(plugin_info, "name", strlen("name")) ||
258 !hv_exists(plugin_info, "load", strlen("load"))) {
259 /* Not a valid plugin. */
260
261 status = FALSE;
262 } else {
263 SV **key;
264 int perl_api_ver;
265
266 key = hv_fetch(plugin_info, "perl_api_version",
267 strlen("perl_api_version"), 0);
268
269 perl_api_ver = SvIV(*key);
270
271 if (perl_api_ver != 2)
272 status = FALSE;
273 else {
274 GaimPluginInfo *info;
275 GaimPerlScript *gps;
276 char *basename;
277 STRLEN len;
278
279 info = g_new0(GaimPluginInfo, 1);
280 gps = g_new0(GaimPerlScript, 1);
281
282 info->magic = GAIM_PLUGIN_MAGIC;
283 info->major_version = GAIM_MAJOR_VERSION;
284 info->minor_version = GAIM_MINOR_VERSION;
285 info->type = GAIM_PLUGIN_STANDARD;
286
287 info->dependencies = g_list_append(info->dependencies,
288 PERL_PLUGIN_ID);
289
290 gps->plugin = plugin;
291
292 basename = g_path_get_basename(plugin->path);
293 gaim_perl_normalize_script_name(basename);
294 gps->package = g_strdup_printf("Gaim::Script::%s",
295 basename);
296 g_free(basename);
297
298 /* We know this one exists. */
299 key = hv_fetch(plugin_info, "name", strlen("name"), 0);
300 info->name = g_strdup(SvPV(*key, len));
301 /* Set id here in case we don't find one later. */
302 info->id = g_strdup(SvPV(*key, len));
303
304 #ifdef GAIM_GTKPERL
305 if ((key = hv_fetch(plugin_info, "GTK_UI",
306 strlen("GTK_UI"), 0)))
307 info->ui_requirement = GAIM_GTK_PLUGIN_TYPE;
308 #endif
309
310 if ((key = hv_fetch(plugin_info, "url",
311 strlen("url"), 0)))
312 info->homepage = g_strdup(SvPV(*key, len));
313
314 if ((key = hv_fetch(plugin_info, "author",
315 strlen("author"), 0)))
316 info->author = g_strdup(SvPV(*key, len));
317
318 if ((key = hv_fetch(plugin_info, "summary",
319 strlen("summary"), 0)))
320 info->summary = g_strdup(SvPV(*key, len));
321
322 if ((key = hv_fetch(plugin_info, "description",
323 strlen("description"), 0)))
324 info->description = g_strdup(SvPV(*key, len));
325
326 if ((key = hv_fetch(plugin_info, "version",
327 strlen("version"), 0)))
328 info->version = g_strdup(SvPV(*key, len));
329
330 /* We know this one exists. */
331 key = hv_fetch(plugin_info, "load", strlen("load"), 0);
332 gps->load_sub = g_strdup_printf("%s::%s", gps->package,
333 SvPV(*key, len));
334
335 if ((key = hv_fetch(plugin_info, "unload",
336 strlen("unload"), 0)))
337 gps->unload_sub = g_strdup_printf("%s::%s",
338 gps->package,
339 SvPV(*key, len));
340
341 if ((key = hv_fetch(plugin_info, "id",
342 strlen("id"), 0))) {
343 g_free(info->id);
344 info->id = g_strdup_printf("perl-%s",
345 SvPV(*key, len));
346 }
347
348 /********************************************************/
349 /* Only one of the next two options should be present */
350 /* */
351 /* prefs_info - Uses non-GUI (read GTK) gaim API calls */
352 /* and creates a GaimPluginPrefInfo type. */
353 /* */
354 /* gtk_prefs_info - Requires gtk2-perl be installed by */
355 /* the user and he must create a */
356 /* GtkWidget the user and he must */
357 /* create a GtkWidget representing the */
358 /* plugin preferences page. */
359 /********************************************************/
360 if ((key = hv_fetch(plugin_info, "prefs_info",
361 strlen("prefs_info"), 0))) {
362 /* key now is the name of the Perl sub that
363 * will create a frame for us */
364 gps->prefs_sub = g_strdup_printf("%s::%s",
365 gps->package,
366 SvPV(*key, len));
367 info->prefs_info = &ui_info;
368 }
369
370 #ifdef GAIM_GTKPERL
371 if ((key = hv_fetch(plugin_info, "gtk_prefs_info",
372 strlen("gtk_prefs_info"), 0))) {
373 /* key now is the name of the Perl sub that
374 * will create a frame for us */
375 gps->gtk_prefs_sub = g_strdup_printf("%s::%s",
376 gps->package,
377 SvPV(*key, len));
378 info->ui_info = &gtk_ui_info;
379 }
380 #endif
381
382 if ((key = hv_fetch(plugin_info, "plugin_action_sub",
383 strlen("plugin_action_sub"), 0))) {
384 gps->plugin_action_sub = g_strdup_printf("%s::%s",
385 gps->package,
386 SvPV(*key, len));
387 info->actions = gaim_perl_plugin_actions;
388 }
389
390 plugin->info = info;
391 info->extra_info = gps;
392
393 status = gaim_plugin_register(plugin);
394 }
395 }
396
397 PL_perl_destruct_level = 1;
398 PERL_SET_CONTEXT(prober);
399 perl_destruct(prober);
400 perl_free(prober);
401 return status;
402 }
403
404 static gboolean
405 load_perl_plugin(GaimPlugin *plugin)
406 {
407 GaimPerlScript *gps = (GaimPerlScript *)plugin->info->extra_info;
408 char *atmp[3] = { plugin->path, NULL, NULL };
409
410 if (gps == NULL || gps->load_sub == NULL)
411 return FALSE;
412
413 gaim_debug(GAIM_DEBUG_INFO, "perl", "Loading perl script\n");
414
415 if (my_perl == NULL)
416 perl_init();
417
418 plugin->handle = gps;
419
420 atmp[1] = gps->package;
421
422 PERL_SET_CONTEXT(my_perl);
423 execute_perl("Gaim::PerlLoader::load_n_eval", 2, atmp);
424
425 {
426 dSP;
427 PERL_SET_CONTEXT(my_perl);
428 SPAGAIN;
429 ENTER;
430 SAVETMPS;
431 PUSHMARK(sp);
432 XPUSHs(sv_2mortal(gaim_perl_bless_object(plugin,
433 "Gaim::Plugin")));
434 PUTBACK;
435
436 perl_call_pv(gps->load_sub, G_EVAL | G_SCALAR);
437 SPAGAIN;
438
439 if (SvTRUE(ERRSV)) {
440 STRLEN len;
441
442 gaim_debug(GAIM_DEBUG_ERROR, "perl",
443 "Perl function %s exited abnormally: %s\n",
444 gps->load_sub, SvPV(ERRSV, len));
445 }
446
447 PUTBACK;
448 FREETMPS;
449 LEAVE;
450 }
451
452 return TRUE;
453 }
454
455 static void
456 destroy_package(const char *package)
457 {
458 dSP;
459 PERL_SET_CONTEXT(my_perl);
460 SPAGAIN;
461
462 ENTER;
463 SAVETMPS;
464
465 PUSHMARK(SP);
466 XPUSHs(sv_2mortal(newSVpv(package, strlen(package))));
467 PUTBACK;
468
469 perl_call_pv("Gaim::PerlLoader::destroy_package",
470 G_VOID | G_EVAL | G_DISCARD);
471
472 SPAGAIN;
473
474 PUTBACK;
475 FREETMPS;
476 LEAVE;
477 }
478
479 static gboolean
480 unload_perl_plugin(GaimPlugin *plugin)
481 {
482 GaimPerlScript *gps = (GaimPerlScript *)plugin->info->extra_info;
483
484 if (gps == NULL)
485 return FALSE;
486
487 gaim_debug(GAIM_DEBUG_INFO, "perl", "Unloading perl script\n");
488
489 if (gps->unload_sub != NULL) {
490 dSP;
491 PERL_SET_CONTEXT(my_perl);
492 SPAGAIN;
493 ENTER;
494 SAVETMPS;
495 PUSHMARK(sp);
496 XPUSHs(sv_2mortal(gaim_perl_bless_object(plugin,
497 "Gaim::Plugin")));
498 PUTBACK;
499
500 perl_call_pv(gps->unload_sub, G_EVAL | G_SCALAR);
501 SPAGAIN;
502
503 if (SvTRUE(ERRSV)) {
504 STRLEN len;
505
506 gaim_debug(GAIM_DEBUG_ERROR, "perl",
507 "Perl function %s exited abnormally: %s\n",
508 gps->load_sub, SvPV(ERRSV, len));
509 }
510
511 PUTBACK;
512 FREETMPS;
513 LEAVE;
514 }
515
516 gaim_perl_cmd_clear_for_plugin(plugin);
517 gaim_perl_signal_clear_for_plugin(plugin);
518 gaim_perl_timeout_clear_for_plugin(plugin);
519
520 destroy_package(gps->package);
521
522 return TRUE;
523 }
524
525 static void
526 destroy_perl_plugin(GaimPlugin *plugin)
527 {
528 if (plugin->info != NULL) {
529 GaimPerlScript *gps;
530
531 g_free(plugin->info->name);
532 g_free(plugin->info->version);
533 g_free(plugin->info->summary);
534 g_free(plugin->info->description);
535 g_free(plugin->info->author);
536 g_free(plugin->info->homepage);
537
538 gps = (GaimPerlScript *)plugin->info->extra_info;
539 if (gps != NULL) {
540 g_free(gps->load_sub);
541 g_free(gps->unload_sub);
542 g_free(gps->package);
543 g_free(gps->prefs_sub);
544 #ifdef GAIM_GTKPERL
545 g_free(gps->gtk_prefs_sub);
546 #endif
547 g_free(gps);
548 plugin->info->extra_info = NULL;
549 }
550 }
551 }
552
553 static gboolean
554 plugin_load(GaimPlugin *plugin)
555 {
556 return TRUE;
557 }
558
559 static gboolean
560 plugin_unload(GaimPlugin *plugin)
561 {
562 perl_end();
563
564 return TRUE;
565 }
566
567 static GaimPluginLoaderInfo loader_info =
568 {
569 NULL, /**< exts */
570 probe_perl_plugin, /**< probe */
571 load_perl_plugin, /**< load */
572 unload_perl_plugin, /**< unload */
573 destroy_perl_plugin /**< destroy */
574 };
575
576 static GaimPluginInfo info =
577 {
578 GAIM_PLUGIN_MAGIC,
579 GAIM_MAJOR_VERSION,
580 GAIM_MINOR_VERSION,
581 GAIM_PLUGIN_LOADER, /**< type */
582 NULL, /**< ui_requirement */
583 0, /**< flags */
584 NULL, /**< dependencies */
585 GAIM_PRIORITY_DEFAULT, /**< priority */
586
587 PERL_PLUGIN_ID, /**< id */
588 N_("Perl Plugin Loader"), /**< name */
589 VERSION, /**< version */
590 N_("Provides support for loading perl plugins."), /**< summary */
591 N_("Provides support for loading perl plugins."), /**< description */
592 "Christian Hammond <chipx86@gnupdate.org>", /**< author */
593 GAIM_WEBSITE, /**< homepage */
594
595 plugin_load, /**< load */
596 plugin_unload, /**< unload */
597 NULL, /**< destroy */
598
599 NULL, /**< ui_info */
600 &loader_info, /**< extra_info */
601 NULL,
602 NULL
603 };
604
605 static void
606 init_plugin(GaimPlugin *plugin)
607 {
608 loader_info.exts = g_list_append(loader_info.exts, "pl");
609 }
610
611 GAIM_INIT_PLUGIN(perl, init_plugin, info)

Mercurial Repository: pidgin3

mercurial