1b16972000-03-27Henrik Grubbström (Grubba) /* $Id: perlmod.c,v 1.15 2000/03/27 00:17:06 grubba Exp $ */
cb96632000-03-14Leif Stensson  #include "builtin_functions.h"
06de061999-02-09Fredrik Hübinette (Hubbe) #include "global.h" #include "svalue.h" #include "array.h" #include "stralloc.h" #include "interpret.h" #include "module_support.h" #include "threads.h" #include "mapping.h" #include "perl_machine.h"
5a2b431998-11-22Fredrik Hübinette (Hubbe) 
cb96632000-03-14Leif Stensson  /* this is just for debugging */ #define _sv_2mortal(x) (x)
5a2b431998-11-22Fredrik Hübinette (Hubbe) #ifdef HAVE_PERL
71f3a21998-11-22Fredrik Hübinette (Hubbe)  #include <EXTERN.h> #include <perl.h>
aa36c41999-04-08Fredrik Hübinette (Hubbe) /* Do not redefine my malloc macro you stupid Perl! */ #include "dmalloc.h"
71f3a21998-11-22Fredrik Hübinette (Hubbe)  static int num_perl_interpreters=0; DEFINE_MUTEX(perl_running); #ifdef MULTIPLICITY #endif struct perlmod_storage { char **argv; char **env; char *env_block; struct array *argv_strings;
cb96632000-03-14Leif Stensson  int constructed, parsed; int array_size_limit;
71f3a21998-11-22Fredrik Hübinette (Hubbe)  PerlInterpreter *my_perl; }; #define THIS ((struct perlmod_storage *)(fp->current_storage)) #define PERL THIS->my_perl
cb96632000-03-14Leif Stensson /* 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); }
71f3a21998-11-22Fredrik Hübinette (Hubbe) static void init_perl_glue(struct object *o)
cb96632000-03-14Leif Stensson { 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;
71f3a21998-11-22Fredrik Hübinette (Hubbe)  #ifndef MULTIPLICITY if(num_perl_interpreters>0) { PERL=0; fprintf(stderr,"num_perl_interpreters=%d\n",num_perl_interpreters);
cb96632000-03-14Leif Stensson  /* error("Perl: There can be only one!\n"); */
71f3a21998-11-22Fredrik Hübinette (Hubbe)  return; } #endif
cb96632000-03-14Leif Stensson  MT_PERMIT;
71f3a21998-11-22Fredrik Hübinette (Hubbe)  p=perl_alloc();
cb96632000-03-14Leif Stensson  MT_FORBID;
71f3a21998-11-22Fredrik Hübinette (Hubbe)  PERL=p; if(p) num_perl_interpreters++; }
cb96632000-03-14Leif Stensson static void _free_arg_and_env() { if(THIS->argv)
71f3a21998-11-22Fredrik Hübinette (Hubbe)  { free((char *)THIS->argv); THIS->argv=0; } if(THIS->argv_strings) { free_array(THIS->argv_strings); THIS->argv_strings=0; } if(THIS->env) { free((char *)THIS->env); THIS->env=0; } if(THIS->env_block) { free((char *)THIS->env_block); THIS->env_block=0; } }
cb96632000-03-14Leif Stensson static void exit_perl_glue(struct object *o)
71f3a21998-11-22Fredrik Hübinette (Hubbe) {
cb96632000-03-14Leif Stensson #ifdef PIKE_PERLDEBUG fprintf(stderr, "[exit_perl_glue]\n"); #endif
71f3a21998-11-22Fredrik Hübinette (Hubbe) 
cb96632000-03-14Leif Stensson  if(PERL) { struct perlmod_storage *storage=THIS;
5a2b431998-11-22Fredrik Hübinette (Hubbe) 
cb96632000-03-14Leif Stensson  MT_PERMIT; if(storage->constructed) {
1dba032000-03-23Leif Stensson  if (!storage->parsed) { static char *dummyargv[] = { "perl", "-e", "1", 0 }; extern void xs_init(void); /* this should be unnecessary, but for some reason, some * perl5.004 installations dump core if we don't do this. */ perl_parse(storage->my_perl, xs_init, 3, dummyargv, NULL); }
cb96632000-03-14Leif Stensson  perl_destruct(storage->my_perl); storage->constructed=0; } perl_free(storage->my_perl); MT_FORBID; num_perl_interpreters--; } _free_arg_and_env();
71f3a21998-11-22Fredrik Hübinette (Hubbe) }
5a2b431998-11-22Fredrik Hübinette (Hubbe) static void perlmod_create(INT32 args)
cb96632000-03-14Leif Stensson { 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)
71f3a21998-11-22Fredrik Hübinette (Hubbe) { extern void xs_init(void); int e; struct mapping *env_mapping=0; PerlInterpreter *p=PERL; struct perlmod_storage *storage=THIS;
cb96632000-03-14Leif Stensson  #ifdef PIKE_PERLDEBUG fprintf(stderr, "[perlmod_parse, %d args]\n", args); #endif
71f3a21998-11-22Fredrik Hübinette (Hubbe) 
cb96632000-03-14Leif Stensson  check_all_args("Perl->parse",args,BIT_ARRAY, BIT_MAPPING|BIT_VOID, 0);
71f3a21998-11-22Fredrik Hübinette (Hubbe)  if(!p) error("No perl interpreter available.\n"); switch(args) { default:
cb96632000-03-14Leif Stensson  env_mapping = Pike_sp[1-args].u.mapping;
71f3a21998-11-22Fredrik Hübinette (Hubbe)  mapping_fix_type_field(env_mapping); if(m_ind_types(env_mapping) & ~BIT_STRING)
5a2b431998-11-22Fredrik Hübinette (Hubbe)  error("Bad argument 2 to Perl->create().\n");
71f3a21998-11-22Fredrik Hübinette (Hubbe)  if(m_val_types(env_mapping) & ~BIT_STRING)
5a2b431998-11-22Fredrik Hübinette (Hubbe)  error("Bad argument 2 to Perl->create().\n");
71f3a21998-11-22Fredrik Hübinette (Hubbe)  case 1:
cb96632000-03-14Leif Stensson  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;
71f3a21998-11-22Fredrik Hübinette (Hubbe)  add_ref(THIS->argv_strings); array_fix_type_field(THIS->argv_strings);
5a2b431998-11-22Fredrik Hübinette (Hubbe)  if(THIS->argv_strings->size<2)
cb96632000-03-14Leif Stensson  error("Perl: Too few elements in argv array.\n");
5a2b431998-11-22Fredrik Hübinette (Hubbe) 
71f3a21998-11-22Fredrik Hübinette (Hubbe)  if(THIS->argv_strings->type_field & ~BIT_STRING)
cb96632000-03-14Leif Stensson  error("Bad argument 1 to Perl->parse().\n");
71f3a21998-11-22Fredrik Hübinette (Hubbe)  } THIS->argv=(char **)xalloc(sizeof(char *)*THIS->argv_strings->size); for(e=0;e<THIS->argv_strings->size;e++) THIS->argv[e]=ITEM(THIS->argv_strings)[e].u.string->str; if(env_mapping) { INT32 d; int env_block_size=0; char *env_blockp; struct keypair *k; MAPPING_LOOP(env_mapping) env_block_size+=k->ind.u.string->len+k->val.u.string->len+2; THIS->env_block=xalloc(env_block_size);
5f648c2000-02-17Fredrik Hübinette (Hubbe)  THIS->env=(char **)xalloc(sizeof(char *)*(m_sizeof(env_mapping)+1));
71f3a21998-11-22Fredrik Hübinette (Hubbe)  env_blockp=THIS->env_block; d=0; MAPPING_LOOP(env_mapping) { THIS->env[d++]=env_blockp; MEMCPY(env_blockp,k->ind.u.string->str,k->ind.u.string->len); env_blockp+=k->ind.u.string->len; *(env_blockp++)='='; MEMCPY(env_blockp,k->val.u.string->str,k->ind.u.string->len); env_blockp+=k->val.u.string->len;
deb58f2000-02-17Fredrik Hübinette (Hubbe)  *(env_blockp++)=0;
71f3a21998-11-22Fredrik Hübinette (Hubbe)  } THIS->env[d]=0;
cb96632000-03-14Leif Stensson  } else {
deb58f2000-02-17Fredrik Hübinette (Hubbe)  /* Perl likes to be able to write in the environment block, * give it it's own copy to protect ourselves.. /Hubbe */ INT32 d; int env_block_size=0; char *env_blockp;
4b74832000-02-17Fredrik Hübinette (Hubbe) #ifdef DECLARE_ENVIRON extern char **environ; #endif
deb58f2000-02-17Fredrik Hübinette (Hubbe)  for(d=0;environ[d];d++) env_block_size+=strlen(environ[d])+1; THIS->env_block=xalloc(env_block_size);
5f648c2000-02-17Fredrik Hübinette (Hubbe)  THIS->env=(char **)xalloc(sizeof(char *)*(d+1));
deb58f2000-02-17Fredrik Hübinette (Hubbe)  env_blockp=THIS->env_block; for(d=0;environ[d];d++) { int l=strlen(environ[d]);
4b74832000-02-17Fredrik Hübinette (Hubbe)  THIS->env[d]=env_blockp;
deb58f2000-02-17Fredrik Hübinette (Hubbe)  MEMCPY(env_blockp,environ[d],l+1); env_blockp+=l+1; }
5f648c2000-02-17Fredrik Hübinette (Hubbe)  #ifdef PIKE_DEBUG if(env_blockp - THIS->env_block > env_block_size) fatal("Arglebargle glop-glyf.\n"); #endif
deb58f2000-02-17Fredrik Hübinette (Hubbe)  THIS->env[d]=0;
71f3a21998-11-22Fredrik Hübinette (Hubbe)  }
cb96632000-03-14Leif Stensson  THIS->parsed++; MT_PERMIT;
71f3a21998-11-22Fredrik Hübinette (Hubbe)  e=perl_parse(p, xs_init, storage->argv_strings->size, storage->argv, storage->env);
cb96632000-03-14Leif Stensson  MT_FORBID;
71f3a21998-11-22Fredrik Hübinette (Hubbe)  pop_n_elems(args); push_int(e); }
cb96632000-03-14Leif Stensson static void perlmod_run(INT32 args)
71f3a21998-11-22Fredrik Hübinette (Hubbe) {
cb96632000-03-14Leif Stensson  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)
1b16972000-03-27Henrik Grubbström (Grubba)  { _perlmod_eval(args, G_SCALAR); }
cb96632000-03-14Leif Stensson  static void perlmod_eval_list(INT32 args)
1b16972000-03-27Henrik Grubbström (Grubba)  { _perlmod_eval(args, G_ARRAY); }
cb96632000-03-14Leif Stensson  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);
71f3a21998-11-22Fredrik Hübinette (Hubbe) } static void perlmod_call(INT32 args)
cb96632000-03-14Leif Stensson { _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)
356d722000-03-18Leif Stensson  _sv_to_svalue(hv_iterkeysv(he), &(arr->item[i]));
cb96632000-03-14Leif Stensson  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);
71f3a21998-11-22Fredrik Hübinette (Hubbe) } void pike_module_init(void) {
cb96632000-03-14Leif Stensson #ifdef PIKE_PERLDEBUG fprintf(stderr, "[perl: module init]\n"); #endif perl_destruct_level=1;
71f3a21998-11-22Fredrik Hübinette (Hubbe)  start_new_program();
90e9781999-01-31Fredrik Hübinette (Hubbe)  ADD_STORAGE(struct perlmod_storage);
cb96632000-03-14Leif Stensson  /* function(void:int) */ ADD_FUNCTION("create",perlmod_create,tFunc(tVoid,tInt),0);
45ee5d1999-02-10Fredrik Hübinette (Hubbe)  /* function(array(string),void|mapping(string:string):int) */
cb96632000-03-14Leif Stensson  ADD_FUNCTION("parse",perlmod_parse,tFunc(tArr(tStr) tOr(tVoid,tMap(tStr,tStr)),tInt),0);
45ee5d1999-02-10Fredrik Hübinette (Hubbe)  /* function(:int) */
07228a1999-06-19Fredrik Hübinette (Hubbe)  ADD_FUNCTION("run",perlmod_run,tFunc(tNone,tInt),0);
cb96632000-03-14Leif Stensson  /* 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);
45ee5d1999-02-10Fredrik Hübinette (Hubbe)  /* function(string:int) */
cb96632000-03-14Leif Stensson  ADD_FUNCTION("get_array",perlmod_get_whole_array, tFunc(tStr,tArr(tMix)),0); /* function(string:int) */
356d722000-03-18Leif Stensson  ADD_FUNCTION("get_hash_keys",perlmod_get_hash_keys,
cb96632000-03-14Leif Stensson  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);
71f3a21998-11-22Fredrik Hübinette (Hubbe)  set_init_callback(init_perl_glue); set_exit_callback(exit_perl_glue); end_class("Perl",0); add_integer_constant("MULTIPLICITY", #ifdef MULTIPLICITY
cb96632000-03-14Leif Stensson  1,
71f3a21998-11-22Fredrik Hübinette (Hubbe) #else
cb96632000-03-14Leif Stensson  0,
71f3a21998-11-22Fredrik Hübinette (Hubbe) #endif
cb96632000-03-14Leif Stensson  0);
71f3a21998-11-22Fredrik Hübinette (Hubbe) } void pike_module_exit(void) { }
5a2b431998-11-22Fredrik Hübinette (Hubbe)  #else /* HAVE_PERL */ void pike_module_init(void) {} void pike_module_exit(void) {} #endif