annotate src/perl.c @ 780:c714def9cebb

[gaim-migrate @ 790] You may be a geek if... You've ever used a computer on Friday, Saturday and Sunday of the same weekend. You find yourself interrupting computer store salesman to correct something he said. The first thing you notice when walking in a business is their computer system. ...and offer advice on how you would change it. You've ever mounted a magnetic tape reel. You own any shareware. You know more IP addresses than phone numbers. You've ever accidentally dialed an IP address. Your friends use you as tech support. You've ever named a computer. You have your local computer store on speed dial. You can't carry on a conversation without talking about computers. Co-workers have to E-mail you about the fire alarm to get you out of the building. You've ever found "stray" diskettes when doing laundry. Your computer has it's own phone line - but your teenager doesn't. You check the national weather service web page for current weather conditions (rather than look out the window). You know more URLs than street addresses. Your pet has a web page. You get really excited when Yahoo adds your link. committer: Tailor Script <[e-mail]>

/*
 * gaim
 *
 * Copyright (C) 1998-1999, Mark Spencer <[e-mail]>
 *
 * 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
 *
 * This was taken almost exactly from X-Chat. The power of the GPL.
 * Translated from X-Chat to Gaim by Eric Warmenhoven.
 * Originally by Erik Scrafford <[e-mail]>.
 * X-Chat Copyright (C) 1998 Peter Zelezny.
 *
 */

#ifdef HAVE_CONFIG_H
#include "../config.h"
#endif
#undef PACKAGE

#ifdef USE_PERL

#include <EXTERN.h>
#ifndef _SEM_SEMUN_UNDEFINED
#define HAS_UNION_SEMUN
#endif
#include <perl.h>
#include <XSUB.h>
#include <sys/mman.h>
#include <sys/types.h>
#include <sys/stat.h>
#include <fcntl.h>
#undef PACKAGE
#include <stdio.h>

/* perl module support */
extern void xs_init _((void));
extern void boot_DynaLoader _((CV * cv)); /* perl is so wacky */

#undef _
#include "gaim.h"

struct perlscript {
	char *name;
	char *version;
	char *shutdowncallback; /* bleh */
};

struct _perl_event_handlers {
	char *event_type;
	char *handler_name;
}

struct _perl_timeout_handlers {
	char *handler_name;
	gint iotag;
};

static GList *perl_list = NULL; /* should probably extern this at some point */
static GList *perl_timeout_handlers = NULL;
static GList *perl_event_handlers = NULL;
static PerlInterpreter *my_perl = NULL;

/* dealing with gaim */
XS(XS_AIM_register); /* set up hooks for script */
XS(XS_AIM_get_info); /* version, last to attempt signon, protocol */
XS(XS_AIM_print); /* lemme figure this one out... */

/* list stuff */
XS(XS_AIM_buddy_list); /* all buddies */
XS(XS_AIM_online_list); /* online buddies */
XS(XS_AIM_deny_list); /* also returns permit list */

/* server stuff */
XS(XS_AIM_command); /* send command to server */
XS(XS_AIM_user_info); /* given name, return struct buddy members */
XS(XS_AIM_print_to_conv); /* send message to someone */
XS(XS_AIM_print_to_chat); /* send message to chat room */

/* handler commands */
XS(XS_AIM_add_event_handler); /* when servers talk */
XS(XS_AIM_add_timeout_handler); /* figure it out */

