From 4a6ceffb98a0b785494f680d3776c4bfc4052f9e Mon Sep 17 00:00:00 2001 From: "berkeviktor@aol.com" Date: Thu, 24 Feb 2011 04:14:30 +0100 Subject: add xchat r1489 --- plugins/perl/perl.c | 1522 +++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 1522 insertions(+) create mode 100644 plugins/perl/perl.c (limited to 'plugins/perl/perl.c') diff --git a/plugins/perl/perl.c b/plugins/perl/perl.c new file mode 100644 index 00000000..a29ce65a --- /dev/null +++ b/plugins/perl/perl.c @@ -0,0 +1,1522 @@ +/* X-Chat 2.0 PERL Plugin + * Copyright (C) 1998-2002 Peter Zelezny. + * + * 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 +#include +#include +#include +#include +#include +#include +#ifdef ENABLE_NLS +#include +#endif +#ifdef WIN32 +#include +#endif + +#undef PACKAGE +#include "../../config.h" /* for #define OLD_PERL */ +#include "xchat-plugin.h" + +static xchat_plugin *ph; /* plugin handle */ + +static int perl_load_file (char *script_name); + +#ifdef WIN32 +/* STRINGIFY is from perl's CORE/config.h */ +#ifndef PERL_REQUIRED_VERSION + #define PERL_REQUIRED_VERSION STRINGIFY(PERL_REVISION) "." STRINGIFY(PERL_VERSION) +#endif + +#ifndef PERL_DLL + #define PERL_DLL "perl" STRINGIFY(PERL_REVISION) STRINGIFY(PERL_VERSION) ".dll" +#endif + +static DWORD +child (char *str) +{ + MessageBoxA (0, str, "Perl DLL Error", + MB_OK | MB_ICONHAND | MB_SETFOREGROUND | MB_TASKMODAL); + return 0; +} + +static void +thread_mbox (char *str) +{ + DWORD tid; + + CloseHandle (CreateThread (NULL, 0, (LPTHREAD_START_ROUTINE) child, + str, 0, &tid)); +} + +#endif + +/* leave this before XSUB.h, to avoid readdir() being redefined */ + +static void +perl_auto_load_from_path (const char *path) +{ + DIR *dir; + struct dirent *ent; + + dir = opendir (path); + if (dir) { + while ((ent = readdir (dir))) { + int len = strlen (ent->d_name); + if (len > 3 && strcasecmp (".pl", ent->d_name + len - 3) == 0) { + char *file = malloc (len + strlen (path) + 2); + sprintf (file, "%s/%s", path, ent->d_name); + perl_load_file (file); + free (file); + } + } + closedir (dir); + } +} + +static int +perl_auto_load (void *unused) +{ + const char *xdir; + char *sub_dir; +#ifdef WIN32 + int copied = 0; + char *slash = NULL; +#endif + + /* get the dir in local filesystem encoding (what opendir() expects!) */ + xdir = xchat_get_info (ph, "xchatdirfs"); + if (!xdir) /* xchatdirfs is new for 2.0.9, will fail on older */ + xdir = xchat_get_info (ph, "xchatdir"); + + /* autoload from ~/.xchat2/ or ${APPDATA}\X-Chat 2\ on win32 */ + perl_auto_load_from_path (xdir); + + sub_dir = malloc (strlen (xdir) + 9); + strcpy (sub_dir, xdir); + strcat (sub_dir, "/plugins"); + perl_auto_load_from_path (sub_dir); + free (sub_dir); + +#ifdef WIN32 + /* autoload from C:\program files\xchat\plugins\ */ + sub_dir = malloc (1025 + 9); + copied = GetModuleFileName( 0, sub_dir, 1024 ); + sub_dir[copied] = '\0'; + slash = strrchr( sub_dir, '\\' ); + if( slash != NULL ) { + *slash = '\0'; + } + perl_auto_load_from_path ( strncat (sub_dir, "\\plugins", 9)); + free (sub_dir); +#endif + return 0; +} + +#include +#define WIN32IOP_H +#include +#include + +typedef struct +{ + SV *callback; + SV *userdata; + xchat_hook *hook; /* required for timers */ + xchat_context *ctx; /* allow timers to remember their context */ + SV *package; /* need to track the package name when removing hooks + by returning REMOVE + */ + unsigned int depth; +} HookData; + +static PerlInterpreter *my_perl = NULL; +extern void boot_DynaLoader (pTHX_ CV * cv); + +/* + this is used for autoload and shutdown callbacks +*/ +static int +execute_perl (SV * function, char *args) +{ + + int count, ret_value = 1; + + dSP; + ENTER; + SAVETMPS; + + PUSHMARK (SP); + XPUSHs (sv_2mortal (newSVpv (args, 0))); + PUTBACK; + + count = call_sv (function, G_EVAL | G_SCALAR); + SPAGAIN; + if (SvTRUE (ERRSV)) { + xchat_printf(ph, "Perl error: %s\n", SvPV_nolen (ERRSV)); + if (!SvOK (POPs)) {} /* remove undef from the top of the stack */ + } else if (count != 1) { + xchat_printf (ph, "Perl error: expected 1 value from %s, " + "got: %d\n", SvPV_nolen (function), count); + } else { + ret_value = POPi; + } + PUTBACK; + FREETMPS; + LEAVE; + + return ret_value; +} + +static char * +get_filename (char *word[], char *word_eol[]) +{ + int len; + char *file; + + len = strlen (word[2]); + + /* if called as /load "filename.pl" the only difference between word and + * word_eol will be the two quotes + */ + + if (strchr (word[2], ' ') != NULL + || (strlen (word_eol[2]) - strlen(word[2])) == 2 ) + { + file = word[2]; + } else { + file = word_eol[2]; + } + + len = strlen (file); + + if (len > 3 && strncasecmp (".pl", file + len - 3, 3) == 0) { + return file; + } + + return NULL; +} + +static SV * +list_item_to_sv ( xchat_list *list, const char *const *fields ) +{ + HV *hash = newHV(); + SV *field_value; + const char *field; + int field_index = 0; + const char *field_name; + int name_len; + + while (fields[field_index] != NULL) { + field_name = fields[field_index] + 1; + name_len = strlen (field_name); + + switch (fields[field_index][0]) { + case 's': + field = xchat_list_str (ph, list, field_name); + if (field != NULL) { + field_value = newSVpvn (field, strlen (field)); + } else { + field_value = &PL_sv_undef; + } + break; + case 'p': + field_value = newSViv (PTR2IV (xchat_list_str (ph, list, + field_name))); + break; + case 'i': + field_value = newSVuv (xchat_list_int (ph, list, field_name)); + break; + case 't': + field_value = newSVnv (xchat_list_time (ph, list, field_name)); + break; + default: + field_value = &PL_sv_undef; + } + hv_store (hash, field_name, name_len, field_value, 0); + field_index++; + } + return sv_2mortal (newRV_noinc ((SV *) hash)); +} + +static AV * +array2av (char *array[]) +{ + int count = 0; + SV *temp = NULL; + AV *av = newAV(); + sv_2mortal ((SV *)av); + + for ( + count = 1; + count < 32 && array[count] != NULL && array[count][0] != 0; + count++ + ) { + temp = newSVpv (array[count], 0); + SvUTF8_on (temp); + av_push (av, temp); + } + + return av; +} + +static int +fd_cb (int fd, int flags, void *userdata) +{ + HookData *data = (HookData *) userdata; + int retVal = 0; + int count = 0; + + dSP; + ENTER; + SAVETMPS; + + PUSHMARK (SP); + XPUSHs (data->userdata); + PUTBACK; + + count = call_sv (data->callback, G_EVAL); + SPAGAIN; + + if (SvTRUE (ERRSV)) { + xchat_printf (ph, "Error in fd callback %s", SvPV_nolen (ERRSV)); + if (!SvOK (POPs)) {} /* remove undef from the top of the stack */ + retVal = XCHAT_EAT_ALL; + } else { + if (count != 1) { + xchat_print (ph, "Fd handler should only return 1 value."); + retVal = XCHAT_EAT_NONE; + } else { + retVal = POPi; + if (retVal == 0) { + /* if 0 is returned, the fd is going to get unhooked */ + PUSHMARK (SP); + XPUSHs (sv_2mortal (newSViv (PTR2IV (data->hook)))); + PUTBACK; + + call_pv ("Xchat::unhook", G_EVAL); + SPAGAIN; + + SvREFCNT_dec (data->callback); + + if (data->userdata) { + SvREFCNT_dec (data->userdata); + } + free (data); + } + } + + } + + PUTBACK; + FREETMPS; + LEAVE; + + return retVal; +} + +static int +timer_cb (void *userdata) +{ + HookData *data = (HookData *) userdata; + int retVal = 0; + int count = 0; + + dSP; + ENTER; + SAVETMPS; + + PUSHMARK (SP); + XPUSHs (data->userdata); + PUTBACK; + + if (data->ctx) { + xchat_set_context (ph, data->ctx); + } + count = call_sv (data->callback, G_EVAL); + SPAGAIN; + + if (SvTRUE (ERRSV)) { + xchat_printf (ph, "Error in timer callback %s", SvPV_nolen (ERRSV)); + if (!SvOK (POPs)) {} /* remove undef from the top of the stack */ + retVal = XCHAT_EAT_ALL; + } else { + if (count != 1) { + xchat_print (ph, "Timer handler should only return 1 value."); + retVal = XCHAT_EAT_NONE; + } else { + retVal = POPi; + if (retVal == 0) { + /* if 0 is return the timer is going to get unhooked */ + PUSHMARK (SP); + XPUSHs (sv_2mortal (newSViv (PTR2IV (data->hook)))); + XPUSHs (sv_mortalcopy (data->package)); + PUTBACK; + + call_pv ("Xchat::unhook", G_EVAL); + SPAGAIN; + } + } + + } + + PUTBACK; + FREETMPS; + LEAVE; + + return retVal; +} + +static int +server_cb (char *word[], char *word_eol[], void *userdata) +{ + HookData *data = (HookData *) userdata; + int retVal = 0; + int count = 0; + + dSP; + ENTER; + SAVETMPS; + + if (data->depth) + return XCHAT_EAT_NONE; + + /* xchat_printf (ph, */ + /* "Recieved %d words in server callback", av_len (wd)); */ + PUSHMARK (SP); + XPUSHs (newRV_noinc ((SV *) array2av (word))); + XPUSHs (newRV_noinc ((SV *) array2av (word_eol))); + XPUSHs (data->userdata); + PUTBACK; + + data->depth++; + count = call_sv (data->callback, G_EVAL); + data->depth--; + SPAGAIN; + if (SvTRUE (ERRSV)) { + xchat_printf (ph, "Error in server callback %s", SvPV_nolen (ERRSV)); + if (!SvOK (POPs)) {} /* remove undef from the top of the stack */ + retVal = XCHAT_EAT_NONE; + } else { + if (count != 1) { + xchat_print (ph, "Server handler should only return 1 value."); + retVal = XCHAT_EAT_NONE; + } else { + retVal = POPi; + } + + } + + PUTBACK; + FREETMPS; + LEAVE; + + return retVal; +} + +static int +command_cb (char *word[], char *word_eol[], void *userdata) +{ + HookData *data = (HookData *) userdata; + int retVal = 0; + int count = 0; + + dSP; + ENTER; + SAVETMPS; + + if (data->depth) + return XCHAT_EAT_NONE; + + /* xchat_printf (ph, "Recieved %d words in command callback", */ + /* av_len (wd)); */ + PUSHMARK (SP); + XPUSHs (newRV_noinc ((SV *) array2av (word))); + XPUSHs (newRV_noinc ((SV *) array2av (word_eol))); + XPUSHs (data->userdata); + PUTBACK; + + data->depth++; + count = call_sv (data->callback, G_EVAL); + data->depth--; + SPAGAIN; + if (SvTRUE (ERRSV)) { + xchat_printf (ph, "Error in command callback %s", SvPV_nolen (ERRSV)); + if (!SvOK (POPs)) {} /* remove undef from the top of the stack */ + retVal = XCHAT_EAT_XCHAT; + } else { + if (count != 1) { + xchat_print (ph, "Command handler should only return 1 value."); + retVal = XCHAT_EAT_NONE; + } else { + retVal = POPi; + } + + } + + PUTBACK; + FREETMPS; + LEAVE; + + return retVal; +} + +static int +print_cb (char *word[], void *userdata) +{ + + HookData *data = (HookData *) userdata; + SV *temp = NULL; + int retVal = 0; + int count = 1; + int last_index = 31; + /* must be initialized after SAVETMPS */ + AV *wd = NULL; + + dSP; + ENTER; + SAVETMPS; + + if (data->depth) + return XCHAT_EAT_NONE; + + wd = newAV (); + sv_2mortal ((SV *) wd); + + /* need to scan backwards to find the index of the last element since some + events such as "DCC Timeout" can have NULL elements in between non NULL + elements */ + + while (last_index >= 0 + && (word[last_index] == NULL || word[last_index][0] == 0)) { + last_index--; + } + + for (count = 1; count <= last_index; count++) { + if (word[count] == NULL) { + av_push (wd, &PL_sv_undef); + } else if (word[count][0] == 0) { + av_push (wd, newSVpvn ("",0)); + } else { + temp = newSVpv (word[count], 0); + SvUTF8_on (temp); + av_push (wd, temp); + } + } + + /*xchat_printf (ph, "Recieved %d words in print callback", av_len (wd)+1); */ + PUSHMARK (SP); + XPUSHs (newRV_noinc ((SV *) wd)); + XPUSHs (data->userdata); + PUTBACK; + + data->depth++; + count = call_sv (data->callback, G_EVAL); + data->depth--; + SPAGAIN; + if (SvTRUE (ERRSV)) { + xchat_printf (ph, "Error in print callback %s", SvPV_nolen (ERRSV)); + if (!SvOK (POPs)) {} /* remove undef from the top of the stack */ + retVal = XCHAT_EAT_NONE; + } else { + if (count != 1) { + xchat_print (ph, "Print handler should only return 1 value."); + retVal = XCHAT_EAT_NONE; + } else { + retVal = POPi; + } + + } + + PUTBACK; + FREETMPS; + LEAVE; + + return retVal; +} + +/* custom IRC perl functions for scripting */ + +/* Xchat::Internal::register (scriptname, version, desc, shutdowncallback, filename) + * + */ + +static +XS (XS_Xchat_register) +{ + char *name, *version, *desc, *filename; + void *gui_entry; + dXSARGS; + if (items != 4) { + xchat_printf (ph, + "Usage: Xchat::Internal::register(scriptname, version, desc, filename)"); + } else { + name = SvPV_nolen (ST (0)); + version = SvPV_nolen (ST (1)); + desc = SvPV_nolen (ST (2)); + filename = SvPV_nolen (ST (3)); + + gui_entry = xchat_plugingui_add (ph, filename, name, + desc, version, NULL); + + XSRETURN_IV (PTR2IV (gui_entry)); + + } +} + + +/* Xchat::print(output) */ +static +XS (XS_Xchat_print) +{ + + char *text = NULL; + + dXSARGS; + if (items != 1) { + xchat_print (ph, "Usage: Xchat::Internal::print(text)"); + } else { + text = SvPV_nolen (ST (0)); + xchat_print (ph, text); + } + XSRETURN_EMPTY; +} + +static +XS (XS_Xchat_emit_print) +{ + char *event_name; + int RETVAL; + int count; + + dXSARGS; + if (items < 1) { + xchat_print (ph, "Usage: Xchat::emit_print(event_name, ...)"); + } else { + event_name = (char *) SvPV_nolen (ST (0)); + RETVAL = 0; + + /* we need to figure out the number of defined values passed in */ + for (count = 0; count < items; count++) { + if (!SvOK (ST (count))) { + break; + } + } + + switch (count) { + case 1: + RETVAL = xchat_emit_print (ph, event_name, NULL); + break; + case 2: + RETVAL = xchat_emit_print (ph, event_name, + SvPV_nolen (ST (1)), NULL); + break; + case 3: + RETVAL = xchat_emit_print (ph, event_name, + SvPV_nolen (ST (1)), + SvPV_nolen (ST (2)), NULL); + break; + case 4: + RETVAL = xchat_emit_print (ph, event_name, + SvPV_nolen (ST (1)), + SvPV_nolen (ST (2)), + SvPV_nolen (ST (3)), NULL); + break; + case 5: + RETVAL = xchat_emit_print (ph, event_name, + SvPV_nolen (ST (1)), + SvPV_nolen (ST (2)), + SvPV_nolen (ST (3)), + SvPV_nolen (ST (4)), NULL); + break; + + } + + XSRETURN_IV (RETVAL); + } +} + +static +XS (XS_Xchat_send_modes) +{ + AV *p_targets = NULL; + int modes_per_line = 0; + char sign; + char mode; + int i = 0; + const char **targets; + int target_count = 0; + SV **elem; + + dXSARGS; + if (items < 3 || items > 4) { + xchat_print (ph, + "Usage: Xchat::send_modes( targets, sign, mode, modes_per_line)" + ); + } else { + if (SvROK (ST (0))) { + p_targets = (AV*) SvRV (ST (0)); + target_count = av_len (p_targets) + 1; + targets = malloc (target_count * sizeof (char *)); + for (i = 0; i < target_count; i++ ) { + elem = av_fetch (p_targets, i, 0); + + if (elem != NULL) { + targets[i] = SvPV_nolen (*elem); + } else { + targets[i] = ""; + } + } + } else{ + targets = malloc (sizeof (char *)); + targets[0] = SvPV_nolen (ST (0)); + target_count = 1; + } + + if (target_count == 0) { + XSRETURN_EMPTY; + } + + sign = (SvPV_nolen (ST (1)))[0]; + mode = (SvPV_nolen (ST (2)))[0]; + + if (items == 4 ) { + modes_per_line = (int) SvIV (ST (3)); + } + + xchat_send_modes (ph, targets, target_count, modes_per_line, sign, mode); + free (targets); + } +} +static +XS (XS_Xchat_get_info) +{ + SV *temp = NULL; + dXSARGS; + if (items != 1) { + xchat_print (ph, "Usage: Xchat::get_info(id)"); + } else { + SV *id = ST (0); + const char *RETVAL; + + RETVAL = xchat_get_info (ph, SvPV_nolen (id)); + if (RETVAL == NULL) { + XSRETURN_UNDEF; + } + + if (!strncmp ("win_ptr", SvPV_nolen (id), 7) + || !strncmp ("gtkwin_ptr", SvPV_nolen (id), 10)) + { + XSRETURN_IV (PTR2IV (RETVAL)); + } else { + + if ( + !strncmp ("libdirfs", SvPV_nolen (id), 8) || + !strncmp ("xchatdirfs", SvPV_nolen (id), 10) + ) { + XSRETURN_PV (RETVAL); + } else { + temp = newSVpv (RETVAL, 0); + SvUTF8_on (temp); + PUSHMARK (SP); + XPUSHs (sv_2mortal (temp)); + PUTBACK; + } + } + } +} + +static +XS (XS_Xchat_context_info) +{ + const char *const *fields; + dXSARGS; + + if (items > 0 ) { + xchat_print (ph, "Usage: Xchat::Internal::context_info()"); + } + fields = xchat_list_fields (ph, "channels" ); + XPUSHs (list_item_to_sv (NULL, fields)); + XSRETURN (1); +} + +static +XS (XS_Xchat_get_prefs) +{ + const char *str; + int integer; + SV *temp = NULL; + dXSARGS; + if (items != 1) { + xchat_print (ph, "Usage: Xchat::get_prefs(name)"); + } else { + + + switch (xchat_get_prefs (ph, SvPV_nolen (ST (0)), &str, &integer)) { + case 0: + XSRETURN_UNDEF; + break; + case 1: + temp = newSVpv (str, 0); + SvUTF8_on (temp); + SP -= items; + sp = mark; + XPUSHs (sv_2mortal (temp)); + PUTBACK; + break; + case 2: + XSRETURN_IV (integer); + break; + case 3: + if (integer) { + XSRETURN_YES; + } else { + XSRETURN_NO; + } + } + } +} + +/* Xchat::Internal::hook_server(name, priority, callback, userdata) */ +static +XS (XS_Xchat_hook_server) +{ + + char *name; + int pri; + SV *callback; + SV *userdata; + xchat_hook *hook; + HookData *data; + + dXSARGS; + + if (items != 4) { + xchat_print (ph, + "Usage: Xchat::Internal::hook_server(name, priority, callback, userdata)"); + } else { + name = SvPV_nolen (ST (0)); + pri = (int) SvIV (ST (1)); + callback = ST (2); + userdata = ST (3); + data = NULL; + data = malloc (sizeof (HookData)); + if (data == NULL) { + XSRETURN_UNDEF; + } + + data->callback = sv_mortalcopy (callback); + SvREFCNT_inc (data->callback); + data->userdata = sv_mortalcopy (userdata); + SvREFCNT_inc (data->userdata); + data->depth = 0; + data->package = NULL; + hook = xchat_hook_server (ph, name, pri, server_cb, data); + + XSRETURN_IV (PTR2IV (hook)); + } +} + +/* Xchat::Internal::hook_command(name, priority, callback, help_text, userdata) */ +static +XS (XS_Xchat_hook_command) +{ + char *name; + int pri; + SV *callback; + char *help_text = NULL; + SV *userdata; + xchat_hook *hook; + HookData *data; + + dXSARGS; + + if (items != 5) { + xchat_print (ph, + "Usage: Xchat::Internal::hook_command(name, priority, callback, help_text, userdata)"); + } else { + name = SvPV_nolen (ST (0)); + pri = (int) SvIV (ST (1)); + callback = ST (2); + + /* leave the help text has NULL if the help text is undefined to avoid + * overriding the default help message for builtin commands */ + if (SvOK(ST (3))) { + help_text = SvPV_nolen (ST (3)); + } + + userdata = ST (4); + data = NULL; + + data = malloc (sizeof (HookData)); + if (data == NULL) { + XSRETURN_UNDEF; + } + + data->callback = sv_mortalcopy (callback); + SvREFCNT_inc (data->callback); + data->userdata = sv_mortalcopy (userdata); + SvREFCNT_inc (data->userdata); + data->depth = 0; + data->package = NULL; + hook = xchat_hook_command (ph, name, pri, command_cb, help_text, data); + + XSRETURN_IV (PTR2IV (hook)); + } + +} + +/* Xchat::Internal::hook_print(name, priority, callback, [userdata]) */ +static +XS (XS_Xchat_hook_print) +{ + + char *name; + int pri; + SV *callback; + SV *userdata; + xchat_hook *hook; + HookData *data; + dXSARGS; + if (items != 4) { + xchat_print (ph, + "Usage: Xchat::Internal::hook_print(name, priority, callback, userdata)"); + } else { + name = SvPV_nolen (ST (0)); + pri = (int) SvIV (ST (1)); + callback = ST (2); + data = NULL; + userdata = ST (3); + + data = malloc (sizeof (HookData)); + if (data == NULL) { + XSRETURN_UNDEF; + } + + data->callback = sv_mortalcopy (callback); + SvREFCNT_inc (data->callback); + data->userdata = sv_mortalcopy (userdata); + SvREFCNT_inc (data->userdata); + data->depth = 0; + data->package = NULL; + hook = xchat_hook_print (ph, name, pri, print_cb, data); + + XSRETURN_IV (PTR2IV (hook)); + } +} + +/* Xchat::Internal::hook_timer(timeout, callback, userdata) */ +static +XS (XS_Xchat_hook_timer) +{ + int timeout; + SV *callback; + SV *userdata; + xchat_hook *hook; + SV *package; + HookData *data; + + dXSARGS; + + if (items != 4) { + xchat_print (ph, + "Usage: Xchat::Internal::hook_timer(timeout, callback, userdata, package)"); + } else { + timeout = (int) SvIV (ST (0)); + callback = ST (1); + data = NULL; + userdata = ST (2); + package = ST (3); + + data = malloc (sizeof (HookData)); + if (data == NULL) { + XSRETURN_UNDEF; + } + + data->callback = sv_mortalcopy (callback); + SvREFCNT_inc (data->callback); + data->userdata = sv_mortalcopy (userdata); + SvREFCNT_inc (data->userdata); + data->ctx = xchat_get_context (ph); + data->package = sv_mortalcopy (package); + SvREFCNT_inc (data->package); + hook = xchat_hook_timer (ph, timeout, timer_cb, data); + data->hook = hook; + + XSRETURN_IV (PTR2IV (hook)); + } +} + +/* Xchat::Internal::hook_fd(fd, callback, flags, userdata) */ +static +XS (XS_Xchat_hook_fd) +{ + int fd; + SV *callback; + int flags; + SV *userdata; + xchat_hook *hook; + HookData *data; + + dXSARGS; + + if (items != 4) { + xchat_print (ph, + "Usage: Xchat::Internal::hook_fd(fd, callback, flags, userdata)"); + } else { + fd = (int) SvIV (ST (0)); + callback = ST (1); + flags = (int) SvIV (ST (2)); + userdata = ST (3); + data = NULL; + +#ifdef WIN32 + if ((flags & XCHAT_FD_NOTSOCKET) == 0) { + /* this _get_osfhandle if from win32iop.h in the perl distribution, + * not the one provided by Windows + */ + fd = _get_osfhandle(fd); + if (fd < 0) { + xchat_print(ph, "Invalid file descriptor"); + XSRETURN_UNDEF; + } + } +#endif + + data = malloc (sizeof (HookData)); + if (data == NULL) { + XSRETURN_UNDEF; + } + + data->callback = sv_mortalcopy (callback); + SvREFCNT_inc (data->callback); + data->userdata = sv_mortalcopy (userdata); + SvREFCNT_inc (data->userdata); + data->package = NULL; + hook = xchat_hook_fd (ph, fd, flags, fd_cb, data); + data->hook = hook; + + XSRETURN_IV (PTR2IV (hook)); + } +} + +static +XS (XS_Xchat_unhook) +{ + xchat_hook *hook; + HookData *userdata; + int retCount = 0; + dXSARGS; + if (items != 1) { + xchat_print (ph, "Usage: Xchat::unhook(hook)"); + } else { + hook = INT2PTR (xchat_hook *, SvUV (ST (0))); + userdata = (HookData *) xchat_unhook (ph, hook); + + if (userdata != NULL) { + if (userdata->callback != NULL) { + SvREFCNT_dec (userdata->callback); + } + + if (userdata->userdata != NULL) { + XPUSHs (sv_mortalcopy (userdata->userdata)); + SvREFCNT_dec (userdata->userdata); + retCount = 1; + } + + if (userdata->package != NULL) { + SvREFCNT_dec (userdata->package); + } + free (userdata); + } + XSRETURN (retCount); + } + XSRETURN_EMPTY; +} + +/* Xchat::Internal::command(command) */ +static +XS (XS_Xchat_command) +{ + char *cmd = NULL; + + dXSARGS; + if (items != 1) { + xchat_print (ph, "Usage: Xchat::Internal::command(command)"); + } else { + cmd = SvPV_nolen (ST (0)); + xchat_command (ph, cmd); + + } + XSRETURN_EMPTY; +} + +static +XS (XS_Xchat_find_context) +{ + char *server = NULL; + char *chan = NULL; + xchat_context *RETVAL; + + dXSARGS; + if (items > 2) + xchat_print (ph, "Usage: Xchat::find_context ([channel, [server]])"); + { + + switch (items) { + case 0: /* no server name and no channel name */ + /* nothing to do, server and chan are already NULL */ + break; + case 1: /* channel name only */ + /* change channel value only if it is true or 0 */ + /* otherwise leave it as null */ + if (SvTRUE (ST (0)) || SvNIOK (ST (0))) { + chan = SvPV_nolen (ST (0)); + /* xchat_printf( ph, "XSUB - find_context( %s, NULL )", chan ); */ + } + /* else { xchat_print( ph, "XSUB - find_context( NULL, NULL )" ); } */ + /* chan is already NULL */ + break; + case 2: /* server and channel */ + /* change channel value only if it is true or 0 */ + /* otherwise leave it as NULL */ + if (SvTRUE (ST (0)) || SvNIOK (ST (0))) { + chan = SvPV_nolen (ST (0)); + /* xchat_printf( ph, "XSUB - find_context( %s, NULL )", SvPV_nolen(ST(0) )); */ + } + + /* else { xchat_print( ph, "XSUB - 2 arg NULL chan" ); } */ + /* change server value only if it is true or 0 */ + /* otherwise leave it as NULL */ + if (SvTRUE (ST (1)) || SvNIOK (ST (1))) { + server = SvPV_nolen (ST (1)); + /* xchat_printf( ph, "XSUB - find_context( NULL, %s )", SvPV_nolen(ST(1) )); */ + } + /* else { xchat_print( ph, "XSUB - 2 arg NULL server" ); } */ + break; + } + + RETVAL = xchat_find_context (ph, server, chan); + if (RETVAL != NULL) { + /* xchat_print (ph, "XSUB - context found"); */ + XSRETURN_IV (PTR2IV (RETVAL)); + } else { + /* xchat_print (ph, "XSUB - context not found"); */ + XSRETURN_UNDEF; + } + } +} + +static +XS (XS_Xchat_get_context) +{ + dXSARGS; + if (items != 0) { + xchat_print (ph, "Usage: Xchat::get_context()"); + } else { + XSRETURN_IV (PTR2IV (xchat_get_context (ph))); + } +} + +static +XS (XS_Xchat_set_context) +{ + xchat_context *ctx; + dXSARGS; + if (items != 1) { + xchat_print (ph, "Usage: Xchat::set_context(ctx)"); + } else { + ctx = INT2PTR (xchat_context *, SvUV (ST (0))); + XSRETURN_IV ((IV) xchat_set_context (ph, ctx)); + } +} + +static +XS (XS_Xchat_nickcmp) +{ + dXSARGS; + if (items != 2) { + xchat_print (ph, "Usage: Xchat::nickcmp(s1, s2)"); + } else { + XSRETURN_IV ((IV) xchat_nickcmp (ph, SvPV_nolen (ST (0)), + SvPV_nolen (ST (1)))); + } +} + +static +XS (XS_Xchat_get_list) +{ + SV *name; + xchat_list *list; + const char *const *fields; + int count = 0; /* return value for scalar context */ + dXSARGS; + + if (items != 1) { + xchat_print (ph, "Usage: Xchat::get_list(name)"); + } else { + SP -= items; /*remove the argument list from the stack */ + + name = ST (0); + + list = xchat_list_get (ph, SvPV_nolen (name)); + + if (list == NULL) { + XSRETURN_EMPTY; + } + + if (GIMME_V == G_SCALAR) { + while (xchat_list_next (ph, list)) { + count++; + } + xchat_list_free (ph, list); + XSRETURN_IV ((IV) count); + } + + fields = xchat_list_fields (ph, SvPV_nolen (name)); + while (xchat_list_next (ph, list)) { + XPUSHs (list_item_to_sv (list, fields)); + } + xchat_list_free (ph, list); + + PUTBACK; + return; + } +} + +static +XS (XS_Xchat_Embed_plugingui_remove) +{ + void *gui_entry; + dXSARGS; + if (items != 1) { + xchat_print (ph, "Usage: Xchat::Embed::plugingui_remove(handle)"); + } else { + gui_entry = INT2PTR (void *, SvUV (ST (0))); + xchat_plugingui_remove (ph, gui_entry); + } + XSRETURN_EMPTY; +} + +/* xs_init is the second argument perl_parse. As the name hints, it + initializes XS subroutines (see the perlembed manpage) */ +static void +xs_init (pTHX) +{ + HV *stash; + SV *version; + /* This one allows dynamic loading of perl modules in perl + scripts by the 'use perlmod;' construction */ + newXS ("DynaLoader::boot_DynaLoader", boot_DynaLoader, __FILE__); + /* load up all the custom IRC perl functions */ + newXS ("Xchat::Internal::register", XS_Xchat_register, __FILE__); + newXS ("Xchat::Internal::hook_server", XS_Xchat_hook_server, __FILE__); + newXS ("Xchat::Internal::hook_command", XS_Xchat_hook_command, __FILE__); + newXS ("Xchat::Internal::hook_print", XS_Xchat_hook_print, __FILE__); + newXS ("Xchat::Internal::hook_timer", XS_Xchat_hook_timer, __FILE__); + newXS ("Xchat::Internal::hook_fd", XS_Xchat_hook_fd, __FILE__); + newXS ("Xchat::Internal::unhook", XS_Xchat_unhook, __FILE__); + newXS ("Xchat::Internal::print", XS_Xchat_print, __FILE__); + newXS ("Xchat::Internal::command", XS_Xchat_command, __FILE__); + newXS ("Xchat::Internal::set_context", XS_Xchat_set_context, __FILE__); + newXS ("Xchat::Internal::get_info", XS_Xchat_get_info, __FILE__); + newXS ("Xchat::Internal::context_info", XS_Xchat_context_info, __FILE__); + newXS ("Xchat::Internal::get_list", XS_Xchat_get_list, __FILE__); + + newXS ("Xchat::find_context", XS_Xchat_find_context, __FILE__); + newXS ("Xchat::get_context", XS_Xchat_get_context, __FILE__); + newXS ("Xchat::get_prefs", XS_Xchat_get_prefs, __FILE__); + newXS ("Xchat::emit_print", XS_Xchat_emit_print, __FILE__); + newXS ("Xchat::send_modes", XS_Xchat_send_modes, __FILE__); + newXS ("Xchat::nickcmp", XS_Xchat_nickcmp, __FILE__); + + newXS ("Xchat::Embed::plugingui_remove", XS_Xchat_Embed_plugingui_remove, + __FILE__); + + stash = get_hv ("Xchat::", TRUE); + if (stash == NULL) { + exit (1); + } + + newCONSTSUB (stash, "PRI_HIGHEST", newSViv (XCHAT_PRI_HIGHEST)); + newCONSTSUB (stash, "PRI_HIGH", newSViv (XCHAT_PRI_HIGH)); + newCONSTSUB (stash, "PRI_NORM", newSViv (XCHAT_PRI_NORM)); + newCONSTSUB (stash, "PRI_LOW", newSViv (XCHAT_PRI_LOW)); + newCONSTSUB (stash, "PRI_LOWEST", newSViv (XCHAT_PRI_LOWEST)); + + newCONSTSUB (stash, "EAT_NONE", newSViv (XCHAT_EAT_NONE)); + newCONSTSUB (stash, "EAT_XCHAT", newSViv (XCHAT_EAT_XCHAT)); + newCONSTSUB (stash, "EAT_PLUGIN", newSViv (XCHAT_EAT_PLUGIN)); + newCONSTSUB (stash, "EAT_ALL", newSViv (XCHAT_EAT_ALL)); + newCONSTSUB (stash, "FD_READ", newSViv (XCHAT_FD_READ)); + newCONSTSUB (stash, "FD_WRITE", newSViv (XCHAT_FD_WRITE)); + newCONSTSUB (stash, "FD_EXCEPTION", newSViv (XCHAT_FD_EXCEPTION)); + newCONSTSUB (stash, "FD_NOTSOCKET", newSViv (XCHAT_FD_NOTSOCKET)); + newCONSTSUB (stash, "KEEP", newSViv (1)); + newCONSTSUB (stash, "REMOVE", newSViv (0)); + + version = get_sv( "Xchat::VERSION", 1 ); + sv_setpv( version, PACKAGE_VERSION ); +} + +static void +perl_init (void) +{ + int warn; + int arg_count; + char *perl_args[] = { "", "-e", "0", "-w" }; + char *env[] = { "" }; + static const char xchat_definitions[] = { + /* Redefine the $SIG{__WARN__} handler to have XChat + printing warnings in the main window. (TheHobbit) */ +#include "xchat.pm.h" + }; +#ifdef OLD_PERL + static const char irc_definitions[] = { +#include "irc.pm.h" + }; +#endif +#ifdef ENABLE_NLS + + /* Problem is, dynamicaly loaded modules check out the $] + var. It appears that in the embedded interpreter we get + 5,00503 as soon as the LC_NUMERIC locale calls for a comma + instead of a point in separating integer and decimal + parts. I realy can't understant why... The following + appears to be an awful workaround... But it'll do until I + (or someone else :)) found the "right way" to solve this + nasty problem. (TheHobbit ) */ + + setlocale (LC_NUMERIC, "C"); + +#endif + + warn = 0; + xchat_get_prefs (ph, "perl_warnings", NULL, &warn); + arg_count = warn ? 4 : 3; + + PERL_SYS_INIT3 (&arg_count, (char ***)&perl_args, (char ***)&env); + my_perl = perl_alloc (); + perl_construct (my_perl); + PL_exit_flags |= PERL_EXIT_DESTRUCT_END; + perl_parse (my_perl, xs_init, arg_count, perl_args, (char **)NULL); + + /* + Now initialising the perl interpreter by loading the + perl_definition array. + */ + + eval_pv (xchat_definitions, TRUE); +#ifdef OLD_PERL + eval_pv (irc_definitions, TRUE); +#endif + +} + + +static int +perl_load_file (char *filename) +{ +#ifdef WIN32 + static HMODULE lib = NULL; + + if (!lib) { + lib = LoadLibraryA (PERL_DLL); + if (!lib) { + if (GetLastError () == ERROR_BAD_EXE_FORMAT) + /* http://forum.xchat.org/viewtopic.php?t=3277 */ + thread_mbox ("Cannot use this " PERL_DLL "\n\n" + "32-bit ActivePerl is required."); + else { + /* a lot of people install this old version */ + lib = LoadLibraryA ("perl56.dll"); + if (lib) { + FreeLibrary (lib); + lib = NULL; + thread_mbox ("Cannot open " PERL_DLL "\n\n" + "You must have ActivePerl " PERL_REQUIRED_VERSION " installed in order to\n" + "run perl scripts.\n\n" + "I have found Perl 5.6, but that is too old."); + } else { + thread_mbox ("Cannot open " PERL_DLL "\n\n" + "You must have ActivePerl " PERL_REQUIRED_VERSION " installed in order to\n" + "run perl scripts.\n\n" + "http://www.activestate.com/ActivePerl/\n\n" + "Make sure perl's bin directory is in your PATH."); + } + } + /* failure */ + return FALSE; + } + + /* success */ + FreeLibrary (lib); + } +#endif + + if (my_perl == NULL) { + perl_init (); + } + + return execute_perl (sv_2mortal (newSVpv ("Xchat::Embed::load", 0)), + filename); + +} + +static void +perl_end (void) +{ + + if (my_perl != NULL) { + execute_perl (sv_2mortal (newSVpv ("Xchat::Embed::unload_all", 0)), ""); + PL_perl_destruct_level = 1; + perl_destruct (my_perl); + perl_free (my_perl); + PERL_SYS_TERM(); + my_perl = NULL; + } + +} + +static int +perl_command_unloadall (char *word[], char *word_eol[], void *userdata) +{ + if (my_perl != NULL) { + execute_perl (sv_2mortal (newSVpv ("Xchat::Embed::unload_all", 0)), ""); + return XCHAT_EAT_XCHAT; + } + + return XCHAT_EAT_XCHAT; +} + +static int +perl_command_reloadall (char *word[], char *word_eol[], void *userdata) +{ + if (my_perl != NULL) { + execute_perl (sv_2mortal (newSVpv ("Xchat::Embed::reload_all", 0)), ""); + + return XCHAT_EAT_XCHAT; + } else { + perl_auto_load( NULL ); + } + return XCHAT_EAT_XCHAT; +} + +static int +perl_command_load (char *word[], char *word_eol[], void *userdata) +{ + char *file = get_filename (word, word_eol); + + if (file != NULL ) + { + perl_load_file (file); + return XCHAT_EAT_XCHAT; + } + + return XCHAT_EAT_NONE; +} + +static int +perl_command_unload (char *word[], char *word_eol[], void *userdata) +{ + char *file = get_filename (word, word_eol); + + if (my_perl != NULL && file != NULL) { + execute_perl (sv_2mortal (newSVpv ("Xchat::Embed::unload", 0)), file); + return XCHAT_EAT_XCHAT; + } + + return XCHAT_EAT_NONE; +} + +static int +perl_command_reload (char *word[], char *word_eol[], void *userdata) +{ + char *file = get_filename (word, word_eol); + + if (my_perl != NULL && file != NULL) { + execute_perl (sv_2mortal (newSVpv ("Xchat::Embed::reload", 0)), file); + return XCHAT_EAT_XCHAT; + } + + return XCHAT_EAT_XCHAT; +} + +void +xchat_plugin_get_info (char **name, char **desc, char **version, + void **reserved) +{ + *name = "Perl"; + *desc = "Perl scripting interface"; + *version = PACKAGE_VERSION; + if (reserved) + *reserved = NULL; +} + + +/* Reinit safeguard */ + +static int initialized = 0; + +int +xchat_plugin_init (xchat_plugin * plugin_handle, char **plugin_name, + char **plugin_desc, char **plugin_version, char *arg) +{ + if (initialized != 0) { + xchat_print (plugin_handle, "Perl interface already loaded\n"); + return 0; + } + + ph = plugin_handle; + initialized = 1; + + *plugin_name = "Perl"; + *plugin_desc = "Perl scripting interface"; + *plugin_version = PACKAGE_VERSION; + + xchat_hook_command (ph, "load", XCHAT_PRI_NORM, perl_command_load, 0, 0); + xchat_hook_command (ph, "unload", XCHAT_PRI_NORM, perl_command_unload, 0, + 0); + xchat_hook_command (ph, "reload", XCHAT_PRI_NORM, perl_command_reload, 0, + 0); + xchat_hook_command (ph, "pl_reload", XCHAT_PRI_NORM, perl_command_reload, 0, + 0); + xchat_hook_command (ph, "unloadall", XCHAT_PRI_NORM, + perl_command_unloadall, 0, 0); + xchat_hook_command (ph, "reloadall", XCHAT_PRI_NORM, + perl_command_reloadall, 0, 0); + + /*perl_init (); */ + xchat_hook_timer (ph, 0, perl_auto_load, NULL ); + + xchat_print (ph, "Perl interface loaded\n"); + + return 1; +} + +int +xchat_plugin_deinit (xchat_plugin * plugin_handle) +{ + perl_end (); + + initialized = 0; + xchat_print (plugin_handle, "Perl interface unloaded\n"); + + return 1; +} -- cgit 1.4.1