----------------
____________________________________________________________________________
+[ 3385] By: gsar on 1999/05/10 19:33:36
+ Log: "weak" references internals, still needs perlguts documentation
+ (somewhat modified version of patch suggested by Tuomas J. Lukka
+ <lukka@fas.harvard.edu>)
+ Branch: perl
+ ! dump.c embed.h embed.pl global.sym mg.c objXSUB.h perl.h
+ ! pod/perldiag.pod proto.h sv.c sv.h util.c
+____________________________________________________________________________
+[ 3384] By: jhi on 1999/05/10 18:21:43
+ Log: Circumnavigate Digital UNIX 4.0D miniperl core dump
+ (due to QAR 56761) (the bug has been fixed in 4.0E or better)
+ Branch: cfgperl
+ ! INSTALL hints/dec_osf.sh
+____________________________________________________________________________
+[ 3381] By: jhi on 1999/05/10 14:39:28
+ Log: Integrate from mainperl.
+ Branch: cfgperl
+ +> cygwin32/Makefile.SHs cygwin32/build-instructions.READFIRST
+ +> cygwin32/build-instructions.charles-wilson
+ +> cygwin32/build-instructions.sebastien-barre
+ +> cygwin32/build-instructions.steven-morlock
+ +> cygwin32/build-instructions.steven-morlock2
+ +> cygwin32/impure_ptr.c cygwin32/ld2.in cygwin32/perlld.in
+ +> ext/ByteLoader/ByteLoader.pm ext/ByteLoader/ByteLoader.xs
+ +> ext/ByteLoader/Makefile.PL pod/Win32.pod t/lib/io_linenum.t
+ +> t/op/numconvert.t utils/perlbc.PL
+ - cygwin32/cw32imp.h cygwin32/gcc2 cygwin32/ld2 cygwin32/perlgcc
+ - cygwin32/perlld
+ !> (integrate 105 files)
+____________________________________________________________________________
+[ 3380] By: gsar on 1999/05/10 12:27:14
+ Log: regen regnodes.h
+ Branch: perl
+ ! Changes regnodes.h
+____________________________________________________________________________
[ 3379] By: gsar on 1999/05/10 12:17:26
Log: From: jan.dubois@ibm.net (Jan Dubois)
Date: Sat, 01 May 1999 22:55:36 +0200
};
#endif /* INDIRECT_BGET_MACROS */
-void *bset_obj_store _((void *, I32));
-
enum {
EOT
/*
- * Copyright (c) 1996-1998 Malcolm Beattie
+ * Copyright (c) 1996-1999 Malcolm Beattie
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
/*
- * Copyright (c) 1996-1998 Malcolm Beattie
+ * Copyright (c) 1996-1999 Malcolm Beattie
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
};
#endif /* INDIRECT_BGET_MACROS */
-void *bset_obj_store _((void *, I32));
-
enum {
INSN_RET, /* 0 */
INSN_LDSV, /* 1 */
join("", @v_fast, sort @v_others),
"!END!\n\n";
-# copy config summary format from the myconfig script
+# copy config summary format from the myconfig.SH script
print CONFIG "my \$summary = <<'!END!';\n";
-open(MYCONFIG,"<myconfig") || die "open myconfig failed: $!";
+open(MYCONFIG,"<myconfig.SH") || die "open myconfig.SH failed: $!";
1 while defined($_ = <MYCONFIG>) && !/^Summary of/;
do { print CONFIG $_ } until !defined($_ = <MYCONFIG>) || /^\s*$/;
close(MYCONFIG);
#define do_vecset Perl_do_vecset
#define do_vop Perl_do_vop
#define dofile Perl_dofile
-#define dofindlabel Perl_dofindlabel
-#define dopoptoeval Perl_dopoptoeval
#define dounwind Perl_dounwind
#define dowantarray Perl_dowantarray
#define dump_all Perl_dump_all
#define hv_iterval Perl_hv_iterval
#define hv_ksplit Perl_hv_ksplit
#define hv_magic Perl_hv_magic
-#define hv_stashpv Perl_hv_stashpv
#define hv_store Perl_hv_store
#define hv_store_ent Perl_hv_store_ent
#define hv_undef Perl_hv_undef
#define block_start CPerlObj::Perl_block_start
#define boot_core_UNIVERSAL CPerlObj::Perl_boot_core_UNIVERSAL
#define bset_obj_store CPerlObj::Perl_bset_obj_store
-#define bset_obj_store CPerlObj::Perl_bset_obj_store
#define byterun CPerlObj::Perl_byterun
#define cache_re CPerlObj::Perl_cache_re
#define call_list CPerlObj::Perl_call_list
+#define call_list_body CPerlObj::Perl_call_list_body
#define cando CPerlObj::Perl_cando
#define cast_i32 CPerlObj::Perl_cast_i32
#define cast_iv CPerlObj::Perl_cast_iv
#define do_vecset CPerlObj::Perl_do_vecset
#define do_vop CPerlObj::Perl_do_vop
#define docatch CPerlObj::Perl_docatch
+#define docatch_body CPerlObj::Perl_docatch_body
#define doencodes CPerlObj::Perl_doencodes
#define doeval CPerlObj::Perl_doeval
#define dofile CPerlObj::Perl_dofile
#define dofindlabel CPerlObj::Perl_dofindlabel
-#define dofindlabel CPerlObj::Perl_dofindlabel
#define doform CPerlObj::Perl_doform
-#define doopen CPerlObj::Perl_doopen
+#define doopen_pmc CPerlObj::Perl_doopen_pmc
#define doparseform CPerlObj::Perl_doparseform
#define dopoptoeval CPerlObj::Perl_dopoptoeval
-#define dopoptoeval CPerlObj::Perl_dopoptoeval
#define dopoptolabel CPerlObj::Perl_dopoptolabel
#define dopoptoloop CPerlObj::Perl_dopoptoloop
#define dopoptosub CPerlObj::Perl_dopoptosub
#define hv_iterval CPerlObj::Perl_hv_iterval
#define hv_ksplit CPerlObj::Perl_hv_ksplit
#define hv_magic CPerlObj::Perl_hv_magic
-#define hv_stashpv CPerlObj::Perl_hv_stashpv
#define hv_store CPerlObj::Perl_hv_store
#define hv_store_ent CPerlObj::Perl_hv_store_ent
#define hv_undef CPerlObj::Perl_hv_undef
#define peep CPerlObj::Perl_peep
#define perl_atexit CPerlObj::perl_atexit
#define perl_call_argv CPerlObj::perl_call_argv
+#define perl_call_body CPerlObj::perl_call_body
#define perl_call_method CPerlObj::perl_call_method
#define perl_call_pv CPerlObj::perl_call_pv
#define perl_call_sv CPerlObj::perl_call_sv
+#define perl_call_xbody CPerlObj::perl_call_xbody
#define perl_construct CPerlObj::perl_construct
#define perl_destruct CPerlObj::perl_destruct
#define perl_eval_pv CPerlObj::perl_eval_pv
#define perl_new_ctype CPerlObj::perl_new_ctype
#define perl_new_numeric CPerlObj::perl_new_numeric
#define perl_parse CPerlObj::perl_parse
+#define perl_parse_body CPerlObj::perl_parse_body
#define perl_require_pv CPerlObj::perl_require_pv
#define perl_run CPerlObj::perl_run
+#define perl_run_body CPerlObj::perl_run_body
#define perl_set_numeric_local CPerlObj::perl_set_numeric_local
#define perl_set_numeric_standard CPerlObj::perl_set_numeric_standard
#define pidgone CPerlObj::Perl_pidgone
refto
seed
docatch
+ docatch_body
+ perl_parse_body
+ perl_run_body
+ perl_call_body
+ perl_call_xbody
+ call_list_body
dofindlabel
doparseform
dopoptoeval
dopoptosub_at
save_lines
doeval
- doopen
+ doopen_pmc
sv_ncmp
sv_i_ncmp
amagic_ncmp
dump
do_aspawn
debprof
- bset_obj_store
new_logop
simplify_sort
is_handle_constructor
#
-# Copyright (c) 1996-1998 Malcolm Beattie
+# Copyright (c) 1996-1999 Malcolm Beattie
#
# You may distribute under the terms of either the GNU General Public
# License or the Artistic License, as specified in the README file.
#include "perl.h"
#include "XSUB.h"
-#include "byterun.c"
+#ifndef WIN32
+/* this is probably not needed manywhere */
+# include "byterun.c"
+#endif
/* defgv must be accessed differently under threaded perl */
/* DEFSV et al are in 5.004_56 */
byteloader_filter(int idx, SV *buf_sv, int maxlen)
#endif
{
+ dTHR;
OP *saveroot = PL_main_root;
OP *savestart = PL_main_start;
SaveError(CPERLarg_ char* pat, ...)
{
va_list args;
+ SV *msv;
char *message;
- int len;
+ STRLEN len;
/* This code is based on croak/warn, see mess() in util.c */
va_start(args, pat);
- message = mess(pat, &args);
+ msv = mess(pat, &args);
va_end(args);
- len = strlen(message) + 1 ; /* include terminating null char */
+ message = SvPV(msv,len);
+ len++; /* include terminating null char */
/* Allocate some memory for the error message */
if (LastError)
do_vecset
do_vop
dofile
-dofindlabel
-dopoptoeval
dounwind
dowantarray
dump_all
hv_iterval
hv_ksplit
hv_magic
-hv_stashpv
hv_store
hv_store_ent
hv_undef
}
#ifdef DYNAMIC_ENV_FETCH /* %ENV lookup? If so, try to fetch the value now */
if (HvNAME(hv) && strEQ(HvNAME(hv),ENV_HV_NAME)) {
- if ((sv = PerlEnv_ENVgetenv_sv(key)) != &PL_sv_undef) {
- SvTAINTED_on(sv);
- return hv_store(hv,key,klen,sv,hash);
- }
+ unsigned long len;
+ char *env = PerlEnv_ENVgetenv_len(key,&len);
+ if (env) {
+ sv = newSVpvn(env,len);
+ SvTAINTED_on(sv);
+ return hv_store(hv,key,klen,sv,hash);
+ }
}
#endif
if (lval) { /* gonna assign to this, so it better be there */
}
#ifdef DYNAMIC_ENV_FETCH /* %ENV lookup? If so, try to fetch the value now */
if (HvNAME(hv) && strEQ(HvNAME(hv),ENV_HV_NAME)) {
- if ((sv = PerlEnv_ENVgetenv_sv(key)) != &PL_sv_undef) {
- SvTAINTED_on(sv);
- return hv_store_ent(hv,keysv,sv,hash);
- }
+ unsigned long len;
+ char *env = PerlEnv_ENVgetenv_len(key,&len);
+ if (env) {
+ sv = newSVpvn(env,len);
+ SvTAINTED_on(sv);
+ return hv_store_ent(hv,keysv,sv,hash);
+ }
}
#endif
if (lval) { /* gonna assign to this, so it better be there */
return TRUE;
}
#ifdef DYNAMIC_ENV_FETCH /* is it out there? */
- if (HvNAME(hv) && strEQ(HvNAME(hv), ENV_HV_NAME) &&
- (sv = PerlEnv_ENVgetenv_sv(key)) != &PL_sv_undef) {
- SvTAINTED_on(sv);
- hv_store(hv,key,klen,sv,hash);
- return TRUE;
+ if (HvNAME(hv) && strEQ(HvNAME(hv), ENV_HV_NAME)) {
+ unsigned long len;
+ char *env = PerlEnv_ENVgetenv_len(key,&len);
+ if (env) {
+ sv = newSVpvn(env,len);
+ SvTAINTED_on(sv);
+ (void)hv_store(hv,key,klen,sv,hash);
+ return TRUE;
+ }
}
#endif
return FALSE;
return TRUE;
}
#ifdef DYNAMIC_ENV_FETCH /* is it out there? */
- if (HvNAME(hv) && strEQ(HvNAME(hv), ENV_HV_NAME) &&
- (sv = PerlEnv_ENVgetenv_sv(key)) != &PL_sv_undef) {
- SvTAINTED_on(sv);
- hv_store_ent(hv,keysv,sv,hash);
- return TRUE;
+ if (HvNAME(hv) && strEQ(HvNAME(hv), ENV_HV_NAME)) {
+ unsigned long len;
+ char *env = PerlEnv_ENVgetenv_len(key,&len);
+ if (env) {
+ sv = newSVpvn(env,len);
+ SvTAINTED_on(sv);
+ (void)hv_store_ent(hv,keysv,sv,hash);
+ return TRUE;
+ }
}
#endif
return FALSE;
{
public:
virtual char * Getenv(const char *varname, int &err) = 0;
-#ifdef HAS_ENVGETENV
- virtual char * ENVGetenv(const char *varname, int &err) = 0;
-#endif
virtual int Putenv(const char *envstring, int &err) = 0;
virtual char * LibPath(char *patchlevel) =0;
virtual char * SiteLibPath(char *patchlevel) =0;
virtual int Uname(struct utsname *name, int &err) =0;
+ virtual char * Getenv_len(const char *varname, unsigned long *len, int &err) = 0;
+#ifdef HAS_ENVGETENV
+ virtual char * ENVGetenv(const char *varname, int &err) = 0;
+ virtual char * ENVGetenv_len(const char *varname, unsigned long *len, int &err) = 0;
+#endif
};
#define PerlEnv_putenv(str) PL_piENV->Putenv((str), ErrorNo())
#define PerlEnv_getenv(str) PL_piENV->Getenv((str), ErrorNo())
-#define PerlEnv_getenv_sv(str) PL_piENV->getenv_sv((str))
+#define PerlEnv_getenv_len(str,l) PL_piENV->Getenv_len((str), (l), ErrorNo())
#ifdef HAS_ENVGETENV
# define PerlEnv_ENVgetenv(str) PL_piENV->ENVGetenv((str), ErrorNo())
-# define PerlEnv_ENVgetenv_sv(str) PL_piENV->ENVgetenv_sv((str))
+# define PerlEnv_ENVgetenv_len(str,l) PL_piENV->ENVGetenv_len((str), (l), ErrorNo())
#else
# define PerlEnv_ENVgetenv(str) PerlEnv_getenv((str))
-# define PerlEnv_ENVgetenv_sv(str) PerlEnv_getenv_sv((str))
+# define PerlEnv_ENVgetenv_len(str,l) PerlEnv_getenv_len((str),(l))
#endif
#define PerlEnv_uname(name) PL_piENV->Uname((name), ErrorNo())
#ifdef WIN32
#define PerlEnv_putenv(str) putenv((str))
#define PerlEnv_getenv(str) getenv((str))
-#define PerlEnv_getenv_sv(str) getenv_sv((str))
+#define PerlEnv_getenv_len(str,l) getenv_len((str), (l))
#ifdef HAS_ENVGETENV
# define PerlEnv_ENVgetenv(str) ENVgetenv((str))
-# define PerlEnv_ENVgetenv_sv(str) ENVgetenv_sv((str))
+# define PerlEnv_ENVgetenv_len(str,l) ENVgetenv_len((str), (l))
#else
# define PerlEnv_ENVgetenv(str) PerlEnv_getenv((str))
-# define PerlEnv_ENVgetenv_sv(str) PerlEnv_getenv_sv((str))
+# define PerlEnv_ENVgetenv_len(str,l) PerlEnv_getenv_len((str), (l))
#endif
#define PerlEnv_uname(name) uname((name))
#define boot_core_UNIVERSAL pPerl->Perl_boot_core_UNIVERSAL
#undef bset_obj_store
#define bset_obj_store pPerl->Perl_bset_obj_store
-#undef bset_obj_store
-#define bset_obj_store pPerl->Perl_bset_obj_store
#undef byterun
#define byterun pPerl->Perl_byterun
#undef cache_re
#define cache_re pPerl->Perl_cache_re
#undef call_list
#define call_list pPerl->Perl_call_list
+#undef call_list_body
+#define call_list_body pPerl->Perl_call_list_body
#undef cando
#define cando pPerl->Perl_cando
#undef cast_i32
#define do_vop pPerl->Perl_do_vop
#undef docatch
#define docatch pPerl->Perl_docatch
+#undef docatch_body
+#define docatch_body pPerl->Perl_docatch_body
#undef doencodes
#define doencodes pPerl->Perl_doencodes
#undef doeval
#define dofile pPerl->Perl_dofile
#undef dofindlabel
#define dofindlabel pPerl->Perl_dofindlabel
-#undef dofindlabel
-#define dofindlabel pPerl->Perl_dofindlabel
#undef doform
#define doform pPerl->Perl_doform
-#undef doopen
-#define doopen pPerl->Perl_doopen
+#undef doopen_pmc
+#define doopen_pmc pPerl->Perl_doopen_pmc
#undef doparseform
#define doparseform pPerl->Perl_doparseform
#undef dopoptoeval
#define dopoptoeval pPerl->Perl_dopoptoeval
-#undef dopoptoeval
-#define dopoptoeval pPerl->Perl_dopoptoeval
#undef dopoptolabel
#define dopoptolabel pPerl->Perl_dopoptolabel
#undef dopoptoloop
#define hv_ksplit pPerl->Perl_hv_ksplit
#undef hv_magic
#define hv_magic pPerl->Perl_hv_magic
-#undef hv_stashpv
-#define hv_stashpv pPerl->Perl_hv_stashpv
#undef hv_store
#define hv_store pPerl->Perl_hv_store
#undef hv_store_ent
#define perl_atexit pPerl->perl_atexit
#undef perl_call_argv
#define perl_call_argv pPerl->perl_call_argv
+#undef perl_call_body
+#define perl_call_body pPerl->perl_call_body
#undef perl_call_method
#define perl_call_method pPerl->perl_call_method
#undef perl_call_pv
#define perl_call_pv pPerl->perl_call_pv
#undef perl_call_sv
#define perl_call_sv pPerl->perl_call_sv
+#undef perl_call_xbody
+#define perl_call_xbody pPerl->perl_call_xbody
#undef perl_construct
#define perl_construct pPerl->perl_construct
#undef perl_destruct
#define perl_new_numeric pPerl->perl_new_numeric
#undef perl_parse
#define perl_parse pPerl->perl_parse
+#undef perl_parse_body
+#define perl_parse_body pPerl->perl_parse_body
#undef perl_require_pv
#define perl_require_pv pPerl->perl_require_pv
#undef perl_run
#define perl_run pPerl->perl_run
+#undef perl_run_body
+#define perl_run_body pPerl->perl_run_body
#undef perl_set_numeric_local
#define perl_set_numeric_local pPerl->perl_set_numeric_local
#undef perl_set_numeric_standard
}
else {
I32 flags = OPf_SPECIAL;
- I32 private = 0;
+ I32 priv = 0;
/* is this op a FH constructor? */
if (is_handle_constructor(o,numargs)) {
flags = 0;
* need to "prove" flag does not mean something
* else already - NI-S 1999/05/07
*/
- private = OPpDEREF;
+ priv = OPpDEREF;
#if 0
/* Helps with open($array[$n],...)
but is too simplistic - need to do selectively
}
kid->op_sibling = 0;
kid = newUNOP(OP_RV2GV, flags, scalar(kid));
- if (private) {
- kid->op_private |= private;
+ if (priv) {
+ kid->op_private |= priv;
}
}
kid->op_sibling = sibl;
++PL_exitlistlen;
}
+#ifdef PERL_OBJECT
+ typedef void (*xs_init_t)(CPerlObj*);
+#else
+ typedef void (*xs_init_t)(void);
+#endif
+
int
#ifdef PERL_OBJECT
-perl_parse(void (*xsinit) (CPerlObj*), int argc, char **argv, char **env)
+perl_parse(xs_init_t xsinit, int argc, char **argv, char **env)
#else
-perl_parse(PerlInterpreter *sv_interp, void (*xsinit) (void), int argc, char **argv, char **env)
+perl_parse(PerlInterpreter *sv_interp, xs_init_t xsinit, int argc, char **argv, char **env)
#endif
{
dTHR;
oldscope = PL_scopestack_ix;
PL_dowarn = G_WARN_OFF;
- CALLPROTECT(&ret, perl_parse_body, env
-#ifndef PERL_OBJECT
- , xsinit
-#endif
- );
+ CALLPROTECT(&ret, FUNC_NAME_TO_PTR(perl_parse_body), env, xsinit);
switch (ret) {
case 0:
return 0;
PerlIO_printf(PerlIO_stderr(), "panic: top_env\n");
return 1;
}
+ return 0;
}
STATIC void *
register SV *sv;
register char *s;
-#ifndef PERL_OBJECT
- typedef void (*xs_init_t)(void);
xs_init_t xsinit = va_arg(args, xs_init_t);
-#endif
sv_setpvn(PL_linestr,"",0);
sv = newSVpvn("",0); /* first used for -I flags */
oldscope = PL_scopestack_ix;
redo_body:
- CALLPROTECT(&ret, perl_run_body, oldscope);
+ CALLPROTECT(&ret, FUNC_NAME_TO_PTR(perl_run_body), oldscope);
switch (ret) {
case 1:
cxstack_ix = -1; /* start context stack again */
PL_markstack_ptr++;
redo_body:
- CALLPROTECT(&ret, perl_call_body, (OP*)&myop, FALSE);
+ CALLPROTECT(&ret, FUNC_NAME_TO_PTR(perl_call_body), (OP*)&myop, FALSE);
switch (ret) {
case 0:
retval = PL_stack_sp - (PL_stack_base + oldmark);
myop.op_flags |= OPf_SPECIAL;
redo_body:
- CALLPROTECT(&ret, perl_call_body, (OP*)&myop, TRUE);
+ CALLPROTECT(&ret, FUNC_NAME_TO_PTR(perl_call_body), (OP*)&myop, TRUE);
switch (ret) {
case 0:
retval = PL_stack_sp - (PL_stack_base + oldmark);
while (AvFILL(paramList) >= 0) {
cv = (CV*)av_shift(paramList);
SAVEFREESV(cv);
- CALLPROTECT(&ret, call_list_body, cv);
+ CALLPROTECT(&ret, FUNC_NAME_TO_PTR(call_list_body), cv);
switch (ret) {
case 0:
(void)SvPV(atsv, len);
# endif
#else
/* VMS and some other platforms don't use the environ array */
-# if !defined(VMS) || \
- !defined(DONT_DECLARE_STD) || \
- (defined(__svr4__) && defined(__GNUC__) && defined(sun)) || \
- defined(__sgi) || \
- defined(__DGUX)
+# if !defined(VMS)
+# if !defined(DONT_DECLARE_STD) || \
+ (defined(__svr4__) && defined(__GNUC__) && defined(sun)) || \
+ defined(__sgi) || \
+ defined(__DGUX)
extern char ** environ; /* environment variables supplied via exec */
+# endif
# endif
#endif
if (!(sv = LvTARG(sv)))
sv = &PL_sv_undef;
else
- SvREFCNT_inc(sv);
+ (void)SvREFCNT_inc(sv);
}
else if (SvPADTMP(sv))
sv = newSVsv(sv);
static I32 sortcv _((SV *a, SV *b));
static void qsortsv _((SV **array, size_t num_elts, I32 (*fun)(SV *a, SV *b)));
static OP *doeval _((int gimme, OP** startop));
-static PerlIO *doopen _((const char *name, const char *mode));
+static PerlIO *doopen_pmc _((const char *name, const char *mode));
static I32 sv_ncmp _((SV *a, SV *b));
static I32 sv_i_ncmp _((SV *a, SV *b));
static I32 amagic_ncmp _((SV *a, SV *b));
#endif
PL_op = o;
redo_body:
- CALLPROTECT(&ret, docatch_body);
+ CALLPROTECT(&ret, FUNC_NAME_TO_PTR(docatch_body));
switch (ret) {
case 0:
break;
RETURNOP(PL_eval_start);
}
-static PerlIO *
-doopen(const char *name, const char *mode)
+STATIC PerlIO *
+doopen_pmc(const char *name, const char *mode)
{
STRLEN namelen = strlen(name);
PerlIO *fp;
if (namelen > 3 && strcmp(name + namelen - 3, ".pm") == 0) {
- SV *pmcsv = newSVpvf("%s%c", name, 'c');
+ SV *pmcsv = newSVpvf("%s%c", name, 'c');
char *pmc = SvPV_nolen(pmcsv);
Stat_t pmstat;
- Stat_t pmcstat;
- if (PerlLIO_stat(pmc, &pmcstat) < 0) {
+ Stat_t pmcstat;
+ if (PerlLIO_stat(pmc, &pmcstat) < 0) {
fp = PerlIO_open(name, mode);
- } else {
+ }
+ else {
if (PerlLIO_stat(name, &pmstat) < 0 ||
- pmstat.st_mtime < pmcstat.st_mtime) {
- fp = PerlIO_open(pmc, mode);
- } else {
- fp = PerlIO_open(name, mode);
- }
+ pmstat.st_mtime < pmcstat.st_mtime)
+ {
+ fp = PerlIO_open(pmc, mode);
+ }
+ else {
+ fp = PerlIO_open(name, mode);
+ }
}
- SvREFCNT_dec(pmcsv);
- } else {
- fp = PerlIO_open(name, mode);
+ SvREFCNT_dec(pmcsv);
+ }
+ else {
+ fp = PerlIO_open(name, mode);
}
-
return fp;
}
)
{
tryname = name;
- tryrsfp = doopen(name,PERL_SCRIPT_MODE);
+ tryrsfp = doopen_pmc(name,PERL_SCRIPT_MODE);
}
else {
AV *ar = GvAVn(PL_incgv);
#endif
TAINT_PROPER("require");
tryname = SvPVX(namesv);
- tryrsfp = doopen(tryname, PERL_SCRIPT_MODE);
+ tryrsfp = doopen_pmc(tryname, PERL_SCRIPT_MODE);
if (tryrsfp) {
if (tryname[0] == '.' && tryname[1] == '/')
tryname += 2;
VIRTUAL bool do_close _((GV* gv, bool not_implicit));
VIRTUAL bool do_eof _((GV* gv));
VIRTUAL bool do_exec _((char* cmd));
+#ifndef WIN32
VIRTUAL bool do_exec3 _((char* cmd, int fd, int flag));
+#endif
VIRTUAL void do_execfree _((void));
#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
I32 do_ipcctl _((I32 optype, SV** mark, SV** sp));
VIRTUAL char* form _((const char* pat, ...));
VIRTUAL void free_tmps _((void));
VIRTUAL OP* gen_constant_list _((OP* o));
-#ifndef HAS_GETENV_SV
-VIRTUAL SV* getenv_sv _((char* key));
+#ifndef HAS_GETENV_LEN
+VIRTUAL char* getenv_len _((char* key, unsigned long *len));
#endif
VIRTUAL void gp_free _((GV* gv));
VIRTUAL GP* gp_ref _((GP* gp));
I32 dopoptosub_at _((PERL_CONTEXT* cxstk, I32 startingblock));
void save_lines _((AV *array, SV *sv));
OP *doeval _((int gimme, OP** startop));
-PerlIO *doopen _((const char *name, const char *mode));
+PerlIO *doopen_pmc _((const char *name, const char *mode));
I32 sv_ncmp _((SV *a, SV *b));
I32 sv_i_ncmp _((SV *a, SV *b));
I32 amagic_ncmp _((SV *a, SV *b));
#endif
void debprof _((OP *o));
-void *bset_obj_store _((void *obj, I32 ix));
OP *new_logop _((I32 type, I32 flags, OP **firstp, OP **otherp));
void simplify_sort _((OP *o));
bool is_handle_constructor _((OP *o, I32 argnum));
VIRTUAL void do_pmop_dump _((I32 level, PerlIO *file, PMOP *pm));
VIRTUAL void do_sv_dump _((I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim));
VIRTUAL void magic_dump _((MAGIC *mg));
-VIRTUAL void* default_protect _((int *except, protect_body_t, ...));
+VIRTUAL void* default_protect _((int *excpt, protect_body_t body, ...));
VIRTUAL void reginitcolors _((void));
VIRTUAL char* sv_2pv_nolen _((SV* sv));
VIRTUAL char* sv_pv _((SV *sv));
VIRTUAL void sv_force_normal _((SV *sv));
VIRTUAL void tmps_grow _((I32 n));
+VIRTUAL void *bset_obj_store _((void *obj, I32 ix));
-VIRTUAL SV* sv_rvweaken _((SV *));
+VIRTUAL SV* sv_rvweaken _((SV *sv));
VIRTUAL int magic_killbackrefs _((SV *sv, MAGIC *mg));
#include "perl.h"
void *
-default_protect(int *except, protect_body_t body, ...)
+default_protect(int *excpt, protect_body_t body, ...)
{
dTHR;
dJMPENV;
ret = NULL;
else {
va_start(args, body);
- ret = body(args);
+ ret = CALL_FPTR(body)(args);
va_end(args);
}
- *except = ex;
+ *excpt = ex;
JMPENV_POP;
return ret;
}
* Function that catches/throws, and its callback for the
* body of protected processing.
*/
-typedef void *(CPERLscope(*protect_body_t)) _((va_list args));
-typedef void *(CPERLscope(*protect_proc_t))
- _((int *except, protect_body_t, ...));
+typedef void *(CPERLscope(*protect_body_t)) _((va_list));
+typedef void *(CPERLscope(*protect_proc_t)) _((int *, protect_body_t, ...));
/*
* How to build the first jmpenv.
# my $file tests
-unlink("afile.new") if -f "afile";
+unlink("afile") if -f "afile";
print "$!\nnot " unless open(my $f,"+>afile");
print "ok 1\n";
+binmode $f;
print "not " unless -f "afile";
print "ok 2\n";
print "not " unless print $f "SomeData\n";
s/\.exe//i if $Is_Dos;
s{\bminiperl\b}{perl}; # so that test doesn't fail with miniperl
s{is perl}{is $perl}; # for systems where $^X is only a basename
+ s{\\}{/}g;
ok 23, ($Is_MSWin32 ? uc($_) eq uc($s1) : $_ eq $s1), ":$_:!=:$s1:";
$_ = `$perl $script`;
s/\.exe//i if $Is_Dos;
+ s{\\}{/}g;
ok 24, ($Is_MSWin32 ? uc($_) eq uc($s1) : $_ eq $s1), ":$_:!=:$s1: after `$perl $script`";
ok 25, unlink($script), $!;
}
return;
/* if filter is on top of stack (usual case) just pop it off */
if (IoDIRP(FILTER_DATA(AvFILLp(PL_rsfp_filters))) == (DIR*)funcp){
+ IoDIRP(FILTER_DATA(AvFILLp(PL_rsfp_filters))) = NULL;
sv_free(av_pop(PL_rsfp_filters));
return;
return PL_specialsv_list;
}
-#ifndef HAS_GETENV_SV
-SV *
-getenv_sv(char *env_elem)
-{
- char *env_trans;
- SV *temp_sv;
- if ((env_trans = PerlEnv_getenv(env_elem)) != Nullch) {
- temp_sv = newSVpv(env_trans, strlen(env_trans));
- return temp_sv;
- } else {
- return &PL_sv_undef;
- }
+#ifndef HAS_GETENV_LEN
+char *
+getenv_len(char *env_elem, unsigned long *len)
+{
+ char *env_trans = PerlEnv_getenv(env_elem);
+ if (env_trans)
+ *len = strlen(env_trans);
+ return env_trans;
}
#endif
* Note: Uses Perl temp to store result so char * can be returned to
* caller; this pointer will be invalidated at next Perl statement
* transition.
- * We define this as a function rather than a macro in terms of my_getenv_sv()
+ * We define this as a function rather than a macro in terms of my_getenv_len()
* so that it'll work when PL_curinterp is undefined (and we therefore can't
* allocate SVs).
*/
/*}}}*/
-/*{{{ SV *my_getenv_sv(const char *lnm, bool sys)*/
-SV *
-my_getenv_sv(const char *lnm, bool sys)
+/*{{{ SV *my_getenv_len(const char *lnm, bool sys)*/
+char *
+my_getenv_len(const char *lnm, unsigned long *len, bool sys)
{
char buf[LNM$C_NAMLENGTH+1], *cp1, *cp2;
- unsigned long int len, idx = 0;
+ unsigned long idx = 0;
for (cp1 = (char *)lnm, cp2 = buf; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
if (cp1 - lnm == 7 && !strncmp(buf,"DEFAULT",7)) {
getcwd(buf,LNM$C_NAMLENGTH);
- return newSVpv(buf,0);
+ *len = strlen(buf);
+ return buf;
}
else {
if ((cp2 = strchr(lnm,';')) != NULL) {
idx = strtoul(cp2+1,NULL,0);
lnm = buf;
}
- if ((len = vmstrnenv(lnm,buf,idx,
+ if ((*len = vmstrnenv(lnm,buf,idx,
sys ? fildev : NULL,
#ifdef SECURE_INTERNAL_GETENV
sys ? PERL__TRNENV_SECURE : 0
#else
0
#endif
- ))) return newSVpv(buf,len);
- else return &PL_sv_undef;
+ )))
+ return buf;
+ else return Nullch;
}
-} /* end of my_getenv_sv() */
+} /* end of my_getenv_len() */
/*}}}*/
static void create_mbx(unsigned short int *, struct dsc$descriptor_s *);
/* getenv used for regular logical names */
# define getenv(v) my_getenv(v,TRUE)
#endif
-#define getenv_sv(v) my_getenv_sv(v,TRUE)
+#define getenv_len(v,l) my_getenv_len(v,l,TRUE)
/* DECC introduces this routine in the RTL as of VMS 7.0; for now,
* we'll use ours, since it gives us the full VMS exit status. */
#define vmstrnenv Perl_vmstrnenv
#define my_trnlnm Perl_my_trnlnm
#define my_getenv Perl_my_getenv
-#define my_getenv_sv Perl_my_getenv_sv
+#define my_getenv_len Perl_my_getenv_len
#define prime_env_iter Perl_prime_env_iter
#define vmssetenv Perl_vmssetenv
#define my_setenv Perl_my_setenv
#define ENV_HV_NAME "%EnV%VmS%"
/* Special getenv function for retrieving %ENV elements. */
#define ENVgetenv(v) my_getenv(v,FALSE)
-#define ENVgetenv_sv(v) my_getenv_sv(v,FALSE)
+#define ENVgetenv_len(v,l) my_getenv_len(v,l,FALSE)
/* Thin jacket around cuserid() tomatch Unix' calling sequence */
int vmstrnenv _((const char *, char *, unsigned long int, struct dsc$descriptor_s **, unsigned long int));
int my_trnlnm _((const char *, char *, unsigned long int));
char * my_getenv _((const char *, bool));
-SV * my_getenv_sv _((const char *, bool));
+char * my_getenv_len _((const char *, unsigned long *, bool));
int vmssetenv _((char *, char *, struct dsc$descriptor_s **));
char * my_crypt _((const char *, const char *));
Pid_t my_waitpid _((Pid_t, int *, int));
safexfree
Perl_GetVars
malloced_size
+do_exec3
+getenv_len
)];
#undef $name
extern "C" $type $funcName ($args)
{
- char *pstr;
- char *pmsg;
+ SV *pmsg;
va_list args;
va_start(args, $arg);
- pmsg = pPerl->Perl_mess($arg, &args);
- New(0, pstr, strlen(pmsg)+1, char);
- strcpy(pstr, pmsg);
-$return pPerl->Perl_$name($start pstr);
+ pmsg = pPerl->Perl_sv_2mortal(pPerl->Perl_newSVsv(pPerl->Perl_mess($arg, &args)));
+$return pPerl->Perl_$name($start SvPV_nolen(pmsg));
va_end(args);
}
ENDCODE
DUMPER = $(EXTDIR)\Data\Dumper\Dumper
ERRNO = $(EXTDIR)\Errno\Errno
PEEK = $(EXTDIR)\Devel\Peek\Peek
-BYTELOADER = $(EXTDIR)\ByteLoader
+BYTELOADER = $(EXTDIR)\ByteLoader\ByteLoader
SOCKET_DLL = $(AUTODIR)\Socket\Socket.dll
FCNTL_DLL = $(AUTODIR)\Fcntl\Fcntl.dll
## Configured by: ~cf_email~
## Target system: WIN32
Author=''
-CONFIG='true'
+CONFIGDOTSH='true'
Date='$Date'
Header=''
Id='$Id'
## Configured by: ~cf_email~
## Target system: WIN32
Author=''
-CONFIG='true'
+CONFIGDOTSH='true'
Date='$Date'
Header=''
Id='$Id'
## Configured by: ~cf_email~
## Target system: WIN32
Author=''
-CONFIG='true'
+CONFIGDOTSH='true'
Date='$Date'
Header=''
Id='$Id'
PL_sortcxix
PL_sublex_info
PL_timesbuf
+Perl_do_exec3
Perl_do_ipcctl
Perl_do_ipcget
Perl_do_msgrcv
__DATA__
# extra globals not included above.
perl_init_i18nl10n
-perl_init_ext
perl_alloc
perl_atexit
perl_construct
DUMPER = $(EXTDIR)\Data\Dumper\Dumper
ERRNO = $(EXTDIR)\Errno\Errno
PEEK = $(EXTDIR)\Devel\Peek\Peek
-BYTELOADER = $(EXTDIR)\ByteLoader
+BYTELOADER = $(EXTDIR)\ByteLoader\ByteLoader
SOCKET_DLL = $(AUTODIR)\Socket\Socket.dll
FCNTL_DLL = $(AUTODIR)\Fcntl\Fcntl.dll
{
return win32_uname(name);
};
+ virtual char *Getenv_len(const char *varname, unsigned long *len, int &err)
+ {
+ char *e = win32_getenv(varname);
+ if (e)
+ *len = strlen(e);
+ return e;
+ };
};
class CPerlSock : public IPerlSock
CPerlObj *pPerl;
-#undef PERL_SYS_INIT
-#define PERL_SYS_INIT(a, c)
-
int
main(int argc, char **argv, char **env)
{
argv[0] = szModuleName;
#endif
+ PERL_SYS_INIT(&argc,&argv);
+
if (!host.PerlCreate())
exit(exitstatus);
SYSTEM_INFO info;
char *arch;
GetSystemInfo(&info);
+
+#ifdef __BORLANDC__
+ switch (info.u.s.wProcessorArchitecture) {
+#else
switch (info.wProcessorArchitecture) {
+#endif
case PROCESSOR_ARCHITECTURE_INTEL:
arch = "x86"; break;
case PROCESSOR_ARCHITECTURE_MIPS:
XS(w32_GetTickCount)
{
dXSARGS;
- EXTEND(SP,1);
DWORD msec = GetTickCount();
+ EXTEND(SP,1);
if ((IV)msec > 0)
XSRETURN_IV(msec);
XSRETURN_NV(msec);
#ifdef PERL_OBJECT
# define DYNAMIC_ENV_FETCH
# define ENV_HV_NAME "___ENV_HV_NAME___"
+# define HAS_GETENV_LEN
# define prime_env_iter()
# define WIN32IO_IS_STDIO /* don't pull in custom stdio layer */
# ifdef PERL_GLOBAL_STRUCT
typedef long uid_t;
typedef long gid_t;
+typedef unsigned short mode_t;
#pragma warning(disable: 4018 4035 4101 4102 4244 4245 4761)
#ifndef PERL_OBJECT
projects / platform / upstream / perl.git / commitdiff