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 along
17 with this program; if not, write to the Free Software Foundation, Inc.,
18 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
29 #include "perl-core.h"
30 #include "perl-common.h"
31 #include "perl-signals.h"
32 #include "perl-sources.h"
35 #include "irssi-core.pl.h"
37 extern char **environ;
40 PerlInterpreter *my_perl;
42 static int print_script_errors;
43 static char *perl_args[] = {"", "-e", "0"};
45 #define IS_PERL_SCRIPT(file) \
46 (strlen(file) > 3 && strcmp(file+strlen(file)-3, ".pl") == 0)
48 static void perl_script_destroy_package(PERL_SCRIPT_REC *script)
56 XPUSHs(sv_2mortal(new_pv(script->package)));
59 perl_call_pv("Irssi::Core::destroy", G_VOID|G_EVAL|G_DISCARD);
68 static void perl_script_destroy(PERL_SCRIPT_REC *script)
70 perl_scripts = g_slist_remove(perl_scripts, script);
72 signal_emit("script destroyed", 1, script);
74 perl_signal_remove_script(script);
75 perl_source_remove_script(script);
78 g_free(script->package);
79 g_free_not_null(script->path);
80 g_free_not_null(script->data);
84 extern void boot_DynaLoader(pTHX_ CV* cv);
86 #if PERL_STATIC_LIBS == 1
87 extern void boot_Irssi(CV *cv);
93 irssi_callXS(boot_Irssi, cv, mark);
101 static void xs_init(pTHX)
105 #if PERL_STATIC_LIBS == 1
106 newXS("Irssi::Core::boot_Irssi_Core", boot_Irssi_Core, __FILE__);
109 /* boot the dynaloader too, if we want to use some
110 other dynamic modules.. */
111 newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, __FILE__);
114 /* Initialize perl interpreter */
115 void perl_scripts_init(void)
117 char *code, *use_code;
120 perl_sources_start();
121 perl_signals_start();
123 my_perl = perl_alloc();
124 perl_construct(my_perl);
126 perl_parse(my_perl, xs_init, G_N_ELEMENTS(perl_args), perl_args, NULL);
127 #if PERL_STATIC_LIBS == 1
128 perl_eval_pv("Irssi::Core::boot_Irssi_Core();", TRUE);
133 use_code = perl_get_use_list();
134 code = g_strdup_printf(irssi_core_code, PERL_STATIC_LIBS, use_code);
135 perl_eval_pv(code, TRUE);
141 /* Destroy all perl scripts and deinitialize perl interpreter */
142 void perl_scripts_deinit(void)
147 /* unload all scripts */
148 while (perl_scripts != NULL)
149 perl_script_unload(perl_scripts->data);
151 signal_emit("perl scripts deinit", 0);
157 /* Unload all perl libraries loaded with dynaloader */
158 perl_eval_pv("foreach my $lib (@DynaLoader::dl_modules) { if ($lib =~ /^Irssi\\b/) { $lib .= '::deinit();'; eval $lib; } }", TRUE);
160 /* We could unload all libraries .. but this crashes with some
161 libraries, probably because we don't call some deinit function..
162 Anyway, this would free some memory with /SCRIPT RESET, but it
163 leaks memory anyway. */
164 /*perl_eval_pv("eval { foreach my $lib (@DynaLoader::dl_librefs) { DynaLoader::dl_unload_file($lib); } }", TRUE);*/
166 /* perl interpreter */
167 PL_perl_destruct_level = 1;
168 perl_destruct(my_perl);
173 /* Modify the script name so that all non-alphanumeric characters are
175 void script_fix_name(char *name)
179 p = strrchr(name, '.');
180 if (p != NULL) *p = '\0';
182 while (*name != '\0') {
183 if (*name != '_' && !i_isalnum(*name))
189 static char *script_file_get_name(const char *path)
193 name = g_strdup(g_basename(path));
194 script_fix_name(name);
198 static char *script_data_get_name(void)
204 name = g_string_new(NULL);
207 g_string_printf(name, "data%d", n);
209 } while (perl_script_find(name->str) != NULL);
212 g_string_free(name, FALSE);
216 static int perl_script_eval(PERL_SCRIPT_REC *script)
227 XPUSHs(sv_2mortal(new_pv(script->path != NULL ? script->path :
229 XPUSHs(sv_2mortal(new_pv(script->name)));
232 retcount = perl_call_pv(script->path != NULL ?
233 "Irssi::Core::eval_file" :
234 "Irssi::Core::eval_data",
240 error = SvPV(ERRSV, PL_na);
243 error = g_strdup(error);
244 signal_emit("script error", 2, script, error);
247 } else if (retcount > 0) {
255 return error == NULL;
258 /* NOTE: name must not be free'd */
259 static PERL_SCRIPT_REC *script_load(char *name, const char *path,
262 PERL_SCRIPT_REC *script;
264 /* if there's a script with a same name, destroy it */
265 script = perl_script_find(name);
267 perl_script_unload(script);
269 script = g_new0(PERL_SCRIPT_REC, 1);
271 script->package = g_strdup_printf("Irssi::Script::%s", name);
272 script->path = g_strdup(path);
273 script->data = g_strdup(data);
275 perl_scripts = g_slist_append(perl_scripts, script);
276 signal_emit("script created", 1, script);
278 if (!perl_script_eval(script))
279 script = NULL; /* the script is destroyed in "script error" signal */
283 /* Load a perl script, path must be a full path. */
284 PERL_SCRIPT_REC *perl_script_load_file(const char *path)
288 g_return_val_if_fail(path != NULL, NULL);
290 name = script_file_get_name(path);
291 return script_load(name, path, NULL);
294 /* Load a perl script from given data */
295 PERL_SCRIPT_REC *perl_script_load_data(const char *data)
299 g_return_val_if_fail(data != NULL, NULL);
301 name = script_data_get_name();
302 return script_load(name, NULL, data);
305 /* Unload perl script */
306 void perl_script_unload(PERL_SCRIPT_REC *script)
308 g_return_if_fail(script != NULL);
310 perl_script_destroy_package(script);
311 perl_script_destroy(script);
314 /* Find loaded script by name */
315 PERL_SCRIPT_REC *perl_script_find(const char *name)
319 g_return_val_if_fail(name != NULL, NULL);
321 for (tmp = perl_scripts; tmp != NULL; tmp = tmp->next) {
322 PERL_SCRIPT_REC *rec = tmp->data;
324 if (strcmp(rec->name, name) == 0)
331 /* Find loaded script by package */
332 PERL_SCRIPT_REC *perl_script_find_package(const char *package)
336 g_return_val_if_fail(package != NULL, NULL);
338 for (tmp = perl_scripts; tmp != NULL; tmp = tmp->next) {
339 PERL_SCRIPT_REC *rec = tmp->data;
341 if (strcmp(rec->package, package) == 0)
348 /* Returns full path for the script */
349 char *perl_script_get_path(const char *name)
354 if (g_path_is_absolute(name) || (name[0] == '~' && name[1] == '/')) {
355 /* full path specified */
356 return convert_home(name);
359 /* add .pl suffix if it's missing */
360 file = IS_PERL_SCRIPT(name) ? g_strdup(name) :
361 g_strdup_printf("%s.pl", name);
363 /* check from ~/.irssi/scripts/ */
364 path = g_strdup_printf("%s/scripts/%s", get_irssi_dir(), file);
365 if (stat(path, &statbuf) != 0) {
366 /* check from SCRIPTDIR */
368 path = g_strdup_printf(SCRIPTDIR"/%s", file);
369 if (stat(path, &statbuf) != 0) {
378 /* If core should handle printing script errors */
379 void perl_core_print_script_error(int print)
381 print_script_errors = print;
384 /* Returns the perl module's API version. */
385 int perl_get_api_version(void)
387 return IRSSI_PERL_API_VERSION;
390 static void perl_scripts_autorun(void)
397 /* run *.pl scripts from ~/.irssi/scripts/autorun/ */
398 path = g_strdup_printf("%s/scripts/autorun", get_irssi_dir());
399 dirp = opendir(path);
405 while ((dp = readdir(dirp)) != NULL) {
406 if (!IS_PERL_SCRIPT(dp->d_name))
409 fname = g_strdup_printf("%s/%s", path, dp->d_name);
410 if (stat(fname, &statbuf) == 0 && !S_ISDIR(statbuf.st_mode))
411 perl_script_load_file(fname);
418 static void sig_script_error(PERL_SCRIPT_REC *script, const char *error)
422 if (print_script_errors) {
423 str = g_strdup_printf("Script '%s' error:",
424 script == NULL ? "??" : script->name);
425 signal_emit("gui dialog", 2, "error", str);
426 signal_emit("gui dialog", 2, "error", error);
430 if (script != NULL) {
431 perl_script_unload(script);
436 static void sig_autorun(void)
438 signal_remove("irssi init finished", (SIGNAL_FUNC) sig_autorun);
440 perl_scripts_autorun();
443 void perl_core_init(void)
445 int argc = G_N_ELEMENTS(perl_args);
446 char **argv = perl_args;
448 PERL_SYS_INIT3(&argc, &argv, &environ);
449 print_script_errors = 1;
450 settings_add_str("perl", "perl_use_lib", PERL_USE_LIB);
452 /*PL_perl_destruct_level = 1; - this crashes with some people.. */
454 signal_add_last("script error", (SIGNAL_FUNC) sig_script_error);
458 if (irssi_init_finished)
459 perl_scripts_autorun();
461 signal_add("irssi init finished", (SIGNAL_FUNC) sig_autorun);
465 module_register("perl", "core");
468 void perl_core_deinit(void)
470 perl_scripts_deinit();
471 perl_signals_deinit();
473 signal_remove("script error", (SIGNAL_FUNC) sig_script_error);