pike.git/ src/ modules/ Perl/ perlmod.c > b44450d8d495873efa82f17e4283eb2a878b3e74 [Annotate]

/* $Id: perlmod.c,v 1.18 2000/07/28 07:14:20 hubbe Exp $ */ 

#include "builtin_functions.h" 

#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" 

/* must be included last */ 

#include "module_magic.h" 

#ifdef HAVE_PERL 

/* #define PERL_560 1 */ 

#include <EXTERN.h> 

#include <perl.h> 

#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 

/* Do not redefine my malloc macro you stupid Perl! */ 

#include "dmalloc.h" 

  /* this is just for debugging */ 

#define _sv_2mortal(x) (sv_2mortal(x)) 

static int num_perl_interpreters=0; 

DEFINE_MUTEX(perlrunning); 

#ifdef MULTIPLICITY 

#endif 

struct perlmod_storage 

{ 

  char **argv; 

  char **env; 

  char *env_block; 

  struct array *argv_strings; 

  int constructed, parsed; 

  int array_size_limit; 

  PerlInterpreter *perl; 

}; 

#define _THIS ((struct perlmod_storage *)(Pike_fp->current_storage)) 

#ifdef PERL_560 

#define my_perl PERL 

#endif 

/* since both Perl and Pike likes to use "sp" as a stack pointer, 

 * let's define some Pike macros as functions... 

 * 

 * Hubbe: Not true anymore, we should really define NO_PIKE_SHORTHAND 

 */ 

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 void _pike_pop() { --Pike_sp;} 

#undef sp 

#define BLOCKING 1 

#ifndef BLOCKING 

#define MT_PERMIT THREADS_ALLOW(); mt_lock(&perl_running); 

#define MT_FORBID mt_unlock(&perl_running); THREADS_DISALLOW(); 

#else 

#define MT_PERMIT ; 

#define MT_FORBID ; 

#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 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; 

    ps->env_block=xalloc(env_block_size); 

    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 }; 

static void init_perl_glue(struct object *o) 

{ struct perlmod_storage *ps = _THIS; 

#ifdef PIKE_PERLDEBUG 

  fprintf(stderr, "[init_perl_glue]\n"); 

#endif 

  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; 

#ifndef MULTIPLICITY 

  if(num_perl_interpreters>0) 

  { 

    ps->perl=0; 

#ifdef PIKE_PERLDEBUG 

    fprintf(stderr,"num_perl_interpreters=%d\n",num_perl_interpreters); 

#endif 

    /*    error("Perl: There can be only one!\n"); */ 

    return; 

  } 

#endif 

  MT_PERMIT; 

  ps->perl = perl_alloc(); 

  PL_perl_destruct_level=2; 

  MT_FORBID; 

  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 

} 

static void _free_arg_and_env() 

{ struct perlmod_storage *ps = _THIS; 

  if (ps->argv) 

  { free((char *)ps->argv); 

    ps->argv=0; 

  } 

  if (ps->argv_strings) 

  { free_array(ps->argv_strings); 

    ps->argv_strings=0; 

  } 

  if (ps->env) 

  { free((char *)ps->env); 

    ps->env=0; 

  } 

  if (ps->env_block) 

  { free((char *)ps->env_block); 

    ps->env_block=0; 

  } 

} 

static void exit_perl_glue(struct object *o) 

{ struct perlmod_storage *ps = _THIS; 

#ifdef PIKE_PERLDEBUG 

  fprintf(stderr, "[exit_perl_glue]\n"); 

#endif 

  if (ps->perl) 

  { 

    if (ps->constructed) 

    { 

      if (!ps->parsed) 

      { /* This should be unnecessary, but for some reason, some 

         * perl5.004 installations dump core if we don't do this. 

         */ 

        _perl_parse(ps, 3, dummyargv, NULL); 

      } 

      perl_destruct(ps->perl); 

      ps->constructed = 0; 

    } 

    MT_PERMIT; 

    perl_free(ps->perl); 

    MT_FORBID; 

    num_perl_interpreters--; 

  } 

  _free_arg_and_env(); 

} 

static void perlmod_create(INT32 args) 

{ struct perlmod_storage *ps = _THIS; 

#ifdef PIKE_PERLDEBUG 

  fprintf(stderr, "[perlmod_create, %d args]\n", args); 

#ifdef MY_XS 

  fprintf(stderr, "[has MY_XS]\n"); 

#endif 

#endif 

  if (args != 0) error("Perl->create takes no arguments."); 

  if (!ps || !ps->perl) error("No perl interpreter available.\n"); 

  MT_PERMIT; 

  if(!ps->constructed) 

  { perl_construct(ps->perl); 

    ps->constructed++; 

  } 

  if (!ps->parsed) 

  { 

    _perl_parse(ps, 3, dummyargv, NULL); 

  } 

  MT_FORBID; 

  pop_n_elems(args); 

  push_int(0); 

} 

static void perlmod_parse(INT32 args) 

