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 "perl-core.h"
29 #include "perl-common.h"
30 #include "perl-signals.h"
33 PERL_SCRIPT_REC *script;
42 } PERL_SIGNAL_ARGS_REC;
44 #include "perl-signals-list.h"
46 static GHashTable *signals;
47 static GHashTable *perl_signal_args_hash;
48 static GSList *perl_signal_args_partial;
50 static PERL_SIGNAL_ARGS_REC *perl_signal_args_find(int signal_id)
52 PERL_SIGNAL_ARGS_REC *rec;
56 rec = g_hash_table_lookup(perl_signal_args_hash,
57 GINT_TO_POINTER(signal_id));
58 if (rec != NULL) return rec;
60 /* try to find by name */
61 signame = signal_get_id_str(signal_id);
62 for (tmp = perl_signal_args_partial; tmp != NULL; tmp = tmp->next) {
65 if (strncmp(rec->signal, signame, strlen(rec->signal)) == 0)
72 static void perl_call_signal(PERL_SCRIPT_REC *script, SV *func,
73 int signal_id, gconstpointer *args)
77 PERL_SIGNAL_ARGS_REC *rec;
78 SV *sv, *perlarg, *saved_args[SIGNAL_MAX_ARGUMENTS];
89 /* push signal argument to perl stack */
90 rec = perl_signal_args_find(signal_id);
92 memset(saved_args, 0, sizeof(saved_args));
93 for (n = 0; n < SIGNAL_MAX_ARGUMENTS &&
94 rec != NULL && rec->args[n] != NULL; n++) {
95 arg = (void *) args[n];
97 if (strcmp(rec->args[n], "string") == 0)
98 perlarg = new_pv(arg);
99 else if (strcmp(rec->args[n], "int") == 0)
100 perlarg = newSViv((IV)arg);
101 else if (strcmp(rec->args[n], "ulongptr") == 0)
102 perlarg = newSViv(*(unsigned long *) arg);
103 else if (strcmp(rec->args[n], "intptr") == 0)
104 saved_args[n] = perlarg = newRV_noinc(newSViv(*(int *) arg));
105 else if (strncmp(rec->args[n], "glistptr_", 9) == 0) {
106 /* pointer to linked list - push as AV */
108 int is_iobject, is_str;
110 is_iobject = strcmp(rec->args[n]+9, "iobject") == 0;
111 is_str = strcmp(rec->args[n]+9, "char*") == 0;
115 for (tmp = *ptr; tmp != NULL; tmp = tmp->next) {
116 sv = is_iobject ? iobject_bless((SERVER_REC *) tmp->data) :
117 is_str ? new_pv(tmp->data) :
118 irssi_bless_plain(rec->args[n]+9, tmp->data);
122 saved_args[n] = perlarg = newRV_noinc((SV *) av);
123 } else if (strncmp(rec->args[n], "gslist_", 7) == 0) {
124 /* linked list - push as AV */
128 is_iobject = strcmp(rec->args[n]+7, "iobject") == 0;
130 for (tmp = arg; tmp != NULL; tmp = tmp->next) {
131 sv = is_iobject ? iobject_bless((SERVER_REC *) tmp->data) :
132 irssi_bless_plain(rec->args[n]+7, tmp->data);
136 perlarg = newRV_noinc((SV *) av);
137 } else if (arg == NULL) {
138 /* don't bless NULL arguments */
139 perlarg = newSViv(0);
140 } else if (strcmp(rec->args[n], "iobject") == 0) {
141 /* "irssi object" - any struct that has
142 "int type; int chat_type" as it's first
143 variables (server, channel, ..) */
144 perlarg = iobject_bless((SERVER_REC *) arg);
145 } else if (strcmp(rec->args[n], "siobject") == 0) {
146 /* "simple irssi object" - any struct that has
147 int type; as it's first variable (dcc) */
148 perlarg = simple_iobject_bless((SERVER_REC *) arg);
151 perlarg = plain_bless(arg, rec->args[n]);
153 XPUSHs(sv_2mortal(perlarg));
157 perl_call_sv(func, G_EVAL|G_DISCARD);
161 char *error = g_strdup(SvPV(ERRSV, PL_na));
162 signal_emit("script error", 2, script, error);
167 /* restore arguments the perl script modified */
168 for (n = 0; n < SIGNAL_MAX_ARGUMENTS &&
169 rec != NULL && rec->args[n] != NULL; n++) {
170 arg = (void *) args[n];
172 if (saved_args[n] == NULL)
175 if (strcmp(rec->args[n], "intptr") == 0) {
177 *val = SvIV(SvRV(saved_args[n]));
178 } else if (strncmp(rec->args[n], "glistptr_", 9) == 0) {
185 av = (AV *) SvRV(saved_args[n]);
187 while (count-- >= 0) {
190 val = g_strdup(SvPV(sv, len));
192 val = GINT_TO_POINTER(SvIV(sv));
194 out = g_list_append(out, val);
197 if (strcmp(rec->args[n]+9, "char*") == 0)
198 g_list_foreach(*ret, (GFunc) g_free, NULL);
209 static void sig_func(const void *p1, const void *p2,
210 const void *p3, const void *p4,
211 const void *p5, const void *p6)
213 PERL_SIGNAL_REC *rec;
216 args[0] = p1; args[1] = p2; args[2] = p3;
217 args[3] = p4; args[4] = p5; args[5] = p6;
219 rec = signal_get_user_data();
220 perl_call_signal(rec->script, rec->func, signal_get_emitted_id(), args);
223 static void perl_signal_add_full_int(const char *signal, SV *func,
224 int priority, int command,
225 const char *category)
227 PERL_SCRIPT_REC *script;
228 PERL_SIGNAL_REC *rec;
232 g_return_if_fail(signal != NULL);
233 g_return_if_fail(func != NULL);
235 script = perl_script_find_package(perl_get_package());
236 g_return_if_fail(script != NULL);
238 rec = g_new(PERL_SIGNAL_REC, 1);
239 rec->script = script;
240 rec->signal_id = signal_get_uniq_id(signal);
241 rec->signal = g_strdup(signal);
242 rec->func = perl_func_sv_inc(func, perl_get_package());
244 if (command || strncmp(signal, "command ", 8) == 0) {
245 /* we used Irssi::signal_add() instead of
246 Irssi::command_bind() - oh well, allow this.. */
247 command_bind_full(MODULE_NAME, priority, signal+8, -1,
248 category, sig_func, rec);
250 signal_add_full_id(MODULE_NAME, priority, rec->signal_id,
254 signal_idp = GINT_TO_POINTER(rec->signal_id);
255 siglist = g_hash_table_lookup(signals, signal_idp);
256 if (siglist == NULL) {
257 siglist = g_new0(GSList *, 1);
258 g_hash_table_insert(signals, signal_idp, siglist);
261 *siglist = g_slist_append(*siglist, rec);
264 void perl_signal_add_full(const char *signal, SV *func, int priority)
266 perl_signal_add_full_int(signal, func, priority, FALSE, NULL);
269 static void perl_signal_destroy(PERL_SIGNAL_REC *rec)
271 if (strncmp(rec->signal, "command ", 8) == 0)
272 command_unbind_full(rec->signal+8, sig_func, rec);
274 signal_remove_id(rec->signal_id, sig_func, rec);
276 SvREFCNT_dec(rec->func);
281 static void perl_signal_remove_list_one(GSList **siglist, PERL_SIGNAL_REC *rec)
283 *siglist = g_slist_remove(*siglist, rec);
284 if (*siglist == NULL) {
286 g_hash_table_remove(signals, GINT_TO_POINTER(rec->signal_id));
289 perl_signal_destroy(rec);
292 #define sv_func_cmp(f1, f2, len) \
293 (f1 == f2 || (SvPOK(f1) && SvPOK(f2) && \
294 strcmp((char *) SvPV(f1, len), (char *) SvPV(f2, len)) == 0))
296 static void perl_signal_remove_list(GSList **list, SV *func)
300 for (tmp = *list; tmp != NULL; tmp = tmp->next) {
301 PERL_SIGNAL_REC *rec = tmp->data;
303 if (sv_func_cmp(rec->func, func, PL_na)) {
304 perl_signal_remove_list_one(list, rec);
310 void perl_signal_remove(const char *signal, SV *func)
315 signal_idp = GINT_TO_POINTER(signal_get_uniq_id(signal));
316 list = g_hash_table_lookup(signals, signal_idp);
319 func = perl_func_sv_inc(func, perl_get_package());
320 perl_signal_remove_list(list, func);
325 void perl_command_bind_to(const char *cmd, const char *category,
326 SV *func, int priority)
330 signal = g_strconcat("command ", cmd, NULL);
331 perl_signal_add_full_int(signal, func, priority, TRUE, category);
335 void perl_command_runsub(const char *cmd, const char *data,
336 SERVER_REC *server, WI_ITEM_REC *item)
338 command_runsub(cmd, data, server, item);
341 void perl_command_unbind(const char *cmd, SV *func)
345 /* perl_signal_remove() calls command_unbind() */
346 signal = g_strconcat("command ", cmd, NULL);
347 perl_signal_remove(signal, func);
351 static int signal_destroy_hash(void *key, GSList **list, PERL_SCRIPT_REC *script)
355 for (tmp = *list; tmp != NULL; tmp = next) {
356 PERL_SIGNAL_REC *rec = tmp->data;
359 if (script == NULL || rec->script == script) {
360 *list = g_slist_remove(*list, rec);
361 perl_signal_destroy(rec);
372 /* destroy all signals used by script */
373 void perl_signal_remove_script(PERL_SCRIPT_REC *script)
375 g_hash_table_foreach_remove(signals, (GHRFunc) signal_destroy_hash,
379 void perl_signals_start(void)
381 signals = g_hash_table_new(NULL, NULL);
384 void perl_signals_stop(void)
386 g_hash_table_foreach(signals, (GHFunc) signal_destroy_hash, NULL);
387 g_hash_table_destroy(signals);
391 void perl_signals_init(void)
395 perl_signal_args_hash = g_hash_table_new((GHashFunc) g_direct_hash,
396 (GCompareFunc) g_direct_equal);
397 perl_signal_args_partial = NULL;
399 for (n = 0; perl_signal_args[n].signal != NULL; n++) {
400 PERL_SIGNAL_ARGS_REC *rec = &perl_signal_args[n];
402 if (rec->signal[strlen(rec->signal)-1] == ' ') {
403 perl_signal_args_partial =
404 g_slist_append(perl_signal_args_partial, rec);
406 int signal_id = signal_get_uniq_id(rec->signal);
407 g_hash_table_insert(perl_signal_args_hash,
408 GINT_TO_POINTER(signal_id),
414 void perl_signals_deinit(void)
416 g_slist_free(perl_signal_args_partial);
417 g_hash_table_destroy(perl_signal_args_hash);