mirror of
https://github.com/irssi/irssi.git
synced 2024-09-08 04:26:01 -04:00
perl lib dir is set, add 'use lib "/perl/lib/dir"' before each script automatically. git-svn-id: http://svn.irssi.org/repos/irssi/trunk@1287 dbcabf3a-b0e7-0310-adc4-f8d773084564
413 lines
8.6 KiB
C
413 lines
8.6 KiB
C
/*
|
|
perl.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
|
|
*/
|
|
|
|
#include "module.h"
|
|
#include "signals.h"
|
|
#include "commands.h"
|
|
#include "misc.h"
|
|
|
|
#include "perl-common.h"
|
|
#include "perl-signals.h"
|
|
|
|
/* For compatibility with perl 5.004 and older */
|
|
#ifndef HAVE_PL_PERL
|
|
# define PL_perl_destruct_level perl_destruct_level
|
|
#endif
|
|
|
|
extern void xs_init(void);
|
|
|
|
typedef struct {
|
|
int tag;
|
|
char *func;
|
|
char *data;
|
|
} PERL_SOURCE_REC;
|
|
|
|
static GSList *perl_sources;
|
|
GSList *perl_scripts;
|
|
PerlInterpreter *my_perl;
|
|
|
|
static void perl_source_destroy(PERL_SOURCE_REC *rec)
|
|
{
|
|
perl_sources = g_slist_remove(perl_sources, 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 = <FH>;\n"
|
|
" close FH;\n"
|
|
"\n"
|
|
" my $eval = qq{package $package; %s 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"
|
|
"}\n";
|
|
char *code, *use_code;
|
|
|
|
perl_signals_start();
|
|
perl_sources = NULL;
|
|
|
|
my_perl = perl_alloc();
|
|
perl_construct(my_perl);
|
|
|
|
perl_parse(my_perl, xs_init, 3, args, NULL);
|
|
|
|
use_code = *PERL_LIB_DIR == '\0' ? "" :
|
|
"use lib \""PERL_LIB_DIR"\";";
|
|
|
|
code = g_strdup_printf(eval_file_code, use_code);
|
|
perl_eval_pv(code, TRUE);
|
|
g_free(code);
|
|
|
|
perl_common_init();
|
|
}
|
|
|
|
static int perl_script_destroy(const char *name)
|
|
{
|
|
GSList *tmp, *next, *item;
|
|
char *package;
|
|
int package_len;
|
|
|
|
item = gslist_find_string(perl_scripts, name);
|
|
if (item == NULL)
|
|
return FALSE;
|
|
|
|
package = g_strdup_printf("Irssi::Script::%s", name);
|
|
package_len = strlen(package);
|
|
|
|
signal_emit("script destroy", 3, "PERL", name, package);
|
|
|
|
perl_signals_package_destroy(package);
|
|
|
|
/* timeouts and input waits */
|
|
for (tmp = perl_sources; tmp != NULL; tmp = next) {
|
|
PERL_SOURCE_REC *rec = tmp->data;
|
|
|
|
next = tmp->next;
|
|
if (strncmp(rec->func, package, package_len) == 0)
|
|
perl_source_destroy(rec);
|
|
}
|
|
|
|
g_free(package);
|
|
g_free(item->data);
|
|
perl_scripts = g_slist_remove(perl_scripts, item->data);
|
|
return TRUE;
|
|
}
|
|
|
|
static void irssi_perl_stop(void)
|
|
{
|
|
char *package;
|
|
|
|
signal_emit("perl stop", 0);
|
|
perl_signals_stop();
|
|
|
|
/* timeouts and input waits */
|
|
while (perl_sources != NULL)
|
|
perl_source_destroy(perl_sources->data);
|
|
|
|
/* scripts list */
|
|
g_slist_foreach(perl_scripts, (GFunc) g_free, NULL);
|
|
g_slist_free(perl_scripts);
|
|
perl_scripts = NULL;
|
|
|
|
/* perl-common stuff */
|
|
perl_common_deinit();
|
|
|
|
/* perl interpreter */
|
|
perl_destruct(my_perl);
|
|
perl_free(my_perl);
|
|
my_perl = 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);
|
|
|
|
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);
|
|
}
|
|
|
|
static void cmd_perl(const char *data)
|
|
{
|
|
dSP;
|
|
GString *code;
|
|
char *uses;
|
|
SV *sv;
|
|
|
|
ENTER;
|
|
SAVETMPS;
|
|
|
|
PUSHMARK(SP);
|
|
|
|
code = g_string_new(NULL);
|
|
|
|
uses = perl_get_use_list();
|
|
g_string_sprintf(code, "sub { use Irssi;%s\n%s }", uses, data);
|
|
|
|
sv = perl_eval_pv(code->str, TRUE);
|
|
perl_call_sv(sv, G_VOID|G_NOARGS|G_EVAL|G_DISCARD);
|
|
|
|
g_free(uses);
|
|
g_string_free(code, TRUE);
|
|
|
|
SPAGAIN;
|
|
|
|
if (SvTRUE(ERRSV)) {
|
|
STRLEN n_a;
|
|
|
|
signal_emit("gui dialog", 2, "error", SvPV(ERRSV, n_a));
|
|
}
|
|
|
|
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();
|
|
}
|
|
|
|
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;
|
|
}
|
|
|
|
int perl_timeout_add(int msecs, const char *func, const char *data)
|
|
{
|
|
PERL_SOURCE_REC *rec;
|
|
|
|
rec = g_new(PERL_SOURCE_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_source_event, rec);
|
|
|
|
perl_sources = g_slist_append(perl_sources, rec);
|
|
return rec->tag;
|
|
}
|
|
|
|
int perl_input_add(int source, int condition,
|
|
const char *func, const char *data)
|
|
{
|
|
PERL_SOURCE_REC *rec;
|
|
GIOChannel *channel;
|
|
|
|
rec = g_new(PERL_SOURCE_REC, 1);
|
|
rec->func = g_strdup_printf("%s::%s", perl_get_package(), func);
|
|
rec->data = g_strdup(data);
|
|
|
|
channel = g_io_channel_unix_new(source);
|
|
rec->tag = g_input_add(channel, condition,
|
|
(GInputFunction) perl_source_event, rec);
|
|
g_io_channel_unref(channel);
|
|
|
|
perl_sources = g_slist_append(perl_sources, rec);
|
|
return rec->tag;
|
|
}
|
|
|
|
void perl_source_remove(int tag)
|
|
{
|
|
GSList *tmp;
|
|
|
|
for (tmp = perl_sources; tmp != NULL; tmp = tmp->next) {
|
|
PERL_SOURCE_REC *rec = tmp->data;
|
|
|
|
if (rec->tag == tag) {
|
|
perl_source_destroy(rec);
|
|
break;
|
|
}
|
|
}
|
|
}
|
|
|
|
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_core_init(void)
|
|
{
|
|
perl_scripts = NULL;
|
|
command_bind("run", NULL, (SIGNAL_FUNC) cmd_run);
|
|
command_bind_first("unload", NULL, (SIGNAL_FUNC) cmd_unload);
|
|
command_bind("perl", NULL, (SIGNAL_FUNC) cmd_perl);
|
|
command_bind("perlflush", NULL, (SIGNAL_FUNC) cmd_perlflush);
|
|
|
|
PL_perl_destruct_level = 1;
|
|
perl_signals_init();
|
|
irssi_perl_start();
|
|
irssi_perl_autorun();
|
|
}
|
|
|
|
void perl_core_deinit(void)
|
|
{
|
|
perl_signals_deinit();
|
|
irssi_perl_stop();
|
|
|
|
command_unbind("run", (SIGNAL_FUNC) cmd_run);
|
|
command_unbind("unload", (SIGNAL_FUNC) cmd_unload);
|
|
command_unbind("perl", (SIGNAL_FUNC) cmd_perl);
|
|
command_unbind("perlflush", (SIGNAL_FUNC) cmd_perlflush);
|
|
}
|