From 5e97ea1549df8b0f5896f2bebf027721bb197eff Mon Sep 17 00:00:00 2001 From: Timo Sirainen Date: Tue, 3 Oct 2000 22:57:14 +0000 Subject: --enable-perl=[yes|no|static] Allows building perl support either as loadable irssi module or statically linked to irssi binary. git-svn-id: http://svn.irssi.org/repos/irssi/trunk@716 dbcabf3a-b0e7-0310-adc4-f8d773084564 --- src/fe-text/irssi.c | 12 + src/perl/Makefile.am | 17 +- src/perl/irc/module.h | 2 +- src/perl/irssi-perl.c | 694 ----------------------------------------------- src/perl/libperl_orig.la | 25 ++ src/perl/perl.c | 694 +++++++++++++++++++++++++++++++++++++++++++++++ 6 files changed, 741 insertions(+), 703 deletions(-) delete mode 100644 src/perl/irssi-perl.c create mode 100644 src/perl/libperl_orig.la create mode 100644 src/perl/perl.c (limited to 'src') diff --git a/src/fe-text/irssi.c b/src/fe-text/irssi.c index 56932326..df11ea66 100644 --- a/src/fe-text/irssi.c +++ b/src/fe-text/irssi.c @@ -40,6 +40,11 @@ #include +#ifdef HAVE_STATIC_PERL +void perl_init(void); +void perl_deinit(void); +#endif + void irc_init(void); void irc_deinit(void); @@ -105,6 +110,9 @@ static void textui_finish_init(void) fe_common_core_finish_init(); fe_common_irc_finish_init(); +#ifdef HAVE_STATIC_PERL + perl_init(); +#endif signal_emit("irssi init finished", 0); screen_refresh_thaw(); @@ -127,6 +135,10 @@ static void textui_deinit(void) gui_entry_deinit(); deinit_screen(); +#ifdef HAVE_STATIC_PERL + perl_deinit(); +#endif + theme_unregister(); fe_common_irc_deinit(); diff --git a/src/perl/Makefile.am b/src/perl/Makefile.am index ae038bc8..785b8205 100644 --- a/src/perl/Makefile.am +++ b/src/perl/Makefile.am @@ -1,9 +1,9 @@ moduledir = $(libdir)/irssi/modules -module_LTLIBRARIES = libirssi_perl.la +module_LTLIBRARIES = libperl.la -libirssi_perl_la_LDFLAGS = -avoid-version +libperl_la_LDFLAGS = -avoid-version -irssi-perl.c: perl-signals.h +perl.c: perl-signals.h INCLUDES = $(GLIB_CFLAGS) \ -DSCRIPTDIR=\""$(libdir)/irssi/scripts"\" \ @@ -11,8 +11,8 @@ INCLUDES = $(GLIB_CFLAGS) \ -I$(top_srcdir)/src \ -I$(top_srcdir)/src/core -libirssi_perl_la_SOURCES = \ - irssi-perl.c \ +libperl_la_SOURCES = \ + perl.c \ perl-common.c \ xsinit.c @@ -54,6 +54,7 @@ IRC_SOURCES = \ EXTRA_DIST = \ libperl_dynaloader.la \ + libperl_orig.la \ get-signals.pl \ $(CORE_SOURCES) \ $(IRC_SOURCES) @@ -63,9 +64,9 @@ noinst_HEADERS = \ perl-common.h all-local: - for dir in core irc; do cd $$dir && if [ ! -f Makefile ]; then if [ "x$(PERL_LIB_DIR)" = "x" ]; then $(perlpath) Makefile.PL; else $(perlpath) Makefile.PL LIB=$(PERL_LIB_DIR); fi; fi && $(MAKE) && cd ..; done + for dir in common irc; do cd $$dir && if [ ! -f Makefile ]; then if [ "x$(PERL_LIB_DIR)" = "x" ]; then $(perlpath) Makefile.PL; else $(perlpath) Makefile.PL LIB=$(PERL_LIB_DIR); fi; fi && $(MAKE) && cd ..; done install-exec-local: - for dir in core irc; do cd $$dir && make install && cd ..; done + for dir in common irc; do cd $$dir && make install && cd ..; done -libirssi_perl_la_LIBADD = $(PERL_LDFLAGS) +libperl_la_LIBADD = $(PERL_LDFLAGS) diff --git a/src/perl/irc/module.h b/src/perl/irc/module.h index 58a0b31f..2e0e7823 100644 --- a/src/perl/irc/module.h +++ b/src/perl/irc/module.h @@ -1,4 +1,4 @@ -#include "../core/module.h" +#include "../common/module.h" #include "irc-servers.h" #include "irc-channels.h" diff --git a/src/perl/irssi-perl.c b/src/perl/irssi-perl.c deleted file mode 100644 index 44dcd7b6..00000000 --- a/src/perl/irssi-perl.c +++ /dev/null @@ -1,694 +0,0 @@ -/* - perl.c : irssi - - Copyright (C) 1999 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 -*/ - -#include -#ifndef _SEM_SEMUN_UNDEFINED -#define HAS_UNION_SEMUN -#endif -#include - -#undef _ -#undef PACKAGE - -#include "module.h" -#include "modules.h" -#include "signals.h" -#include "commands.h" -#include "misc.h" -#include "perl-common.h" - -/* For compatibility with perl 5.004 and older */ -#ifndef ERRSV -# define ERRSV GvSV(errgv) -#endif - -#ifndef HAVE_PL_PERL -# define PL_perl_destruct_level perl_destruct_level -#endif - -extern void xs_init(void); - -typedef struct { - int signal_id; - char *signal; - char *args[7]; -} PERL_SIGNAL_ARGS_REC; - -typedef struct { - char *signal; - int signal_id; - - char *func; - int last; -} PERL_SIGNAL_REC; - -typedef struct { - int tag; - char *func; - char *data; -} PERL_TIMEOUT_REC; - -#include "perl-signals.h" - -static GHashTable *first_signals, *last_signals; -static GSList *perl_timeouts; -static GSList *perl_scripts; -static PerlInterpreter *irssi_perl_interp; -static int signal_grabbed, siglast_grabbed; - -static void sig_signal(void *signal, ...); -static void sig_lastsignal(void *signal, ...); - -static void perl_signal_destroy(PERL_SIGNAL_REC *rec) -{ - GHashTable *table; - GSList **siglist; - void *signal_idp; - - g_return_if_fail(rec != NULL); - - table = rec->last ? last_signals : first_signals; - signal_idp = GINT_TO_POINTER(rec->signal_id); - - siglist = g_hash_table_lookup(table, signal_idp); - if (siglist == NULL) return; - - *siglist = g_slist_remove(*siglist, rec); - if (*siglist == NULL) { - g_free(siglist); - g_hash_table_remove(table, signal_idp); - } - - if (!rec->last && signal_grabbed && g_hash_table_size(first_signals) == 0) { - signal_grabbed = FALSE; - signal_remove("signal", (SIGNAL_FUNC) sig_signal); - } - - if (rec->last && siglast_grabbed && g_hash_table_size(last_signals) == 0) { - siglast_grabbed = FALSE; - signal_remove("last signal", (SIGNAL_FUNC) sig_lastsignal); - } - - if (strncmp(rec->signal, "command ", 8) == 0) - command_unbind(rec->signal+8, NULL); - - g_free(rec->signal); - g_free(rec->func); - g_free(rec); -} - -static void perl_timeout_destroy(PERL_TIMEOUT_REC *rec) -{ - perl_timeouts = g_slist_remove(perl_timeouts, rec); - - g_source_remove(rec->tag); - g_free(rec->func); - g_free(rec->data); - g_free(rec); -} - -static void irssi_perl_start(void) -{ - char *args[] = {"", "-e", "0"}; - char eval_file_code[] = - "package Irssi::Load;\n" - "\n" - "use Symbol qw(delete_package);\n" - "\n" - "sub eval_file {\n" - " my ($filename, $id) = @_;\n" - " my $package = \"Irssi::Script::$id\";\n" - " delete_package($package);\n" - "\n" - " local *FH;\n" - " open FH, $filename or die \"File not found: $filename\";\n" - " local($/) = undef;\n" - " my $sub = ;\n" - " close FH;\n" - "\n" - " my $eval = qq{package $package; sub handler { $sub; }};\n" - " {\n" - " # hide our variables within this block\n" - " my ($filename, $package, $sub);\n" - " eval $eval;\n" - " }\n" - " die $@ if $@;\n" - "\n" - " eval {$package->handler;};\n" - " die $@ if $@;\n" - "}"; - - first_signals = g_hash_table_new((GHashFunc) g_direct_hash, - (GCompareFunc) g_direct_equal); - last_signals = g_hash_table_new((GHashFunc) g_direct_hash, - (GCompareFunc) g_direct_equal); - perl_timeouts = NULL; - - irssi_perl_interp = perl_alloc(); - perl_construct(irssi_perl_interp); - - perl_parse(irssi_perl_interp, xs_init, 3, args, NULL); - perl_eval_pv(eval_file_code, TRUE); -} - -static int signal_destroy_hash(void *key, GSList **list, const char *package) -{ - GSList *tmp, *next; - int len; - - len = package == NULL ? 0 : strlen(package); - for (tmp = *list; tmp != NULL; tmp = next) { - PERL_SIGNAL_REC *rec = tmp->data; - - next = tmp->next; - if (package != NULL && strncmp(rec->func, package, len) != 0) - continue; - - if (strncmp(rec->signal, "command ", 8) == 0) - command_unbind(rec->signal+8, NULL); - - *list = g_slist_remove(*list, rec); - - g_free(rec->signal); - g_free(rec->func); - g_free(rec); - } - - if (*list != NULL) - return FALSE; - - g_free(list); - return TRUE; -} - -static int perl_script_destroy(const char *name) -{ - GSList *tmp, *next; - char *package; - int package_len; - - if (gslist_find_string(perl_scripts, name) == NULL) - return FALSE; - - package = g_strdup_printf("Irssi::Script::%s::", name); - package_len = strlen(package); - - g_hash_table_foreach_remove(first_signals, - (GHRFunc) signal_destroy_hash, package); - g_hash_table_foreach_remove(last_signals, - (GHRFunc) signal_destroy_hash, package); - - for (tmp = perl_timeouts; tmp != NULL; tmp = next) { - PERL_TIMEOUT_REC *rec = tmp->data; - - next = tmp->next; - if (strncmp(rec->func, package, package_len) == 0) - perl_timeout_destroy(rec); - } - - g_free(package); - return TRUE; -} - -static void irssi_perl_stop(void) -{ - g_hash_table_foreach(first_signals, - (GHFunc) signal_destroy_hash, NULL); - g_hash_table_destroy(first_signals); - g_hash_table_foreach(last_signals, - (GHFunc) signal_destroy_hash, NULL); - g_hash_table_destroy(last_signals); - first_signals = last_signals = NULL; - - if (signal_grabbed) { - signal_grabbed = FALSE; - signal_remove("signal", (SIGNAL_FUNC) sig_signal); - } - - if (siglast_grabbed) { - siglast_grabbed = FALSE; - signal_remove("last signal", (SIGNAL_FUNC) sig_lastsignal); - } - - while (perl_timeouts != NULL) - perl_timeout_destroy(perl_timeouts->data); - - g_slist_foreach(perl_scripts, (GFunc) g_free, NULL); - g_slist_free(perl_scripts); - perl_scripts = NULL; - - perl_destruct(irssi_perl_interp); - perl_free(irssi_perl_interp); - irssi_perl_interp = NULL; -} - -static void script_fix_name(char *name) -{ - while (*name != '\0') { - if (*name != '_' && !isalnum(*name)) - *name = '_'; - name++; - } -} - -static void cmd_run(const char *data) -{ - dSP; - struct stat statbuf; - char *fname, *name, *p; - int retcount; - - if (g_path_is_absolute(data)) { - /* whole path specified */ - fname = g_strdup(data); - } else { - /* add .pl suffix if it's missing */ - name = (strlen(data) <= 3 || strcmp(data+strlen(data)-3, ".pl") == 0) ? - g_strdup(data) : g_strdup_printf("%s.pl", data); - - /* check from ~/.irssi/scripts/ */ - fname = g_strdup_printf("%s/.irssi/scripts/%s", g_get_home_dir(), name); - if (stat(fname, &statbuf) != 0) { - /* check from SCRIPTDIR */ - g_free(fname), - fname = g_strdup_printf(SCRIPTDIR"/%s", name); - } - g_free(name); - } - - /* get script name */ - name = g_strdup(g_basename(fname)); - p = strrchr(name, '.'); - if (p != NULL) *p = '\0'; - - script_fix_name(name); - perl_script_destroy(name); - perl_scripts = g_slist_append(perl_scripts, g_strdup(name)); - - ENTER; - SAVETMPS; - - PUSHMARK(SP); - XPUSHs(sv_2mortal(newSVpv(fname, strlen(fname)))); g_free(fname); - XPUSHs(sv_2mortal(newSVpv(name, strlen(name)))); g_free(name); - PUTBACK; - - retcount = perl_call_pv("Irssi::Load::eval_file", - G_EVAL|G_SCALAR); - SPAGAIN; - - if (SvTRUE(ERRSV)) { - STRLEN n_a; - - signal_emit("gui dialog", 2, "error", SvPV(ERRSV, n_a)); - (void) POPs; - } - else if (retcount > 0) { - char *str = POPp; - - if (str != NULL && *str != '\0') - signal_emit("gui dialog", 2, "error", str); - } - - PUTBACK; - FREETMPS; - LEAVE; -} - -static void cmd_unload(const char *data) -{ - char *name; - - name = g_strdup(data); - script_fix_name(name); - if (perl_script_destroy(name)) - signal_stop(); - g_free(name); -} - -static void cmd_perlflush(const char *data) -{ - irssi_perl_stop(); - irssi_perl_start(); -} - -/* returns the package who called us */ -static char *perl_get_package(void) -{ - STRLEN n_a; - - perl_eval_pv("($package) = caller;", TRUE); - return SvPV(perl_get_sv("package", FALSE), n_a); -} - -static void perl_signal_to(const char *signal, const char *func, int last) -{ - PERL_SIGNAL_REC *rec; - GHashTable *table; - GSList **siglist; - void *signal_idp; - - rec = g_new(PERL_SIGNAL_REC, 1); - rec->signal_id = signal_get_uniq_id(signal); - rec->signal = g_strdup(signal); - rec->func = g_strdup_printf("%s::%s", perl_get_package(), func); - rec->last = last; - - table = last ? last_signals : first_signals; - signal_idp = GINT_TO_POINTER(rec->signal_id); - - siglist = g_hash_table_lookup(table, signal_idp); - if (siglist == NULL) { - siglist = g_new0(GSList *, 1); - g_hash_table_insert(table, signal_idp, siglist); - } - - *siglist = g_slist_append(*siglist, rec); - - if (!last && !signal_grabbed) { - signal_grabbed = TRUE; - signal_add("signal", (SIGNAL_FUNC) sig_signal); - } else if (last && !siglast_grabbed) { - siglast_grabbed = TRUE; - signal_add("last signal", (SIGNAL_FUNC) sig_lastsignal); - } -} - -void perl_signal_add(const char *signal, const char *func) -{ - perl_signal_to(signal, func, FALSE); -} - -void perl_signal_add_last(const char *signal, const char *func) -{ - perl_signal_to(signal, func, TRUE); -} - -static void perl_signal_remove_list(GSList **list, const char *func) -{ - GSList *tmp; - - g_return_if_fail(list != NULL); - - for (tmp = *list; tmp != NULL; tmp = tmp->next) { - PERL_SIGNAL_REC *rec = tmp->data; - - if (strcmp(func, rec->func) == 0) { - perl_signal_destroy(rec); - break; - } - } -} - -void perl_signal_remove(const char *signal, const char *func) -{ - GSList **list; - char *fullfunc; - int signal_id; - - signal_id = signal_get_uniq_id(signal); - - fullfunc = g_strdup_printf("%s::%s", perl_get_package(), func); - list = g_hash_table_lookup(first_signals, GINT_TO_POINTER(signal_id)); - if (list != NULL) - perl_signal_remove_list(list, func); - else { - list = g_hash_table_lookup(last_signals, GINT_TO_POINTER(signal_id)); - if (list != NULL) perl_signal_remove_list(list, func); - } - g_free(fullfunc); -} - -static int perl_timeout(PERL_TIMEOUT_REC *rec) -{ - dSP; - int retcount; - - ENTER; - SAVETMPS; - - PUSHMARK(SP); - XPUSHs(sv_2mortal(newSVpv(rec->data, strlen(rec->data)))); - PUTBACK; - - retcount = perl_call_pv(rec->func, G_EVAL|G_SCALAR); - SPAGAIN; - - if (SvTRUE(ERRSV)) { - STRLEN n_a; - - signal_emit("perl error", 1, SvPV(ERRSV, n_a)); - (void) POPs; - } - else while (retcount--) (void) POPi; - - PUTBACK; - FREETMPS; - LEAVE; - - return 1; -} - -int perl_timeout_add(int msecs, const char *func, const char *data) -{ - PERL_TIMEOUT_REC *rec; - - rec = g_new(PERL_TIMEOUT_REC, 1); - rec->func = g_strdup_printf("%s::%s", perl_get_package(), func); - rec->data = g_strdup(data); - rec->tag = g_timeout_add(msecs, (GSourceFunc) perl_timeout, rec); - - perl_timeouts = g_slist_append(perl_timeouts, rec); - return rec->tag; -} - -void perl_timeout_remove(int tag) -{ - GSList *tmp; - - for (tmp = perl_timeouts; tmp != NULL; tmp = tmp->next) { - PERL_TIMEOUT_REC *rec = tmp->data; - - if (rec->tag == tag) { - perl_timeout_destroy(rec); - break; - } - } -} - -static int call_perl(const char *func, int signal, va_list va) -{ - dSP; - PERL_SIGNAL_ARGS_REC *rec; - int retcount, n, ret; - void *arg; - HV *stash; - - /* first check if we find exact match */ - rec = NULL; - for (n = 0; perl_signal_args[n].signal != NULL; n++) - { - if (signal == perl_signal_args[n].signal_id) - { - rec = &perl_signal_args[n]; - break; - } - } - - if (rec == NULL) - { - /* try to find by name */ - const char *signame; - - signame = module_find_id_str("signals", signal); - for (n = 0; perl_signal_args[n].signal != NULL; n++) - { - if (strncmp(signame, perl_signal_args[n].signal, - strlen(perl_signal_args[n].signal)) == 0) - { - rec = &perl_signal_args[n]; - break; - } - } - } - - ENTER; - SAVETMPS; - - PUSHMARK(sp); - - if (rec != NULL) - { - /* put the arguments to perl stack */ - for (n = 0; n < 7; n++) - { - arg = va_arg(va, gpointer); - - if (rec->args[n] == NULL) - break; - - if (strcmp(rec->args[n], "string") == 0) - XPUSHs(sv_2mortal(newSVpv(arg == NULL ? "" : arg, arg == NULL ? 0 : strlen(arg)))); - else if (strcmp(rec->args[n], "int") == 0) - XPUSHs(sv_2mortal(newSViv(GPOINTER_TO_INT(arg)))); - else if (strcmp(rec->args[n], "ulongptr") == 0) - XPUSHs(sv_2mortal(newSViv(*(gulong *) arg))); - else if (strncmp(rec->args[n], "gslist_", 7) == 0) - { - GSList *tmp; - - stash = gv_stashpv(rec->args[n]+7, 0); - for (tmp = arg; tmp != NULL; tmp = tmp->next) - XPUSHs(sv_2mortal(sv_bless(newRV_noinc(newSViv(GPOINTER_TO_INT(tmp->data))), stash))); - } - else - { - if (arg == NULL) - XPUSHs(sv_2mortal(newSViv(0))); - else { - stash = gv_stashpv(rec->args[n], 0); - XPUSHs(sv_2mortal(sv_bless(newRV_noinc(newSViv(GPOINTER_TO_INT(arg))), stash))); - } - } - } - } - - PUTBACK; - retcount = perl_call_pv((char *) func, G_EVAL|G_SCALAR); - SPAGAIN; - - ret = 0; - if (SvTRUE(ERRSV)) - { - STRLEN n_a; - - signal_emit("gui dialog", 2, "error", SvPV(ERRSV, n_a)); - (void)POPs; - } - else - { - SV *sv; - - if (retcount > 0) - { - sv = POPs; - if (SvIOK(sv) && SvIV(sv) == 1) ret = 1; - } - for (n = 2; n <= retcount; n++) - (void)POPi; - } - - PUTBACK; - FREETMPS; - LEAVE; - - return ret; -} - -static void sig_signal(void *signal, ...) -{ - GSList **list, *tmp; - va_list va; - - va_start(va, signal); - - list = g_hash_table_lookup(first_signals, signal); - for (tmp = list == NULL ? NULL : *list; tmp != NULL; tmp = tmp->next) { - PERL_SIGNAL_REC *rec = tmp->data; - - if (call_perl(rec->func, GPOINTER_TO_INT(signal), va)) { - signal_stop(); - break; - } - } - - va_end(va); -} - -static void sig_lastsignal(void *signal, ...) -{ - GSList **list, *tmp; - va_list va; - - va_start(va, signal); - - list = g_hash_table_lookup(last_signals, signal); - for (tmp = list == NULL ? NULL : *list; tmp != NULL; tmp = tmp->next) { - PERL_SIGNAL_REC *rec = tmp->data; - - if (call_perl(rec->func, GPOINTER_TO_INT(signal), va)) { - signal_stop(); - break; - } - } - - va_end(va); -} - -static void irssi_perl_autorun(void) -{ - DIR *dirp; - struct dirent *dp; - struct stat statbuf; - char *path, *fname; - - path = g_strdup_printf("%s/.irssi/scripts/autorun", g_get_home_dir()); - dirp = opendir(path); - if (dirp == NULL) { - g_free(path); - return; - } - - while ((dp = readdir(dirp)) != NULL) { - fname = g_strdup_printf("%s/%s", path, dp->d_name); - if (stat(fname, &statbuf) == 0 && !S_ISDIR(statbuf.st_mode)) - cmd_run(fname); - g_free(fname); - } - closedir(dirp); - g_free(path); -} - -void irssi_perl_init(void) -{ - perl_common_init(); - - perl_scripts = NULL; - command_bind("run", NULL, (SIGNAL_FUNC) cmd_run); - command_bind_first("unload", NULL, (SIGNAL_FUNC) cmd_unload); - command_bind("perlflush", NULL, (SIGNAL_FUNC) cmd_perlflush); - signal_grabbed = siglast_grabbed = FALSE; - - PL_perl_destruct_level = 1; - irssi_perl_start(); - irssi_perl_autorun(); -} - -void irssi_perl_deinit(void) -{ - irssi_perl_stop(); - perl_common_deinit(); - - if (signal_grabbed) signal_remove("signal", (SIGNAL_FUNC) sig_signal); - if (siglast_grabbed) signal_remove("last signal", (SIGNAL_FUNC) sig_lastsignal); - command_unbind("run", (SIGNAL_FUNC) cmd_run); - command_unbind("unload", (SIGNAL_FUNC) cmd_unload); - command_unbind("perlflush", (SIGNAL_FUNC) cmd_perlflush); -} diff --git a/src/perl/libperl_orig.la b/src/perl/libperl_orig.la new file mode 100644 index 00000000..c83ffc42 --- /dev/null +++ b/src/perl/libperl_orig.la @@ -0,0 +1,25 @@ +# libsilc.la - a libtool library file +# Generated by ltmain.sh - GNU libtool 1.3.5 (1.385.2.206 2000/05/27 11:12:27) + +# The name that we can dlopen(3). +dlname='' + +# Names of this library. +library_names='' + +# The name of the static archive. +old_library='libperl_orig.a' + +# Libraries that this one depends upon. +dependency_libs='' + +# Version information for libsilc. +current=0 +age=0 +revision=0 + +# Is this an already installed library? +installed=no + +# Directory that this library needs to be installed in: +libdir='' diff --git a/src/perl/perl.c b/src/perl/perl.c new file mode 100644 index 00000000..bf1ae551 --- /dev/null +++ b/src/perl/perl.c @@ -0,0 +1,694 @@ +/* + perl.c : irssi + + Copyright (C) 1999 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 +*/ + +#include +#ifndef _SEM_SEMUN_UNDEFINED +#define HAS_UNION_SEMUN +#endif +#include + +#undef _ +#undef PACKAGE + +#include "module.h" +#include "modules.h" +#include "signals.h" +#include "commands.h" +#include "misc.h" +#include "perl-common.h" + +/* For compatibility with perl 5.004 and older */ +#ifndef ERRSV +# define ERRSV GvSV(errgv) +#endif + +#ifndef HAVE_PL_PERL +# define PL_perl_destruct_level perl_destruct_level +#endif + +extern void xs_init(void); + +typedef struct { + int signal_id; + char *signal; + char *args[7]; +} PERL_SIGNAL_ARGS_REC; + +typedef struct { + char *signal; + int signal_id; + + char *func; + int last; +} PERL_SIGNAL_REC; + +typedef struct { + int tag; + char *func; + char *data; +} PERL_TIMEOUT_REC; + +#include "perl-signals.h" + +static GHashTable *first_signals, *last_signals; +static GSList *perl_timeouts; +static GSList *perl_scripts; +static PerlInterpreter *irssi_perl_interp; +static int signal_grabbed, siglast_grabbed; + +static void sig_signal(void *signal, ...); +static void sig_lastsignal(void *signal, ...); + +static void perl_signal_destroy(PERL_SIGNAL_REC *rec) +{ + GHashTable *table; + GSList **siglist; + void *signal_idp; + + g_return_if_fail(rec != NULL); + + table = rec->last ? last_signals : first_signals; + signal_idp = GINT_TO_POINTER(rec->signal_id); + + siglist = g_hash_table_lookup(table, signal_idp); + if (siglist == NULL) return; + + *siglist = g_slist_remove(*siglist, rec); + if (*siglist == NULL) { + g_free(siglist); + g_hash_table_remove(table, signal_idp); + } + + if (!rec->last && signal_grabbed && g_hash_table_size(first_signals) == 0) { + signal_grabbed = FALSE; + signal_remove("signal", (SIGNAL_FUNC) sig_signal); + } + + if (rec->last && siglast_grabbed && g_hash_table_size(last_signals) == 0) { + siglast_grabbed = FALSE; + signal_remove("last signal", (SIGNAL_FUNC) sig_lastsignal); + } + + if (strncmp(rec->signal, "command ", 8) == 0) + command_unbind(rec->signal+8, NULL); + + g_free(rec->signal); + g_free(rec->func); + g_free(rec); +} + +static void perl_timeout_destroy(PERL_TIMEOUT_REC *rec) +{ + perl_timeouts = g_slist_remove(perl_timeouts, rec); + + g_source_remove(rec->tag); + g_free(rec->func); + g_free(rec->data); + g_free(rec); +} + +static void irssi_perl_start(void) +{ + char *args[] = {"", "-e", "0"}; + char eval_file_code[] = + "package Irssi::Load;\n" + "\n" + "use Symbol qw(delete_package);\n" + "\n" + "sub eval_file {\n" + " my ($filename, $id) = @_;\n" + " my $package = \"Irssi::Script::$id\";\n" + " delete_package($package);\n" + "\n" + " local *FH;\n" + " open FH, $filename or die \"File not found: $filename\";\n" + " local($/) = undef;\n" + " my $sub = ;\n" + " close FH;\n" + "\n" + " my $eval = qq{package $package; sub handler { $sub; }};\n" + " {\n" + " # hide our variables within this block\n" + " my ($filename, $package, $sub);\n" + " eval $eval;\n" + " }\n" + " die $@ if $@;\n" + "\n" + " eval {$package->handler;};\n" + " die $@ if $@;\n" + "}"; + + first_signals = g_hash_table_new((GHashFunc) g_direct_hash, + (GCompareFunc) g_direct_equal); + last_signals = g_hash_table_new((GHashFunc) g_direct_hash, + (GCompareFunc) g_direct_equal); + perl_timeouts = NULL; + + irssi_perl_interp = perl_alloc(); + perl_construct(irssi_perl_interp); + + perl_parse(irssi_perl_interp, xs_init, 3, args, NULL); + perl_eval_pv(eval_file_code, TRUE); +} + +static int signal_destroy_hash(void *key, GSList **list, const char *package) +{ + GSList *tmp, *next; + int len; + + len = package == NULL ? 0 : strlen(package); + for (tmp = *list; tmp != NULL; tmp = next) { + PERL_SIGNAL_REC *rec = tmp->data; + + next = tmp->next; + if (package != NULL && strncmp(rec->func, package, len) != 0) + continue; + + if (strncmp(rec->signal, "command ", 8) == 0) + command_unbind(rec->signal+8, NULL); + + *list = g_slist_remove(*list, rec); + + g_free(rec->signal); + g_free(rec->func); + g_free(rec); + } + + if (*list != NULL) + return FALSE; + + g_free(list); + return TRUE; +} + +static int perl_script_destroy(const char *name) +{ + GSList *tmp, *next; + char *package; + int package_len; + + if (gslist_find_string(perl_scripts, name) == NULL) + return FALSE; + + package = g_strdup_printf("Irssi::Script::%s::", name); + package_len = strlen(package); + + g_hash_table_foreach_remove(first_signals, + (GHRFunc) signal_destroy_hash, package); + g_hash_table_foreach_remove(last_signals, + (GHRFunc) signal_destroy_hash, package); + + for (tmp = perl_timeouts; tmp != NULL; tmp = next) { + PERL_TIMEOUT_REC *rec = tmp->data; + + next = tmp->next; + if (strncmp(rec->func, package, package_len) == 0) + perl_timeout_destroy(rec); + } + + g_free(package); + return TRUE; +} + +static void irssi_perl_stop(void) +{ + g_hash_table_foreach(first_signals, + (GHFunc) signal_destroy_hash, NULL); + g_hash_table_destroy(first_signals); + g_hash_table_foreach(last_signals, + (GHFunc) signal_destroy_hash, NULL); + g_hash_table_destroy(last_signals); + first_signals = last_signals = NULL; + + if (signal_grabbed) { + signal_grabbed = FALSE; + signal_remove("signal", (SIGNAL_FUNC) sig_signal); + } + + if (siglast_grabbed) { + siglast_grabbed = FALSE; + signal_remove("last signal", (SIGNAL_FUNC) sig_lastsignal); + } + + while (perl_timeouts != NULL) + perl_timeout_destroy(perl_timeouts->data); + + g_slist_foreach(perl_scripts, (GFunc) g_free, NULL); + g_slist_free(perl_scripts); + perl_scripts = NULL; + + perl_destruct(irssi_perl_interp); + perl_free(irssi_perl_interp); + irssi_perl_interp = NULL; +} + +static void script_fix_name(char *name) +{ + while (*name != '\0') { + if (*name != '_' && !isalnum(*name)) + *name = '_'; + name++; + } +} + +static void cmd_run(const char *data) +{ + dSP; + struct stat statbuf; + char *fname, *name, *p; + int retcount; + + if (g_path_is_absolute(data)) { + /* whole path specified */ + fname = g_strdup(data); + } else { + /* add .pl suffix if it's missing */ + name = (strlen(data) <= 3 || strcmp(data+strlen(data)-3, ".pl") == 0) ? + g_strdup(data) : g_strdup_printf("%s.pl", data); + + /* check from ~/.irssi/scripts/ */ + fname = g_strdup_printf("%s/.irssi/scripts/%s", g_get_home_dir(), name); + if (stat(fname, &statbuf) != 0) { + /* check from SCRIPTDIR */ + g_free(fname), + fname = g_strdup_printf(SCRIPTDIR"/%s", name); + } + g_free(name); + } + + /* get script name */ + name = g_strdup(g_basename(fname)); + p = strrchr(name, '.'); + if (p != NULL) *p = '\0'; + + script_fix_name(name); + perl_script_destroy(name); + perl_scripts = g_slist_append(perl_scripts, g_strdup(name)); + + ENTER; + SAVETMPS; + + PUSHMARK(SP); + XPUSHs(sv_2mortal(newSVpv(fname, strlen(fname)))); g_free(fname); + XPUSHs(sv_2mortal(newSVpv(name, strlen(name)))); g_free(name); + PUTBACK; + + retcount = perl_call_pv("Irssi::Load::eval_file", + G_EVAL|G_SCALAR); + SPAGAIN; + + if (SvTRUE(ERRSV)) { + STRLEN n_a; + + signal_emit("gui dialog", 2, "error", SvPV(ERRSV, n_a)); + (void) POPs; + } + else if (retcount > 0) { + char *str = POPp; + + if (str != NULL && *str != '\0') + signal_emit("gui dialog", 2, "error", str); + } + + PUTBACK; + FREETMPS; + LEAVE; +} + +static void cmd_unload(const char *data) +{ + char *name; + + name = g_strdup(data); + script_fix_name(name); + if (perl_script_destroy(name)) + signal_stop(); + g_free(name); +} + +static void cmd_perlflush(const char *data) +{ + irssi_perl_stop(); + irssi_perl_start(); +} + +/* returns the package who called us */ +static char *perl_get_package(void) +{ + STRLEN n_a; + + perl_eval_pv("($package) = caller;", TRUE); + return SvPV(perl_get_sv("package", FALSE), n_a); +} + +static void perl_signal_to(const char *signal, const char *func, int last) +{ + PERL_SIGNAL_REC *rec; + GHashTable *table; + GSList **siglist; + void *signal_idp; + + rec = g_new(PERL_SIGNAL_REC, 1); + rec->signal_id = signal_get_uniq_id(signal); + rec->signal = g_strdup(signal); + rec->func = g_strdup_printf("%s::%s", perl_get_package(), func); + rec->last = last; + + table = last ? last_signals : first_signals; + signal_idp = GINT_TO_POINTER(rec->signal_id); + + siglist = g_hash_table_lookup(table, signal_idp); + if (siglist == NULL) { + siglist = g_new0(GSList *, 1); + g_hash_table_insert(table, signal_idp, siglist); + } + + *siglist = g_slist_append(*siglist, rec); + + if (!last && !signal_grabbed) { + signal_grabbed = TRUE; + signal_add("signal", (SIGNAL_FUNC) sig_signal); + } else if (last && !siglast_grabbed) { + siglast_grabbed = TRUE; + signal_add("last signal", (SIGNAL_FUNC) sig_lastsignal); + } +} + +void perl_signal_add(const char *signal, const char *func) +{ + perl_signal_to(signal, func, FALSE); +} + +void perl_signal_add_last(const char *signal, const char *func) +{ + perl_signal_to(signal, func, TRUE); +} + +static void perl_signal_remove_list(GSList **list, const char *func) +{ + GSList *tmp; + + g_return_if_fail(list != NULL); + + for (tmp = *list; tmp != NULL; tmp = tmp->next) { + PERL_SIGNAL_REC *rec = tmp->data; + + if (strcmp(func, rec->func) == 0) { + perl_signal_destroy(rec); + break; + } + } +} + +void perl_signal_remove(const char *signal, const char *func) +{ + GSList **list; + char *fullfunc; + int signal_id; + + signal_id = signal_get_uniq_id(signal); + + fullfunc = g_strdup_printf("%s::%s", perl_get_package(), func); + list = g_hash_table_lookup(first_signals, GINT_TO_POINTER(signal_id)); + if (list != NULL) + perl_signal_remove_list(list, func); + else { + list = g_hash_table_lookup(last_signals, GINT_TO_POINTER(signal_id)); + if (list != NULL) perl_signal_remove_list(list, func); + } + g_free(fullfunc); +} + +static int perl_timeout(PERL_TIMEOUT_REC *rec) +{ + dSP; + int retcount; + + ENTER; + SAVETMPS; + + PUSHMARK(SP); + XPUSHs(sv_2mortal(newSVpv(rec->data, strlen(rec->data)))); + PUTBACK; + + retcount = perl_call_pv(rec->func, G_EVAL|G_SCALAR); + SPAGAIN; + + if (SvTRUE(ERRSV)) { + STRLEN n_a; + + signal_emit("perl error", 1, SvPV(ERRSV, n_a)); + (void) POPs; + } + else while (retcount--) (void) POPi; + + PUTBACK; + FREETMPS; + LEAVE; + + return 1; +} + +int perl_timeout_add(int msecs, const char *func, const char *data) +{ + PERL_TIMEOUT_REC *rec; + + rec = g_new(PERL_TIMEOUT_REC, 1); + rec->func = g_strdup_printf("%s::%s", perl_get_package(), func); + rec->data = g_strdup(data); + rec->tag = g_timeout_add(msecs, (GSourceFunc) perl_timeout, rec); + + perl_timeouts = g_slist_append(perl_timeouts, rec); + return rec->tag; +} + +void perl_timeout_remove(int tag) +{ + GSList *tmp; + + for (tmp = perl_timeouts; tmp != NULL; tmp = tmp->next) { + PERL_TIMEOUT_REC *rec = tmp->data; + + if (rec->tag == tag) { + perl_timeout_destroy(rec); + break; + } + } +} + +static int call_perl(const char *func, int signal, va_list va) +{ + dSP; + PERL_SIGNAL_ARGS_REC *rec; + int retcount, n, ret; + void *arg; + HV *stash; + + /* first check if we find exact match */ + rec = NULL; + for (n = 0; perl_signal_args[n].signal != NULL; n++) + { + if (signal == perl_signal_args[n].signal_id) + { + rec = &perl_signal_args[n]; + break; + } + } + + if (rec == NULL) + { + /* try to find by name */ + const char *signame; + + signame = module_find_id_str("signals", signal); + for (n = 0; perl_signal_args[n].signal != NULL; n++) + { + if (strncmp(signame, perl_signal_args[n].signal, + strlen(perl_signal_args[n].signal)) == 0) + { + rec = &perl_signal_args[n]; + break; + } + } + } + + ENTER; + SAVETMPS; + + PUSHMARK(sp); + + if (rec != NULL) + { + /* put the arguments to perl stack */ + for (n = 0; n < 7; n++) + { + arg = va_arg(va, gpointer); + + if (rec->args[n] == NULL) + break; + + if (strcmp(rec->args[n], "string") == 0) + XPUSHs(sv_2mortal(newSVpv(arg == NULL ? "" : arg, arg == NULL ? 0 : strlen(arg)))); + else if (strcmp(rec->args[n], "int") == 0) + XPUSHs(sv_2mortal(newSViv(GPOINTER_TO_INT(arg)))); + else if (strcmp(rec->args[n], "ulongptr") == 0) + XPUSHs(sv_2mortal(newSViv(*(gulong *) arg))); + else if (strncmp(rec->args[n], "gslist_", 7) == 0) + { + GSList *tmp; + + stash = gv_stashpv(rec->args[n]+7, 0); + for (tmp = arg; tmp != NULL; tmp = tmp->next) + XPUSHs(sv_2mortal(sv_bless(newRV_noinc(newSViv(GPOINTER_TO_INT(tmp->data))), stash))); + } + else + { + if (arg == NULL) + XPUSHs(sv_2mortal(newSViv(0))); + else { + stash = gv_stashpv(rec->args[n], 0); + XPUSHs(sv_2mortal(sv_bless(newRV_noinc(newSViv(GPOINTER_TO_INT(arg))), stash))); + } + } + } + } + + PUTBACK; + retcount = perl_call_pv((char *) func, G_EVAL|G_SCALAR); + SPAGAIN; + + ret = 0; + if (SvTRUE(ERRSV)) + { + STRLEN n_a; + + signal_emit("gui dialog", 2, "error", SvPV(ERRSV, n_a)); + (void)POPs; + } + else + { + SV *sv; + + if (retcount > 0) + { + sv = POPs; + if (SvIOK(sv) && SvIV(sv) == 1) ret = 1; + } + for (n = 2; n <= retcount; n++) + (void)POPi; + } + + PUTBACK; + FREETMPS; + LEAVE; + + return ret; +} + +static void sig_signal(void *signal, ...) +{ + GSList **list, *tmp; + va_list va; + + va_start(va, signal); + + list = g_hash_table_lookup(first_signals, signal); + for (tmp = list == NULL ? NULL : *list; tmp != NULL; tmp = tmp->next) { + PERL_SIGNAL_REC *rec = tmp->data; + + if (call_perl(rec->func, GPOINTER_TO_INT(signal), va)) { + signal_stop(); + break; + } + } + + va_end(va); +} + +static void sig_lastsignal(void *signal, ...) +{ + GSList **list, *tmp; + va_list va; + + va_start(va, signal); + + list = g_hash_table_lookup(last_signals, signal); + for (tmp = list == NULL ? NULL : *list; tmp != NULL; tmp = tmp->next) { + PERL_SIGNAL_REC *rec = tmp->data; + + if (call_perl(rec->func, GPOINTER_TO_INT(signal), va)) { + signal_stop(); + break; + } + } + + va_end(va); +} + +static void irssi_perl_autorun(void) +{ + DIR *dirp; + struct dirent *dp; + struct stat statbuf; + char *path, *fname; + + path = g_strdup_printf("%s/.irssi/scripts/autorun", g_get_home_dir()); + dirp = opendir(path); + if (dirp == NULL) { + g_free(path); + return; + } + + while ((dp = readdir(dirp)) != NULL) { + fname = g_strdup_printf("%s/%s", path, dp->d_name); + if (stat(fname, &statbuf) == 0 && !S_ISDIR(statbuf.st_mode)) + cmd_run(fname); + g_free(fname); + } + closedir(dirp); + g_free(path); +} + +void perl_init(void) +{ + perl_common_init(); + + perl_scripts = NULL; + command_bind("run", NULL, (SIGNAL_FUNC) cmd_run); + command_bind_first("unload", NULL, (SIGNAL_FUNC) cmd_unload); + command_bind("perlflush", NULL, (SIGNAL_FUNC) cmd_perlflush); + signal_grabbed = siglast_grabbed = FALSE; + + PL_perl_destruct_level = 1; + irssi_perl_start(); + irssi_perl_autorun(); +} + +void perl_deinit(void) +{ + irssi_perl_stop(); + perl_common_deinit(); + + if (signal_grabbed) signal_remove("signal", (SIGNAL_FUNC) sig_signal); + if (siglast_grabbed) signal_remove("last signal", (SIGNAL_FUNC) sig_lastsignal); + command_unbind("run", (SIGNAL_FUNC) cmd_run); + command_unbind("unload", (SIGNAL_FUNC) cmd_unload); + command_unbind("perlflush", (SIGNAL_FUNC) cmd_perlflush); +} -- cgit v1.2.3