X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=perl.c;h=8af7172d16dee5321b3db246a9fede5662ed1d5c;hb=e9e069932a0db06904b29e2b09a435afd40ed35c;hp=8794dd69fe464ec5a7c31bf529ecff98204bd38f;hpb=20efc0829f6564c44574762adb07e8865bc14026;p=p5sagit%2Fp5-mst-13.2.git diff --git a/perl.c b/perl.c index 8794dd6..8af7172 100644 --- a/perl.c +++ b/perl.c @@ -1,6 +1,6 @@ /* perl.c * - * Copyright (c) 1987-1996 Larry Wall + * Copyright (c) 1987-1997 Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -20,6 +20,10 @@ #include #endif +#if !defined(STANDARD_C) && !defined(HAS_GETENV_PROTOTYPE) +char *getenv _((char *)); /* Usually in */ +#endif + dEXTCONST char rcsid[] = "perl.c\nPatch level: ###\n"; #ifdef IAMSUID @@ -55,6 +59,7 @@ dEXTCONST char rcsid[] = "perl.c\nPatch level: ###\n"; dlmax = 128; \ laststatval = -1; \ laststype = OP_STAT; \ + mess_sv = Nullsv; \ } STMT_END static void find_beginning _((void)); @@ -140,6 +145,10 @@ register PerlInterpreter *sv_interp; init_ids(); + start_env.je_prev = NULL; + start_env.je_ret = -1; + start_env.je_mustcatch = TRUE; + top_env = &start_env; STATUS_ALL_SUCCESS; SET_NUMERIC_STANDARD(); @@ -187,14 +196,6 @@ register PerlInterpreter *sv_interp; } #endif - /* unhook hooks which will soon be, or use, destroyed data */ - SvREFCNT_dec(warnhook); - warnhook = Nullsv; - SvREFCNT_dec(diehook); - diehook = Nullsv; - SvREFCNT_dec(parsehook); - parsehook = Nullsv; - LEAVE; FREETMPS; @@ -221,6 +222,14 @@ register PerlInterpreter *sv_interp; sv_clean_objs(); } + /* unhook hooks which will soon be, or use, destroyed data */ + SvREFCNT_dec(warnhook); + warnhook = Nullsv; + SvREFCNT_dec(diehook); + diehook = Nullsv; + SvREFCNT_dec(parsehook); + parsehook = Nullsv; + if (destruct_level == 0){ DEBUG_P(debprofdump()); @@ -419,9 +428,20 @@ register PerlInterpreter *sv_interp; if (origfilename) Safefree(origfilename); nuke_stacks(); - hints = 0; /* Reset hints. Should hints be per-interpreter ? */ + hints = 0; /* Reset hints. Should hints be per-interpreter ? */ DEBUG_P(debprofdump()); + + /* As the absolutely last thing, free the non-arena SV for mess() */ + + if (mess_sv) { + /* we know that type >= SVt_PV */ + SvOOK_off(mess_sv); + Safefree(SvPVX(mess_sv)); + Safefree(SvANY(mess_sv)); + Safefree(mess_sv); + mess_sv = Nullsv; + } } void @@ -432,9 +452,6 @@ PerlInterpreter *sv_interp; return; Safefree(sv_interp); } -#if !defined(STANDARD_C) && !defined(HAS_GETENV_PROTOTYPE) -char *getenv _((char *)); /* Usually in */ -#endif int perl_parse(sv_interp, xsinit, argc, argv, env) @@ -449,7 +466,10 @@ char **env; char *scriptname = NULL; VOL bool dosearch = FALSE; char *validarg = ""; + I32 oldscope; AV* comppadlist; + dJMPENV; + int ret; #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW #ifdef IAMSUID @@ -496,20 +516,24 @@ setuid perl scripts securely.\n"); main_cv = Nullcv; time(&basetime); - mustcatch = FALSE; + oldscope = scopestack_ix; - switch (Sigsetjmp(top_env,1)) { + JMPENV_PUSH(ret); + switch (ret) { case 1: STATUS_ALL_FAILURE; /* FALL THROUGH */ case 2: /* my_exit() was called */ + while (scopestack_ix > oldscope) + LEAVE; curstash = defstash; if (endav) - calllist(endav); + call_list(oldscope, endav); + JMPENV_POP; return STATUS_NATIVE_EXPORT; case 3: - mustcatch = FALSE; + JMPENV_POP; PerlIO_printf(PerlIO_stderr(), "panic: top_env\n"); return 1; } @@ -518,6 +542,7 @@ setuid perl scripts securely.\n"); sv = newSVpv("",0); /* first used for -I flags */ SAVEFREESV(sv); init_main_stash(); + for (argc--,argv++; argc > 0; argc--,argv++) { if (argv[0][0] != '-' || !argv[0][1]) break; @@ -615,43 +640,42 @@ setuid perl scripts securely.\n"); #else sv_catpv(Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\","); #endif -#if defined(DEBUGGING) || defined(NOEMBED) || defined(MULTIPLICITY) - strcpy(buf,"\" Compile-time options:"); +#if defined(DEBUGGING) || defined(NO_EMBED) || defined(MULTIPLICITY) + sv_catpv(Sv,"\" Compile-time options:"); # ifdef DEBUGGING - strcat(buf," DEBUGGING"); + sv_catpv(Sv," DEBUGGING"); # endif -# ifdef NOEMBED - strcat(buf," NOEMBED"); +# ifdef NO_EMBED + sv_catpv(Sv," NO_EMBED"); # endif # ifdef MULTIPLICITY - strcat(buf," MULTIPLICITY"); + sv_catpv(Sv," MULTIPLICITY"); # endif - strcat(buf,"\\n\","); - sv_catpv(Sv,buf); + sv_catpv(Sv,"\\n\","); #endif #if defined(LOCAL_PATCH_COUNT) - if (LOCAL_PATCH_COUNT > 0) - { int i; - sv_catpv(Sv,"print \" Locally applied patches:\\n\","); + if (LOCAL_PATCH_COUNT > 0) { + int i; + sv_catpv(Sv,"\" Locally applied patches:\\n\","); for (i = 1; i <= LOCAL_PATCH_COUNT; i++) { - if (localpatches[i]) { - sprintf(buf,"\" \\t%s\\n\",",localpatches[i]); - sv_catpv(Sv,buf); - } + if (localpatches[i]) + sv_catpvf(Sv,"\" \\t%s\\n\",",localpatches[i]); } } #endif - sprintf(buf,"\" Built under %s\\n\",",OSNAME); - sv_catpv(Sv,buf); + sv_catpvf(Sv,"\" Built under %s\\n\"",OSNAME); #ifdef __DATE__ # ifdef __TIME__ - sprintf(buf,"\" Compiled at %s %s\\n\"",__DATE__,__TIME__); + sv_catpvf(Sv,",\" Compiled at %s %s\\n\"",__DATE__,__TIME__); # else - sprintf(buf,"\" Compiled on %s\\n\"",__DATE__); + sv_catpvf(Sv,",\" Compiled on %s\\n\"",__DATE__); # endif - sv_catpv(Sv,buf); #endif - sv_catpv(Sv,"; $\"=\"\\n \"; print \" \\@INC:\\n @INC\\n\""); + sv_catpv(Sv, "; \ +$\"=\"\\n \"; \ +@env = map { \"$_=\\\"$ENV{$_}\\\"\" } sort grep {/^PERL/} keys %ENV; \ +print \" \\%ENV:\\n @env\\n\" if @env; \ +print \" \\@INC:\\n @INC\\n\";"); } else { Sv = newSVpv("config_vars(qw(",0); @@ -678,11 +702,33 @@ setuid perl scripts securely.\n"); } } switch_end: + + if (!tainting && (s = getenv("PERL5OPT"))) { + for (;;) { + while (isSPACE(*s)) + s++; + if (*s == '-') { + s++; + if (isSPACE(*s)) + continue; + } + if (!*s) + break; + if (!strchr("DIMUdmw", *s)) + croak("Illegal switch in PERL5OPT: -%c", *s); + s = moreswitches(s); + } + } + if (!scriptname) scriptname = argv[0]; if (e_fp) { - if (PerlIO_flush(e_fp) || PerlIO_error(e_fp) || PerlIO_close(e_fp)) + if (PerlIO_flush(e_fp) || PerlIO_error(e_fp) || PerlIO_close(e_fp)) { +#ifndef MULTIPLICITY + warn("Did you forget to compile with -DMULTIPLICITY?"); +#endif croak("Can't write to temp file for -e: %s", Strerror(errno)); + } e_fp = Nullfp; argc++,argv--; scriptname = e_tmpname; @@ -776,6 +822,7 @@ setuid perl scripts securely.\n"); ENTER; restartop = 0; + JMPENV_POP; return 0; } @@ -783,28 +830,39 @@ int perl_run(sv_interp) PerlInterpreter *sv_interp; { + I32 oldscope; + dJMPENV; + int ret; + if (!(curinterp = sv_interp)) return 255; - switch (Sigsetjmp(top_env,1)) { + + oldscope = scopestack_ix; + + JMPENV_PUSH(ret); + switch (ret) { case 1: cxstack_ix = -1; /* start context stack again */ break; case 2: /* my_exit() was called */ + while (scopestack_ix > oldscope) + LEAVE; curstash = defstash; if (endav) - calllist(endav); + call_list(oldscope, endav); FREETMPS; #ifdef DEBUGGING_MSTATS if (getenv("PERL_DEBUG_MSTATS")) dump_mstats("after execution: "); #endif + JMPENV_POP; return STATUS_NATIVE_EXPORT; case 3: - mustcatch = FALSE; if (!restartop) { PerlIO_printf(PerlIO_stderr(), "panic: restartop\n"); FREETMPS; + JMPENV_POP; return 1; } if (curstack != mainstack) { @@ -843,6 +901,7 @@ PerlInterpreter *sv_interp; } my_exit(0); + /* NOTREACHED */ return 0; } @@ -953,10 +1012,11 @@ I32 flags; /* See G_* flags in cop.h */ SV** sp = stack_sp; I32 oldmark; I32 retval; - Sigjmp_buf oldtop; I32 oldscope; static CV *DBcv; - bool oldmustcatch = mustcatch; + bool oldcatch = CATCH_GET; + dJMPENV; + int ret; if (flags & G_DISCARD) { ENTER; @@ -964,15 +1024,12 @@ I32 flags; /* See G_* flags in cop.h */ } Zero(&myop, 1, LOGOP); - if (flags & G_NOARGS) { - PUSHMARK(sp); - } - else - myop.op_flags |= OPf_STACKED; myop.op_next = Nullop; - myop.op_flags |= OPf_KNOW; - if (flags & G_ARRAY) - myop.op_flags |= OPf_LIST; + if (!(flags & G_NOARGS)) + myop.op_flags |= OPf_STACKED; + myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID : + (flags & G_ARRAY) ? OPf_WANT_LIST : + OPf_WANT_SCALAR); SAVESPTR(op); op = (OP*)&myop; @@ -990,14 +1047,12 @@ I32 flags; /* See G_* flags in cop.h */ op->op_private |= OPpENTERSUB_DB; if (flags & G_EVAL) { - Copy(top_env, oldtop, 1, Sigjmp_buf); - cLOGOP->op_other = op; markstack_ptr--; /* we're trying to emulate pp_entertry() here */ { register CONTEXT *cx; - I32 gimme = GIMME; + I32 gimme = GIMME_V; ENTER; SAVETMPS; @@ -1015,8 +1070,8 @@ I32 flags; /* See G_* flags in cop.h */ } markstack_ptr++; - restart: - switch (Sigsetjmp(top_env,1)) { + JMPENV_PUSH(ret); + switch (ret) { case 0: break; case 1: @@ -1026,17 +1081,16 @@ I32 flags; /* See G_* flags in cop.h */ /* my_exit() was called */ curstash = defstash; FREETMPS; - Copy(oldtop, top_env, 1, Sigjmp_buf); + JMPENV_POP; if (statusvalue) croak("Callback called exit"); my_exit_jump(); /* NOTREACHED */ case 3: - mustcatch = FALSE; if (restartop) { op = restartop; restartop = 0; - goto restart; + break; } stack_sp = stack_base + oldmark; if (flags & G_ARRAY) @@ -1049,7 +1103,7 @@ I32 flags; /* See G_* flags in cop.h */ } } else - mustcatch = TRUE; + CATCH_SET(TRUE); if (op == (OP*)&myop) op = pp_entersub(); @@ -1074,10 +1128,10 @@ I32 flags; /* See G_* flags in cop.h */ curpm = newpm; LEAVE; } - Copy(oldtop, top_env, 1, Sigjmp_buf); + JMPENV_POP; } else - mustcatch = oldmustcatch; + CATCH_SET(oldcatch); if (flags & G_DISCARD) { stack_sp = stack_base + oldmark; @@ -1099,8 +1153,9 @@ I32 flags; /* See G_* flags in cop.h */ SV** sp = stack_sp; I32 oldmark = sp - stack_base; I32 retval; - Sigjmp_buf oldtop; I32 oldscope; + dJMPENV; + int ret; if (flags & G_DISCARD) { ENTER; @@ -1118,16 +1173,14 @@ I32 flags; /* See G_* flags in cop.h */ myop.op_flags = OPf_STACKED; myop.op_next = Nullop; myop.op_type = OP_ENTEREVAL; - myop.op_flags |= OPf_KNOW; + myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID : + (flags & G_ARRAY) ? OPf_WANT_LIST : + OPf_WANT_SCALAR); if (flags & G_KEEPERR) myop.op_flags |= OPf_SPECIAL; - if (flags & G_ARRAY) - myop.op_flags |= OPf_LIST; - Copy(top_env, oldtop, 1, Sigjmp_buf); - -restart: - switch (Sigsetjmp(top_env,1)) { + JMPENV_PUSH(ret); + switch (ret) { case 0: break; case 1: @@ -1137,17 +1190,16 @@ restart: /* my_exit() was called */ curstash = defstash; FREETMPS; - Copy(oldtop, top_env, 1, Sigjmp_buf); + JMPENV_POP; if (statusvalue) croak("Callback called exit"); my_exit_jump(); /* NOTREACHED */ case 3: - mustcatch = FALSE; if (restartop) { op = restartop; restartop = 0; - goto restart; + break; } stack_sp = stack_base + oldmark; if (flags & G_ARRAY) @@ -1168,7 +1220,7 @@ restart: sv_setpv(GvSV(errgv),""); cleanup: - Copy(oldtop, top_env, 1, Sigjmp_buf); + JMPENV_POP; if (flags & G_DISCARD) { stack_sp = stack_base + oldmark; retval = 0; @@ -1178,6 +1230,28 @@ restart: return retval; } +SV* +perl_eval_pv(p, croak_on_error) +char* p; +I32 croak_on_error; +{ + dSP; + SV* sv = newSVpv(p, 0); + + PUSHMARK(sp); + perl_eval_sv(sv, G_SCALAR); + SvREFCNT_dec(sv); + + SPAGAIN; + sv = POPs; + PUTBACK; + + if (croak_on_error && SvTRUE(GvSV(errgv))) + croak(SvPVx(GvSV(errgv), na)); + + return sv; +} + /* Require a module. */ void @@ -1274,9 +1348,8 @@ char *s; forbid_setid("-d"); s++; if (*s == ':' || *s == '=') { - sprintf(buf, "use Devel::%s;", ++s); + my_setenv("PERL5DB", form("use Devel::%s;", ++s)); s += strlen(s); - my_setenv("PERL5DB",buf); } if (!perldb) { perldb = TRUE; @@ -1400,7 +1473,7 @@ char *s; return s; case 'T': if (!tainting) - croak("Too late for \"-T\" option (try putting it first)"); + croak("Too late for \"-T\" option"); s++; return s; case 'u': @@ -1427,7 +1500,7 @@ char *s; #endif #ifdef OS2 printf("\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n" - "Version 5 port Copyright (c) 1994-1996, Andreas Kaiser, Ilya Zakharevich\n"); + "Version 5 port Copyright (c) 1994-1997, Andreas Kaiser, Ilya Zakharevich\n"); #endif #ifdef atarist printf("atariST series port, ++jrb bammi@cadence.com\n"); @@ -1472,15 +1545,20 @@ void my_unexec() { #ifdef UNEXEC + SV* prog; + SV* file; int status; extern int etext; - sprintf (buf, "%s.perldump", origfilename); - sprintf (tokenbuf, "%s/perl", BIN); + prog = newSVpv(BIN_EXP); + sv_catpv(prog, "/perl"); + file = newSVpv(origfilename); + sv_catpv(file, ".perldump"); - status = unexec(buf, tokenbuf, &etext, sbrk(0), 0); + status = unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0); if (status) - PerlIO_printf(PerlIO_stderr(), "unexec of %s into %s failed!\n", tokenbuf, buf); + PerlIO_printf(PerlIO_stderr(), "unexec of %s into %s failed!\n", + SvPVX(prog), SvPVX(file)); exit(status); #else # ifdef VMS @@ -1542,15 +1620,19 @@ SV *sv; I32 len; int retval; #if defined(DOSISH) && !defined(OS2) && !defined(atarist) -#define SEARCH_EXTS ".bat", ".cmd", NULL +# define SEARCH_EXTS ".bat", ".cmd", NULL +# define MAX_EXT_LEN 4 #endif #ifdef VMS # define SEARCH_EXTS ".pl", ".com", NULL +# define MAX_EXT_LEN 4 #endif /* additional extensions to try in each dir if scriptname not found */ #ifdef SEARCH_EXTS char *ext[] = { SEARCH_EXTS }; int extidx = (strchr(scriptname,'.')) ? -1 : 0; /* has ext already */ +#else +# define MAX_EXT_LEN 0 #endif #ifdef VMS @@ -1560,38 +1642,51 @@ SV *sv; hasdir = (strpbrk(scriptname,":[= sizeof tokenbuf) + continue; /* don't search dir with too-long name */ + strcat(tokenbuf, scriptname); #else /* !VMS */ if (dosearch && !strchr(scriptname, '/') && (s = getenv("PATH"))) { - bufend = s + strlen(s); - while (*s) { -#ifndef DOSISH - s = cpytill(tokenbuf,s,bufend,':',&len); + while (s < bufend) { +#ifndef atarist + s = delimcpy(tokenbuf, tokenbuf + sizeof tokenbuf, s, bufend, +#ifdef DOSISH + ';', #else -#ifdef atarist - for (len = 0; *s && *s != ',' && *s != ';'; tokenbuf[len++] = *s++); - tokenbuf[len] = '\0'; -#else - for (len = 0; *s && *s != ';'; tokenbuf[len++] = *s++); - tokenbuf[len] = '\0'; -#endif + ':', #endif - if (*s) + &len); +#else /* atarist */ + for (len = 0; *s && *s != ',' && *s != ';'; len++, s++) { + if (len < sizeof tokenbuf) + tokenbuf[len] = *s; + } + if (len < sizeof tokenbuf) + tokenbuf[len] = '\0'; +#endif /* atarist */ + if (s < bufend) s++; -#ifndef DOSISH - if (len && tokenbuf[len-1] != '/') -#else -#ifdef atarist - if (len && ((tokenbuf[len-1] != '\\') && (tokenbuf[len-1] != '/'))) -#else - if (len && tokenbuf[len-1] != '\\') -#endif -#endif - (void)strcat(tokenbuf+len,"/"); - (void)strcat(tokenbuf+len,scriptname); + if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tokenbuf) + continue; /* don't search dir with too-long name */ + if (len +#if defined(atarist) && !defined(DOSISH) + && tokenbuf[len - 1] != '/' +#endif +#if defined(atarist) || defined(DOSISH) + && tokenbuf[len - 1] != '\\' +#endif + ) + tokenbuf[len++] = '/'; + (void)strcpy(tokenbuf + len, scriptname); #endif /* !VMS */ #ifdef SEARCH_EXTS @@ -1647,16 +1742,19 @@ SV *sv; #endif } else if (preprocess) { - char *cpp = CPPSTDIN; + char *cpp_cfg = CPPSTDIN; + SV *cpp = NEWSV(0,0); + SV *cmd = NEWSV(0,0); + + if (strEQ(cpp_cfg, "cppstdin")) + sv_catpvf(cpp, "%s/", BIN_EXP); + sv_catpv(cpp, cpp_cfg); - if (strEQ(cpp,"cppstdin")) - sprintf(tokenbuf, "%s/%s", SCRIPTDIR, cpp); - else - sprintf(tokenbuf, "%s", cpp); sv_catpv(sv,"-I"); sv_catpv(sv,PRIVLIB_EXP); + #ifdef MSDOS - (void)sprintf(buf, "\ + sv_setpvf(cmd, "\ sed %s -e \"/^[^#]/b\" \ -e \"/^#[ ]*include[ ]/b\" \ -e \"/^#[ ]*define[ ]/b\" \ @@ -1668,10 +1766,10 @@ sed %s -e \"/^[^#]/b\" \ -e \"/^#[ ]*undef[ ]/b\" \ -e \"/^#[ ]*endif/b\" \ -e \"s/^#.*//\" \ - %s | %s -C %s %s", + %s | %_ -C %_ %s", (doextract ? "-e \"1,/^#/d\n\"" : ""), #else - (void)sprintf(buf, "\ + sv_setpvf(cmd, "\ %s %s -e '/^[^#]/b' \ -e '/^#[ ]*include[ ]/b' \ -e '/^#[ ]*define[ ]/b' \ @@ -1683,7 +1781,7 @@ sed %s -e \"/^[^#]/b\" \ -e '/^#[ ]*undef[ ]/b' \ -e '/^#[ ]*endif/b' \ -e 's/^[ ]*#.*//' \ - %s | %s -C %s %s", + %s | %_ -C %_ %s", #ifdef LOC_SED LOC_SED, #else @@ -1691,7 +1789,7 @@ sed %s -e \"/^[^#]/b\" \ #endif (doextract ? "-e '1,/^#/d\n'" : ""), #endif - scriptname, tokenbuf, SvPV(sv, na), CPPMINUS); + scriptname, cpp, sv, CPPMINUS); doextract = FALSE; #ifdef IAMSUID /* actually, this is caught earlier */ if (euid != uid && !euid) { /* if running suidperl */ @@ -1712,7 +1810,9 @@ sed %s -e \"/^[^#]/b\" \ croak("Can't do seteuid!\n"); } #endif /* IAMSUID */ - rsfp = my_popen(buf,"r"); + rsfp = my_popen(SvPVX(cmd), "r"); + SvREFCNT_dec(cmd); + SvREFCNT_dec(cpp); } else if (!*scriptname) { forbid_setid("program input from stdin"); @@ -1733,8 +1833,8 @@ sed %s -e \"/^[^#]/b\" \ #ifndef IAMSUID /* in case script is not readable before setuid */ if (euid && Stat(SvPVX(GvSV(curcop->cop_filegv)),&statbuf) >= 0 && statbuf.st_mode & (S_ISUID|S_ISGID)) { - (void)sprintf(buf, "%s/sperl%s", BIN, patchlevel); - execv(buf, origargv); /* try again */ + /* try again */ + execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv); croak("Can't do setuid\n"); } #endif @@ -1881,8 +1981,8 @@ FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n"); if (euid) { /* oops, we're not the setuid root perl */ (void)PerlIO_close(rsfp); #ifndef IAMSUID - (void)sprintf(buf, "%s/sperl%s", BIN, patchlevel); - execv(buf, origargv); /* try again */ + /* try again */ + execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv); #endif croak("Can't do setuid\n"); } @@ -1959,15 +2059,12 @@ FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n"); for (which = 1; origargv[which] && origargv[which] != scriptname; which++) ; if (!origargv[which]) croak("Permission denied"); - (void)sprintf(buf, "/dev/fd/%d/%.127s", PerlIO_fileno(rsfp), origargv[which]); - origargv[which] = buf; - + origargv[which] = savepv(form("/dev/fd/%d/%s", + PerlIO_fileno(rsfp), origargv[which])); #if defined(HAS_FCNTL) && defined(F_SETFD) fcntl(PerlIO_fileno(rsfp),F_SETFD,0); /* ensure no close-on-exec */ #endif - - (void)sprintf(tokenbuf, "%s/perl%s", BIN, patchlevel); - execv(tokenbuf, origargv); /* try again */ + execv(form("%s/perl%s", BIN_EXP, patchlevel), origargv); /* try again */ croak("Can't do setuid\n"); #endif /* IAMSUID */ #else /* !DOSUID */ @@ -2233,7 +2330,7 @@ register char **env; HV *hv; GvMULTI_on(envgv); hv = GvHVn(envgv); - hv_clear(hv); + hv_magic(hv, envgv, 'E'); #ifndef VMS /* VMS doesn't have environ array */ /* Note that if the supplied env parameter is actually a copy of the global environ then it may now point to free'd memory @@ -2242,16 +2339,16 @@ register char **env; */ if (!env) env = environ; - if (env != environ) { + if (env != environ) environ[0] = Nullch; - hv_magic(hv, envgv, 'E'); - } for (; *env; env++) { if (!(s = strchr(*env,'='))) continue; *s++ = '\0'; +#ifdef WIN32 + (void)strupr(*env); +#endif sv = newSVpv(s--,0); - sv_magic(sv, sv, 'e', *env, s - *env); (void)hv_store(hv, *env, s - *env, sv, 0); *s = '='; } @@ -2259,11 +2356,10 @@ register char **env; #ifdef DYNAMIC_ENV_FETCH HvNAME(hv) = savepv(ENV_HV_NAME); #endif - hv_magic(hv, envgv, 'E'); } TAINT_NOT; if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV)) - sv_setiv(GvSV(tmpgv),(I32)getpid()); + sv_setiv(GvSV(tmpgv), (IV)getpid()); } static void @@ -2426,34 +2522,37 @@ int addsubdirs; } void -calllist(list) +call_list(oldscope, list) +I32 oldscope; AV* list; { - Sigjmp_buf oldtop; - STRLEN len; line_t oldline = curcop->cop_line; - - Copy(top_env, oldtop, 1, Sigjmp_buf); + STRLEN len; + dJMPENV; + int ret; while (AvFILL(list) >= 0) { CV *cv = (CV*)av_shift(list); SAVEFREESV(cv); - switch (Sigsetjmp(top_env,1)) { + JMPENV_PUSH(ret); + switch (ret) { case 0: { SV* atsv = GvSV(errgv); PUSHMARK(stack_sp); perl_call_sv((SV*)cv, G_EVAL|G_DISCARD); (void)SvPV(atsv, len); if (len) { - Copy(oldtop, top_env, 1, Sigjmp_buf); + JMPENV_POP; curcop = &compiling; curcop->cop_line = oldline; if (list == beginav) sv_catpv(atsv, "BEGIN failed--compilation aborted"); else sv_catpv(atsv, "END failed--cleanup aborted"); + while (scopestack_ix > oldscope) + LEAVE; croak("%s", SvPVX(atsv)); } } @@ -2463,11 +2562,13 @@ AV* list; /* FALL THROUGH */ case 2: /* my_exit() was called */ + while (scopestack_ix > oldscope) + LEAVE; curstash = defstash; if (endav) - calllist(endav); + call_list(oldscope, endav); FREETMPS; - Copy(oldtop, top_env, 1, Sigjmp_buf); + JMPENV_POP; curcop = &compiling; curcop->cop_line = oldline; if (statusvalue) { @@ -2484,14 +2585,13 @@ AV* list; FREETMPS; break; } - Copy(oldtop, top_env, 1, Sigjmp_buf); + JMPENV_POP; curcop = &compiling; curcop->cop_line = oldline; - Siglongjmp(top_env, 3); + JMPENV_JUMP(3); } + JMPENV_POP; } - - Copy(oldtop, top_env, 1, Sigjmp_buf); } void @@ -2559,5 +2659,5 @@ my_exit_jump() LEAVE; } - Siglongjmp(top_env, 2); + JMPENV_JUMP(2); }