1 /* $Id: perl_embed.c,v 1.16 2004/12/26 22:23:16 shaster Exp $ */
2
3 /*
4 * GNU Gadu 2
5 *
6 * Copyright (C) 2001-2005 GNU Gadu Team
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 of the License, or
11 * (at your option) 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 program; if not, write to the Free Software
20 * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
21 */
22
23 /*
24 * Written by Bartosz Zapalowski <zapal@users.sf.net>
25 * based on perl plugin in X-Chat
26 *
27 * Thanks to Adam Wujek for help in testing.
28 */
29
30 #ifdef HAVE_CONFIG_H
31 # include "config.h"
32 #endif
33
34 #ifdef PERL_EMBED
35
36 #include <stdio.h>
37 #include <EXTERN.h>
38 #include <XSUB.h>
39 #include <perl.h>
40 #include <glib.h>
41 #include <libgen.h>
42
43 #include "perl_embed.h"
44 #include "signals.h"
45 #include "ggadu_support.h"
46 #include "ggadu_repo.h"
47
48 typedef struct
49 {
50 GGaduSigID q_name;
51 char *func;
52 } signal_hook;
53
54 typedef struct
55 {
56 char *name;
57 char *repo_name;
58 char *func;
59 } repo_hook;
60
61 typedef struct
62 {
63 char loaded;
64 char *filename;
65
66 GSList *hooks;
67 GSList *userlist_watch;
68
69 PerlInterpreter *perl;
70 } perlscript;
71
72 GSList *perlscripts = NULL;
73
74 PerlInterpreter *my_perl;
75
76 extern void boot_DynaLoader(pTHX_ CV * cv);
77
find_perl_script(gchar * name)78 perlscript *find_perl_script(gchar * name)
79 {
80 perlscript *script;
81 GSList *list = perlscripts;
82
83 while (list)
84 {
85 gchar *fn_dup, *tmp;
86 script = (perlscript *) list->data;
87 fn_dup = g_strdup(script->filename);
88 tmp = basename(fn_dup);
89 if (!strcmp(tmp, name))
90 {
91 g_free(fn_dup);
92 return script;
93 }
94 else
95 g_free(fn_dup);
96 list = list->next;
97 }
98
99 return NULL;
100 }
101
execute_perl(char * function,char ** perl_args)102 int execute_perl(char *function, char **perl_args)
103 {
104 /*
105 char *perl_args[2] = {args, NULL};
106 */
107 int count, ret_value = 1;
108 SV *sv;
109
110 dSP;
111 ENTER;
112 SAVETMPS;
113 PUSHMARK(sp);
114 count = perl_call_argv(function, G_EVAL | G_SCALAR, perl_args);
115 SPAGAIN;
116
117 print_debug("EXECUTE_PERL\n");
118
119 sv = GvSV(gv_fetchpv("@", TRUE, SVt_PV));
120 if (SvTRUE(sv))
121 {
122 printf("perl: Error %s\n", SvPV(sv, count));
123 POPs;
124 }
125 else if (count != 1)
126 {
127 printf("perl: Error: expected 1 value from %s, got %d\n", function, count);
128 }
129 else
130 {
131 ret_value = POPi;
132 }
133
134 PUTBACK;
135 FREETMPS;
136 LEAVE;
137
138 return ret_value;
139 }
140
execute_perl_one(char * function,char * args)141 int execute_perl_one(char *function, char *args)
142 {
143 char *perl_args[2] = { args, NULL };
144 return execute_perl(function, perl_args);
145 }
146
execute_perl_string(char * function,char ** perl_args)147 char *execute_perl_string(char *function, char **perl_args)
148 {
149 /*
150 char *perl_args[2] = {args, NULL};
151 */
152 int count;
153 char *ret_value = NULL;
154 SV *sv;
155 STRLEN n_a;
156
157 dSP;
158 ENTER;
159 SAVETMPS;
160 PUSHMARK(sp);
161 count = perl_call_argv(function, G_EVAL | G_SCALAR, perl_args);
162 SPAGAIN;
163
164 sv = GvSV(gv_fetchpv("@", TRUE, SVt_PV));
165 if (SvTRUE(sv))
166 {
167 printf("perl: Error %s\n", SvPV(sv, count));
168 POPs;
169 }
170 else if (count != 1)
171 {
172 printf("perl: Error: expected 1 value from %s, got %d\n", function, count);
173 }
174 else
175 {
176 ret_value = g_strdup(POPpx);
177 }
178
179 PUTBACK;
180 FREETMPS;
181 LEAVE;
182
183 return ret_value;
184 }
185
execute_perl_string_one(char * function,char * args)186 char *execute_perl_string_one(char *function, char *args)
187 {
188 char *perl_args[2] = { args, NULL };
189 return execute_perl_string(function, perl_args);
190 }
191
hook_handler(GGaduSignal * signal,void (* perl_func)(GGaduSignal *,gchar *,void *))192 void hook_handler(GGaduSignal * signal, void (*perl_func) (GGaduSignal *, gchar *, void *))
193 {
194 GSList *list_script;
195 GSList *list_hooks;
196 perlscript *script;
197 signal_hook *hook;
198
199 list_script = perlscripts;
200 while (list_script)
201 {
202 script = (perlscript *) list_script->data;
203
204 list_hooks = script->hooks;
205 while (list_hooks)
206 {
207 hook = (signal_hook *) list_hooks->data;
208
209 if (signal->name == hook->q_name)
210 {
211 PERL_SET_CONTEXT(script->perl);
212 my_perl = script->perl;
213 perl_func(signal, hook->func, (void *) script->perl);
214 }
215
216 list_hooks = list_hooks->next;
217 }
218
219 list_script = list_script->next;
220 }
221 }
222
userlist_handler(gchar * repo_name,gpointer key,gint actions)223 void userlist_handler(gchar * repo_name, gpointer key, gint actions)
224 {
225 GGaduContact *k = NULL;
226 GSList *list_script, *list;
227 perlscript *script;
228 repo_hook *hook;
229
230 k = ggadu_repo_find_value(repo_name, key);
231
232 g_return_if_fail(k != NULL);
233
234 list_script = perlscripts;
235 while (list_script)
236 {
237 script = (perlscript *) list_script->data;
238 list = script->userlist_watch;
239 while (list)
240 {
241 hook = (repo_hook *) list->data;
242 if (hook->repo_name == NULL || !strcmp(hook->repo_name, repo_name))
243 {
244 int count;
245 SV *sv_name;
246 SV *sv_action;
247 SV *sv_user_id;
248
249 dSP;
250
251 PERL_SET_CONTEXT(script->perl);
252 my_perl = script->perl;
253
254 ENTER;
255 SAVETMPS;
256
257 sv_name = sv_2mortal(newSVpv(repo_name, 0));
258 sv_action = sv_2mortal(newSViv(actions));
259 sv_user_id = sv_2mortal(newSVpv(k->id, 0));
260
261 PUSHMARK(SP);
262 XPUSHs(sv_name);
263 XPUSHs(sv_action);
264 XPUSHs(sv_user_id);
265 PUTBACK;
266
267 count = call_pv(hook->func, G_DISCARD);
268
269 FREETMPS;
270 LEAVE;
271 }
272 list = list->next;
273 }
274 list_script = list_script->next;
275 }
276 }
277
XS(XS_GGadu_register_script)278 static XS(XS_GGadu_register_script)
279 {
280 char *name;
281 int junk;
282 perlscript *script;
283 dXSARGS;
284
285 items = items;
286
287 name = SvPV(ST(0), junk);
288
289 print_debug("registering %s\n", name);
290
291 script = find_perl_script(name);
292 if (!script)
293 XSRETURN(1);
294 script->loaded = 1;
295 print_debug("found %s in %s\n", name, script->filename);
296 XSRETURN(0);
297 }
298
XS(XS_GGadu_hello)299 static XS(XS_GGadu_hello)
300 {
301 char *world;
302 int junk;
303 dXSARGS;
304
305 items = items;
306
307 world = SvPV(ST(0), junk);
308 printf("Perl: Hello %s\n", world);
309 XSRETURN_EMPTY;
310 }
311
XS(XS_GGadu_signal_emit)312 static XS(XS_GGadu_signal_emit)
313 {
314 char *signame;
315 void *sigdata;
316 char *sigdst;
317 int must_dup;
318 int junk;
319 dXSARGS;
320
321 items = items;
322
323 signame = SvPV(ST(0), junk);
324 sigdata = SvPV(ST(1), junk);
325 sigdst = SvPV(ST(2), junk);
326 must_dup = SvIV(ST(3));
327
328 signal_emit_full("perl:", signame, sigdata ? (must_dup ? g_strdup(sigdata) : sigdata) : NULL, sigdst, NULL);
329 XSRETURN_EMPTY;
330 }
331
XS(XS_GGadu_signal_hook)332 static XS(XS_GGadu_signal_hook)
333 {
334 char *name;
335 char *signame;
336 GGaduSigID q_signame;
337 char *func;
338 int junk;
339 signal_hook *hook;
340 perlscript *script;
341 dXSARGS;
342
343 items = items;
344
345 name = SvPV(ST(0), junk);
346 signame = SvPV(ST(1), junk);
347 func = SvPV(ST(2), junk);
348 q_signame = g_quark_from_string(signame);
349
350 print_debug("hooking %s, %s, %s, %d\n", name, signame, func, q_signame);
351
352 script = find_perl_script(name);
353 if (!script)
354 XSRETURN(1);
355
356 print_debug("still hooking\n");
357
358 hook = g_new0(signal_hook, 1);
359 hook->q_name = q_signame;
360 hook->func = g_strdup(func);
361 script->hooks = g_slist_append(script->hooks, hook);
362 hook_signal((GGaduSigID) g_quark_from_string(signame), hook_handler);
363
364 XSRETURN(0);
365 }
366
XS(XS_GGadu_repo_watch_userlist)367 static XS(XS_GGadu_repo_watch_userlist)
368 {
369 char *name;
370 char *protocol;
371 char *func;
372 int junk;
373 repo_hook *hook;
374 perlscript *script;
375 dXSARGS;
376
377 items = items;
378
379 name = SvPV(ST(0), junk);
380 protocol = SvPV(ST(1), junk);
381 func = SvPV(ST(2), junk);
382
383 print_debug("watching userlist %s for %s, %s\n", protocol, name, func);
384
385 script = find_perl_script(name);
386 if (!script)
387 XSRETURN(1);
388
389 hook = g_new0(repo_hook, 1);
390 hook->name = g_strdup(name);
391 hook->func = g_strdup(func);
392 if (protocol[0] == '*')
393 hook->repo_name = NULL;
394 else
395 hook->repo_name = g_strdup(protocol);
396 script->userlist_watch = g_slist_append(script->userlist_watch, hook);
397 ggadu_repo_watch_add(hook->repo_name, REPO_ACTION_VALUE_CHANGE, REPO_VALUE_CONTACT, userlist_handler);
398
399 XSRETURN(0);
400 }
401
XS(XS_GGadu_find_user_id)402 static XS(XS_GGadu_find_user_id)
403 {
404 char *id;
405 char *protocol;
406 char *interest;
407 int junk;
408 gpointer index;
409 GGaduContact *k;
410 gchar *key;
411 dXSARGS;
412
413 items = items;
414
415 id = SvPV(ST(0), junk);
416 protocol = SvPV(ST(1), junk);
417 interest = SvPV(ST(2), junk);
418
419 print_debug("Finding id='%s' in '%s'\n", id, protocol);
420
421 index = ggadu_repo_value_first(protocol, REPO_VALUE_CONTACT, (gpointer *) & key);
422 while (index)
423 {
424 k = ggadu_repo_find_value(protocol, key);
425 print_debug("id='%s', k->id='%s'\n", id, k->id);
426 #define ODDAJ(x,y) if (y) XST_mPV(x,y); else XST_mPV(x,"<unset>")
427 if (!ggadu_strcasecmp(id, k->id))
428 {
429 ODDAJ(0, k->id);
430 ODDAJ(1, k->first_name);
431 ODDAJ(2, k->last_name);
432 ODDAJ(3, k->nick);
433 ODDAJ(4, k->mobile);
434 ODDAJ(5, k->email);
435 ODDAJ(6, k->gender);
436 ODDAJ(7, k->group);
437 ODDAJ(8, k->comment);
438 ODDAJ(9, k->birthdate);
439 ODDAJ(10, k->status_descr);
440 ODDAJ(11, k->ip);
441 ODDAJ(12, k->city);
442 ODDAJ(13, k->age);
443 XST_mIV(14, k->status);
444 XSRETURN(15);
445 }
446 index = ggadu_repo_value_next(protocol, REPO_VALUE_CONTACT, (gpointer *) & key, index);
447 }
448
449 XSRETURN(0);
450 }
451
xs_init(pTHX)452 static void xs_init(pTHX)
453 {
454 char *file = __FILE__;
455 dXSUB_SYS;
456
457 newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);
458
459 newXS("GGadu::register_script", XS_GGadu_register_script, "GGadu");
460 newXS("GGadu::signal_emit", XS_GGadu_signal_emit, "GGadu");
461 newXS("GGadu::hello", XS_GGadu_hello, "GGadu");
462 newXS("GGadu::signal_hook", XS_GGadu_signal_hook, "GGadu");
463 newXS("GGadu::repo_watch_userlist", XS_GGadu_repo_watch_userlist, "GGadu");
464 newXS("GGadu::find_user_id", XS_GGadu_find_user_id, "GGadu");
465 }
466
perl_load_script(char * script_name)467 int perl_load_script(char *script_name)
468 {
469 perlscript *script;
470 char *perl_args[] = { "", "-e", "0", "-w" };
471 const char perl_definitions[] = {
472 "sub load_file{" "my $f_name=shift;" "local $/=undef;" "open FH,$f_name or return \"__FAILED__\";" "$_=<FH>;" "close FH;" "return $_;" "}"
473 "sub load_n_eval{" "my $f_name=shift;" "my $strin=load_file($f_name);" "return 2 if($strin eq \"__FAILED__\");" "eval $strin;" "if($@){"
474 /*" #something went wrong\n" */
475 "print\"Errors loading file $f_name:\\n\";" "print\"$@\\n\";" "return 1;" "}" "return 0;" "}" "$SIG{__WARN__}=sub{print\"$_[0]\n\";};"
476 };
477
478 print_debug("gotta load %s\n", script_name);
479 script = g_new0(perlscript, 1);
480 script->loaded = 0;
481 script->filename = g_strdup(script_name);
482 script->perl = perl_alloc();
483 PERL_SET_CONTEXT(script->perl);
484 my_perl = script->perl;
485 perl_construct(script->perl);
486 perl_parse(script->perl, xs_init, 4, perl_args, NULL);
487 eval_pv(perl_definitions, TRUE);
488
489 perlscripts = g_slist_append(perlscripts, script);
490
491 execute_perl_one("load_n_eval", script->filename);
492
493 print_debug("aaaa\n");
494
495 return 0;
496 };
497
perl_unload_script(char * script_name)498 int perl_unload_script(char *script_name)
499 {
500 perlscript *script;
501 GSList *list;
502
503 list = perlscripts;
504 while (list)
505 {
506 script = (perlscript *) list->data;
507 print_debug("script_name: %s, script->filename: %s\n", script_name, script->filename);
508 if (!strcmp(script_name, script->filename))
509 {
510 PERL_SET_CONTEXT(script->perl);
511 perl_destruct(script->perl);
512 perl_free(script->perl);
513 perlscripts = g_slist_remove(perlscripts, script);
514 g_free(script);
515 break;
516 }
517 list = list->next;
518 }
519
520 return 0;
521 }
522
perl_load_scripts(void)523 gint perl_load_scripts(void)
524 {
525 /* GIOChannel *ch = NULL;
526 GString *buffer = g_string_new (NULL);*/
527 gchar *filename;
528 gint loaded = 0;
529 GDir *dir;
530 gchar *file;
531
532 filename = g_build_filename(config->configdir, "perl.scripts", NULL);
533 dir = g_dir_open(filename, 0, NULL);
534 g_free(filename);
535 if (!dir)
536 return 0;
537
538 while ((file = (gchar *) g_dir_read_name(dir)))
539 {
540 gchar *real_filename;
541 print_debug("perl: Autoloading script %s\n", file);
542 real_filename = g_build_filename(config->configdir, "perl.scripts", file, NULL);
543 perl_load_script(real_filename);
544 g_free(real_filename);
545 print_debug("perl: %s loaded\n", file);
546 loaded++;
547 }
548
549 g_dir_close(dir);
550
551 print_debug("perl: Loaded %d scripts.\n", loaded);
552
553 /*
554 filename = g_build_filename (config->configdir, "perl.load", NULL);
555
556 ch = g_io_channel_new_file (filename, "r", NULL);
557 g_free (filename);
558
559 if (!ch)
560 {
561 g_string_free (buffer, TRUE);
562 return 0;
563 }
564
565 while (g_io_channel_read_line_string (ch, buffer, NULL, NULL) != G_IO_STATUS_EOF)
566 {
567 print_debug ("Loading script %s\n", buffer->str);
568 buffer->str[buffer->len - 1] = '\0';
569 perl_load_script (buffer->str);
570 loaded++;
571 }
572
573 g_io_channel_shutdown (ch, TRUE, NULL);
574
575 g_string_free (buffer, TRUE);
576 */
577 return loaded;
578 }
579
580 #endif
581