4 Copyright (C) 1999-2001 Timo Sirainen
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
8 the Free Software Foundation; either version 2 of the License, or
9 (at your option) any later version.
11 This program is distributed in the hope that it will be useful,
12 but WITHOUT ANY WARRANTY; without even the implied warranty of
13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 GNU General Public License for more details.
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
18 Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
28 #include "lib-config/iconfig.h" /* FIXME: remove before .99 */
30 #include "perl-core.h"
31 #include "perl-common.h"
32 #include "perl-signals.h"
33 #include "perl-sources.h"
36 #include "irssi-core.pl.h"
38 /* For compatibility with perl 5.004 and older */
40 # define PL_perl_destruct_level perl_destruct_level
44 PerlInterpreter *my_perl;
46 static int print_script_errors;
48 #define IS_PERL_SCRIPT(file) \
49 (strlen(file) > 3 && strcmp(file+strlen(file)-3, ".pl") == 0)
51 static void perl_script_destroy_package(PERL_SCRIPT_REC *script)
59 XPUSHs(sv_2mortal(new_pv(script->package)));
62 perl_call_pv("Irssi::Core::destroy", G_VOID|G_EVAL|G_DISCARD);
71 static void perl_script_destroy(PERL_SCRIPT_REC *script)
73 perl_scripts = g_slist_remove(perl_scripts, script);
75 signal_emit("script destroyed", 1, script);
77 perl_signal_remove_script(script);
78 perl_source_remove_script(script);
81 g_free(script->package);
82 g_free_not_null(script->path);
83 g_free_not_null(script->data);
87 extern void boot_DynaLoader(pTHX_ CV* cv);
89 #if PERL_STATIC_LIBS == 1
90 extern void boot_Irssi(CV *cv);
96 irssi_callXS(boot_Irssi, cv, mark);
104 static void xs_init(pTHX)
108 #if PERL_STATIC_LIBS == 1
109 newXS("Irssi::Core::boot_Irssi_Core", boot_Irssi_Core, __FILE__);
112 /* boot the dynaloader too, if we want to use some
113 other dynamic modules.. */
114 newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, __FILE__);
117 /* Initialize perl interpreter */
118 void perl_scripts_init(void)
120 char *args[] = {"", "-e", "0"};
121 char *code, *use_code;
124 perl_sources_start();
125 perl_signals_start();
127 my_perl = perl_alloc();
128 perl_construct(my_perl);
130 perl_parse(my_perl, xs_init, 3, args, NULL);
131 #if PERL_STATIC_LIBS == 1
132 perl_eval_pv("Irssi::Core::boot_Irssi_Core();", TRUE);
137 use_code = perl_get_use_list();
138 code = g_strdup_printf(irssi_core_code, PERL_STATIC_LIBS, use_code);
139 perl_eval_pv(code, TRUE);
145 /* Destroy all perl scripts and deinitialize perl interpreter */
146 void perl_scripts_deinit(void)
151 /* unload all scripts */
152 while (perl_scripts != NULL)
153 perl_script_unload(perl_scripts->data);
155 signal_emit("perl scripts deinit", 0);
161 /* Unload all perl libraries loaded with dynaloader */
162 perl_eval_pv("foreach my $lib (@DynaLoader::dl_modules) { if ($lib =~ /^Irssi\\b/) { $lib .= '::deinit();'; eval $lib; } }", TRUE);
164 /* We could unload all libraries .. but this crashes with some
165 libraries, probably because we don't call some deinit function..
166 Anyway, this would free some memory with /SCRIPT RESET, but it
167 leaks memory anyway. */
168 /*perl_eval_pv("eval { foreach my $lib (@DynaLoader::dl_librefs) { DynaLoader::dl_unload_file($lib); } }", TRUE);*/
170 /* perl interpreter */
171 perl_destruct(my_perl);
176 /* Modify the script name so that all non-alphanumeric characters are
178 void script_fix_name(char *name)
182 p = strrchr(name, '.');
183 if (p != NULL) *p = '\0';
185 while (*name != '\0') {
186 if (*name != '_' && !i_isalnum(*name))
192 static char *script_file_get_name(const char *path)
196 name = g_strdup(g_basename(path));
197 script_fix_name(name);
201 static char *script_data_get_name(void)
207 name = g_string_new(NULL);
210 g_string_sprintf(name, "data%d", n);
212 } while (perl_script_find(name->str) != NULL);
215 g_string_free(name, FALSE);
219 static int perl_script_eval(PERL_SCRIPT_REC *script)
230 XPUSHs(sv_2mortal(new_pv(script->path != NULL ? script->path :
232 XPUSHs(sv_2mortal(new_pv(script->name)));
235 retcount = perl_call_pv(script->path != NULL ?
236 "Irssi::Core::eval_file" :
237 "Irssi::Core::eval_data",
243 error = SvPV(ERRSV, PL_na);
246 error = g_strdup(error);
247 signal_emit("script error", 2, script, error);
250 } else if (retcount > 0) {
251 /* if script returns 0, it means the script wanted to die
252 immediately without any error message */
254 if (ret != &PL_sv_undef && SvIOK(ret) && SvIV(ret) == 0)
262 return error == NULL;
265 /* NOTE: name must not be free'd */
266 static PERL_SCRIPT_REC *script_load(char *name, const char *path,
269 PERL_SCRIPT_REC *script;
271 /* if there's a script with a same name, destroy it */
272 script = perl_script_find(name);
274 perl_script_destroy(script);
276 script = g_new0(PERL_SCRIPT_REC, 1);
278 script->package = g_strdup_printf("Irssi::Script::%s", name);
279 script->path = g_strdup(path);
280 script->data = g_strdup(data);
282 perl_scripts = g_slist_append(perl_scripts, script);
283 signal_emit("script created", 1, script);
285 if (!perl_script_eval(script))
286 script = NULL; /* the script is destroyed in "script error" signal */
290 /* Load a perl script, path must be a full path. */
291 PERL_SCRIPT_REC *perl_script_load_file(const char *path)
295 g_return_val_if_fail(path != NULL, NULL);
297 name = script_file_get_name(path);
298 return script_load(name, path, NULL);
301 /* Load a perl script from given data */
302 PERL_SCRIPT_REC *perl_script_load_data(const char *data)
306 g_return_val_if_fail(data != NULL, NULL);
308 name = script_data_get_name();
309 return script_load(name, NULL, data);
312 /* Unload perl script */
313 void perl_script_unload(PERL_SCRIPT_REC *script)
315 g_return_if_fail(script != NULL);
317 perl_script_destroy_package(script);
318 perl_script_destroy(script);
321 /* Find loaded script by name */
322 PERL_SCRIPT_REC *perl_script_find(const char *name)
326 g_return_val_if_fail(name != NULL, NULL);
328 for (tmp = perl_scripts; tmp != NULL; tmp = tmp->next) {
329 PERL_SCRIPT_REC *rec = tmp->data;
331 if (strcmp(rec->name, name) == 0)
338 /* Find loaded script by package */
339 PERL_SCRIPT_REC *perl_script_find_package(const char *package)
343 g_return_val_if_fail(package != NULL, NULL);
345 for (tmp = perl_scripts; tmp != NULL; tmp = tmp->next) {
346 PERL_SCRIPT_REC *rec = tmp->data;
348 if (strcmp(rec->package, package) == 0)
355 /* Returns full path for the script */
356 char *perl_script_get_path(const char *name)
361 if (g_path_is_absolute(name) || (name[0] == '~' && name[1] == '/')) {
362 /* full path specified */
363 return convert_home(name);
366 /* add .pl suffix if it's missing */
367 file = IS_PERL_SCRIPT(name) ? g_strdup(name) :
368 g_strdup_printf("%s.pl", name);
370 /* check from ~/.irssi/scripts/ */
371 path = g_strdup_printf("%s/scripts/%s", get_irssi_dir(), file);
372 if (stat(path, &statbuf) != 0) {
373 /* check from SCRIPTDIR */
375 path = g_strdup_printf(SCRIPTDIR"/%s", file);
376 if (stat(path, &statbuf) != 0) {
385 /* If core should handle printing script errors */
386 void perl_core_print_script_error(int print)
388 print_script_errors = print;
391 /* Returns the perl module's API version. */
392 int perl_get_api_version(void)
394 return IRSSI_PERL_API_VERSION;
397 static void perl_scripts_autorun(void)
404 /* run *.pl scripts from ~/.irssi/scripts/autorun/ */
405 path = g_strdup_printf("%s/scripts/autorun", get_irssi_dir());
406 dirp = opendir(path);
412 while ((dp = readdir(dirp)) != NULL) {
413 if (!IS_PERL_SCRIPT(dp->d_name))
416 fname = g_strdup_printf("%s/%s", path, dp->d_name);
417 if (stat(fname, &statbuf) == 0 && !S_ISDIR(statbuf.st_mode))
418 perl_script_load_file(fname);
425 static void sig_script_error(PERL_SCRIPT_REC *script, const char *error)
429 if (print_script_errors) {
430 str = g_strdup_printf("Script '%s' error:",
431 script == NULL ? "??" : script->name);
432 signal_emit("gui dialog", 2, "error", str);
433 signal_emit("gui dialog", 2, "error", error);
437 if (script != NULL) {
438 perl_script_unload(script);
443 static void sig_autorun(void)
445 signal_remove("irssi init finished", (SIGNAL_FUNC) sig_autorun);
447 perl_scripts_autorun();
450 void perl_core_init(void)
452 print_script_errors = 1;
453 settings_add_str("perl", "perl_use_lib", PERL_USE_LIB);
455 /*PL_perl_destruct_level = 1; - this crashes with some people.. */
457 signal_add_last("script error", (SIGNAL_FUNC) sig_script_error);
461 if (irssi_init_finished)
462 perl_scripts_autorun();
464 signal_add("irssi init finished", (SIGNAL_FUNC) sig_autorun);
468 module_register("perl", "core");
471 void perl_core_deinit(void)
473 perl_scripts_deinit();
474 perl_signals_deinit();
476 signal_remove("script error", (SIGNAL_FUNC) sig_script_error);