/* 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>
#include <dirent.h>
#ifdef ENABLE_NLS
#include <locale.h>
#endif
#ifdef WIN32
#include <windows.h>
#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

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 (void)
{
	DIR *dir;
	struct dirent *ent;
	const char *xdir;

	/* 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");
	dir = opendir (xdir);
	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 (xdir) + 2);
				sprintf (file, "%s/%s", xdir, ent->d_name);
				perl_load_file (file);
				free (file);
			}
		}
		closedir (dir);
	}
}

#include <EXTERN.h>
#define WIN32IOP_H
#include <perl.h>
#include <XSUB.h>
#include <glib.h>

typedef enum { PRINT_HOOK, SERVER_HOOK, COMMAND_HOOK, TIMER_HOOK } HookType;

typedef struct
{
  char *name;
  char *version;
  char *desc;
  SV *shutdowncallback;
  void *gui_entry;
} PerlScript;

typedef struct
{
  SV *name;
  SV *callback;
  SV *userdata;
  HookType type;
  xchat_hook *hook;
  
} HookData;

static PerlInterpreter *my_perl = NULL;
static GSList *perl_list = NULL;
static GSList *hook_list = NULL;

#ifdef OLD_PERL
static GSList *compat_hook_list = NULL;
#endif

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;
	SV *sv;

	dSP;
	ENTER;
	SAVETMPS;

	PUSHMARK (SP);
	XPUSHs ( sv_2mortal (newSVpvn (args, strlen (args))));
	PUTBACK;

	count = call_sv(function, G_EVAL | G_SCALAR);
	SPAGAIN;

	sv = GvSV(gv_fetchpv("@", TRUE, SVt_PV));
	if (SvTRUE(sv)) {
/* 		xchat_printf(ph, "Perl error: %s\n", SvPV(sv, count)); */
	  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", function, count);
	} else {
		ret_value = POPi;
	}

	PUTBACK;
	FREETMPS;
	LEAVE;

	return ret_value;
}

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;

	count =	call_sv (data->callback, G_EVAL);
	SPAGAIN;
	if (SvTRUE (ERRSV))
	{
		xchat_printf (ph, "Error in timer callback %s",
				SvPV_nolen (ERRSV));
		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
				*/
				hook_list = g_slist_remove (hook_list,
								data->hook);
				SvREFCNT_dec (data->callback);

				if (data->userdata) {
				  SvREFCNT_dec (data->userdata);
				}
				free (data);
			}
		}

	}
	
	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;

	/* these must be initialized after SAVETMPS */
	AV* wd = NULL;
	AV* wd_eol = NULL;

	dSP;
	ENTER;
	SAVETMPS;
	
	wd = newAV ();
	sv_2mortal ((SV*)wd);
	wd_eol = newAV ();
	sv_2mortal ((SV*)wd_eol);

	for (count = 1;
	(count < 32) && (word[count] != NULL) && (word[count][0] != 0);
	count++) {
	  av_push (wd, newSVpv (word[count], 0));
	}

	for (count = 1;
	(count < 32) && (word_eol[count] != NULL) && (word_eol[count][0] != 0);
	count++)
	{
		av_push (wd_eol, newSVpv (word_eol[count], 0));
	}
	
/* 	xchat_printf (ph, */
/* 			"Recieved %d words in server callback", av_len (wd)); */
	PUSHMARK (SP);
	XPUSHs (newRV_noinc ((SV*) wd));
	XPUSHs (newRV_noinc ((SV*) wd_eol));
	XPUSHs (data->userdata);
	PUTBACK;

	count =	call_sv (data->callback, G_EVAL);
	SPAGAIN;
	if (SvTRUE (ERRSV))
	{
		xchat_printf (ph, "Error in server callback %s",
				SvPV_nolen (ERRSV));
		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;

	/* these must be initialized after SAVETMPS */
	AV* wd = NULL;
	AV* wd_eol = NULL;

	dSP;
	ENTER;
	SAVETMPS;
	
	wd = newAV ();
	sv_2mortal ((SV*)wd);
	wd_eol = newAV ();
	sv_2mortal ((SV*)wd_eol);

	for (count = 1;
		  (count < 32) && (word[count] != NULL) && (word[count][0] != 0);
		  count++) {
	  av_push (wd, newSVpv (word[count], 0));
	}

	for (count = 1;
	(count < 32) && (word_eol[count] != NULL) && 
		(word_eol[count][0] != 0);
	count++)
	{
		av_push (wd_eol, newSVpv (word_eol[count], 0));
	}
	
/* 	xchat_printf (ph, "Recieved %d words in command callback", */
/* 			av_len (wd)); */
	PUSHMARK (SP);
	XPUSHs (newRV_noinc ((SV*)wd));
	XPUSHs (newRV_noinc ((SV*)wd_eol));
	XPUSHs (data->userdata);
	PUTBACK;

	count =	call_sv (data->callback, G_EVAL);
	SPAGAIN;
	if (SvTRUE (ERRSV))
	{
		xchat_printf (ph, "Error in command callback %s",
				SvPV_nolen (ERRSV));
		POPs; /* remove undef from the top of the stack */
		retVal = XCHAT_EAT_NONE;
	}
	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;
	int retVal = 0;
	int count = 0;

	/* must be initialized after SAVETMPS */
	AV* wd = NULL;

	dSP;
	ENTER;
	SAVETMPS;

	wd = newAV ();
	sv_2mortal ((SV*)wd);

	for (count = 1;
	(count < 32) && (word[count] != NULL) && (word[count][0] != 0);
	count++)
	{
		av_push (wd, newSVpv (word[count], 0));
	}
	
/* 	xchat_printf (ph, "Recieved %d words in print callback", av_len (wd)); */
	PUSHMARK (SP);
	XPUSHs (newRV_noinc ((SV*)wd));
	XPUSHs (data->userdata);
	PUTBACK;

	count =	call_sv (data->callback, G_EVAL);
	SPAGAIN;
	if (SvTRUE (ERRSV))
	{
		xchat_printf (ph, "Error in print callback %s",
			       SvPV_nolen(ERRSV));
		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::register (scriptname, version, desc, shutdowncallback,)
 *  all scripts should call this at startup
 *
 */

static XS (XS_Xchat_register)
{
	char *name, *ver, *desc;
	SV *callback;
	PerlScript *scp;
	dXSARGS;
	if (items < 2 || items > 4) {
		xchat_printf (ph,
		"Usage: Xchat::register(scriptname, version, [desc,[shutdowncallback]])");
	} else {
		name = SvPV_nolen (ST (0));
		ver = SvPV_nolen (ST (1));
		desc = NULL;
		callback = &PL_sv_undef;

		switch(items)
		{
		case 3:
			desc = SvPV_nolen (ST (2));
			break;
		case 4:
			desc = SvPV_nolen (ST (2));
			callback = ST (3);
			break;
		}
	  
		if(desc == NULL ) {
			desc = "";
		}
		scp = malloc (sizeof (PerlScript));
		scp->name = strdup (name);
		scp->version = strdup (ver);
		scp->desc = strdup (desc);
	  
		scp->shutdowncallback = sv_mortalcopy (callback);
		SvREFCNT_inc (scp->shutdowncallback);
		/* FIXME: no filename */
		scp->gui_entry = xchat_plugingui_add (ph, scp->name, scp->name,
															scp->desc, scp->version, NULL);
	  
		perl_list = g_slist_prepend (perl_list, scp);
	  
		XSRETURN_EMPTY;
	}
}


/* Xchat::print(output) */
static XS (XS_Xchat_print)
{
  
	char *text = NULL;

	dXSARGS;
	if (items != 1 ) {
		xchat_print (ph, "Usage: Xchat::_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  (items) {*/
		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_get_info)
{
	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;
		}
		XSRETURN_PV (RETVAL);
	}
}

static XS (XS_Xchat_get_prefs)
{
	const char *str;
	int integer;
	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:
			XSRETURN_PV(str);
			break;
		case 2:
			XSRETURN_IV(integer);
			break;
		case 3:
			if (integer) {
				XSRETURN_YES;
			} else {
				XSRETURN_NO;
			}
		}
	}
}

