static int perl_source_event(PERL_SOURCE_REC *rec)
{
dSP;
int retcount;
ENTER;
SAVETMPS;
PUSHMARK(SP);
XPUSHs(sv_2mortal(new_pv(rec->data)));
PUTBACK;
retcount = perl_call_pv(rec->func, G_EVAL|G_DISCARD);
SPAGAIN;
if (SvTRUE(ERRSV)) {
STRLEN n_a;
signal_emit("perl error", 1, SvPV(ERRSV, n_a));
}
PUTBACK;
FREETMPS;
LEAVE;
return 1;
}
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) {
ret = POPs;
}
PUTBACK;
FREETMPS;
LEAVE;
return error == NULL;
}
static int perl_script_eval(PERL_SCRIPT_REC *script)
{
dSP;
char *error;
ENTER;
SAVETMPS;
PUSHMARK(SP);
XPUSHs(sv_2mortal(new_pv(script->path != NULL ? script->path :
script->data)));
XPUSHs(sv_2mortal(new_pv(script->name)));
PUTBACK;
perl_call_pv(script->path != NULL ?
"Irssi::Core::eval_file" :
"Irssi::Core::eval_data",
G_EVAL|G_DISCARD);
SPAGAIN;
error = NULL;
if (SvTRUE(ERRSV)) {
error = SvPV_nolen(ERRSV);
if (error != NULL) {
error = g_strdup(error);
signal_emit("script error", 2, script, error);
g_free(error);
}
}
FREETMPS;
LEAVE;
return error == NULL;
}
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);
FREETMPS;
LEAVE;
}
void perl_signal_args_to_c(
void (*callback)(void *, void **), void *cb_arg,
int signal_id, SV **args, size_t n_args)
{
union {
int v_int;
unsigned long v_ulong;
GSList *v_gslist;
GList *v_glist;
} saved_args[SIGNAL_MAX_ARGUMENTS];
void *p[SIGNAL_MAX_ARGUMENTS];
PERL_SIGNAL_ARGS_REC *rec;
size_t n;
if (!(rec = perl_signal_args_find(signal_id))) {
const char *name = signal_get_id_str(signal_id);
if (!name) {
croak("%d is not a known signal id", signal_id);
}
croak("\"%s\" is not a registered signal", name);
}
for (n = 0; n < SIGNAL_MAX_ARGUMENTS && n < n_args && rec->args[n] != NULL; ++n) {
void *c_arg;
SV *arg = args[n];
if (!SvOK(arg)) {
c_arg = NULL;
} else if (strcmp(rec->args[n], "string") == 0) {
c_arg = SvPV_nolen(arg);
} else if (strcmp(rec->args[n], "int") == 0) {
c_arg = (void *)SvIV(arg);
} else if (strcmp(rec->args[n], "ulongptr") == 0) {
saved_args[n].v_ulong = SvUV(arg);
c_arg = &saved_args[n].v_ulong;
} else if (strcmp(rec->args[n], "intptr") == 0) {
saved_args[n].v_int = SvIV(SvRV(arg));
c_arg = &saved_args[n].v_int;
} else if (strncmp(rec->args[n], "glistptr_", 9) == 0) {
GList *gl;
int is_str;
AV *av;
SV *t;
int count;
t = SvRV(arg);
if (SvTYPE(t) != SVt_PVAV) {
croak("Not an ARRAY reference");
}
av = (AV *)t;
is_str = strcmp(rec->args[n]+9, "char*") == 0;
gl = NULL;
count = av_len(av) + 1;
while (count-- > 0) {
SV **px = av_fetch(av, count, 0);
SV *x = px ? *px : NULL;
gl = g_list_prepend(
gl,
x == NULL ? NULL :
is_str ? g_strdup(SvPV_nolen(x)) :
irssi_ref_object(x)
);
}
saved_args[n].v_glist = gl;
c_arg = &saved_args[n].v_glist;
} else if (strncmp(rec->args[n], "gslist_", 7) == 0) {
GSList *gsl;
AV *av;
SV *t;
int count;
t = SvRV(arg);
if (SvTYPE(t) != SVt_PVAV) {
croak("Not an ARRAY reference");
}
av = (AV *)t;
gsl = NULL;
count = av_len(av) + 1;
while (count-- > 0) {
SV **x = av_fetch(av, count, 0);
gsl = g_slist_prepend(
gsl,
x == NULL ? NULL :
irssi_ref_object(*x)
);
}
c_arg = saved_args[n].v_gslist = gsl;
} else {
c_arg = irssi_ref_object(arg);
}
p[n] = c_arg;
}
for (; n < SIGNAL_MAX_ARGUMENTS; ++n) {
p[n] = NULL;
}
callback(cb_arg, p);
for (n = 0; n < SIGNAL_MAX_ARGUMENTS && n < n_args && rec->args[n] != NULL; ++n) {
SV *arg = args[n];
if (!SvOK(arg)) {
continue;
}
if (strcmp(rec->args[n], "intptr") == 0) {
SV *t = SvRV(arg);
SvIOK_only(t);
SvIV_set(t, saved_args[n].v_int);
} else if (strncmp(rec->args[n], "gslist_", 7) == 0) {
g_slist_free(saved_args[n].v_gslist);
} else if (strncmp(rec->args[n], "glistptr_", 9) == 0) {
int is_iobject, is_str;
AV *av;
GList *gl, *tmp;
is_iobject = strcmp(rec->args[n]+9, "iobject") == 0;
is_str = strcmp(rec->args[n]+9, "char*") == 0;
av = (AV *)SvRV(arg);
av_clear(av);
gl = saved_args[n].v_glist;
for (tmp = gl; tmp != NULL; tmp = tmp->next) {
av_push(av,
is_iobject ? iobject_bless((SERVER_REC *)tmp->data) :
is_str ? new_pv(tmp->data) :
irssi_bless_plain(rec->args[n]+9, tmp->data)
);
}
if (is_str) {
g_list_foreach(gl, (GFunc)g_free, NULL);
}
g_list_free(gl);
}
}
}
static void perl_call_signal(PERL_SCRIPT_REC *script, SV *func,
int signal_id, gconstpointer *args)
{
dSP;
PERL_SIGNAL_ARGS_REC *rec;
SV *sv, *perlarg, *saved_args[SIGNAL_MAX_ARGUMENTS];
AV *av;
void *arg;
int n;
ENTER;
SAVETMPS;
PUSHMARK(sp);
/* push signal argument to perl stack */
rec = perl_signal_args_find(signal_id);
memset(saved_args, 0, sizeof(saved_args));
for (n = 0; n < SIGNAL_MAX_ARGUMENTS &&
rec != NULL && rec->args[n] != NULL; n++) {
arg = (void *) args[n];
if (strncmp(rec->args[n], "glistptr_", 9) == 0) {
/* pointer to linked list - push as AV */
GList *tmp, **ptr;
int is_iobject, is_str;
is_iobject = strcmp(rec->args[n]+9, "iobject") == 0;
is_str = strcmp(rec->args[n]+9, "char*") == 0;
av = newAV();
ptr = arg;
for (tmp = *ptr; tmp != NULL; tmp = tmp->next) {
sv = is_iobject ? iobject_bless((SERVER_REC *) tmp->data) :
is_str ? new_pv(tmp->data) :
irssi_bless_plain(rec->args[n]+9, tmp->data);
av_push(av, sv);
}
saved_args[n] = perlarg = newRV_noinc((SV *) av);
} else if (strcmp(rec->args[n], "int") == 0)
perlarg = newSViv((IV)arg);
else if (arg == NULL)
perlarg = &PL_sv_undef;
else if (strcmp(rec->args[n], "string") == 0)
perlarg = new_pv(arg);
else if (strcmp(rec->args[n], "ulongptr") == 0)
perlarg = newSViv(*(unsigned long *) arg);
else if (strcmp(rec->args[n], "intptr") == 0)
saved_args[n] = perlarg = newRV_noinc(newSViv(*(int *) arg));
else if (strncmp(rec->args[n], "gslist_", 7) == 0) {
/* linked list - push as AV */
GSList *tmp;
int is_iobject;
is_iobject = strcmp(rec->args[n]+7, "iobject") == 0;
av = newAV();
for (tmp = arg; tmp != NULL; tmp = tmp->next) {
sv = is_iobject ? iobject_bless((SERVER_REC *) tmp->data) :
irssi_bless_plain(rec->args[n]+7, tmp->data);
av_push(av, sv);
}
perlarg = newRV_noinc((SV *) av);
} else if (strcmp(rec->args[n], "iobject") == 0) {
/* "irssi object" - any struct that has
"int type; int chat_type" as it's first
variables (server, channel, ..) */
perlarg = iobject_bless((SERVER_REC *) arg);
} else if (strcmp(rec->args[n], "siobject") == 0) {
/* "simple irssi object" - any struct that has
int type; as it's first variable (dcc) */
perlarg = simple_iobject_bless((SERVER_REC *) arg);
} else {
/* blessed object */
perlarg = plain_bless(arg, rec->args[n]);
}
XPUSHs(sv_2mortal(perlarg));
}
PUTBACK;
perl_call_sv(func, G_EVAL|G_DISCARD);
SPAGAIN;
if (SvTRUE(ERRSV)) {
char *error = g_strdup(SvPV_nolen(ERRSV));
signal_emit("script error", 2, script, error);
g_free(error);
rec = NULL;
}
/* restore arguments the perl script modified */
for (n = 0; n < SIGNAL_MAX_ARGUMENTS &&
rec != NULL && rec->args[n] != NULL; n++) {
arg = (void *) args[n];
if (saved_args[n] == NULL)
continue;
if (strcmp(rec->args[n], "intptr") == 0) {
int *val = arg;
*val = SvIV(SvRV(saved_args[n]));
} else if (strncmp(rec->args[n], "glistptr_", 9) == 0) {
GList **ret = arg;
GList *out = NULL;
void *val;
int count;
av = (AV *) SvRV(saved_args[n]);
count = av_len(av);
while (count-- >= 0) {
sv = av_shift(av);
if (SvPOKp(sv))
val = g_strdup(SvPV_nolen(sv));
else
val = GINT_TO_POINTER(SvIV(sv));
out = g_list_append(out, val);
}
if (strcmp(rec->args[n]+9, "char*") == 0)
g_list_foreach(*ret, (GFunc) g_free, NULL);
g_list_free(*ret);
*ret = out;
}
}
FREETMPS;
LEAVE;
}
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);
ENTER;
SAVETMPS;
PUSHMARK(SP);
XPUSHs(sv_2mortal(new_pv(fname))); g_free(fname);
XPUSHs(sv_2mortal(new_pv(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));
}
else if (retcount > 0) {
char *str = POPp;
if (str != NULL && *str != '\0')
signal_emit("gui dialog", 2, "error", str);
}
PUTBACK;
FREETMPS;
LEAVE;
perl_scripts = g_slist_append(perl_scripts, g_strdup(name));
signal_emit("script new", 2, "PERL", name);
g_free(name);
}
