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