/* Xchat::_hook_server(name, priority, callback, [userdata]) */
static XS (XS_Xchat_hook_server)
{

	SV *	name;
	int	pri;
	SV *	callback;
	SV *	userdata;
	xchat_hook *	RETVAL;
	HookData *data;

	dXSARGS;

	if (items != 4) {
		xchat_print (ph,
				"Usage: Xchat::_hook_server(name, priority, callback, userdata)");
	} else {
		name = 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->name = sv_mortalcopy (name);
		SvREFCNT_inc (data->name);
		data->callback = sv_mortalcopy (callback);
		SvREFCNT_inc (data->callback);
		data->userdata = sv_mortalcopy (userdata);
		SvREFCNT_inc (data->userdata);
		RETVAL = xchat_hook_server (ph, SvPV_nolen (name), pri,
						server_cb, data);
		hook_list = g_slist_append (hook_list, RETVAL);

		XSRETURN_IV(PTR2UV(RETVAL));
	}
}

/* Xchat::_hook_command(name, priority, callback, help_text, userdata) */
static XS(XS_Xchat_hook_command)
{
	SV *name;
	int pri;
	SV *callback;
	char *help_text;
	SV *userdata;
	xchat_hook *RETVAL;
	HookData *data;
	
	dXSARGS;
	
	if (items != 5) {
		xchat_print (ph, "Usage: Xchat::_hook_command(name, priority, callback, help_text, userdata)");
	} else {
		name = ST (0);
		pri = (int)SvIV(ST (1));
		callback = ST (2);
		help_text = SvPV_nolen(ST (3));
		userdata = ST(4);
		data = NULL;

		data = malloc (sizeof (HookData));
		if (data == NULL) {
			XSRETURN_UNDEF;
		}

		data->name = sv_mortalcopy (name);
		SvREFCNT_inc (data->name);
		data->callback = sv_mortalcopy (callback);
		SvREFCNT_inc (data->callback);
		data->userdata = sv_mortalcopy (userdata);
		SvREFCNT_inc (data->userdata);
		RETVAL = xchat_hook_command (ph, SvPV_nolen (name), pri,
						command_cb, help_text, data);
		hook_list = g_slist_append (hook_list, RETVAL);

		XSRETURN_IV (PTR2UV(RETVAL));
	}

}

/* Xchat::_hook_print(name, priority, callback, [userdata]) */
static XS (XS_Xchat_hook_print)
{

	SV *	name;
	int	pri;
	SV *	callback;
	SV *	userdata;
	xchat_hook *	RETVAL;
	HookData *data;
	dXSARGS;
	if (items != 4) {
		xchat_print (ph,
				"Usage: Xchat::_hook_print(name, priority, callback, userdata)");
	} else {
		name = 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->name = sv_mortalcopy (name);
		SvREFCNT_inc (data->name);
		data->callback = sv_mortalcopy (callback);
		SvREFCNT_inc (data->callback);
		data->userdata = sv_mortalcopy (userdata);
		SvREFCNT_inc (data->userdata);
		RETVAL = xchat_hook_print (ph, SvPV_nolen (name), pri,
						print_cb, data);
		hook_list = g_slist_append (hook_list, RETVAL);

		XSRETURN_IV(PTR2UV(RETVAL));
	}
}

/* Xchat::_hook_timer(timeout, callback, [userdata]) */
static XS (XS_Xchat_hook_timer)
{
	int	timeout;
	SV *	callback;
	SV *	userdata;
	xchat_hook * RETVAL;
	HookData *data;

	dXSARGS;

	if (items != 3) {
		xchat_print (ph,
		"Usage: Xchat::_hook_timer(timeout, callback, userdata)");
	} else {
		timeout = (int)SvIV(ST (0));
		callback = ST (1);
		data = NULL;
		userdata = ST (2);
		data = malloc (sizeof (HookData));

		if (data == NULL) {
			XSRETURN_UNDEF;
		}

		data->name = NULL;
		data->callback = sv_mortalcopy (callback);
		SvREFCNT_inc (data->callback);
		data->userdata = sv_mortalcopy (userdata);
		SvREFCNT_inc (data->userdata);
		RETVAL = xchat_hook_timer (ph, timeout, timer_cb, data);
		data->hook = RETVAL;
		hook_list = g_slist_append (hook_list, RETVAL);

		XSRETURN_IV (PTR2UV(RETVAL));
	}
}

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 {
	  if(looks_like_number(ST (0))) {
		 hook = INT2PTR(xchat_hook *,SvIV(ST (0)));
		 
		 if(g_slist_find( hook_list, hook ) != NULL ) {
			userdata = (HookData*)xchat_unhook (ph, hook);
			hook_list = g_slist_remove (hook_list, hook);
			if (userdata->name) {
			  SvREFCNT_dec (userdata->name);
			}
			if (userdata->callback) {
			  SvREFCNT_dec (userdata->callback);
			}
			if (userdata->userdata) {
			  XPUSHs(sv_mortalcopy (userdata->userdata));
			  SvREFCNT_dec (userdata->userdata);
			  retCount = 1;
			}
			free (userdata);
			XSRETURN(retCount);
		 }
	  }
	  XSRETURN_EMPTY;
	}
}

/* Xchat::_command(command) */
static XS (XS_Xchat_command)
{
	char *cmd = NULL;

	dXSARGS;
	if (items != 1 ) {
		xchat_print (ph, "Usage: Xchat::_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(PTR2UV(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(PTR2UV(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 *,SvIV(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;
	HV * hash;
	xchat_list *list;
	const char ** fields;
	const char *field;
	int i = 0; /* field index */
	int count = 0; /* return value for scalar context */
	U32 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;
		}
		
		context = GIMME_V;

		if( context == 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)) {
			i = 0;
			hash = newHV ();
			sv_2mortal ((SV*) hash);
			while (fields[i] != NULL) {
				switch (fields[i][0]) {
				case 's':
					field = xchat_list_str (ph, list, fields[i]+1);
					if (field != NULL)
					{
						hv_store (hash, fields[i]+1, strlen (fields[i]+1),
										newSVpvn (field, strlen (field)), 0);
/* 					xchat_printf (ph, */
/* 						"string: %s - %d - %s",  */
/* 						fields[i]+1, */
/* 						strlen(fields[i]+1), */
/* 						field, strlen(field) */
/* 							); */
					} else {
						hv_store (hash, fields[i]+1, strlen (fields[i]+1),
									&PL_sv_undef, 0);
/* 					xchat_printf (ph, */
/* 						"string: %s - %d - undef",  */
/* 							fields[i]+1, */
/* 							strlen(fields[i]+1) */
/* 							); */
					}
					break;
				case 'p':
/* 				xchat_printf (ph, "pointer: %s", fields[i]+1); */
					hv_store (hash, fields[i]+1, strlen (fields[i]+1),
								newSVuv(PTR2UV ( xchat_list_str (ph, list,
																				fields[i]+1)
									)), 0);
					break;
				case 'i': 
					hv_store (hash, fields[i]+1, strlen (fields[i]+1),
								newSVuv (xchat_list_int (ph, list, fields[i]+1)), 0);
/* 				xchat_printf (ph, "int: %s - %d",fields[i]+1, */
/* 				       xchat_list_int (ph, list, fields[i]+1) */
/* 						); */
					break;
				case 't':
					hv_store (hash, fields[i]+1, strlen (fields[i]+1),
								newSVnv(xchat_list_time(ph,list,fields[i]+1)), 0);
					break;
				}
				i++;
		}
	       
		XPUSHs(newRV_noinc ((SV*)hash));
		
	}
	xchat_list_free (ph, list);

	PUTBACK;
	return;
	}
}

