diff options
Diffstat (limited to 'src/plugins/scripts/perl/perl.c')
| -rw-r--r-- | src/plugins/scripts/perl/perl.c | 2444 |
1 files changed, 0 insertions, 2444 deletions
diff --git a/src/plugins/scripts/perl/perl.c b/src/plugins/scripts/perl/perl.c deleted file mode 100644 index a1eeef6ae..000000000 --- a/src/plugins/scripts/perl/perl.c +++ /dev/null @@ -1,2444 +0,0 @@ -/* - * Copyright (c) 2003-2008 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 3 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, see <http://www.gnu.org/licenses/>. - */ - -/* weechat-perl.c: Perl plugin support for WeeChat */ - -#undef _ - -#include <EXTERN.h> -#include <perl.h> -#include <XSUB.h> - -#include <stdio.h> -#include <stdlib.h> -#include <string.h> -#include <stdarg.h> -#include <time.h> - -#include <sys/socket.h> -#include <netinet/in.h> -#include <arpa/inet.h> -#include <sys/types.h> -#include <sys/stat.h> - -#include "../../weechat-plugin.h" -#include "../weechat-script.h" - -WEECHAT_PLUGIN_NAME("perl"); -WEECHAT_PLUGIN_DESCRIPTION("Perl plugin for WeeChat"); -WEECHAT_PLUGIN_AUTHOR("FlashCode <flashcode@flashtux.org>"); -WEECHAT_PLUGIN_VERSION("0.1"); -WEECHAT_PLUGIN_LICENSE("GPL"); - -t_weechat_plugin *perl_plugin; - -t_plugin_script *perl_scripts = NULL; -t_plugin_script *perl_current_script = NULL; -char *perl_current_script_filename = NULL; - -extern void boot_DynaLoader (pTHX_ CV* cv); - -#ifdef NO_PERL_MULTIPLICITY -#undef MULTIPLICITY -#endif - -#ifndef MULTIPLICITY -#define PKG_NAME_PREFIX "WeechatPerlPackage" -static PerlInterpreter *perl_main = NULL; -int perl_num = 0; -#endif - -char *perl_weechat_code = -{ -#ifndef MULTIPLICITY - "package WeechatPerlScriptLoader;" -#endif - "$weechat_perl_load_eval_file_error = \"\";" - "sub weechat_perl_load_file" - "{" - " my $filename = shift;" - " local $/ = undef;" - " open FILE, $filename or return \"__WEECHAT_PERL_ERROR__\";" - " $_ = <FILE>;" - " close FILE;" - " return $_;" - "}" - "sub weechat_perl_load_eval_file" - "{" -#ifndef MULTIPLICITY - " my ($filename, $package) = @_;" -#else - " my $filename = shift;" -#endif - " my $content = weechat_perl_load_file ($filename);" - " if ($content eq \"__WEECHAT_PERL_ERROR__\")" - " {" - " return 1;" - " }" -#ifndef MULTIPLICITY - " my $eval = qq{package $package; $content;};" -#else - " my $eval = $content;" -#endif - " {" - " eval $eval;" - " }" - " if ($@)" - " {" - " $weechat_perl_load_eval_file_error = $@;" - " return 2;" - " }" - " return 0;" - "}" - "$SIG{__WARN__} = sub { weechat::print \"Perl error: $_[0]\", \"\"; };" - "$SIG{__DIE__} = sub { weechat::print \"Perl error: $_[0]\", \"\"; };" -}; - -/* - * weechat_perl_exec: execute a Perl script - */ - -void * -weechat_perl_exec (t_weechat_plugin *plugin, - t_plugin_script *script, - int ret_type, - char *function, char *arg1, char *arg2, char *arg3) -{ - char empty_arg[1] = { '\0' }; - char *func; - char *argv[4]; - unsigned int count; - void *ret_value; - int *ret_i; - SV *ret_s; - int mem_err; - - /* this code is placed here to conform ISO C90 */ - dSP; - -#ifndef MULTIPLICITY - int size = strlen (script->interpreter) + strlen(function) + 3; - func = (char *)malloc (size * sizeof(char)); - if (!func) - return NULL; - snprintf (func, size, "%s::%s", (char *) script->interpreter, function); -#else - func = function; - PERL_SET_CONTEXT (script->interpreter); -#endif - - ENTER; - SAVETMPS; - PUSHMARK(sp); - - /* are we loading the script file ? */ - if (strcmp (function, "weechat_perl_load_eval_file") != 0) - perl_current_script = script; - - if (arg1) - { - argv[0] = (arg1) ? arg1 : empty_arg; - if (arg2) - { - argv[1] = (arg2) ? arg2 : empty_arg; - if (arg3) - { - argv[2] = (arg3) ? arg3 : empty_arg; - argv[3] = NULL; - } - else - argv[2] = NULL; - } - else - argv[1] = NULL; - } - else - argv[0] = NULL; - - count = perl_call_argv (func, G_EVAL | G_SCALAR, argv); - ret_value = NULL; - mem_err = 1; - - SPAGAIN; - - if (SvTRUE (ERRSV)) - { - plugin->print_server (plugin, "Perl error: %s", SvPV_nolen (ERRSV)); - (void) POPs; /* poping the 'undef' */ - mem_err = 0; - } - else - { - if (count != 1) - { - plugin->print_server (plugin, - "Perl error: function \"%s\" must return 1 valid value (%d)", - function, count); - mem_err = 0; - } - else - { - if (ret_type == SCRIPT_EXEC_STRING) - { - ret_s = newSVsv(POPs); - ret_value = strdup (SvPV_nolen (ret_s)); - SvREFCNT_dec (ret_s); - } - else if (ret_type == SCRIPT_EXEC_INT) - { - ret_i = (int *)malloc (sizeof(int)); - if (ret_i) - *ret_i = POPi; - ret_value = ret_i; - } - else - { - plugin->print_server (plugin, - "Perl error: function \"%s\" is internally misused.", - function); - mem_err = 0; - } - } - } - - PUTBACK; - FREETMPS; - LEAVE; - -#ifndef MULTIPLICITY - free (func); -#endif - - if (ret_value == NULL && mem_err == 1) - { - plugin->print_server (plugin, - "Perl error: unable to alloc memory in function \"%s\"", - function); - return NULL; - } - - return ret_value; -} - -/* - * weechat_perl_cmd_msg_handler: general command/message handler for Perl - */ - -int -weechat_perl_cmd_msg_handler (t_weechat_plugin *plugin, - int argc, char **argv, - char *handler_args, void *handler_pointer) -{ - int *r; - int ret; - - if (argc >= 3) - { - r = (int *) weechat_perl_exec (plugin, (t_plugin_script *)handler_pointer, - SCRIPT_EXEC_INT, - handler_args, argv[0], argv[2], NULL); - if (r == NULL) - ret = PLUGIN_RC_KO; - else - { - ret = *r; - free (r); - } - return ret; - } - else - return PLUGIN_RC_KO; -} - -/* - * weechat_perl_timer_handler: general timer handler for Perl - */ - -int -weechat_perl_timer_handler (t_weechat_plugin *plugin, - int argc, char **argv, - char *handler_args, void *handler_pointer) -{ - int *r, ret; - - /* make C compiler happy */ - (void) argc; - (void) argv; - - r = (int *) weechat_perl_exec (plugin, (t_plugin_script *)handler_pointer, - SCRIPT_EXEC_INT, - handler_args, NULL, NULL, NULL); - if (r == NULL) - ret = PLUGIN_RC_KO; - else - { - ret = *r; - free (r); - } - return ret; -} - -/* - * weechat_perl_keyboard_handler: general keyboard handler for Perl - */ - -int -weechat_perl_keyboard_handler (t_weechat_plugin *plugin, - int argc, char **argv, - char *handler_args, void *handler_pointer) -{ - int *r; - int ret; - - if (argc >= 3) - { - r = (int *) weechat_perl_exec (plugin, (t_plugin_script *)handler_pointer, - SCRIPT_EXEC_INT, - handler_args, argv[0], argv[1], argv[2]); - if (r == NULL) - ret = PLUGIN_RC_KO; - else - { - ret = *r; - free (r); - } - return ret; - } - else - return PLUGIN_RC_KO; -} - -/* - * weechat_perl_event_handler: general event handler for Perl - */ - -int -weechat_perl_event_handler (t_weechat_plugin *plugin, - int argc, char **argv, - char *handler_args, void *handler_pointer) -{ - int *r, ret; - - if (argc >= 1) - { - r = (int *) weechat_perl_exec (plugin, (t_plugin_script *)handler_pointer, - SCRIPT_EXEC_INT, - handler_args, - argv[0], - (argc >= 2) ? argv[1] : NULL, - (argc >= 3) ? argv[2] : NULL); - if (r == NULL) - ret = PLUGIN_RC_KO; - else - { - ret = *r; - free (r); - } - return ret; - } - else - return PLUGIN_RC_KO; -} - -/* - * weechat_perl_modifier: general modifier for Perl - */ - -char * -weechat_perl_modifier (t_weechat_plugin *plugin, - int argc, char **argv, - char *modifier_args, void *modifier_pointer) -{ - if (argc >= 2) - return (char *) weechat_perl_exec (plugin, (t_plugin_script *)modifier_pointer, - SCRIPT_EXEC_STRING, - modifier_args, argv[0], argv[1], NULL); - else - return NULL; -} - -/* - * weechat::register: startup function for all WeeChat Perl scripts - */ - -static XS (XS_weechat_register) -{ - char *name, *version, *shutdown_func, *description, *charset; - dXSARGS; - - /* make C compiler happy */ - (void) items; - (void) cv; - - perl_current_script = NULL; - - if ((items < 4) || (items > 5)) - { - perl_plugin->print_server (perl_plugin, - "Perl error: wrong parameters for " - "\"register\" function"); - XSRETURN_NO; - } - - name = SvPV (ST (0), PL_na); - version = SvPV (ST (1), PL_na); - shutdown_func = SvPV (ST (2), PL_na); - description = SvPV (ST (3), PL_na); - charset = (items == 5) ? SvPV (ST (4), PL_na) : NULL; - - if (weechat_script_search (perl_plugin, &perl_scripts, name)) - { - /* error: another script already exists with this name! */ - perl_plugin->print_server (perl_plugin, - "Perl error: unable to register " - "\"%s\" script (another script " - "already exists with this name)", - name); - XSRETURN_NO; - } - - /* register script */ - perl_current_script = weechat_script_add (perl_plugin, - &perl_scripts, - (perl_current_script_filename) ? - perl_current_script_filename : "", - name, version, shutdown_func, - description, charset); - if (perl_current_script) - { - perl_plugin->print_server (perl_plugin, - "Perl: registered script \"%s\", " - "version %s (%s)", - name, version, description); - } - else - { - XSRETURN_NO; - } - - XSRETURN_YES; -} - -/* - * weechat::set_charset: set script charset - */ - -static XS (XS_weechat_set_charset) -{ - dXSARGS; - - /* make C compiler happy */ - (void) cv; - - if (!perl_current_script) - { - perl_plugin->print_server (perl_plugin, - "Perl error: unable to set charset, " - "script not initialized"); - XSRETURN_EMPTY; - } - - if (items < 1) - { - perl_plugin->print_server (perl_plugin, - "Perl error: wrong parameters for " - "\"set_charset\" function"); - XSRETURN_EMPTY; - } - - weechat_script_set_charset (perl_plugin, - perl_current_script, - SvPV (ST (0), PL_na)); - - XSRETURN_YES; -} - -/* - * weechat::print: print message into a buffer (current or specified one) - */ - -static XS (XS_weechat_print) -{ - char *message, *channel_name, *server_name; - dXSARGS; - - /* make C compiler happy */ - (void) cv; - - if (!perl_current_script) - { - perl_plugin->print_server (perl_plugin, - "Perl error: unable to print message, " - "script not initialized"); - XSRETURN_NO; - } - - if (items < 1) - { - perl_plugin->print_server (perl_plugin, - "Perl error: wrong parameters for " - "\"print\" function"); - XSRETURN_NO; - } - - message = SvPV (ST (0), PL_na); - - channel_name = NULL; - server_name = NULL; - - if (items > 1) - { - channel_name = SvPV (ST (1), PL_na); - if (items > 2) - server_name = SvPV (ST (2), PL_na); - } - - weechat_script_print (perl_plugin, perl_current_script, - server_name, channel_name, - "%s", message); - - XSRETURN_YES; -} - -/* - * weechat::print_server: print message into a server buffer - */ - -static XS (XS_weechat_print_server) -{ - char *message; - dXSARGS; - - /* make C compiler happy */ - (void) cv; - - if (!perl_current_script) - { - perl_plugin->print_server (perl_plugin, - "Perl error: unable to print message, " - "script not initialized"); - XSRETURN_NO; - } - - if (items < 1) - { - perl_plugin->print_server (perl_plugin, - "Perl error: wrong parameters for " - "\"print_server\" function"); - XSRETURN_NO; - } - - message = SvPV (ST (0), PL_na); - - weechat_script_print_server (perl_plugin, perl_current_script, - "%s", message); - - XSRETURN_YES; -} - -/* - * weechat::print_infobar: print message to infobar - */ - -static XS (XS_weechat_print_infobar) -{ - dXSARGS; - - /* make C compiler happy */ - (void) cv; - - if (!perl_current_script) - { - perl_plugin->print_server (perl_plugin, - "Perl error: unable to print infobar message, " - "script not initialized"); - XSRETURN_NO; - } - - if (items < 2) - { - perl_plugin->print_server (perl_plugin, - "Perl error: wrong parameters for " - "\"print_infobar\" function"); - XSRETURN_NO; - } - - weechat_script_print_infobar (perl_plugin, perl_current_script, - SvIV (ST (0)), - "%s", SvPV (ST (1), PL_na)); - - XSRETURN_YES; -} - -/* - * weechat::remove_infobar: remove message(s) from infobar - */ - -static XS (XS_weechat_remove_infobar) -{ - dXSARGS; - - /* make C compiler happy */ - (void) cv; - - if (!perl_current_script) - { - perl_plugin->print_server (perl_plugin, - "Perl error: unable to remove infobar message(s), " - "script not initialized"); - XSRETURN_NO; - } - - perl_plugin->infobar_remove (perl_plugin, - (items >= 1) ? SvIV (ST (0)) : 0); - - XSRETURN_YES; -} - -/* - * weechat::log: log message in server/channel (current or specified ones) - */ - -static XS (XS_weechat_log) -{ - char *message, *channel_name, *server_name; - dXSARGS; - - /* make C compiler happy */ - (void) cv; - - if (!perl_current_script) - { - perl_plugin->print_server (perl_plugin, - "Perl error: unable to print message, " - "script not initialized"); - XSRETURN_NO; - } - - if (items < 1) - { - perl_plugin->print_server (perl_plugin, - "Perl error: wrong parameters for " - "\"log\" function"); - XSRETURN_NO; - } - - message = SvPV (ST (0), PL_na); - - channel_name = NULL; - server_name = NULL; - - if (items > 1) - { - channel_name = SvPV (ST (1), PL_na); - if (items > 2) - server_name = SvPV (ST (2), PL_na); - } - - weechat_script_log (perl_plugin, perl_current_script, - server_name, channel_name, - "%s", message); - - XSRETURN_YES; -} - -/* - * weechat::command: send command to server - */ - -static XS (XS_weechat_command) -{ - char *channel_name, *server_name; - dXSARGS; - - /* make C compiler happy */ - (void) cv; - - if (!perl_current_script) - { - perl_plugin->print_server (perl_plugin, - "Perl error: unable to run command, " - "script not initialized"); - XSRETURN_NO; - } - - if (items < 1) - { - perl_plugin->print_server (perl_plugin, - "Perl error: wrong parameters for " - "\"command\" function"); - XSRETURN_NO; - } - - channel_name = NULL; - server_name = NULL; - - if (items > 1) - { - channel_name = SvPV (ST (1), PL_na); - if (items > 2) - server_name = SvPV (ST (2), PL_na); - } - - weechat_script_exec_command (perl_plugin, perl_current_script, - server_name, channel_name, - SvPV (ST (0), PL_na)); - - XSRETURN_YES; -} - -/* - * weechat::add_message_handler: add a handler for messages (privmsg, ...) - */ - -static XS (XS_weechat_add_message_handler) -{ - char *irc_command, *function; - dXSARGS; - - /* make C compiler happy */ - (void) cv; - - if (!perl_current_script) - { - perl_plugin->print_server (perl_plugin, - "Perl error: unable to add message handler, " - "script not initialized"); - XSRETURN_NO; - } - - if (items < 2) - { - perl_plugin->print_server (perl_plugin, - "Perl error: wrong parameters for " - "\"add_message_handler\" function"); - XSRETURN_NO; - } - - irc_command = SvPV (ST (0), PL_na); - function = SvPV (ST (1), PL_na); - - if (perl_plugin->msg_handler_add (perl_plugin, irc_command, - weechat_perl_cmd_msg_handler, function, - (void *)perl_current_script)) - XSRETURN_YES; - - XSRETURN_NO; -} - -/* - * weechat::add_command_handler: add a command handler (define/redefine commands) - */ - -static XS (XS_weechat_add_command_handler) -{ - char *command, *function, *description, *arguments, *arguments_description; - char *completion_template; - dXSARGS; - - /* make C compiler happy */ - (void) cv; - - if (!perl_current_script) - { - perl_plugin->print_server (perl_plugin, - "Perl error: unable to add command handler, " - "script not initialized"); - XSRETURN_NO; - } - - if (items < 2) - { - perl_plugin->print_server (perl_plugin, - "Perl error: wrong parameters for " - "\"add_command_handler\" function"); - XSRETURN_NO; - } - - command = SvPV (ST (0), PL_na); - function = SvPV (ST (1), PL_na); - description = (items >= 3) ? SvPV (ST (2), PL_na) : NULL; - arguments = (items >= 4) ? SvPV (ST (3), PL_na) : NULL; - arguments_description = (items >= 5) ? SvPV (ST (4), PL_na) : NULL; - completion_template = (items >= 6) ? SvPV (ST (5), PL_na) : NULL; - - if (perl_plugin->cmd_handler_add (perl_plugin, - command, - description, - arguments, - arguments_description, - completion_template, - weechat_perl_cmd_msg_handler, - function, - (void *)perl_current_script)) - XSRETURN_YES; - - XSRETURN_NO; -} - -/* - * weechat::add_timer_handler: add a timer handler - */ - -static XS (XS_weechat_add_timer_handler) -{ - int interval; - char *function; - dXSARGS; - - /* make C compiler happy */ - (void) cv; - - if (!perl_current_script) - { - perl_plugin->print_server (perl_plugin, - "Perl error: unable to add timer handler, " - "script not initialized"); - XSRETURN_NO; - } - - if (items < 2) - { - perl_plugin->print_server (perl_plugin, - "Perl error: wrong parameters for " - "\"add_timer_handler\" function"); - XSRETURN_NO; - } - - interval = SvIV (ST (0)); - function = SvPV (ST (1), PL_na); - - if (perl_plugin->timer_handler_add (perl_plugin, interval, - weechat_perl_timer_handler, function, - (void *)perl_current_script)) - XSRETURN_YES; - - XSRETURN_NO; -} - -/* - * weechat::add_keyboard_handler: add a keyboard handler - */ - -static XS (XS_weechat_add_keyboard_handler) -{ - char *function; - dXSARGS; - - /* make C compiler happy */ - (void) cv; - - if (!perl_current_script) - { - perl_plugin->print_server (perl_plugin, - "Perl error: unable to add keyboard handler, " - "script not initialized"); - XSRETURN_NO; - } - - if (items < 1) - { - perl_plugin->print_server (perl_plugin, - "Perl error: wrong parameters for " - "\"add_keyboard_handler\" function"); - XSRETURN_NO; - } - - function = SvPV (ST (0), PL_na); - - if (perl_plugin->keyboard_handler_add (perl_plugin, - weechat_perl_keyboard_handler, - function, - (void *)perl_current_script)) - XSRETURN_YES; - - XSRETURN_NO; -} - -/* - * weechat::add_event_handler: add an event handler - */ - -static XS (XS_weechat_add_event_handler) -{ - char *event, *function; - dXSARGS; - - /* make C compiler happy */ - (void) cv; - - if (!perl_current_script) - { - perl_plugin->print_server (perl_plugin, - "Perl error: unable to add event handler, " - "script not initialized"); - XSRETURN_NO; - } - - if (items < 2) - { - perl_plugin->print_server (perl_plugin, - "Perl error: wrong parameters for " - "\"add_event_handler\" function"); - XSRETURN_NO; - } - - event = SvPV (ST (0), PL_na); - function = SvPV (ST (1), PL_na); - - if (perl_plugin->event_handler_add (perl_plugin, event, - weechat_perl_event_handler, function, - (void *)perl_current_script)) - XSRETURN_YES; - - XSRETURN_NO; -} - -/* - * weechat::remove_handler: remove a message/command handler - */ - -static XS (XS_weechat_remove_handler) -{ - char *command, *function; - dXSARGS; - - /* make C compiler happy */ - (void) cv; - - if (!perl_current_script) - { - perl_plugin->print_server (perl_plugin, - "Perl error: unable to remove handler, " - "script not initialized"); - XSRETURN_NO; - } - - if (items < 2) - { - perl_plugin->print_server (perl_plugin, - "Perl error: wrong parameters for " - "\"remove_handler\" function"); - XSRETURN_NO; - } - - command = SvPV (ST (0), PL_na); - function = SvPV (ST (1), PL_na); - - weechat_script_remove_handler (perl_plugin, perl_current_script, - command, function); - - XSRETURN_YES; -} - -/* - * weechat::remove_timer_handler: remove a timer handler - */ - -static XS (XS_weechat_remove_timer_handler) -{ - char *function; - dXSARGS; - - /* make C compiler happy */ - (void) cv; - - if (!perl_current_script) - { - perl_plugin->print_server (perl_plugin, - "Perl error: unable to remove timer handler, " - "script not initialized"); - XSRETURN_NO; - } - - if (items < 1) - { - perl_plugin->print_server (perl_plugin, - "Perl error: wrong parameters for " - "\"remove_timer_handler\" function"); - XSRETURN_NO; - } - - function = SvPV (ST (0), PL_na); - - weechat_script_remove_timer_handler (perl_plugin, perl_current_script, - function); - - XSRETURN_YES; -} - -/* - * weechat::remove_keyboard_handler: remove a keyboard handler - */ - -static XS (XS_weechat_remove_keyboard_handler) -{ - char *function; - dXSARGS; - - /* make C compiler happy */ - (void) cv; - - if (!perl_current_script) - { - perl_plugin->print_server (perl_plugin, - "Perl error: unable to remove keyboard handler, " - "script not initialized"); - XSRETURN_NO; - } - - if (items < 1) - { - perl_plugin->print_server (perl_plugin, - "Perl error: wrong parameters for " - "\"remove_keyboard_handler\" function"); - XSRETURN_NO; - } - - function = SvPV (ST (0), PL_na); - - weechat_script_remove_keyboard_handler (perl_plugin, perl_current_script, - function); - - XSRETURN_YES; -} - -/* - * weechat::remove_event_handler: remove an event handler - */ - -static XS (XS_weechat_remove_event_handler) -{ - char *function; - dXSARGS; - - /* make C compiler happy */ - (void) cv; - - if (!perl_current_script) - { - perl_plugin->print_server (perl_plugin, - "Perl error: unable to remove event handler, " - "script not initialized"); - XSRETURN_NO; - } - - if (items < 1) - { - perl_plugin->print_server (perl_plugin, - "Perl error: wrong parameters for " - "\"remove_event_handler\" function"); - XSRETURN_NO; - } - - function = SvPV (ST (0), PL_na); - - weechat_script_remove_event_handler (perl_plugin, perl_current_script, - function); - - XSRETURN_YES; -} - -/* - * weechat::add_modifier: add a modifier - */ - -static XS (XS_weechat_add_modifier) -{ - char *type, *command, *function; - dXSARGS; - - /* make C compiler happy */ - (void) cv; - - if (!perl_current_script) - { - perl_plugin->print_server (perl_plugin, - "Perl error: unable to add modifier, " - "script not initialized"); - XSRETURN_NO; - } - - if (items < 3) - { - perl_plugin->print_server (perl_plugin, - "Perl error: wrong parameters for " - "\"add_modifier\" function"); - XSRETURN_NO; - } - - type = SvPV (ST (0), PL_na); - command = SvPV (ST (1), PL_na); - function = SvPV (ST (2), PL_na); - - if (perl_plugin->modifier_add (perl_plugin, type, command, - weechat_perl_modifier, function, - (void *)perl_current_script)) - XSRETURN_YES; - - XSRETURN_NO; -} - -/* - * weechat::remove_modifier: remove a modifier - */ - -static XS (XS_weechat_remove_modifier) -{ - char *type, *command, *function; - dXSARGS; - - /* make C compiler happy */ - (void) cv; - - if (!perl_current_script) - { - perl_plugin->print_server (perl_plugin, - "Perl error: unable to remove modifier, " - "script not initialized"); - XSRETURN_NO; - } - - if (items < 2) - { - perl_plugin->print_server (perl_plugin, - "Perl error: wrong parameters for " - "\"remove_modifier\" function"); - XSRETURN_NO; - } - - type = SvPV (ST (0), PL_na); - command = SvPV (ST (1), PL_na); - function = SvPV (ST (2), PL_na); - - weechat_script_remove_modifier (perl_plugin, perl_current_script, - type, command, function); - - XSRETURN_YES; -} - -/* - * weechat::get_info: get various infos - */ - -static XS (XS_weechat_get_info) -{ - char *arg, *info, *server_name; - dXSARGS; - - /* make C compiler happy */ - (void) cv; - - if (!perl_current_script) - { - perl_plugin->print_server (perl_plugin, - "Perl error: unable to get info, " - "script not initialized"); - XSRETURN_NO; - } - - if (items < 1) - { - perl_plugin->print_server (perl_plugin, - "Perl error: wrong parameters for " - "\"get_info\" function"); - XSRETURN_NO; - } - - server_name = (items == 2) ? SvPV (ST (1), PL_na) : NULL; - - arg = SvPV (ST (0), PL_na); - if (arg) - { - info = perl_plugin->get_info (perl_plugin, arg, server_name); - - if (info) - { - XST_mPV (0, info); - free (info); - XSRETURN (1); - } - } - - 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 count; - char timebuffer1[64]; - char timebuffer2[64]; - struct in_addr in; - HV *dcc_hash_member; - dXSARGS; - - /* make C compiler happy */ - (void) cv; - (void) items; - - if (!perl_current_script) - { - perl_plugin->print_server (perl_plugin, - "Perl error: unable to get DCC info, " - "script not initialized"); - XSRETURN_EMPTY; - } - - dcc_info = perl_plugin->get_dcc_info (perl_plugin); - count = 0; - if (!dcc_info) - XSRETURN_EMPTY; - - for (ptr_dcc = dcc_info; ptr_dcc; ptr_dcc = ptr_dcc->next_dcc) - { - strftime(timebuffer1, sizeof(timebuffer1), "%F %T", - localtime(&ptr_dcc->start_time)); - strftime(timebuffer2, sizeof(timebuffer2), "%F %T", - localtime(&ptr_dcc->start_transfer)); - in.s_addr = htonl(ptr_dcc->addr); - - dcc_hash_member = (HV *) sv_2mortal ((SV *) newHV()); - - hv_store (dcc_hash_member, "server", 6, newSVpv (ptr_dcc->server, 0), 0); - hv_store (dcc_hash_member, "channel", 7, newSVpv (ptr_dcc->channel, 0), 0); - hv_store (dcc_hash_member, "type", 4, newSViv (ptr_dcc->type), 0); - hv_store (dcc_hash_member, "status", 6, newSViv (ptr_dcc->status), 0); - hv_store (dcc_hash_member, "start_time", 10, newSVpv (timebuffer1, 0), 0); - hv_store (dcc_hash_member, "start_transfer", 14, newSVpv (timebuffer2, 0), 0); - hv_store (dcc_hash_member, "address", 7, newSVpv (inet_ntoa(in), 0), 0); - hv_store (dcc_hash_member, "port", 4, newSViv (ptr_dcc->port), 0); - hv_store (dcc_hash_member, "nick", 4, newSVpv (ptr_dcc->nick, 0), 0); - hv_store (dcc_hash_member, "remote_file", 11, newSVpv (ptr_dcc->filename, 0), 0); - hv_store (dcc_hash_member, "local_file", 10, newSVpv (ptr_dcc->local_filename, 0), 0); - hv_store (dcc_hash_member, "filename_suffix", 15, newSViv (ptr_dcc->filename_suffix), 0); - hv_store (dcc_hash_member, "size", 4, newSVnv (ptr_dcc->size), 0); - hv_store (dcc_hash_member, "pos", 3, newSVnv (ptr_dcc->pos), 0); - hv_store (dcc_hash_member, "start_resume", 12, newSVnv (ptr_dcc->start_resume), 0); - hv_store (dcc_hash_member, "cps", 3, newSViv (ptr_dcc->bytes_per_sec), 0); - - XPUSHs(newRV_inc((SV *) dcc_hash_member)); - count++; - } - perl_plugin->free_dcc_info (perl_plugin, dcc_info); - - XSRETURN (count); -} - -/* - * weechat::get_config: get value of a WeeChat config option - */ - -static XS (XS_weechat_get_config) -{ - char *option, *return_value; - dXSARGS; - - /* make C compiler happy */ - (void) cv; - - if (!perl_current_script) - { - perl_plugin->print_server (perl_plugin, - "Perl error: unable to get config option, " - "script not initialized"); - XSRETURN_EMPTY; - } - - if (items < 1) - { - perl_plugin->print_server (perl_plugin, - "Perl error: wrong parameters for " - "\"get_config\" function"); - XSRETURN_EMPTY; - } - - option = SvPV (ST (0), PL_na); - - if (option) - { - return_value = perl_plugin->get_config (perl_plugin, option); - - if (return_value) - { - XST_mPV (0, return_value); - free (return_value); - XSRETURN (1); - } - } - - XST_mPV (0, ""); - XSRETURN (1); -} - -/* - * weechat::set_config: set value of a WeeChat config option - */ - -static XS (XS_weechat_set_config) -{ - char *option, *value; - dXSARGS; - - /* make C compiler happy */ - (void) cv; - - if (!perl_current_script) - { - perl_plugin->print_server (perl_plugin, - "Perl error: unable to set config option, " - "script not initialized"); - XSRETURN_NO; - } - - if (items < 2) - { - perl_plugin->print_server (perl_plugin, - "Perl error: wrong parameters for " - "\"set_config\" function"); - XSRETURN_NO; - } - - option = SvPV (ST (0), PL_na); - value = SvPV (ST (1), PL_na); - - if (option && value) - { - if (perl_plugin->set_config (perl_plugin, option, value)) - XSRETURN_YES; - } - - XSRETURN_NO; -} - -/* - * weechat::get_plugin_config: get value of a plugin config option - */ - -static XS (XS_weechat_get_plugin_config) -{ - char *option, *return_value; - dXSARGS; - - /* make C compiler happy */ - (void) cv; - - if (!perl_current_script) - { - perl_plugin->print_server (perl_plugin, - "Perl error: unable to get plugin config option, " - "script not initialized"); - XSRETURN_EMPTY; - } - - if (items < 1) - { - perl_plugin->print_server (perl_plugin, - "Perl error: wrong parameters for " - "\"get_plugin_config\" function"); - XSRETURN_EMPTY; - } - - option = SvPV (ST (0), PL_na); - - if (option) - { - return_value = weechat_script_get_plugin_config (perl_plugin, - perl_current_script, - option); - - if (return_value) - { - XST_mPV (0, return_value); - free (return_value); - XSRETURN (1); - } - } - - XST_mPV (0, ""); - XSRETURN (1); -} - -/* - * weechat::set_plugin_config: set value of a WeeChat config option - */ - -static XS (XS_weechat_set_plugin_config) -{ - char *option, *value; - dXSARGS; - - /* make C compiler happy */ - (void) cv; - - if (!perl_current_script) - { - perl_plugin->print_server (perl_plugin, - "Perl error: unable to set plugin config option, " - "script not initialized"); - XSRETURN_NO; - } - - if (items < 2) - { - perl_plugin->print_server (perl_plugin, - "Perl error: wrong parameters for " - "\"set_plugin_config\" function"); - XSRETURN_NO; - } - - option = SvPV (ST (0), PL_na); - value = SvPV (ST (1), PL_na); - - if (option && value) - { - if (weechat_script_set_plugin_config (perl_plugin, - perl_current_script, - option, value)) - XSRETURN_YES; - } - - XSRETURN_NO; -} - -/* - * weechat::get_server_info: get infos about servers - */ - -static XS (XS_weechat_get_server_info) -{ - t_plugin_server_info *server_info, *ptr_server; - char timebuffer[64]; - HV *server_hash, *server_hash_member; - dXSARGS; - - /* make C compiler happy */ - (void) cv; - (void) items; - - if (!perl_current_script) - { - perl_plugin->print_server (perl_plugin, - "Perl error: unable to get server info, " - "script not initialized"); - XSRETURN_EMPTY; - } - - server_info = perl_plugin->get_server_info (perl_plugin); - if (!server_info) - { - XSRETURN_EMPTY; - } - - server_hash = (HV *) sv_2mortal((SV *) newHV()); - if (!server_hash) - { - perl_plugin->free_server_info (perl_plugin, server_info); - XSRETURN_EMPTY; - } - - for (ptr_server = server_info; ptr_server; ptr_server = ptr_server->next_server) - { - strftime(timebuffer, sizeof(timebuffer), "%F %T", - localtime(&ptr_server->away_time)); - - server_hash_member = (HV *) sv_2mortal((SV *) newHV()); - - hv_store (server_hash_member, "autoconnect", 11, newSViv (ptr_server->autoconnect), 0); - hv_store (server_hash_member, "autoreconnect", 13, newSViv (ptr_server->autoreconnect), 0); - hv_store (server_hash_member, "autoreconnect_delay", 19, newSViv (ptr_server->autoreconnect_delay), 0); - hv_store (server_hash_member, "temp_server", 11, newSViv (ptr_server->temp_server), 0); - hv_store (server_hash_member, "address", 7, newSVpv (ptr_server->address, 0), 0); - hv_store (server_hash_member, "port", 4, newSViv (ptr_server->port), 0); - hv_store (server_hash_member, "ipv6", 4, newSViv (ptr_server->ipv6), 0); - hv_store (server_hash_member, "ssl", 3, newSViv (ptr_server->ssl), 0); - hv_store (server_hash_member, "password", 8, newSVpv (ptr_server->password, 0), 0); - hv_store (server_hash_member, "nick1", 5, newSVpv (ptr_server->nick1, 0), 0); - hv_store (server_hash_member, "nick2", 5, newSVpv (ptr_server->nick2, 0), 0); - hv_store (server_hash_member, "nick3", 5, newSVpv (ptr_server->nick3, 0), 0); - hv_store (server_hash_member, "username", 8, newSVpv (ptr_server->username, 0), 0); - hv_store (server_hash_member, "realname", 8, newSVpv (ptr_server->realname, 0), 0); - hv_store (server_hash_member, "command", 7, newSVpv (ptr_server->command, 0), 0); - hv_store (server_hash_member, "command_delay", 13, newSViv (ptr_server->command_delay), 0); - hv_store (server_hash_member, "autojoin", 8, newSVpv (ptr_server->autojoin, 0), 0); - hv_store (server_hash_member, "autorejoin", 10, newSViv (ptr_server->autorejoin), 0); - hv_store (server_hash_member, "notify_levels", 13, newSVpv (ptr_server->notify_levels, 0), 0); - hv_store (server_hash_member, "is_connected", 12, newSViv (ptr_server->is_connected), 0); - hv_store (server_hash_member, "ssl_connected", 13, newSViv (ptr_server->ssl_connected), 0); - hv_store (server_hash_member, "nick", 4, newSVpv (ptr_server->nick, 0), 0); - hv_store (server_hash_member, "nick_modes", 10, newSVpv (ptr_server->nick_modes, 0), 0); - hv_store (server_hash_member, "away_time", 9, newSVpv (timebuffer, 0), 0); - hv_store (server_hash_member, "lag", 3, newSViv (ptr_server->lag), 0); - - hv_store (server_hash, ptr_server->name, strlen(ptr_server->name), newRV_inc((SV *) server_hash_member), 0); - } - perl_plugin->free_server_info (perl_plugin, server_info); - - ST (0) = newRV_inc((SV *) server_hash); - if (SvREFCNT(ST(0))) sv_2mortal(ST(0)); - - XSRETURN (1); -} - -/* - * weechat::get_channel_info: get infos about channels - */ - -static XS (XS_weechat_get_channel_info) -{ - t_plugin_channel_info *channel_info, *ptr_channel; - char *server; - HV *channel_hash, *channel_hash_member; - dXSARGS; - - /* make C compiler happy */ - (void) cv; - - if (!perl_current_script) - { - perl_plugin->print_server (perl_plugin, - "Perl error: unable to get channel info, " - "script not initialized"); - XSRETURN_EMPTY; - } - - if (items != 1) - { - perl_plugin->print_server (perl_plugin, - "Perl error: wrong parameters for " - "\"get_channel_info\" function"); - XSRETURN_EMPTY; - } - - server = SvPV (ST (0), PL_na); - if (!server) - XSRETURN_EMPTY; - - channel_info = perl_plugin->get_channel_info (perl_plugin, server); - if (!channel_info) - { - XSRETURN_EMPTY; - } - - channel_hash = (HV *) sv_2mortal((SV *) newHV()); - if (!channel_hash) - { - perl_plugin->free_channel_info (perl_plugin, channel_info); - XSRETURN_EMPTY; - } - - for (ptr_channel = channel_info; ptr_channel; ptr_channel = ptr_channel->next_channel) - { - channel_hash_member = (HV *) sv_2mortal((SV *) newHV()); - - hv_store (channel_hash_member, "type", 4, newSViv (ptr_channel->type), 0); - hv_store (channel_hash_member, "topic", 5, newSVpv (ptr_channel->topic, 0), 0); - hv_store (channel_hash_member, "modes", 5, newSVpv (ptr_channel->modes, 0), 0); - hv_store (channel_hash_member, "limit", 5, newSViv (ptr_channel->limit), 0); - hv_store (channel_hash_member, "key", 3, newSVpv (ptr_channel->key, 0), 0); - hv_store (channel_hash_member, "nicks_count", 11, newSViv (ptr_channel->nicks_count), 0); - - hv_store (channel_hash, ptr_channel->name, strlen(ptr_channel->name), newRV_inc((SV *) channel_hash_member), 0); - } - perl_plugin->free_channel_info (perl_plugin, channel_info); - - ST (0) = newRV_inc((SV *) channel_hash); - if (SvREFCNT(ST(0))) sv_2mortal(ST(0)); - - XSRETURN (1); -} - -/* - * weechat::get_nick_info: get infos about nicks - */ - -static XS (XS_weechat_get_nick_info) -{ - t_plugin_nick_info *nick_info, *ptr_nick; - char *server, *channel; - HV *nick_hash; - dXSARGS; - - /* make C compiler happy */ - (void) cv; - - if (!perl_current_script) - { - perl_plugin->print_server (perl_plugin, - "Perl error: unable to get nick info, " - "script not initialized"); - XSRETURN_EMPTY; - } - - if (items != 2) - { - perl_plugin->print_server (perl_plugin, - "Perl error: wrong parameters for " - "\"get_nick_info\" function"); - XSRETURN_EMPTY; - } - - server = SvPV (ST (0), PL_na); - channel = SvPV (ST (1), PL_na); - if (!server || !channel) - XSRETURN_EMPTY; - - nick_info = perl_plugin->get_nick_info (perl_plugin, server, channel); - if (!nick_info) - { - XSRETURN_EMPTY; - } - - nick_hash = (HV *) sv_2mortal((SV *) newHV()); - if (!nick_hash) - { - perl_plugin->free_nick_info (perl_plugin, nick_info); - XSRETURN_EMPTY; - } - - for (ptr_nick = nick_info; ptr_nick; ptr_nick = ptr_nick->next_nick) - { - HV *nick_hash_member = (HV *) sv_2mortal((SV *) newHV()); - - hv_store (nick_hash_member, "flags", 5, newSViv (ptr_nick->flags), 0); - hv_store (nick_hash_member, "host", 4, newSVpv ( - ptr_nick->host ? ptr_nick->host : "", 0), 0); - - hv_store (nick_hash, ptr_nick->nick, strlen(ptr_nick->nick), newRV_inc((SV *) nick_hash_member), 0); - } - perl_plugin->free_nick_info (perl_plugin, nick_info); - - ST (0) = newRV_inc((SV *) nick_hash); - if (SvREFCNT(ST(0))) sv_2mortal(ST(0)); - - XSRETURN (1); -} - -/* - * weechat::color_input: add color in input buffer - */ - -static XS (XS_weechat_input_color) -{ - int color, start, length; - dXSARGS; - - /* make C compiler happy */ - (void) cv; - - if (!perl_current_script) - { - perl_plugin->print_server (perl_plugin, - "Perl error: unable to colorize input, " - "script not initialized"); - XSRETURN_NO; - } - - if (items < 3) - { - perl_plugin->print_server (perl_plugin, - "Perl error: wrong parameters for " - "\"color_input\" function"); - XSRETURN_NO; - } - - color = SvIV (ST (0)); - start = SvIV (ST (1)); - length = SvIV (ST (2)); - - perl_plugin->input_color (perl_plugin, color, start, length); - - XSRETURN_YES; -} - -/* - * weechat::get_irc_color: - * get the numeric value which identify an irc color by its name - */ - -static XS (XS_weechat_get_irc_color) -{ - char *color; - dXSARGS; - - /* make C compiler happy */ - (void) cv; - - if (!perl_current_script) - { - perl_plugin->print_server (perl_plugin, - "Perl error: unable to get irc color, " - "script not initialized"); - XST_mIV (0, -1); - XSRETURN (1); - } - - if (items != 1) - { - perl_plugin->print_server (perl_plugin, - "Perl error: wrong parameters for " - "\"get_irc_info\" function"); - XST_mIV (0, -1); - XSRETURN (1); - } - - color = SvPV (ST (0), PL_na); - if (color) - { - XST_mIV (0, perl_plugin->get_irc_color (perl_plugin, color)); - XSRETURN (1); - } - - XST_mIV (0, -1); - XSRETURN (-1); -} - -/* - * weechat::get_window_info: get infos about windows - */ - -static XS (XS_weechat_get_window_info) -{ - t_plugin_window_info *window_info, *ptr_win; - int count; - HV *window_hash_member; - dXSARGS; - - /* make C compiler happy */ - (void) cv; - (void) items; - - if (!perl_current_script) - { - perl_plugin->print_server (perl_plugin, - "Perl error: unable to get window info, " - "script not initialized"); - XSRETURN_EMPTY; - } - - window_info = perl_plugin->get_window_info (perl_plugin); - count = 0; - if (!window_info) - XSRETURN_EMPTY; - - for (ptr_win = window_info; ptr_win; ptr_win = ptr_win->next_window) - { - window_hash_member = (HV *) sv_2mortal((SV *) newHV()); - - hv_store (window_hash_member, "num_buffer", 10, newSViv (ptr_win->num_buffer), 0); - hv_store (window_hash_member, "win_x", 5, newSViv (ptr_win->win_x), 0); - hv_store (window_hash_member, "win_y", 5, newSViv (ptr_win->win_y), 0); - hv_store (window_hash_member, "win_width", 9, newSViv (ptr_win->win_width), 0); - hv_store (window_hash_member, "win_height", 10, newSViv (ptr_win->win_height), 0); - hv_store (window_hash_member, "win_width_pct", 13, newSViv (ptr_win->win_width_pct), 0); - hv_store (window_hash_member, "win_height_pct", 14, newSViv (ptr_win->win_height_pct), 0); - - XPUSHs(newRV_inc((SV *) window_hash_member)); - count++; - } - perl_plugin->free_window_info (perl_plugin, window_info); - - XSRETURN (count); -} - -/* - * weechat::get_buffer_info: get infos about buffers - */ - -static XS (XS_weechat_get_buffer_info) -{ - t_plugin_buffer_info *buffer_info, *ptr_buffer; - HV *buffer_hash, *buffer_hash_member; - char conv[8]; - dXSARGS; - - /* make C compiler happy */ - (void) cv; - (void) items; - - if (!perl_current_script) - { - perl_plugin->print_server (perl_plugin, - "Perl error: unable to get buffer info, " - "script not initialized"); - XSRETURN_EMPTY; - } - - buffer_info = perl_plugin->get_buffer_info (perl_plugin); - if (!buffer_info) - { - XSRETURN_EMPTY; - } - - buffer_hash = (HV *) sv_2mortal((SV *) newHV()); - if (!buffer_hash) - { - perl_plugin->free_buffer_info (perl_plugin, buffer_info); - XSRETURN_EMPTY; - } - - for (ptr_buffer = buffer_info; ptr_buffer; ptr_buffer = ptr_buffer->next_buffer) - { - buffer_hash_member = (HV *) sv_2mortal((SV *) newHV()); - - hv_store (buffer_hash_member, "type", 4, newSViv (ptr_buffer->type), 0); - hv_store (buffer_hash_member, "num_displayed", 13, newSViv (ptr_buffer->num_displayed), 0); - hv_store (buffer_hash_member, "server", 6, - newSVpv (ptr_buffer->server_name == NULL ? "" : ptr_buffer->server_name, 0), 0); - hv_store (buffer_hash_member, "channel", 7, - newSVpv (ptr_buffer->channel_name == NULL ? "" : ptr_buffer->channel_name, 0), 0); - hv_store (buffer_hash_member, "notify_level", 12, newSViv (ptr_buffer->notify_level), 0); - hv_store (buffer_hash_member, "log_filename", 12, - newSVpv (ptr_buffer->log_filename == NULL ? "" : ptr_buffer->log_filename, 0), 0); - snprintf(conv, sizeof(conv), "%d", ptr_buffer->number); - hv_store (buffer_hash, conv, strlen(conv), newRV_inc((SV *) buffer_hash_member), 0); - } - perl_plugin->free_buffer_info (perl_plugin, buffer_info); - - ST (0) = newRV_inc((SV *) buffer_hash); - if (SvREFCNT(ST(0))) sv_2mortal(ST(0)); - - XSRETURN (1); -} - -/* - * weechat::get_buffer_data: get buffer content - */ - -static XS (XS_weechat_get_buffer_data) -{ - t_plugin_buffer_line *buffer_data, *ptr_data; - HV *data_list_member; - char *server, *channel; - char timebuffer[64]; - int count; - - dXSARGS; - - /* make C compiler happy */ - (void) cv; - (void) items; - - if (!perl_current_script) - { - perl_plugin->print_server (perl_plugin, - "Perl error: unable to get buffer data, " - "script not initialized"); - XSRETURN_EMPTY; - } - - if (items != 2) - { - perl_plugin->print_server (perl_plugin, - "Perl error: wrong parameters for " - "\"get_buffer_data\" function"); - XSRETURN_EMPTY; - } - - channel = NULL; - server = NULL; - - if (items >= 1) - server = SvPV (ST (0), PL_na); - if (items >= 2) - channel = SvPV (ST (1), PL_na); - - SP -= items; - - buffer_data = perl_plugin->get_buffer_data (perl_plugin, server, channel); - count = 0; - if (!buffer_data) - XSRETURN_EMPTY; - - for (ptr_data = buffer_data; ptr_data; ptr_data = ptr_data->next_line) - { - data_list_member = (HV *) sv_2mortal((SV *) newHV()); - - strftime(timebuffer, sizeof(timebuffer), "%F %T", - localtime(&ptr_data->date)); - - hv_store (data_list_member, "date", 4, newSVpv (timebuffer, 0), 0); - hv_store (data_list_member, "nick", 4, - newSVpv (ptr_data->nick == NULL ? "" : ptr_data->nick, 0), 0); - hv_store (data_list_member, "data", 4, - newSVpv (ptr_data->data == NULL ? "" : ptr_data->data, 0), 0); - - XPUSHs(newRV_inc((SV *) data_list_member)); - count++; - } - perl_plugin->free_buffer_data (perl_plugin, buffer_data); - - XSRETURN (count); -} - -/* - * weechat_perl_xs_init: initialize subroutines - */ - -void -weechat_perl_xs_init (pTHX) -{ - HV *stash; - - newXS ("DynaLoader::boot_DynaLoader", boot_DynaLoader, __FILE__); - - /* interface functions */ - newXS ("weechat::register", XS_weechat_register, "weechat"); - newXS ("weechat::set_charset", XS_weechat_set_charset, "weechat"); - newXS ("weechat::print", XS_weechat_print, "weechat"); - newXS ("weechat::print_server", XS_weechat_print_server, "weechat"); - newXS ("weechat::print_infobar", XS_weechat_print_infobar, "weechat"); - newXS ("weechat::remove_infobar", XS_weechat_remove_infobar, "weechat"); - newXS ("weechat::log", XS_weechat_log, "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::add_timer_handler", XS_weechat_add_timer_handler, "weechat"); - newXS ("weechat::add_keyboard_handler", XS_weechat_add_keyboard_handler, "weechat"); - newXS ("weechat::add_event_handler", XS_weechat_add_event_handler, "weechat"); - newXS ("weechat::remove_handler", XS_weechat_remove_handler, "weechat"); - newXS ("weechat::remove_timer_handler", XS_weechat_remove_timer_handler, "weechat"); - newXS ("weechat::remove_keyboard_handler", XS_weechat_remove_keyboard_handler, "weechat"); - newXS ("weechat::remove_event_handler", XS_weechat_remove_event_handler, "weechat"); - newXS ("weechat::add_modifier", XS_weechat_add_modifier, "weechat"); - newXS ("weechat::remove_modifier", XS_weechat_remove_modifier, "weechat"); - newXS ("weechat::get_info", XS_weechat_get_info, "weechat"); - newXS ("weechat::get_dcc_info", XS_weechat_get_dcc_info, "weechat"); - newXS ("weechat::get_config", XS_weechat_get_config, "weechat"); - newXS ("weechat::set_config", XS_weechat_set_config, "weechat"); - newXS ("weechat::get_plugin_config", XS_weechat_get_plugin_config, "weechat"); - newXS ("weechat::set_plugin_config", XS_weechat_set_plugin_config, "weechat"); - newXS ("weechat::get_server_info", XS_weechat_get_server_info, "weechat"); - newXS ("weechat::get_channel_info", XS_weechat_get_channel_info, "weechat"); - newXS ("weechat::get_nick_info", XS_weechat_get_nick_info, "weechat"); - newXS ("weechat::input_color", XS_weechat_input_color, "weechat"); - newXS ("weechat::get_irc_color", XS_weechat_get_irc_color, "weechat"); - newXS ("weechat::get_window_info", XS_weechat_get_window_info, "weechat"); - newXS ("weechat::get_buffer_info", XS_weechat_get_buffer_info, "weechat"); - newXS ("weechat::get_buffer_data", XS_weechat_get_buffer_data, "weechat"); - - /* interface constants */ - stash = gv_stashpv ("weechat", TRUE); - newCONSTSUB (stash, "weechat::PLUGIN_RC_KO", newSViv (PLUGIN_RC_KO)); - newCONSTSUB (stash, "weechat::PLUGIN_RC_OK", newSViv (PLUGIN_RC_OK)); - newCONSTSUB (stash, "weechat::PLUGIN_RC_OK_IGNORE_WEECHAT", newSViv (PLUGIN_RC_OK_IGNORE_WEECHAT)); - newCONSTSUB (stash, "weechat::PLUGIN_RC_OK_IGNORE_PLUGINS", newSViv (PLUGIN_RC_OK_IGNORE_PLUGINS)); - newCONSTSUB (stash, "weechat::PLUGIN_RC_OK_IGNORE_ALL", newSViv (PLUGIN_RC_OK_IGNORE_ALL)); - newCONSTSUB (stash, "weechat::PLUGIN_RC_OK_WITH_HIGHLIGHT", newSViv (PLUGIN_RC_OK_WITH_HIGHLIGHT)); -} - -/* - * weechat_perl_load: load a Perl script - */ - -int -weechat_perl_load (t_weechat_plugin *plugin, char *filename) -{ - STRLEN len; - t_plugin_script tempscript; - int *eval; - struct stat buf; - -#ifndef MULTIPLICITY - char pkgname[64]; -#else - PerlInterpreter *perl_current_interpreter; - char *perl_args[] = { "", "-e", "0" }; -#endif - - plugin->print_server (plugin, "Loading Perl script \"%s\"", filename); - - if (stat (filename, &buf) != 0) - { - plugin->print_server (plugin, "Perl error: script \"%s\" not found", - filename); - return 0; - } - - perl_current_script = NULL; - -#ifndef MULTIPLICITY - snprintf(pkgname, sizeof(pkgname), "%s%d", PKG_NAME_PREFIX, perl_num); - perl_num++; - tempscript.interpreter = "WeechatPerlScriptLoader"; - eval = weechat_perl_exec (plugin, &tempscript, - SCRIPT_EXEC_INT, - "weechat_perl_load_eval_file", filename, pkgname, ""); -#else - perl_current_interpreter = perl_alloc(); - - if (perl_current_interpreter == NULL) - { - plugin->print_server (plugin, - "Perl error: unable to create new sub-interpreter"); - return 0; - } - - perl_current_script_filename = filename; - - PERL_SET_CONTEXT (perl_current_interpreter); - perl_construct (perl_current_interpreter); - tempscript.interpreter = (PerlInterpreter *) perl_current_interpreter; - perl_parse (perl_current_interpreter, weechat_perl_xs_init, 3, perl_args, NULL); - - eval_pv (perl_weechat_code, TRUE); - eval = weechat_perl_exec (plugin, &tempscript, - SCRIPT_EXEC_INT, - "weechat_perl_load_eval_file", filename, "", ""); -#endif - if (eval == NULL) - { - plugin->print_server (plugin, - "Perl error: memory error while parsing file \"%s\"", - filename); - return 0; - } - - if ( *eval != 0) - { - if (*eval == 2) - { - plugin->print_server (plugin, - "Perl error: unable to parse file \"%s\"", - filename); - plugin->print_server (plugin, - "Perl error: %s", -#ifndef MULTIPLICITY - SvPV(perl_get_sv("WeechatPerlScriptLoader::weechat_perl_load_eval_file_error", FALSE), len) -#else - SvPV(perl_get_sv("weechat_perl_load_eval_file_error", FALSE), len) -#endif - ); - } - else if (*eval == 1) - { - plugin->print_server (plugin, - "Perl error: unable to run file \"%s\"", - filename); - } - else { - plugin->print_server (plugin, - "Perl error: unknown error while loading file \"%s\"", - filename); - } -#ifdef MULTIPLICITY - perl_destruct (perl_current_interpreter); - perl_free (perl_current_interpreter); -#endif - if ((perl_current_script != NULL) && (perl_current_script != &tempscript)) - weechat_script_remove (plugin, &perl_scripts, perl_current_script); - - free (eval); - return 0; - } - - free (eval); - - if (perl_current_script == NULL) - { - plugin->print_server (plugin, - "Perl error: function \"register\" not found " - "(or failed) in file \"%s\"", - filename); -#ifdef MULTIPLICITY - perl_destruct (perl_current_interpreter); - perl_free (perl_current_interpreter); -#endif - return 0; - } - -#ifndef MULTIPLICITY - perl_current_script->interpreter = strdup(pkgname); -#else - perl_current_script->interpreter = (PerlInterpreter *) perl_current_interpreter; -#endif - - return 1; -} - -/* - * weechat_perl_unload: unload a Perl script - */ - -void -weechat_perl_unload (t_weechat_plugin *plugin, t_plugin_script *script) -{ - int *r; - - plugin->print_server (plugin, - "Unloading Perl script \"%s\"", - script->name); - -#ifndef MULTIPLICITY - eval_pv(script->interpreter, TRUE); -#else - PERL_SET_CONTEXT (script->interpreter); -#endif - - if (script->shutdown_func[0]) - { - r = (int *) weechat_perl_exec (plugin, script, SCRIPT_EXEC_INT, - script->shutdown_func, NULL, NULL, NULL); - if (r) - free (r); - } - -#ifndef MULTIPLICITY - if (script->interpreter) - free (script->interpreter); -#else - perl_destruct (script->interpreter); - perl_free (script->interpreter); -#endif - - weechat_script_remove (plugin, &perl_scripts, script); -} - -/* - * weechat_perl_unload_name: unload a Perl script by name - */ - -void -weechat_perl_unload_name (t_weechat_plugin *plugin, char *name) -{ - t_plugin_script *ptr_script; - - ptr_script = weechat_script_search (plugin, &perl_scripts, name); - if (ptr_script) - { - weechat_perl_unload (plugin, ptr_script); - plugin->print_server (plugin, - "Perl script \"%s\" unloaded", - name); - } - else - { - plugin->print_server (plugin, - "Perl error: script \"%s\" not loaded", - name); - } -} - -/* - * weechat_perl_unload_all: unload all Perl scripts - */ - -void -weechat_perl_unload_all (t_weechat_plugin *plugin) -{ - plugin->print_server (plugin, - "Unloading all Perl scripts"); - while (perl_scripts) - weechat_perl_unload (plugin, perl_scripts); - - plugin->print_server (plugin, - "Perl scripts unloaded"); -} - -/* - * weechat_perl_cmd: /perl command handler - */ - -int -weechat_perl_cmd (t_weechat_plugin *plugin, - int cmd_argc, char **cmd_argv, - char *handler_args, void *handler_pointer) -{ - int argc, handler_found, modifier_found; - char **argv, *path_script; - t_plugin_script *ptr_script; - t_plugin_handler *ptr_handler; - t_plugin_modifier *ptr_modifier; - - if (cmd_argc < 3) - return PLUGIN_RC_KO; - - /* make C compiler happy */ - (void) handler_args; - (void) handler_pointer; - - if (cmd_argv[2]) - argv = plugin->explode_string (plugin, cmd_argv[2], " ", 0, &argc); - else - { - argv = NULL; - argc = 0; - } - - switch (argc) - { - case 0: - /* list registered Perl scripts */ - plugin->print_server (plugin, ""); - plugin->print_server (plugin, "Registered Perl scripts:"); - if (perl_scripts) - { - for (ptr_script = perl_scripts; - ptr_script; ptr_script = ptr_script->next_script) - { - plugin->print_server (plugin, " %s v%s%s%s", - ptr_script->name, - ptr_script->version, - (ptr_script->description[0]) ? " - " : "", - ptr_script->description); - } - } - else - plugin->print_server (plugin, " (none)"); - - /* list Perl message handlers */ - plugin->print_server (plugin, ""); - plugin->print_server (plugin, "Perl message handlers:"); - handler_found = 0; - for (ptr_handler = plugin->handlers; - ptr_handler; ptr_handler = ptr_handler->next_handler) - { - if ((ptr_handler->type == PLUGIN_HANDLER_MESSAGE) - && (ptr_handler->handler_args)) - { - handler_found = 1; - plugin->print_server (plugin, " IRC(%s) => Perl(%s)", - ptr_handler->irc_command, - ptr_handler->handler_args); - } - } - if (!handler_found) - plugin->print_server (plugin, " (none)"); - - /* list Perl command handlers */ - plugin->print_server (plugin, ""); - plugin->print_server (plugin, "Perl command handlers:"); - handler_found = 0; - for (ptr_handler = plugin->handlers; - ptr_handler; ptr_handler = ptr_handler->next_handler) - { - if ((ptr_handler->type == PLUGIN_HANDLER_COMMAND) - && (ptr_handler->handler_args)) - { - handler_found = 1; - plugin->print_server (plugin, " /%s => Perl(%s)", - ptr_handler->command, - ptr_handler->handler_args); - } - } - if (!handler_found) - plugin->print_server (plugin, " (none)"); - - /* list Perl timer handlers */ - plugin->print_server (plugin, ""); - plugin->print_server (plugin, "Perl timer handlers:"); - handler_found = 0; - for (ptr_handler = plugin->handlers; - ptr_handler; ptr_handler = ptr_handler->next_handler) - { - if ((ptr_handler->type == PLUGIN_HANDLER_TIMER) - && (ptr_handler->handler_args)) - { - handler_found = 1; - plugin->print_server (plugin, " %d seconds => Perl(%s)", - ptr_handler->interval, - ptr_handler->handler_args); - } - } - if (!handler_found) - plugin->print_server (plugin, " (none)"); - - /* list Perl keyboard handlers */ - plugin->print_server (plugin, ""); - plugin->print_server (plugin, "Perl keyboard handlers:"); - handler_found = 0; - for (ptr_handler = plugin->handlers; - ptr_handler; ptr_handler = ptr_handler->next_handler) - { - if ((ptr_handler->type == PLUGIN_HANDLER_KEYBOARD) - && (ptr_handler->handler_args)) - { - handler_found = 1; - plugin->print_server (plugin, " Perl(%s)", - ptr_handler->handler_args); - } - } - if (!handler_found) - plugin->print_server (plugin, " (none)"); - - /* list Perl event handlers */ - plugin->print_server (plugin, ""); - plugin->print_server (plugin, "Perl event handlers:"); - handler_found = 0; - for (ptr_handler = plugin->handlers; - ptr_handler; ptr_handler = ptr_handler->next_handler) - { - if ((ptr_handler->type == PLUGIN_HANDLER_EVENT) - && (ptr_handler->handler_args)) - { - handler_found = 1; - plugin->print_server (plugin, " %s => Perl(%s)", - ptr_handler->event, - ptr_handler->handler_args); - } - } - if (!handler_found) - plugin->print_server (plugin, " (none)"); - - /* List Perl modifiers */ - plugin->print_server (plugin, ""); - plugin->print_server (plugin, "Perl modifiers:"); - modifier_found = 0; - for (ptr_modifier = plugin->modifiers; - ptr_modifier; ptr_modifier = ptr_modifier->next_modifier) - { - modifier_found = 1; - if (ptr_modifier->type == PLUGIN_MODIFIER_IRC_IN) - plugin->print_server (plugin, " IRC(%s, %s) => Perl(%s)", - ptr_modifier->command, - PLUGIN_MODIFIER_IRC_IN_STR, - ptr_modifier->modifier_args); - else if (ptr_modifier->type == PLUGIN_MODIFIER_IRC_USER) - plugin->print_server (plugin, " IRC(%s, %s) => Perl(%s)", - ptr_modifier->command, - PLUGIN_MODIFIER_IRC_USER_STR, - ptr_modifier->modifier_args); - else if (ptr_modifier->type == PLUGIN_MODIFIER_IRC_OUT) - plugin->print_server (plugin, " IRC(%s, %s) => Perl(%s)", - ptr_modifier->command, - PLUGIN_MODIFIER_IRC_OUT_STR, - ptr_modifier->modifier_args); - } - if (!modifier_found) - plugin->print_server (plugin, " (none)"); - break; - - case 1: - if (plugin->strcasecmp (plugin, argv[0], "autoload") == 0) - weechat_script_auto_load (plugin, "perl", weechat_perl_load); - else if (plugin->strcasecmp (plugin, argv[0], "reload") == 0) - { - weechat_perl_unload_all (plugin); - weechat_script_auto_load (plugin, "perl", weechat_perl_load); - } - else if (plugin->strcasecmp (plugin, argv[0], "unload") == 0) - weechat_perl_unload_all (plugin); - break; - case 2: - if (plugin->strcasecmp (plugin, argv[0], "load") == 0) - { - /* load Perl script */ - path_script = weechat_script_search_full_name (plugin, "perl", argv[1]); - weechat_perl_load (plugin, (path_script) ? path_script : argv[1]); - if (path_script) - free (path_script); - } - else if (plugin->strcasecmp (plugin, argv[0], "unload") == 0) - { - /* unload Perl script */ - weechat_perl_unload_name (plugin, argv[1]); - } - else - { - plugin->print_server (plugin, - "Perl error: unknown option for " - "\"perl\" command"); - } - break; - default: - plugin->print_server (plugin, - "Perl error: wrong argument count for \"perl\" command"); - } - - if (argv) - plugin->free_exploded_string (plugin, argv); - - return PLUGIN_RC_OK; -} - -/* - * weechat_plugin_init: initialize Perl plugin - */ - -int -weechat_plugin_init (t_weechat_plugin *plugin) -{ - perl_plugin = plugin; - -#ifdef MULTIPLICITY - plugin->print_server (plugin, "Loading Perl module \"weechat\""); -#else - char *perl_args[] = { "", "-e", "0" }; - - plugin->print_server (plugin, "Loading Perl module \"weechat\" (without multiplicity)"); - - perl_main = perl_alloc (); - - if (!perl_main) - { - plugin->print_server (plugin, - "Perl error: unable to initialize Perl"); - return PLUGIN_RC_KO; - } - - perl_construct (perl_main); - perl_parse (perl_main, weechat_perl_xs_init, 3, perl_args, NULL); - eval_pv (perl_weechat_code, TRUE); -#endif - - plugin->cmd_handler_add (plugin, "perl", - "list/load/unload Perl scripts", - "[load filename] | [autoload] | [reload] | [unload [script]]", - "filename: Perl script (file) to load\n" - "script: script name to unload\n\n" - "Without argument, /perl command lists all loaded Perl scripts.", - "load|autoload|reload|unload %f", - 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 PLUGIN_RC_OK; -} - -/* - * weechat_plugin_end: shutdown Perl interface - */ - -void -weechat_plugin_end (t_weechat_plugin *plugin) -{ - /* unload all scripts */ - weechat_perl_unload_all (plugin); - -#ifndef MULTIPLICITY - /* free perl intepreter */ - if (perl_main) - { - perl_destruct (perl_main); - perl_free (perl_main); - perl_main = NULL; - } -#endif - - perl_plugin->print_server (perl_plugin, - "Perl plugin ended"); -} |