Mercurial > pidgin3 / file comparison

comparison: src/perl.c

src/perl.c

changeset 3551
acce66c34dbd
parent 3517
ef03be2348a5
child 3556
328d8598a916
equal deleted inserted replaced
3550:d734c112cec8 3551:acce66c34dbd
71 }; 71 };
72 72
73 struct _perl_event_handlers { 73 struct _perl_event_handlers {
74 char *event_type; 74 char *event_type;
75 char *handler_name; 75 char *handler_name;
76 char *handle;
76 }; 77 };
77 78
78 struct _perl_timeout_handlers { 79 struct _perl_timeout_handlers {
79 char *handler_name; 80 char *handler_name;
80 char *handler_args; 81 char *handler_args;
81 gint iotag; 82 gint iotag;
83 char *handle;
82 }; 84 };
83 85
84 static GList *perl_list = NULL; /* should probably extern this at some point */ 86 static GList *perl_list = NULL; /* should probably extern this at some point */
85 static GList *perl_timeout_handlers = NULL; 87 static GList *perl_timeout_handlers = NULL;
86 static GList *perl_event_handlers = NULL; 88 static GList *perl_event_handlers = NULL;
113 XS(XS_GAIM_play_sound); /*play a sound*/ 115 XS(XS_GAIM_play_sound); /*play a sound*/
114 116
115 void xs_init() 117 void xs_init()
116 { 118 {
117 char *file = __FILE__; 119 char *file = __FILE__;
120
121 /* This one allows dynamic loading of perl modules in perl
122 scripts by the 'use perlmod;' construction*/
118 newXS ("DynaLoader::boot_DynaLoader", boot_DynaLoader, file); 123 newXS ("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);
124
125 /* load up all the custom Gaim perl functions */
126 newXS ("GAIM::register", XS_GAIM_register, "GAIM");
127 newXS ("GAIM::get_info", XS_GAIM_get_info, "GAIM");
128 newXS ("GAIM::print", XS_GAIM_print, "GAIM");
129 newXS ("GAIM::write_to_conv", XS_GAIM_write_to_conv, "GAIM");
130
131 newXS ("GAIM::buddy_list", XS_GAIM_buddy_list, "GAIM");
132 newXS ("GAIM::online_list", XS_GAIM_online_list, "GAIM");
133
134 newXS ("GAIM::command", XS_GAIM_command, "GAIM");
135 newXS ("GAIM::user_info", XS_GAIM_user_info, "GAIM");
136 newXS ("GAIM::print_to_conv", XS_GAIM_print_to_conv, "GAIM");
137 newXS ("GAIM::print_to_chat", XS_GAIM_print_to_chat, "GAIM");
138 newXS ("GAIM::serv_send_im", XS_GAIM_serv_send_im, "GAIM");
139
140 newXS ("GAIM::add_event_handler", XS_GAIM_add_event_handler, "GAIM");
141 newXS ("GAIM::remove_event_handler", XS_GAIM_remove_event_handler, "GAIM");
142 newXS ("GAIM::add_timeout_handler", XS_GAIM_add_timeout_handler, "GAIM");
143
144 newXS ("GAIM::play_sound", XS_GAIM_play_sound, "GAIM");
119 } 145 }
120 146
121 static char *escape_quotes(char *buf) 147 static char *escape_quotes(char *buf)
122 { 148 {
123 static char *tmp_buf = NULL; 149 static char *tmp_buf = NULL;
134 *j = '\0'; 160 *j = '\0';
135 161
136 return (tmp_buf); 162 return (tmp_buf);
137 } 163 }
138 164
139 static SV *execute_perl(char *function, char *args) 165 /*
140 { 166 2001/06/14: execute_perl replaced by Martin Persson <mep@passagen.se>
141 static char *perl_cmd = NULL; 167 previous use of perl_eval leaked memory, replaced with
142 SV *i; 168 a version that uses perl_call instead
143 169 */
144 if (perl_cmd) 170
145 g_free(perl_cmd); 171 static int
146 perl_cmd = g_malloc(strlen(function) + strlen(args) + 4); 172 execute_perl(char *function, char *args)
147 sprintf(perl_cmd, "&%s(%s)", function, args); 173 {
148 #ifndef HAVE_PERL_EVAL_PV 174 char *perl_args[2] = { args, NULL }, buf[512];
149 i = (perl_eval_pv(perl_cmd, TRUE)); 175 int count, ret_value = 1;
150 #else 176 SV *sv;
151 i = (Perl_eval_pv(perl_cmd, TRUE)); 177
152 #endif 178 dSP;
153 return i; 179 ENTER;
180 SAVETMPS;
181 PUSHMARK(sp);
182 count = perl_call_argv(function, G_EVAL | G_SCALAR, perl_args);
183 SPAGAIN;
184
185 sv = GvSV(gv_fetchpv("@", TRUE, SVt_PV));
186 if (SvTRUE(sv)) {
187 snprintf(buf, 512, "Perl error: %s\n", SvPV(sv, count));
188 debug_printf(buf);
189 POPs;
190 } else if (count != 1) {
191 snprintf(buf, 512, "Perl error: expected 1 value from %s, "
192 "got: %d\n", function, count);
193 debug_printf(buf);
194 } else {
195 ret_value = POPi;
196 }
197
198 PUTBACK;
199 FREETMPS;
200 LEAVE;
201
202 return ret_value;
203
204 }
205
206 /* This function is so incredibly broken and should never, ever, ever
207 be trusted to work */
208 void perl_unload_file(struct gaim_plugin *plug) {
209 struct perlscript *scp = NULL;
210 struct _perl_timeout_handlers *thn;
211 struct _perl_event_handlers *ehn;
212
213 GList *pl = perl_list;
214
215 debug_printf("Unloading %s\n", plug->handle);
216 while (pl) {
217 scp = pl->data;
218 /* This is so broken */
219 if (!strcmp(scp->name, plug->desc.name) &&
220 !strcmp(scp->version, plug->desc.version))
221 break;
222 pl = pl->next;
223 scp = NULL;
224 }
225 if (scp) {
226 perl_list = g_list_remove(perl_list, scp);
227 if (scp->shutdowncallback[0])
228 execute_perl(scp->shutdowncallback, "");
229 perl_list = g_list_remove(perl_list, scp);
230 g_free(scp->name);
231 g_free(scp->version);
232 g_free(scp->shutdowncallback);
233 g_free(scp);
234 }
235
236 pl = perl_timeout_handlers;
237 while (pl) {
238 thn = pl->data;
239 if (thn && thn->handle == plug->handle) {
240 g_list_remove(perl_timeout_handlers, thn);
241 g_source_remove(thn->iotag);
242 g_free(thn->handler_args);
243 g_free(thn->handler_name);
244 g_free(thn);
245 }
246 pl = pl->next;
247 }
248
249 pl = perl_event_handlers;
250 while (pl) {
251 ehn = pl->data;
252 if (ehn && ehn->handle == plug->handle) {
253 perl_event_handlers = g_list_remove(perl_event_handlers, ehn);
254 g_free(ehn->event_type);
255 g_free(ehn->handler_name);
256 g_free(ehn);
257 }
258 pl = pl->next;
259 }
260
261 plug->handle=NULL;
154 } 262 }
155 263
156 int perl_load_file(char *script_name) 264 int perl_load_file(char *script_name)
157 { 265 {
158 char *name = g_strdup_printf("'%s'", escape_quotes(script_name)); 266 struct gaim_plugin *plug;
159 SV *return_val; 267 GList *p = probed_plugins;
268 GList *e = perl_event_handlers;
269 GList *t = perl_timeout_handlers;
270 int num_e, num_t, ret;
271
160 if (my_perl == NULL) 272 if (my_perl == NULL)
161 perl_init(); 273 perl_init();
162 return_val = execute_perl("load_file", name); 274
163 g_free(name); 275 while (p) {
164 return SvNV (return_val); 276 plug = (struct gaim_plugin *)p->data;
165 } 277 if (!strcmp(script_name, plug->path))
166 278 break;
167 static int is_pl_file(char *filename) 279 p = p->next;
168 { 280 }
169 int len; 281
170 if (!filename) return 0; 282 if (!plug) {
171 if (!filename[0]) return 0; 283 probe_perl(script_name);
172 len = strlen(filename); 284 }
173 len -= 3; 285
174 if (len < 0) return 0; 286 plug->handle = plug->path;
175 return (!strncmp(filename + len, ".pl", 3)); 287
176 } 288 /* This is such a terrible hack-- if I weren't tired and annoyed
177 289 * with perl, I'm sure I wouldn't even be considering this. */
178 void perl_autoload() 290 num_e=g_list_length(e);
179 { 291 num_t=g_list_length(t);
180 DIR *dir; 292
181 struct dirent *ent; 293 ret = execute_perl("load_n_eval", script_name);
182 struct dirent dirent_buf; 294
183 char *buf; 295 t = g_list_nth(perl_timeout_handlers, num_t++);
184 char *path; 296 while (t) {
185 297 struct _perl_timeout_handlers *h = t->data;
186 path = gaim_user_dir(); 298 h->handle = plug->handle;
187 dir = opendir(path); 299 t = t->next;
188 if (dir) { 300 }
189 while ((readdir_r(dir,&dirent_buf,&ent),ent)) { 301
190 if (strcmp(ent->d_name, ".") && strcmp(ent->d_name, "..")) { 302 e = g_list_nth(perl_event_handlers, num_e++);
191 if (is_pl_file(ent->d_name)) { 303 while (e) {
192 buf = g_malloc(strlen(path) + strlen(ent->d_name) + 2); 304 struct _perl_event_handlers *h = e->data;
193 sprintf(buf, "%s/%s", path, ent->d_name); 305 h->handle = plug->handle;
194 perl_load_file(buf); 306 e = e->next;
195 g_free(buf); 307 }
196 } 308 return ret;
197 } 309 }
198 } 310
199 closedir(dir); 311 struct gaim_plugin *probe_perl(const char *filename) {
200 } 312
201 g_free(path); 313 /* XXX This woulld be much faster if I didn't create a new
314 * PerlInterpreter every time I did probed a plugin */
315
316 PerlInterpreter *prober = perl_alloc();
317 struct gaim_plugin * plug = NULL;
318 char *argv[] = {"", filename};
319 int count;
320 perl_construct(prober);
321 perl_parse(prober, NULL, 2, argv, NULL);
322
323 {
324 dSP;
325 ENTER;
326 SAVETMPS;
327 PUSHMARK(SP);
328 count =perl_call_pv("description", G_NOARGS | G_ARRAY);
329 SPAGAIN;
330
331 if (count = sizeof(struct gaim_plugin_description) / sizeof(char*)) {
332 plug = g_new0(struct gaim_plugin, 1);
333 plug->type = perl_script;
334 g_snprintf(plug->path, sizeof(plug->path), filename);
335 plug->desc.iconfile = g_strdup(POPp);
336 plug->desc.url = g_strdup(POPp);
337 plug->desc.authors = g_strdup(POPp);
338 plug->desc.description = g_strdup(POPp);
339 plug->desc.version = g_strdup(POPp);
340 plug->desc.name = g_strdup(POPp);
341 }
342
343 PUTBACK;
344 FREETMPS;
345 LEAVE;
346 }
347 perl_destruct(prober);
348 perl_free(prober);
349 return plug;
202 } 350 }
203 351
204 static void perl_init() 352 static void perl_init()
205 { 353 { /*changed the name of the variable from load_file to
206 char *perl_args[] = {"", "-e", "0", "-w"}; 354 perl_definitions since now it does much more than defining
207 char load_file[] = 355 the load_file sub. Moreover, deplaced the initialisation to
208 "sub load_file()\n" 356 the xs_init function. (TheHobbit)*/
209 "{\n" 357 char *perl_args[] = { "", "-e", "0", "-w" };
210 " (my $file_name) = @_;\n" 358 char perl_definitions[] =
211 " open FH, $file_name or return 2;\n" 359 {
212 " my $is = $/;\n" 360 /* We use to function one to load a file the other to
213 " local($/) = undef;\n" 361 execute the string obtained from the first and holding
214 " $file = <FH>;\n" 362 the file conents. This allows to have a realy local $/
215 " close FH;\n" 363 without introducing temp variables to hold the old
216 " $/ = $is;\n" 364 value. Just a question of style:) */
217 " $file = \"\\@ISA = qw(Exporter DynaLoader);\\n\" . $file;\n" 365 "sub load_file{"
218 " eval $file;\n" 366 "my $f_name=shift;"
219 " eval $file if $@;\n" 367 "local $/=undef;"
220 " return 1 if $@;\n" 368 "open FH,$f_name or return \"__FAILED__\";"
221 " return 0;\n" 369 "$_=<FH>;"
222 "}"; 370 "close FH;"
371 "return $_;"
372 "}"
373 "sub load_n_eval{"
374 "my $f_name=shift;"
375 "my $strin=load_file($f_name);"
376 "return 2 if($strin eq \"__FAILED__\");"
377 "eval $strin;"
378 "if($@){"
379 /*" #something went wrong\n"*/
380 "GAIM::print\"Errors loading file $f_name:\\n\";"
381 "GAIM::print\"$@\\n\";"
382 "return 1;"
383 "}"
384 "return 0;"
385 "}"
386 };
223 387
224 my_perl = perl_alloc(); 388 my_perl = perl_alloc();
225 perl_construct(my_perl); 389 perl_construct(my_perl);
390 #ifdef DEBUG
226 perl_parse(my_perl, xs_init, 4, perl_args, NULL); 391 perl_parse(my_perl, xs_init, 4, perl_args, NULL);
392 #else
393 perl_parse(my_perl, xs_init, 3, perl_args, NULL);
394 #endif
227 #ifndef HAVE_PERL_EVAL_PV 395 #ifndef HAVE_PERL_EVAL_PV
228 perl_eval_pv(load_file, TRUE); 396 eval_pv(perl_definitions, TRUE);
229 #else 397 #else
230 Perl_eval_pv(load_file, TRUE); 398 perl_eval_pv(perl_definitions, TRUE); /* deprecated */
231 #endif 399 #endif
232 400
233 newXS ("GAIM::register", XS_GAIM_register, "GAIM"); 401
234 newXS ("GAIM::get_info", XS_GAIM_get_info, "GAIM");
235 newXS ("GAIM::print", XS_GAIM_print, "GAIM");
236 newXS ("GAIM::write_to_conv", XS_GAIM_write_to_conv, "GAIM");
237
238 newXS ("GAIM::buddy_list", XS_GAIM_buddy_list, "GAIM");
239 newXS ("GAIM::online_list", XS_GAIM_online_list, "GAIM");
240
241 newXS ("GAIM::command", XS_GAIM_command, "GAIM");
242 newXS ("GAIM::user_info", XS_GAIM_user_info, "GAIM");
243 newXS ("GAIM::print_to_conv", XS_GAIM_print_to_conv, "GAIM");
244 newXS ("GAIM::print_to_chat", XS_GAIM_print_to_chat, "GAIM");
245 newXS ("GAIM::serv_send_im", XS_GAIM_serv_send_im, "GAIM");
246
247 newXS ("GAIM::add_event_handler", XS_GAIM_add_event_handler, "GAIM");
248 newXS ("GAIM::remove_event_handler", XS_GAIM_remove_event_handler, "GAIM");
249 newXS ("GAIM::add_timeout_handler", XS_GAIM_add_timeout_handler, "GAIM");
250
251 newXS ("GAIM::play_sound", XS_GAIM_play_sound, "GAIM");
252 } 402 }
253 403
254 void perl_end() 404 void perl_end()
255 { 405 {
256 struct perlscript *scp; 406 struct perlscript *scp;
279 429
280 while (perl_event_handlers) { 430 while (perl_event_handlers) {
281 ehn = perl_event_handlers->data; 431 ehn = perl_event_handlers->data;
282 perl_event_handlers = g_list_remove(perl_event_handlers, ehn); 432 perl_event_handlers = g_list_remove(perl_event_handlers, ehn);
283 g_free(ehn->event_type); 433 g_free(ehn->event_type);
434 debug_printf("handler_name: %s\n", ehn->handler_name);
284 g_free(ehn->handler_name); 435 g_free(ehn->handler_name);
285 g_free(ehn); 436 g_free(ehn);
286 } 437 }
287 438
288 if (my_perl != NULL) { 439 if (my_perl != NULL) {
410 dXSARGS; 561 dXSARGS;
411 items = 0; 562 items = 0;
412 563
413 title = SvPV(ST(0), junk); 564 title = SvPV(ST(0), junk);
414 message = SvPV(ST(1), junk); 565 message = SvPV(ST(1), junk);
415 do_error_dialog(message, NULL, GAIM_INFO); 566 do_error_dialog(title, message, GAIM_INFO);
416 XSRETURN(0); 567 XSRETURN(0);
417 } 568 }
418 569
419 XS (XS_GAIM_buddy_list) 570 XS (XS_GAIM_buddy_list)
420 { 571 {

Mercurial Repository: pidgin3

mercurial