#ifdef OLD_PERL
static int
compat_execute_perl (char *function, char *args)
{
	char *perl_args[2];
	int count, ret_value = 1;
	SV *sv;

	dSP;
	ENTER;
	SAVETMPS;
	PUSHMARK(sp);
	perl_args[0] = args;
	perl_args[1] = NULL;
	count = call_argv(function, G_EVAL | G_SCALAR, perl_args);
	SPAGAIN;

	sv = GvSV(gv_fetchpv("@", TRUE, SVt_PV));
	if (SvTRUE(sv)) {
		xchat_printf(ph, "Perl error: %s\n", SvPV(sv, count));
		POPs;
	} else if (count != 1) {
		xchat_printf(ph, "Perl error: expected 1 value from %s, "
						 "got: %d\n", function, count);
	} else {
		ret_value = POPi;
	}

	PUTBACK;
	FREETMPS;
	LEAVE;

	return ret_value;
}

static int
perl_timer_cb (void *perl_callback)
{
	compat_execute_perl (perl_callback, "");
	compat_hook_list = g_slist_remove (compat_hook_list, perl_callback);
	free (perl_callback);
	return 0;	/* returning zero removes the timeout handler */
}

static int
perl_server_cb (char *word[], char *word_eol[], void *perl_callback)
{
	return compat_execute_perl (perl_callback, word_eol[1]);
}

static int
perl_command_cb (char *word[], char *word_eol[], void *perl_callback)
{
	return compat_execute_perl (perl_callback, word_eol[2]);
}

static int
perl_print_cb (char *word[], void *perl_callback)
{
	char *arg;
	int count = 1, retVal = 0;

	dSP;
	ENTER;
	SAVETMPS;

	arg = g_strdup_printf ("%s %s %s %s", word[1], word[2], word[3],
								word[4]);

	PUSHMARK( SP );
	XPUSHs( sv_2mortal( newSVpv( arg, strlen(arg) ) ) );

	for( count = 1;
	(count < 32) && (word[count] != NULL) && (word[count][0] != 0);
	count++ )
	{
		XPUSHs( sv_2mortal( newSVpv( word[count], 0 ) ) );
	}
	PUTBACK;

	count = call_pv( (char*)perl_callback, G_EVAL);

	SPAGAIN;

	if (SvTRUE (ERRSV))
	{
		xchat_printf( ph, "Error in print callback %s",
		SvPV_nolen(ERRSV) );
		POPs;
		retVal = XCHAT_EAT_NONE;
	} else
	{
		if (count != 1)
		{
			xchat_print (ph,
				"Print handler should only return 1 value.");
			retVal = XCHAT_EAT_XCHAT;
		} else
		{
			retVal = POPi;
		}
	}

	g_free(arg);
	PUTBACK;
	FREETMPS;
	LEAVE;
	return retVal;
}

/* custom IRC perl functions for scripting */

/* IRC::register (scriptname, version, shutdowncallback, unused)

 *  all scripts should call this at startup
 *
 */

static XS (XS_IRC_register)
{
	char *name, *ver, *desc; 
	SV *callback;
	PerlScript *scp;
	dXSARGS;
	
	if (items != 4) {
	     xchat_print (ph,
	"Usage: IRC::register(scriptname, version, shutdowncallback, desc)");
		XSRETURN_EMPTY;
	} else {
		name = SvPV_nolen (ST (0));
		ver = SvPV_nolen (ST (1));
		callback = ST (2);
		desc = SvPV_nolen (ST (3));

		scp = malloc (sizeof (PerlScript));
		scp->name = strdup (name);
		scp->version = strdup (ver);
		scp->desc = strdup (desc);
		scp->shutdowncallback = sv_mortalcopy (callback);
		SvREFCNT_inc( scp->shutdowncallback );
		/* FIXME: no filename */
		scp->gui_entry = xchat_plugingui_add (ph, scp->name,
							scp->name, scp->desc,
							  scp->version, NULL);

		perl_list = g_slist_prepend (perl_list, scp);

		XST_mPV (0, VERSION);
		XSRETURN (1);
	}
}


/* print to main window */
/* IRC::main_print(output) */
static XS (XS_IRC_print)
{
	int i;
	char *output;
	dXSARGS;

	for (i = 0; i < items; ++i)
	{
		output = SvPV_nolen (ST (i));
		xchat_print (ph, output);
	}

	XSRETURN_EMPTY;
}

/*
 * IRC::print_with_channel( text, channelname, servername )
 *    
 *   The servername is optional, channelname is required.
 *   Returns 1 on success, 0 on fail.
 */

static XS (XS_IRC_print_with_channel)
{
	void *ctx, *old_ctx;
	char *server = NULL;
	dXSARGS;

	if (items > 2)
	{
		server = SvPV_nolen (ST (2));
		if (!server[0])
			server = NULL;
	}

	old_ctx = xchat_get_context (ph);
	ctx = xchat_find_context (ph, server, SvPV_nolen (ST (1)));
	if (ctx)
	{
		xchat_set_context (ph, ctx);
		xchat_print (ph, SvPV_nolen (ST (0)));
		xchat_set_context (ph, old_ctx);
		XSRETURN_YES;
	}

	XSRETURN_NO;
}

static XS (XS_IRC_get_info)
{
	char *ret;
	static const char *ids[] = {"version", "nick", "channel", "server",
				 "xchatdir", NULL, "network", "host", "topic"};
	int i;
	dXSARGS;

	i = SvIV (ST (0));
	if( items != 1 ) {
		xchat_print (ph, "Usage: IRC::get_info(id)");
		XSRETURN_EMPTY;
	} else {
		if (i < 9 && i >= 0 && i != 5) {
			ret = (char *)xchat_get_info (ph, ids[i]);
		} else {
			switch (i) {
				case 5:
					if (xchat_get_info (ph, "away")) {
						XST_mIV (0, 1);
					} else {
						XST_mIV (0, 0);
					}
					XSRETURN (1);

				default:
					ret = "Error2";
			}
		}

		if (ret) {
			XST_mPV (0, ret);
		} else {
			XST_mPV (0, "");	/* emulate 1.8.x behaviour */
		}
		XSRETURN (1);
	}
}

/* Added by TheHobbit <thehobbit@altern.org>*/
/* IRC::get_prefs(var) */
static XS (XS_IRC_get_prefs)
{
	const char *str;
	int integer;
	dXSARGS;

	if( items != 1 ) {
		xchat_print (ph, "Usage: IRC::get_prefs(name)");
		XSRETURN_EMPTY;
	}
	switch (xchat_get_prefs (ph, SvPV_nolen (ST (0)), &str, &integer))
	{
	case 0:
		XST_mPV (0, "Unknown variable");
		break;
	case 1:
		XST_mPV (0, str);
		break;
	case 2:
		XST_mIV (0, integer);
		break;
	case 3:
		if (integer)
			XST_mYES (0);
		else
			XST_mNO (0);
	}

	XSRETURN (1);
}

