Skip to content
Snippets Groups Projects
Select Git revision
  • 1dba03ad18b0deaa55bd6910958d31ba1d554bc0
  • master default protected
  • 9.0
  • 8.0
  • nt-tools
  • 7.8
  • 7.6
  • 7.4
  • 7.2
  • 7.0
  • 0.6
  • rosuav/latex-markdown-renderer
  • rxnpatch/rxnpatch
  • marcus/gobject-introspection
  • rxnpatch/8.0
  • rosuav/pre-listening-ports
  • rosuav/async-annotations
  • rosuav/pgsql-ssl
  • rxnpatch/rxnpatch-broken/2023-10-06T094250
  • grubba/fdlib
  • grubba/wip/sakura/8.0
  • v8.0.2020
  • v8.0.2018
  • v8.0.2016
  • v8.0.2014
  • v8.0.2012
  • v8.0.2008
  • v8.0.2006
  • v8.0.2004
  • v8.0.2002
  • v8.0.2000
  • v8.0.1998
  • v8.0.1996
  • v8.0.1994
  • v8.0.1992
  • v8.0.1990
  • v8.0.1988
  • v8.0.1986
  • rxnpatch/clusters/8.0/2025-04-29T124414
  • rxnpatch/2025-04-29T124414
  • v8.0.1984
41 results

perlmod.c

Blame
  • perlmod.c 20.14 KiB
    /* $Id: perlmod.c,v 1.14 2000/03/23 21:48:38 leif 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"
    
      /* this is just for debugging */
    #define _sv_2mortal(x) (x)
    
    #ifdef HAVE_PERL
    
    #include <EXTERN.h>
    #include <perl.h>
    
    /* Do not redefine my malloc macro you stupid Perl! */
    #include "dmalloc.h"
    
    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;
      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;
    
    #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"); */
        return;
      }
    #endif
      MT_PERMIT;
      p=perl_alloc();
      MT_FORBID;
      PERL=p;
      if(p) num_perl_interpreters++;
    }
    
    static void _free_arg_and_env()
    { if(THIS->argv)
      {
        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;
      }
    }
    
    static void exit_perl_glue(struct object *o)
    {
    #ifdef PIKE_PERLDEBUG
      fprintf(stderr, "[exit_perl_glue]\n");
    #endif
    
      if(PERL)
      {
        struct perlmod_storage *storage=THIS;
    
        MT_PERMIT;
        if(storage->constructed)
        {
          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);
          }
          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->parse",args,BIT_ARRAY, BIT_MAPPING|BIT_VOID, 0);
      if(!p) 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();
          }
    
          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");
    
          if(THIS->argv_strings->type_field & ~BIT_STRING)
    	   error("Bad argument 1 to Perl->parse().\n");
      }
    
      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);
        THIS->env=(char **)xalloc(sizeof(char *)*(m_sizeof(env_mapping)+1));
    
        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;
    
    	*(env_blockp++)=0;
          }
        THIS->env[d]=0;
      }
      else
      {
        /* 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;
    
    #ifdef DECLARE_ENVIRON
        extern char **environ;
    #endif
    
        for(d=0;environ[d];d++)
          env_block_size+=strlen(environ[d])+1;
    
        THIS->env_block=xalloc(env_block_size);
        THIS->env=(char **)xalloc(sizeof(char *)*(d+1));
    
        env_blockp=THIS->env_block;
    
        for(d=0;environ[d];d++)
        {
          int l=strlen(environ[d]);
          THIS->env[d]=env_blockp;
          MEMCPY(env_blockp,environ[d],l+1);
          env_blockp+=l+1;
        }
    
    #ifdef PIKE_DEBUG
        if(env_blockp - THIS->env_block > env_block_size)
          fatal("Arglebargle glop-glyf.\n");
    #endif
    
        THIS->env[d]=0;
      }
      
    
      THIS->parsed++;
    
      MT_PERMIT;
      e=perl_parse(p,
    	       xs_init,
    	       storage->argv_strings->size,
    	       storage->argv,
    	       storage->env);
      MT_FORBID;
      pop_n_elems(args);
      push_int(e);
    }
    
    static void perlmod_run(INT32 args)
    {
      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)
    { _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_iterkeysv(he), &(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)
    {
    #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("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("get_array",perlmod_get_whole_array,
                   tFunc(tStr,tArr(tMix)),0);
    
      /* function(string:int) */
      ADD_FUNCTION("get_hash_keys",perlmod_get_hash_keys,
                   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,
    #else
                           0,
    #endif
                           0);
    }
    
    void pike_module_exit(void)
    {
    }
    
    #else /* HAVE_PERL */
    void pike_module_init(void) {}
    void pike_module_exit(void) {}
    #endif