[cvslog] Module eggdrop1.7: Change committed

cvslog cvs at tsss.org
Tue Oct 16 00:09:01 CST 2001


CVSROOT    : /usr/local/cvsroot
Module     : eggdrop1.7
Commit time: 2001-10-16 05:08:55 UTC
Commited by: stdarg <stdarg at techmonkeys.org>

Modified files:
     src/mod/tclscript.mod/tclscript.c

Added files:
     src/mod/perlscript.mod/perlscript.c

Log message:

Added a basic perl module.
Fixed a few things in tclscript.mod.

---------------------- diff included ----------------------
Index: eggdrop1.7/src/mod/perlscript.mod/perlscript.c
diff -u /dev/null eggdrop1.7/src/mod/perlscript.mod/perlscript.c:1.1
--- /dev/null	Tue Oct 16 00:08:55 2001
+++ eggdrop1.7/src/mod/perlscript.mod/perlscript.c	Tue Oct 16 00:08:45 2001
@@ -0,0 +1,287 @@
+#include <stdio.h>
+#include <stdlib.h>
+#include <EXTERN.h>
+#include <perl.h>
+#include <XSUB.h>
+#include "src/mod/module.h"
+#include "src/egglib/mstack.h"
+#include "src/egglib/msprintf.h"
+#include "src/script_api.h"
+
+#define MODULE_NAME "perlscript"
+
+static Function *global = NULL;
+
+static PerlInterpreter *ginterp; /* Our global interpreter. */
+
+typedef struct {
+	AV *result;
+} my_walking_data;
+
+static XS(my_command_handler);
+
+static int my_load_script(registry_entry_t * entry, char *fname)
+{
+	FILE *fp;
+	char *data;
+	int size, len;
+
+	/* Check the filename and make sure it ends in .pl */
+	len = strlen(fname);
+	if (len < 3 || fname[len-1] != 'l' || fname[len-2] != 'p' || fname[len-3] != '.') {
+		/* Nope, not ours. */
+		return(0);
+	}
+
+	fp = fopen(fname, "r");
+	if (!fp) return (0);
+	fseek(fp, 0, SEEK_END);
+	size = ftell(fp);
+	data = (char *)malloc(size + 1);
+	fseek(fp, 0, SEEK_SET);
+	fread(data, size, 1, fp);
+	data[size] = 0;
+	fclose(fp);
+	perl_eval_pv(data, TRUE);
+	free(data);
+	return(0);
+}
+
+static int my_create_cmd(void *ignore, script_command_t *info)
+{
+	char *cmdname;
+	CV *cv;
+
+	if (info->class && strlen(info->class)) {
+		cmdname = msprintf("%s_%s", info->class, info->name);
+	}
+	else {
+		malloc_strcpy(cmdname, info->name);
+	}
+	cv = newXS(cmdname, my_command_handler, "eggdrop");
+	XSANY.any_i32 = (int) info;
+	free(cmdname);
+
+	return (0);
+}
+
+static SV *my_resolve_variable(script_var_t *v)
+{
+	SV *result;
+
+	switch (v->type & SCRIPT_TYPE_MASK) {
+		case SCRIPT_INTEGER:
+			result = newSViv((int) v->value);
+			break;
+		case SCRIPT_STRING:
+		case SCRIPT_BYTES:
+			if (v->len == -1) v->len = strlen((char *)v->value);
+			result = newSVpv((char *)v->value, v->len);
+			if (v->type & SCRIPT_FREE) free(v->value);
+			break;
+
+/* Save for later when we do arrays again
+	else if (v->type & (SCRIPTING_ARRAY | SCRIPTING_VARRAY)) {
+		AV *array;
+		int i;
+
+		array = newAV();
+		for (i = 0; i < v->len; i++) {
+			SV *item;
+
+			if (v->type & SCRIPTING_ARRAY) item = my_resolve_variable(v->ptrarray[i]);
+			else item = my_resolve_variable(&v->varray[i]);
+			av_push(array, item);
+		}
+		result = newRV_noinc((SV *)array);
+	}
+end of array code */
+		case SCRIPT_POINTER: {
+			char str[32];
+			int str_len;
+
+			sprintf(str, "#%u", v->value);
+			str_len = strlen(str);
+			result = newSVpv(str, str_len);
+			break;
+		}
+		default:
+			result = &PL_sv_undef;
+	}
+	return(result);
+}
+
+static XS(my_command_handler)
+{
+	dXSARGS;
+	dXSI32;
+
+	/* Now we have an "items" variable for number of args and also an XSANY.any_i32 variable for client data. This isn't what you would call a "well documented" feature of perl heh. */
+
+	script_command_t *cmd = (script_command_t *) XSANY.any_i32;
+	script_var_t retval;
+	SV *result = NULL;
+	mstack_t *args;
+	int i, len, my_err;
+	char *syntax;
+	void **al;
+
+	/* Check for proper number of args. */
+	/* -1 means "any number" and implies pass_array. */
+	if (cmd->nargs >= 0 && cmd->nargs != items) {
+		Perl_croak(aTHX_ cmd->syntax_error);
+		return;
+	}
+
+	/* Initialize argstack. We want at least 5 items. */
+	args = mstack_new(2*items+5);
+
+	/* Callback's client data is first arg. */
+	mstack_push(args, cmd->client_data);
+
+	syntax = cmd->syntax;
+	for (i = 0; i < items; i++) {
+		switch (*syntax++) {
+			case SCRIPT_BYTES:	/* Byte-arrays. */
+			case SCRIPT_STRING: {
+				char *val;
+				val = SvPV(ST(i), len);
+				mstack_push(args, (void *)val);
+				break;
+			}
+			case SCRIPT_INTEGER: {	/* Integer. */
+				int val;
+				val = SvIV(ST(i));
+				mstack_push(args, (void *)val);
+				break;
+			}
+			case SCRIPT_CALLBACK:	/* Callback. */
+				/* No callbacks yet. */
+				mstack_push(args, NULL);
+				break;
+			case 'l':
+				/* Length of previous string or byte-array. */
+				mstack_push(args, (void *)len);
+				/* Doesn't take up a perl object. */
+				i--;
+				break;
+			case '*':
+				/* Repeat last entry. */
+				if (*(syntax - 2) == 'l') syntax -= 3;
+				else syntax -= 2;
+				i--; /* No perl object. */
+				break;
+			default:
+				goto argerror;
+		} /* End of switch. */
+	} /* End of for loop. */
+
+	/* Ok, now we have our arg stack. */
+
+	memset(&retval, 0, sizeof(retval));
+
+	al = (void **)args->stack; /* Argument list shortcut name. */
+
+	/* If they don't want their client data, bump the pointer. */
+	if (!(cmd->flags & SCRIPT_WANTS_CD)) {
+		al++;
+		args->len--;
+	}
+
+	if (cmd->flags & SCRIPT_COMPLEX) {
+		if (cmd->pass_array) cmd->callback(&retval, args->len, al);
+		else cmd->callback(&retval, al[0], al[1], al[2], al[3], al[4]);
+	}
+	else {
+		retval.type = cmd->retval_type;
+		retval.len = -1;
+		if (cmd->pass_array) retval.value = (void *)cmd->callback(args->len, al);
+		else retval.value = (void *)cmd->callback(al[0], al[1], al[2], al[3], al[4]);
+	}
+
+	my_err = retval.type & SCRIPT_ERROR;
+	result = my_resolve_variable(&retval);
+
+	mstack_destroy(args);
+
+	if (result) {
+		XSprePUSH;
+		PUSHs(result);
+		XSRETURN(1);
+	}
+	else {
+		XSRETURN_EMPTY;
+	}
+
+argerror:
+	mstack_destroy(args);
+	Perl_croak(aTHX_ cmd->syntax_error);
+}
+
+static registry_simple_chain_t my_functions[] = {
+	{"script", NULL, 0},
+	{"load script", my_load_script, 2},
+	{"create cmd", my_create_cmd, 2},
+	0
+};
+
+static void init_xs_stuff()
+{
+	extern void boot_DynaLoader();
+	newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, "eggdrop");
+}
+
+static Function journal_table[] = {
+        (Function)1, /* Version */
+        (Function)SCRIPT_EVENT_MAX, /* Our length */
+        my_load_script,
+	NULL,
+	NULL,
+	NULL,
+	NULL,
+	NULL,
+	NULL,
+        my_create_cmd,
+	NULL
+};
+
+static Function journal_playback;
+static void *journal_playback_h;
+
+EXPORT_SCOPE char *perlscript_LTX_start();
+static char *perlscript_close();
+
+static Function perlscript_table[] = {
+	(Function) perlscript_LTX_start,
+	(Function) perlscript_close,
+	(Function) 0,
+	(Function) 0
+};
+
+char *perlmodule_LTX_start(Function *global_funcs)
+{
+	char *embedding[] = {"", "-e", "0"};
+
+	global = global_funcs;
+	ginterp = perl_alloc();
+	perl_construct(ginterp);
+	perl_parse(ginterp, init_xs_stuff, 3, embedding, NULL);
+	registry_add_simple_chains(my_functions);
+        registry_lookup("script", "playback", &journal_playback, &journal_playback_h);
+        if (journal_playback) journal_playback(journal_playback_h, journal_table);
+
+	if (module_register("perlscript", perlscript_table, 107, 0)) {
+		module_undepend("perlscript");
+		return "This module requires eggdrop1.7.0 of later";
+	}
+
+	return(NULL);
+}
+
+static char *perlscript_close()
+{
+	perl_destruct(ginterp);
+	perl_free(ginterp);
+	module_undepend("perlscript");
+	return(NULL);
+}
Index: eggdrop1.7/src/mod/tclscript.mod/tclscript.c
diff -u eggdrop1.7/src/mod/tclscript.mod/tclscript.c:1.6 eggdrop1.7/src/mod/tclscript.mod/tclscript.c:1.7
--- eggdrop1.7/src/mod/tclscript.mod/tclscript.c:1.6	Mon Oct 15 21:42:33 2001
+++ eggdrop1.7/src/mod/tclscript.mod/tclscript.c	Tue Oct 16 00:08:45 2001
@@ -3,6 +3,8 @@
 #include "src/egglib/msprintf.h"
 #include "src/script_api.h"
 