/* add handler for messages with message_type(ie PRIVMSG, 400, etc) */
/* IRC::add_message_handler(message_type, handler_name) */
static XS (XS_IRC_add_message_handler)
{
	char *tmp;
	char *name;
	void *hook;
	dXSARGS;

	if( items != 2 ) {
		xchat_print (ph,
			"Usage: IRC::add_message_handler(message,callback)");
	} else {
		tmp = strdup (SvPV_nolen (ST (1)));
		name = SvPV_nolen (ST (0));
		if (strcasecmp (name, "inbound") == 0) {
			name = "RAW LINE";
		}
		hook = xchat_hook_server (ph, name, XCHAT_PRI_NORM, perl_server_cb,
									tmp);

		compat_hook_list = g_slist_prepend (compat_hook_list, hook);
	
	}
	XSRETURN_EMPTY;
}

/* add handler for commands with command_name */
/* IRC::add_command_handler(command_name, handler_name) */
static XS (XS_IRC_add_command_handler)
{
	char *tmp;
	void *hook;
	dXSARGS;

	if( items != 2 ) {
		xchat_print (ph,
			"Usage: IRC::add_command_handler(command,callback)");
	} else {
		tmp = strdup (SvPV_nolen (ST (1)));

		/* use perl_server_cb when it's a "" hook, so that it gives
		   word_eol[1] as the arg, instead of word_eol[2] */
		hook = xchat_hook_command (ph, SvPV_nolen (ST (0)),
						XCHAT_PRI_NORM,
						SvPV_nolen (ST (0))[0] == 0 ? 
					perl_server_cb : perl_command_cb,
								NULL, tmp);

		compat_hook_list = g_slist_prepend (compat_hook_list, hook);
		
	}
	XSRETURN_EMPTY;
}

/* add handler for commands with print_name */
/* IRC::add_print_handler(print_name, handler_name) */
static XS (XS_IRC_add_print_handler)
{
	char *tmp;
	void *hook;
	dXSARGS;

	if( items != 2 ) {
		xchat_print (ph,
			"Usage: IRC::add_print_handler(event,callback)");
	} else {
		tmp = strdup (SvPV_nolen (ST (1)));

		hook = xchat_hook_print (ph, SvPV_nolen (ST (0)),
						XCHAT_PRI_NORM,
						perl_print_cb, tmp);

		compat_hook_list = g_slist_prepend (compat_hook_list, hook);
	}
	XSRETURN_EMPTY;
}

static XS (XS_IRC_add_timeout_handler)
{
	void *hook;
	dXSARGS;

	if( items != 2 ) {
		xchat_print (ph,
			"Usage: IRC::add_timeout_handler(interval,callback)");
	} else {
		hook = xchat_hook_timer (ph, SvIV (ST (0)), perl_timer_cb,
						strdup (SvPV_nolen (ST (1))));
		compat_hook_list = g_slist_prepend (compat_hook_list, hook);
	}
	XSRETURN_EMPTY;
}

/* send raw data to server */
/* IRC::send_raw(data) */
static XS (XS_IRC_send_raw)
{
	dXSARGS;
	
	if( items != 1 ) {
		xchat_print (ph, "Usage: IRC::send_raw(message)");
	} else {
		xchat_commandf (ph, "quote %s", SvPV_nolen (ST (0)));
	}
	XSRETURN_EMPTY;
}

static XS (XS_IRC_channel_list)
{
	int i = 0;
	xchat_list *list;
	xchat_context *old = xchat_get_context (ph);
	
	dXSARGS;
	
	if( items != 0 ) {
		xchat_print (ph, "Usage: IRC::channel_list()");
		XSRETURN_EMPTY;
	} else {
		list = xchat_list_get (ph, "channels");
		if (list) {
			while (xchat_list_next (ph, list)) {
				XST_mPV (i, xchat_list_str
							(ph, list, "channel"));
				i++;
				XST_mPV (i, xchat_list_str
							(ph, list, "server"));
				i++;
				xchat_set_context (ph,
					(xchat_context *) xchat_list_str (ph, list, "context"));
				XST_mPV (i, xchat_get_info (ph, "nick"));
				i++;
			}

			xchat_list_free (ph, list);
		}

		xchat_set_context (ph, old);

		XSRETURN (i);
	}
}

static XS (XS_IRC_server_list)
{
	int i = 0;
	xchat_list *list;
	dXSARGS;

	if( items != 0 ) {
		xchat_print (ph, "Usage: IRC::server_list()");
		XSRETURN_EMPTY;
	} else {
		list = xchat_list_get (ph, "channels");
		if (list) {
			while (xchat_list_next (ph, list)) {
				XST_mPV (i, xchat_list_str
							(ph, list, "server"));
				i++;
			}

			xchat_list_free (ph, list);
		}

		XSRETURN (i);
	}
}

static XS (XS_IRC_ignore_list)
{
	int i = 0, flags;
	xchat_list *list;
	
	dXSARGS;

	if( items != 0 ) {
		xchat_print (ph, "Usage: IRC::ignore_list()");
		XSRETURN_EMPTY;
	} else {
		list = xchat_list_get (ph, "ignore");
		if (list) {
			while (xchat_list_next (ph, list)) {
			/* Make sure there is room on the stack */
				EXTEND(SP, i + 10);

				XST_mPV (i, xchat_list_str (ph, list, "mask"));
				i++;

				flags = xchat_list_int (ph, list, "flags");

				XST_mIV (i, flags & 1);
				i++;
				XST_mIV (i, flags & 2);
				i++;
				XST_mIV (i, flags & 4);
				i++;
				XST_mIV (i, flags & 8);
				i++;
				XST_mIV (i, flags & 16);
				i++;
				XST_mIV (i, flags & 32);
				i++;
				XST_mPV (i, ":");
				i++;
			}

			xchat_list_free (ph, list);
		}

		XSRETURN (i);
	}
}

static XS (XS_IRC_notify_list)
{
	dXSARGS;
#if 0
	struct notify *not;
	struct notify_per_server *notserv;
	GSList *list = notify_list;
	GSList *notslist;

	while (list)
	{
		not = (struct notify *) list->data;
		notslist = not->server_list;

		XST_mPV (i, not->name);
		i++;
		while (notslist)
		{
			notserv = (struct notify_per_server *)notslist->data;

			XST_mPV (i, notserv->server->servername);
			i++;
			XST_mIV (i, notserv->laston);
			i++;
			XST_mIV (i, notserv->lastseen);
			i++;
			XST_mIV (i, notserv->lastoff);
			i++;
			if (notserv->ison)
				XST_mYES (i);
			else
				XST_mNO (i);
			i++;
			XST_mPV (i, "::");
			i++;
			
			notslist = notslist->next;
		}
		XST_mPV (i, ":");
		i++;

		list = list->next;
	}
#endif

	XSRETURN_IV (items);
}


/*

   IRC::user_info( nickname )

 */

