1 /*
2 * purple
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., 51 Franklin Street, Fifth Floor, Boston, MA 02111-1301 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 #define SILENT_NO_TAINT_SUPPORT 0
52 #define NO_TAINT_SUPPORT 0
53
54 #include <perl.h>
55 #include <XSUB.h>
56
57 #ifndef _WIN32
58 # include <sys/mman.h>
59 #endif
60
61 #undef PACKAGE
62
63 #ifndef _WIN32
64 # include <dirent.h>
65 #else
66 /* We're using perl's win32 port of this */
67 # define dirent direct
68 #endif
69
70 #undef group
71
72 /* perl module support */
73 #ifdef _WIN32
74 EXTERN_C void boot_Win32CORE (pTHX_ CV* cv);
75 #endif
76
77 #ifdef OLD_PERL
78 extern void boot_DynaLoader _((CV * cv));
79 #else
80 extern void boot_DynaLoader _((pTHX_ CV * cv)); /* perl is so wacky */
81 #endif
82
83 #undef _
84 #ifdef DEBUG
85 # undef DEBUG
86 #endif
87 #ifdef _WIN32
88 # undef pipe
89 #endif
90
91 #ifdef _WIN32
92 #define _WIN32DEP_H_
93 #endif
94 #include "internal.h"
95 #include "debug.h"
96 #include "plugin.h"
97 #include "signals.h"
98 #include "version.h"
99
100 #include "perl-common.h"
101 #include "perl-handlers.h"
102
103 #include <gmodule.h>
104
105 #define PERL_PLUGIN_ID "core-perl"
106
107 PerlInterpreter *my_perl = NULL;
108
109 static PurplePluginUiInfo ui_info =
110 {
111 purple_perl_get_plugin_frame,
112 0, /* page_num (Reserved) */
113 NULL, /* frame (Reserved) */
114 /* Padding */
115 NULL,
116 NULL,
117 NULL,
118 NULL
119 };
120
121 #ifdef PURPLE_GTKPERL
122 static PurpleGtkPluginUiInfo gtk_ui_info =
123 {
124 purple_perl_gtk_get_plugin_frame,
125 0 /* page_num (Reserved) */
126 };
127 #endif
128
129 static void
130 #ifdef OLD_PERL
xs_init()131 xs_init()
132 #else
133 xs_init(pTHX)
134 #endif
135 {
136 char *file = __FILE__;
137 GList *search_paths = purple_plugins_get_search_paths();
138 dXSUB_SYS;
139
140 /* This one allows dynamic loading of perl modules in perl scripts by
141 * the 'use perlmod;' construction */
142 newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);
143 #ifdef _WIN32
144 newXS("Win32CORE::bootstrap", boot_Win32CORE, file);
145 #endif
146
147 while (search_paths != NULL) {
148 gchar *uselib;
149 const gchar *search_path = search_paths->data;
150 search_paths = g_list_next(search_paths);
151
152 uselib = g_strdup_printf("unshift @INC, q(%s%sperl);",
153 search_path, G_DIR_SEPARATOR_S);
154 eval_pv(uselib, TRUE);
155 g_free(uselib);
156 }
157 }
158
159 static void
perl_init(void)160 perl_init(void)
161 {
162 /* changed the name of the variable from load_file to perl_definitions
163 * since now it does much more than defining the load_file sub.
164 * Moreover, deplaced the initialisation to the xs_init function.
165 * (TheHobbit) */
166 char *perl_args[] = { "", "-e", "0", "-w" };
167 char perl_definitions[] =
168 {
169 /* We use to function one to load a file the other to execute
170 * the string obtained from the first and holding the file
171 * contents. This allows to have a really local $/ without
172 * introducing temp variables to hold the old value. Just a
173 * question of style:) */
174 "package Purple::PerlLoader;"
175 "use Symbol;"
176
177 "sub load_file {"
178 "my $f_name=shift;"
179 "local $/=undef;"
180 "open FH,$f_name or return \"__FAILED__\";"
181 "$_=<FH>;"
182 "close FH;"
183 "return $_;"
184 "}"
185
186 "sub destroy_package {"
187 "eval { $_[0]->UNLOAD() if $_[0]->can('UNLOAD'); };"
188 "Symbol::delete_package($_[0]);"
189 "}"
190
191 "sub load_n_eval {"
192 "my ($f_name, $package) = @_;"
193 "destroy_package($package);"
194 "my $strin=load_file($f_name);"
195 "return 2 if($strin eq \"__FAILED__\");"
196 "my $eval = qq{package $package; $strin;};"
197
198 "{"
199 " eval $eval;"
200 "}"
201
202 "if($@) {"
203 /*" #something went wrong\n"*/
204 "die(\"Errors loading file $f_name: $@\");"
205 "}"
206
207 "return 0;"
208 "}"
209 };
210
211 my_perl = perl_alloc();
212 PERL_SET_CONTEXT(my_perl);
213 PL_perl_destruct_level = 1;
214 perl_construct(my_perl);
215 #ifdef DEBUG
216 perl_parse(my_perl, xs_init, 4, perl_args, NULL);
217 #else
218 perl_parse(my_perl, xs_init, 3, perl_args, NULL);
219 #endif
220 #ifdef HAVE_PERL_EVAL_PV
221 eval_pv(perl_definitions, TRUE);
222 #else
223 perl_eval_pv(perl_definitions, TRUE); /* deprecated */
224 #endif
225 perl_run(my_perl);
226 }
227
228 static void
perl_end(void)229 perl_end(void)
230 {
231 if (my_perl == NULL)
232 return;
233
234 PL_perl_destruct_level = 1;
235 PERL_SET_CONTEXT(my_perl);
236 perl_eval_pv(
237 "foreach my $lib (@DynaLoader::dl_modules) {"
238 "if ($lib =~ /^Purple\\b/) {"
239 "$lib .= '::deinit();';"
240 "eval $lib;"
241 "}"
242 "}",
243 TRUE);
244
245 PL_perl_destruct_level = 1;
246 PERL_SET_CONTEXT(my_perl);
247 perl_destruct(my_perl);
248 perl_free(my_perl);
249 my_perl = NULL;
250 }
251
252 void
purple_perl_callXS(void (* subaddr)(pTHX_ CV * cv),CV * cv,SV ** mark)253 purple_perl_callXS(void (*subaddr)(pTHX_ CV *cv), CV *cv, SV **mark)
254 {
255 dSP;
256
257 PUSHMARK(mark);
258 (*subaddr)(aTHX_ cv);
259
260 PUTBACK;
261 }
262
263 static gboolean
probe_perl_plugin(PurplePlugin * plugin)264 probe_perl_plugin(PurplePlugin *plugin)
265 {
266
267 char *args[] = {"", plugin->path };
268 char **argv = args;
269 int argc = 2, ret;
270 PerlInterpreter *prober;
271 gboolean status = TRUE;
272 HV *plugin_info;
273
274 PERL_SYS_INIT(&argc, &argv);
275
276 /* XXX This would be much faster if we didn't create a new
277 * PerlInterpreter every time we probe a plugin */
278 prober = perl_alloc();
279
280 PERL_SET_CONTEXT(prober);
281
282 PL_perl_destruct_level = 1;
283 perl_construct(prober);
284
285 /* Fix IO redirection to match where pidgin's is going.
286 * Without this, we lose stdout/stderr unless we redirect to a file */
287 #ifdef _WIN32
288 {
289 PerlIO* newprlIO = PerlIO_open("CONOUT$", "w");
290 if (newprlIO) {
291 int stdout_fd = PerlIO_fileno(PerlIO_stdout());
292 int stderr_fd = PerlIO_fileno(PerlIO_stderr());
293 PerlIO_close(PerlIO_stdout());
294 PerlIO_close(PerlIO_stderr());
295 PerlLIO_dup2(PerlIO_fileno(newprlIO), stdout_fd);
296 PerlLIO_dup2(PerlIO_fileno(newprlIO), stderr_fd);
297
298 PerlIO_close(newprlIO);
299 }
300 }
301 #endif
302
303 ret = perl_parse(prober, xs_init, argc, argv, NULL);
304
305 if (ret != 0) {
306 const char * errmsg = "Unknown error";
307 if (SvTRUE(ERRSV))
308 errmsg = SvPVutf8_nolen(ERRSV);
309 purple_debug_error("perl", "Unable to parse plugin %s (%d:%s)\n",
310 plugin->path, ret, errmsg);
311 status = FALSE;
312 goto cleanup;
313 }
314
315 ret = perl_run(prober);
316
317 if (ret != 0) {
318 const char * errmsg = "Unknown error";
319 if (SvTRUE(ERRSV))
320 errmsg = SvPVutf8_nolen(ERRSV);
321 purple_debug_error("perl", "Unable to run perl interpreter on plugin %s (%d:%s)\n",
322 plugin->path, ret, errmsg);
323 status = FALSE;
324 goto cleanup;
325 }
326
327 plugin_info = perl_get_hv("PLUGIN_INFO", FALSE);
328
329 if (plugin_info == NULL)
330 status = FALSE;
331 else if (!hv_exists(plugin_info, "perl_api_version",
332 strlen("perl_api_version")) ||
333 !hv_exists(plugin_info, "name", strlen("name")) ||
334 !hv_exists(plugin_info, "load", strlen("load"))) {
335 /* Not a valid plugin. */
336
337 status = FALSE;
338 } else {
339 SV **key;
340 int perl_api_ver;
341
342 key = hv_fetch(plugin_info, "perl_api_version",
343 strlen("perl_api_version"), 0);
344
345 perl_api_ver = SvIV(*key);
346
347 if (perl_api_ver != 2)
348 status = FALSE;
349 else {
350 PurplePluginInfo *info;
351 PurplePerlScript *gps;
352 char *basename;
353
354 info = g_new0(PurplePluginInfo, 1);
355 gps = g_new0(PurplePerlScript, 1);
356
357 info->magic = PURPLE_PLUGIN_MAGIC;
358 info->major_version = PURPLE_MAJOR_VERSION;
359 info->minor_version = PURPLE_MINOR_VERSION;
360 info->type = PURPLE_PLUGIN_STANDARD;
361
362 info->dependencies = g_list_append(info->dependencies,
363 PERL_PLUGIN_ID);
364
365 gps->plugin = plugin;
366
367 basename = g_path_get_basename(plugin->path);
368 purple_perl_normalize_script_name(basename);
369 gps->package = g_strdup_printf("Purple::Script::%s",
370 basename);
371 g_free(basename);
372
373 /* We know this one exists. */
374 key = hv_fetch(plugin_info, "name", strlen("name"), 0);
375 info->name = g_strdup(SvPVutf8_nolen(*key));
376 /* Set id here in case we don't find one later. */
377 info->id = g_strdup(info->name);
378
379 #ifdef PURPLE_GTKPERL
380 if ((key = hv_fetch(plugin_info, "GTK_UI",
381 strlen("GTK_UI"), 0)))
382 info->ui_requirement = PURPLE_GTK_PLUGIN_TYPE;
383 #endif
384
385 if ((key = hv_fetch(plugin_info, "url",
386 strlen("url"), 0)))
387 info->homepage = g_strdup(SvPVutf8_nolen(*key));
388
389 if ((key = hv_fetch(plugin_info, "author",
390 strlen("author"), 0)))
391 info->author = g_strdup(SvPVutf8_nolen(*key));
392
393 if ((key = hv_fetch(plugin_info, "summary",
394 strlen("summary"), 0)))
395 info->summary = g_strdup(SvPVutf8_nolen(*key));
396
397 if ((key = hv_fetch(plugin_info, "description",
398 strlen("description"), 0)))
399 info->description = g_strdup(SvPVutf8_nolen(*key));
400
401 if ((key = hv_fetch(plugin_info, "version",
402 strlen("version"), 0)))
403 info->version = g_strdup(SvPVutf8_nolen(*key));
404
405 /* We know this one exists. */
406 key = hv_fetch(plugin_info, "load", strlen("load"), 0);
407 gps->load_sub = g_strdup_printf("%s::%s", gps->package,
408 SvPVutf8_nolen(*key));
409
410 if ((key = hv_fetch(plugin_info, "unload",
411 strlen("unload"), 0)))
412 gps->unload_sub = g_strdup_printf("%s::%s",
413 gps->package,
414 SvPVutf8_nolen(*key));
415
416 if ((key = hv_fetch(plugin_info, "id",
417 strlen("id"), 0))) {
418 g_free(info->id);
419 info->id = g_strdup_printf("perl-%s",
420 SvPVutf8_nolen(*key));
421 }
422
423 /********************************************************/
424 /* Only one of the next two options should be present */
425 /* */
426 /* prefs_info - Uses non-GUI (read GTK) purple API calls */
427 /* and creates a PurplePluginPrefInfo type. */
428 /* */
429 /* gtk_prefs_info - Requires gtk2-perl be installed by */
430 /* the user and he must create a */
431 /* GtkWidget the user and he must */
432 /* create a GtkWidget representing the */
433 /* plugin preferences page. */
434 /********************************************************/
435 if ((key = hv_fetch(plugin_info, "prefs_info",
436 strlen("prefs_info"), 0))) {
437 /* key now is the name of the Perl sub that
438 * will create a frame for us */
439 gps->prefs_sub = g_strdup_printf("%s::%s",
440 gps->package,
441 SvPVutf8_nolen(*key));
442 info->prefs_info = &ui_info;
443 }
444
445 #ifdef PURPLE_GTKPERL
446 if ((key = hv_fetch(plugin_info, "gtk_prefs_info",
447 strlen("gtk_prefs_info"), 0))) {
448 /* key now is the name of the Perl sub that
449 * will create a frame for us */
450 gps->gtk_prefs_sub = g_strdup_printf("%s::%s",
451 gps->package,
452 SvPVutf8_nolen(*key));
453 info->ui_info = >k_ui_info;
454 }
455 #endif
456
457 if ((key = hv_fetch(plugin_info, "plugin_action_sub",
458 strlen("plugin_action_sub"), 0))) {
459 gps->plugin_action_sub = g_strdup_printf("%s::%s",
460 gps->package,
461 SvPVutf8_nolen(*key));
462 info->actions = purple_perl_plugin_actions;
463 }
464
465 plugin->info = info;
466 info->extra_info = gps;
467
468 status = purple_plugin_register(plugin);
469 }
470 }
471
472 cleanup:
473 PL_perl_destruct_level = 1;
474 PERL_SET_CONTEXT(prober);
475 perl_destruct(prober);
476 perl_free(prober);
477 return status;
478 }
479
480 static gboolean
load_perl_plugin(PurplePlugin * plugin)481 load_perl_plugin(PurplePlugin *plugin)
482 {
483 PurplePerlScript *gps = (PurplePerlScript *)plugin->info->extra_info;
484 gboolean loaded = TRUE;
485 char *atmp[3] = { plugin->path, NULL, NULL };
486
487 if (gps == NULL || gps->load_sub == NULL)
488 return FALSE;
489
490 purple_debug(PURPLE_DEBUG_INFO, "perl", "Loading perl script\n");
491
492 if (my_perl == NULL)
493 perl_init();
494
495 plugin->handle = gps;
496
497 atmp[1] = gps->package;
498
499 PERL_SET_CONTEXT(my_perl);
500 execute_perl("Purple::PerlLoader::load_n_eval", 2, atmp);
501
502 {
503 dSP;
504 PERL_SET_CONTEXT(my_perl);
505 SPAGAIN;
506 ENTER;
507 SAVETMPS;
508 PUSHMARK(sp);
509 XPUSHs(sv_2mortal(purple_perl_bless_object(plugin,
510 "Purple::Plugin")));
511 PUTBACK;
512
513 perl_call_pv(gps->load_sub, G_EVAL | G_SCALAR);
514 SPAGAIN;
515
516 if (SvTRUE(ERRSV)) {
517 purple_debug(PURPLE_DEBUG_ERROR, "perl",
518 "Perl function %s exited abnormally: %s\n",
519 gps->load_sub, SvPVutf8_nolen(ERRSV));
520 loaded = FALSE;
521 }
522
523 PUTBACK;
524 FREETMPS;
525 LEAVE;
526 }
527
528 return loaded;
529 }
530
531 static void
destroy_package(const char * package)532 destroy_package(const char *package)
533 {
534 dSP;
535 PERL_SET_CONTEXT(my_perl);
536 SPAGAIN;
537
538 ENTER;
539 SAVETMPS;
540
541 PUSHMARK(SP);
542 XPUSHs(sv_2mortal(newSVpv(package, 0)));
543 PUTBACK;
544
545 perl_call_pv("Purple::PerlLoader::destroy_package",
546 G_VOID | G_EVAL | G_DISCARD);
547
548 SPAGAIN;
549
550 PUTBACK;
551 FREETMPS;
552 LEAVE;
553 }
554
555 static gboolean
unload_perl_plugin(PurplePlugin * plugin)556 unload_perl_plugin(PurplePlugin *plugin)
557 {
558 PurplePerlScript *gps = (PurplePerlScript *)plugin->info->extra_info;
559
560 if (gps == NULL)
561 return FALSE;
562
563 purple_debug(PURPLE_DEBUG_INFO, "perl", "Unloading perl script\n");
564
565 if (gps->unload_sub != NULL) {
566 dSP;
567 PERL_SET_CONTEXT(my_perl);
568 SPAGAIN;
569 ENTER;
570 SAVETMPS;
571 PUSHMARK(sp);
572 XPUSHs(sv_2mortal(purple_perl_bless_object(plugin,
573 "Purple::Plugin")));
574 PUTBACK;
575
576 perl_call_pv(gps->unload_sub, G_EVAL | G_SCALAR);
577 SPAGAIN;
578
579 if (SvTRUE(ERRSV)) {
580 purple_debug(PURPLE_DEBUG_ERROR, "perl",
581 "Perl function %s exited abnormally: %s\n",
582 gps->unload_sub, SvPVutf8_nolen(ERRSV));
583 }
584
585 PUTBACK;
586 FREETMPS;
587 LEAVE;
588 }
589
590 purple_perl_cmd_clear_for_plugin(plugin);
591 purple_perl_signal_clear_for_plugin(plugin);
592 purple_perl_timeout_clear_for_plugin(plugin);
593 purple_perl_pref_cb_clear_for_plugin(plugin);
594
595 destroy_package(gps->package);
596
597 return TRUE;
598 }
599
600 static void
destroy_perl_plugin(PurplePlugin * plugin)601 destroy_perl_plugin(PurplePlugin *plugin)
602 {
603 if (plugin->info != NULL) {
604 PurplePerlScript *gps;
605
606 g_free(plugin->info->name);
607 g_free(plugin->info->id);
608 g_free(plugin->info->homepage);
609 g_free(plugin->info->author);
610 g_free(plugin->info->summary);
611 g_free(plugin->info->description);
612 g_free(plugin->info->version);
613
614 gps = (PurplePerlScript *)plugin->info->extra_info;
615 if (gps != NULL) {
616 g_free(gps->package);
617 g_free(gps->load_sub);
618 g_free(gps->unload_sub);
619 g_free(gps->prefs_sub);
620 #ifdef PURPLE_GTKPERL
621 g_free(gps->gtk_prefs_sub);
622 #endif
623 g_free(gps->plugin_action_sub);
624 g_free(gps);
625 plugin->info->extra_info = NULL;
626 }
627
628 g_free(plugin->info);
629 plugin->info = NULL;
630 }
631 }
632
633 static gboolean
plugin_load(PurplePlugin * plugin)634 plugin_load(PurplePlugin *plugin)
635 {
636 return TRUE;
637 }
638
639 static gboolean
plugin_unload(PurplePlugin * plugin)640 plugin_unload(PurplePlugin *plugin)
641 {
642 perl_end();
643
644 return TRUE;
645 }
646
647 static PurplePluginLoaderInfo loader_info =
648 {
649 NULL, /**< exts */
650 probe_perl_plugin, /**< probe */
651 load_perl_plugin, /**< load */
652 unload_perl_plugin, /**< unload */
653 destroy_perl_plugin, /**< destroy */
654
655 /* padding */
656 NULL,
657 NULL,
658 NULL,
659 NULL
660 };
661
662 static PurplePluginInfo info =
663 {
664 PURPLE_PLUGIN_MAGIC,
665 PURPLE_MAJOR_VERSION,
666 PURPLE_MINOR_VERSION,
667 PURPLE_PLUGIN_LOADER, /**< type */
668 NULL, /**< ui_requirement */
669 0, /**< flags */
670 NULL, /**< dependencies */
671 PURPLE_PRIORITY_DEFAULT, /**< priority */
672
673 PERL_PLUGIN_ID, /**< id */
674 N_("Perl Plugin Loader"), /**< name */
675 DISPLAY_VERSION, /**< version */
676 N_("Provides support for loading perl plugins."), /**< summary */
677 N_("Provides support for loading perl plugins."), /**< description */
678 "Christian Hammond <chipx86@gnupdate.org>", /**< author */
679 PURPLE_WEBSITE, /**< homepage */
680
681 plugin_load, /**< load */
682 plugin_unload, /**< unload */
683 NULL, /**< destroy */
684
685 NULL, /**< ui_info */
686 &loader_info, /**< extra_info */
687 NULL,
688 NULL,
689
690 /* padding */
691 NULL,
692 NULL,
693 NULL,
694 NULL
695 };
696
697 static void
init_plugin(PurplePlugin * plugin)698 init_plugin(PurplePlugin *plugin)
699 {
700 loader_info.exts = g_list_append(loader_info.exts, "pl");
701 }
702
703 #ifdef __SUNPRO_C
704 #pragma init (my_init)
705 #else
706 void __attribute__ ((constructor)) my_init(void);
707 #endif
708
709 void
my_init(void)710 my_init(void)
711 {
712 /* Mostly evil hack... puts perl.so's symbols in the global table but
713 * does not create a circular dependency because g_module_open will
714 * only open the library once. */
715 /* Do we need to keep track of the returned GModule here so that we
716 * can g_module_close it when this plugin gets unloaded?
717 * At the moment I don't think this plugin can ever get unloaded but
718 * in case that becomes possible this wants to get noted. */
719 g_module_open("perl.so", 0);
720 }
721
722 PURPLE_INIT_PLUGIN(perl, init_plugin, info)
723