pike.git / src / modules / Perl / perlmod.c

version» Context lines:

pike.git/src/modules/Perl/perlmod.c:1: - /* $Id: perlmod.c,v 1.21 2000/10/12 10:45:25 grubba Exp $ */ + /* $Id: perlmod.c,v 1.22 2000/12/01 08:10:18 hubbe Exp $ */      #define NO_PIKE_SHORTHAND      #include "builtin_functions.h"   #include "global.h"   #include "svalue.h"   #include "array.h"   #include "stralloc.h"   #include "interpret.h"   #include "module_support.h"
pike.git/src/modules/Perl/perlmod.c:17:   #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. */ + /* #Pike_error Threaded Perl not supported. */   #endif      #define MY_XS 1   #undef MY_XS      /* #define PIKE_PERLDEBUG */      #ifdef MY_XS   EXTERN_C void boot_DynaLoader();   
pike.git/src/modules/Perl/perlmod.c:98:   static SV * _pikev2sv(struct svalue *s)   { switch (s->type)    { case PIKE_T_INT:    return newSViv(s->u.integer); break;    case PIKE_T_FLOAT:    return newSVnv(s->u.float_number); break;    case PIKE_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"); +  Pike_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 = PIKE_T_INT; sval->subtype = 0;    sval->u.integer = SvIV(sv);    return;    }
pike.git/src/modules/Perl/perlmod.c:148:    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"); +  Pike_error("Internal Pike_error: no Perl storage allocated.\n");    if (!ps->perl) -  error("Internal error: no Perl interpreter allocated.\n"); +  Pike_error("Internal Pike_error: no Perl interpreter allocated.\n");    if (!ps->constructed) -  error("Internal error: Perl interpreter not constructed.\n"); +  Pike_error("Internal Pike_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
pike.git/src/modules/Perl/perlmod.c:221:    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"); */ +  /* Pike_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 */
pike.git/src/modules/Perl/perlmod.c:307:   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"); +  if (args != 0) Pike_error("Perl->create takes no arguments."); +  if (!ps || !ps->perl) Pike_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);    }
pike.git/src/modules/Perl/perlmod.c:338: Inside #if undefined(MY_XS)
   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"); +  if(!ps->perl) Pike_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"); +  Pike_error("Bad argument 2 to Perl->create().\n");    if(m_val_types(env_mapping) & ~BIT_STRING) -  error("Bad argument 2 to Perl->create().\n"); +  Pike_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"); +  Pike_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"); +  Pike_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;
pike.git/src/modules/Perl/perlmod.c:414:       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"); +  if(!ps->perl) Pike_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"); +  Pike_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"); +  if (!ps->perl) Pike_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
pike.git/src/modules/Perl/perlmod.c:482:       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); +  Pike_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;
pike.git/src/modules/Perl/perlmod.c:517:   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 (!ps->perl) Pike_error("No perl interpreter available.\n");    -  if (args < 1) error("Too few arguments.\n"); -  if (args > 201) error("Too many arguments.\n"); +  if (args < 1) Pike_error("Too few arguments.\n"); +  if (args > 201) Pike_error("Too many arguments.\n");       if (Pike_sp[-args].type != PIKE_T_STRING ||    Pike_sp[-args].u.string->size_shift) -  error("bad Perl function name (must be an 8-bit string)"); +  Pike_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 PIKE_T_INT:    XPUSHs(sv_2mortal(newSViv(s->u.integer)));    break;    case PIKE_T_FLOAT:    XPUSHs(sv_2mortal(newSVnv((double)(s->u.float_number))));    break;    case PIKE_T_STRING:    if (s->u.string->size_shift)    { PUTBACK; FREETMPS; LEAVE; -  error("widestrings not supported in Pike-to-Perl call interface"); +  Pike_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 PIKE_T_MAPPING:    msg = "Mapping argument not allowed here.\n"; if (0)    case PIKE_T_OBJECT:    msg = "Object argument not allowed here.\n"; if (0)    case PIKE_T_MULTISET:    msg = "Multiset argument not allowed here.\n"; if (0)    case PIKE_T_ARRAY:    msg = "Array argument not allowed here.\n"; if (0)    default:    msg = "Unsupported argument type.\n";    PUTBACK; FREETMPS; LEAVE; -  error(msg); +  Pike_error(msg);    return;    }    }    PUTBACK;       pv = Pike_sp[-args].u.string->str;   // #undef sp    MT_PERMIT;       n = perl_call_pv(pv, perlflags);
pike.git/src/modules/Perl/perlmod.c:587:       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); +  Pike_error(errtmp);    }       if (n < 0)    { PUTBACK; FREETMPS; LEAVE; -  error("Internal error: perl_call_pv returned a negative number.\n"); +  Pike_error("Internal Pike_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"); +  Pike_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);
pike.git/src/modules/Perl/perlmod.c:632:   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 (!(_THIS->perl)) Pike_error("No Perl interpreter available.\n");    -  if (args != wanted_args) error("Wrong number of arguments.\n"); +  if (args != wanted_args) Pike_error("Wrong number of arguments.\n");    if (Pike_sp[-args].type != PIKE_T_STRING ||    Pike_sp[-args].u.string->size_shift != 0) -  error("Variable name must be an 8-bit string.\n"); +  Pike_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 != PIKE_T_INT || (i = Pike_sp[1-args].u.integer) < 0) -  error("Array subscript must be a non-negative integer.\n"); +  Pike_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"); +  Pike_error("Internal Pike_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"); +  else Pike_error("Internal Pike_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 (args != 1) Pike_error("Wrong number of arguments.\n");    if (Pike_sp[-args].type != PIKE_T_STRING ||    Pike_sp[-args].u.string->size_shift != 0) -  error("Array name must be given as an 8-bit string.\n"); +  Pike_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"); +  if (!av) Pike_error("Interal Pike_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 (args != 1) Pike_error("Wrong number of arguments.\n");    if (Pike_sp[-args].type != PIKE_T_STRING ||    Pike_sp[-args].u.string->size_shift != 0) -  error("Array name must be given as an 8-bit string.\n"); +  Pike_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"); +  if (!av) Pike_error("Interal Pike_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"); +  Pike_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 (args != 1) Pike_error("Wrong number of arguments.\n");    if (Pike_sp[-args].type != PIKE_T_STRING ||    Pike_sp[-args].u.string->size_shift != 0) -  error("Hash name must be given as an 8-bit string.\n"); +  Pike_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"); +  if (!hv) Pike_error("Interal Pike_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"); +  Pike_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 != PIKE_T_INT || Pike_sp[-args].u.integer < 1) -  error("Argument must be a integer in range 1 to 2147483647."); +  Pike_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"); +  Pike_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
pike.git/src/modules/Perl/perlmod.c:866:    0);   }      void pike_module_exit(void)   {   }      #else /* HAVE_PERL */      #ifdef ERROR_IF_NO_PERL - #error "No Perl!" + #Pike_error "No Perl!"   #endif      void pike_module_init(void) {}   void pike_module_exit(void) {}   #endif