From: Gurusamy Sarathy Date: Tue, 11 May 1999 09:34:13 +0000 (+0000) Subject: various fixes for clean build and test on win32; configpm broken, X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=a6c403648ecd5cc72235fdb1e7535523a8ff2ac9;p=p5sagit%2Fp5-mst-13.2.git various fixes for clean build and test on win32; configpm broken, needed to open myconfig.SH rather than myconfig; sundry adjustments to bytecode stuff; tweaks to DYNAMIC_ENV_FETCH code to make it work under win32; getenv_sv() changed to getenv_len() since SVs aren't visible in the lower echelons; remove bogus exports from config.sym; PERL_OBJECT-ness for C++ exception support; null out IoDIRP in filter_del() or sv_free() will attempt to close it p4raw-id: //depot/perl@3387 --- diff --git a/Changes b/Changes index dd39e11..a19392f 100644 --- a/Changes +++ b/Changes @@ -79,6 +79,41 @@ Version 5.005_57 Development release working toward 5.006 ---------------- ____________________________________________________________________________ +[ 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 + ) + 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 diff --git a/bytecode.pl b/bytecode.pl index c61b7aa..f53b0ce 100644 --- a/bytecode.pl +++ b/bytecode.pl @@ -169,8 +169,6 @@ struct bytestream { }; #endif /* INDIRECT_BGET_MACROS */ -void *bset_obj_store _((void *, I32)); - enum { EOT diff --git a/byterun.c b/byterun.c index f6c5232..f8c07f9 100644 --- a/byterun.c +++ b/byterun.c @@ -1,5 +1,5 @@ /* - * 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. diff --git a/byterun.h b/byterun.h index 430de55..3aac6fa 100644 --- a/byterun.h +++ b/byterun.h @@ -1,5 +1,5 @@ /* - * 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. @@ -17,8 +17,6 @@ struct bytestream { }; #endif /* INDIRECT_BGET_MACROS */ -void *bset_obj_store _((void *, I32)); - enum { INSN_RET, /* 0 */ INSN_LDSV, /* 1 */ diff --git a/configpm b/configpm index 4c9eb12..dd9e858 100755 --- a/configpm +++ b/configpm @@ -81,11 +81,11 @@ print CONFIG "\n", 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,") && !/^Summary of/; do { print CONFIG $_ } until !defined($_ = ) || /^\s*$/; close(MYCONFIG); diff --git a/embed.h b/embed.h index cabef95..aba2f59 100644 --- a/embed.h +++ b/embed.h @@ -137,8 +137,6 @@ #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 @@ -205,7 +203,6 @@ #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 @@ -1012,10 +1009,10 @@ #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 @@ -1137,16 +1134,15 @@ #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 @@ -1233,7 +1229,6 @@ #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 @@ -1480,9 +1475,11 @@ #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 @@ -1498,8 +1495,10 @@ #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 diff --git a/embed.pl b/embed.pl index 19f68a9..2fde0dd 100755 --- a/embed.pl +++ b/embed.pl @@ -245,6 +245,12 @@ my @staticfuncs = qw( refto seed docatch + docatch_body + perl_parse_body + perl_run_body + perl_call_body + perl_call_xbody + call_list_body dofindlabel doparseform dopoptoeval @@ -254,7 +260,7 @@ my @staticfuncs = qw( dopoptosub_at save_lines doeval - doopen + doopen_pmc sv_ncmp sv_i_ncmp amagic_ncmp @@ -372,7 +378,6 @@ my @staticfuncs = qw( dump do_aspawn debprof - bset_obj_store new_logop simplify_sort is_handle_constructor diff --git a/ext/B/B/Asmdata.pm b/ext/B/B/Asmdata.pm index ddc391b..d4128b6 100644 --- a/ext/B/B/Asmdata.pm +++ b/ext/B/B/Asmdata.pm @@ -1,5 +1,5 @@ # -# 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. diff --git a/ext/ByteLoader/ByteLoader.xs b/ext/ByteLoader/ByteLoader.xs index 98053c7..24c3ae8 100644 --- a/ext/ByteLoader/ByteLoader.xs +++ b/ext/ByteLoader/ByteLoader.xs @@ -2,7 +2,10 @@ #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 */ @@ -17,6 +20,7 @@ byteloader_filter(CPerlObj *pPerl, int idx, SV *buf_sv, int maxlen) byteloader_filter(int idx, SV *buf_sv, int maxlen) #endif { + dTHR; OP *saveroot = PL_main_root; OP *savestart = PL_main_start; diff --git a/ext/DynaLoader/dlutils.c b/ext/DynaLoader/dlutils.c index bfa1f78..3bd58ed 100644 --- a/ext/DynaLoader/dlutils.c +++ b/ext/DynaLoader/dlutils.c @@ -48,16 +48,18 @@ static void 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) diff --git a/global.sym b/global.sym index b46c106..1e739bc 100644 --- a/global.sym +++ b/global.sym @@ -128,8 +128,6 @@ do_trans do_vecset do_vop dofile -dofindlabel -dopoptoeval dounwind dowantarray dump_all @@ -196,7 +194,6 @@ hv_iternextsv hv_iterval hv_ksplit hv_magic -hv_stashpv hv_store hv_store_ent hv_undef diff --git a/hv.c b/hv.c index e7a73ce..d21af5c 100644 --- a/hv.c +++ b/hv.c @@ -150,10 +150,13 @@ hv_fetch(HV *hv, const char *key, U32 klen, I32 lval) } #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 */ @@ -238,10 +241,13 @@ hv_fetch_ent(HV *hv, SV *keysv, I32 lval, register U32 hash) } #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 */ @@ -613,11 +619,15 @@ hv_exists(HV *hv, const char *key, U32 klen) 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; @@ -680,11 +690,15 @@ hv_exists_ent(HV *hv, SV *keysv, U32 hash) 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; diff --git a/iperlsys.h b/iperlsys.h index 7251e8f..5f0ed0c 100644 --- a/iperlsys.h +++ b/iperlsys.h @@ -447,24 +447,26 @@ class IPerlEnv { 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 @@ -476,13 +478,13 @@ public: #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)) diff --git a/objXSUB.h b/objXSUB.h index 53ad4e2..0305bf0 100644 --- a/objXSUB.h +++ b/objXSUB.h @@ -881,14 +881,14 @@ #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 @@ -1131,6 +1131,8 @@ #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 @@ -1139,18 +1141,14 @@ #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 @@ -1323,8 +1321,6 @@ #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 @@ -1817,12 +1813,16 @@ #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 @@ -1853,10 +1853,14 @@ #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 diff --git a/op.c b/op.c index 13f2a15..919d9d8 100644 --- a/op.c +++ b/op.c @@ -4782,7 +4782,7 @@ ck_fun(OP *o) } 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; @@ -4790,7 +4790,7 @@ ck_fun(OP *o) * 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 @@ -4800,8 +4800,8 @@ ck_fun(OP *o) } 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; diff --git a/perl.c b/perl.c index daa15cc..a08b95e 100644 --- a/perl.c +++ b/perl.c @@ -630,11 +630,17 @@ perl_atexit(void (*fn) (void *), void *ptr) ++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; @@ -690,11 +696,7 @@ setuid perl scripts securely.\n"); 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; @@ -714,6 +716,7 @@ setuid perl scripts securely.\n"); PerlIO_printf(PerlIO_stderr(), "panic: top_env\n"); return 1; } + return 0; } STATIC void * @@ -731,10 +734,7 @@ perl_parse_body(va_list args) 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 */ @@ -1071,7 +1071,7 @@ perl_run(PerlInterpreter *sv_interp) 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 */ @@ -1321,7 +1321,7 @@ perl_call_sv(SV *sv, I32 flags) 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); @@ -1443,7 +1443,7 @@ perl_eval_sv(SV *sv, I32 flags) 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); @@ -3005,7 +3005,7 @@ call_list(I32 oldscope, AV *paramList) 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); diff --git a/perl.h b/perl.h index 14e891c..5cbecd2 100644 --- a/perl.h +++ b/perl.h @@ -1903,12 +1903,13 @@ EXT char *** environ_pointer; # 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 diff --git a/pp.c b/pp.c index 34fffef..431dc9a 100644 --- a/pp.c +++ b/pp.c @@ -531,7 +531,7 @@ refto(SV *sv) if (!(sv = LvTARG(sv))) sv = &PL_sv_undef; else - SvREFCNT_inc(sv); + (void)SvREFCNT_inc(sv); } else if (SvPADTMP(sv)) sv = newSVsv(sv); diff --git a/pp_ctl.c b/pp_ctl.c index 9d6d063..621024a 100644 --- a/pp_ctl.c +++ b/pp_ctl.c @@ -42,7 +42,7 @@ static void save_lines _((AV *array, SV *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)); @@ -2511,7 +2511,7 @@ docatch(OP *o) #endif PL_op = o; redo_body: - CALLPROTECT(&ret, docatch_body); + CALLPROTECT(&ret, FUNC_NAME_TO_PTR(docatch_body)); switch (ret) { case 0: break; @@ -2776,32 +2776,35 @@ doeval(int gimme, OP** startop) 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; } @@ -2855,7 +2858,7 @@ PP(pp_require) ) { tryname = name; - tryrsfp = doopen(name,PERL_SCRIPT_MODE); + tryrsfp = doopen_pmc(name,PERL_SCRIPT_MODE); } else { AV *ar = GvAVn(PL_incgv); @@ -2879,7 +2882,7 @@ PP(pp_require) #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; diff --git a/proto.h b/proto.h index 526a0ff..f2f45a7 100644 --- a/proto.h +++ b/proto.h @@ -99,7 +99,9 @@ VIRTUAL void do_chop _((SV* asv, SV* sv)); 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)); @@ -155,8 +157,8 @@ VIRTUAL OP* fold_constants _((OP* arg)); 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)); @@ -759,7 +761,7 @@ I32 dopoptosub _((I32 startingblock)); 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)); @@ -896,7 +898,6 @@ void del_sv _((SV *p)); #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)); @@ -975,12 +976,13 @@ VIRTUAL void do_op_dump _((I32 level, PerlIO *file, OP *o)); 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)); diff --git a/scope.c b/scope.c index 6c9c427..ad7fe29 100644 --- a/scope.c +++ b/scope.c @@ -16,7 +16,7 @@ #include "perl.h" void * -default_protect(int *except, protect_body_t body, ...) +default_protect(int *excpt, protect_body_t body, ...) { dTHR; dJMPENV; @@ -31,10 +31,10 @@ default_protect(int *except, protect_body_t body, ...) 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; } diff --git a/scope.h b/scope.h index 1502d4f..b217fea 100644 --- a/scope.h +++ b/scope.h @@ -159,9 +159,8 @@ typedef struct jmpenv JMPENV; * 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. diff --git a/t/io/open.t b/t/io/open.t index 50ae38d..63079c8 100755 --- a/t/io/open.t +++ b/t/io/open.t @@ -8,9 +8,10 @@ print "1..9\n"; # 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"; diff --git a/t/op/magic.t b/t/op/magic.t index 8486512..17246f6 100755 --- a/t/op/magic.t +++ b/t/op/magic.t @@ -155,9 +155,11 @@ EOF 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), $!; } diff --git a/toke.c b/toke.c index e9234f6..6f846dc 100644 --- a/toke.c +++ b/toke.c @@ -1487,6 +1487,7 @@ filter_del(filter_t funcp) 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; diff --git a/util.c b/util.c index ba77288..9ea0851 100644 --- a/util.c +++ b/util.c @@ -3079,18 +3079,14 @@ get_specialsv_list(void) 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 diff --git a/vms/vms.c b/vms/vms.c index 1212555..ebb05a1 100644 --- a/vms/vms.c +++ b/vms/vms.c @@ -207,7 +207,7 @@ int my_trnlnm(const char *lnm, char *eqv, unsigned long int idx) * 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). */ @@ -256,17 +256,18 @@ my_getenv(const char *lnm, bool sys) /*}}}*/ -/*{{{ 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) { @@ -275,18 +276,19 @@ my_getenv_sv(const char *lnm, bool sys) 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 *); diff --git a/vms/vmsish.h b/vms/vmsish.h index 4b45cf4..5398bcc 100644 --- a/vms/vmsish.h +++ b/vms/vmsish.h @@ -74,7 +74,7 @@ /* 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. */ @@ -90,7 +90,7 @@ #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 @@ -413,7 +413,7 @@ struct utimbuf { #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 */ @@ -581,7 +581,7 @@ typedef char __VMS_PROTOTYPES__; 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)); diff --git a/win32/GenCAPI.pl b/win32/GenCAPI.pl index 77e7aad..82e0b32 100644 --- a/win32/GenCAPI.pl +++ b/win32/GenCAPI.pl @@ -73,6 +73,8 @@ safexrealloc safexfree Perl_GetVars malloced_size +do_exec3 +getenv_len )]; @@ -155,14 +157,11 @@ while () { #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 diff --git a/win32/Makefile b/win32/Makefile index ffa8c6b..41d88ed 100644 --- a/win32/Makefile +++ b/win32/Makefile @@ -527,7 +527,7 @@ RE = $(EXTDIR)\re\re 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 diff --git a/win32/config.bc b/win32/config.bc index 691dfbb..6936dcc 100644 --- a/win32/config.bc +++ b/win32/config.bc @@ -1,7 +1,7 @@ ## Configured by: ~cf_email~ ## Target system: WIN32 Author='' -CONFIG='true' +CONFIGDOTSH='true' Date='$Date' Header='' Id='$Id' diff --git a/win32/config.gc b/win32/config.gc index 39b7701..200b10c 100644 --- a/win32/config.gc +++ b/win32/config.gc @@ -1,7 +1,7 @@ ## Configured by: ~cf_email~ ## Target system: WIN32 Author='' -CONFIG='true' +CONFIGDOTSH='true' Date='$Date' Header='' Id='$Id' diff --git a/win32/config.vc b/win32/config.vc index ea86e5f..09fa5af 100644 --- a/win32/config.vc +++ b/win32/config.vc @@ -1,7 +1,7 @@ ## Configured by: ~cf_email~ ## Target system: WIN32 Author='' -CONFIG='true' +CONFIGDOTSH='true' Date='$Date' Header='' Id='$Id' diff --git a/win32/makedef.pl b/win32/makedef.pl index f13c1da..212f000 100644 --- a/win32/makedef.pl +++ b/win32/makedef.pl @@ -79,6 +79,7 @@ PL_pending_ident PL_sortcxix PL_sublex_info PL_timesbuf +Perl_do_exec3 Perl_do_ipcctl Perl_do_ipcget Perl_do_msgrcv @@ -302,7 +303,6 @@ sub output_symbol { __DATA__ # extra globals not included above. perl_init_i18nl10n -perl_init_ext perl_alloc perl_atexit perl_construct diff --git a/win32/makefile.mk b/win32/makefile.mk index bee351c..7f2b515 100644 --- a/win32/makefile.mk +++ b/win32/makefile.mk @@ -642,7 +642,7 @@ RE = $(EXTDIR)\re\re 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 diff --git a/win32/perlhost.h b/win32/perlhost.h index cc5b5e5..458ff9a 100644 --- a/win32/perlhost.h +++ b/win32/perlhost.h @@ -102,6 +102,13 @@ public: { 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 diff --git a/win32/runperl.c b/win32/runperl.c index 1b569d2..336f2a8 100644 --- a/win32/runperl.c +++ b/win32/runperl.c @@ -28,9 +28,6 @@ xs_init(CPERLarg) CPerlObj *pPerl; -#undef PERL_SYS_INIT -#define PERL_SYS_INIT(a, c) - int main(int argc, char **argv, char **env) { @@ -48,6 +45,8 @@ main(int argc, char **argv, char **env) argv[0] = szModuleName; #endif + PERL_SYS_INIT(&argc,&argv); + if (!host.PerlCreate()) exit(exitstatus); diff --git a/win32/win32.c b/win32/win32.c index 414e4c5..4988e31 100644 --- a/win32/win32.c +++ b/win32/win32.c @@ -1307,7 +1307,12 @@ win32_uname(struct utsname *name) 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: @@ -2860,8 +2865,8 @@ static XS(w32_GetTickCount) { dXSARGS; - EXTEND(SP,1); DWORD msec = GetTickCount(); + EXTEND(SP,1); if ((IV)msec > 0) XSRETURN_IV(msec); XSRETURN_NV(msec); diff --git a/win32/win32.h b/win32/win32.h index a072b87..f712928 100644 --- a/win32/win32.h +++ b/win32/win32.h @@ -12,6 +12,7 @@ #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 @@ -184,6 +185,7 @@ struct utsname { 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