X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=perl.c;h=8af7172d16dee5321b3db246a9fede5662ed1d5c;hb=e9e069932a0db06904b29e2b09a435afd40ed35c;hp=36e4795760286f3f320fbef1024c81691703f6de;hpb=8ebc5c0145d2e3559bce3073437e6d027dcdffcc;p=p5sagit%2Fp5-mst-13.2.git diff --git a/perl.c b/perl.c index 36e4795..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,11 +59,12 @@ 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)); static void forbid_setid _((char *)); -static void incpush _((char *)); +static void incpush _((char *, int)); static void init_ids _((void)); static void init_debugger _((void)); static void init_lexer _((void)); @@ -68,6 +73,7 @@ static void init_perllib _((void)); static void init_postdump_symbols _((int, char **, char **)); static void init_predump_symbols _((void)); static void init_stacks _((void)); +static void my_exit_jump _((void)) __attribute__((noreturn)); static void nuke_stacks _((void)); static void open_script _((char *, bool, SV *)); static void usage _((char *)); @@ -116,6 +122,8 @@ register PerlInterpreter *sv_interp; nrs = newSVpv("\n", 1); rs = SvREFCNT_inc(nrs); + pidstatus = newHV(); + #ifdef MSDOS /* * There is no way we can refer to them from Perl so close them to save @@ -137,6 +145,12 @@ 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(); #if defined(SUBVERSION) && SUBVERSION > 0 sprintf(patchlevel, "%7.5f", (double) 5 @@ -154,7 +168,6 @@ register PerlInterpreter *sv_interp; PerlIO_init(); /* Hook to IO system */ fdpid = newAV(); /* for remembering popen pids by fd */ - pidstatus = newHV();/* for remembering status of dead pids */ init_stacks(); ENTER; @@ -183,23 +196,21 @@ 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; - /* We must account for everything. First the syntax tree. */ + /* We must account for everything. */ + + /* Destroy the main CV and syntax tree */ if (main_root) { curpad = AvARRAY(comppad); op_free(main_root); - main_root = 0; + main_root = Nullop; } + main_start = Nullop; + SvREFCNT_dec(main_cv); + main_cv = Nullcv; + if (sv_objcount) { /* * Try to destruct global references. We do this first so that the @@ -211,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()); @@ -319,10 +338,6 @@ register PerlInterpreter *sv_interp; beginav = Nullav; endav = Nullav; - /* pid-to-status mappings for waitpid */ - SvREFCNT_dec(pidstatus); - pidstatus = Nullhv; - /* temp stack during pp_sort() */ SvREFCNT_dec(sortstack); sortstack = Nullav; @@ -349,13 +364,17 @@ register PerlInterpreter *sv_interp; FREETMPS; if (destruct_level >= 2) { if (scopestack_ix != 0) - warn("Unbalanced scopes: %d more ENTERs than LEAVEs\n", scopestack_ix); + warn("Unbalanced scopes: %ld more ENTERs than LEAVEs\n", + (long)scopestack_ix); if (savestack_ix != 0) - warn("Unbalanced saves: %d more saves than restores\n", savestack_ix); + warn("Unbalanced saves: %ld more saves than restores\n", + (long)savestack_ix); if (tmps_floor != -1) - warn("Unbalanced tmps: %d more allocs than frees\n", tmps_floor + 1); + warn("Unbalanced tmps: %ld more allocs than frees\n", + (long)tmps_floor + 1); if (cxstack_ix != -1) - warn("Unbalanced context: %d more PUSHes than POPs\n", cxstack_ix + 1); + warn("Unbalanced context: %ld more PUSHes than POPs\n", + (long)cxstack_ix + 1); } /* Now absolutely destruct everything, somehow or other, loops or no. */ @@ -399,17 +418,30 @@ register PerlInterpreter *sv_interp; SvREFCNT_dec(strtab); if (sv_count != 0) - warn("Scalars leaked: %d\n", sv_count); + warn("Scalars leaked: %ld\n", (long)sv_count); sv_free_arenas(); - - linestr = NULL; /* No SVs have survived, need to clean out */ + + /* No SVs have survived, need to clean out */ + linestr = NULL; + pidstatus = Nullhv; 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 @@ -420,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) @@ -437,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 @@ -474,23 +506,34 @@ setuid perl scripts securely.\n"); return 0; } - if (main_root) + if (main_root) { + curpad = AvARRAY(comppad); op_free(main_root); - main_root = 0; + main_root = Nullop; + } + main_start = Nullop; + SvREFCNT_dec(main_cv); + main_cv = Nullcv; + + time(&basetime); + oldscope = scopestack_ix; - switch (Sigsetjmp(top_env,1)) { + JMPENV_PUSH(ret); + switch (ret) { case 1: -#ifdef VMS - statusvalue = 255; -#else - statusvalue = 1; -#endif + STATUS_ALL_FAILURE; + /* FALL THROUGH */ case 2: + /* my_exit() was called */ + while (scopestack_ix > oldscope) + LEAVE; curstash = defstash; if (endav) - calllist(endav); - return(statusvalue); /* my_exit() was called */ + call_list(oldscope, endav); + JMPENV_POP; + return STATUS_NATIVE_EXPORT; case 3: + JMPENV_POP; PerlIO_printf(PerlIO_stderr(), "panic: top_env\n"); return 1; } @@ -499,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; @@ -525,7 +569,6 @@ setuid perl scripts securely.\n"); case 'n': case 'p': case 's': - case 'T': case 'u': case 'U': case 'v': @@ -534,6 +577,11 @@ setuid perl scripts securely.\n"); goto reswitch; break; + case 'T': + tainting = TRUE; + s++; + goto reswitch; + case 'e': if (euid != uid || egid != gid) croak("No -e allowed in setuid scripts"); @@ -562,10 +610,10 @@ setuid perl scripts securely.\n"); sv_catpv(sv,s); sv_catpv(sv," "); if (*++s) { - av_push(GvAVn(incgv),newSVpv(s,0)); + incpush(s, TRUE); } else if (argv[1]) { - av_push(GvAVn(incgv),newSVpv(argv[1],0)); + incpush(argv[1], TRUE); sv_catpv(sv,argv[1]); argc--,argv++; sv_catpv(sv," "); @@ -592,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); @@ -655,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; @@ -681,7 +750,7 @@ setuid perl scripts securely.\n"); if (doextract) find_beginning(); - compcv = (CV*)NEWSV(1104,0); + main_cv = compcv = (CV*)NEWSV(1104,0); sv_upgrade((SV *)compcv, SVt_PVCV); CvUNIQUE_on(compcv); @@ -753,6 +822,7 @@ setuid perl scripts securely.\n"); ENTER; restartop = 0; + JMPENV_POP; return 0; } @@ -760,26 +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 - return(statusvalue); /* my_exit() was called */ + JMPENV_POP; + return STATUS_NATIVE_EXPORT; case 3: if (!restartop) { PerlIO_printf(PerlIO_stderr(), "panic: restartop\n"); FREETMPS; + JMPENV_POP; return 1; } if (curstack != mainstack) { @@ -812,32 +895,16 @@ PerlInterpreter *sv_interp; runops(); } else if (main_start) { + CvDEPTH(main_cv) = 1; op = main_start; runops(); } my_exit(0); + /* NOTREACHED */ return 0; } -void -my_exit(status) -U32 status; -{ - register CONTEXT *cx; - I32 gimme; - SV **newsp; - - statusvalue = FIXSTATUS(status); - if (cxstack_ix >= 0) { - if (cxstack_ix > 0) - dounwind(0); - POPBLOCK(cx,curpm); - LEAVE; - } - Siglongjmp(top_env, 2); -} - SV* perl_get_sv(name, create) char* name; @@ -882,7 +949,7 @@ I32 create; { GV* gv = gv_fetchpv(name, create, SVt_PVCV); if (create && !GvCVu(gv)) - return newSUB(start_subparse(), + return newSUB(start_subparse(FALSE, 0), newSVOP(OP_CONST, 0, newSVpv(name,0)), Nullop, Nullop); @@ -943,31 +1010,34 @@ I32 flags; /* See G_* flags in cop.h */ { LOGOP myop; /* fake syntax tree node */ SV** sp = stack_sp; - I32 oldmark = TOPMARK; + I32 oldmark; I32 retval; - Sigjmp_buf oldtop; I32 oldscope; static CV *DBcv; - + bool oldcatch = CATCH_GET; + dJMPENV; + int ret; + if (flags & G_DISCARD) { ENTER; SAVETMPS; } + Zero(&myop, 1, LOGOP); + myop.op_next = Nullop; + 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; - Zero(op, 1, LOGOP); + EXTEND(stack_sp, 1); *++stack_sp = sv; + oldmark = TOPMARK; oldscope = scopestack_ix; - if (!(flags & G_NOARGS)) - myop.op_flags = OPf_STACKED; - myop.op_next = Nullop; - myop.op_flags |= OPf_KNOW; - if (flags & G_ARRAY) - myop.op_flags |= OPf_LIST; - if (perldb && curstash != debstash /* Handle first BEGIN of -d. */ && (DBcv || (DBcv = GvCV(DBsub))) @@ -977,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; @@ -1002,31 +1070,27 @@ 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: -#ifdef VMS - statusvalue = 255; /* XXX I don't think we use 1 anymore. */ -#else - statusvalue = 1; -#endif + STATUS_ALL_FAILURE; /* FALL THROUGH */ case 2: /* my_exit() was called */ curstash = defstash; FREETMPS; - Copy(oldtop, top_env, 1, Sigjmp_buf); + JMPENV_POP; if (statusvalue) croak("Callback called exit"); - my_exit(statusvalue); + my_exit_jump(); /* NOTREACHED */ case 3: if (restartop) { op = restartop; restartop = 0; - goto restart; + break; } stack_sp = stack_base + oldmark; if (flags & G_ARRAY) @@ -1038,6 +1102,8 @@ I32 flags; /* See G_* flags in cop.h */ goto cleanup; } } + else + CATCH_SET(TRUE); if (op == (OP*)&myop) op = pp_entersub(); @@ -1062,8 +1128,11 @@ I32 flags; /* See G_* flags in cop.h */ curpm = newpm; LEAVE; } - Copy(oldtop, top_env, 1, Sigjmp_buf); + JMPENV_POP; } + else + CATCH_SET(oldcatch); + if (flags & G_DISCARD) { stack_sp = stack_base + oldmark; retval = 0; @@ -1084,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; @@ -1103,39 +1173,33 @@ 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: -#ifdef VMS - statusvalue = 255; /* XXX I don't think we use 1 anymore. */ -#else - statusvalue = 1; -#endif + STATUS_ALL_FAILURE; /* FALL THROUGH */ case 2: /* my_exit() was called */ curstash = defstash; FREETMPS; - Copy(oldtop, top_env, 1, Sigjmp_buf); + JMPENV_POP; if (statusvalue) croak("Callback called exit"); - my_exit(statusvalue); + my_exit_jump(); /* NOTREACHED */ case 3: if (restartop) { op = restartop; restartop = 0; - goto restart; + break; } stack_sp = stack_base + oldmark; if (flags & G_ARRAY) @@ -1156,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; @@ -1166,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 @@ -1191,47 +1277,6 @@ I32 namlen; sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen); } -#if defined(DOSISH) -# define PERLLIB_SEP ';' -#else -# if defined(VMS) -# define PERLLIB_SEP '|' -# else -# define PERLLIB_SEP ':' -# endif -#endif -#ifndef PERLLIB_MANGLE -# define PERLLIB_MANGLE(s,n) (s) -#endif - -static void -incpush(p) -char *p; -{ - char *s; - - if (!p) - return; - - /* Break at all separators */ - while (*p) { - /* First, skip any consecutive separators */ - while ( *p == PERLLIB_SEP ) { - /* Uncomment the next line for PATH semantics */ - /* av_push(GvAVn(incgv), newSVpv(".", 1)); */ - p++; - } - if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) { - av_push(GvAVn(incgv), newSVpv(PERLLIB_MANGLE(p, (STRLEN)(s - p)), - (STRLEN)(s - p))); - p = s + 1; - } else { - av_push(GvAVn(incgv), newSVpv(PERLLIB_MANGLE(p, 0), 0)); - break; - } - } -} - static void usage(name) /* XXX move this out into a module ? */ char *name; @@ -1303,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; @@ -1347,9 +1391,11 @@ char *s; case 'I': forbid_setid("-I"); if (*++s) { - char *e; + char *e, *p; for (e = s; *e && !isSPACE(*e); e++) ; - av_push(GvAVn(incgv),newSVpv(s,e-s)); + p = savepvn(s, e-s); + incpush(p, TRUE); + Safefree(p); if (*e) return e; } @@ -1426,7 +1472,8 @@ char *s; s++; return s; case 'T': - tainting = TRUE; + if (!tainting) + croak("Too late for \"-T\" option"); s++; return s; case 'u': @@ -1444,8 +1491,7 @@ char *s; printf("\nThis is perl, version %s",patchlevel); #endif - printf("\n\nCopyright 1987-1996, Larry Wall\n"); - printf("\n\t+ suidperl security patch"); + printf("\n\nCopyright 1987-1997, Larry Wall\n"); #ifdef MSDOS printf("\n\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n"); #endif @@ -1454,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"); @@ -1477,6 +1523,10 @@ GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n") case '\n': case '\t': break; +#ifdef ALTERNATE_SHEBANG + case 'S': /* OS/2 needs -S on "extproc" line. */ + break; +#endif case 'P': if (preprocess) return s+1; @@ -1495,23 +1545,28 @@ 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 # include lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */ -#else +# else ABORT(); /* for use with undump */ -#endif +# endif #endif } @@ -1565,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 @@ -1583,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 @@ -1670,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\" \ @@ -1691,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' \ @@ -1706,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 @@ -1714,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 */ @@ -1735,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"); @@ -1756,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 @@ -1840,12 +1917,12 @@ char *scriptname; (void)PerlIO_close(rsfp); if (rsfp = my_popen("/bin/mail root","w")) { /* heh, heh */ PerlIO_printf(rsfp, -"User %d tried to run dev %d ino %d in place of dev %d ino %d!\n\ -(Filename of set-id script was %s, uid %d gid %d.)\n\nSincerely,\nperl\n", - uid,tmpstatbuf.st_dev, tmpstatbuf.st_ino, - statbuf.st_dev, statbuf.st_ino, +"User %ld tried to run dev %ld ino %ld in place of dev %ld ino %ld!\n\ +(Filename of set-id script was %s, uid %ld gid %ld.)\n\nSincerely,\nperl\n", + (long)uid,(long)tmpstatbuf.st_dev, (long)tmpstatbuf.st_ino, + (long)statbuf.st_dev, (long)statbuf.st_ino, SvPVX(GvSV(curcop->cop_filegv)), - statbuf.st_uid, statbuf.st_gid); + (long)statbuf.st_uid, (long)statbuf.st_gid); (void)my_pclose(rsfp); } croak("Permission denied\n"); @@ -1904,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"); } @@ -1982,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 */ @@ -2242,8 +2316,6 @@ register char **env; sv_setpv(GvSV(tmpgv),origfilename); magicname("0", "0", 1); } - if (tmpgv = gv_fetchpv("\024",TRUE, SVt_PV)) - time(&basetime); if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV)) sv_setpv(GvSV(tmpgv),origargv[0]); if (argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) { @@ -2258,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 @@ -2267,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 = '='; } @@ -2284,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 @@ -2299,9 +2370,9 @@ init_perllib() #ifndef VMS s = getenv("PERL5LIB"); if (s) - incpush(s); + incpush(s, TRUE); else - incpush(getenv("PERLLIB")); + incpush(getenv("PERLLIB"), FALSE); #else /* VMS */ /* Treat PERL5?LIB as a possible search list logical name -- the * "natural" VMS idiom for a Unix path string. We allow each @@ -2310,9 +2381,9 @@ init_perllib() char buf[256]; int idx = 0; if (my_trnlnm("PERL5LIB",buf,0)) - do { incpush(buf); } while (my_trnlnm("PERL5LIB",buf,++idx)); + do { incpush(buf,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx)); else - while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf); + while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE); #endif /* VMS */ } @@ -2320,78 +2391,184 @@ init_perllib() ARCHLIB PRIVLIB SITEARCH SITELIB and OLDARCHLIB */ #ifdef APPLLIB_EXP - incpush(APPLLIB_EXP); + incpush(APPLLIB_EXP, FALSE); #endif #ifdef ARCHLIB_EXP - incpush(ARCHLIB_EXP); + incpush(ARCHLIB_EXP, FALSE); #endif #ifndef PRIVLIB_EXP #define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl" #endif - incpush(PRIVLIB_EXP); + incpush(PRIVLIB_EXP, FALSE); #ifdef SITEARCH_EXP - incpush(SITEARCH_EXP); + incpush(SITEARCH_EXP, FALSE); #endif #ifdef SITELIB_EXP - incpush(SITELIB_EXP); + incpush(SITELIB_EXP, FALSE); #endif #ifdef OLDARCHLIB_EXP /* 5.00[01] compatibility */ - incpush(OLDARCHLIB_EXP); + incpush(OLDARCHLIB_EXP, FALSE); #endif if (!tainting) - incpush("."); + incpush(".", FALSE); +} + +#if defined(DOSISH) +# define PERLLIB_SEP ';' +#else +# if defined(VMS) +# define PERLLIB_SEP '|' +# else +# define PERLLIB_SEP ':' +# endif +#endif +#ifndef PERLLIB_MANGLE +# define PERLLIB_MANGLE(s,n) (s) +#endif + +static void +incpush(p, addsubdirs) +char *p; +int addsubdirs; +{ + SV *subdir = Nullsv; + static char *archpat_auto; + + if (!p) + return; + + if (addsubdirs) { + subdir = newSV(0); + if (!archpat_auto) { + STRLEN len = (sizeof(ARCHNAME) + strlen(patchlevel) + + sizeof("//auto")); + New(55, archpat_auto, len, char); + sprintf(archpat_auto, "/%s/%s/auto", ARCHNAME, patchlevel); +#ifdef VMS + for (len = sizeof(ARCHNAME) + 2; + archpat_auto[len] != '\0' && archpat_auto[len] != '/'; len++) + if (archpat_auto[len] == '.') archpat_auto[len] = '_'; +#endif + } + } + + /* Break at all separators */ + while (p && *p) { + SV *libdir = newSV(0); + char *s; + + /* skip any consecutive separators */ + while ( *p == PERLLIB_SEP ) { + /* Uncomment the next line for PATH semantics */ + /* av_push(GvAVn(incgv), newSVpv(".", 1)); */ + p++; + } + + if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) { + sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)), + (STRLEN)(s - p)); + p = s + 1; + } + else { + sv_setpv(libdir, PERLLIB_MANGLE(p, 0)); + p = Nullch; /* break out */ + } + + /* + * BEFORE pushing libdir onto @INC we may first push version- and + * archname-specific sub-directories. + */ + if (addsubdirs) { + struct stat tmpstatbuf; +#ifdef VMS + char *unix; + STRLEN len; + + if ((unix = tounixspec_ts(SvPV(libdir,na),Nullch)) != Nullch) { + len = strlen(unix); + while (unix[len-1] == '/') len--; /* Cosmetic */ + sv_usepvn(libdir,unix,len); + } + else + PerlIO_printf(PerlIO_stderr(), + "Failed to unixify @INC element \"%s\"\n", + SvPV(libdir,na)); +#endif + /* .../archname/version if -d .../archname/version/auto */ + sv_setsv(subdir, libdir); + sv_catpv(subdir, archpat_auto); + if (Stat(SvPVX(subdir), &tmpstatbuf) >= 0 && + S_ISDIR(tmpstatbuf.st_mode)) + av_push(GvAVn(incgv), + newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto")); + + /* .../archname if -d .../archname/auto */ + sv_insert(subdir, SvCUR(libdir) + sizeof(ARCHNAME), + strlen(patchlevel) + 1, "", 0); + if (Stat(SvPVX(subdir), &tmpstatbuf) >= 0 && + S_ISDIR(tmpstatbuf.st_mode)) + av_push(GvAVn(incgv), + newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto")); + } + + /* finally push this lib directory on the end of @INC */ + av_push(GvAVn(incgv), libdir); + } + + SvREFCNT_dec(subdir); } 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)); } } break; case 1: -#ifdef VMS - statusvalue = 255; /* XXX I don't think we use 1 anymore. */ -#else - statusvalue = 1; -#endif + 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); FREETMPS; - Copy(oldtop, top_env, 1, Sigjmp_buf); + JMPENV_POP; curcop = &compiling; curcop->cop_line = oldline; if (statusvalue) { @@ -2400,22 +2577,87 @@ AV* list; else croak("END failed--cleanup aborted"); } - my_exit(statusvalue); + my_exit_jump(); /* NOTREACHED */ - return; case 3: if (!restartop) { PerlIO_printf(PerlIO_stderr(), "panic: restartop\n"); 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 +my_exit(status) +U32 status; +{ + switch (status) { + case 0: + STATUS_ALL_SUCCESS; + break; + case 1: + STATUS_ALL_FAILURE; + break; + default: + STATUS_NATIVE_SET(status); + break; + } + my_exit_jump(); +} + +void +my_failure_exit() +{ +#ifdef VMS + if (vaxc$errno & 1) { + if (STATUS_NATIVE & 1) /* fortuitiously includes "-1" */ + STATUS_NATIVE_SET(44); + } + else { + if (!vaxc$errno && errno) /* unlikely */ + STATUS_NATIVE_SET(44); + else + STATUS_NATIVE_SET(vaxc$errno); + } +#else + if (errno & 255) + STATUS_POSIX_SET(errno); + else if (STATUS_POSIX == 0) + STATUS_POSIX_SET(255); +#endif + my_exit_jump(); } +static void +my_exit_jump() +{ + register CONTEXT *cx; + I32 gimme; + SV **newsp; + + if (e_tmpname) { + if (e_fp) { + PerlIO_close(e_fp); + e_fp = Nullfp; + } + (void)UNLINK(e_tmpname); + Safefree(e_tmpname); + e_tmpname = Nullch; + } + + if (cxstack_ix >= 0) { + if (cxstack_ix > 0) + dounwind(0); + POPBLOCK(cx,curpm); + LEAVE; + } + + JMPENV_JUMP(2); +}