Mercurial > pidgin
comparison plugins/perl/perl.c @ 6636:452c62a92963
[gaim-migrate @ 7161]
Say goodbye to perl namespace collision issues.
committer: Tailor Script <tailor@pidgin.im>
author | Christian Hammond <chipx86@chipx86.com> |
---|---|
date | Wed, 27 Aug 2003 04:50:25 +0000 |
parents | 87a0fb97d3b9 |
children | eb95f31fa4eb |
comparison
equal
deleted
inserted
replaced
6635:96c5630f8d1d | 6636:452c62a92963 |
---|---|
90 #define PERL_PLUGIN_ID "core-perl" | 90 #define PERL_PLUGIN_ID "core-perl" |
91 | 91 |
92 typedef struct | 92 typedef struct |
93 { | 93 { |
94 GaimPlugin *plugin; | 94 GaimPlugin *plugin; |
95 char *package; | |
95 char *load_sub; | 96 char *load_sub; |
96 char *unload_sub; | 97 char *unload_sub; |
97 | 98 |
98 } GaimPerlScript; | 99 } GaimPerlScript; |
99 | 100 |
109 { | 110 { |
110 char *file = __FILE__; | 111 char *file = __FILE__; |
111 | 112 |
112 /* This one allows dynamic loading of perl modules in perl | 113 /* This one allows dynamic loading of perl modules in perl |
113 scripts by the 'use perlmod;' construction*/ | 114 scripts by the 'use perlmod;' construction*/ |
114 newXS ("DynaLoader::boot_DynaLoader", boot_DynaLoader, file); | 115 newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file); |
115 } | 116 } |
116 | 117 |
117 | 118 |
118 static void | 119 static void |
119 perl_init(void) | 120 perl_init(void) |
128 /* We use to function one to load a file the other to | 129 /* We use to function one to load a file the other to |
129 execute the string obtained from the first and holding | 130 execute the string obtained from the first and holding |
130 the file conents. This allows to have a realy local $/ | 131 the file conents. This allows to have a realy local $/ |
131 without introducing temp variables to hold the old | 132 without introducing temp variables to hold the old |
132 value. Just a question of style:) */ | 133 value. Just a question of style:) */ |
133 "sub load_file{" | 134 "package Gaim::PerlLoader;" |
135 "use Symbol;" | |
136 | |
137 "sub load_file {" | |
134 "my $f_name=shift;" | 138 "my $f_name=shift;" |
135 "local $/=undef;" | 139 "local $/=undef;" |
136 "open FH,$f_name or return \"__FAILED__\";" | 140 "open FH,$f_name or return \"__FAILED__\";" |
137 "$_=<FH>;" | 141 "$_=<FH>;" |
138 "close FH;" | 142 "close FH;" |
139 "return $_;" | 143 "return $_;" |
140 "}" | 144 "}" |
141 "sub load_n_eval{" | 145 |
142 "my $f_name=shift;" | 146 "sub destroy_package {" |
147 "eval { $_[0]->UNLOAD() if $_[0]->can('UNLOAD'); };" | |
148 "Symbol::delete_package($_[0]);" | |
149 "}" | |
150 | |
151 "sub load_n_eval {" | |
152 "my ($f_name, $package) = @_;" | |
153 "destroy_package($package);" | |
143 "my $strin=load_file($f_name);" | 154 "my $strin=load_file($f_name);" |
144 "return 2 if($strin eq \"__FAILED__\");" | 155 "return 2 if($strin eq \"__FAILED__\");" |
145 "eval $strin;" | 156 "my $eval = qq{package $package; $strin;};" |
146 "if($@){" | 157 |
158 "{" | |
159 " eval $eval;" | |
160 "}" | |
161 | |
162 "if($@) {" | |
147 /*" #something went wrong\n"*/ | 163 /*" #something went wrong\n"*/ |
148 "Gaim::debug(\"perl\", \"Errors loading file $f_name:\\n$@\");" | 164 "die(\"Errors loading file $f_name: $@\");" |
149 "return 1;" | |
150 "}" | 165 "}" |
166 | |
151 "return 0;" | 167 "return 0;" |
152 "}" | 168 "}" |
153 }; | 169 }; |
154 | 170 |
155 my_perl = perl_alloc(); | 171 my_perl = perl_alloc(); |
197 (*subaddr)(aTHX_ cv); | 213 (*subaddr)(aTHX_ cv); |
198 | 214 |
199 PUTBACK; | 215 PUTBACK; |
200 } | 216 } |
201 | 217 |
218 static void | |
219 normalize_script_name(char *name) | |
220 { | |
221 char *c; | |
222 | |
223 c = strrchr(name, '.'); | |
224 | |
225 if (c != NULL) | |
226 *c = '\0'; | |
227 | |
228 for (c = name; *c != '\0'; c++) | |
229 { | |
230 if (*c == '_' && !g_ascii_isalnum(*c)) | |
231 *c = '_'; | |
232 } | |
233 } | |
234 | |
202 static gboolean | 235 static gboolean |
203 probe_perl_plugin(GaimPlugin *plugin) | 236 probe_perl_plugin(GaimPlugin *plugin) |
204 { | 237 { |
205 /* XXX This would be much faster if I didn't create a new | 238 /* XXX This would be much faster if I didn't create a new |
206 * PerlInterpreter every time I probed a plugin */ | 239 * PerlInterpreter every time I probed a plugin */ |
240 status = FALSE; | 273 status = FALSE; |
241 else | 274 else |
242 { | 275 { |
243 GaimPluginInfo *info; | 276 GaimPluginInfo *info; |
244 GaimPerlScript *gps; | 277 GaimPerlScript *gps; |
278 char *basename; | |
245 int len; | 279 int len; |
246 | 280 |
247 gaim_debug(GAIM_DEBUG_INFO, "perl", "Found plugin info\n"); | 281 gaim_debug(GAIM_DEBUG_INFO, "perl", "Found plugin info\n"); |
248 | 282 |
249 info = g_new0(GaimPluginInfo, 1); | 283 info = g_new0(GaimPluginInfo, 1); |
254 | 288 |
255 info->dependencies = g_list_append(info->dependencies, | 289 info->dependencies = g_list_append(info->dependencies, |
256 PERL_PLUGIN_ID); | 290 PERL_PLUGIN_ID); |
257 | 291 |
258 gps->plugin = plugin; | 292 gps->plugin = plugin; |
293 | |
294 basename = g_path_get_basename(plugin->path); | |
295 normalize_script_name(basename); | |
296 gps->package = g_strdup_printf("Gaim::Script::%s", basename); | |
297 g_free(basename); | |
259 | 298 |
260 /* We know this one exists. */ | 299 /* We know this one exists. */ |
261 key = hv_fetch(plugin_info, "name", strlen("name"), 0); | 300 key = hv_fetch(plugin_info, "name", strlen("name"), 0); |
262 info->name = g_strdup(SvPV(*key, len)); | 301 info->name = g_strdup(SvPV(*key, len)); |
263 | 302 |
277 | 316 |
278 if ((key = hv_fetch(plugin_info, "version", strlen("version"), 0))) | 317 if ((key = hv_fetch(plugin_info, "version", strlen("version"), 0))) |
279 info->version = g_strdup(SvPV(*key, len)); | 318 info->version = g_strdup(SvPV(*key, len)); |
280 | 319 |
281 if ((key = hv_fetch(plugin_info, "load", strlen("load"), 0))) | 320 if ((key = hv_fetch(plugin_info, "load", strlen("load"), 0))) |
282 gps->load_sub = g_strdup(SvPV(*key, len)); | 321 gps->load_sub = g_strdup_printf("%s::%s", gps->package, |
322 SvPV(*key, len)); | |
283 | 323 |
284 if ((key = hv_fetch(plugin_info, "unload", strlen("unload"), 0))) | 324 if ((key = hv_fetch(plugin_info, "unload", strlen("unload"), 0))) |
285 gps->unload_sub = g_strdup(SvPV(*key, len)); | 325 gps->unload_sub = g_strdup_printf("%s::%s", gps->package, |
326 SvPV(*key, len)); | |
286 | 327 |
287 plugin->info = info; | 328 plugin->info = info; |
288 info->extra_info = gps; | 329 info->extra_info = gps; |
289 | 330 |
290 status = gaim_plugin_register(plugin); | 331 status = gaim_plugin_register(plugin); |
299 | 340 |
300 static gboolean | 341 static gboolean |
301 load_perl_plugin(GaimPlugin *plugin) | 342 load_perl_plugin(GaimPlugin *plugin) |
302 { | 343 { |
303 GaimPerlScript *gps = (GaimPerlScript *)plugin->info->extra_info; | 344 GaimPerlScript *gps = (GaimPerlScript *)plugin->info->extra_info; |
304 char *atmp[2] = { plugin->path, NULL }; | 345 char *atmp[3] = { plugin->path, NULL, NULL }; |
305 | 346 |
306 if (gps == NULL || gps->load_sub == NULL) | 347 if (gps == NULL || gps->load_sub == NULL) |
307 return FALSE; | 348 return FALSE; |
308 | 349 |
309 gaim_debug(GAIM_DEBUG_INFO, "perl", "Loading perl script\n"); | 350 gaim_debug(GAIM_DEBUG_INFO, "perl", "Loading perl script\n"); |
310 | 351 |
311 if (my_perl == NULL) | 352 if (my_perl == NULL) |
312 perl_init(); | 353 perl_init(); |
313 | 354 |
314 plugin->handle = plugin->path; | 355 plugin->handle = gps; |
315 | 356 |
316 execute_perl("load_n_eval", 1, atmp); | 357 atmp[1] = gps->package; |
358 | |
359 execute_perl("Gaim::PerlLoader::load_n_eval", 2, atmp); | |
317 | 360 |
318 { | 361 { |
319 dSP; | 362 dSP; |
320 ENTER; | 363 ENTER; |
321 SAVETMPS; | 364 SAVETMPS; |
340 } | 383 } |
341 | 384 |
342 return TRUE; | 385 return TRUE; |
343 } | 386 } |
344 | 387 |
388 static void | |
389 destroy_package(const char *package) | |
390 { | |
391 dSP; | |
392 | |
393 ENTER; | |
394 SAVETMPS; | |
395 | |
396 PUSHMARK(SP); | |
397 XPUSHs(sv_2mortal(newSVpv(package, strlen(package)))); | |
398 PUTBACK; | |
399 | |
400 perl_call_pv("Gaim::PerlLoader::destroy_package", | |
401 G_VOID | G_EVAL | G_DISCARD); | |
402 | |
403 SPAGAIN; | |
404 | |
405 PUTBACK; | |
406 FREETMPS; | |
407 LEAVE; | |
408 } | |
409 | |
345 static gboolean | 410 static gboolean |
346 unload_perl_plugin(GaimPlugin *plugin) | 411 unload_perl_plugin(GaimPlugin *plugin) |
347 { | 412 { |
348 GaimPerlScript *gps = (GaimPerlScript *)plugin->info->extra_info; | 413 GaimPerlScript *gps = (GaimPerlScript *)plugin->info->extra_info; |
349 | 414 |
369 gaim_debug(GAIM_DEBUG_ERROR, "perl", | 434 gaim_debug(GAIM_DEBUG_ERROR, "perl", |
370 "Perl function %s exited abnormally: %s\n", | 435 "Perl function %s exited abnormally: %s\n", |
371 gps->load_sub, SvPV(ERRSV, len)); | 436 gps->load_sub, SvPV(ERRSV, len)); |
372 } | 437 } |
373 | 438 |
374 | |
375 PUTBACK; | 439 PUTBACK; |
376 FREETMPS; | 440 FREETMPS; |
377 LEAVE; | 441 LEAVE; |
378 } | 442 } |
379 | 443 |
380 gaim_perl_signal_clear_for_plugin(plugin); | 444 gaim_perl_signal_clear_for_plugin(plugin); |
381 gaim_perl_timeout_clear_for_plugin(plugin); | 445 gaim_perl_timeout_clear_for_plugin(plugin); |
382 | 446 |
447 destroy_package(gps->package); | |
448 | |
383 return TRUE; | 449 return TRUE; |
384 } | 450 } |
385 | 451 |
386 static void | 452 static void |
387 destroy_perl_plugin(GaimPlugin *plugin) | 453 destroy_perl_plugin(GaimPlugin *plugin) |
415 if (gps->load_sub != NULL) | 481 if (gps->load_sub != NULL) |
416 g_free(gps->load_sub); | 482 g_free(gps->load_sub); |
417 | 483 |
418 if (gps->unload_sub != NULL) | 484 if (gps->unload_sub != NULL) |
419 g_free(gps->unload_sub); | 485 g_free(gps->unload_sub); |
486 | |
487 if (gps->package != NULL) | |
488 g_free(gps->package); | |
420 | 489 |
421 g_free(gps); | 490 g_free(gps); |
422 plugin->info->extra_info = NULL; | 491 plugin->info->extra_info = NULL; |
423 } | 492 } |
424 } | 493 } |