summaryrefslogtreecommitdiff
path: root/src/plugins/scripts/perl/weechat-perl.c
diff options
context:
space:
mode:
Diffstat (limited to 'src/plugins/scripts/perl/weechat-perl.c')
-rw-r--r--src/plugins/scripts/perl/weechat-perl.c739
1 files changed, 739 insertions, 0 deletions
diff --git a/src/plugins/scripts/perl/weechat-perl.c b/src/plugins/scripts/perl/weechat-perl.c
new file mode 100644
index 000000000..504a0a596
--- /dev/null
+++ b/src/plugins/scripts/perl/weechat-perl.c
@@ -0,0 +1,739 @@
+/*
+ * Copyright (c) 2003-2005 by FlashCode <flashcode@flashtux.org>
+ * See README for License detail, AUTHORS for developers list.
+ *
+ * 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
+ */
+
+/* weechat-perl.c: Perl plugin support for WeeChat */
+
+
+#include <stdlib.h>
+#include <EXTERN.h>
+#include <perl.h>
+#include <XSUB.h>
+#undef _
+#include "../../weechat-plugin.h"
+#include "../weechat-script.h"
+
+
+char plugin_name[] = "Perl";
+char plugin_version[] = "0.1";
+char plugin_description[] = "Perl scripts support";
+
+t_weechat_plugin *perl_plugin;
+
+t_plugin_script *perl_scripts = NULL;
+t_plugin_script *current_perl_script = NULL;
+
+static PerlInterpreter *my_perl = NULL;
+
+extern void boot_DynaLoader (pTHX_ CV* cv);
+
+
+/*
+ * weechat_perl_exec: execute a Perl script
+ */
+
+int
+weechat_perl_exec (t_weechat_plugin *plugin,
+ t_plugin_script *script,
+ char *function, char *server, char *arguments)
+{
+ char empty_server[1] = { '\0' };
+ char *argv[3];
+ unsigned int count;
+ int return_code;
+ SV *sv;
+
+ /* make gcc happy */
+ (void) script;
+
+ dSP;
+ ENTER;
+ SAVETMPS;
+ PUSHMARK(sp);
+ if (!server)
+ argv[0] = empty_server;
+ else
+ argv[0] = server;
+ argv[1] = arguments;
+ argv[2] = NULL;
+ count = perl_call_argv (function, G_EVAL | G_SCALAR, argv);
+ SPAGAIN;
+
+ sv = GvSV (gv_fetchpv ("@", TRUE, SVt_PV));
+ return_code = 1;
+ if (SvTRUE (sv))
+ {
+ plugin->printf_server (plugin, "Perl error: %s", SvPV (sv, count));
+ POPs;
+ }
+ else
+ {
+ if (count != 1)
+ {
+ plugin->printf_server (plugin,
+ "Perl error: too much values from \"%s\" (%d). Expected: 1.",
+ function, count);
+ }
+ else
+ return_code = POPi;
+ }
+
+ PUTBACK;
+ FREETMPS;
+ LEAVE;
+
+ return return_code;
+}
+
+/*
+ * weechat_perl_handler: general message and command handler for Perl
+ */
+
+int
+weechat_perl_handler (t_weechat_plugin *plugin,
+ char *server, char *command, char *arguments,
+ char *handler_args, void *handler_pointer)
+{
+ /* make gcc happy */
+ (void) command;
+
+ weechat_perl_exec (plugin, (t_plugin_script *)handler_pointer,
+ handler_args, server, arguments);
+ return 1;
+}
+
+/*
+ * weechat::register: startup function for all WeeChat Perl scripts
+ */
+
+static XS (XS_weechat_register)
+{
+ char *name, *version, *shutdown_func, *description;
+ unsigned int integer;
+ dXSARGS;
+
+ /* make gcc happy */
+ (void) items;
+ (void) cv;
+
+ if (items != 4)
+ {
+ perl_plugin->printf_server (perl_plugin,
+ "Perl error: wrong parameters for "
+ "\"register\" function");
+ XSRETURN (0);
+ return;
+ }
+
+ name = SvPV (ST (0), integer);
+ version = SvPV (ST (1), integer);
+ shutdown_func = SvPV (ST (2), integer);
+ description = SvPV (ST (3), integer);
+
+ if (weechat_script_search (perl_plugin, &perl_scripts, name))
+ {
+ /* error: another script already exists with this name! */
+ perl_plugin->printf_server (perl_plugin,
+ "Perl error: unable to register "
+ "\"%s\" script (another script "
+ "already exists with this name)",
+ name);
+ XSRETURN (0);
+ return;
+ }
+
+ /* register script */
+ current_perl_script = weechat_script_add (perl_plugin,
+ &perl_scripts,
+ "",
+ name, version, shutdown_func,
+ description);
+ if (current_perl_script)
+ {
+ perl_plugin->printf_server (perl_plugin,
+ "Perl: registered script \"%s\", "
+ "version %s (%s)",
+ name, version, description);
+ }
+ else
+ {
+ perl_plugin->printf_server (perl_plugin,
+ "Perl error: unable to load script "
+ "\"%s\" (not enough memory)",
+ name);
+ XSRETURN (0);
+ return;
+ }
+ XSRETURN (1);
+}
+
+/*
+ * weechat::print: print message into a buffer (current or specified one)
+ */
+
+static XS (XS_weechat_print)
+{
+ unsigned int integer;
+ char *message, *channel_name, *server_name;
+ dXSARGS;
+
+ /* make gcc happy */
+ (void) cv;
+
+ if ((items < 1) || (items > 3))
+ {
+ perl_plugin->printf_server (perl_plugin,
+ "Perl error: wrong parameters for "
+ "\"print\" function");
+ XSRETURN_NO;
+ return;
+ }
+
+ channel_name = NULL;
+ server_name = NULL;
+
+ if (items > 1)
+ {
+ channel_name = SvPV (ST (1), integer);
+ if (items > 2)
+ server_name = SvPV (ST (2), integer);
+ }
+
+ message = SvPV (ST (0), integer);
+ perl_plugin->printf (perl_plugin,
+ server_name, channel_name,
+ "%s", message);
+ XSRETURN_YES;
+}
+
+/*
+ * weechat::print_infobar: print message to infobar
+ */
+
+static XS (XS_weechat_print_infobar)
+{
+ unsigned int integer;
+ dXSARGS;
+
+ /* make gcc happy */
+ (void) cv;
+
+ if (items != 2)
+ {
+ perl_plugin->printf_server (perl_plugin,
+ "Perl error: wrong parameters for "
+ "\"print_infobar\" function");
+ XSRETURN_NO;
+ }
+
+ perl_plugin->infobar_printf (perl_plugin,
+ SvIV (ST (0)),
+ SvPV (ST (1), integer));
+ XSRETURN_YES;
+}
+
+/*
+ * weechat::command: send command to server
+ */
+
+static XS (XS_weechat_command)
+{
+ unsigned int integer;
+ char *channel_name, *server_name;
+ dXSARGS;
+
+ /* make gcc happy */
+ (void) cv;
+
+ if ((items < 1) || (items > 3))
+ {
+ perl_plugin->printf_server (perl_plugin,
+ "Perl error: wrong parameters for "
+ "\"command\" function");
+ XSRETURN_NO;
+ return;
+ }
+
+ channel_name = NULL;
+ server_name = NULL;
+
+ if (items > 1)
+ {
+ channel_name = SvPV (ST (1), integer);
+ if (items > 2)
+ server_name = SvPV (ST (2), integer);
+ }
+
+ perl_plugin->exec_command (perl_plugin,
+ server_name, channel_name,
+ SvPV (ST (0), integer));
+ XSRETURN_YES;
+}
+
+/*
+ * weechat::add_message_handler: add handler for messages (privmsg, ...)
+ */
+
+static XS (XS_weechat_add_message_handler)
+{
+ char *name, *function;
+ unsigned int integer;
+ dXSARGS;
+
+ /* make gcc happy */
+ (void) cv;
+
+ if (items != 2)
+ {
+ perl_plugin->printf_server (perl_plugin,
+ "Perl error: wrong parameters for "
+ "\"add_message_handler\" function");
+ XSRETURN_NO;
+ }
+
+ name = SvPV (ST (0), integer);
+ function = SvPV (ST (1), integer);
+ perl_plugin->msg_handler_add (perl_plugin, name,
+ weechat_perl_handler, function,
+ (void *)current_perl_script);
+ XSRETURN_YES;
+}
+
+/*
+ * weechat::add_command_handler: add command handler (define/redefine commands)
+ */
+
+static XS (XS_weechat_add_command_handler)
+{
+ char *command, *function, *description, *arguments, *arguments_description;
+ unsigned int integer;
+ dXSARGS;
+
+ /* make gcc happy */
+ (void) cv;
+
+ if (items < 2)
+ {
+ perl_plugin->printf_server (perl_plugin,
+ "Perl error: wrong parameters for "
+ "\"add_command_handler\" function");
+ XSRETURN_NO;
+ }
+
+ command = SvPV (ST (0), integer);
+ function = SvPV (ST (1), integer);
+ description = (items >= 3) ? SvPV (ST (2), integer) : NULL;
+ arguments = (items >= 4) ? SvPV (ST (3), integer) : NULL;
+ arguments_description = (items >= 5) ? SvPV (ST (4), integer) : NULL;
+
+ perl_plugin->cmd_handler_add (perl_plugin,
+ command,
+ description,
+ arguments,
+ arguments_description,
+ weechat_perl_handler,
+ function,
+ (void *)current_perl_script);
+ XSRETURN_YES;
+}
+
+/*
+ * weechat::get_info: get various infos
+ */
+
+static XS (XS_weechat_get_info)
+{
+ char *arg, *info, *server_name, *channel_name;
+ unsigned int integer;
+ dXSARGS;
+
+ /* make gcc happy */
+ (void) cv;
+
+ if ((items < 1) || (items > 3))
+ {
+ perl_plugin->printf_server (perl_plugin,
+ "Perl error: wrong parameters for "
+ "\"get_info\" function");
+ XSRETURN_NO;
+ }
+
+ server_name = NULL;
+ channel_name = NULL;
+
+ if (items >= 2)
+ server_name = SvPV (ST (1), integer);
+ if (items == 3)
+ channel_name = SvPV (ST (2), integer);
+
+ arg = SvPV (ST (0), integer);
+ if (arg)
+ {
+ info = perl_plugin->get_info (perl_plugin, arg, server_name, channel_name);
+
+ if (info)
+ {
+ XST_mPV (0, info);
+ free (info);
+ }
+ else
+ XST_mPV (0, "");
+ }
+
+ XSRETURN (1);
+}
+
+/*
+ * weechat::get_dcc_info: get infos about DCC
+ */
+
+static XS (XS_weechat_get_dcc_info)
+{
+ t_plugin_dcc_info *dcc_info, *ptr_dcc;
+ int dcc_count;
+ dXSARGS;
+
+ /* make gcc happy */
+ (void) cv;
+ (void) items;
+
+ dcc_info = perl_plugin->get_dcc_info (perl_plugin);
+ dcc_count = 0;
+
+ if (!dcc_info)
+ {
+ XSRETURN (0);
+ return;
+ }
+
+ for (ptr_dcc = dcc_info; ptr_dcc; ptr_dcc = ptr_dcc->next_dcc)
+ {
+ HV *infohash = (HV *) sv_2mortal((SV *) newHV());
+
+ hv_store (infohash, "server", 6, newSVpv (ptr_dcc->server, 0), 0);
+ hv_store (infohash, "channel", 7, newSVpv (ptr_dcc->channel, 0), 0);
+ hv_store (infohash, "type", 4, newSViv (ptr_dcc->type), 0);
+ hv_store (infohash, "status", 6, newSViv (ptr_dcc->status), 0);
+ hv_store (infohash, "start_time", 10, newSViv (ptr_dcc->start_time), 0);
+ hv_store (infohash, "start_transfer", 14, newSViv (ptr_dcc->start_transfer), 0);
+ hv_store (infohash, "address", 7, newSViv (ptr_dcc->addr), 0);
+ hv_store (infohash, "port", 4, newSViv (ptr_dcc->port), 0);
+ hv_store (infohash, "nick", 4, newSVpv (ptr_dcc->nick, 0), 0);
+ hv_store (infohash, "remote_file", 11, newSVpv (ptr_dcc->filename, 0), 0);
+ hv_store (infohash, "local_file", 10, newSVpv (ptr_dcc->local_filename, 0), 0);
+ hv_store (infohash, "filename_suffix", 15, newSViv (ptr_dcc->filename_suffix), 0);
+ hv_store (infohash, "size", 4, newSVnv (ptr_dcc->size), 0);
+ hv_store (infohash, "pos", 3, newSVnv (ptr_dcc->pos), 0);
+ hv_store (infohash, "start_resume", 12, newSVnv (ptr_dcc->start_resume), 0);
+ hv_store (infohash, "cps", 3, newSViv (ptr_dcc->bytes_per_sec), 0);
+
+ XPUSHs(newRV((SV *) infohash));
+ dcc_count++;
+ }
+
+ perl_plugin->free_dcc_info (perl_plugin, dcc_info);
+
+ XSRETURN (dcc_count);
+}
+
+/*
+ * weechat_perl_xs_init: initialize subroutines
+ */
+
+void
+weechat_perl_xs_init (pTHX)
+{
+ newXS ("DynaLoader::boot_DynaLoader", boot_DynaLoader, __FILE__);
+
+ newXS ("weechat::register", XS_weechat_register, "weechat");
+ newXS ("weechat::print", XS_weechat_print, "weechat");
+ newXS ("weechat::print_infobar", XS_weechat_print_infobar, "weechat");
+ newXS ("weechat::command", XS_weechat_command, "weechat");
+ newXS ("weechat::add_message_handler", XS_weechat_add_message_handler, "weechat");
+ newXS ("weechat::add_command_handler", XS_weechat_add_command_handler, "weechat");
+ newXS ("weechat::get_info", XS_weechat_get_info, "weechat");
+ newXS ("weechat::get_dcc_info", XS_weechat_get_dcc_info, "weechat");
+}
+
+/*
+ * wee_perl_load: load a Perl script
+ */
+
+int
+weechat_perl_load (t_weechat_plugin *plugin, char *filename)
+{
+ plugin->printf_server (plugin, "Loading Perl script \"%s\"", filename);
+ return weechat_perl_exec (plugin, NULL, "wee_perl_load_eval_file", filename, "");
+}
+
+/*
+ * weechat_perl_unload: unload a Perl script
+ */
+
+void
+weechat_perl_unload (t_weechat_plugin *plugin, t_plugin_script *script)
+{
+ if (script->shutdown_func && script->shutdown_func[0])
+ weechat_perl_exec (plugin, script, script->shutdown_func, "", "");
+
+ weechat_script_remove (plugin, &perl_scripts, script);
+}
+
+/*
+ * weechat_perl_unload_all: unload all Perl scripts
+ */
+
+void
+weechat_perl_unload_all (t_weechat_plugin *plugin)
+{
+ plugin->printf_server (plugin,
+ "Unloading all Perl scripts");
+ while (perl_scripts)
+ weechat_perl_unload (plugin, perl_scripts);
+
+ plugin->printf_server (plugin,
+ "Perl scripts unloaded");
+}
+
+/*
+ * weechat_perl_cmd: /perl command handler
+ */
+
+int
+weechat_perl_cmd (t_weechat_plugin *plugin,
+ char *server, char *command, char *arguments,
+ char *handler_args, void *handler_pointer)
+{
+ int argc, path_length, handler_found;
+ char **argv, *path_script, *dir_home;
+ t_plugin_script *ptr_plugin_script;
+ t_plugin_msg_handler *ptr_msg_handler;
+ t_plugin_cmd_handler *ptr_cmd_handler;
+
+ /* make gcc happy */
+ (void) server;
+ (void) command;
+ (void) handler_args;
+ (void) handler_pointer;
+
+ argv = plugin->explode_string (plugin, arguments, " ", 0, &argc);
+
+ switch (argc)
+ {
+ case 0:
+ /* list registered Perl scripts */
+ plugin->printf_server (plugin, "");
+ plugin->printf_server (plugin, "Registered Perl scripts:");
+ if (perl_scripts)
+ {
+ for (ptr_plugin_script = perl_scripts; ptr_plugin_script;
+ ptr_plugin_script = ptr_plugin_script->next_script)
+ {
+ plugin->printf_server (plugin, " %s v%s%s%s",
+ ptr_plugin_script->name,
+ ptr_plugin_script->version,
+ (ptr_plugin_script->description[0]) ? " - " : "",
+ ptr_plugin_script->description);
+ }
+ }
+ else
+ plugin->printf_server (plugin, " (none)");
+
+ /* list Perl message handlers */
+ plugin->printf_server (plugin, "");
+ plugin->printf_server (plugin, "Perl message handlers:");
+ handler_found = 0;
+ for (ptr_msg_handler = plugin->msg_handlers; ptr_msg_handler;
+ ptr_msg_handler = ptr_msg_handler->next_handler)
+ {
+ if (ptr_msg_handler->msg_handler_args)
+ {
+ handler_found = 1;
+ plugin->printf_server (plugin, " IRC(%s) => Perl(%s)",
+ ptr_msg_handler->irc_command,
+ ptr_msg_handler->msg_handler_args);
+ }
+ }
+ if (!handler_found)
+ plugin->printf_server (plugin, " (none)");
+
+ /* list Perl command handlers */
+ plugin->printf_server (plugin, "");
+ plugin->printf_server (plugin, "Perl command handlers:");
+ handler_found = 0;
+ for (ptr_cmd_handler = plugin->cmd_handlers; ptr_cmd_handler;
+ ptr_cmd_handler = ptr_cmd_handler->next_handler)
+ {
+ if (ptr_cmd_handler->cmd_handler_args)
+ {
+ handler_found = 1;
+ plugin->printf_server (plugin, " /%s => Perl(%s)",
+ ptr_cmd_handler->command,
+ ptr_cmd_handler->cmd_handler_args);
+ }
+ }
+ if (!handler_found)
+ plugin->printf_server (plugin, " (none)");
+ break;
+ case 1:
+ if (plugin->ascii_strcasecmp (plugin, argv[0], "autoload") == 0)
+ weechat_script_auto_load (plugin, "perl", weechat_perl_load);
+ else if (plugin->ascii_strcasecmp (plugin, argv[0], "reload") == 0)
+ {
+ weechat_perl_unload_all (plugin);
+ weechat_script_auto_load (plugin, "perl", weechat_perl_load);
+ }
+ else if (plugin->ascii_strcasecmp (plugin, argv[0], "unload") == 0)
+ weechat_perl_unload_all (plugin);
+ break;
+ case 2:
+ if (plugin->ascii_strcasecmp (plugin, argv[0], "load") == 0)
+ {
+ /* load Perl script */
+ if ((strstr (argv[1], "/")) || (strstr (argv[1], "\\")))
+ path_script = NULL;
+ else
+ {
+ dir_home = plugin->get_info (plugin, "weechat_dir", NULL, NULL);
+ if (dir_home)
+ {
+ path_length = strlen (dir_home) + strlen (argv[1]) + 16;
+ path_script = (char *) malloc (path_length * sizeof (char));
+ if (path_script)
+ snprintf (path_script, path_length, "%s/perl/%s",
+ dir_home, argv[1]);
+ else
+ path_script = NULL;
+ free (dir_home);
+ }
+ else
+ path_script = NULL;
+ }
+ weechat_perl_load (plugin, (path_script) ? path_script : argv[1]);
+ if (path_script)
+ free (path_script);
+ }
+ else
+ {
+ plugin->printf_server (plugin,
+ "Perl error: unknown option for "
+ "\"perl\" command");
+ }
+ break;
+ default:
+ plugin->printf_server (plugin,
+ "Perl error: wrong argument count for \"perl\" command");
+ }
+ plugin->free_exploded_string (plugin, argv);
+ return 1;
+}
+
+/*
+ * weechat_plugin_init: initialize Perl plugin
+ */
+
+int
+weechat_plugin_init (t_weechat_plugin *plugin)
+{
+ char *perl_args[] = { "", "-e", "0" };
+ /* Following Perl code is extracted/modified from X-Chat IRC client */
+ /* X-Chat is (c) 1998-2005 Peter Zelezny */
+ char *weechat_perl_func =
+ {
+ "sub wee_perl_load_file"
+ "{"
+ " my $filename = shift;"
+ " local $/ = undef;"
+ " open FILE, $filename or return \"__WEECHAT_ERROR__\";"
+ " $_ = <FILE>;"
+ " close FILE;"
+ " return $_;"
+ "}"
+ "sub wee_perl_load_eval_file"
+ "{"
+ " my $filename = shift;"
+ " my $content = wee_perl_load_file ($filename);"
+ " if ($content eq \"__WEECHAT_ERROR__\")"
+ " {"
+ " weechat::print \"Perl error: script '$filename' not found.\", \"\";"
+ " return 1;"
+ " }"
+ " eval $content;"
+ " if ($@)"
+ " {"
+ " weechat::print \"Perl error: unable to load script '$filename':\", \"\";"
+ " weechat::print \"$@\";"
+ " return 2;"
+ " }"
+ " return 0;"
+ "}"
+ "$SIG{__WARN__} = sub { weechat::print \"$_[0]\", \"\"; };"
+ };
+
+ perl_plugin = plugin;
+
+ plugin->printf_server (plugin, "Loading Perl module \"weechat\"");
+
+ my_perl = perl_alloc ();
+ if (!my_perl)
+ {
+ plugin->printf_server (plugin,
+ "Perl error: unable to initialize Perl");
+ return 0;
+ }
+ perl_construct (my_perl);
+ perl_parse (my_perl, weechat_perl_xs_init, 3, perl_args, NULL);
+ eval_pv (weechat_perl_func, TRUE);
+
+ plugin->cmd_handler_add (plugin, "perl",
+ "list/load/unload Perl scripts",
+ "[load filename] | [autoload] | [reload] | [unload]",
+ "filename: Perl script (file) to load\n\n"
+ "Without argument, /perl command lists all loaded Perl scripts.",
+ weechat_perl_cmd, NULL, NULL);
+
+ plugin->mkdir_home (plugin, "perl");
+ plugin->mkdir_home (plugin, "perl/autoload");
+
+ weechat_script_auto_load (plugin, "perl", weechat_perl_load);
+
+ /* init ok */
+ return 1;
+}
+
+/*
+ * weechat_plugin_end: shutdown Perl interface
+ */
+
+void
+weechat_plugin_end (t_weechat_plugin *plugin)
+{
+ /* unload all scripts */
+ weechat_perl_unload_all (plugin);
+
+ /* free Perl interpreter */
+ if (my_perl)
+ {
+ perl_destruct (my_perl);
+ perl_free (my_perl);
+ my_perl = NULL;
+ }
+
+ perl_plugin->printf_server (perl_plugin,
+ "Perl plugin ended");
+}
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-01 07:24:06 +0000