pike.git
/
src
/
modules
/
Perl
/
perlmod.c
version
»
Context lines:
10
20
40
80
file
none
3
pike.git/src/modules/Perl/perlmod.c:1:
-
/* $Id: perlmod.c,v 1.
25
2002/08/
15
14
:
50
:
27
marcus
Exp $ */
+
/* $Id: perlmod.c,v 1.
26
2002/08/
29
12
:
48
:
40
stensson
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:29:
#define MY_XS 1 #undef MY_XS /* #define PIKE_PERLDEBUG */ #ifdef MY_XS EXTERN_C void boot_DynaLoader(); static void xs_init()
-
{ char *file = __FILE__;
+
{
+
char *file = __FILE__;
dXSUB_SYS; #ifdef PIKE_PERLDEBUG fprintf(stderr, "[my xs_init]\n"); #endif newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file); } #endif /* Do not redefine my malloc macro you stupid Perl! */
pike.git/src/modules/Perl/perlmod.c:64:
char **env; char *env_block; struct array *argv_strings; int constructed, parsed; int array_size_limit; PerlInterpreter *perl; }; #define _THIS ((struct perlmod_storage *)(Pike_fp->current_storage))
-
#ifdef PERL_560
+
#ifdef PERL_560
/* Perl 5.6? */
#define my_perl PERL
-
+
#else
+
#define my_perl (_THIS)->perl
#endif #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 ; #define MT_FORBID ; #endif /* utility function: push a zero_type zero */ static void _push_zerotype()
-
{ push_int(0);
+
{
+
push_int(0);
Pike_sp[-1].subtype = 1; } static SV * _pikev2sv(struct svalue *s)
-
{ switch (s->type)
-
{ case PIKE_T_INT:
+
{
+
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; } 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;
+
{
+
if (sv && (SvOK(sv)))
+
{
+
if (SvIOKp(sv))
+
{
+
sval->type = PIKE_T_INT; sval->subtype = 0;
sval->u.integer = SvIV(sv); return; } else if (SvNOKp(sv))
-
{ sval->type = PIKE_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 = PIKE_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 = 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))
+
{
+
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 int _perl_parse(struct perlmod_storage *ps, int argc, char *argv[], char *envp[])
-
{ int result;
+
{
+
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) Pike_error("Internal error: no Perl storage allocated.\n"); if (!ps->perl)
pike.git/src/modules/Perl/perlmod.c:171:
extern char **environ; #endif for(d=0;environ[d];d++) env_block_size+=strlen(environ[d])+1; if (env_block_size) ps->env_block=xalloc(env_block_size); else ps->env_block = NULL;
+
ps->env=(char **)xalloc(sizeof(char *)*(d+1)); env_blockp = ps->env_block; for(d=0;environ[d];d++) { int l=strlen(environ[d]); ps->env[d]=env_blockp; MEMCPY(env_blockp,environ[d],l+1); env_blockp+=l+1;
pike.git/src/modules/Perl/perlmod.c:200:
MT_PERMIT; result = perl_parse(ps->perl, xs_init, argc, argv, envp ? envp : ps->env); MT_FORBID; ps->parsed += 1; return result; } static char *dummyargv[] = { "perl", "-e", "1", 0 }; static void init_perl_glue(struct object *o)
-
{ struct perlmod_storage *ps = _THIS;
+
{
+
struct perlmod_storage *ps = _THIS;
#ifdef PIKE_PERLDEBUG fprintf(stderr, "[init_perl_glue]\n"); #endif ps->argv = 0; ps->env = 0; ps->env_block = 0; ps->argv_strings = 0; ps->constructed = 0;