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