X-Git-Url: http://git.silcnet.org/gitweb/?a=blobdiff_plain;f=apps%2Firssi%2Fsrc%2Fperl%2Fperl-core.c;fp=apps%2Firssi%2Fsrc%2Fperl%2Fperl-core.c;h=0000000000000000000000000000000000000000;hb=72c2de619079457f7a68100eb13385275a424a23;hp=2b660eefa813405aa73cb1538f8214180ccc70e4;hpb=e7b6c157b80152bf9fb9266e6bdd93f9fb0db776;p=runtime.git diff --git a/apps/irssi/src/perl/perl-core.c b/apps/irssi/src/perl/perl-core.c deleted file mode 100644 index 2b660eef..00000000 --- a/apps/irssi/src/perl/perl-core.c +++ /dev/null @@ -1,477 +0,0 @@ -/* - perl-core.c : irssi - - Copyright (C) 1999-2001 Timo Sirainen - - This program is free software; you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation; either version 2 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program; if not, write to the Free Software - Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -*/ - -#define NEED_PERL_H -#include "module.h" -#include "modules.h" -#include "core.h" -#include "signals.h" -#include "misc.h" -#include "settings.h" -#include "lib-config/iconfig.h" /* FIXME: remove before .99 */ - -#include "perl-core.h" -#include "perl-common.h" -#include "perl-signals.h" -#include "perl-sources.h" - -#include "XSUB.h" -#include "irssi-core.pl.h" - -/* For compatibility with perl 5.004 and older */ -#ifndef HAVE_PL_PERL -# define PL_perl_destruct_level perl_destruct_level -#endif - -GSList *perl_scripts; -PerlInterpreter *my_perl; - -static int print_script_errors; - -#define IS_PERL_SCRIPT(file) \ - (strlen(file) > 3 && strcmp(file+strlen(file)-3, ".pl") == 0) - -static void perl_script_destroy_package(PERL_SCRIPT_REC *script) -{ - dSP; - - ENTER; - SAVETMPS; - - PUSHMARK(SP); - XPUSHs(sv_2mortal(new_pv(script->package))); - PUTBACK; - - perl_call_pv("Irssi::Core::destroy", G_VOID|G_EVAL|G_DISCARD); - - SPAGAIN; - - PUTBACK; - FREETMPS; - LEAVE; -} - -static void perl_script_destroy(PERL_SCRIPT_REC *script) -{ - perl_scripts = g_slist_remove(perl_scripts, script); - - signal_emit("script destroyed", 1, script); - - perl_signal_remove_script(script); - perl_source_remove_script(script); - - g_free(script->name); - g_free(script->package); - g_free_not_null(script->path); - g_free_not_null(script->data); - g_free(script); -} - -extern void boot_DynaLoader(pTHX_ CV* cv); - -#if PERL_STATIC_LIBS == 1 -extern void boot_Irssi(CV *cv); - -XS(boot_Irssi_Core) -{ - dXSARGS; - - irssi_callXS(boot_Irssi, cv, mark); - irssi_boot(Irc); - irssi_boot(UI); - irssi_boot(TextUI); - XSRETURN_YES; -} -#endif - -static void xs_init(pTHX) -{ - dXSUB_SYS; - -#if PERL_STATIC_LIBS == 1 - newXS("Irssi::Core::boot_Irssi_Core", boot_Irssi_Core, __FILE__); -#endif - - /* boot the dynaloader too, if we want to use some - other dynamic modules.. */ - newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, __FILE__); -} - -/* Initialize perl interpreter */ -void perl_scripts_init(void) -{ - char *args[] = {"", "-e", "0"}; - char *code, *use_code; - - perl_scripts = NULL; - perl_sources_start(); - perl_signals_start(); - - my_perl = perl_alloc(); - perl_construct(my_perl); - - perl_parse(my_perl, xs_init, 3, args, NULL); -#if PERL_STATIC_LIBS == 1 - perl_eval_pv("Irssi::Core::boot_Irssi_Core();", TRUE); -#endif - - perl_common_start(); - - use_code = perl_get_use_list(); - code = g_strdup_printf(irssi_core_code, PERL_STATIC_LIBS, use_code); - perl_eval_pv(code, TRUE); - - g_free(code); - g_free(use_code); -} - -/* Destroy all perl scripts and deinitialize perl interpreter */ -void perl_scripts_deinit(void) -{ - if (my_perl == NULL) - return; - - /* unload all scripts */ - while (perl_scripts != NULL) - perl_script_unload(perl_scripts->data); - - signal_emit("perl scripts deinit", 0); - - perl_signals_stop(); - perl_sources_stop(); - perl_common_stop(); - - /* Unload all perl libraries loaded with dynaloader */ - perl_eval_pv("foreach my $lib (@DynaLoader::dl_modules) { if ($lib =~ /^Irssi\\b/) { $lib .= '::deinit();'; eval $lib; } }", TRUE); - - /* We could unload all libraries .. but this crashes with some - libraries, probably because we don't call some deinit function.. - Anyway, this would free some memory with /SCRIPT RESET, but it - leaks memory anyway. */ - /*perl_eval_pv("eval { foreach my $lib (@DynaLoader::dl_librefs) { DynaLoader::dl_unload_file($lib); } }", TRUE);*/ - - /* perl interpreter */ - perl_destruct(my_perl); - perl_free(my_perl); - my_perl = NULL; -} - -/* Modify the script name so that all non-alphanumeric characters are - translated to '_' */ -void script_fix_name(char *name) -{ - char *p; - - p = strrchr(name, '.'); - if (p != NULL) *p = '\0'; - - while (*name != '\0') { - if (*name != '_' && !i_isalnum(*name)) - *name = '_'; - name++; - } -} - -static char *script_file_get_name(const char *path) -{ - char *name; - - name = g_strdup(g_basename(path)); - script_fix_name(name); - return name; -} - -static char *script_data_get_name(void) -{ - GString *name; - char *ret; - int n; - - name = g_string_new(NULL); - n = 1; - do { - g_string_sprintf(name, "data%d", n); - n++; - } while (perl_script_find(name->str) != NULL); - - ret = name->str; - g_string_free(name, FALSE); - return ret; -} - -static int perl_script_eval(PERL_SCRIPT_REC *script) -{ - dSP; - char *error; - int retcount; - SV *ret; - - ENTER; - SAVETMPS; - - PUSHMARK(SP); - XPUSHs(sv_2mortal(new_pv(script->path != NULL ? script->path : - script->data))); - XPUSHs(sv_2mortal(new_pv(script->name))); - PUTBACK; - - retcount = perl_call_pv(script->path != NULL ? - "Irssi::Core::eval_file" : - "Irssi::Core::eval_data", - G_EVAL|G_SCALAR); - SPAGAIN; - - error = NULL; - if (SvTRUE(ERRSV)) { - error = SvPV(ERRSV, PL_na); - - if (error != NULL) { - error = g_strdup(error); - signal_emit("script error", 2, script, error); - g_free(error); - } - } else if (retcount > 0) { - /* if script returns 0, it means the script wanted to die - immediately without any error message */ - ret = POPs; - if (ret != &PL_sv_undef && SvIOK(ret) && SvIV(ret) == 0) - error = ""; - } - - PUTBACK; - FREETMPS; - LEAVE; - - return error == NULL; -} - -/* NOTE: name must not be free'd */ -static PERL_SCRIPT_REC *script_load(char *name, const char *path, - const char *data) -{ - PERL_SCRIPT_REC *script; - - /* if there's a script with a same name, destroy it */ - script = perl_script_find(name); - if (script != NULL) - perl_script_destroy(script); - - script = g_new0(PERL_SCRIPT_REC, 1); - script->name = name; - script->package = g_strdup_printf("Irssi::Script::%s", name); - script->path = g_strdup(path); - script->data = g_strdup(data); - - perl_scripts = g_slist_append(perl_scripts, script); - signal_emit("script created", 1, script); - - if (!perl_script_eval(script)) - script = NULL; /* the script is destroyed in "script error" signal */ - return script; -} - -/* Load a perl script, path must be a full path. */ -PERL_SCRIPT_REC *perl_script_load_file(const char *path) -{ - char *name; - - g_return_val_if_fail(path != NULL, NULL); - - name = script_file_get_name(path); - return script_load(name, path, NULL); -} - -/* Load a perl script from given data */ -PERL_SCRIPT_REC *perl_script_load_data(const char *data) -{ - char *name; - - g_return_val_if_fail(data != NULL, NULL); - - name = script_data_get_name(); - return script_load(name, NULL, data); -} - -/* Unload perl script */ -void perl_script_unload(PERL_SCRIPT_REC *script) -{ - g_return_if_fail(script != NULL); - - perl_script_destroy_package(script); - perl_script_destroy(script); -} - -/* Find loaded script by name */ -PERL_SCRIPT_REC *perl_script_find(const char *name) -{ - GSList *tmp; - - g_return_val_if_fail(name != NULL, NULL); - - for (tmp = perl_scripts; tmp != NULL; tmp = tmp->next) { - PERL_SCRIPT_REC *rec = tmp->data; - - if (strcmp(rec->name, name) == 0) - return rec; - } - - return NULL; -} - -/* Find loaded script by package */ -PERL_SCRIPT_REC *perl_script_find_package(const char *package) -{ - GSList *tmp; - - g_return_val_if_fail(package != NULL, NULL); - - for (tmp = perl_scripts; tmp != NULL; tmp = tmp->next) { - PERL_SCRIPT_REC *rec = tmp->data; - - if (strcmp(rec->package, package) == 0) - return rec; - } - - return NULL; -} - -/* Returns full path for the script */ -char *perl_script_get_path(const char *name) -{ - struct stat statbuf; - char *file, *path; - - if (g_path_is_absolute(name) || (name[0] == '~' && name[1] == '/')) { - /* full path specified */ - return convert_home(name); - } - - /* add .pl suffix if it's missing */ - file = IS_PERL_SCRIPT(name) ? g_strdup(name) : - g_strdup_printf("%s.pl", name); - - /* check from ~/.irssi/scripts/ */ - path = g_strdup_printf("%s/scripts/%s", get_irssi_dir(), file); - if (stat(path, &statbuf) != 0) { - /* check from SCRIPTDIR */ - g_free(path); - path = g_strdup_printf(SCRIPTDIR"/%s", file); - if (stat(path, &statbuf) != 0) { - g_free(path); - path = NULL; - } - } - g_free(file); - return path; -} - -/* If core should handle printing script errors */ -void perl_core_print_script_error(int print) -{ - print_script_errors = print; -} - -/* Returns the perl module's API version. */ -int perl_get_api_version(void) -{ - return IRSSI_PERL_API_VERSION; -} - -static void perl_scripts_autorun(void) -{ - DIR *dirp; - struct dirent *dp; - struct stat statbuf; - char *path, *fname; - - /* run *.pl scripts from ~/.irssi/scripts/autorun/ */ - path = g_strdup_printf("%s/scripts/autorun", get_irssi_dir()); - dirp = opendir(path); - if (dirp == NULL) { - g_free(path); - return; - } - - while ((dp = readdir(dirp)) != NULL) { - if (!IS_PERL_SCRIPT(dp->d_name)) - continue; - - fname = g_strdup_printf("%s/%s", path, dp->d_name); - if (stat(fname, &statbuf) == 0 && !S_ISDIR(statbuf.st_mode)) - perl_script_load_file(fname); - g_free(fname); - } - closedir(dirp); - g_free(path); -} - -static void sig_script_error(PERL_SCRIPT_REC *script, const char *error) -{ - char *str; - - if (print_script_errors) { - str = g_strdup_printf("Script '%s' error:", - script == NULL ? "??" : script->name); - signal_emit("gui dialog", 2, "error", str); - signal_emit("gui dialog", 2, "error", error); - g_free(str); - } - - if (script != NULL) { - perl_script_unload(script); - signal_stop(); - } -} - -static void sig_autorun(void) -{ - signal_remove("irssi init finished", (SIGNAL_FUNC) sig_autorun); - - perl_scripts_autorun(); -} - -void perl_core_init(void) -{ - print_script_errors = 1; - settings_add_str("perl", "perl_use_lib", PERL_USE_LIB); - - /*PL_perl_destruct_level = 1; - this crashes with some people.. */ - perl_signals_init(); - signal_add_last("script error", (SIGNAL_FUNC) sig_script_error); - - perl_scripts_init(); - - if (irssi_init_finished) - perl_scripts_autorun(); - else { - signal_add("irssi init finished", (SIGNAL_FUNC) sig_autorun); - settings_check(); - } - - module_register("perl", "core"); -} - -void perl_core_deinit(void) -{ - perl_scripts_deinit(); - perl_signals_deinit(); - - signal_remove("script error", (SIGNAL_FUNC) sig_script_error); -}