X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=perl.c;h=77bcb4d02ccd23bc12c71230c9ad1d8f0ad46838;hb=046ff0edbba626fc32c37c08cfba99cfeef41b6d;hp=f51bdc3738d91032a349cb6cc200d578d2add599;hpb=552a7a9bd7c71973e24c16b391cbb65050f28fae;p=p5sagit%2Fp5-mst-13.2.git diff --git a/perl.c b/perl.c index f51bdc3..77bcb4d 100644 --- a/perl.c +++ b/perl.c @@ -20,7 +20,7 @@ #include #endif -dEXT char rcsid[] = "perl.c\nPatch level: ###\n"; +dEXTCONST char rcsid[] = "perl.c\nPatch level: ###\n"; #ifdef IAMSUID #ifndef DOSUID @@ -34,8 +34,32 @@ dEXT char rcsid[] = "perl.c\nPatch level: ###\n"; #endif #endif +#define I_REINIT \ + STMT_START { \ + chopset = " \n-"; \ + copline = NOLINE; \ + curcop = &compiling; \ + curcopdb = NULL; \ + cxstack_ix = -1; \ + cxstack_max = 128; \ + dbargs = 0; \ + dlmax = 128; \ + laststatval = -1; \ + laststype = OP_STAT; \ + maxscream = -1; \ + maxsysfd = MAXSYSFD; \ + statname = Nullsv; \ + tmps_floor = -1; \ + tmps_ix = -1; \ + op_mask = NULL; \ + dlmax = 128; \ + laststatval = -1; \ + laststype = OP_STAT; \ + } STMT_END + static void find_beginning _((void)); -static void incpush _((char *)); +static void forbid_setid _((char *)); +static void incpush _((char *, int)); static void init_ids _((void)); static void init_debugger _((void)); static void init_lexer _((void)); @@ -44,6 +68,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 *)); @@ -92,6 +117,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 @@ -104,22 +131,18 @@ register PerlInterpreter *sv_interp; } #ifdef MULTIPLICITY - chopset = " \n-"; - copline = NOLINE; - curcop = &compiling; - dbargs = 0; - dlmax = 128; - laststatval = -1; - laststype = OP_STAT; - maxscream = -1; - maxsysfd = MAXSYSFD; - rsfp = Nullfp; - statname = Nullsv; - tmps_floor = -1; + I_REINIT; + perl_destruct_level = 1; +#else + if(perl_destruct_level > 0) + I_REINIT; #endif init_ids(); + STATUS_ALL_SUCCESS; + + SET_NUMERIC_STANDARD(); #if defined(SUBVERSION) && SUBVERSION > 0 sprintf(patchlevel, "%7.5f", (double) 5 + ((double) PATCHLEVEL / (double) 1000) @@ -136,7 +159,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; @@ -157,11 +179,22 @@ register PerlInterpreter *sv_interp; #ifdef DEBUGGING { char *s; - if (s = getenv("PERL_DESTRUCT_LEVEL")) - destruct_level = atoi(s); + if (s = getenv("PERL_DESTRUCT_LEVEL")) { + int i = atoi(s); + if (destruct_level < i) + destruct_level = i; + } } #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; @@ -189,8 +222,126 @@ register PerlInterpreter *sv_interp; /* The exit() function will do everything that needs doing. */ return; } - + + /* loosen bonds of global variables */ + + if(rsfp) { + (void)PerlIO_close(rsfp); + rsfp = Nullfp; + } + + /* Filters for program text */ + SvREFCNT_dec(rsfp_filters); + rsfp_filters = Nullav; + + /* switches */ + preprocess = FALSE; + minus_n = FALSE; + minus_p = FALSE; + minus_l = FALSE; + minus_a = FALSE; + minus_F = FALSE; + doswitches = FALSE; + dowarn = FALSE; + doextract = FALSE; + sawampersand = FALSE; /* must save all match strings */ + sawstudy = FALSE; /* do fbm_instr on all strings */ + sawvec = FALSE; + unsafe = FALSE; + + Safefree(inplace); + inplace = Nullch; + + Safefree(e_tmpname); + e_tmpname = Nullch; + + if (e_fp) { + PerlIO_close(e_fp); + e_fp = Nullfp; + } + + /* magical thingies */ + + Safefree(ofs); /* $, */ + ofs = Nullch; + + Safefree(ors); /* $\ */ + ors = Nullch; + + SvREFCNT_dec(nrs); /* $\ helper */ + nrs = Nullsv; + + multiline = 0; /* $* */ + + SvREFCNT_dec(statname); + statname = Nullsv; + statgv = Nullgv; + + /* defgv, aka *_ should be taken care of elsewhere */ + +#if 0 /* just about all regexp stuff, seems to be ok */ + + /* shortcuts to regexp stuff */ + leftgv = Nullgv; + ampergv = Nullgv; + + SAVEFREEOP(curpm); + SAVEFREEOP(oldlastpm); /* for saving regexp context during debugger */ + + regprecomp = NULL; /* uncompiled string. */ + regparse = NULL; /* Input-scan pointer. */ + regxend = NULL; /* End of input for compile */ + regnpar = 0; /* () count. */ + regcode = NULL; /* Code-emit pointer; ®dummy = don't. */ + regsize = 0; /* Code size. */ + regnaughty = 0; /* How bad is this pattern? */ + regsawback = 0; /* Did we see \1, ...? */ + + reginput = NULL; /* String-input pointer. */ + regbol = NULL; /* Beginning of input, for ^ check. */ + regeol = NULL; /* End of input, for $ check. */ + regstartp = (char **)NULL; /* Pointer to startp array. */ + regendp = (char **)NULL; /* Ditto for endp. */ + reglastparen = 0; /* Similarly for lastparen. */ + regtill = NULL; /* How far we are required to go. */ + regflags = 0; /* are we folding, multilining? */ + regprev = (char)NULL; /* char before regbol, \n if none */ + +#endif /* if 0 */ + + /* clean up after study() */ + SvREFCNT_dec(lastscream); + lastscream = Nullsv; + Safefree(screamfirst); + screamfirst = 0; + Safefree(screamnext); + screamnext = 0; + + /* startup and shutdown function lists */ + SvREFCNT_dec(beginav); + SvREFCNT_dec(endav); + beginav = Nullav; + endav = Nullav; + + /* temp stack during pp_sort() */ + SvREFCNT_dec(sortstack); + sortstack = Nullav; + + /* shortcuts just get cleared */ + envgv = Nullgv; + siggv = Nullgv; + incgv = Nullgv; + errgv = Nullgv; + argvgv = Nullgv; + argvoutgv = Nullgv; + stdingv = Nullgv; + last_in_gv = Nullgv; + + /* reset so print() ends up where we expect */ + setdefout(Nullgv); + /* Prepare to destruct main symbol table. */ + hv = defstash; defstash = 0; SvREFCNT_dec(hv); @@ -251,8 +402,10 @@ register PerlInterpreter *sv_interp; warn("Scalars leaked: %d\n", 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(); @@ -327,18 +480,18 @@ setuid perl scripts securely.\n"); op_free(main_root); main_root = 0; + time(&basetime); + switch (Sigsetjmp(top_env,1)) { case 1: -#ifdef VMS - statusvalue = 255; -#else - statusvalue = 1; -#endif + STATUS_ALL_FAILURE; + /* FALL THROUGH */ case 2: + /* my_exit() was called */ curstash = defstash; if (endav) calllist(endav); - return(statusvalue); /* my_exit() was called */ + return STATUS_NATIVE_EXPORT; case 3: PerlIO_printf(PerlIO_stderr(), "panic: top_env\n"); return 1; @@ -374,7 +527,6 @@ setuid perl scripts securely.\n"); case 'n': case 'p': case 's': - case 'T': case 'u': case 'U': case 'v': @@ -383,6 +535,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"); @@ -406,27 +563,27 @@ setuid perl scripts securely.\n"); (void)PerlIO_putc(e_fp,'\n'); break; case 'I': - taint_not("-I"); + forbid_setid("-I"); sv_catpv(sv,"-"); 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," "); } break; case 'P': - taint_not("-P"); + forbid_setid("-P"); preprocess = TRUE; s++; goto reswitch; case 'S': - taint_not("-S"); + forbid_setid("-S"); dosearch = TRUE; s++; goto reswitch; @@ -516,7 +673,7 @@ setuid perl scripts securely.\n"); else if (scriptname == Nullch) { #ifdef MSDOS if ( isatty(PerlIO_fileno(PerlIO_stdin())) ) - moreswitches("v"); + moreswitches("h"); #endif scriptname = "-"; } @@ -532,6 +689,7 @@ setuid perl scripts securely.\n"); compcv = (CV*)NEWSV(1104,0); sv_upgrade((SV *)compcv, SVt_PVCV); + CvUNIQUE_on(compcv); comppad = newAV(); av_push(comppad, Nullsv); @@ -615,6 +773,7 @@ PerlInterpreter *sv_interp; cxstack_ix = -1; /* start context stack again */ break; case 2: + /* my_exit() was called */ curstash = defstash; if (endav) calllist(endav); @@ -623,7 +782,7 @@ PerlInterpreter *sv_interp; if (getenv("PERL_DEBUG_MSTATS")) dump_mstats("after execution: "); #endif - return(statusvalue); /* my_exit() was called */ + return STATUS_NATIVE_EXPORT; case 3: if (!restartop) { PerlIO_printf(PerlIO_stderr(), "panic: restartop\n"); @@ -668,24 +827,6 @@ PerlInterpreter *sv_interp; 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; @@ -729,13 +870,13 @@ char* name; I32 create; { GV* gv = gv_fetchpv(name, create, SVt_PVCV); - if (create && !GvCV(gv)) - return newSUB(start_subparse(), + if (create && !GvCVu(gv)) + return newSUB(start_subparse(FALSE, 0), newSVOP(OP_CONST, 0, newSVpv(name,0)), Nullop, Nullop); if (gv) - return GvCV(gv); + return GvCVu(gv); return Nullcv; } @@ -816,8 +957,12 @@ I32 flags; /* See G_* flags in cop.h */ if (flags & G_ARRAY) myop.op_flags |= OPf_LIST; - if (perldb && curstash != debstash - && (DBcv || (DBcv = GvCV(DBsub)))) /* to handle first BEGIN of -d */ + if (perldb && curstash != debstash + /* Handle first BEGIN of -d. */ + && (DBcv || (DBcv = GvCV(DBsub))) + /* Try harder, since this may have been a sighandler, thus + * curstash may be meaningless. */ + && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != debstash)) op->op_private |= OPpENTERSUB_DB; if (flags & G_EVAL) { @@ -851,11 +996,7 @@ I32 flags; /* See G_* flags in cop.h */ 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 */ @@ -864,7 +1005,7 @@ I32 flags; /* See G_* flags in cop.h */ Copy(oldtop, top_env, 1, Sigjmp_buf); if (statusvalue) croak("Callback called exit"); - my_exit(statusvalue); + my_exit_jump(); /* NOTREACHED */ case 3: if (restartop) { @@ -960,11 +1101,7 @@ restart: 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 */ @@ -973,7 +1110,7 @@ restart: Copy(oldtop, top_env, 1, Sigjmp_buf); if (statusvalue) croak("Callback called exit"); - my_exit(statusvalue); + my_exit_jump(); /* NOTREACHED */ case 3: if (restartop) { @@ -1035,47 +1172,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; @@ -1144,7 +1240,7 @@ char *s; s++; return s; case 'd': - taint_not("-d"); + forbid_setid("-d"); s++; if (*s == ':' || *s == '=') { sprintf(buf, "use Devel::%s;", ++s); @@ -1158,7 +1254,7 @@ char *s; return s; case 'D': #ifdef DEBUGGING - taint_not("-D"); + forbid_setid("-D"); if (isALPHA(s[1])) { static char debopts[] = "psltocPmfrxuLHXD"; char *d; @@ -1189,11 +1285,13 @@ char *s; *s = '\0'; break; case 'I': - taint_not("-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; } @@ -1222,10 +1320,10 @@ char *s; } return s; case 'M': - taint_not("-M"); /* XXX ? */ + forbid_setid("-M"); /* XXX ? */ /* FALL THROUGH */ case 'm': - taint_not("-m"); /* XXX ? */ + forbid_setid("-m"); /* XXX ? */ if (*++s) { char *start; char *use = "use "; @@ -1265,12 +1363,13 @@ char *s; s++; return s; case 's': - taint_not("-s"); + forbid_setid("-s"); doswitches = TRUE; s++; return s; case 'T': - tainting = TRUE; + if (!tainting) + croak("Too late for \"-T\" option (try putting it first)"); s++; return s; case 'u': @@ -1288,13 +1387,15 @@ 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("MS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n"); + printf("\n\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n"); +#endif +#ifdef DJGPP + printf("djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n"); #endif #ifdef OS2 - printf("OS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n" + 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"); #endif #ifdef atarist @@ -1303,9 +1404,6 @@ char *s; printf("\n\ Perl may be copied only under the terms of either the Artistic License or the\n\ GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n"); -#ifdef MSDOS - usage(origargv[0]); -#endif exit(0); case 'w': dowarn = TRUE; @@ -1509,7 +1607,8 @@ SV *sv; if (fdscript >= 0) { rsfp = PerlIO_fdopen(fdscript,"r"); #if defined(HAS_FCNTL) && defined(F_SETFD) - fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */ + if (rsfp) + fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */ #endif } else if (preprocess) { @@ -1581,16 +1680,20 @@ sed %s -e \"/^[^#]/b\" \ rsfp = my_popen(buf,"r"); } else if (!*scriptname) { - taint_not("program input from stdin"); + forbid_setid("program input from stdin"); rsfp = PerlIO_stdin(); } else { rsfp = PerlIO_open(scriptname,"r"); #if defined(HAS_FCNTL) && defined(F_SETFD) - fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */ + if (rsfp) + fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */ #endif } - if ((PerlIO*)rsfp == Nullfp) { + if (e_tmpname) { + e_fp = rsfp; + } + if (!rsfp) { #ifdef DOSUID #ifndef IAMSUID /* in case script is not readable before setuid */ if (euid && Stat(SvPVX(GvSV(curcop->cop_filegv)),&statbuf) >= 0 && @@ -1856,7 +1959,7 @@ find_beginning() /* skip forward in input to the real script? */ - taint_not("-x"); + forbid_setid("-x"); while (doextract) { if ((s = sv_gets(linestr, rsfp, 0)) == Nullch) croak("No Perl script found in input\n"); @@ -1893,6 +1996,16 @@ init_ids() } static void +forbid_setid(s) +char *s; +{ + if (euid != uid) + croak("No %s allowed while running setuid", s); + if (egid != gid) + croak("No %s allowed while running setgid", s); +} + +static void init_debugger() { curstash = debstash; @@ -1914,15 +2027,32 @@ static void init_stacks() { curstack = newAV(); - mainstack = curstack; /* remember in case we switch stacks */ - AvREAL_off(curstack); /* not a real array */ + mainstack = curstack; /* remember in case we switch stacks */ + AvREAL_off(curstack); /* not a real array */ av_extend(curstack,127); stack_base = AvARRAY(curstack); stack_sp = stack_base; stack_max = stack_base + 127; - /* Shouldn't these stacks be per-interpreter? */ + cxstack_max = 8192 / sizeof(CONTEXT) - 2; /* Use most of 8K. */ + New(50,cxstack,cxstack_max + 1,CONTEXT); + cxstack_ix = -1; + + New(50,tmps_stack,128,SV*); + tmps_ix = -1; + tmps_max = 128; + + DEBUG( { + New(51,debname,128,char); + New(52,debdelim,128,char); + } ) + + /* + * The following stacks almost certainly should be per-interpreter, + * but for now they're not. XXX + */ + if (markstack) { markstack_ptr = markstack; } else { @@ -1953,20 +2083,7 @@ init_stacks() New(54,retstack,16,OP*); retstack_ix = 0; retstack_max = 16; - } - - cxstack_max = 8192 / sizeof(CONTEXT) - 2; /* Use most of 8K. */ - New(50,cxstack,cxstack_max + 1,CONTEXT); - cxstack_ix = -1; - - New(50,tmps_stack,128,SV*); - tmps_ix = -1; - tmps_max = 128; - - DEBUG( { - New(51,debname,128,char); - New(52,debdelim,128,char); - } ) + } } static void @@ -1974,14 +2091,18 @@ nuke_stacks() { Safefree(cxstack); Safefree(tmps_stack); + DEBUG( { + Safefree(debname); + Safefree(debdelim); + } ) } static PerlIO *tmpfp; /* moved outside init_lexer() because of UNICOS bug */ + static void init_lexer() { tmpfp = rsfp; - lex_start(linestr); rsfp = tmpfp; subname = newSVpv("main",4); @@ -2058,13 +2179,11 @@ register char **env; sv_setpvn(bodytarget, "", 0); formtarget = bodytarget; - tainted = 1; + TAINT; if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) { 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)) { @@ -2107,10 +2226,9 @@ register char **env; #endif hv_magic(hv, envgv, 'E'); } - tainted = 0; + TAINT_NOT; if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV)) sv_setiv(GvSV(tmpgv),(I32)getpid()); - } static void @@ -2121,9 +2239,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 @@ -2132,9 +2250,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 */ } @@ -2142,29 +2260,116 @@ 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); + } + } + + /* 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; + + /* .../archname/version if -d .../archname/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/version if -d .../archname/version/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 @@ -2201,11 +2406,7 @@ AV* list; } 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 */ @@ -2222,9 +2423,8 @@ 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"); @@ -2241,3 +2441,69 @@ AV* list; 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 (GETSTATUS_NATIVE & 1) /* fortuitiously includes "-1" */ + SETSTATUS_NATIVE(44); + } + else { + if (!vaxc$errno && errno) /* someone must have set $^E = 0 */ + SETSTATUS_NATIVE(44); + else + SETSTATUS_NATIVE(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; + } + Siglongjmp(top_env, 2); +}