static XS (XS_IRC_user_info)
{
	dXSARGS;
	xchat_list *list;
	int i = 0;
	const char *nick;
	const char *find_nick;
	const char *host, *prefix;

	if( items > 1 ) {
		xchat_print (ph, "Usage: IRC::user_info([nick])");
		XSRETURN_EMPTY;
	} else {
		find_nick = SvPV_nolen (ST (0));
		if (find_nick[0] == 0) {
			find_nick = xchat_get_info (ph, "nick");
		}

		list = xchat_list_get (ph, "users");
		if (list) {
			while (xchat_list_next (ph, list)) {
				nick = xchat_list_str (ph, list, "nick");

				if (xchat_nickcmp (ph, 
					(char *)nick, (char *)find_nick) == 0)
				{
					XST_mPV (i, nick);
					i++;
					host = xchat_list_str (ph, list,
								"host");
					if (!host) {
						host = "FETCHING";
					}
					XST_mPV (i, host);
					i++;

					prefix = xchat_list_str
							(ph, list, "prefix");

					XST_mIV (i,(prefix[0] == '@') ? 1 : 0);
					i++;

					XST_mIV (i,(prefix[0] == '+') ? 1 : 0);
					i++;

					xchat_list_free (ph, list);
					XSRETURN (4);
				}
			}

			xchat_list_free (ph, list);
		}
		
		XSRETURN (0);
	}
}

/*
 * IRC::add_user_list(ul_channel, ul_server, nick, user_host,
 * 		      realname, server)
 */
static XS (XS_IRC_add_user_list)
{
	dXSARGS;

	XSRETURN_IV(items);
}

/*
 * IRC::sub_user_list(ul_channel, ul_server, nick)
 */
static XS (XS_IRC_sub_user_list)
{
	dXSARGS;

	XSRETURN_IV(items);
}

/*
 * IRC::clear_user_list(channel, server)
 */
static XS (XS_IRC_clear_user_list)
{
	dXSARGS;

	XSRETURN_IV(items);
};

/*

   IRC::user_list( channel, server )

 */

static XS (XS_IRC_user_list)
{
	const char *host;
	const char *prefix;
	int i = 0;
	dXSARGS;
	xchat_list *list;
	xchat_context *ctx, *old = xchat_get_context (ph);

	if( items > 2 ) {
		xchat_print (ph, "Usage: IRC::user_list(channel,server)");
		XSRETURN_EMPTY;
	} else {
		ctx = xchat_find_context (ph, SvPV_nolen (ST (1)),
							SvPV_nolen (ST (0)));
		if (!ctx) {
			XSRETURN (0);
		}
		xchat_set_context (ph, ctx);

		list = xchat_list_get (ph, "users");
		if (list) {
			while (xchat_list_next (ph, list)) {
				/* Make sure there is room on the stack */
				EXTEND(SP, i + 9);

				XST_mPV (i, xchat_list_str (ph, list, "nick"));
				i++;
				host = xchat_list_str (ph, list, "host");
				if (!host) {
					host = "FETCHING";
				}
				XST_mPV (i, host);
				i++;

				prefix = xchat_list_str (ph, list, "prefix");

				XST_mIV (i, (prefix[0] == '@') ? 1 : 0);
				i++;
				XST_mIV (i, (prefix[0] == '+') ? 1 : 0);
				i++;
				XST_mPV (i, ":");
				i++;
			}

			xchat_list_free (ph, list);
		}

		xchat_set_context (ph, old);

		XSRETURN (i);
	}
}

static XS (XS_IRC_dcc_list)
{
	int i = 0;
	xchat_list *list;
	const char *file;
	int type;

	dXSARGS;
	if( items != 0 ) {
		xchat_print (ph, "Usage: IRC::dcc_list()");
		XSRETURN_EMPTY;
	} else {
		list = xchat_list_get (ph, "dcc");
		if (list) {
			while (xchat_list_next (ph, list)) {
				/* Make sure there is room on the stack */
				EXTEND (SP, i + 11);

				XST_mPV (i, xchat_list_str (ph, list, "nick"));
				i++;

				file = xchat_list_str (ph, list, "file");
				if (!file) {
					file = "";
				}

				XST_mPV (i, file);
				i++;
				XST_mIV (i, xchat_list_int (ph, list, "type"));
				i++;
				XST_mIV (i, xchat_list_int
							(ph, list, "status"));
				i++;
				XST_mIV (i, xchat_list_int (ph, list, "cps"));
				i++;
				XST_mIV (i, xchat_list_int (ph, list, "size"));
				i++;
				type = xchat_list_int (ph, list, "type");
				if (type == 0) {
					XST_mIV (i, xchat_list_int
							(ph, list, "pos"));
				} else {
					XST_mIV (i, xchat_list_int
							(ph, list, "resume"));
				}

				i++;
				XST_mIV (i, xchat_list_int
						(ph, list, "address32"));
				i++;
				file = xchat_list_str (ph, list, "destfile");
				if (!file)
					file = "";

				XST_mPV (i, file);
				i++;
			}

			xchat_list_free (ph, list);
		}

		XSRETURN (i);
	}
}

/* run internal xchat command */
/* IRC::command(command) */
static XS (XS_IRC_command)
{
	char *cmd;
	dXSARGS;

	if( items != 1 ) {
		xchat_print (ph, "Usage: IRC::command(command)");
	} else {
		cmd = SvPV_nolen (ST (0));
		if (cmd[0] == '/') {
			/* skip the forward slash */
			xchat_command (ph, cmd + 1);
		} else {
			xchat_commandf (ph, "say %s", cmd);
		}
	}
	XSRETURN_EMPTY;
}

/* command_with_server(command, server) */
static XS (XS_IRC_command_with_server)
{
	void *ctx, *old_ctx;
	char *cmd;

	dXSARGS;

	if( items != 2 ) {
		xchat_print (ph,
			"Usage: IRC::command_with_server(command,server)");
		XSRETURN_EMPTY;
	} else {
		cmd = SvPV_nolen (ST (0));
		old_ctx = xchat_get_context (ph);
		ctx = xchat_find_context (ph, SvPV_nolen (ST (1)), NULL);
		if (ctx) {
			xchat_set_context (ph, ctx);

			if (cmd[0] == '/') {
				/* skip the forward slash */
				xchat_command (ph, cmd + 1);
			} else {
				xchat_commandf (ph, "say %s", cmd);
			}
			xchat_set_context (ph, old_ctx);
			XSRETURN_YES;
		}

		XSRETURN_NO;
	}
}

/* command_with_channel( command, channel, [server] ) */
static XS (XS_IRC_command_with_channel)
{
	
	void *ctx, *old_ctx;
	char *cmd;
	char *server = NULL;

	dXSARGS;

	cmd = SvPV_nolen (ST (0));

	if (items > 2)
	{
		server = SvPV_nolen (ST (2));
		if (!server[0])
			server = NULL;
	}

	old_ctx = xchat_get_context (ph);
	ctx = xchat_find_context (ph, server, SvPV_nolen (ST (1)));
	if (ctx)
	{
		xchat_set_context (ph, ctx);

		if (cmd[0] == '/')
			/* skip the forward slash */
			xchat_command (ph, cmd + 1);
		else
			xchat_commandf (ph, "say %s", cmd);

		xchat_set_context (ph, old_ctx);
		XSRETURN_YES;
	}

	XSRETURN_NO;
}

/* MAG030600: BEGIN IRC::user_list_short */
/*

   IRC::user_list_short( channel, server )
   returns a shorter user list consisting of pairs of nick & user@host
   suitable for assigning to a hash.  modified IRC::user_list()
   
 */