void xs_init()
{
	char *file = __FILE__;
	newXS ("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);
}

static char *escape_quotes(char *buf)
{
	static char *tmp_buf = NULL;
	char *i, *j;

	if (tmp_buf)
		g_free(tmp_buf);
	tmp_buf = g_malloc(strlen(buf) * 2 + 1);
	for (i = buf, j = tmp_buf; *i; i++, j++) {
		if (*i == '\'' || *i == '\\')
			*j++ = '\\';
		*j = *i;
	}
	*j = '\0';

	return (tmp_buf);
}

static SV *execute_perl(char *function, char *args)
{
	static char *perl_cmd = NULL;

	if (perl_cmd)
		g_free(perl_cmd);
	perl_cmd = g_malloc(strlen(function) + strlen(args) + 2 + 10);
	sprintf(perl_cmd, "&%s('%s')", function, escape_quotes(args));
#ifndef HAVE_PERL_EVAL_PV
	return (perl_eval_pv(perl_cmd, TRUE));
#else
	return (Perl_eval_pv(perl_cmd, TRUE));
#endif
}

int perl_load_file(char *script_name)
{
	SV *return_val;
	return_val = execute_perl("load_file", script_name);
	return SvNV (return_val);
}

void perl_init()
{
	char *perl_args[] = {"", "-e", "0"};
	char load_file[] =
"sub load_file()\n"
"{\n"
"	(my $file_name) = @_;\n"
"	open FH, $file_name or return 2;\n"
"	local($/) = undef;\n"
"	$file = <FH>;\n"
"	close FH;\n"
"	eval $file;\n"
"	eval $file if $@;\n"
"	return 1 if $@;\n"
"	return 0;\n"
"}";

	my_perl = perl_alloc();
	perl_construct(my_perl);
	perl_parse(my_perl, xs_init, 4, perl_args, NULL);
#ifndef HAVE_PERL_EVAL_PV
	perl_eval_pv(load_file, TRUE);
#else
	Perl_eval_pv(load_file, TRUE);
#endif

	newXS ("AIM::register", XS_AIM_register, "AIM");
	newXS ("AIM::get_info", XS_AIM_get_info, "AIM");
	newXS ("AIM::print", XS_AIM_print, "AIM");

	newXS ("AIM::buddy_list", XS_AIM_buddy_list, "AIM");
	newXS ("AIM::online_list", XS_AIM_online_list, "AIM");
	newXS ("AIM::deny_list", XS_AIM_deny_list, "AIM");

	newXS ("AIM::command", XS_AIM_command, "AIM");
	newXS ("AIM::user_info", XS_AIM_user_info, "AIM");
	newXS ("AIM::print_to_conv", XS_AIM_print_to_conv, "AIM");
	newXS ("AIM::print_to_chat", XS_AIM_print_to_chat, "AIM");

	newXS ("AIM::add_event_handler", XS_AIM_add_event_handler, "AIM");
	newXS ("AIM::add_timeout_handler", XS_AIM_add_timeout_handler, "AIM");
}

void perl_end()
{
	struct perlscript *scp;
	struct _perl_timeout_handlers *thn;
	struct _perl_event_handlers *ehn;

	while (perl_list) {
		scp = perl_list->data;
		perl_list = g_list_remove(perl_list, scp);
		if (scp->shutdowncallback[0])
			execute_perl(scp->shutdowncallback, "");
		g_free(scp->name);
		g_free(scp->version);
		g_free(scp->shutdowncallback);
		g_free(scp);
	}

	while (perl_timeout_handlers) {
		thn = perl_timeout_handlers->data;
		perl_timeout_handlers = g_list_remove(perl_timeout_handlers, thn);
		gtk_timeout_remove(thn->iotag);
		g_free(thn->handler_name);
		g_free(thn);
	}

	while (perl_event_handlers) {
		ehn = perl_event_handlers->data;
		perl_event_handlers = g_list_remove(perl_event_handlers, ehn);
		g_free(ehn->event_type);
		g_free(ehn->handler_name);
		g_free(ehn);
	}

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

XS (XS_AIM_register)
{
	char *name, *ver, *callback, *unused; /* exactly like X-Chat, eh? :) */
	int junk;
	struct perlscript *scp;
	dXSARGS;
	items = 0;

	name = SvPV (ST (0), junk);
	ver = SvPV (ST (1), junk);
	callback = SvPV (ST (2), junk);
	unused = SvPV (ST (3), junk);

	scp = g_new0(struct perlscript, 1);
	scp->name = g_strdup(name);
	scp->version = g_strdup(ver);
	scp->shutdowncallback = g_strdup(callback);
	perl_list = g_list_append(perl_list, scp);

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

XS (XS_AIM_get_info)
{
	int junk;
	dXSARGS;
	items = 0;

	switch(atoi(SvPV(ST(0), junk))) {
	case 0:
		XST_mPV(0, VERSION);
		break;
	case 1:
		XST_mPV(0, current_user->username);
		break;
	case 2:
		if (!blist)
			XST_mPV(0, "Offline");
		else if (!USE_OSCAR)
			XST_mPV(0, "TOC");
		else
			XST_mPV(0, "Oscar");
		break;
	default:
		XST_mPV(0, "Error2");
	}

	XSRETURN(1);
}

XS (XS_AIM_print)
{
	char *title;
	char *message;
	int junk;
	dXSARGS;
	items = 0;

	title = SvPV(ST(0), junk);
	message = SvPV(ST(1), junk);
	do_error_dialog(message, title);
	XSRETURN(0);
}

XS (XS_AIM_buddy_list)
{
	struct buddy *buddy;
	struct group *g;
	GList *list = groups;
	GList *mem;
	int i = 0;
	dXSARGS;
	items = 0;

	while (list) {
		g = (struct group *)list->data;
		mem = g->members;
		while (mem) {
			buddy = (struct buddy *)mem->data;
			XST_mPV(i++, buddy->name);
			mem = mem->next;
		}
		list = list->next;
	}
	XSRETURN(i);
}

XS (XS_AIM_online_list)
{
	struct buddy *b;
	struct group *g;
	GList *list = groups;
	GList *mem;
	int i = 0;
	dXSARGS;
	items = 0;

	while (list) {
		g = (struct group *)list->data;
		mem = g->members;
		while (mem) {
			b = (struct buddy *)mem->data;
			if (b->present) XST_mPV(i++, b->name);
			mem = mem->next;
		}
		list = list->next;
	}
	XSRETURN(i);
}

XS (XS_AIM_deny_list)
{
	char *name;
	GList *list = deny;
	int i = 0;
	dXSARGS;
	items = 0;

	while (list) {
		name = (char *)list->data;
		XST_mPV(i++, name);
		list = list->next;
	}
	XSRETURN(i);
}

XS (XS_AIM_command)
{
	int junk;
	char *command = NULL;
	dXSARGS;
	items = 0;

	command = SvPV(ST(0), junk);
	if (!command) XSRETURN(0);
	if        (!strncasecmp(command, "signon", 6)) {
		if (!blist) {
			show_login();
			dologin(0, 0);
		}
	} else if (!strncasecmp(command, "signoff", 7)) {
		signoff();
	} else if (!strncasecmp(command, "away", 4)) {
		char *message = SvPV(ST(1), junk);
		struct away_message a;
		g_snprintf(a.message, sizeof(a.message), "%s", message);
		do_away_message(NULL, &a);
	} else if (!strncasecmp(command, "back", 4)) {
		do_im_back();
	} else if (!strncasecmp(command, "idle", 4)) {
		serv_set_idle(atoi(SvPV(ST(1), junk)));
	} else if (!strncasecmp(command, "warn", 4)) {
		char *name = SvPV(ST(1), junk);
		serv_warn(name, 0);
	}

	XSRETURN(0);
}

XS (XS_AIM_user_info)
{
	int junk;
	struct buddy *buddy;
	char *nick;
	dXSARGS;
	items = 0;

	nick = SvPV(ST(0), junk);
	if (!nick[0])
		XSRETURN(0);
	buddy = find_buddy(nick);
	if (!buddy)
		XSRETURN(0);
	XST_mPV(0, buddy->name);
	XST_mPV(1, buddy->present ? "Online" : "Offline");
	XST_mIV(2, buddy->evil);
	XST_mIV(3, buddy->signon);
	XST_mIV(4, buddy->idle);
	XST_mIV(5, buddy->uc);
	XST_mIV(6, buddy->caps);
	XSRETURN(7);
}

XS (XS_AIM_print_to_conv)
{
	char *nick, *what;
	struct conversation *c;
	int junk;
	dXSARGS;
	items = 0;

	nick = SvPV(ST(0), junk);
	what = SvPV(ST(1), junk);
	c = find_conversation(nick);
	if (!c)
		c = new_conversation(nick);
	write_to_conv(c, what, WFLAG_SEND, NULL);
	serv_send_im(nick, what, 0);
}

XS (XS_AIM_print_to_chat)
{
	char *nick, *what;
	struct conversation *c = NULL;
	GList *bcs = buddy_chats;
	int junk;
	dXSARGS;
	items = 0;

	nick = SvPV(ST(0), junk);
	what = SvPV(ST(1), junk);
	while (bcs) {
		c = (struct conversation *)bcs->data;
		if (!strcmp(c->name, nick))
			break;
		bcs = bcs->next;
		c = NULL;
	}
	if (!c)
		XSRETURN(0);
	serv_chat_send(c->id, what);
}

static char *event_name(enum gaim_event event)
{
	static char buf[128];
	switch(event) {
		case event_signon:
			sprintf(buf, "event_signon");
			break;
		case event_signoff:
			sprintf(buf, "event_signoff");
			break;
		case event_away:
			sprintf(buf, "event_away");
			break;
		case event_back:
			sprintf(buf, "event_back");
			break;
		case event_im_recv:
			sprintf(buf, "event_im_recv");
			break;
		case event_im_send:
			sprintf(buf, "event_im_send");
			break;
		case event_buddy_signon:
			sprintf(buf, "event_buddy_signon");
			break;
		case event_buddy_signoff:
			sprintf(buf, "event_buddy_signoff");
			break;
		case event_buddy_away:
			sprintf(buf, "event_buddy_away");
			break;
		case event_buddy_back:
			sprintf(buf, "event_buddy_back");
			break;
		case event_blist_update:
			sprintf(buf, "event_blist_update");
			break;
		case event_chat_invited:
			sprintf(buf, "event_chat_invited");
			break;
		case event_chat_join:
			sprintf(buf, "event_chat_join");
			break;
		case event_chat_leave:
			sprintf(buf, "event_chat_leave");
			break;
		case event_chat_buddy_join:
			sprintf(buf, "event_chat_buddy_join");
			break;
		case event_chat_buddy_leave:
			sprintf(buf, "event_chat_buddy_leave");
			break;
		case event_chat_recv:
			sprintf(buf, "event_chat_recv");
			break;
		case event_chat_send:
			sprintf(buf, "event_chat_send");
			break;
		case event_warned:
			sprintf(buf, "event_warned");
			break;
		case event_error:
			sprintf(buf, "event_error");
			break;
		case event_quit:
			sprintf(buf, "event_quit");
			break;
		default:
			sprintf(buf, "event_unknown");
			break;
	}
}

int perl_event(enum gaim_event event, char *args)
{
	GList *handler;
	struct _perl_event_handlers *data;

	for (handler = perl_event_handlers; handler != NULL; handler = handler->next) {
		data = handler->data;
		if (!strcmp(event_name(event), data->event_type))
			execute_perl(args);
	}

	return 0;
}

XS (XS_AIM_add_event_handler)
{
	int junk;
	struct _perl_event_handlers *handler;
	dXSARGS;
	items = 0;

	handler = g_new0(struct _perl_event_handlers, 1);
	handler->event_type = g_strdup(SvPV(ST(0), junk));
	handler->handler_name = g_strdup(SvPV(ST(1), junk));
	perl_event_handlers = g_list_append(perl_event_handlers, handler);
	XSRETURN_EMPTY;
}

static int perl_timeout(struct _perl_timeout_handlers *handler)
{
	execute_perl(handler->handler_name, "");
	perl_timeout_handlers = g_list_remove(perl_timeout_handlers, handler);
	g_free(handler->handler_name);
	g_free(handler);

	return 0; /* returning zero removes the timeout handler */
}

XS (XS_AIM_add_timeout_handler)
{
	int junk;
	long timeout;
	struct _perl_timeout_handlers *handler;
	dXSARGS;
	items = 0;

	handler = g_new0(struct _perl_timeout_handlers, 1);
	timeout = atol(SvPV(ST(0), junk));
	handler->handler_name = g_strdup(SvPV(ST(1), junk));
	perl_timeout_handlers = g_list_append(perl_timeout_handlers, handler);
	handler->iotag = gtk_timeout_add(timeout, (GtkFunction)perl_timeout, handler);
	XSRETURN_EMPTY;
}

#endif /* USE_PERL */