+#define MODULE_NAME "tclscript"
+
 static Function *global = NULL;
 
 #if (TCL_MAJOR_VERSION > 8) || (TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION > 1)
@@ -32,15 +34,14 @@
 	int result;
 	int len;
 
-	/* Check the filename and make sure it ends in tcl */
+	/* Check the filename and make sure it ends in .tcl */
 	len = strlen(fname);
-	if (len < 3 || fname[len-1] != 'l' || fname[len-2] != 'c' || fname[len-3] != 't') {
+	if (len < 4 || fname[len-1] != 'l' || fname[len-2] != 'c' || fname[len-3] != 't' || fname[len-4] != '.') {
 		/* Nope, let someone else load it. */
 		return(0);
 	}
 
 	result = Tcl_EvalFile(ginterp, fname);
-	entry->action = REGISTRY_HALT;
 	return(0);
 }
 
@@ -376,7 +377,7 @@
 	else {
 		retval.type = cmd->retval_type;
 		retval.len = -1;
-		if (cmd->pass_array) retval.value = (void *)cmd->callback(&retval, argstack.args->len, al);
+		if (cmd->pass_array) retval.value = (void *)cmd->callback(argstack.args->len, al);
 		else retval.value = (void *)cmd->callback(al[0], al[1], al[2], al[3], al[4]);
 	}
 
----------------------- End of diff -----------------------



More information about the Changes mailing list