static XS (XS_IRC_user_list_short)
{
	const char *host;
	int i = 0;
	
	xchat_list *list;
	xchat_context *ctx, *old = xchat_get_context (ph);

	dXSARGS;
	
	if( items != 2 ) {
		xchat_print (ph,
			"Usage: IRC::user_list_short(channel,server)");
		XSRETURN_EMPTY;
	} else {
		ctx = xchat_find_context (ph, SvPV_nolen (ST (1)), SvPV_nolen (ST (0)));
		if (!ctx) {
			XSRETURN (0);
		}
		xchat_set_context (ph, ctx);

		list = xchat_list_get (ph, "users");
		if (list) {
			while (xchat_list_next (ph, list)) {
				/* Make sure there is room on the stack */
				EXTEND(SP, i + 5);

				XST_mPV (i, xchat_list_str (ph, list, "nick"));
				i++;
				host = xchat_list_str (ph, list, "host");
				if (!host) {
					host = "FETCHING";
				}
				XST_mPV (i, host);
				i++;
			}

			xchat_list_free (ph, list);
		}

		xchat_set_context (ph, old);

		XSRETURN (i);
	}
}

static XS (XS_IRC_perl_script_list)
{
	int i = 0;
	GSList *handler;
	dXSARGS;
	if (items != 0) {
		xchat_print (ph, "Usage: IRC::perl_script_list()");
	} else {
	  handler = perl_list;
	  while (handler) {
	    PerlScript *scp = handler->data;
	    
	    /* Make sure there is room on the stack */
	    EXTEND(SP, i + 5);
	    
	    XST_mPV (i, scp->name);
	    i++;
	    XST_mPV (i, scp->version);
	    i++;
	    handler = handler->next;
	  }
	  XSRETURN(i);
	}
}
#endif

/* 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)
{
	char *file = __FILE__;
	HV *stash;
	
	/* 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::register", XS_Xchat_register, "Xchat");
	newXS("Xchat::_hook_server", XS_Xchat_hook_server, "Xchat");
	newXS("Xchat::_hook_command", XS_Xchat_hook_command, "Xchat");
	newXS("Xchat::_hook_print", XS_Xchat_hook_print, "Xchat");
	newXS("Xchat::_hook_timer", XS_Xchat_hook_timer, "Xchat");
	newXS("Xchat::unhook", XS_Xchat_unhook, "Xchat");
	newXS("Xchat::_print", XS_Xchat_print, "Xchat");
	newXS("Xchat::_command", XS_Xchat_command, "Xchat");
	newXS("Xchat::find_context", XS_Xchat_find_context, "Xchat");
	newXS("Xchat::get_context", XS_Xchat_get_context, "Xchat");
	newXS("Xchat::set_context", XS_Xchat_set_context, "Xchat");
	newXS("Xchat::get_info", XS_Xchat_get_info, "Xchat");
	newXS("Xchat::get_prefs", XS_Xchat_get_prefs, "Xchat");
	newXS("Xchat::emit_print", XS_Xchat_emit_print, "Xchat");
	newXS("Xchat::nickcmp", XS_Xchat_nickcmp, "Xchat");
	newXS("Xchat::get_list", XS_Xchat_get_list, "Xchat");
	
#ifdef OLD_PERL
	/* for old interface compatibility */
	newXS ("IRC::register", XS_IRC_register, "IRC");
	newXS ("IRC::add_message_handler", XS_IRC_add_message_handler, "IRC");
	newXS ("IRC::add_command_handler", XS_IRC_add_command_handler, "IRC");
	newXS ("IRC::add_print_handler", XS_IRC_add_print_handler, "IRC");
	newXS ("IRC::add_timeout_handler", XS_IRC_add_timeout_handler, "IRC");
	newXS ("IRC::print", XS_IRC_print, "IRC");
	newXS ("IRC::print_with_channel", XS_IRC_print_with_channel, "IRC");
	newXS ("IRC::send_raw", XS_IRC_send_raw, "IRC");
	newXS ("IRC::command", XS_IRC_command, "IRC");
	newXS ("IRC::command_with_server", XS_IRC_command_with_server, "IRC");
	newXS ("IRC::command_with_channel", XS_IRC_command_with_channel, "IRC");
	newXS ("IRC::channel_list", XS_IRC_channel_list, "IRC");
	newXS ("IRC::server_list", XS_IRC_server_list, "IRC");
	newXS ("IRC::add_user_list", XS_IRC_add_user_list, "IRC");
	newXS ("IRC::sub_user_list", XS_IRC_sub_user_list, "IRC");
	newXS ("IRC::clear_user_list", XS_IRC_clear_user_list, "IRC");
	newXS ("IRC::user_list", XS_IRC_user_list, "IRC");
	newXS ("IRC::user_info", XS_IRC_user_info, "IRC");
	newXS ("IRC::ignore_list", XS_IRC_ignore_list, "IRC");
	newXS ("IRC::notify_list", XS_IRC_notify_list, "IRC");
	newXS ("IRC::dcc_list", XS_IRC_dcc_list, "IRC");
	newXS ("IRC::get_info", XS_IRC_get_info, "IRC");
	newXS ("IRC::get_prefs", XS_IRC_get_prefs, "IRC");
	newXS ("IRC::user_list_short", XS_IRC_user_list_short, "IRC");
	newXS ("IRC::perl_script_list", XS_IRC_perl_script_list, "IRC");
#endif
	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, "KEEP", newSViv(1));
	newCONSTSUB (stash, "REMOVE", newSViv(0));
}

