SoniEx2
/
c.sexchat
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity
c.sexchat/plugins/perl/perl.c

1599 lines
35 KiB
C
Raw Blame History

/* 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 <stdlib.h>
#include <stdio.h>
#include <string.h>
#include <sys/types.h>
#include <sys/stat.h>
#include <fcntl.h>
#ifdef ENABLE_NLS
#include <locale.h>
#endif
#ifdef WIN32
#include <windows.h>
#else
#include <dirent.h>
#endif
#undef PACKAGE
#ifdef WIN32
#include "../../config-win32.h" /* for #define OLD_PERL */
#else
#include "../../config.h"
#endif
#include "hexchat-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 */
#ifdef WIN32
static void
perl_auto_load_from_path (const char *path)
{
WIN32_FIND_DATA find_data;
HANDLE find_handle;
char *search_path;
int path_len = strlen (path);
/* +6 for \*.pl and \0 */
search_path = malloc(path_len + 6);
sprintf (search_path, "%s\\*.pl", path);
find_handle = FindFirstFile (search_path, &find_data);
if (find_handle != INVALID_HANDLE_VALUE)
{
do
{
if (!(find_data.dwFileAttributes & FILE_ATTRIBUTE_DIRECTORY
||find_data.dwFileAttributes & FILE_ATTRIBUTE_HIDDEN))
{
char *full_path =
malloc (path_len + strlen (find_data.cFileName) + 2);
sprintf (full_path, "%s\\%s", path, find_data.cFileName);
perl_load_file (full_path);
free (full_path);
}
}
while (FindNextFile (find_handle, &find_data) != 0);
FindClose (find_handle);
}
free (search_path);
}
#else
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);
}
}
#endif
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");
/* don't pollute the filesystem with script files, this only causes misuse of the folders
* only use ~/.config/hexchat/addons/ and %APPDATA%\HexChat\addons */
#if 0
/* autoload from ~/.config/hexchat/ or %APPDATA%\HexChat\ on win32 */
perl_auto_load_from_path (xdir);
#endif
sub_dir = malloc (strlen (xdir) + 8);
strcpy (sub_dir, xdir);
strcat (sub_dir, "/addons");
perl_auto_load_from_path (sub_dir);
free (sub_dir);
#if 0
#ifdef WIN32
/* autoload from C:\Program Files\HexChat\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
#endif
return 0;
}
#include <EXTERN.h>
#define WIN32IOP_H
#include <perl.h>
#include <XSUB.h>
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;
}
/* sets $Xchat::Embed::current_package */
static void
set_current_package (SV *package)
{
SV *current_package = get_sv ("Xchat::Embed::current_package", 1);
SvSetSV_nosteal (current_package, package);
}
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;
set_current_package (data->package);
count = call_sv (data->callback, G_EVAL);
set_current_package (&PL_sv_undef);
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);
}
set_current_package (data->package);
count = call_sv (data->callback, G_EVAL);
set_current_package (&PL_sv_undef);
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++;
set_current_package (data->package);
count = call_sv (data->callback, G_EVAL);
set_current_package (&PL_sv_undef);
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++;
set_current_package (data->package);
count = call_sv (data->callback, G_EVAL);
set_current_package (&PL_sv_undef);
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++;
set_current_package (data->package);
count = call_sv (data->callback, G_EVAL);
set_current_package (&PL_sv_undef);
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;
SV *package;
xchat_hook *hook;
HookData *data;
dXSARGS;
if (items != 5) {
xchat_print (ph,
"Usage: Xchat::Internal::hook_server(name, priority, callback, userdata, package)");
} else {
name = SvPV_nolen (ST (0));
pri = (int) SvIV (ST (1));
callback = ST (2);
userdata = ST (3);
package = ST (4);
data = NULL;
data = malloc (sizeof (HookData));
if (data == NULL) {
XSRETURN_UNDEF;
}
data->callback = newSVsv (callback);
data->userdata = newSVsv (userdata);
data->depth = 0;
data->package = newSVsv (package);
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;
SV *package;
xchat_hook *hook;
HookData *data;
dXSARGS;
if (items != 6) {
xchat_print (ph,
"Usage: Xchat::Internal::hook_command(name, priority, callback, help_text, userdata, package)");
} else {
name = SvPV_nolen (ST (0));
pri = (int) SvIV (ST (1));
callback = ST (2);
/* leave the help text as 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);
package = ST (5);
data = NULL;
data = malloc (sizeof (HookData));
if (data == NULL) {
XSRETURN_UNDEF;
}
data->callback = newSVsv (callback);
data->userdata = newSVsv (userdata);
data->depth = 0;
data->package = newSVsv (package);
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;
SV *package;
xchat_hook *hook;
HookData *data;
dXSARGS;
if (items != 5) {
xchat_print (ph,
"Usage: Xchat::Internal::hook_print(name, priority, callback, userdata, package)");
} else {
name = SvPV_nolen (ST (0));
pri = (int) SvIV (ST (1));
callback = ST (2);
data = NULL;
userdata = ST (3);
package = ST (4);
data = malloc (sizeof (HookData));
if (data == NULL) {
XSRETURN_UNDEF;
}
data->callback = newSVsv (callback);
data->userdata = newSVsv (userdata);
data->depth = 0;
data->package = newSVsv (package);
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 = newSVsv (callback);
data->userdata = newSVsv (userdata);
data->ctx = xchat_get_context (ph);
data->package = newSVsv (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;
SV *package;
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);
package = ST (4);
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 = newSVsv (callback);
data->userdata = newSVsv (userdata);
data->depth = 0;
data->package = newSVsv (package);
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 <thehobbit@altern.org>) */
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"
#ifdef _WIN64
"64-bit Strawberry Perl is required.");
#else
"32-bit Strawberry Perl is required.");
#endif
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 either ActivePerl or Straberry Perl"
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 either ActivePerl or Strawberry Perl "
PERL_REQUIRED_VERSION " installed in order to\n"
"run perl scripts.\n\n"
"http://www.activestate.com/ActivePerl/\n"
"http://strawberryperl.com/\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;
}
Reference in New Issue View Git Blame Copy Permalink