Mercurial > pidgin3 / file comparison

comparison: plugins/perl/perl.c

plugins/perl/perl.c

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

Mercurial Repository: pidgin3

mercurial