7e86382000-10-12Martin Stjernholm /* $Id: perlmod.c,v 1.20 2000/10/12 00:34:18 mast Exp $ */
3228712000-10-12Martin Stjernholm  #define NO_PIKE_SHORTHAND
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) 
6dc2772000-07-28Fredrik Hübinette (Hubbe) /* must be included last */ #include "module_magic.h"
5a2b431998-11-22Fredrik Hübinette (Hubbe) #ifdef HAVE_PERL
71f3a21998-11-22Fredrik Hübinette (Hubbe) 
670f332000-05-16Leif Stensson /* #define PERL_560 1 */
71f3a21998-11-22Fredrik Hübinette (Hubbe) #include <EXTERN.h> #include <perl.h>
670f332000-05-16Leif Stensson #ifdef USE_THREADS /* #error Threaded Perl not supported. */ #endif #define MY_XS 1 #undef MY_XS /* #define PIKE_PERLDEBUG */ #ifdef MY_XS EXTERN_C void boot_DynaLoader(); static void xs_init() { char *file = __FILE__; dXSUB_SYS; #ifdef PIKE_PERLDEBUG fprintf(stderr, "[my xs_init]\n"); #endif newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file); } #endif
aa36c41999-04-08Fredrik Hübinette (Hubbe) /* Do not redefine my malloc macro you stupid Perl! */ #include "dmalloc.h"
71f3a21998-11-22Fredrik Hübinette (Hubbe) 
670f332000-05-16Leif Stensson  /* this is just for debugging */ #define _sv_2mortal(x) (sv_2mortal(x))
71f3a21998-11-22Fredrik Hübinette (Hubbe) static int num_perl_interpreters=0;
670f332000-05-16Leif Stensson DEFINE_MUTEX(perlrunning);
71f3a21998-11-22Fredrik Hübinette (Hubbe)  #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;
670f332000-05-16Leif Stensson  PerlInterpreter *perl;
71f3a21998-11-22Fredrik Hübinette (Hubbe) };
670f332000-05-16Leif Stensson #define _THIS ((struct perlmod_storage *)(Pike_fp->current_storage)) #ifdef PERL_560 #define my_perl PERL #endif
71f3a21998-11-22Fredrik Hübinette (Hubbe) 
670f332000-05-16Leif Stensson #define BLOCKING 1
cb96632000-03-14Leif Stensson #ifndef BLOCKING #define MT_PERMIT THREADS_ALLOW(); mt_lock(&perl_running); #define MT_FORBID mt_unlock(&perl_running); THREADS_DISALLOW();
670f332000-05-16Leif Stensson #else #define MT_PERMIT ; #define MT_FORBID ;
cb96632000-03-14Leif Stensson #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)
3228712000-10-12Martin Stjernholm  { case PIKE_T_INT:
cb96632000-03-14Leif Stensson  return newSViv(s->u.integer); break;
3228712000-10-12Martin Stjernholm  case PIKE_T_FLOAT:
cb96632000-03-14Leif Stensson  return newSVnv(s->u.float_number); break;
3228712000-10-12Martin Stjernholm  case PIKE_T_STRING:
cb96632000-03-14Leif Stensson  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))
3228712000-10-12Martin Stjernholm  { sval->type = PIKE_T_INT; sval->subtype = 0;
cb96632000-03-14Leif Stensson  sval->u.integer = SvIV(sv); return; } else if (SvNOKp(sv))
3228712000-10-12Martin Stjernholm  { sval->type = PIKE_T_FLOAT; sval->subtype = 0;
cb96632000-03-14Leif Stensson  sval->u.float_number = SvNV(sv); return; } else if (SvPOKp(sv))
3228712000-10-12Martin Stjernholm  { sval->type = PIKE_T_STRING; sval->subtype = 0;
cb96632000-03-14Leif Stensson  sval->u.string = make_shared_binary_string(SvPVX(sv), SvCUR(sv)); return; } }
3228712000-10-12Martin Stjernholm  sval->type = PIKE_T_INT; sval->u.integer = 0;
cb96632000-03-14Leif Stensson  sval->subtype = !sv; /* zero-type zero if NULL pointer */ } static void _pikepush_sv(SV *sv) { if (!SvOK(sv))
3228712000-10-12Martin Stjernholm  push_int(0);
cb96632000-03-14Leif Stensson  else if (SvIOKp(sv))
3228712000-10-12Martin Stjernholm  push_int(SvIV(sv));
cb96632000-03-14Leif Stensson  else if (SvNOKp(sv))
3228712000-10-12Martin Stjernholm  push_float((float)(SvNV(sv)));
cb96632000-03-14Leif Stensson  else if (SvPOKp(sv))
3228712000-10-12Martin Stjernholm  push_string(make_shared_binary_string(SvPVX(sv), SvCUR(sv)));
cb96632000-03-14Leif Stensson  else
3228712000-10-12Martin Stjernholm  push_int(0);
cb96632000-03-14Leif Stensson }
670f332000-05-16Leif Stensson static int _perl_parse(struct perlmod_storage *ps, int argc, char *argv[], char *envp[]) { int result; #ifndef MY_XS extern void xs_init(void); #endif #ifdef PIKE_PERLDEBUG fprintf(stderr, "[_perl_parse, argc=%d]\n", argc); #endif if (!ps) error("Internal error: no Perl storage allocated.\n"); if (!ps->perl) error("Internal error: no Perl interpreter allocated.\n"); if (!ps->constructed) error("Internal error: Perl interpreter not constructed.\n"); if (!envp && !ps->env) { /* Copy environment data, since Perl may wish to modify it. */ INT32 d; int env_block_size=0; char *env_blockp; #ifdef DECLARE_ENVIRON extern char **environ; #endif for(d=0;environ[d];d++) env_block_size+=strlen(environ[d])+1;
7e86382000-10-12Martin Stjernholm  if (env_block_size) ps->env_block=xalloc(env_block_size);
670f332000-05-16Leif Stensson  ps->env=(char **)xalloc(sizeof(char *)*(d+1)); env_blockp = ps->env_block; for(d=0;environ[d];d++) { int l=strlen(environ[d]); ps->env[d]=env_blockp; MEMCPY(env_blockp,environ[d],l+1); env_blockp+=l+1; } #ifdef PIKE_DEBUG if(env_blockp - ps->env_block > env_block_size) fatal("Arglebargle glop-glyf.\n"); #endif ps->env[d]=0; } MT_PERMIT; result = perl_parse(ps->perl, xs_init, argc, argv, envp ? envp : ps->env); MT_FORBID; ps->parsed += 1; return result; } static char *dummyargv[] = { "perl", "-e", "1", 0 };
cb96632000-03-14Leif Stensson 
71f3a21998-11-22Fredrik Hübinette (Hubbe) static void init_perl_glue(struct object *o)
670f332000-05-16Leif Stensson { struct perlmod_storage *ps = _THIS;
cb96632000-03-14Leif Stensson  #ifdef PIKE_PERLDEBUG fprintf(stderr, "[init_perl_glue]\n"); #endif
670f332000-05-16Leif Stensson  ps->argv = 0; ps->env = 0; ps->env_block = 0; ps->argv_strings = 0; ps->constructed = 0; ps->parsed = 0; ps->array_size_limit = 500;
71f3a21998-11-22Fredrik Hübinette (Hubbe)  #ifndef MULTIPLICITY if(num_perl_interpreters>0) {
670f332000-05-16Leif Stensson  ps->perl=0; #ifdef PIKE_PERLDEBUG
71f3a21998-11-22Fredrik Hübinette (Hubbe)  fprintf(stderr,"num_perl_interpreters=%d\n",num_perl_interpreters);
670f332000-05-16Leif Stensson #endif
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;
670f332000-05-16Leif Stensson  ps->perl = perl_alloc(); PL_perl_destruct_level=2;
cb96632000-03-14Leif Stensson  MT_FORBID;
670f332000-05-16Leif Stensson  if(ps->perl) num_perl_interpreters++; /* #define SPECIAL_PERL_DEBUG */ #ifdef SPECIAL_PERL_DEBUG if (!ps->constructed) { fprintf(stderr, "[SpecialDebug: early perl_construct]\n"); perl_construct(ps->perl); ps->constructed = 1; } if (!ps->parsed) { fprintf(stderr, "[SpecialDebug: early perl_parse]\n"); perl_parse(ps->perl, xs_init, 3, dummyargv, NULL); ps->parsed = 1; } #endif
71f3a21998-11-22Fredrik Hübinette (Hubbe) }
cb96632000-03-14Leif Stensson static void _free_arg_and_env()
670f332000-05-16Leif Stensson { struct perlmod_storage *ps = _THIS; if (ps->argv) { free((char *)ps->argv); ps->argv=0;
71f3a21998-11-22Fredrik Hübinette (Hubbe)  }
670f332000-05-16Leif Stensson  if (ps->argv_strings) { free_array(ps->argv_strings); ps->argv_strings=0;
71f3a21998-11-22Fredrik Hübinette (Hubbe)  }
670f332000-05-16Leif Stensson  if (ps->env) { free((char *)ps->env); ps->env=0;
71f3a21998-11-22Fredrik Hübinette (Hubbe)  }
670f332000-05-16Leif Stensson  if (ps->env_block) { free((char *)ps->env_block); ps->env_block=0;
71f3a21998-11-22Fredrik Hübinette (Hubbe)  } }
cb96632000-03-14Leif Stensson static void exit_perl_glue(struct object *o)
670f332000-05-16Leif Stensson { struct perlmod_storage *ps = _THIS;
cb96632000-03-14Leif Stensson #ifdef PIKE_PERLDEBUG fprintf(stderr, "[exit_perl_glue]\n"); #endif
71f3a21998-11-22Fredrik Hübinette (Hubbe) 
670f332000-05-16Leif Stensson  if (ps->perl)
cb96632000-03-14Leif Stensson  {
670f332000-05-16Leif Stensson  if (ps->constructed)
cb96632000-03-14Leif Stensson  {
670f332000-05-16Leif Stensson  if (!ps->parsed) { /* This should be unnecessary, but for some reason, some
1dba032000-03-23Leif Stensson  * perl5.004 installations dump core if we don't do this. */
670f332000-05-16Leif Stensson  _perl_parse(ps, 3, dummyargv, NULL);
1dba032000-03-23Leif Stensson  }
670f332000-05-16Leif Stensson  perl_destruct(ps->perl); ps->constructed = 0;
cb96632000-03-14Leif Stensson  }
670f332000-05-16Leif Stensson  MT_PERMIT; perl_free(ps->perl);
cb96632000-03-14Leif Stensson  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)
670f332000-05-16Leif Stensson { struct perlmod_storage *ps = _THIS;
cb96632000-03-14Leif Stensson  #ifdef PIKE_PERLDEBUG fprintf(stderr, "[perlmod_create, %d args]\n", args);
670f332000-05-16Leif Stensson #ifdef MY_XS fprintf(stderr, "[has MY_XS]\n"); #endif
cb96632000-03-14Leif Stensson #endif if (args != 0) error("Perl->create takes no arguments.");
670f332000-05-16Leif Stensson  if (!ps || !ps->perl) error("No perl interpreter available.\n");
cb96632000-03-14Leif Stensson  MT_PERMIT;
670f332000-05-16Leif Stensson  if(!ps->constructed) { perl_construct(ps->perl); ps->constructed++; } if (!ps->parsed) { _perl_parse(ps, 3, dummyargv, NULL);
cb96632000-03-14Leif Stensson  } MT_FORBID; pop_n_elems(args); push_int(0); } static void perlmod_parse(INT32 args)
71f3a21998-11-22Fredrik Hübinette (Hubbe) { int e; struct mapping *env_mapping=0;
670f332000-05-16Leif Stensson  struct perlmod_storage *ps = _THIS; #ifndef MY_XS extern void xs_init(void); #endif
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);
670f332000-05-16Leif Stensson  if(!ps->perl) error("No perl interpreter available.\n");
71f3a21998-11-22Fredrik Hübinette (Hubbe)  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:
670f332000-05-16Leif Stensson  if (_THIS->argv_strings || _THIS->env_block)
cb96632000-03-14Leif Stensson  { /* if we have already setup args/env, free the old values now */ _free_arg_and_env(); }
670f332000-05-16Leif Stensson  ps->argv_strings = Pike_sp[-args].u.array; add_ref(ps->argv_strings); array_fix_type_field(ps->argv_strings);
71f3a21998-11-22Fredrik Hübinette (Hubbe) 
670f332000-05-16Leif Stensson  if(ps->argv_strings->size<2)
cb96632000-03-14Leif Stensson  error("Perl: Too few elements in argv array.\n");
5a2b431998-11-22Fredrik Hübinette (Hubbe) 
670f332000-05-16Leif Stensson  if(ps->argv_strings->type_field & ~BIT_STRING)
cb96632000-03-14Leif Stensson  error("Bad argument 1 to Perl->parse().\n");
71f3a21998-11-22Fredrik Hübinette (Hubbe)  }
670f332000-05-16Leif Stensson  ps->argv=(char **)xalloc(sizeof(char *)*ps->argv_strings->size); for(e=0;e<ps->argv_strings->size;e++) ps->argv[e]=ITEM(ps->argv_strings)[e].u.string->str;
71f3a21998-11-22Fredrik Hübinette (Hubbe)  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;
670f332000-05-16Leif Stensson  ps->env_block=xalloc(env_block_size); ps->env=(char **)xalloc(sizeof(char *)*(m_sizeof(env_mapping)+1));
71f3a21998-11-22Fredrik Hübinette (Hubbe) 
670f332000-05-16Leif Stensson  env_blockp = ps->env_block;
71f3a21998-11-22Fredrik Hübinette (Hubbe)  d=0; MAPPING_LOOP(env_mapping) {
670f332000-05-16Leif Stensson  ps->env[d++]=env_blockp;
71f3a21998-11-22Fredrik Hübinette (Hubbe)  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)  }
670f332000-05-16Leif Stensson  ps->env[d]=0;
71f3a21998-11-22Fredrik Hübinette (Hubbe)  }
670f332000-05-16Leif Stensson  else ps->env = 0;
cb96632000-03-14Leif Stensson 
670f332000-05-16Leif Stensson  e = _perl_parse(ps, ps->argv_strings->size, ps->argv, ps->env);
cb96632000-03-14Leif Stensson 
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;
670f332000-05-16Leif Stensson  struct perlmod_storage *ps = _THIS; if(!ps->perl) error("No perl interpreter available.\n");
cb96632000-03-14Leif Stensson  pop_n_elems(args);
670f332000-05-16Leif Stensson  if(!_THIS->constructed || !_THIS->parsed)
cb96632000-03-14Leif Stensson  error("No Perl program loaded (run() called before parse()).\n"); MT_PERMIT;
670f332000-05-16Leif Stensson  i=perl_run(ps->perl);
cb96632000-03-14Leif Stensson  MT_FORBID; push_int(i); } static void _perlmod_eval(INT32 args, int perlflags)
670f332000-05-16Leif Stensson { struct pike_string *firstarg; struct perlmod_storage *ps = _THIS;
cb96632000-03-14Leif Stensson  int i, n;
670f332000-05-16Leif Stensson // #define sp _perlsp
cb96632000-03-14Leif Stensson  dSP;
670f332000-05-16Leif Stensson  if (!ps->perl) error("Perl interpreter not available.\n");
cb96632000-03-14Leif Stensson  check_all_args("Perl->eval", args, BIT_STRING, 0);
670f332000-05-16Leif Stensson  firstarg = Pike_sp[-args].u.string;
cb96632000-03-14Leif Stensson  ENTER; SAVETMPS; PUSHMARK(sp); PUTBACK;
670f332000-05-16Leif Stensson // #undef sp
cb96632000-03-14Leif Stensson 
670f332000-05-16Leif Stensson  if (!ps->parsed) { #if 0 _perl_parse(ps, 3, dummyargv, NULL); #else #ifndef MY_XS
cb96632000-03-14Leif Stensson  extern void xs_init(void);
670f332000-05-16Leif Stensson #endif perl_parse(ps->perl, xs_init, 3, dummyargv, NULL); #endif
cb96632000-03-14Leif Stensson  }
670f332000-05-16Leif Stensson  MT_PERMIT; /* perl5.6.0 testing: newSVpv((const char *) "ABC", 3); */ n = perl_eval_sv(newSVpv((firstarg->str), (firstarg->len)), perlflags | G_EVAL);
cb96632000-03-14Leif Stensson  MT_FORBID;
3228712000-10-12Martin Stjernholm  pop_n_elems(args);
cb96632000-03-14Leif Stensson 
670f332000-05-16Leif Stensson // #define sp _perlsp
cb96632000-03-14Leif Stensson  SPAGAIN;
670f332000-05-16Leif Stensson  if (SvTRUE(GvSV(PL_errgv)))
cb96632000-03-14Leif Stensson  { char errtmp[256]; memset(errtmp, 0, sizeof(errtmp)); strcpy(errtmp, "Error from Perl: ");
670f332000-05-16Leif Stensson  strncpy(errtmp+strlen(errtmp), SvPV(GvSV(PL_errgv), PL_na), 254-strlen(errtmp));
cb96632000-03-14Leif Stensson  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]));
3228712000-10-12Martin Stjernholm  push_array(a);
cb96632000-03-14Leif Stensson  } else if (n > 0) { for(; n > 1; --n) POPs; _pikepush_sv(POPs); } else _push_zerotype(); PUTBACK; FREETMPS; LEAVE;
670f332000-05-16Leif Stensson // #undef sp
cb96632000-03-14Leif Stensson } 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)
670f332000-05-16Leif Stensson { struct perlmod_storage *ps = _THIS;
cb96632000-03-14Leif Stensson  int i, n; char *pv;
670f332000-05-16Leif Stensson // #define sp _perlsp
cb96632000-03-14Leif Stensson  dSP; #ifdef PIKE_PERLDEBUG fprintf(stderr, "[perlmod_call: args=%d]\n", args); #endif
670f332000-05-16Leif Stensson  if (!ps->perl) error("No perl interpreter available.\n");
cb96632000-03-14Leif Stensson  if (args < 1) error("Too few arguments.\n"); if (args > 201) error("Too many arguments.\n");
3228712000-10-12Martin Stjernholm  if (Pike_sp[-args].type != PIKE_T_STRING ||
670f332000-05-16Leif Stensson  Pike_sp[-args].u.string->size_shift)
cb96632000-03-14Leif Stensson  error("bad Perl function name (must be an 8-bit string)"); ENTER; SAVETMPS; PUSHMARK(sp); for(n = 1; n < args; ++n)
670f332000-05-16Leif Stensson  { struct svalue *s = &(Pike_sp[n-args]);
cb96632000-03-14Leif Stensson  char *msg; switch (s->type)
3228712000-10-12Martin Stjernholm  { case PIKE_T_INT:
cb96632000-03-14Leif Stensson  XPUSHs(sv_2mortal(newSViv(s->u.integer))); break;
3228712000-10-12Martin Stjernholm  case PIKE_T_FLOAT:
cb96632000-03-14Leif Stensson  XPUSHs(sv_2mortal(newSVnv((double)(s->u.float_number)))); break;
3228712000-10-12Martin Stjernholm  case PIKE_T_STRING:
cb96632000-03-14Leif Stensson  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;
3228712000-10-12Martin Stjernholm  case PIKE_T_MAPPING:
cb96632000-03-14Leif Stensson  msg = "Mapping argument not allowed here.\n"; if (0)
3228712000-10-12Martin Stjernholm  case PIKE_T_OBJECT:
cb96632000-03-14Leif Stensson  msg = "Object argument not allowed here.\n"; if (0)
3228712000-10-12Martin Stjernholm  case PIKE_T_MULTISET:
cb96632000-03-14Leif Stensson  msg = "Multiset argument not allowed here.\n"; if (0)
3228712000-10-12Martin Stjernholm  case PIKE_T_ARRAY:
cb96632000-03-14Leif Stensson  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;
670f332000-05-16Leif Stensson // #undef sp
cb96632000-03-14Leif Stensson  MT_PERMIT; n = perl_call_pv(pv, perlflags); MT_FORBID;
670f332000-05-16Leif Stensson // #define sp _perlsp
cb96632000-03-14Leif Stensson 
3228712000-10-12Martin Stjernholm  pop_n_elems(args);
cb96632000-03-14Leif Stensson  SPAGAIN;
670f332000-05-16Leif Stensson  if (SvTRUE(GvSV(PL_errgv)))
cb96632000-03-14Leif Stensson  { char errtmp[256]; memset(errtmp, 0, sizeof(errtmp)); strcpy(errtmp, "Error from Perl: ");
670f332000-05-16Leif Stensson  strncpy(errtmp+strlen(errtmp), SvPV(GvSV(PL_errgv), PL_na), 254-strlen(errtmp));
cb96632000-03-14Leif Stensson  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;
670f332000-05-16Leif Stensson  if (n > ps->array_size_limit)
cb96632000-03-14Leif Stensson  { 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]));
3228712000-10-12Martin Stjernholm  push_array(a);
cb96632000-03-14Leif Stensson  } else if (n == 1) _pikepush_sv(POPs); else /* shouldn't happen unless we put G_DISCARD in perlflags */ _push_zerotype(); PUTBACK; FREETMPS; LEAVE;
670f332000-05-16Leif Stensson // #undef sp
cb96632000-03-14Leif Stensson } 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;
670f332000-05-16Leif Stensson  if (!(_THIS->perl)) error("No Perl interpreter available.\n");
cb96632000-03-14Leif Stensson  if (args != wanted_args) error("Wrong number of arguments.\n");
3228712000-10-12Martin Stjernholm  if (Pike_sp[-args].type != PIKE_T_STRING ||
cb96632000-03-14Leif Stensson  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;
3228712000-10-12Martin Stjernholm  if (Pike_sp[1-args].type != PIKE_T_INT || (i = Pike_sp[1-args].u.integer) < 0)
cb96632000-03-14Leif Stensson  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");
3228712000-10-12Martin Stjernholm  if (Pike_sp[-args].type != PIKE_T_STRING ||
cb96632000-03-14Leif Stensson  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. */
3228712000-10-12Martin Stjernholm  push_int(av_len(av)+1);
cb96632000-03-14Leif Stensson } 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");
3228712000-10-12Martin Stjernholm  if (Pike_sp[-args].type != PIKE_T_STRING ||
cb96632000-03-14Leif Stensson  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;
670f332000-05-16Leif Stensson  if (n > _THIS->array_size_limit)
cb96632000-03-14Leif Stensson  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");
3228712000-10-12Martin Stjernholm  if (Pike_sp[-args].type != PIKE_T_STRING ||
cb96632000-03-14Leif Stensson  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);
670f332000-05-16Leif Stensson  if (n > _THIS->array_size_limit)
cb96632000-03-14Leif Stensson  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:
3228712000-10-12Martin Stjernholm  if (Pike_sp[-args].type != PIKE_T_INT || Pike_sp[-args].u.integer < 1)
cb96632000-03-14Leif Stensson  error("Argument must be a integer in range 1 to 2147483647.");
670f332000-05-16Leif Stensson  _THIS->array_size_limit = Pike_sp[-args].u.integer;
cb96632000-03-14Leif Stensson  break; default: error("Wrong number of arguments.\n"); } pop_n_elems(args);
3228712000-10-12Martin Stjernholm  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
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 */
670f332000-05-16Leif Stensson  #ifdef ERROR_IF_NO_PERL #error "No Perl!" #endif
5a2b431998-11-22Fredrik Hübinette (Hubbe) void pike_module_init(void) {} void pike_module_exit(void) {} #endif