The perl patch is there again because the old one doesn't work with
the new string patch. You have to run autoconf and use the --with-perl
switch with configure. It seems that it requires perl 5.6 or 5.6.1 to
build. This has to be sorted out yet.
diff -ruN ../epic4-1.0.1/acconfig.h ./acconfig.h
--- ../epic4-1.0.1/acconfig.h Tue Dec 5 11:11:56 2000
+++ ./acconfig.h Thu Sep 20 09:56:20 2001
@@ -192,6 +192,11 @@
#undef Rlisten
#undef Rselect
+/*
+ * Perl support.
+ * /
+#undef PERL
+
/* Define this is DIRSIZ takes no argument */
#undef DIRSIZ_TAKES_NO_ARG
diff -ruN ../epic4-1.0.1/configure.in ./configure.in
--- ../epic4-1.0.1/configure.in Tue Dec 5 11:11:56 2000
+++ ./configure.in Thu Sep 20 09:56:20 2001
@@ -366,6 +366,32 @@
)
dnl ----------------------------------------------------------
+dnl
+dnl Perl support?
+dnl
+
+AC_MSG_CHECKING(whether to support Perl)
+AC_ARG_WITH(perl,
+[ --with-perl[=PATH] Compile with perl support.],
+[ case "$withval" in
+ no)
+ AC_MSG_RESULT(no)
+ ;;
+ *)
+ if test "x$withval" != "xyes"; then
+ LIBS="$LIBS -L$withval"
+ fi
+
+ AC_MSG_RESULT(yes)
+ LIBS="$LIBS `perl -MExtUtils::Embed -e ldopts`"
+ PERLDOTOH="perl.o"
+ AC_DEFINE(PERL)
+ ;;
+ esac ],
+ AC_MSG_RESULT(no)
+)
+
+dnl ----------------------------------------------------------
dnl ----------------------------------------------------------
dnl
dnl closing stuff
@@ -381,6 +407,7 @@
if test -z "$CFLAGS"; then CFLAGS=-g -O; fi
if test -z "$LDFLAGS"; then LDFLAGS= ; fi
+if test -z "$PERLDOTOH"; then PERLDOTOH= ; fi
if test -z "$bindir"; then bindir=\${prefix}/bin; fi
if test -z "$libdir"; then libdir=\${prefix}/lib; fi
if test -z "$irclibdir"; then irclibdir=\${libdir}/irc; fi
@@ -414,6 +441,7 @@
AC_SUBST(CFLAGS)
AC_SUBST(LDFLAGS)
+AC_SUBST(PERLDOTOH)
AC_SUBST(bindir)
AC_SUBST(irclibdir)
AC_SUBST(libexecdir)
diff -ruN ../epic4-1.0.1/include/array.h ./include/array.h
--- ../epic4-1.0.1/include/array.h Tue Dec 5 11:11:57 2000
+++ ./include/array.h Thu Sep 20 09:56:20 2001
@@ -31,3 +31,9 @@
char * function_gettmatch (char *);
#endif
+
+typedef struct an_array_struct {
+ char **item;
+ long *index;
+ long size;
+} an_array;
diff -ruN ../epic4-1.0.1/include/defs.h.in ./include/defs.h.in
--- ../epic4-1.0.1/include/defs.h.in Tue Dec 5 11:11:57 2000
+++ ./include/defs.h.in Thu Sep 20 09:56:20 2001
@@ -181,6 +181,11 @@
#undef Rlisten
#undef Rselect
+/*
+ * Perl support.
+ */
+#undef PERL
+
/* Define this if you have setsid() */
#undef HAVE_SETSID
diff -ruN ../epic4-1.0.1/source/Makefile.in ./source/Makefile.in
--- ../epic4-1.0.1/source/Makefile.in Thu Mar 15 07:01:46 2001
+++ ./source/Makefile.in Thu Sep 20 09:56:20 2001
@@ -17,7 +17,7 @@
ircsig.o keys.o lastlog.o list.o log.o mail.o names.o network.o \
newio.o notice.o notify.o numbers.o output.o parse.o queue.o reg.o \
screen.o server.o status.o term.o timer.o vars.o who.o window.o \
- words.o @ALLOCA@
+ words.o @PERLDOTOH@ @ALLOCA@
INCLUDES = -I@srcdir@/../include -I../include
@@ -73,6 +73,9 @@
screen.o: Makefile ../Makefile
$(CC) $(CFLAGS) $(ANSIFLAGS) $(INCLUDES) -c @srcdir@/screen.c \
-DWSERV_PATH=\"$(INSTALL_WSERV)\"
+
+perl.o: perl.c Makefile ../Makefile
+ $(CC) $(CFLAGS) $(ansiflags) $(INCLUDES) -c perl.c `perl -MExtUtils::Embed -e
+ccopts`
#
diff -ruN ../epic4-1.0.1/source/array.c ./source/array.c
--- ../epic4-1.0.1/source/array.c Tue Dec 5 11:11:56 2000
+++ ./source/array.c Thu Sep 20 09:56:20 2001
@@ -173,11 +173,13 @@
#define ARRAY_THRESHOLD 100
+#if 0
typedef struct an_array_struct {
char **item;
long *index;
long size;
} an_array;
+#endif
static an_array array_info = {
(char **) 0,
@@ -356,6 +358,63 @@
}
/*
+ * This was once the inner loop of SETITEM.
+ * The documentation for it still applies.
+ */
+int set_item (char* name, long item, char* input)
+{
+ long index = 0;
+ long oldindex;
+ an_array *array;
+ int result = -1;
+ if (array_info.size && ((index = find_item(array_info, name)) >= 0))
+ {
+ array = &array_array[array_info.index[index]];
+ result = -2;
+ if (item < array->size)
+ {
+ oldindex = find_index(array, item);
+ index = find_item(*array, input);
+ index = (index >= 0) ? index : (-index) - 1;
+ move_index(array, oldindex, index);
+ new_free(&array->item[item]);
+ malloc_strcpy(&array->item[item], input);
+ result = 0;
+ }
+ else if (item == array->size)
+ {
+ RESIZE(array->item, char *, array->size + 1);
+ array->item[item] = (char *) 0;
+ malloc_strcpy(&array->item[item], input);
+ index = find_item(*array, input);
+ index = (index >= 0) ? index : (-index) - 1;
+ insert_index(&array->index, &array->size, index);
+ result = 2;
+ }
+ }
+ else
+ {
+ if (item == 0)
+ {
+ RESIZE(array_array, an_array, array_info.size + 1);
+ array = &array_array[array_info.size];
+ array->size = 1;
+ array->item = (char **)new_malloc(sizeof(char *));
+ array->index = (long *)new_malloc(sizeof(long));
+ array->item[0] = (char*) 0;
+ array->index[0] = 0;
+ malloc_strcpy(&array->item[0], input);
+ RESIZE(array_info.item, char *, array_info.size + 1);
+ array_info.item[array_info.size] = (char *) 0;
+ malloc_strcpy(&array_info.item[array_info.size], name);
+ insert_index(&array_info.index, &array_info.size, (-index) -
+1);
+ result = 1;
+ }
+ }
+ return result;
+}
+
+/*
* Now for the actual alias functions
* ==================================
*/
@@ -615,9 +674,6 @@
char *name = (char *) 0;
char *itemstr = (char *) 0;
long item;
- long index = 0;
- long oldindex;
- an_array *array;
int result = -1;
if ((name = next_arg(input, &input)))
@@ -628,50 +684,7 @@
if (item >= 0)
{
upper(name);
- if (array_info.size && ((index = find_item(array_info,
name)) >= 0))
- {
- array = &array_array[array_info.index[index]];
- result = -2;
- if (item < array->size)
- {
- oldindex = find_index(array, item);
- index = find_item(*array, input);
- index = (index >= 0) ? index :
(-index) - 1;
- move_index(array, oldindex, index);
- new_free(&array->item[item]);
- malloc_strcpy(&array->item[item],
input);
- result = 0;
- }
- else if (item == array->size)
- {
- RESIZE(array->item, char *,
array->size + 1);
- array->item[item] = (char *) 0;
- malloc_strcpy(&array->item[item],
input);
- index = find_item(*array, input);
- index = (index >= 0) ? index :
(-index) - 1;
- insert_index(&array->index,
&array->size, index);
- result = 2;
- }
- }
- else
- {
- if (item == 0)
- {
- RESIZE(array_array, an_array,
array_info.size + 1);
- array = &array_array[array_info.size];
- array->size = 1;
- array->item = (char
**)new_malloc(sizeof(char *));
- array->index = (long
*)new_malloc(sizeof(long));
- array->item[0] = (char*) 0;
- array->index[0] = 0;
- malloc_strcpy(&array->item[0], input);
- RESIZE(array_info.item, char *,
array_info.size + 1);
- array_info.item[array_info.size] =
(char *) 0;
-
malloc_strcpy(&array_info.item[array_info.size], name);
- insert_index(&array_info.index,
&array_info.size, (-index) - 1);
- result = 1;
- }
- }
+ result = set_item(name, item, input);
}
}
}
diff -ruN ../epic4-1.0.1/source/functions.c ./source/functions.c
--- ../epic4-1.0.1/source/functions.c Wed Mar 21 06:42:58 2001
+++ ./source/functions.c Thu Sep 20 09:56:20 2001
@@ -244,6 +244,11 @@
*function_pad (char *),
*function_pattern (char *),
*function_pass (char *),
+#ifdef PERL
+ *function_perl (char *),
+ *function_perlcall (char *),
+ *function_perlxcall (char *),
+#endif
*function_prefix (char *),
*function_printlen (char *),
*function_querywin (char *),
@@ -472,6 +477,11 @@
{ "PAD", function_pad },
{ "PASS", function_pass },
{ "PATTERN", function_pattern },
+#ifdef PERL
+ { "PERL", function_perl },
+ { "PERLCALL", function_perlcall },
+ { "PERLXCALL", function_perlxcall },
+#endif
{ "PID", function_pid },
{ "POP", function_pop },
{ "PPID", function_ppid },
@@ -5868,3 +5878,32 @@
return m_sprintf("%f", (double)tan(num));
}
+#ifdef PERL
+
+BUILT_IN_FUNCTION(function_perl, input)
+{
+ extern char* perleval ( const char* );
+ return perleval ( input );
+}
+
+BUILT_IN_FUNCTION(function_perlcall, input)
+{
+ char *sub=NULL;
+ extern char* perlcall ( const char*, char*, char*, long, char* );
+ GET_STR_ARG(sub, input);
+ return perlcall ( sub, NULL, NULL, -1, input );
+}
+
+BUILT_IN_FUNCTION(function_perlxcall, input)
+{
+ long item=0;
+ char *sub=NULL, *in=NULL, *out=NULL;
+ extern char* perlcall ( const char*, char*, char*, long, char* );
+ GET_STR_ARG(sub, input);
+ if (input && *input) GET_STR_ARG(in, input);
+ if (input && *input) GET_STR_ARG(out, input);
+ if (input && *input) GET_INT_ARG(item, input);
+ return perlcall ( sub, in, out, item, input );
+}
+
+#endif
diff -ruN ../epic4-1.0.1/source/irc.c ./source/irc.c
--- ../epic4-1.0.1/source/irc.c Wed Apr 18 03:20:30 2001
+++ ./source/irc.c Thu Sep 20 09:56:20 2001
@@ -236,6 +236,9 @@
char buffer[BIG_BUFFER_SIZE];
char * sub_format;
int old_window_display = window_display;
+#ifdef PERL
+ extern void perlstartstop(int);
+#endif
/*
* If we get called recursively, something is hosed.
@@ -276,6 +279,9 @@
/* Do some clean up */
do_hook(EXIT_LIST, "%s", buffer);
+#ifdef PERL
+ perlstartstop(0); /* In case there's perl code in the exit hook. */
+#endif
close_all_servers(buffer);
logger(0);
clean_up_processes();
diff -ruN ../epic4-1.0.1/source/perl.c ./source/perl.c
--- ../epic4-1.0.1/source/perl.c Thu Jan 1 10:00:00 1970
+++ ./source/perl.c Thu Sep 20 09:56:20 2001
@@ -0,0 +1,157 @@
+#include "irc.h"
+#include "ircaux.h"
+#include "array.h"
+#include <EXTERN.h>
+#include <perl.h>
+#include <XSUB.h>
+
+int isperlrunning=0, perlcalldepth=0;
+PerlInterpreter *my_perl;
+
+EXTERN_C void xs_init (pTHXo);
+EXTERN_C void boot_DynaLoader (pTHXo_ CV* cv);
+
+#define RETURN_MSTR(x) return ((x) ? (x) : "");
+#define SV2STR(x,y) (y)=(void*)m_strdup(SvPV_nolen(x))
+
+static XS (XS_cmd) {
+ unsigned foo;
+ dXSARGS;
+ for (foo=0; foo<items; foo++) {
+ parse_line(NULL, "$*", SvPV_nolen(ST(foo)), 0, 0);
+ }
+ XSRETURN(0);
+}
+
+static XS (XS_eval) {
+ unsigned foo;
+ dXSARGS;
+ for (foo=0; foo<items; foo++) {
+ parse_line(NULL, SvPV_nolen(ST(foo)), "", 0, 0);
+ }
+ XSRETURN(0);
+}
+
+static XS (XS_expr) {
+ unsigned foo;
+ char* retval=NULL;
+ dXSARGS;
+ for (foo=0; foo<items; foo++) {
+ retval=(char*)parse_inline(LOCAL_COPY(SvPV_nolen(ST(foo))), "", 0);
+ XST_mPV(foo, retval);
+ new_free(&retval);
+ }
+ XSRETURN(items);
+}
+
+static XS (XS_yell) {
+ unsigned foo;
+ char* retval=NULL;
+ dXSARGS;
+ for (foo=0; foo<items; foo++) {
+ yell("Perl: %s",SvPV_nolen(ST(foo)));
+ }
+ XSRETURN(items);
+}
+
+EXTERN_C void
+xs_init(pTHXo)
+{
+ char *file = __FILE__;
+ dXSUB_SYS;
+
+ /* DynaLoader is a special case */
+ newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);
+ newXS("EPIC::cmd", XS_cmd, "IRC");
+ newXS("EPIC::eval", XS_eval, "IRC");
+ newXS("EPIC::expr", XS_expr, "IRC");
+ newXS("EPIC::yell", XS_yell, "IRC");
+}
+
+/* Stopping has one big memory leak right now, so it's not used. */
+void perlstartstop (int startnotstop) {
+ if (startnotstop && !isperlrunning) {
+ char *embedding[] = {
+ "", "-e",
+ "$SIG{__DIE__}=$SIG{__WARN__}=\\&EPIC::yell;"
+ };
+ ++isperlrunning;
+ my_perl = perl_alloc();
+ perl_construct( my_perl );
+ perl_parse(my_perl, xs_init, 3, embedding, NULL);
+ if (SvTRUE(ERRSV)) yell("perl_parse: %s", SvPV_nolen(ERRSV));
+ perl_run(my_perl);
+ if (SvTRUE(ERRSV)) yell("perl_run: %s", SvPV_nolen(ERRSV));
+ } else if (!startnotstop && isperlrunning && !perlcalldepth) {
+ perl_destruct(my_perl);
+ if (SvTRUE(ERRSV)) yell("perl_destruct: %s", SvPV_nolen(ERRSV));
+ perl_free(my_perl);
+ if (SvTRUE(ERRSV)) yell("perl_free: %s", SvPV_nolen(ERRSV));
+ isperlrunning=0;
+ }
+}
+
+char* perlcall (const char* sub, char* in, char* out, long item, char* input) {
+ char *retval=NULL;
+ int count, foo;
+ an_array *array;
+ extern an_array* get_array (char *);
+ extern int set_item(char*, long, char*);
+ dSP ;
+ if (!isperlrunning){RETURN_MSTR(retval);}
+ ++perlcalldepth;
+ ENTER; SAVETMPS;
+ PUSHMARK(SP);
+ if (input && *input) XPUSHs(sv_2mortal(newSVpv(input, 0)));
+ if (in && *in && (array=get_array(in))) {
+ for (foo=0; foo<array->size; foo++) {
+ XPUSHs(sv_2mortal(newSVpv(array->item[foo], 0)));
+ }
+ }
+ PUTBACK ;
+ if (out && *out) {
+ long size;
+ upper(out);
+ size=(array=get_array(out))?array->size:0;
+ if (0>item) item=size-~item;
+ if (item>size) item=-1;
+ } else {
+ item=-1;
+ }
+ if (0<=item) {
+ I32 ax;
+ count = call_pv(sub, G_EVAL|G_ARRAY);
+ SPAGAIN ;
+ SP -= count ;
+ ax = (SP - PL_stack_base) + 1 ;
+ for (foo=0; foo<count; foo++) {
+ set_item(out, item+foo, SvPV_nolen(ST(foo)));
+ }
+ retval=(void*)new_realloc((void**)(&retval),32);
+ snprintf(retval,31,"%u",count);
+ } else {
+ SV *sv;
+ count = call_pv(sub, G_EVAL|G_SCALAR);
+ SPAGAIN ; sv=POPs ;
+ SV2STR(sv,retval);
+ }
+ PUTBACK ;
+ FREETMPS; LEAVE;
+ --perlcalldepth;
+ RETURN_MSTR(retval);
+}
+
+char* perleval (const char* input) {
+ char *retval=NULL;
+ if (input && *input) {
+ SV *sv;
+ perlstartstop(1);
+ ++perlcalldepth;
+ ENTER; SAVETMPS;
+ sv=eval_pv(input, FALSE);
+ SV2STR(sv,retval);
+ FREETMPS; LEAVE;
+ --perlcalldepth;
+ };
+ RETURN_MSTR(retval);
+}
