Mercurial > pidgin3 / file comparison

comparison: plugins/perl/perl.c

plugins/perl/perl.c

changeset 12871
3584d93ae63c
parent 11842
114c297fae75
child 12872
b3d38f1b9bd7
equal deleted inserted replaced
12870:20dd598144a9 12871:3584d93ae63c
101 char *package; 101 char *package;
102 char *load_sub; 102 char *load_sub;
103 char *unload_sub; 103 char *unload_sub;
104 } GaimPerlScript; 104 } GaimPerlScript;
105 105
106
107 PerlInterpreter *my_perl = NULL; 106 PerlInterpreter *my_perl = NULL;
108 107
109 static void 108 static void
110 #ifdef OLD_PERL 109 #ifdef OLD_PERL
111 xs_init() 110 xs_init()
118 /* This one allows dynamic loading of perl modules in perl 117 /* This one allows dynamic loading of perl modules in perl
119 scripts by the 'use perlmod;' construction*/ 118 scripts by the 'use perlmod;' construction*/
120 newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file); 119 newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);
121 } 120 }
122 121
123
124 static void 122 static void
125 perl_init(void) 123 perl_init(void)
126 { 124 {
127 /* changed the name of the variable from load_file to 125 /* changed the name of the variable from load_file to
128 perl_definitions since now it does much more than defining 126 perl_definitions since now it does much more than defining
129 the load_file sub. Moreover, deplaced the initialisation to 127 the load_file sub. Moreover, deplaced the initialisation to
130 the xs_init function. (TheHobbit)*/ 128 the xs_init function. (TheHobbit) */
131 char *perl_args[] = { "", "-e", "0", "-w" }; 129 char *perl_args[] = { "", "-e", "0", "-w" };
132 char perl_definitions[] = 130 char perl_definitions[] =
133 { 131 {
134 /* We use to function one to load a file the other to 132 /* We use to function one to load a file the other to
135 execute the string obtained from the first and holding 133 execute the string obtained from the first and holding
172 "return 0;" 170 "return 0;"
173 "}" 171 "}"
174 }; 172 };
175 173
176 my_perl = perl_alloc(); 174 my_perl = perl_alloc();
177 PERL_SET_CONTEXT(my_perl); 175 PERL_SET_CONTEXT(my_perl);
178 PL_perl_destruct_level = 1; 176 PL_perl_destruct_level = 1;
179 perl_construct(my_perl); 177 perl_construct(my_perl);
180 #ifdef DEBUG 178 #ifdef DEBUG
181 perl_parse(my_perl, xs_init, 4, perl_args, NULL); 179 perl_parse(my_perl, xs_init, 4, perl_args, NULL);
182 #else 180 #else
193 static void 191 static void
194 perl_end(void) 192 perl_end(void)
195 { 193 {
196 if (my_perl == NULL) 194 if (my_perl == NULL)
197 return; 195 return;
198 196
199 PL_perl_destruct_level = 1; 197 PL_perl_destruct_level = 1;
200 PERL_SET_CONTEXT(my_perl); 198 PERL_SET_CONTEXT(my_perl);
201 perl_eval_pv( 199 perl_eval_pv(
202 "foreach my $lib (@DynaLoader::dl_modules) {" 200 "foreach my $lib (@DynaLoader::dl_modules) {"
203 "if ($lib =~ /^Gaim\\b/) {" 201 "if ($lib =~ /^Gaim\\b/) {"
206 "}" 204 "}"
207 "}", 205 "}",
208 TRUE); 206 TRUE);
209 207
210 PL_perl_destruct_level = 1; 208 PL_perl_destruct_level = 1;
211 PERL_SET_CONTEXT(my_perl); 209 PERL_SET_CONTEXT(my_perl);
212 perl_destruct(my_perl); 210 perl_destruct(my_perl);
213 perl_free(my_perl); 211 perl_free(my_perl);
214 my_perl = NULL; 212 my_perl = NULL;
215 } 213 }
216 214
228 static gboolean 226 static gboolean
229 probe_perl_plugin(GaimPlugin *plugin) 227 probe_perl_plugin(GaimPlugin *plugin)
230 { 228 {
231 /* XXX This would be much faster if I didn't create a new 229 /* XXX This would be much faster if I didn't create a new
232 * PerlInterpreter every time I probed a plugin */ 230 * PerlInterpreter every time I probed a plugin */
233 231
234 PerlInterpreter *prober = perl_alloc(); 232 PerlInterpreter *prober = perl_alloc();
235 char *argv[] = {"", plugin->path }; 233 char *argv[] = {"", plugin->path };
236 gboolean status = TRUE; 234 gboolean status = TRUE;
237 HV *plugin_info; 235 HV *plugin_info;
238 PERL_SET_CONTEXT(prober); 236 PERL_SET_CONTEXT(prober);
239 PL_perl_destruct_level = 1; 237 PL_perl_destruct_level = 1;
240 perl_construct(prober); 238 perl_construct(prober);
241 239
242 perl_parse(prober, xs_init, 2, argv, NULL); 240 perl_parse(prober, xs_init, 2, argv, NULL);
243 241
246 plugin_info = perl_get_hv("PLUGIN_INFO", FALSE); 244 plugin_info = perl_get_hv("PLUGIN_INFO", FALSE);
247 245
248 if (plugin_info == NULL) 246 if (plugin_info == NULL)
249 status = FALSE; 247 status = FALSE;
250 else if (!hv_exists(plugin_info, "perl_api_version", 248 else if (!hv_exists(plugin_info, "perl_api_version",
251 strlen("perl_api_version")) || 249 strlen("perl_api_version")) ||
252 !hv_exists(plugin_info, "name", strlen("name")) || 250 !hv_exists(plugin_info, "name", strlen("name")) ||
253 !hv_exists(plugin_info, "load", strlen("load"))) 251 !hv_exists(plugin_info, "load", strlen("load"))) {
254 {
255 /* Not a valid plugin. */ 252 /* Not a valid plugin. */
256 253
257 status = FALSE; 254 status = FALSE;
258 } 255 } else {
259 else
260 {
261 SV **key; 256 SV **key;
262 int perl_api_ver; 257 int perl_api_ver;
263 258
264 key = hv_fetch(plugin_info, "perl_api_version", 259 key = hv_fetch(plugin_info, "perl_api_version",
265 strlen("perl_api_version"), 0); 260 strlen("perl_api_version"), 0);
266 261
267 perl_api_ver = SvIV(*key); 262 perl_api_ver = SvIV(*key);
268 263
269 if (perl_api_ver != 2) 264 if (perl_api_ver != 2)
270 status = FALSE; 265 status = FALSE;
271 else 266 else {
272 {
273 GaimPluginInfo *info; 267 GaimPluginInfo *info;
274 GaimPerlScript *gps; 268 GaimPerlScript *gps;
275 char *basename; 269 char *basename;
276 STRLEN len; 270 STRLEN len;
277 271
278 gaim_debug(GAIM_DEBUG_INFO, "perl", "Found plugin info\n"); 272 gaim_debug(GAIM_DEBUG_INFO, "perl",
273 "Found plugin info\n");
279 274
280 info = g_new0(GaimPluginInfo, 1); 275 info = g_new0(GaimPluginInfo, 1);
281 gps = g_new0(GaimPerlScript, 1); 276 gps = g_new0(GaimPerlScript, 1);
282 277
283 info->magic = GAIM_PLUGIN_MAGIC; 278 info->magic = GAIM_PLUGIN_MAGIC;
284 info->major_version = GAIM_MAJOR_VERSION; 279 info->major_version = GAIM_MAJOR_VERSION;
285 info->minor_version = GAIM_MINOR_VERSION; 280 info->minor_version = GAIM_MINOR_VERSION;
286 info->type = GAIM_PLUGIN_STANDARD; 281 info->type = GAIM_PLUGIN_STANDARD;
287 282
288 info->dependencies = g_list_append(info->dependencies, 283 info->dependencies = g_list_append(info->dependencies,
289 PERL_PLUGIN_ID); 284 PERL_PLUGIN_ID);
290 285
291 gps->plugin = plugin; 286 gps->plugin = plugin;
292 287
293 basename = g_path_get_basename(plugin->path); 288 basename = g_path_get_basename(plugin->path);
294 gaim_perl_normalize_script_name(basename); 289 gaim_perl_normalize_script_name(basename);
295 gps->package = g_strdup_printf("Gaim::Script::%s", basename); 290 gps->package = g_strdup_printf("Gaim::Script::%s",
291 basename);
296 g_free(basename); 292 g_free(basename);
297 293
298 /* We know this one exists. */ 294 /* We know this one exists. */
299 key = hv_fetch(plugin_info, "name", strlen("name"), 0); 295 key = hv_fetch(plugin_info, "name", strlen("name"), 0);
300 info->name = g_strdup(SvPV(*key, len)); 296 info->name = g_strdup(SvPV(*key, len));
301 297
302 if ((key = hv_fetch(plugin_info, "GTK_UI", strlen("GTK_UI"), 0))) 298 if ((key = hv_fetch(plugin_info, "GTK_UI",
299 strlen("GTK_UI"), 0)))
303 info->ui_requirement = GAIM_GTK_PLUGIN_TYPE; 300 info->ui_requirement = GAIM_GTK_PLUGIN_TYPE;
304 301
305 if ((key = hv_fetch(plugin_info, "url", strlen("url"), 0))) 302 if ((key = hv_fetch(plugin_info, "url",
303 strlen("url"), 0)))
306 info->homepage = g_strdup(SvPV(*key, len)); 304 info->homepage = g_strdup(SvPV(*key, len));
307 305
308 if ((key = hv_fetch(plugin_info, "author", strlen("author"), 0))) 306 if ((key = hv_fetch(plugin_info, "author",
307 strlen("author"), 0)))
309 info->author = g_strdup(SvPV(*key, len)); 308 info->author = g_strdup(SvPV(*key, len));
310 309
311 if ((key = hv_fetch(plugin_info, "summary", 310 if ((key = hv_fetch(plugin_info, "summary",
312 strlen("summary"), 0))) 311 strlen("summary"), 0)))
313 info->summary = g_strdup(SvPV(*key, len)); 312 info->summary = g_strdup(SvPV(*key, len));
314 313
315 if ((key = hv_fetch(plugin_info, "description", 314 if ((key = hv_fetch(plugin_info, "description",
316 strlen("description"), 0))) 315 strlen("description"), 0)))
317 info->description = g_strdup(SvPV(*key, len)); 316 info->description = g_strdup(SvPV(*key, len));
318 317
319 if ((key = hv_fetch(plugin_info, "version", strlen("version"), 0))) 318 if ((key = hv_fetch(plugin_info, "version",
319 strlen("version"), 0)))
320 info->version = g_strdup(SvPV(*key, len)); 320 info->version = g_strdup(SvPV(*key, len));
321 321
322 if ((key = hv_fetch(plugin_info, "load", strlen("load"), 0))) 322 if ((key = hv_fetch(plugin_info, "load",
323 gps->load_sub = g_strdup_printf("%s::%s", gps->package, 323 strlen("load"), 0)))
324 SvPV(*key, len)); 324 gps->load_sub = g_strdup_printf("%s::%s",
325 325 gps->package,
326 if ((key = hv_fetch(plugin_info, "unload", strlen("unload"), 0))) 326 SvPV(*key, len));
327 gps->unload_sub = g_strdup_printf("%s::%s", gps->package, 327
328 SvPV(*key, len)); 328 if ((key = hv_fetch(plugin_info, "unload",
329 329 strlen("unload"), 0)))
330 /********************************************************/ 330 gps->unload_sub = g_strdup_printf("%s::%s",
331 /* Only one of the next two options should be present */ 331 gps->package,
332 /* */ 332 SvPV(*key, len));
333 /* prefs_info - Uses non-GUI (read GTK) gaim API calls */ 333
334 /* and creates a GaimPluginPrefInfo type. */ 334 /********************************************************/
335 /* */ 335 /* Only one of the next two options should be present */
336 /* gtk_prefs_info - Requires gtk2-perl be installed by */ 336 /* */
337 /* the user and he must create a GtkWidget */ 337 /* prefs_info - Uses non-GUI (read GTK) gaim API calls */
338 /* representing the plugin preferences */ 338 /* and creates a GaimPluginPrefInfo type. */
339 /* page. */ 339 /* */
340 /********************************************************/ 340 /* gtk_prefs_info - Requires gtk2-perl be installed by */
341 if ((key = hv_fetch(plugin_info, "prefs_info", strlen("prefs_info"), 0))) { 341 /* the user and he must create a GtkWidget */
342 /* representing the plugin preferences */
343 /* page. */
344 /********************************************************/
345 if ((key = hv_fetch(plugin_info, "prefs_info",
346 strlen("prefs_info"), 0))) {
342 char *tmp = g_strdup_printf("%s::%s", gps->package, SvPV(*key, len)); 347 char *tmp = g_strdup_printf("%s::%s", gps->package, SvPV(*key, len));
343 /* key now is the name of the Perl sub that will create a frame for us */ 348 /* key now is the name of the Perl sub that
349 * will create a frame for us */
344 info->prefs_info = gaim_perl_plugin_pref(tmp); 350 info->prefs_info = gaim_perl_plugin_pref(tmp);
345 g_free(tmp); 351 g_free(tmp);
346 } 352 }
347 353
348 if ((key = hv_fetch(plugin_info, "gtk_prefs_info", strlen("gtk_prefs_info"), 0))) { 354 if ((key = hv_fetch(plugin_info, "gtk_prefs_info",
355 strlen("gtk_prefs_info"), 0))) {
349 char *tmp = g_strdup_printf("%s::%s", gps->package, SvPV(*key, len)); 356 char *tmp = g_strdup_printf("%s::%s", gps->package, SvPV(*key, len));
350 /* key now is the name of the Perl sub that will create a frame for us */ 357 /* key now is the name of the Perl sub that
358 * will create a frame for us */
351 info->ui_info = gaim_perl_gtk_plugin_pref(tmp); 359 info->ui_info = gaim_perl_gtk_plugin_pref(tmp);
352 g_free(tmp); 360 g_free(tmp);
353 } 361 }
354 362
355 /********************************************************/ 363 /********************************************************/
356 /* */ 364 /* */
357 /* plugin_action - This is given to the plugin info */ 365 /* plugin_action - This is given to the plugin info */
358 /* as the action GList. There are two parts */ 366 /* as the action GList. There are two */
359 /* so the user can set the title as it will appear */ 367 /* parts so the user can set the title */
360 /* in the plugin action menu. The name is */ 368 /* as it will appear in the plugin */
361 /* extracted and then the callback perl sub's name */ 369 /* action menu. The name is extracted */
362 /* both of which then are handled by an internal */ 370 /* and then the callback perl sub's */
363 /* gaim_perl function that sets up the single cb */ 371 /* name both of which then are handled */
364 /* function which is then inserted into 'info'. */ 372 /* by an internal gaim_perl function */
365 /********************************************************/ 373 /* that sets up the single cb function */
366 if ((key = hv_fetch(plugin_info, "plugin_action_label", strlen("plugin_action_label"), 0))) { 374 /* which is then inserted into 'info'. */
375 /********************************************************/
376 if ((key = hv_fetch(plugin_info, "plugin_action_label",
377 strlen("plugin_action_label"), 0))) {
367 gaim_perl_plugin_action_label = g_strdup(SvPV(*key, len)); 378 gaim_perl_plugin_action_label = g_strdup(SvPV(*key, len));
368 } 379 }
369 380
370 if ((key = hv_fetch(plugin_info, "plugin_action", strlen("plugin_action"), 0))) { 381 if ((key = hv_fetch(plugin_info, "plugin_action",
382 strlen("plugin_action"), 0))) {
371 gaim_perl_plugin_action_callback_sub = g_strdup_printf("%s::%s", gps->package, SvPV(*key, len)); 383 gaim_perl_plugin_action_callback_sub = g_strdup_printf("%s::%s", gps->package, SvPV(*key, len));
372 info->actions = gaim_perl_plugin_action; 384 info->actions = gaim_perl_plugin_action;
373 } 385 }
374 386
375 plugin->info = info; 387 plugin->info = info;
376 info->extra_info = gps; 388 info->extra_info = gps;
377 389
378 status = gaim_plugin_register(plugin); 390 status = gaim_plugin_register(plugin);
379 } 391 }
380 } 392 }
381 393
382 PL_perl_destruct_level = 1; 394 PL_perl_destruct_level = 1;
383 PERL_SET_CONTEXT(prober); 395 PERL_SET_CONTEXT(prober);
384 perl_destruct(prober); 396 perl_destruct(prober);
385 perl_free(prober); 397 perl_free(prober);
386 return status; 398 return status;
387 } 399 }
388 400
401 perl_init(); 413 perl_init();
402 414
403 plugin->handle = gps; 415 plugin->handle = gps;
404 416
405 atmp[1] = gps->package; 417 atmp[1] = gps->package;
406 418
407 PERL_SET_CONTEXT(my_perl); 419 PERL_SET_CONTEXT(my_perl);
408 execute_perl("Gaim::PerlLoader::load_n_eval", 2, atmp); 420 execute_perl("Gaim::PerlLoader::load_n_eval", 2, atmp);
409 421
410 { 422 {
411 dSP; 423 dSP;
412 PERL_SET_CONTEXT(my_perl); 424 PERL_SET_CONTEXT(my_perl);
413 SPAGAIN; 425 SPAGAIN;
414 ENTER; 426 ENTER;
415 SAVETMPS; 427 SAVETMPS;
416 PUSHMARK(sp); 428 PUSHMARK(sp);
417 XPUSHs(sv_2mortal(gaim_perl_bless_object(plugin, "Gaim::Plugin"))); 429 XPUSHs(sv_2mortal(gaim_perl_bless_object(plugin,
430 "Gaim::Plugin")));
418 PUTBACK; 431 PUTBACK;
419 432
420 perl_call_pv(gps->load_sub, G_EVAL | G_SCALAR); 433 perl_call_pv(gps->load_sub, G_EVAL | G_SCALAR);
421 SPAGAIN; 434 SPAGAIN;
422 435
423 if (SvTRUE(ERRSV)) { 436 if (SvTRUE(ERRSV)) {
424 STRLEN len; 437 STRLEN len;
425 438
426 gaim_debug(GAIM_DEBUG_ERROR, "perl", 439 gaim_debug(GAIM_DEBUG_ERROR, "perl",
427 "Perl function %s exited abnormally: %s\n", 440 "Perl function %s exited abnormally: %s\n",
428 gps->load_sub, SvPV(ERRSV, len)); 441 gps->load_sub, SvPV(ERRSV, len));
429 } 442 }
430 443
431 PUTBACK; 444 PUTBACK;
432 FREETMPS; 445 FREETMPS;
433 LEAVE; 446 LEAVE;
449 PUSHMARK(SP); 462 PUSHMARK(SP);
450 XPUSHs(sv_2mortal(newSVpv(package, strlen(package)))); 463 XPUSHs(sv_2mortal(newSVpv(package, strlen(package))));
451 PUTBACK; 464 PUTBACK;
452 465
453 perl_call_pv("Gaim::PerlLoader::destroy_package", 466 perl_call_pv("Gaim::PerlLoader::destroy_package",
454 G_VOID | G_EVAL | G_DISCARD); 467 G_VOID | G_EVAL | G_DISCARD);
455 468
456 SPAGAIN; 469 SPAGAIN;
457 470
458 PUTBACK; 471 PUTBACK;
459 FREETMPS; 472 FREETMPS;
468 if (gps == NULL) 481 if (gps == NULL)
469 return FALSE; 482 return FALSE;
470 483
471 gaim_debug(GAIM_DEBUG_INFO, "perl", "Unloading perl script\n"); 484 gaim_debug(GAIM_DEBUG_INFO, "perl", "Unloading perl script\n");
472 485
473 if (gps->unload_sub != NULL) 486 if (gps->unload_sub != NULL) {
474 {
475 dSP; 487 dSP;
476 PERL_SET_CONTEXT(my_perl); 488 PERL_SET_CONTEXT(my_perl);
477 SPAGAIN; 489 SPAGAIN;
478 ENTER; 490 ENTER;
479 SAVETMPS; 491 SAVETMPS;
480 PUSHMARK(sp); 492 PUSHMARK(sp);
481 XPUSHs(sv_2mortal(gaim_perl_bless_object(plugin, "Gaim::Plugin"))); 493 XPUSHs(sv_2mortal(gaim_perl_bless_object(plugin,
494 "Gaim::Plugin")));
482 PUTBACK; 495 PUTBACK;
483 496
484 perl_call_pv(gps->unload_sub, G_EVAL | G_SCALAR); 497 perl_call_pv(gps->unload_sub, G_EVAL | G_SCALAR);
485 SPAGAIN; 498 SPAGAIN;
486 499
487 if (SvTRUE(ERRSV)) { 500 if (SvTRUE(ERRSV)) {
488 STRLEN len; 501 STRLEN len;
489 502
490 gaim_debug(GAIM_DEBUG_ERROR, "perl", 503 gaim_debug(GAIM_DEBUG_ERROR, "perl",
491 "Perl function %s exited abnormally: %s\n", 504 "Perl function %s exited abnormally: %s\n",
492 gps->load_sub, SvPV(ERRSV, len)); 505 gps->load_sub, SvPV(ERRSV, len));
493 } 506 }
494 507
495 PUTBACK; 508 PUTBACK;
496 FREETMPS; 509 FREETMPS;
497 LEAVE; 510 LEAVE;
510 { 523 {
511 if (plugin->info != NULL) 524 if (plugin->info != NULL)
512 { 525 {
513 GaimPerlScript *gps; 526 GaimPerlScript *gps;
514 527
515 if (plugin->info->name != NULL) 528 g_free(plugin->info->name);
516 g_free(plugin->info->name); 529 g_free(plugin->info->version);
517 530 g_free(plugin->info->summary);
518 if (plugin->info->version != NULL) 531 g_free(plugin->info->description);
519 g_free(plugin->info->version); 532 g_free(plugin->info->author);
520 533 g_free(plugin->info->homepage);
521 if (plugin->info->summary != NULL)
522 g_free(plugin->info->summary);
523
524 if (plugin->info->description != NULL)
525 g_free(plugin->info->description);
526
527 if (plugin->info->author != NULL)
528 g_free(plugin->info->author);
529
530 if (plugin->info->homepage != NULL)
531 g_free(plugin->info->homepage);
532 534
533 gps = (GaimPerlScript *)plugin->info->extra_info; 535 gps = (GaimPerlScript *)plugin->info->extra_info;
534 536 if (gps != NULL) {
535 if (gps != NULL) 537 g_free(gps->load_sub);
536 { 538 g_free(gps->unload_sub);
537 if (gps->load_sub != NULL) 539 g_free(gps->package);
538 g_free(gps->load_sub);
539
540 if (gps->unload_sub != NULL)
541 g_free(gps->unload_sub);
542
543 if (gps->package != NULL)
544 g_free(gps->package);
545
546 g_free(gps); 540 g_free(gps);
547 plugin->info->extra_info = NULL; 541 plugin->info->extra_info = NULL;
548 } 542 }
549 } 543 }
550 } 544 }

Mercurial Repository: pidgin3

mercurial