static void
perl_init (void)
{
	/*changed the name of the variable from load_file to
	  perl_definitions since now it does much more than defining
	  the load_file sub. Moreover, deplaced the initialisation to
	  the xs_init function. (TheHobbit)*/
	int warn;
	char *perl_args[] = { "", "-e", "0", "-w" };
	const char perl_definitions[] =
	{
	  /* We use to function one to load a file the other to
	     execute the string obtained from the first and holding
	     the file conents. This allows to have a realy local $/
	     without introducing temp variables to hold the old
	     value. Just a question of style:) 
	     We also redefine the $SIG{__WARN__} handler to have XChat
	     printing warnings in the main window. (TheHobbit)*/

	  "BEGIN {\n"
	  "$INC{'Xchat.pm'} = 'DUMMY';\n"
	  "}\n"

	  "{\n"
	  "package Xchat;\n"
	  "use base qw(Exporter);\n"
	  "our @EXPORT = (qw(PRI_HIGHEST PRI_HIGH PRI_NORM PRI_LOW PRI_LOWEST),\n"
	  "qw(EAT_NONE EAT_XCHAT EAT_PLUGIN EAT_ALL),\n"
	  ");\n"
	  "our @EXPORT_OK = (qw(register hook_server hook_command hook_print),\n"
	  "qw(hook_timer unhook print command find_context),\n"
	  "qw(get_context set_context get_info get_prefs emit_print),\n"
	  "qw(nickcmp get_list context_info strip_code),\n"
	  "qw(PRI_HIGHEST PRI_HIGH PRI_NORM PRI_LOW PRI_LOWEST),\n"
	  "qw(EAT_NONE EAT_XCHAT EAT_PLUGIN EAT_ALL),\n"
	  ");\n"
	  "our %EXPORT_TAGS = ( all => [\n"
	  "qw(register hook_server hook_command),\n"
	  "qw(hook_print hook_timer unhook print command),\n"
	  "qw(find_context get_context set_context),\n"
	  "qw(get_info get_prefs emit_print nickcmp),\n"
	  "qw(get_list context_info strip_code),\n"
	  "qw(PRI_HIGHEST PRI_HIGH PRI_NORM PRI_LOW),\n"
	  "qw(PRI_LOWEST EAT_NONE EAT_XCHAT EAT_PLUGIN),\n"
	  "qw(EAT_ALL),\n"
	  "],\n"
	  "constants => [\n"
	  "qw(PRI_HIGHEST PRI_HIGH PRI_NORM PRI_LOW),\n"
	  "qw(PRI_LOWEST EAT_NONE EAT_XCHAT),\n"
	  "qw(EAT_PLUGIN EAT_ALL),\n"
	  "],\n"
	  "hooks => [\n"
	  "qw(hook_server hook_command),\n"
	  "qw(hook_print hook_timer unhook),\n"
	  "],\n"
	  "util => [\n"
	  "qw(register print command find_context),\n"
	  "qw(get_context set_context get_info get_prefs),\n"
	  "qw(emit_print nickcmp get_list context_info),\n"
	  "qw(strip_code),\n"
	  "],\n"
	  ");\n"

	  "}\n"
	  "sub Xchat::hook_server {\n"
	  "return undef unless @_ >= 2;\n"
  
	  "my $message = shift;\n"
	  "my $callback = shift;\n"
	  "my $options = shift;\n"
  
	  "my ($priority, $data) = ( Xchat::PRI_NORM, undef );\n"
  
	  "if ( ref( $options ) eq 'HASH' ) {\n"
	  "if ( exists( $options->{priority} ) && defined( $options->{priority} ) ) {\n"
	  "$priority = $options->{priority};\n"
	  "}\n"
	  "if ( exists( $options->{data} ) && defined( $options->{data} ) ) {\n"
	  "$data = $options->{data};\n"
	  "}\n"
	  "}\n"
  
	  "return Xchat::_hook_server( $message, $priority, $callback, $data);\n"

	  "}\n"

	  "sub Xchat::hook_command {\n"
	  "return undef unless @_ >= 2;\n"

	  "my $command = shift;\n"
	  "my $callback = shift;\n"
	  "my $options = shift;\n"

	  "my ($priority, $help_text, $data) = ( Xchat::PRI_NORM, '', undef );\n"

	  "if ( ref( $options ) eq 'HASH' ) {\n"
	  "if ( exists( $options->{priority} ) && defined( $options->{priority} ) ) {\n"
	  "$priority = $options->{priority};\n"
	  "}\n"
	  "if ( exists( $options->{help_text} ) && defined( $options->{help_text} ) ) {\n"
	  "$help_text = $options->{help_text};\n"
	  "}\n"
	  "if ( exists( $options->{data} ) && defined( $options->{data} ) ) {\n"
	  "$data = $options->{data};\n"
	  "}\n"
	  "}\n"

	  "return Xchat::_hook_command( $command, $priority, $callback, $help_text,\n"
	  "$data);\n"

	  "}\n"

	  "sub Xchat::hook_print {\n"
	  "return undef unless @_ >= 2;\n"

	  "my $event = shift;\n"
	  "my $callback = shift;\n"
	  "my $options = shift;\n"

	  "my ($priority, $data) = ( Xchat::PRI_NORM, undef );\n"

	  "if ( ref( $options ) eq 'HASH' ) {\n"
	  "if ( exists( $options->{priority} ) && defined( $options->{priority} ) ) {\n"
	  "$priority = $options->{priority};\n"
	  "}\n"
	  "if ( exists( $options->{data} ) && defined( $options->{data} ) ) {\n"
	  "$data = $options->{data};\n"
	  "}\n"
	  "}\n"

	  "return Xchat::_hook_print( $event, $priority, $callback, $data);\n"

	  "}\n"


	  "sub Xchat::hook_timer {\n"
	  "return undef unless @_ >= 2;\n"

	  "my $timeout = shift;\n"
	  "my $callback = shift;\n"
	  "my $data = shift;\n"

	  "if( ref( $data ) eq 'HASH' && exists( $data->{data} )\n"
	  "&& defined( $data->{data} ) ) {\n"
	  "$data = $data->{data};\n"
	  "}\n"

	  "return Xchat::_hook_timer( $timeout, $callback, $data );\n"

	  "}\n"

	  "sub Xchat::print {\n"

	  "my $text = shift @_;\n"
	  "if( ref( $text ) eq 'ARRAY' ) {\n"
	  "if( $, ) {\n"
	  "$text = join $, , @$text;\n"
	  "} else {\n"
	  "$text = join \"\", @$text;\n"
	  "}\n"
	  "}\n"
  
	  "if( @_ >= 1 ) {\n"
	  "my $channel = shift @_;\n"
	  "my $server = shift @_;\n"
	  "my $old_ctx = Xchat::get_context();\n"
	  "my $ctx = Xchat::find_context( $channel, $server );\n"
    
	  "if( $ctx ) {\n"
	  "Xchat::set_context( $ctx );\n"
	  "Xchat::_print( $text );\n"
	  "Xchat::set_context( $old_ctx );\n"
	  "return 1;\n"
	  "} else {\n"
	  "return 0;\n"
	  "}\n"
	  "} else {\n"
	  "Xchat::_print( $text );\n"
	  "return 1;\n"
	  "}\n"

	  "}\n"

	  "sub Xchat::printf {\n"
	  "my $format = shift;\n"
	  "Xchat::print( sprintf( $format, @_ ) );\n"
	  "}\n"

	  "sub Xchat::command {\n"

	  "my $command = shift;\n"
	  "my @commands;\n"
	  "if( ref( $command ) eq 'ARRAY' ) {\n"
	  "@commands = @$command;\n"
	  "} else {\n"
	  "@commands = ($command);\n"
	  "}\n"
	  "if( @_ >= 1 ) {\n"
	  "my ($channel, $server) = @_;\n"
	  "my $old_ctx = Xchat::get_context();\n"
	  "my $ctx = Xchat::find_context( $channel, $server );\n"

	  "if( $ctx ) {\n"
	  "Xchat::set_context( $ctx );\n"
	  "Xchat::_command( $_ ) foreach @commands;\n"
	  "Xchat::set_context( $old_ctx );\n"
	  "return 1;\n"
	  "} else {\n"
	  "return 0;\n"
	  "}\n"
	  "} else {\n"
	  "Xchat::_command( $_ ) foreach @commands;\n"
	  "return 1;\n"
	  "}\n"

	  "}\n"

	  "sub Xchat::commandf {\n"
	  "my $format = shift;\n"
	  "Xchat::command( sprintf( $format, @_ ) );\n"
	  "}\n"

	  "sub Xchat::user_info {\n"
	  "my $nick = shift @_ || Xchat::get_info( \"nick\" );\n"
	  "my $user;\n"

	  "for(Xchat::get_list( \"users\" ) ) {\n"
	  "if( Xchat::nickcmp( $_->{nick}, $nick ) == 0 ) {\n"
	  "$user = $_;\n"
	  "last;\n"
	  "}\n"
	  "}\n"
	  "return $user;\n"
	  "}\n"

	  "sub Xchat::context_info {\n"
	  "my $ctx = shift @_;\n"
	  "my $old_ctx = Xchat::get_context;\n"
	  "my @fields = (qw(away channel host network nick server topic version),\n"
	  "qw(win_status xchatdir xchatdirfs),\n"
	  ");\n"

	  "Xchat::set_context( $ctx );\n"
	  "my %info;\n"
	  "for my $field ( @fields ) {\n"
	  "$info{$field} = Xchat::get_info( $field );\n"
	  "}\n"
	  "Xchat::set_context( $old_ctx );\n"

	  "return %info if wantarray;\n"
	  "return \\%info;\n"
	  "}\n"

	  "sub Xchat::strip_code {\n"
	  "my $pattern =\n"
	  "qr/\\cB| #Bold\n"
	  "\\cC\\d{0,2}(?:,\\d{0,2})?| #Color\n"
	  "\\cG| #Beep\n"
	  "\\cO| #Reset\n"
	  "\\cV| #Reverse\n"
	  "\\c_  #Underline\n"
	  "/x;\n"

	  "if( defined wantarray ) {\n"
	  "my $msg = shift;\n"
	  "$msg =~ s/$pattern//g;\n"
	  "return $msg;\n"
	  "} else {\n"
	  "$_[0] =~ s/$pattern//g;\n"
	  "}\n"
	  "}\n"

	  "$SIG{__WARN__} = sub {\n"
	  "local $, = \"\\n\";\n"
	  "my ($package, $file, $line, $sub) = caller(1);\n"
	  "Xchat::print( \"Warning from ${sub}.\" );\n"
	  "Xchat::print( @_ );\n"
	  "};\n"

	  "sub Xchat::Embed::load {\n"
	  "my $file = shift @_;\n"

	  "if( open FH, $file ) {\n"
	  "my $data = do {local $/; <FH>};\n"
	  "close FH;\n"

	  "eval $data;\n"

	  "if( $@ ) {\n"
	  "Xchat::print( \"Error loading '$file':\\n$@\\n\" );\n"
	  "return 1;\n"
	  "}\n"

	  "} else {\n"

	  "Xchat::print( \"Error opening '$file': $!\\n\" );\n"
	  "return 2;\n"
	  "}\n"

	  "return 0;\n"
	  "}\n"

	};
#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

	my_perl = perl_alloc ();
	PL_perl_destruct_level = 1;
	perl_construct (my_perl);

	warn = 0;
	xchat_get_prefs (ph, "perl_warnings", NULL, &warn);
	if (warn)
		perl_parse (my_perl, xs_init, 4, perl_args, NULL);
	else
		perl_parse (my_perl, xs_init, 3, perl_args, NULL);
	/*
	  Now initialising the perl interpreter by loading the
	  perl_definition array.
	*/

	eval_pv (perl_definitions, TRUE);

}


