Mercurial > pidgin
comparison plugins/perl/perl.c @ 6508:cbd24b37350d
[gaim-migrate @ 7025]
Okay, ready for some breakage again? I rewrote the perl loader plugin. All
old scripts are broken, but the new API will be much better. Currently, you
can access accounts and do debug output, and that's it, but adding support
for new things is much easier. Please don't come after me with pitchforks.
committer: Tailor Script <tailor@pidgin.im>
author | Christian Hammond <chipx86@chipx86.com> |
---|---|
date | Tue, 19 Aug 2003 21:47:36 +0000 |
parents | 70d5122bc3ff |
children | 2e2593d95121 |
comparison
equal
deleted
inserted
replaced
6507:c8e31153eea7 | 6508:cbd24b37350d |
---|---|
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) |