Mercurial > pidgin
annotate plugins/perl/perl.c @ 5470:cb8e58ded7b0
[gaim-migrate @ 5862]
now builds on win32, after plugin re-design
committer: Tailor Script <tailor@pidgin.im>
author | Herman Bloggs <hermanator12002@yahoo.com> |
---|---|
date | Wed, 21 May 2003 15:59:30 +0000 |
parents | ad9b6e65713b |
children | cde28f5c47d4 |
rev | line source |
---|---|
5205 | 1 /* |
2 * gaim | |
3 * | |
4 * Copyright (C) 1998-1999, Mark Spencer <markster@marko.net> | |
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 * This was taken almost exactly from X-Chat. The power of the GPL. | |
21 * Translated from X-Chat to Gaim by Eric Warmenhoven. | |
22 * Originally by Erik Scrafford <eriks@chilisoft.com>. | |
23 * X-Chat Copyright (C) 1998 Peter Zelezny. | |
24 * | |
25 */ | |
26 | |
27 #ifdef HAVE_CONFIG_H | |
28 #include <config.h> | |
29 #ifdef DEBUG | |
30 #undef DEBUG | |
31 #endif | |
32 #endif | |
33 #undef PACKAGE | |
34 | |
35 #define group perl_group | |
36 #ifdef _WIN32 | |
37 /* This took me an age to figure out.. without this __declspec(dllimport) | |
38 * will be ignored. | |
39 */ | |
40 #define HASATTRIBUTE | |
41 #endif | |
42 #include <EXTERN.h> | |
43 #ifndef _SEM_SEMUN_UNDEFINED | |
44 #define HAS_UNION_SEMUN | |
45 #endif | |
46 #include <perl.h> | |
47 #include <XSUB.h> | |
48 #ifndef _WIN32 | |
49 #include <sys/mman.h> | |
50 #endif | |
51 #include <sys/types.h> | |
52 #include <sys/stat.h> | |
53 #include <fcntl.h> | |
54 #undef PACKAGE | |
55 #include <stdio.h> | |
56 #ifndef _WIN32 | |
57 #include <dirent.h> | |
58 #else | |
59 /* We're using perl's win32 port of this */ | |
60 #define dirent direct | |
61 #endif | |
62 #include <string.h> | |
63 | |
64 #undef group | |
65 | |
66 /* perl module support */ | |
67 #ifdef OLD_PERL | |
68 extern void boot_DynaLoader _((CV * cv)); | |
69 #else | |
70 extern void boot_DynaLoader _((pTHX_ CV * cv)); /* perl is so wacky */ | |
71 #endif | |
72 | |
73 #undef _ | |
74 #ifdef DEBUG | |
75 #undef DEBUG | |
76 #endif | |
77 #ifdef _WIN32 | |
78 #undef pipe | |
79 #endif | |
80 #include "gaim.h" | |
81 #include "prpl.h" | |
82 #include "sound.h" | |
83 | |
84 #ifndef call_pv | |
85 # define call_pv(i,j) perl_call_pv((i), (j)) | |
86 #endif | |
87 | |
88 #define PERL_PLUGIN_ID "core-perl" | |
89 | |
90 struct perlscript { | |
91 char *name; | |
92 char *version; | |
93 char *shutdowncallback; /* bleh */ | |
94 GaimPlugin *plug; | |
95 }; | |
96 | |
97 struct _perl_event_handlers { | |
98 char *event_type; | |
99 char *handler_name; | |
100 GaimPlugin *plug; | |
101 }; | |
102 | |
103 struct _perl_timeout_handlers { | |
104 char *handler_name; | |
105 char *handler_args; | |
106 gint iotag; | |
107 GaimPlugin *plug; | |
108 }; | |
109 | |
5436
ad445074d239
[gaim-migrate @ 5818]
Christian Hammond <chipx86@chipx86.com>
parents:
5408
diff
changeset
|
110 static GaimPlugin *my_plugin = NULL; |
5205 | 111 static GList *perl_list = NULL; |
112 static GList *perl_timeout_handlers = NULL; | |
113 static GList *perl_event_handlers = NULL; | |
114 static PerlInterpreter *my_perl = NULL; | |
115 static void perl_init(); | |
116 | |
117 /* dealing with gaim */ | |
118 XS(XS_GAIM_register); /* set up hooks for script */ | |
119 XS(XS_GAIM_get_info); /* version, last to attempt signon, protocol */ | |
120 XS(XS_GAIM_print); /* lemme figure this one out... */ | |
121 XS(XS_GAIM_write_to_conv); /* write into conversation window */ | |
122 | |
123 /* list stuff */ | |
124 XS(XS_GAIM_buddy_list); /* all buddies */ | |
125 XS(XS_GAIM_online_list); /* online buddies */ | |
126 | |
127 /* server stuff */ | |
128 XS(XS_GAIM_command); /* send command to server */ | |
129 XS(XS_GAIM_user_info); /* given name, return struct buddy members */ | |
130 XS(XS_GAIM_print_to_conv); /* send message to someone */ | |
131 XS(XS_GAIM_print_to_chat); /* send message to chat room */ | |
132 XS(XS_GAIM_serv_send_im); /* send message to someone (but do not display) */ | |
133 | |
134 /* handler commands */ | |
135 XS(XS_GAIM_add_event_handler); /* when servers talk */ | |
136 XS(XS_GAIM_remove_event_handler); /* remove a handler */ | |
137 XS(XS_GAIM_add_timeout_handler); /* figure it out */ | |
138 | |
139 /* play sound */ | |
140 XS(XS_GAIM_play_sound); /*play a sound */ | |
141 | |
142 static void | |
143 #ifdef OLD_PERL | |
144 xs_init() | |
145 #else | |
146 xs_init(pTHX) | |
147 #endif | |
148 { | |
149 char *file = __FILE__; | |
150 | |
151 /* This one allows dynamic loading of perl modules in perl | |
152 scripts by the 'use perlmod;' construction*/ | |
153 newXS ("DynaLoader::boot_DynaLoader", boot_DynaLoader, file); | |
154 | |
155 /* load up all the custom Gaim perl functions */ | |
156 newXS ("GAIM::register", XS_GAIM_register, "GAIM"); | |
157 newXS ("GAIM::get_info", XS_GAIM_get_info, "GAIM"); | |
158 newXS ("GAIM::print", XS_GAIM_print, "GAIM"); | |
159 newXS ("GAIM::write_to_conv", XS_GAIM_write_to_conv, "GAIM"); | |
160 | |
161 newXS ("GAIM::buddy_list", XS_GAIM_buddy_list, "GAIM"); | |
162 newXS ("GAIM::online_list", XS_GAIM_online_list, "GAIM"); | |
163 | |
164 newXS ("GAIM::command", XS_GAIM_command, "GAIM"); | |
165 newXS ("GAIM::user_info", XS_GAIM_user_info, "GAIM"); | |
166 newXS ("GAIM::print_to_conv", XS_GAIM_print_to_conv, "GAIM"); | |
167 newXS ("GAIM::print_to_chat", XS_GAIM_print_to_chat, "GAIM"); | |
168 newXS ("GAIM::serv_send_im", XS_GAIM_serv_send_im, "GAIM"); | |
169 | |
170 newXS ("GAIM::add_event_handler", XS_GAIM_add_event_handler, "GAIM"); | |
171 newXS ("GAIM::remove_event_handler", XS_GAIM_remove_event_handler, "GAIM"); | |
172 newXS ("GAIM::add_timeout_handler", XS_GAIM_add_timeout_handler, "GAIM"); | |
173 | |
174 newXS ("GAIM::play_sound", XS_GAIM_play_sound, "GAIM"); | |
175 } | |
176 | |
177 static char * | |
178 escape_quotes(const char *buf) | |
179 { | |
180 static char *tmp_buf = NULL; | |
181 const char *i; | |
182 char *j; | |
183 | |
184 if (tmp_buf) | |
185 g_free(tmp_buf); | |
186 | |
187 tmp_buf = g_malloc(strlen(buf) * 2 + 1); | |
188 | |
189 for (i = buf, j = tmp_buf; *i; i++, j++) { | |
190 if (*i == '\'' || *i == '\\') | |
191 *j++ = '\\'; | |
192 | |
193 *j = *i; | |
194 } | |
195 | |
196 *j = '\0'; | |
197 | |
198 return tmp_buf; | |
199 } | |
200 | |
201 /* | |
202 2003/02/06: execute_perl modified by Mark Doliner <mark@kingant.net> | |
203 Pass parameters by pushing them onto the stack rather than | |
204 passing an array of strings. This way, perl scripts can | |
205 modify the parameters and we can get the changed values | |
206 and then shoot ourselves. I mean, uh, use them. | |
207 | |
208 2001/06/14: execute_perl replaced by Martin Persson <mep@passagen.se> | |
209 previous use of perl_eval leaked memory, replaced with | |
210 a version that uses perl_call instead | |
211 | |
212 30/11/2002: execute_perl modified by Eric Timme <timothy@voidnet.com> | |
213 args changed to char** so that we can have preparsed | |
214 arguments again, and many headaches ensued! This essentially | |
215 means we replaced one hacked method with a messier hacked | |
216 method out of perceived necessity. Formerly execute_perl | |
217 required a single char_ptr, and it would insert it into an | |
218 array of character pointers and NULL terminate the new array. | |
219 Now we have to pass in pre-terminated character pointer arrays | |
220 to accomodate functions that want to pass in multiple arguments. | |
221 | |
222 Previously arguments were preparsed because an argument list | |
223 was constructed in the form 'arg one','arg two' and was | |
224 executed via a call like &funcname(arglist) (see .59.x), so | |
225 the arglist was magically pre-parsed because of the method. | |
226 With Martin Persson's change to perl_call we now need to | |
227 use a null terminated list of character pointers for arguments | |
228 if we wish them to be parsed. Lacking a better way to allow | |
229 for both single arguments and many I created a NULL terminated | |
230 array in every function that called execute_perl and passed | |
231 that list into the function. In the former version a single | |
232 character pointer was passed in, and was placed into an array | |
233 of character pointers with two elements, with a NULL element | |
234 tacked onto the back, but this method no longer seemed prudent. | |
235 | |
236 Enhancements in the future might be to get rid of pre-declaring | |
237 the array sizes? I am not comfortable enough with this | |
238 subject to attempt it myself and hope it to stand the test | |
239 of time. | |
240 */ | |
241 | |
242 static int | |
243 execute_perl(const char *function, int argc, char **args) | |
244 { | |
245 int count = 0, i, ret_value = 1; | |
246 SV *sv_args[argc]; | |
247 STRLEN na; | |
248 | |
249 /* | |
250 * Set up the perl environment, push arguments onto the | |
251 * perl stack, then call the given function | |
252 */ | |
253 dSP; | |
254 ENTER; | |
255 SAVETMPS; | |
256 PUSHMARK(sp); | |
257 | |
258 for (i = 0; i < argc; i++) { | |
259 if (args[i]) { | |
260 sv_args[i] = sv_2mortal(newSVpv(args[i], 0)); | |
261 XPUSHs(sv_args[i]); | |
262 } | |
263 } | |
264 | |
265 PUTBACK; | |
266 count = call_pv(function, G_EVAL | G_SCALAR); | |
267 SPAGAIN; | |
268 | |
269 /* | |
270 * Check for "die," make sure we have 1 argument, and set our | |
271 * return value. | |
272 */ | |
273 if (SvTRUE(ERRSV)) { | |
5227
6d1707dc8c3d
[gaim-migrate @ 5597]
Christian Hammond <chipx86@chipx86.com>
parents:
5205
diff
changeset
|
274 gaim_debug(GAIM_DEBUG_ERROR, "perl", |
6d1707dc8c3d
[gaim-migrate @ 5597]
Christian Hammond <chipx86@chipx86.com>
parents:
5205
diff
changeset
|
275 "Perl function %s exited abnormally: %s\n", |
6d1707dc8c3d
[gaim-migrate @ 5597]
Christian Hammond <chipx86@chipx86.com>
parents:
5205
diff
changeset
|
276 function, SvPV(ERRSV, na)); |
5205 | 277 POPs; |
278 } | |
279 else if (count != 1) { | |
280 /* | |
281 * This should NEVER happen. G_SCALAR ensures that we WILL | |
282 * have 1 parameter. | |
283 */ | |
5227
6d1707dc8c3d
[gaim-migrate @ 5597]
Christian Hammond <chipx86@chipx86.com>
parents:
5205
diff
changeset
|
284 gaim_debug(GAIM_DEBUG_ERROR, "perl", |
6d1707dc8c3d
[gaim-migrate @ 5597]
Christian Hammond <chipx86@chipx86.com>
parents:
5205
diff
changeset
|
285 "Perl error from %s: expected 1 return value, " |
6d1707dc8c3d
[gaim-migrate @ 5597]
Christian Hammond <chipx86@chipx86.com>
parents:
5205
diff
changeset
|
286 "but got %d\n", function, count); |
5205 | 287 } |
288 else | |
289 ret_value = POPi; | |
290 | |
291 /* Check for changed arguments */ | |
292 for (i = 0; i < argc; i++) { | |
293 if (args[i] && strcmp(args[i], SvPVX(sv_args[i]))) { | |
294 /* | |
295 * Shizzel. So the perl script changed one of the parameters, | |
296 * and we want this change to affect the original parameters. | |
297 * args[i] is just a tempory little list of pointers. We don't | |
298 * want to free args[i] here because the new parameter doesn't | |
299 * overwrite the data that args[i] points to. That is done by | |
300 * the function that called execute_perl. I'm not explaining this | |
301 * very well. See, it's aggregate... Oh, but if 2 perl scripts | |
302 * both modify the data, _that's_ a memleak. This is really kind | |
303 * of hackish. I should fix it. Look how long this comment is. | |
304 * Holy crap. | |
305 */ | |
306 args[i] = g_strdup(SvPV(sv_args[i], na)); | |
307 } | |
308 } | |
309 | |
310 PUTBACK; | |
311 FREETMPS; | |
312 LEAVE; | |
313 | |
314 return ret_value; | |
315 } | |
316 | |
317 static void | |
318 perl_unload_file(GaimPlugin *plug) | |
319 { | |
320 char *atmp[2] = { "", NULL }; | |
321 struct perlscript *scp = NULL; | |
322 struct _perl_timeout_handlers *thn; | |
323 struct _perl_event_handlers *ehn; | |
324 GList *pl; | |
325 | |
326 for (pl = perl_list; pl != NULL; pl = pl->next) { | |
327 scp = pl->data; | |
328 | |
329 if (scp->plug == plug) { | |
330 perl_list = g_list_remove(perl_list, scp); | |
331 | |
332 if (scp->shutdowncallback[0]) | |
333 execute_perl(scp->shutdowncallback, 1, atmp); | |
334 | |
335 g_free(scp->name); | |
336 g_free(scp->version); | |
337 g_free(scp->shutdowncallback); | |
338 g_free(scp); | |
339 | |
340 break; | |
341 } | |
342 } | |
343 | |
344 for (pl = perl_timeout_handlers; pl != NULL; pl = pl->next) { | |
345 thn = pl->data; | |
346 | |
347 if (thn && thn->plug == plug) { | |
348 perl_timeout_handlers = g_list_remove(perl_timeout_handlers, thn); | |
349 | |
350 g_source_remove(thn->iotag); | |
351 g_free(thn->handler_args); | |
352 g_free(thn->handler_name); | |
353 g_free(thn); | |
354 } | |
355 } | |
356 | |
357 for (pl = perl_event_handlers; pl != NULL; pl = pl->next) { | |
358 ehn = pl->data; | |
359 | |
360 if (ehn && ehn->plug == plug) { | |
361 perl_event_handlers = g_list_remove(perl_event_handlers, ehn); | |
362 | |
363 g_free(ehn->event_type); | |
364 g_free(ehn->handler_name); | |
365 g_free(ehn); | |
366 } | |
367 } | |
368 } | |
369 | |
370 static int | |
371 perl_load_file(char *script_name, GaimPlugin *plugin) | |
372 { | |
373 char *atmp[2] = { script_name, NULL }; | |
374 GList *s; | |
375 struct perlscript *scp; | |
376 int ret; | |
377 | |
378 if (my_perl == NULL) | |
379 perl_init(); | |
380 | |
381 plugin->handle = plugin->path; | |
382 | |
383 ret = execute_perl("load_n_eval", 1, atmp); | |
384 | |
385 for (s = perl_list; s != NULL; s = s->next) { | |
386 scp = s->data; | |
387 | |
388 if (!strcmp(scp->name, plugin->info->name) && | |
389 !strcmp(scp->version, plugin->info->version)) { | |
390 | |
391 break; | |
392 } | |
393 } | |
394 | |
395 if (!s) { | |
396 plugin->error = g_strdup(_("GAIM::register not called with " | |
397 "proper arguments. Consult PERL-HOWTO.")); | |
398 | |
399 return 0; | |
400 } | |
401 | |
402 return ret; | |
403 } | |
404 | |
405 static void | |
406 perl_init(void) | |
407 { | |
408 /* changed the name of the variable from load_file to | |
409 perl_definitions since now it does much more than defining | |
410 the load_file sub. Moreover, deplaced the initialisation to | |
411 the xs_init function. (TheHobbit)*/ | |
412 char *perl_args[] = { "", "-e", "0", "-w" }; | |
413 char perl_definitions[] = | |
414 { | |
415 /* We use to function one to load a file the other to | |
416 execute the string obtained from the first and holding | |
417 the file conents. This allows to have a realy local $/ | |
418 without introducing temp variables to hold the old | |
419 value. Just a question of style:) */ | |
420 "sub load_file{" | |
421 "my $f_name=shift;" | |
422 "local $/=undef;" | |
423 "open FH,$f_name or return \"__FAILED__\";" | |
424 "$_=<FH>;" | |
425 "close FH;" | |
426 "return $_;" | |
427 "}" | |
428 "sub load_n_eval{" | |
429 "my $f_name=shift;" | |
430 "my $strin=load_file($f_name);" | |
431 "return 2 if($strin eq \"__FAILED__\");" | |
432 "eval $strin;" | |
433 "if($@){" | |
434 /*" #something went wrong\n"*/ | |
435 "GAIM::print(\"Errors loading file $f_name:\\n\",\"$@\");" | |
436 "return 1;" | |
437 "}" | |
438 "return 0;" | |
439 "}" | |
440 }; | |
441 | |
442 my_perl = perl_alloc(); | |
443 perl_construct(my_perl); | |
444 #ifdef DEBUG | |
445 perl_parse(my_perl, xs_init, 4, perl_args, NULL); | |
446 #else | |
447 perl_parse(my_perl, xs_init, 3, perl_args, NULL); | |
448 #endif | |
449 #ifdef HAVE_PERL_EVAL_PV | |
450 eval_pv(perl_definitions, TRUE); | |
451 #else | |
452 perl_eval_pv(perl_definitions, TRUE); /* deprecated */ | |
453 #endif | |
454 } | |
455 | |
456 static void | |
457 perl_end(void) | |
458 { | |
459 char *atmp[2] = { "", NULL }; | |
460 struct perlscript *scp; | |
461 struct _perl_timeout_handlers *thn; | |
462 struct _perl_event_handlers *ehn; | |
463 | |
464 while (perl_list) { | |
465 scp = perl_list->data; | |
466 perl_list = g_list_remove(perl_list, scp); | |
467 | |
468 if (scp->shutdowncallback[0]) | |
469 execute_perl(scp->shutdowncallback, 1, atmp); | |
470 | |
471 g_free(scp->name); | |
472 g_free(scp->version); | |
473 g_free(scp->shutdowncallback); | |
474 g_free(scp); | |
475 } | |
476 | |
477 while (perl_timeout_handlers) { | |
478 thn = perl_timeout_handlers->data; | |
479 perl_timeout_handlers = g_list_remove(perl_timeout_handlers, thn); | |
480 g_source_remove(thn->iotag); | |
481 g_free(thn->handler_args); | |
482 g_free(thn->handler_name); | |
483 g_free(thn); | |
484 } | |
485 | |
486 while (perl_event_handlers) { | |
487 ehn = perl_event_handlers->data; | |
488 perl_event_handlers = g_list_remove(perl_event_handlers, ehn); | |
489 g_free(ehn->event_type); | |
490 g_free(ehn->handler_name); | |
491 g_free(ehn); | |
492 } | |
493 | |
494 if (my_perl != NULL) { | |
495 perl_destruct(my_perl); | |
496 perl_free(my_perl); | |
497 my_perl = NULL; | |
498 } | |
499 } | |
500 | |
501 XS (XS_GAIM_register) | |
502 { | |
503 char *name, *ver, *callback, *unused; /* exactly like X-Chat, eh? :) */ | |
504 unsigned int junk; | |
505 struct perlscript *scp; | |
506 GaimPlugin *plug = NULL; | |
507 GList *pl; | |
508 | |
509 dXSARGS; | |
510 items = 0; | |
511 | |
512 name = SvPV(ST(0), junk); | |
513 ver = SvPV(ST(1), junk); | |
514 callback = SvPV(ST(2), junk); | |
515 unused = SvPV(ST(3), junk); | |
516 | |
5227
6d1707dc8c3d
[gaim-migrate @ 5597]
Christian Hammond <chipx86@chipx86.com>
parents:
5205
diff
changeset
|
517 gaim_debug(GAIM_DEBUG_INFO, "perl", |
6d1707dc8c3d
[gaim-migrate @ 5597]
Christian Hammond <chipx86@chipx86.com>
parents:
5205
diff
changeset
|
518 "GAIM::register(%s, %s)\n", name, ver); |
5205 | 519 |
520 for (pl = gaim_plugins_get_all(); pl != NULL; pl = pl->next) { | |
521 plug = pl->data; | |
522 | |
523 if (!strcmp(name, plug->info->name) && | |
524 !strcmp(ver, plug->info->version)) { | |
525 | |
526 break; | |
527 } | |
528 | |
529 plug = NULL; | |
530 } | |
531 | |
532 if (plug) { | |
533 scp = g_new0(struct perlscript, 1); | |
534 scp->name = g_strdup(name); | |
535 scp->version = g_strdup(ver); | |
536 scp->shutdowncallback = g_strdup(callback); | |
537 scp->plug = plug; | |
538 perl_list = g_list_append(perl_list, scp); | |
539 XST_mPV(0, plug->path); | |
540 } | |
541 else | |
542 XST_mPV(0, NULL); | |
543 | |
544 XSRETURN (1); | |
545 } | |
546 | |
547 XS (XS_GAIM_get_info) | |
548 { | |
549 int i = 0; | |
550 dXSARGS; | |
551 items = 0; | |
552 | |
553 switch(SvIV(ST(0))) { | |
554 case 0: | |
555 XST_mPV(0, VERSION); | |
556 i = 1; | |
557 break; | |
558 | |
559 case 1: | |
560 { | |
5470
cb8e58ded7b0
[gaim-migrate @ 5862]
Herman Bloggs <hermanator12002@yahoo.com>
parents:
5445
diff
changeset
|
561 GSList *c = gaim_get_connections(); |
5205 | 562 struct gaim_connection *gc; |
563 | |
564 while (c) { | |
565 gc = (struct gaim_connection *)c->data; | |
566 XST_mIV(i++, (guint)gc); | |
567 c = c->next; | |
568 } | |
569 } | |
570 break; | |
571 | |
572 case 2: | |
573 { | |
574 struct gaim_connection *gc = | |
575 (struct gaim_connection *)SvIV(ST(1)); | |
576 | |
5470
cb8e58ded7b0
[gaim-migrate @ 5862]
Herman Bloggs <hermanator12002@yahoo.com>
parents:
5445
diff
changeset
|
577 if (g_slist_find(gaim_get_connections(), gc)) |
5205 | 578 XST_mIV(i++, gc->protocol); |
579 else | |
580 XST_mIV(i++, -1); | |
581 } | |
582 break; | |
583 | |
584 case 3: | |
585 { | |
586 struct gaim_connection *gc = | |
587 (struct gaim_connection *)SvIV(ST(1)); | |
588 | |
5470
cb8e58ded7b0
[gaim-migrate @ 5862]
Herman Bloggs <hermanator12002@yahoo.com>
parents:
5445
diff
changeset
|
589 if (g_slist_find(gaim_get_connections(), gc)) |
5205 | 590 XST_mPV(i++, gc->username); |
591 else | |
592 XST_mPV(i++, ""); | |
593 } | |
594 break; | |
595 | |
596 case 4: | |
597 { | |
598 struct gaim_connection *gc = | |
599 (struct gaim_connection *)SvIV(ST(1)); | |
600 | |
5470
cb8e58ded7b0
[gaim-migrate @ 5862]
Herman Bloggs <hermanator12002@yahoo.com>
parents:
5445
diff
changeset
|
601 if (g_slist_find(gaim_get_connections(), gc)) |
5205 | 602 XST_mIV(i++, g_slist_index(gaim_accounts, gc->account)); |
603 else | |
604 XST_mIV(i++, -1); | |
605 } | |
606 break; | |
607 | |
608 case 5: | |
609 { | |
610 GSList *a = gaim_accounts; | |
611 while (a) { | |
612 struct gaim_account *account = a->data; | |
613 XST_mPV(i++, account->username); | |
614 a = a->next; | |
615 } | |
616 } | |
617 break; | |
618 | |
619 case 6: | |
620 { | |
621 GSList *a = gaim_accounts; | |
622 while (a) { | |
623 struct gaim_account *account = a->data; | |
624 XST_mIV(i++, account->protocol); | |
625 a = a->next; | |
626 } | |
627 } | |
628 break; | |
629 | |
630 case 7: | |
631 { | |
632 struct gaim_connection *gc = | |
633 (struct gaim_connection *)SvIV(ST(1)); | |
634 | |
5470
cb8e58ded7b0
[gaim-migrate @ 5862]
Herman Bloggs <hermanator12002@yahoo.com>
parents:
5445
diff
changeset
|
635 if (g_slist_find(gaim_get_connections(), gc)) |
5205 | 636 XST_mPV(i++, gc->prpl->info->name); |
637 else | |
638 XST_mPV(i++, "Unknown"); | |
639 } | |
640 break; | |
641 | |
642 default: | |
643 XST_mPV(0, "Error2"); | |
644 i = 1; | |
645 } | |
646 | |
647 XSRETURN(i); | |
648 } | |
649 | |
650 XS (XS_GAIM_print) | |
651 { | |
652 char *title; | |
653 char *message; | |
654 unsigned int junk; | |
655 dXSARGS; | |
656 items = 0; | |
657 | |
658 title = SvPV(ST(0), junk); | |
659 message = SvPV(ST(1), junk); | |
5445
ad9b6e65713b
[gaim-migrate @ 5827]
Christian Hammond <chipx86@chipx86.com>
parents:
5436
diff
changeset
|
660 gaim_notify_info(my_plugin, NULL, title, message); |
5205 | 661 XSRETURN(0); |
662 } | |
663 | |
664 XS (XS_GAIM_buddy_list) | |
665 { | |
666 struct gaim_connection *gc; | |
667 struct buddy *buddy; | |
668 struct group *g; | |
669 GaimBlistNode *gnode,*bnode; | |
670 int i = 0; | |
671 dXSARGS; | |
672 items = 0; | |
673 | |
674 gc = (struct gaim_connection *)SvIV(ST(0)); | |
675 | |
676 for(gnode = gaim_get_blist()->root; gnode; gnode = gnode->next) { | |
677 if(!GAIM_BLIST_NODE_IS_GROUP(gnode)) | |
678 continue; | |
679 g = (struct group *)gnode; | |
680 for(bnode = gnode->child; bnode; bnode = bnode->next) { | |
681 if(!GAIM_BLIST_NODE_IS_BUDDY(bnode)) | |
682 continue; | |
683 buddy = (struct buddy *)bnode; | |
684 if(buddy->account == gc->account) | |
685 XST_mPV(i++, buddy->name); | |
686 } | |
687 } | |
688 XSRETURN(i); | |
689 } | |
690 | |
691 XS (XS_GAIM_online_list) | |
692 { | |
693 struct gaim_connection *gc; | |
694 struct buddy *b; | |
695 struct group *g; | |
696 GaimBlistNode *gnode,*bnode; | |
697 int i = 0; | |
698 dXSARGS; | |
699 items = 0; | |
700 | |
701 gc = (struct gaim_connection *)SvIV(ST(0)); | |
702 | |
703 for(gnode = gaim_get_blist()->root; gnode; gnode = gnode->next) { | |
704 if(!GAIM_BLIST_NODE_IS_GROUP(gnode)) | |
705 continue; | |
706 g = (struct group *)gnode; | |
707 for(bnode = gnode->child; bnode; bnode = bnode->next) { | |
708 if(!GAIM_BLIST_NODE_IS_BUDDY(bnode)) | |
709 continue; | |
710 b = (struct buddy *)bnode; | |
711 if (b->account == gc->account && GAIM_BUDDY_IS_ONLINE(b)) XST_mPV(i++, b->name); | |
712 } | |
713 } | |
714 XSRETURN(i); | |
715 } | |
716 | |
717 XS (XS_GAIM_command) | |
718 { | |
719 unsigned int junk; | |
720 char *command = NULL; | |
721 dXSARGS; | |
722 items = 0; | |
723 | |
724 command = SvPV(ST(0), junk); | |
725 if (!command) XSRETURN(0); | |
726 if (!strncasecmp(command, "signon", 6)) { | |
727 int index = SvIV(ST(1)); | |
728 if (g_slist_nth_data(gaim_accounts, index)) | |
729 serv_login(g_slist_nth_data(gaim_accounts, index)); | |
730 } else if (!strncasecmp(command, "signoff", 7)) { | |
731 struct gaim_connection *gc = (struct gaim_connection *)SvIV(ST(1)); | |
5470
cb8e58ded7b0
[gaim-migrate @ 5862]
Herman Bloggs <hermanator12002@yahoo.com>
parents:
5445
diff
changeset
|
732 if (g_slist_find(gaim_get_connections(), gc)) signoff(gc); |
5205 | 733 else signoff_all(NULL, NULL); |
734 } else if (!strncasecmp(command, "info", 4)) { | |
735 struct gaim_connection *gc = (struct gaim_connection *)SvIV(ST(1)); | |
5470
cb8e58ded7b0
[gaim-migrate @ 5862]
Herman Bloggs <hermanator12002@yahoo.com>
parents:
5445
diff
changeset
|
736 if (g_slist_find(gaim_get_connections(), gc)) |
5205 | 737 serv_set_info(gc, SvPV(ST(2), junk)); |
738 } else if (!strncasecmp(command, "away", 4)) { | |
739 char *message = SvPV(ST(1), junk); | |
740 static struct away_message a; | |
741 g_snprintf(a.message, sizeof(a.message), "%s", message); | |
742 do_away_message(NULL, &a); | |
743 } else if (!strncasecmp(command, "back", 4)) { | |
744 do_im_back(); | |
745 } else if (!strncasecmp(command, "idle", 4)) { | |
5470
cb8e58ded7b0
[gaim-migrate @ 5862]
Herman Bloggs <hermanator12002@yahoo.com>
parents:
5445
diff
changeset
|
746 GSList *c = gaim_get_connections(); |
5205 | 747 struct gaim_connection *gc; |
748 | |
749 while (c) { | |
750 gc = (struct gaim_connection *)c->data; | |
751 serv_set_idle(gc, SvIV(ST(1))); | |
752 c = c->next; | |
753 } | |
754 } else if (!strncasecmp(command, "warn", 4)) { | |
5470
cb8e58ded7b0
[gaim-migrate @ 5862]
Herman Bloggs <hermanator12002@yahoo.com>
parents:
5445
diff
changeset
|
755 GSList *c = gaim_get_connections(); |
5205 | 756 struct gaim_connection *gc; |
757 | |
758 while (c) { | |
759 gc = (struct gaim_connection *)c->data; | |
760 serv_warn(gc, SvPV(ST(1), junk), SvIV(ST(2))); | |
761 c = c->next; | |
762 } | |
763 } | |
764 | |
765 XSRETURN(0); | |
766 } | |
767 | |
768 XS (XS_GAIM_user_info) | |
769 { | |
770 struct gaim_connection *gc; | |
771 unsigned int junk; | |
772 struct buddy *buddy = NULL; | |
773 dXSARGS; | |
774 items = 0; | |
775 | |
776 gc = (struct gaim_connection *)SvIV(ST(0)); | |
5470
cb8e58ded7b0
[gaim-migrate @ 5862]
Herman Bloggs <hermanator12002@yahoo.com>
parents:
5445
diff
changeset
|
777 if (g_slist_find(gaim_get_connections(), gc)) |
5205 | 778 buddy = gaim_find_buddy(gc->account, SvPV(ST(1), junk)); |
779 | |
780 if (!buddy) | |
781 XSRETURN(0); | |
782 XST_mPV(0, buddy->name); | |
783 XST_mPV(1, gaim_get_buddy_alias(buddy)); | |
784 XST_mPV(2, GAIM_BUDDY_IS_ONLINE(buddy) ? "Online" : "Offline"); | |
785 XST_mIV(3, buddy->evil); | |
786 XST_mIV(4, buddy->signon); | |
787 XST_mIV(5, buddy->idle); | |
788 XSRETURN(6); | |
789 } | |
790 | |
791 XS (XS_GAIM_write_to_conv) | |
792 { | |
793 char *nick, *who, *what; | |
794 struct gaim_conversation *c; | |
795 int junk; | |
796 int send, wflags; | |
797 dXSARGS; | |
798 items = 0; | |
799 | |
800 nick = SvPV(ST(0), junk); | |
801 send = SvIV(ST(1)); | |
802 what = SvPV(ST(2), junk); | |
803 who = SvPV(ST(3), junk); | |
804 | |
805 if (!*who) who=NULL; | |
806 | |
807 switch (send) { | |
808 case 0: wflags=WFLAG_SEND; break; | |
809 case 1: wflags=WFLAG_RECV; break; | |
810 case 2: wflags=WFLAG_SYSTEM; break; | |
811 default: wflags=WFLAG_RECV; | |
812 } | |
813 | |
814 c = gaim_find_conversation(nick); | |
815 | |
816 if (!c) | |
817 c = gaim_conversation_new(GAIM_CONV_IM, NULL, nick); | |
818 | |
819 gaim_conversation_write(c, who, what, -1, wflags, time(NULL)); | |
820 XSRETURN(0); | |
821 } | |
822 | |
823 XS (XS_GAIM_serv_send_im) | |
824 { | |
825 struct gaim_connection *gc; | |
826 char *nick, *what; | |
827 int isauto; | |
828 int junk; | |
829 dXSARGS; | |
830 items = 0; | |
831 | |
832 gc = (struct gaim_connection *)SvIV(ST(0)); | |
833 nick = SvPV(ST(1), junk); | |
834 what = SvPV(ST(2), junk); | |
835 isauto = SvIV(ST(3)); | |
836 | |
5470
cb8e58ded7b0
[gaim-migrate @ 5862]
Herman Bloggs <hermanator12002@yahoo.com>
parents:
5445
diff
changeset
|
837 if (!g_slist_find(gaim_get_connections(), gc)) { |
5205 | 838 XSRETURN(0); |
839 return; | |
840 } | |
841 serv_send_im(gc, nick, what, -1, isauto); | |
842 XSRETURN(0); | |
843 } | |
844 | |
845 XS (XS_GAIM_print_to_conv) | |
846 { | |
847 struct gaim_connection *gc; | |
848 char *nick, *what; | |
849 int isauto; | |
850 struct gaim_conversation *c; | |
851 unsigned int junk; | |
852 dXSARGS; | |
853 items = 0; | |
854 | |
855 gc = (struct gaim_connection *)SvIV(ST(0)); | |
856 nick = SvPV(ST(1), junk); | |
857 what = SvPV(ST(2), junk); | |
858 isauto = SvIV(ST(3)); | |
5470
cb8e58ded7b0
[gaim-migrate @ 5862]
Herman Bloggs <hermanator12002@yahoo.com>
parents:
5445
diff
changeset
|
859 if (!g_slist_find(gaim_get_connections(), gc)) { |
5205 | 860 XSRETURN(0); |
861 return; | |
862 } | |
863 | |
864 c = gaim_find_conversation(nick); | |
865 | |
866 if (!c) | |
867 c = gaim_conversation_new(GAIM_CONV_IM, gc->account, nick); | |
868 else | |
869 gaim_conversation_set_account(c, gc->account); | |
870 | |
871 gaim_conversation_write(c, NULL, what, -1, | |
872 (WFLAG_SEND | (isauto ? WFLAG_AUTO : 0)), time(NULL)); | |
873 serv_send_im(gc, nick, what, -1, isauto ? IM_FLAG_AWAY : 0); | |
874 XSRETURN(0); | |
875 } | |
876 | |
877 | |
878 | |
879 XS (XS_GAIM_print_to_chat) | |
880 { | |
881 struct gaim_connection *gc; | |
882 int id; | |
883 char *what; | |
884 struct gaim_conversation *b = NULL; | |
885 GSList *bcs; | |
886 unsigned int junk; | |
887 dXSARGS; | |
888 items = 0; | |
889 | |
890 gc = (struct gaim_connection *)SvIV(ST(0)); | |
891 id = SvIV(ST(1)); | |
892 what = SvPV(ST(2), junk); | |
893 | |
5470
cb8e58ded7b0
[gaim-migrate @ 5862]
Herman Bloggs <hermanator12002@yahoo.com>
parents:
5445
diff
changeset
|
894 if (!g_slist_find(gaim_get_connections(), gc)) { |
5205 | 895 XSRETURN(0); |
896 return; | |
897 } | |
898 bcs = gc->buddy_chats; | |
899 while (bcs) { | |
900 b = (struct gaim_conversation *)bcs->data; | |
901 | |
902 if (gaim_chat_get_id(gaim_conversation_get_chat_data(b)) == id) | |
903 break; | |
904 bcs = bcs->next; | |
905 b = NULL; | |
906 } | |
907 if (b) | |
908 serv_chat_send(gc, id, what); | |
909 XSRETURN(0); | |
910 } | |
911 | |
912 static int | |
913 perl_event(GaimEvent event, void *unused, va_list args) | |
914 { | |
915 char *buf[5] = { NULL, NULL, NULL, NULL, NULL }; /* Maximum of 5 args */ | |
916 void *arg1 = NULL, *arg2 = NULL, *arg3 = NULL, *arg4 = NULL, *arg5 = NULL; | |
917 char tmpbuf1[16], tmpbuf2[16], tmpbuf3[1]; | |
918 GList *handler; | |
919 struct _perl_event_handlers *data; | |
920 int handler_return; | |
921 | |
922 arg1 = va_arg(args, void *); | |
923 arg2 = va_arg(args, void *); | |
924 arg3 = va_arg(args, void *); | |
925 arg4 = va_arg(args, void *); | |
926 arg5 = va_arg(args, void *); | |
927 | |
928 tmpbuf1[0] = '\0'; | |
929 tmpbuf2[0] = '\0'; | |
930 tmpbuf3[0] = '\0'; | |
931 | |
932 /* Make a pretty array of char*'s with which to call perl functions */ | |
933 switch (event) { | |
5408
2af3224b329a
[gaim-migrate @ 5784]
Christian Hammond <chipx86@chipx86.com>
parents:
5227
diff
changeset
|
934 case event_connecting: |
5205 | 935 case event_signon: |
936 case event_signoff: | |
937 g_snprintf(tmpbuf1, 16, "%lu", (unsigned long)arg1); | |
938 buf[0] = tmpbuf1; | |
939 break; | |
940 case event_away: | |
941 g_snprintf(tmpbuf1, 16, "%lu", (unsigned long)arg1); | |
942 buf[0] = tmpbuf1; | |
943 buf[1] = ((struct gaim_connection *)arg1)->away ? | |
944 ((struct gaim_connection *)arg1)->away : tmpbuf2; | |
945 break; | |
946 case event_im_recv: | |
947 if (!*(char**)arg2 || !*(char**)arg3) return 1; | |
948 g_snprintf(tmpbuf1, 16, "%lu", (unsigned long)arg1); | |
949 buf[0] = tmpbuf1; | |
950 buf[1] = *(char **)arg2; | |
951 buf[2] = *(char **)arg3; | |
952 break; | |
953 case event_im_send: | |
954 if (!*(char**)arg3) return 1; | |
955 g_snprintf(tmpbuf1, 16, "%lu", (unsigned long)arg1); | |
956 buf[0] = tmpbuf1; | |
957 buf[1] = arg2 ? arg2 : tmpbuf3; | |
958 buf[2] = *(char **)arg3; | |
959 break; | |
960 case event_buddy_signon: | |
961 case event_buddy_signoff: | |
962 case event_set_info: | |
963 case event_buddy_away: | |
964 case event_buddy_back: | |
965 case event_buddy_idle: | |
966 case event_buddy_unidle: | |
967 case event_got_typing: | |
968 g_snprintf(tmpbuf1, 16, "%lu", (unsigned long)arg1); | |
969 buf[0] = tmpbuf1; | |
970 buf[1] = arg2; | |
971 break; | |
972 case event_chat_invited: | |
973 g_snprintf(tmpbuf1, 16, "%lu", (unsigned long)arg1); | |
974 buf[0] = tmpbuf1; | |
975 buf[1] = arg2; | |
976 buf[2] = arg3; | |
977 buf[3] = arg4; | |
978 break; | |
979 case event_chat_join: | |
980 case event_chat_buddy_join: | |
981 case event_chat_buddy_leave: | |
982 g_snprintf(tmpbuf1, 16, "%lu", (unsigned long)arg1); | |
983 buf[0] = tmpbuf1; | |
984 g_snprintf(tmpbuf2, 16, "%d", (int)arg2); | |
985 buf[1] = tmpbuf2; | |
986 buf[2] = arg3; | |
987 break; | |
988 case event_chat_leave: | |
989 g_snprintf(tmpbuf1, 16, "%lu", (unsigned long)arg1); | |
990 buf[0] = tmpbuf1; | |
991 g_snprintf(tmpbuf2, 16, "%d", (int)arg2); | |
992 buf[1] = tmpbuf2; | |
993 break; | |
994 case event_chat_recv: | |
995 if (!*(char**)arg3 || !*(char**)arg4) return 1; | |
996 g_snprintf(tmpbuf1, 16, "%lu", (unsigned long)arg1); | |
997 buf[0] = tmpbuf1; | |
998 g_snprintf(tmpbuf2, 16, "%d", (int)arg2); | |
999 buf[1] = tmpbuf2; | |
1000 buf[2] = *(char **)arg3; | |
1001 buf[3] = *(char **)arg4; | |
1002 break; | |
1003 case event_chat_send_invite: | |
1004 if (!*(char**)arg4) return 1; | |
1005 g_snprintf(tmpbuf1, 16, "%lu", (unsigned long)arg1); | |
1006 buf[0] = tmpbuf1; | |
1007 g_snprintf(tmpbuf2, 16, "%d", (int)arg2); | |
1008 buf[1] = tmpbuf2; | |
1009 buf[2] = arg3; | |
1010 buf[3] = *(char **)arg4; | |
1011 break; | |
1012 case event_chat_send: | |
1013 if (!*(char**)arg3) return 1; | |
1014 g_snprintf(tmpbuf1, 16, "%lu", (unsigned long)arg1); | |
1015 buf[0] = tmpbuf1; | |
1016 g_snprintf(tmpbuf2, 16, "%d", (int)arg2); | |
1017 buf[1] = tmpbuf2; | |
1018 buf[2] = *(char **)arg3; | |
1019 break; | |
1020 case event_warned: | |
1021 g_snprintf(tmpbuf1, 16, "%lu", (unsigned long)arg1); | |
1022 buf[0] = tmpbuf1; | |
1023 buf[1] = arg2 ? arg2 : tmpbuf3; | |
1024 g_snprintf(tmpbuf2, 16, "%d", (int)arg3); | |
1025 buf[2] = tmpbuf2; | |
1026 break; | |
1027 case event_quit: | |
1028 case event_blist_update: | |
1029 buf[0] = tmpbuf3; | |
1030 break; | |
1031 case event_new_conversation: | |
1032 case event_del_conversation: | |
1033 buf[0] = arg1; | |
1034 break; | |
1035 case event_im_displayed_sent: | |
1036 if (!*(char**)arg3) return 1; | |
1037 g_snprintf(tmpbuf1, 16, "%lu", (unsigned long)arg1); | |
1038 buf[0] = tmpbuf1; | |
1039 buf[1] = arg2; | |
1040 buf[2] = *(char **)arg3; | |
1041 break; | |
1042 case event_im_displayed_rcvd: | |
1043 g_snprintf(tmpbuf1, 16, "%lu", (unsigned long)arg1); | |
1044 buf[0] = tmpbuf1; | |
1045 buf[1] = arg2; | |
1046 buf[2] = arg3 ? arg3 : tmpbuf3; | |
1047 break; | |
1048 case event_draw_menu: | |
1049 /* we can't handle this usefully without gtk/perl bindings */ | |
1050 return 0; | |
1051 default: | |
5227
6d1707dc8c3d
[gaim-migrate @ 5597]
Christian Hammond <chipx86@chipx86.com>
parents:
5205
diff
changeset
|
1052 gaim_debug(GAIM_DEBUG_WARNING, "perl", |
6d1707dc8c3d
[gaim-migrate @ 5597]
Christian Hammond <chipx86@chipx86.com>
parents:
5205
diff
changeset
|
1053 "Someone forgot to handle %s in the perl binding\n", |
6d1707dc8c3d
[gaim-migrate @ 5597]
Christian Hammond <chipx86@chipx86.com>
parents:
5205
diff
changeset
|
1054 gaim_event_get_name(event)); |
5205 | 1055 return 0; |
1056 } | |
1057 | |
1058 /* Call any applicable functions */ | |
1059 for (handler = perl_event_handlers; | |
1060 handler != NULL; | |
1061 handler = handler->next) { | |
1062 | |
1063 data = handler->data; | |
1064 | |
1065 if (!strcmp(gaim_event_get_name(event), data->event_type)) { | |
1066 | |
1067 handler_return = execute_perl(data->handler_name, 5, buf); | |
1068 | |
1069 if (handler_return) | |
1070 return handler_return; | |
1071 } | |
1072 } | |
1073 | |
1074 /* Now make changes from perl scripts affect the real data */ | |
1075 switch (event) { | |
1076 case event_im_recv: | |
1077 if (buf[1] != *(char **)arg2) { | |
1078 free(*(char **)arg2); | |
1079 *(char **)arg2 = buf[1]; | |
1080 } | |
1081 if (buf[2] != *(char **)arg3) { | |
1082 free(*(char **)arg3); | |
1083 *(char **)arg3 = buf[2]; | |
1084 } | |
1085 break; | |
1086 case event_im_send: | |
1087 if (buf[2] != *(char **)arg3) { | |
1088 free(*(char **)arg3); | |
1089 *(char **)arg3 = buf[2]; | |
1090 } | |
1091 break; | |
1092 case event_chat_recv: | |
1093 if (buf[2] != *(char **)arg3) { | |
1094 free(*(char **)arg3); | |
1095 *(char **)arg3 = buf[2]; | |
1096 } | |
1097 if (buf[3] != *(char **)arg4) { | |
1098 free(*(char **)arg4); | |
1099 *(char **)arg4 = buf[3]; | |
1100 } | |
1101 break; | |
1102 case event_chat_send_invite: | |
1103 if (buf[3] != *(char **)arg4) { | |
1104 free(*(char **)arg4); | |
1105 *(char **)arg4 = buf[3]; | |
1106 } | |
1107 break; | |
1108 case event_chat_send: | |
1109 if (buf[2] != *(char **)arg3) { | |
1110 free(*(char **)arg3); | |
1111 *(char **)arg3 = buf[2]; | |
1112 } | |
1113 break; | |
1114 case event_im_displayed_sent: | |
1115 if (buf[2] != *(char **)arg3) { | |
1116 free(*(char **)arg3); | |
1117 *(char **)arg3 = buf[2]; | |
1118 } | |
1119 break; | |
1120 default: | |
1121 break; | |
1122 } | |
1123 | |
1124 return 0; | |
1125 } | |
1126 | |
1127 XS (XS_GAIM_add_event_handler) | |
1128 { | |
1129 unsigned int junk; | |
1130 struct _perl_event_handlers *handler; | |
1131 char *handle; | |
1132 GaimPlugin *plug; | |
1133 GList *p; | |
1134 dXSARGS; | |
1135 items = 0; | |
1136 | |
1137 handle = SvPV(ST(0), junk); | |
1138 | |
1139 for (p = gaim_plugins_get_all(); p != NULL; p = p->next) { | |
1140 plug = p->data; | |
1141 | |
1142 if (!strcmp(handle, plug->path)) | |
1143 break; | |
1144 } | |
1145 | |
1146 if (p) { | |
1147 handler = g_new0(struct _perl_event_handlers, 1); | |
1148 handler->event_type = g_strdup(SvPV(ST(1), junk)); | |
1149 handler->handler_name = g_strdup(SvPV(ST(2), junk)); | |
1150 handler->plug = plug; | |
1151 perl_event_handlers = g_list_append(perl_event_handlers, handler); | |
5227
6d1707dc8c3d
[gaim-migrate @ 5597]
Christian Hammond <chipx86@chipx86.com>
parents:
5205
diff
changeset
|
1152 gaim_debug(GAIM_DEBUG_INFO, "perl", |
6d1707dc8c3d
[gaim-migrate @ 5597]
Christian Hammond <chipx86@chipx86.com>
parents:
5205
diff
changeset
|
1153 "Registered perl event handler for %s\n", |
6d1707dc8c3d
[gaim-migrate @ 5597]
Christian Hammond <chipx86@chipx86.com>
parents:
5205
diff
changeset
|
1154 handler->event_type); |
5205 | 1155 } else { |
5227
6d1707dc8c3d
[gaim-migrate @ 5597]
Christian Hammond <chipx86@chipx86.com>
parents:
5205
diff
changeset
|
1156 gaim_debug(GAIM_DEBUG_ERROR, "perl", |
6d1707dc8c3d
[gaim-migrate @ 5597]
Christian Hammond <chipx86@chipx86.com>
parents:
5205
diff
changeset
|
1157 "Invalid handle (%s) registering perl event handler\n", |
6d1707dc8c3d
[gaim-migrate @ 5597]
Christian Hammond <chipx86@chipx86.com>
parents:
5205
diff
changeset
|
1158 handle); |
5205 | 1159 } |
1160 | |
1161 XSRETURN_EMPTY; | |
1162 } | |
1163 | |
1164 XS (XS_GAIM_remove_event_handler) | |
1165 { | |
1166 unsigned int junk; | |
1167 struct _perl_event_handlers *ehn; | |
1168 GList *cur = perl_event_handlers; | |
1169 dXSARGS; | |
1170 items = 0; | |
1171 | |
1172 while (cur) { | |
1173 GList *next = cur->next; | |
1174 ehn = cur->data; | |
1175 | |
1176 if (!strcmp(ehn->event_type, SvPV(ST(0), junk)) && | |
1177 !strcmp(ehn->handler_name, SvPV(ST(1), junk))) | |
1178 { | |
1179 perl_event_handlers = g_list_remove(perl_event_handlers, ehn); | |
1180 g_free(ehn->event_type); | |
1181 g_free(ehn->handler_name); | |
1182 g_free(ehn); | |
1183 } | |
1184 | |
1185 cur = next; | |
1186 } | |
1187 } | |
1188 | |
1189 static int | |
1190 perl_timeout(gpointer data) | |
1191 { | |
1192 char *atmp[2] = { NULL, NULL }; | |
1193 struct _perl_timeout_handlers *handler = data; | |
1194 | |
1195 atmp[0] = escape_quotes(handler->handler_args); | |
1196 execute_perl(handler->handler_name, 1, atmp); | |
1197 | |
1198 perl_timeout_handlers = g_list_remove(perl_timeout_handlers, handler); | |
1199 g_free(handler->handler_args); | |
1200 g_free(handler->handler_name); | |
1201 g_free(handler); | |
1202 | |
1203 return 0; /* returning zero removes the timeout handler */ | |
1204 } | |
1205 | |
1206 XS (XS_GAIM_add_timeout_handler) | |
1207 { | |
1208 unsigned int junk; | |
1209 long timeout; | |
1210 struct _perl_timeout_handlers *handler; | |
1211 char *handle; | |
1212 GaimPlugin *plug; | |
1213 GList *p; | |
1214 | |
1215 dXSARGS; | |
1216 items = 0; | |
1217 | |
1218 handle = SvPV(ST(0), junk); | |
1219 | |
1220 for (p = gaim_plugins_get_all(); p != NULL; p = p->next) { | |
1221 plug = p->data; | |
1222 | |
1223 if (!strcmp(handle, plug->path)) | |
1224 break; | |
1225 } | |
1226 | |
1227 if (p) { | |
1228 handler = g_new0(struct _perl_timeout_handlers, 1); | |
1229 timeout = 1000 * SvIV(ST(1)); | |
5227
6d1707dc8c3d
[gaim-migrate @ 5597]
Christian Hammond <chipx86@chipx86.com>
parents:
5205
diff
changeset
|
1230 gaim_debug(GAIM_DEBUG_INFO, "perl", |
6d1707dc8c3d
[gaim-migrate @ 5597]
Christian Hammond <chipx86@chipx86.com>
parents:
5205
diff
changeset
|
1231 "Adding timeout for %ld seconds.\n", timeout/1000); |
5205 | 1232 handler->plug = plug; |
1233 handler->handler_name = g_strdup(SvPV(ST(2), junk)); | |
1234 handler->handler_args = g_strdup(SvPV(ST(3), junk)); | |
1235 perl_timeout_handlers = g_list_append(perl_timeout_handlers, handler); | |
1236 handler->iotag = g_timeout_add(timeout, perl_timeout, handler); | |
1237 } else { | |
5227
6d1707dc8c3d
[gaim-migrate @ 5597]
Christian Hammond <chipx86@chipx86.com>
parents:
5205
diff
changeset
|
1238 gaim_debug(GAIM_DEBUG_ERROR, "perl", |
6d1707dc8c3d
[gaim-migrate @ 5597]
Christian Hammond <chipx86@chipx86.com>
parents:
5205
diff
changeset
|
1239 "Invalid handle (%s) in adding perl timeout handler.", |
6d1707dc8c3d
[gaim-migrate @ 5597]
Christian Hammond <chipx86@chipx86.com>
parents:
5205
diff
changeset
|
1240 handle); |
5205 | 1241 } |
1242 XSRETURN_EMPTY; | |
1243 } | |
1244 | |
1245 XS (XS_GAIM_play_sound) | |
1246 { | |
1247 int id; | |
1248 dXSARGS; | |
1249 | |
1250 items = 0; | |
1251 | |
1252 id = SvIV(ST(0)); | |
1253 | |
1254 gaim_sound_play_event(id); | |
1255 | |
1256 XSRETURN_EMPTY; | |
1257 } | |
1258 | |
1259 static gboolean | |
1260 probe_perl_plugin(GaimPlugin *plugin) | |
1261 { | |
1262 /* XXX This would be much faster if I didn't create a new | |
1263 * PerlInterpreter every time I probed a plugin */ | |
1264 | |
1265 GaimPluginInfo *info; | |
1266 PerlInterpreter *prober = perl_alloc(); | |
1267 char *argv[] = {"", plugin->path }; | |
1268 int count; | |
1269 gboolean status = TRUE; | |
1270 | |
1271 perl_construct(prober); | |
1272 perl_parse(prober, NULL, 2, argv, NULL); | |
1273 | |
1274 { | |
1275 dSP; | |
1276 ENTER; | |
1277 SAVETMPS; | |
1278 PUSHMARK(SP); | |
1279 | |
1280 count = perl_call_pv("description", G_NOARGS | G_ARRAY | G_EVAL); | |
1281 SPAGAIN; | |
1282 | |
1283 if (count == 6) { | |
1284 info = g_new0(GaimPluginInfo, 1); | |
1285 | |
1286 info->api_version = 2; | |
1287 info->type = GAIM_PLUGIN_STANDARD; | |
1288 | |
1289 info->dependencies = g_list_append(info->dependencies, | |
1290 PERL_PLUGIN_ID); | |
1291 | |
1292 POPp; /* iconfile */ | |
1293 | |
1294 info->homepage = g_strdup(POPp); | |
1295 info->author = g_strdup(POPp); | |
1296 info->description = g_strdup(POPp); | |
1297 info->version = g_strdup(POPp); | |
1298 info->name = g_strdup(POPp); | |
1299 | |
1300 plugin->info = info; | |
1301 | |
1302 if (!gaim_plugin_register(plugin)) | |
1303 status = FALSE; | |
1304 } | |
1305 else | |
1306 status = FALSE; | |
1307 | |
1308 PUTBACK; | |
1309 FREETMPS; | |
1310 LEAVE; | |
1311 } | |
1312 | |
1313 perl_destruct(prober); | |
1314 perl_free(prober); | |
1315 | |
1316 return status; | |
1317 } | |
1318 | |
1319 static gboolean | |
1320 load_perl_plugin(GaimPlugin *plugin) | |
1321 { | |
1322 perl_load_file(plugin->path, plugin); | |
1323 | |
1324 return TRUE; | |
1325 } | |
1326 | |
1327 static gboolean | |
1328 unload_perl_plugin(GaimPlugin *plugin) | |
1329 { | |
1330 perl_unload_file(plugin); | |
1331 | |
1332 return TRUE; | |
1333 } | |
1334 | |
1335 static void | |
1336 destroy_perl_plugin(GaimPlugin *plugin) | |
1337 { | |
1338 if (plugin->info != NULL) { | |
1339 g_free(plugin->info->name); | |
1340 g_free(plugin->info->version); | |
1341 g_free(plugin->info->description); | |
1342 g_free(plugin->info->author); | |
1343 g_free(plugin->info->homepage); | |
1344 } | |
1345 } | |
1346 | |
1347 static gboolean | |
1348 plugin_unload(GaimPlugin *plugin) | |
1349 { | |
1350 perl_end(); | |
1351 | |
1352 return TRUE; | |
1353 } | |
1354 | |
1355 static GaimPluginLoaderInfo loader_info = | |
1356 { | |
1357 NULL, /**< exts */ | |
1358 | |
1359 probe_perl_plugin, /**< probe */ | |
1360 load_perl_plugin, /**< load */ | |
1361 unload_perl_plugin, /**< unload */ | |
1362 destroy_perl_plugin, /**< destroy */ | |
1363 perl_event /**< broadcast */ | |
1364 }; | |
1365 | |
1366 static GaimPluginInfo info = | |
1367 { | |
1368 2, /**< api_version */ | |
1369 GAIM_PLUGIN_LOADER, /**< type */ | |
1370 NULL, /**< ui_requirement */ | |
1371 0, /**< flags */ | |
1372 NULL, /**< dependencies */ | |
1373 GAIM_PRIORITY_DEFAULT, /**< priority */ | |
1374 | |
1375 PERL_PLUGIN_ID, /**< id */ | |
1376 N_("Perl Plugin Loader"), /**< name */ | |
1377 VERSION, /**< version */ | |
1378 N_("Provides support for loading perl plugins."), /**< summary */ | |
1379 N_("Provides support for loading perl plugins."), /**< description */ | |
1380 "Christian Hammond <chipx86@gnupdate.org>", /**< author */ | |
1381 WEBSITE, /**< homepage */ | |
1382 | |
1383 NULL, /**< load */ | |
1384 plugin_unload, /**< unload */ | |
1385 NULL, /**< destroy */ | |
1386 | |
1387 NULL, /**< ui_info */ | |
1388 &loader_info /**< extra_info */ | |
1389 }; | |
1390 | |
1391 static void | |
1392 __init_plugin(GaimPlugin *plugin) | |
1393 { | |
5436
ad445074d239
[gaim-migrate @ 5818]
Christian Hammond <chipx86@chipx86.com>
parents:
5408
diff
changeset
|
1394 my_plugin = plugin; |
ad445074d239
[gaim-migrate @ 5818]
Christian Hammond <chipx86@chipx86.com>
parents:
5408
diff
changeset
|
1395 |
5205 | 1396 loader_info.exts = g_list_append(loader_info.exts, "pl"); |
1397 } | |
1398 | |
1399 GAIM_INIT_PLUGIN(perl, __init_plugin, info); |