{ 

  int e; 

  struct mapping *env_mapping=0; 

  struct perlmod_storage *ps = _THIS; 

#ifndef MY_XS 

  extern void xs_init(void); 

#endif 

#ifdef PIKE_PERLDEBUG 

  fprintf(stderr, "[perlmod_parse, %d args]\n", args); 

#endif 

  check_all_args("Perl->parse",args,BIT_ARRAY, BIT_MAPPING|BIT_VOID, 0); 

  if(!ps->perl) error("No perl interpreter available.\n"); 

  switch(args) 

  { 

    default: 

      env_mapping = Pike_sp[1-args].u.mapping; 

      mapping_fix_type_field(env_mapping); 

      if(m_ind_types(env_mapping) & ~BIT_STRING) 

        error("Bad argument 2 to Perl->create().\n"); 

      if(m_val_types(env_mapping) & ~BIT_STRING) 

        error("Bad argument 2 to Perl->create().\n"); 

    case 1: 

      if (_THIS->argv_strings || _THIS->env_block) 

      { /* if we have already setup args/env, free the old values now */ 

        _free_arg_and_env(); 

      } 

      ps->argv_strings = Pike_sp[-args].u.array; 

      add_ref(ps->argv_strings); 

      array_fix_type_field(ps->argv_strings); 

      if(ps->argv_strings->size<2) 

           error("Perl: Too few elements in argv array.\n"); 

      if(ps->argv_strings->type_field & ~BIT_STRING) 

           error("Bad argument 1 to Perl->parse().\n"); 

  } 

  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; 

  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; 

    ps->env_block=xalloc(env_block_size); 

    ps->env=(char **)xalloc(sizeof(char *)*(m_sizeof(env_mapping)+1)); 

    env_blockp = ps->env_block; 

    d=0; 

    MAPPING_LOOP(env_mapping) 

      { 

        ps->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; 

        *(env_blockp++)=0; 

      } 

    ps->env[d]=0; 

  } 

  else ps->env = 0; 

  e = _perl_parse(ps, ps->argv_strings->size, ps->argv, ps->env); 

  pop_n_elems(args); 

  push_int(e); 

} 

static void perlmod_run(INT32 args) 

{ 

  INT32 i; 

  struct perlmod_storage *ps = _THIS; 

  if(!ps->perl) 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(ps->perl); 

  MT_FORBID; 

  push_int(i); 

} 

static void _perlmod_eval(INT32 args, int perlflags) 

{ struct pike_string *firstarg; 

  struct perlmod_storage *ps = _THIS; 

  int i, n; 

// #define sp _perlsp 

  dSP; 

  if (!ps->perl) error("Perl interpreter not available.\n"); 

  check_all_args("Perl->eval", args, BIT_STRING, 0); 

  firstarg = Pike_sp[-args].u.string; 

  ENTER; 

  SAVETMPS; 

  PUSHMARK(sp); 

  PUTBACK; 

// #undef sp 

  if (!ps->parsed) 

  { 

#if 0 

    _perl_parse(ps, 3, dummyargv, NULL); 

#else 

#ifndef MY_XS 

    extern void xs_init(void); 

#endif 

    perl_parse(ps->perl, xs_init, 3, dummyargv, NULL); 

#endif 

  } 

  MT_PERMIT; 

/* perl5.6.0 testing: newSVpv((const char *) "ABC", 3); */ 

  n = perl_eval_sv(newSVpv((firstarg->str), 

                           (firstarg->len)), 

                    perlflags | G_EVAL); 

  MT_FORBID; 

  _pop_n_elems(args); 

// #define sp _perlsp 

  SPAGAIN; 

  if (SvTRUE(GvSV(PL_errgv))) 

  { char errtmp[256]; 

    memset(errtmp, 0, sizeof(errtmp)); 

    strcpy(errtmp, "Error from Perl: "); 

    strncpy(errtmp+strlen(errtmp), 

            SvPV(GvSV(PL_errgv), PL_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) 

  { _perlmod_eval(args, G_SCALAR); } 

static void perlmod_eval_list(INT32 args) 

  { _perlmod_eval(args, G_ARRAY); } 

static void _perlmod_call(INT32 args, int perlflags) 

{ struct perlmod_storage *ps = _THIS; 

  int i, n; char *pv; 

// #define sp _perlsp 

  dSP; 

#ifdef PIKE_PERLDEBUG 

  fprintf(stderr, "[perlmod_call: args=%d]\n", args); 

#endif 

  if (!ps->perl) error("No perl interpreter available.\n"); 

  if (args <   1) error("Too few arguments.\n"); 

  if (args > 201) error("Too many arguments.\n"); 

  if (Pike_sp[-args].type != T_STRING || 

      Pike_sp[-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 = &(Pike_sp[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(PL_errgv))) 

  { char errtmp[256]; 

    memset(errtmp, 0, sizeof(errtmp)); 

    strcpy(errtmp, "Error from Perl: "); 

    strncpy(errtmp+strlen(errtmp), 

            SvPV(GvSV(PL_errgv), PL_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 > ps->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) 

{ _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 (!(_THIS->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");