diff --git a/.gitattributes b/.gitattributes
index 3b237b0807f1ce34f0019167f3d3c682ba784208..3d66b4bc0880f0df4f802b214bfd87366bc8d08e 100644
--- a/.gitattributes
+++ b/.gitattributes
@@ -310,6 +310,7 @@ testfont binary
/src/modules/Perl/Makefile.in foreign_ident
/src/modules/Perl/acconfig.h foreign_ident
/src/modules/Perl/configure.in foreign_ident
+/src/modules/Perl/perlmod.c foreign_ident
/src/modules/Pipe/Makefile.in foreign_ident
/src/modules/Pipe/acconfig.h foreign_ident
/src/modules/Pipe/configure.in foreign_ident
diff --git a/src/modules/Perl/perlmod.c b/src/modules/Perl/perlmod.c
index 6559f48c4fa2d5873cd579f9e96bd438fb854bb7..54f07c975c0866a6b0870d5d0ff427e6aafbb30f 100644
--- a/src/modules/Perl/perlmod.c
+++ b/src/modules/Perl/perlmod.c
@@ -1,3 +1,6 @@
+/* $Id: perlmod.c,v 1.12 2000/03/14 21:33:24 leif Exp $ */
+
+#include "builtin_functions.h"
#include "global.h"
#include "svalue.h"
#include "array.h"
@@ -8,6 +11,9 @@
#include "mapping.h"
#include "perl_machine.h"
+ /* this is just for debugging */
+#define _sv_2mortal(x) (x)
+
#ifdef HAVE_PERL
#include <EXTERN.h>
@@ -28,59 +34,122 @@ struct perlmod_storage
char **env;
char *env_block;
struct array *argv_strings;
- int parsed;
+ int constructed, parsed;
+ int array_size_limit;
PerlInterpreter *my_perl;
};
#define THIS ((struct perlmod_storage *)(fp->current_storage))
#define PERL THIS->my_perl
+/* since both Perl and Pike likes to use "sp" as a stack pointer,
+ * let's define some Pike macros as functions...
+ */
+static void _push_int(INT32 i) { push_int(i);}
+static void _push_float(float f) { push_float(f);}
+static void _push_string(struct pike_string *s) { push_string(s);}
+static void _push_array(struct array *a) { push_array(a);}
+static void _pop_n_elems(int n) { pop_n_elems(n);}
+static struct svalue *_pikesp() { return Pike_sp;}
+static void _pike_pop() { --sp;}
+#undef sp
+
+#ifndef BLOCKING
+
+#define MT_PERMIT THREADS_ALLOW(); mt_lock(&perl_running);
+#define MT_FORBID mt_unlock(&perl_running); THREADS_DISALLOW();
+
+#endif
+
+/* utility function: push a zero_type zero */
+static void _push_zerotype()
+{ push_int(0);
+ Pike_sp[-1].subtype = 1;
+}
+
+static SV * _pikev2sv(struct svalue *s)
+{ switch (s->type)
+ { case T_INT:
+ return newSViv(s->u.integer); break;
+ case T_FLOAT:
+ return newSVnv(s->u.float_number); break;
+ case T_STRING:
+ if (s->u.string->size_shift) break;
+ return newSVpv(s->u.string->str, s->u.string->len); break;
+ }
+ error("Unsupported value type.\n");
+ return 0;
+}
+
+static void _sv_to_svalue(SV *sv, struct svalue *sval)
+{ if (sv && (SvOK(sv)))
+ { if (SvIOKp(sv))
+ { sval->type = T_INT; sval->subtype = 0;
+ sval->u.integer = SvIV(sv);
+ return;
+ }
+ else if (SvNOKp(sv))
+ { sval->type = T_FLOAT; sval->subtype = 0;
+ sval->u.float_number = SvNV(sv);
+ return;
+ }
+ else if (SvPOKp(sv))
+ { sval->type = T_STRING; sval->subtype = 0;
+ sval->u.string = make_shared_binary_string(SvPVX(sv), SvCUR(sv));
+ return;
+ }
+ }
+ sval->type = T_INT; sval->u.integer = 0;
+ sval->subtype = !sv; /* zero-type zero if NULL pointer */
+}
+
+static void _pikepush_sv(SV *sv)
+{ if (!SvOK(sv))
+ _push_int(0);
+ else if (SvIOKp(sv))
+ _push_int(SvIV(sv));
+ else if (SvNOKp(sv))
+ _push_float((float)(SvNV(sv)));
+ else if (SvPOKp(sv))
+ _push_string(make_shared_binary_string(SvPVX(sv), SvCUR(sv)));
+ else
+ _push_int(0);
+}
+
+
static void init_perl_glue(struct object *o)
-{
- PerlInterpreter *p;
- THIS->argv=0;
- THIS->env=0;
- THIS->env_block=0;
- THIS->argv_strings=0;
- THIS->parsed=0;
+{ PerlInterpreter *p;
+
+#ifdef PIKE_PERLDEBUG
+ fprintf(stderr, "[init_perl_glue]\n");
+#endif
+
+ THIS->argv = 0;
+ THIS->env = 0;
+ THIS->env_block = 0;
+ THIS->argv_strings = 0;
+ THIS->constructed = 0;
+ THIS->parsed = 0;
+ THIS->array_size_limit = 500;
#ifndef MULTIPLICITY
if(num_perl_interpreters>0)
{
PERL=0;
fprintf(stderr,"num_perl_interpreters=%d\n",num_perl_interpreters);
-/* error("Perl: There can be only one!\n"); */
+ /* error("Perl: There can be only one!\n"); */
return;
}
#endif
- THREADS_ALLOW();
- mt_lock(&perl_running);
+ MT_PERMIT;
p=perl_alloc();
- mt_unlock(&perl_running);
- THREADS_DISALLOW();
+ MT_FORBID;
PERL=p;
if(p) num_perl_interpreters++;
}
-static void exit_perl_glue(struct object *o)
-{
- if(PERL)
- {
- struct perlmod_storage *storage=THIS;
-
- THREADS_ALLOW();
- mt_lock(&perl_running);
- if(storage->parsed)
- {
- perl_destruct(storage->my_perl);
- storage->parsed=0;
- }
- perl_free(storage->my_perl);
- mt_unlock(&perl_running);
- THREADS_DISALLOW();
- num_perl_interpreters--;
- }
- if(THIS->argv)
+static void _free_arg_and_env()
+{ if(THIS->argv)
{
free((char *)THIS->argv);
THIS->argv=0;
@@ -102,42 +171,69 @@ static void exit_perl_glue(struct object *o)
}
}
-static void perlmod_run(INT32 args)
+static void exit_perl_glue(struct object *o)
{
- INT32 i;
- PerlInterpreter *p=PERL;
- if(!p) error("No perl interpreter available.\n");
- pop_n_elems(args);
+#ifdef PIKE_PERLDEBUG
+ fprintf(stderr, "[exit_perl_glue]\n");
+#endif
- if(!THIS->argv_strings)
- error("Perl->create() must be called first.\n");
+ if(PERL)
+ {
+ struct perlmod_storage *storage=THIS;
- THREADS_ALLOW();
- mt_lock(&perl_running);
- i=perl_run(p);
- mt_unlock(&perl_running);
- THREADS_DISALLOW();
- push_int(i);
+ MT_PERMIT;
+ if(storage->constructed)
+ {
+ perl_destruct(storage->my_perl);
+ storage->constructed=0;
+ }
+ perl_free(storage->my_perl);
+ MT_FORBID;
+ num_perl_interpreters--;
+ }
+ _free_arg_and_env();
}
static void perlmod_create(INT32 args)
+{ PerlInterpreter *p=PERL;
+ struct perlmod_storage *storage=THIS;
+
+#ifdef PIKE_PERLDEBUG
+ fprintf(stderr, "[perlmod_create, %d args]\n", args);
+#endif
+
+ if (args != 0) error("Perl->create takes no arguments.");
+ if(!p) error("No perl interpreter available.\n");
+
+ MT_PERMIT;
+ if(!storage->constructed)
+ { perl_construct(p);
+ storage->constructed++;
+ }
+ MT_FORBID;
+ pop_n_elems(args);
+ push_int(0);
+}
+
+static void perlmod_parse(INT32 args)
{
extern void xs_init(void);
int e;
struct mapping *env_mapping=0;
PerlInterpreter *p=PERL;
struct perlmod_storage *storage=THIS;
+
+#ifdef PIKE_PERLDEBUG
+ fprintf(stderr, "[perlmod_parse, %d args]\n", args);
+#endif
- check_all_args("Perl->create",args,BIT_ARRAY, BIT_MAPPING|BIT_VOID, 0);
+ check_all_args("Perl->parse",args,BIT_ARRAY, BIT_MAPPING|BIT_VOID, 0);
if(!p) error("No perl interpreter available.\n");
- if(THIS->argv_strings)
- error("Perl->create() can only be called once.\n");
-
switch(args)
{
default:
- env_mapping=sp[1-args].u.mapping;
+ env_mapping = Pike_sp[1-args].u.mapping;
mapping_fix_type_field(env_mapping);
if(m_ind_types(env_mapping) & ~BIT_STRING)
@@ -146,15 +242,20 @@ static void perlmod_create(INT32 args)
error("Bad argument 2 to Perl->create().\n");
case 1:
- THIS->argv_strings=sp[-args].u.array;
+ if (THIS->argv_strings || THIS->env_block)
+ { /* if we have already setup args/env, free the old values now */
+ _free_arg_and_env();
+ }
+
+ THIS->argv_strings = Pike_sp[-args].u.array;
add_ref(THIS->argv_strings);
array_fix_type_field(THIS->argv_strings);
if(THIS->argv_strings->size<2)
- error("Perl: Too few elements in argv array.\n");
+ error("Perl: Too few elements in argv array.\n");
if(THIS->argv_strings->type_field & ~BIT_STRING)
- error("Bad argument 1 to Perl->create().\n");
+ error("Bad argument 1 to Perl->parse().\n");
}
THIS->argv=(char **)xalloc(sizeof(char *)*THIS->argv_strings->size);
@@ -189,7 +290,9 @@ static void perlmod_create(INT32 args)
*(env_blockp++)=0;
}
THIS->env[d]=0;
- } else {
+ }
+ else
+ {
/* Perl likes to be able to write in the environment block,
* give it it's own copy to protect ourselves.. /Hubbe
*/
@@ -225,58 +328,457 @@ static void perlmod_create(INT32 args)
THIS->env[d]=0;
}
- THREADS_ALLOW();
- mt_lock(&perl_running);
- if(!storage->parsed)
- {
- perl_construct(p);
- storage->parsed++;
- }
+
+ THIS->parsed++;
+
+ MT_PERMIT;
e=perl_parse(p,
xs_init,
storage->argv_strings->size,
storage->argv,
storage->env);
- mt_unlock(&perl_running);
- THREADS_DISALLOW();
+ MT_FORBID;
pop_n_elems(args);
push_int(e);
}
-static void perlmod_eval(INT32 args)
+static void perlmod_run(INT32 args)
{
- error("Perl->eval not yet implemented.\n");
+ INT32 i;
+ PerlInterpreter *p=PERL;
+ if(!p) error("No perl interpreter available.\n");
+ pop_n_elems(args);
+
+ if(!THIS->constructed || !THIS->parsed)
+ error("No Perl program loaded (run() called before parse()).\n");
+
+ MT_PERMIT;
+ i=perl_run(p);
+ MT_FORBID;
+
+ push_int(i);
+}
+
+static void _perlmod_eval(INT32 args, int perlflags)
+{ PerlInterpreter *p = PERL;
+ struct pike_string *arg1;
+ struct perlmod_storage *storage = THIS;
+ int i, n;
+#define sp _perlsp
+ dSP;
+
+ if (!p) error("Perl interpreter not available.\n");
+
+ check_all_args("Perl->eval", args, BIT_STRING, 0);
+ arg1 = _pikesp()[-args].u.string;
+
+ ENTER;
+ SAVETMPS;
+ PUSHMARK(sp);
+
+ PUTBACK;
+#undef sp
+ MT_PERMIT;
+
+ if (!storage->parsed)
+ { static char *dummyargv[] = { "perl", "-e", "1", 0 };
+ extern void xs_init(void);
+ perl_parse(p, xs_init, 3, dummyargv, NULL);
+ storage->parsed++;
+ }
+
+ n = perl_eval_sv(newSVpv(arg1->str, arg1->len), perlflags | G_EVAL);
+
+ MT_FORBID;
+
+ _pop_n_elems(args);
+
+#define sp _perlsp
+ SPAGAIN;
+
+ if (SvTRUE(GvSV(errgv)))
+ { char errtmp[256];
+ memset(errtmp, 0, sizeof(errtmp));
+ strcpy(errtmp, "Error from Perl: ");
+ strncpy(errtmp+strlen(errtmp), SvPV(GvSV(errgv), na), 254-strlen(errtmp));
+ POPs;
+ PUTBACK; FREETMPS; LEAVE;
+ error(errtmp);
+ }
+
+ if (perlflags & G_ARRAY)
+ { struct array *a = allocate_array(n);
+ for(i = 0; i < n; ++i)
+ _sv_to_svalue(POPs, &(a->item[(n-1)-i]));
+ _push_array(a);
+ }
+ else if (n > 0)
+ { for(; n > 1; --n) POPs;
+ _pikepush_sv(POPs);
+ }
+ else _push_zerotype();
+
+ PUTBACK; FREETMPS; LEAVE;
+#undef sp
+}
+
+static void perlmod_eval(INT32 args)
+ { return _perlmod_eval(args, G_SCALAR);}
+
+static void perlmod_eval_list(INT32 args)
+ { return _perlmod_eval(args, G_ARRAY);}
+
+static void _perlmod_call(INT32 args, int perlflags)
+{ PerlInterpreter *p = PERL;
+ int i, n; char *pv;
+#define sp _perlsp
+ dSP;
+
+#ifdef PIKE_PERLDEBUG
+ fprintf(stderr, "[perlmod_call: args=%d]\n", args);
+#endif
+
+ if (!p) error("No perl interpreter available.\n");
+
+ if (args < 1) error("Too few arguments.\n");
+ if (args > 201) error("Too many arguments.\n");
+
+ if (_pikesp()[-args].type != T_STRING ||
+ _pikesp()[-args].u.string->size_shift)
+ error("bad Perl function name (must be an 8-bit string)");
+
+ ENTER;
+ SAVETMPS;
+ PUSHMARK(sp);
+
+ for(n = 1; n < args; ++n)
+ { struct svalue *s = &(_pikesp()[n-args]);
+ char *msg;
+ switch (s->type)
+ { case T_INT:
+ XPUSHs(sv_2mortal(newSViv(s->u.integer)));
+ break;
+ case T_FLOAT:
+ XPUSHs(sv_2mortal(newSVnv((double)(s->u.float_number))));
+ break;
+ case T_STRING:
+ if (s->u.string->size_shift)
+ { PUTBACK; FREETMPS; LEAVE;
+ error("widestrings not supported in Pike-to-Perl call interface");
+ return;
+ }
+ XPUSHs(sv_2mortal(newSVpv(s->u.string->str, s->u.string->len)));
+ break;
+ case T_MAPPING:
+ msg = "Mapping argument not allowed here.\n"; if (0)
+ case T_OBJECT:
+ msg = "Object argument not allowed here.\n"; if (0)
+ case T_MULTISET:
+ msg = "Multiset argument not allowed here.\n"; if (0)
+ case T_ARRAY:
+ msg = "Array argument not allowed here.\n"; if (0)
+ default:
+ msg = "Unsupported argument type.\n";
+ PUTBACK; FREETMPS; LEAVE;
+ error(msg);
+ return;
+ }
+ }
+ PUTBACK;
+
+ pv = Pike_sp[-args].u.string->str;
+#undef sp
+ MT_PERMIT;
+
+ n = perl_call_pv(pv, perlflags);
+
+ MT_FORBID;
+#define sp _perlsp
+
+ _pop_n_elems(args);
+
+ SPAGAIN;
+
+ if (SvTRUE(GvSV(errgv)))
+ { char errtmp[256];
+ memset(errtmp, 0, sizeof(errtmp));
+ strcpy(errtmp, "Error from Perl: ");
+ strncpy(errtmp+strlen(errtmp), SvPV(GvSV(errgv), na), 254-strlen(errtmp));
+ POPs;
+ PUTBACK; FREETMPS; LEAVE;
+ error(errtmp);
+ }
+
+ if (n < 0)
+ { PUTBACK; FREETMPS; LEAVE;
+ error("Internal error: perl_call_pv returned a negative number.\n");
+ }
+
+ if (!(perlflags & G_ARRAY) && n > 1)
+ while (n > 1) --n, POPs;
+
+ if (n > THIS->array_size_limit)
+ { PUTBACK; FREETMPS; LEAVE;
+ error("Perl function returned too many values.\n");
+ }
+
+ if (perlflags & G_ARRAY)
+ { struct array *a = allocate_array(n);
+ for(i = 0; i < n; ++i)
+ _sv_to_svalue(POPs, &(a->item[(n-1)-i]));
+ _push_array(a);
+ }
+ else if (n == 1)
+ _pikepush_sv(POPs);
+ else /* shouldn't happen unless we put G_DISCARD in perlflags */
+ _push_zerotype();
+
+ PUTBACK; FREETMPS; LEAVE;
+#undef sp
+}
+
+static void perlmod_call_list(INT32 args)
+{ _perlmod_call(args, G_ARRAY | G_EVAL);
}
static void perlmod_call(INT32 args)
-{
- error("Perl->call not yet implemented.\n");
+{ _perlmod_call(args, G_SCALAR | G_EVAL);
+}
+
+static void _perlmod_varop(INT32 args, int op, int type)
+{ int i, wanted_args;
+
+ wanted_args = type == 'S' ? 1 : 2;
+ if (op == 'W') ++wanted_args;
+
+ if (!(PERL)) error("No Perl interpreter available.\n");
+
+ if (args != wanted_args) error("Wrong number of arguments.\n");
+ if (Pike_sp[-args].type != T_STRING ||
+ Pike_sp[-args].u.string->size_shift != 0)
+ error("Variable name must be an 8-bit string.\n");
+
+ if (type == 'S') /* scalar */
+ { SV *sv = perl_get_sv(Pike_sp[-args].u.string->str, TRUE | GV_ADDMULTI);
+ if (op == 'W')
+ { sv_setsv(sv, sv_2mortal(_pikev2sv(Pike_sp-1)));}
+ pop_n_elems(args);
+ if (op == 'R') _pikepush_sv(sv);
+ }
+ else if (type == 'A') /* array */
+ { AV *av = perl_get_av(Pike_sp[-args].u.string->str, TRUE | GV_ADDMULTI);
+ SV **svp;
+ if (Pike_sp[1-args].type != T_INT || (i = Pike_sp[1-args].u.integer) < 0)
+ error("Array subscript must be a non-negative integer.\n");
+ if (op == 'W')
+ av_store(av, i, _sv_2mortal(_pikev2sv(Pike_sp+2-args)));
+ pop_n_elems(args);
+ if (op == 'R')
+ { if ((svp = av_fetch(av, i, 0))) _pikepush_sv(*svp);
+ else _push_zerotype();
+ }
+ }
+ else if (type == 'H') /* hash */
+ { HV *hv = perl_get_hv(Pike_sp[-args].u.string->str, TRUE | GV_ADDMULTI);
+ SV *key = sv_2mortal(_pikev2sv(Pike_sp+1-args));
+ HE *he;
+ if (op == 'W')
+ { if ((he = hv_store_ent
+ (hv, key, _sv_2mortal(_pikev2sv(Pike_sp+2-args)), 0)))
+ sv_setsv(HeVAL(he), _sv_2mortal(_pikev2sv(Pike_sp+2-args)));
+ else
+ error("Internal error: hv_store_ent returned NULL.\n");
+ }
+ pop_n_elems(args);
+ if (op == 'R')
+ { if ((he = hv_fetch_ent(hv, key, 0, 0)))
+ _pikepush_sv(HeVAL(he));
+ else
+ _push_zerotype();
+ }
+ }
+ else error("Internal error in _perlmod_varop.\n");
+
+ if (op != 'R') push_int(0);
+}
+
+static void perlmod_get_scalar(INT32 args)
+ { _perlmod_varop(args, 'R', 'S');}
+static void perlmod_set_scalar(INT32 args)
+ { _perlmod_varop(args, 'W', 'S');}
+static void perlmod_get_array_item(INT32 args)
+ { _perlmod_varop(args, 'R', 'A');}
+static void perlmod_set_array_item(INT32 args)
+ { _perlmod_varop(args, 'W', 'A');}
+static void perlmod_get_hash_item(INT32 args)
+ { _perlmod_varop(args, 'R', 'H');}
+static void perlmod_set_hash_item(INT32 args)
+ { _perlmod_varop(args, 'W', 'H');}
+
+static void perlmod_array_size(INT32 args)
+{ AV *av;
+ if (args != 1) error("Wrong number of arguments.\n");
+ if (Pike_sp[-args].type != T_STRING ||
+ Pike_sp[-args].u.string->size_shift != 0)
+ error("Array name must be given as an 8-bit string.\n");
+
+ av = perl_get_av(Pike_sp[-args].u.string->str, TRUE | GV_ADDMULTI);
+ if (!av) error("Interal error: perl_get_av() return NULL.\n");
+ pop_n_elems(args);
+ /* Return av_len()+1, since av_len() returns the value of the highest
+ * index, which is 1 less than the size. */
+ _push_int(av_len(av)+1);
+}
+
+static void perlmod_get_whole_array(INT32 args)
+{ AV *av; int i, n; struct array *arr;
+ if (args != 1) error("Wrong number of arguments.\n");
+ if (Pike_sp[-args].type != T_STRING ||
+ Pike_sp[-args].u.string->size_shift != 0)
+ error("Array name must be given as an 8-bit string.\n");
+
+ av = perl_get_av(Pike_sp[-args].u.string->str, TRUE | GV_ADDMULTI);
+ if (!av) error("Interal error: perl_get_av() returned NULL.\n");
+ n = av_len(av) + 1;
+
+ if (n > THIS->array_size_limit)
+ error("The array is larger than array_size_limit.\n");
+
+ arr = allocate_array(n);
+ for(i = 0; i < n; ++i)
+ { SV **svp = av_fetch(av, i, 0);
+ _sv_to_svalue(svp ? *svp : NULL, &(arr->item[i]));
+ }
+ pop_n_elems(args);
+ push_array(arr);
+}
+
+static void perlmod_get_hash_keys(INT32 args)
+{ HV *hv; HE *he; SV *sv; int i, n; I32 len; struct array *arr;
+ if (args != 1) error("Wrong number of arguments.\n");
+ if (Pike_sp[-args].type != T_STRING ||
+ Pike_sp[-args].u.string->size_shift != 0)
+ error("Hash name must be given as an 8-bit string.\n");
+
+ hv = perl_get_hv(Pike_sp[-args].u.string->str, TRUE | GV_ADDMULTI);
+ if (!hv) error("Interal error: perl_get_av() return NULL.\n");
+
+ /* count number of elements in hash */
+ for(n = 0, hv_iterinit(hv); (he = hv_iternext(hv)); ++n);
+
+ if (n > THIS->array_size_limit)
+ error("The array is larger than array_size_limit.\n");
+
+ arr = allocate_array(n);
+ for(i = 0, hv_iterinit(hv); (he = hv_iternext(hv)); ++i)
+ _sv_to_svalue(hv_iterkey(he, &len),
+ &(arr->item[i]));
+
+ pop_n_elems(args);
+ push_array(arr);
+}
+
+static void perlmod_array_size_limit(INT32 args)
+{ int i;
+ switch (args)
+ { case 0:
+ break;
+ case 1:
+ if (Pike_sp[-args].type != T_INT || Pike_sp[-args].u.integer < 1)
+ error("Argument must be a integer in range 1 to 2147483647.");
+ THIS->array_size_limit = Pike_sp[-args].u.integer;
+ break;
+ default:
+ error("Wrong number of arguments.\n");
+ }
+ pop_n_elems(args);
+ _push_int(THIS->array_size_limit);
}
void pike_module_init(void)
{
- perl_destruct_level=2;
+#ifdef PIKE_PERLDEBUG
+ fprintf(stderr, "[perl: module init]\n");
+#endif
+
+ perl_destruct_level=1;
+
start_new_program();
ADD_STORAGE(struct perlmod_storage);
+ /* function(void:int) */
+ ADD_FUNCTION("create",perlmod_create,tFunc(tVoid,tInt),0);
/* function(array(string),void|mapping(string:string):int) */
- ADD_FUNCTION("create",perlmod_create,tFunc(tArr(tStr) tOr(tVoid,tMap(tStr,tStr)),tInt),0);
+ ADD_FUNCTION("parse",perlmod_parse,tFunc(tArr(tStr) tOr(tVoid,tMap(tStr,tStr)),tInt),0);
/* function(:int) */
ADD_FUNCTION("run",perlmod_run,tFunc(tNone,tInt),0);
+
+ /* function(string,mixed...:mixed) */
+ ADD_FUNCTION("call",perlmod_call,tFuncV(tStr,tMix,tMix),0);
+
+ /* function(string,mixed...:mixed) */
+ ADD_FUNCTION("call_list",perlmod_call_list,tFuncV(tStr,tMix,tMix),0);
+
+ /* function(string:mixed) */
+ ADD_FUNCTION("eval",perlmod_eval,tFunc(tStr,tMix),0);
+
+ /* function(string:array) */
+ ADD_FUNCTION("eval_list",perlmod_eval_list,tFunc(tStr,tArr(tMix)),0);
+
+ /* function(string:mixed) */
+ ADD_FUNCTION("get_scalar",perlmod_get_scalar,tFunc(tStr,tMix),0);
+
+ /* function(string,mixed:mixed) */
+ ADD_FUNCTION("set_scalar",perlmod_set_scalar,tFunc(tStr tMix,tMix),0);
+
+ /* function(string,int:mixed) */
+ ADD_FUNCTION("get_array_item",perlmod_get_array_item,
+ tFunc(tStr tInt,tMix),0);
+
+ /* function(string,int,mixed:mixed) */
+ ADD_FUNCTION("set_array_item",perlmod_set_array_item,
+ tFunc(tStr tInt tMix,tMix),0);
+
+ /* function(string,mixed:mixed) */
+ ADD_FUNCTION("get_hash_item",perlmod_get_hash_item,
+ tFunc(tStr tMix,tMix),0);
+
+ /* function(string,mixed,mixed:mixed) */
+ ADD_FUNCTION("set_hash_item",perlmod_set_hash_item,
+ tFunc(tStr tMix tMix,tMix),0);
+
+ /* function(string:int) */
+ ADD_FUNCTION("array_size",perlmod_array_size,
+ tFunc(tStr,tInt),0);
+
/* function(string:int) */
- ADD_FUNCTION("eval",perlmod_eval,tFunc(tStr,tInt),0);
- /* function(string,mixed...:int) */
- ADD_FUNCTION("call",perlmod_call,tFuncV(tStr,tMix,tInt),0);
+ ADD_FUNCTION("get_array",perlmod_get_whole_array,
+ tFunc(tStr,tArr(tMix)),0);
+
+ /* function(string:int) */
+ ADD_FUNCTION("get_hash_keys",perlmod_get_whole_array,
+ tFunc(tStr,tArr(tMix)),0);
+
+#if 0
+ /* function(string,array:array) */
+ ADD_FUNCTION("set_array", perlmod_set_whole_array,
+ tFunc(tStr tArr(tMix),tArr(tMix)),0);
+#endif
+
+ /* function(void|int:int) */
+ ADD_FUNCTION("array_size_limit",perlmod_array_size_limit,
+ tFunc(tOr(tVoid,tInt),tInt),0);
+
set_init_callback(init_perl_glue);
set_exit_callback(exit_perl_glue);
end_class("Perl",0);
add_integer_constant("MULTIPLICITY",
#ifdef MULTIPLICITY
- 1,
+ 1,
#else
- 0,
+ 0,
#endif
- 0);
+ 0);
}
void pike_module_exit(void)