Mercurial > pidgin.yaz

comparison plugins/perl/perl.c @ 12871:2422097a7a5e

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
[gaim-migrate @ 15223] Whitespace in some .c and .h files that I hadn't had a reason to touch before, this is it's own commit mostly to show how easy it was to get perl plugins to support individual plugin pref frames, as opposed to just one for all the loaded perl plugins. And some whitespace that I missed in Conversation.xs. committer: Tailor Script <tailor@pidgin.im>
author Etan Reisner <pidgin@unreliablesource.net>
date Sat, 14 Jan 2006 07:12:46 +0000
parents cdd941172951
children 59ff3e1c874e
comparison
equal deleted inserted replaced
12870:a9cd674078b1 12871:2422097a7a5e
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 }