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

version» Context lines:

pike.git/src/modules/Perl/perlmod.c:1: - /* $Id: perlmod.c,v 1.18 2000/07/28 07:14:20 hubbe Exp $ */ + /* $Id: perlmod.c,v 1.19 2000/10/11 23:55:44 mast 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"   #include "threads.h"   #include "mapping.h"   #include "perl_machine.h"
pike.git/src/modules/Perl/perlmod.c:66:    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 ;
pike.git/src/modules/Perl/perlmod.c:101:   #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: +  { case PIKE_T_INT:    return newSViv(s->u.integer); break; -  case T_FLOAT: +  case PIKE_T_FLOAT:    return newSVnv(s->u.float_number); break; -  case T_STRING: +  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");    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->type = PIKE_T_INT; sval->subtype = 0;    sval->u.integer = SvIV(sv);    return;    }    else if (SvNOKp(sv)) -  { sval->type = T_FLOAT; sval->subtype = 0; +  { sval->type = PIKE_T_FLOAT; sval->subtype = 0;    sval->u.float_number = SvNV(sv);    return;    }    else if (SvPOKp(sv)) -  { sval->type = T_STRING; sval->subtype = 0; +  { sval->type = PIKE_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->type = PIKE_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); +  push_int(0);    else if (SvIOKp(sv)) -  _push_int(SvIV(sv)); +  push_int(SvIV(sv));    else if (SvNOKp(sv)) -  _push_float((float)(SvNV(sv))); +  push_float((float)(SvNV(sv)));    else if (SvPOKp(sv)) -  _push_string(make_shared_binary_string(SvPVX(sv), SvCUR(sv))); +  push_string(make_shared_binary_string(SvPVX(sv), SvCUR(sv)));    else -  _push_int(0); +  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);
pike.git/src/modules/Perl/perlmod.c:476:    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); +  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); +  push_array(a);    }    else if (n > 0)    { for(; n > 1; --n) POPs;    _pikepush_sv(POPs);    }    else _push_zerotype();       PUTBACK; FREETMPS; LEAVE;   // #undef sp   }
pike.git/src/modules/Perl/perlmod.c:530: Inside #if defined(PIKE_PERLDEBUG)
     #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 || +  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)");       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: +  { case PIKE_T_INT:    XPUSHs(sv_2mortal(newSViv(s->u.integer)));    break; -  case T_FLOAT: +  case PIKE_T_FLOAT:    XPUSHs(sv_2mortal(newSVnv((double)(s->u.float_number))));    break; -  case T_STRING: +  case PIKE_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: +  case PIKE_T_MAPPING:    msg = "Mapping argument not allowed here.\n"; if (0) -  case T_OBJECT: +  case PIKE_T_OBJECT:    msg = "Object argument not allowed here.\n"; if (0) -  case T_MULTISET: +  case PIKE_T_MULTISET:    msg = "Multiset argument not allowed here.\n"; if (0) -  case T_ARRAY: +  case PIKE_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); +  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));
pike.git/src/modules/Perl/perlmod.c:615:       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); +  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   }   
pike.git/src/modules/Perl/perlmod.c:643:      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 || +  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");       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) +  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");    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 */
pike.git/src/modules/Perl/perlmod.c:707:   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 || +  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");       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); +  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 || +  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");       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");   
pike.git/src/modules/Perl/perlmod.c:745:    { 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 || +  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");       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)
pike.git/src/modules/Perl/perlmod.c:772:    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) +  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.");    _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); +  push_int(_THIS->array_size_limit);   }      void pike_module_init(void)   {   #ifdef PIKE_PERLDEBUG    fprintf(stderr, "[perl: module init]\n");   #endif       start_new_program();    ADD_STORAGE(struct perlmod_storage);