static int
perl_load_file (char *script_name)
{
#ifdef WIN32
	static HINSTANCE lib = NULL;

	if (!lib)
	{
		lib = LoadLibrary (PERL_DLL);
		if (!lib)
		{
			thread_mbox ("Cannot open " PERL_DLL "\n\n"
							 "You must have ActivePerl 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.");
			return FALSE;
		}
		FreeLibrary (lib);
	}
#endif

	if (my_perl == NULL) {
		perl_init ();
	}

	return execute_perl (sv_2mortal (newSVpv ("Xchat::Embed::load", 0)),
								  script_name);
	
}

/* checks for "~" in a file and expands */

static char *
expand_homedir (char *file)
{
#ifndef WIN32
	char *ret;

	if (*file == '~')
	{
		ret = malloc (strlen (file) + strlen (g_get_home_dir ()) + 1);
		sprintf (ret, "%s%s", g_get_home_dir (), file + 1);
		return ret;
	}
#endif
	return strdup (file);
}

static void
perl_end (void)
{
	PerlScript *scp;
	HookData *tmp;

	while (perl_list)
	{
		scp = perl_list->data;
		perl_list = g_slist_remove (perl_list, scp);

		if (SvTRUE (scp->shutdowncallback)) {
			execute_perl (scp->shutdowncallback, "");
		}
		xchat_plugingui_remove (ph, scp->gui_entry);
		free (scp->name);
		free (scp->version);
		free (scp->desc);
		SvREFCNT_dec(scp->shutdowncallback);
		free (scp);
	}

	if (my_perl != NULL)
	{
		perl_destruct (my_perl);
		perl_free (my_perl);
		my_perl = NULL;
	}

	while (hook_list)
	{
		tmp = xchat_unhook (ph, hook_list->data);
		if (tmp) {
			free (tmp);

		}
		hook_list = g_slist_remove (hook_list, hook_list->data);
	}

#ifdef OLD_PERL
	while (compat_hook_list)
	{
		tmp = xchat_unhook (ph, compat_hook_list->data);
		if (tmp)
			free(tmp);
		compat_hook_list = g_slist_remove (compat_hook_list, compat_hook_list->data);
	}
#endif
}

static int
perl_command_unloadall (char *word[], char *word_eol[], void *userdata)
{
	perl_end ();

	return XCHAT_EAT_XCHAT;
}

static int
perl_command_reloadall (char *word[], char *word_eol[], void *userdata)
{
	perl_end ();
	perl_auto_load ();

	return XCHAT_EAT_XCHAT;
}

static int
perl_command_unload (char *word[], char *word_eol[], void *userdata)
{
	int len;
	PerlScript *scp;
	GSList *list;

	/* try it by filename */
	len = strlen (word[2]);
	if (len > 3 && strcasecmp (".pl", word[2] + len - 3) == 0)
	{
		/* if only unloading was possible with this shitty interface */
		xchat_print (ph, "Unloading individual perl scripts is not supported.\nYou may use /UNLOADALL to unload all Perl scripts.\n");
		return XCHAT_EAT_XCHAT;
	}

	/* try it by script name */
	list = perl_list;
	while (list)
	{
		scp = list->data;
		if (strcasecmp (scp->name, word[2]) == 0)
		{
			xchat_print (ph, "Unloading individual perl scripts is not supported.\nYou may use /UNLOADALL to unload all Perl scripts.\n");
			return XCHAT_EAT_XCHAT;
		}
		list = list->next;
	}

	return XCHAT_EAT_NONE;
}

static int
perl_command_load (char *word[], char *word_eol[], void *userdata)
{
	char *file;
	int len;

	len = strlen (word[2]);
	if (len > 3 && strcasecmp (".pl", word[2] + len - 3) == 0)
	{
		file = expand_homedir (word[2]);
		switch (perl_load_file (file))
		{
		case 1:
			xchat_print (ph, "Error compiling script\n");
			break;
		case 2:
			xchat_print (ph, "Error Loading file\n");
		}
		free (file);
		return XCHAT_EAT_XCHAT;
	}

	return XCHAT_EAT_NONE;
}


/* Reinit safeguard */

static int initialized = 0;
static int reinit_tried = 0;

int
xchat_plugin_init (xchat_plugin *plugin_handle,
				char **plugin_name, char **plugin_desc, char **plugin_version,
				char *arg)
{
	ph = plugin_handle;
	
	if (initialized != 0)
	{
		xchat_print (ph, "Perl interface already loaded\n");
		reinit_tried++;
		return 0;
	}
	initialized = 1;

	*plugin_name = "Perl";
	*plugin_version = VERSION;
	*plugin_desc = "Perl scripting interface";

	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, "unloadall", XCHAT_PRI_NORM, perl_command_unloadall,
							  0, 0);
	xchat_hook_command (ph, "reloadall", XCHAT_PRI_NORM, perl_command_reloadall,
							  0, 0);

	perl_auto_load ();

	xchat_print (ph, "Perl interface loaded\n");

	return 1;
}

int
xchat_plugin_deinit (xchat_plugin *plugin_handle)
{
	if (reinit_tried)
	{
		reinit_tried--;
		return 1;
	}

	perl_end ();

	xchat_print (plugin_handle, "Perl interface unloaded\n");

	return 1;
}
