X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=perl.c;h=d769b44e39eded254dd79393bfa14d0c064e0515;hb=94d58c47cfbe97ca0a689bcd5b7f9132f7918fee;hp=a01afc1a734deb02c2f57d4c191f5ef858de5137;hpb=f0b7e567eb499713477c3eec4806ba74015e12df;p=p5sagit%2Fp5-mst-13.2.git diff --git a/perl.c b/perl.c index a01afc1..d769b44 100644 --- a/perl.c +++ b/perl.c @@ -1,6 +1,6 @@ /* perl.c * - * Copyright (c) 1987-1994 Larry Wall + * Copyright (c) 1987-1996 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. @@ -21,7 +21,7 @@ #endif */ -char rcsid[] = "perl.c\nPatch level: ###\n"; +dEXT char rcsid[] = "perl.c\nPatch level: ###\n"; #ifdef IAMSUID #ifndef DOSUID @@ -46,6 +46,7 @@ static void init_postdump_symbols _((int, char **, char **)); static void init_predump_symbols _((void)); static void init_stacks _((void)); static void open_script _((char *, bool, SV *)); +static void usage _((char *)); static void validate_suid _((char *)); PerlInterpreter * @@ -84,6 +85,9 @@ register PerlInterpreter *sv_interp; SvNV(&sv_yes); SvREADONLY_on(&sv_yes); + nrs = newSVpv("\n", 1); + rs = SvREFCNT_inc(nrs); + #ifdef MSDOS /* * There is no way we can refer to them from Perl so close them to save @@ -99,24 +103,29 @@ register PerlInterpreter *sv_interp; chopset = " \n-"; copline = NOLINE; curcop = &compiling; + dbargs = 0; dlmax = 128; laststatval = -1; laststype = OP_STAT; maxscream = -1; maxsysfd = MAXSYSFD; - nrs = "\n"; - nrschar = '\n'; - nrslen = 1; - rs = "\n"; - rschar = '\n'; rsfp = Nullfp; - rslen = 1; statname = Nullsv; tmps_floor = -1; #endif init_ids(); + +#if defined(SUBVERSION) && SUBVERSION > 0 + sprintf(patchlevel, "%7.5f", 5.0 + (PATCHLEVEL / 1000.0) + + (SUBVERSION / 100000.0)); +#else sprintf(patchlevel, "%5.3f", 5.0 + (PATCHLEVEL / 1000.0)); +#endif + +#if defined(LOCAL_PATCH_COUNT) + Ilocalpatches = local_patches; /* For possible -v */ +#endif fdpid = newAV(); /* for remembering popen pids by fd */ pidstatus = newHV();/* for remembering status of dead pids */ @@ -137,6 +146,14 @@ register PerlInterpreter *sv_interp; return; destruct_level = perl_destruct_level; +#ifdef DEBUGGING + { + char *s; + if (s = getenv("PERL_DESTRUCT_LEVEL")) + destruct_level = atoi(s); + } +#endif + LEAVE; FREETMPS; @@ -192,6 +209,7 @@ register PerlInterpreter *sv_interp; } if (sv_count != 0) warn("Scalars leaked: %d\n", sv_count); + sv_free_arenas(); DEBUG_P(debprofdump()); } @@ -218,7 +236,7 @@ char **env; { register SV *sv; register char *s; - char *scriptname; + char *scriptname = NULL; VOL bool dosearch = FALSE; char *validarg = ""; AV* comppadlist; @@ -239,6 +257,7 @@ setuid perl scripts securely.\n"); #ifndef VMS /* VMS doesn't have environ array */ origenviron = environ; #endif + e_tmpname = Nullch; if (do_undump) { @@ -256,7 +275,7 @@ setuid perl scripts securely.\n"); op_free(main_root); main_root = 0; - switch (setjmp(top_env)) { + switch (Sigsetjmp(top_env,1)) { case 1: #ifdef VMS statusvalue = 255; @@ -295,8 +314,11 @@ setuid perl scripts securely.\n"); case 'c': case 'd': case 'D': + case 'h': case 'i': case 'l': + case 'M': + case 'm': case 'n': case 'p': case 's': @@ -352,6 +374,22 @@ setuid perl scripts securely.\n"); dosearch = TRUE; s++; goto reswitch; + case 'V': + if (!preambleav) + preambleav = newAV(); + av_push(preambleav, newSVpv("use Config qw(myconfig config_vars)",0)); + if (*++s != ':') { + Sv = newSVpv("print myconfig(),'@INC: '.\"@INC\\n\"",0); + } + else { + Sv = newSVpv("config_vars(qw(",0); + sv_catpv(Sv, ++s); + sv_catpv(Sv, "))"); + s += strlen(s); + } + av_push(preambleav, Sv); + scriptname = BIT_BUCKET; /* don't look for script or read stdin */ + goto reswitch; case 'x': doextract = TRUE; s++; @@ -368,10 +406,12 @@ setuid perl scripts securely.\n"); } } switch_end: - scriptname = argv[0]; + if (!scriptname) + scriptname = argv[0]; if (e_fp) { - if (fflush(e_fp) || ferror(e_fp) || fclose(e_fp)) + if (Fflush(e_fp) || ferror(e_fp) || fclose(e_fp)) croak("Can't write to temp file for -e: %s", Strerror(errno)); + e_fp = Nullfp; argc++,argv--; scriptname = e_tmpname; } @@ -407,8 +447,8 @@ setuid perl scripts securely.\n"); comppadlist = newAV(); AvREAL_off(comppadlist); - av_store(comppadlist, 0, SvREFCNT_inc((SV*)comppad_name)); - av_store(comppadlist, 1, SvREFCNT_inc((SV*)comppad)); + av_store(comppadlist, 0, (SV*)comppad_name); + av_store(comppadlist, 1, (SV*)comppad); CvPADLIST(compcv) = comppadlist; if (xsinit) @@ -437,18 +477,16 @@ setuid perl scripts securely.\n"); curcop->cop_line = 0; curstash = defstash; preprocess = FALSE; - if (e_fp) { - e_fp = Nullfp; + if (e_tmpname) { (void)UNLINK(e_tmpname); + Safefree(e_tmpname); + e_tmpname = Nullch; } /* now that script is parsed, we can modify record separator */ - - rs = nrs; - rslen = nrslen; - rschar = nrschar; - rspara = (nrslen == 2); - sv_setpvn(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), rs, rslen); + SvREFCNT_dec(rs); + rs = SvREFCNT_inc(nrs); + sv_setsv(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), rs); if (do_undump) my_unexec(); @@ -458,6 +496,12 @@ setuid perl scripts securely.\n"); LEAVE; FREETMPS; + +#ifdef DEBUGGING_MSTATS + if ((s=getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2) + dump_mstats("after compilation:"); +#endif + ENTER; restartop = 0; return 0; @@ -469,7 +513,7 @@ PerlInterpreter *sv_interp; { if (!(curinterp = sv_interp)) return 255; - switch (setjmp(top_env)) { + switch (Sigsetjmp(top_env,1)) { case 1: cxstack_ix = -1; /* start context stack again */ break; @@ -478,6 +522,10 @@ PerlInterpreter *sv_interp; if (endav) calllist(endav); FREETMPS; +#ifdef DEBUGGING_MSTATS + if (getenv("PERL_DEBUG_MSTATS")) + dump_mstats("after execution: "); +#endif return(statusvalue); /* my_exit() was called */ case 3: if (!restartop) { @@ -509,11 +557,11 @@ PerlInterpreter *sv_interp; if (restartop) { op = restartop; restartop = 0; - run(); + runops(); } else if (main_start) { op = main_start; - run(); + runops(); } my_exit(0); @@ -535,7 +583,7 @@ U32 status; POPBLOCK(cx,curpm); LEAVE; } - longjmp(top_env, 2); + Siglongjmp(top_env, 2); } SV* @@ -584,6 +632,7 @@ I32 create; if (create && !GvCV(gv)) return newSUB(start_subparse(), newSVOP(OP_CONST, 0, newSVpv(name,0)), + Nullop, Nullop); if (gv) return GvCV(gv); @@ -644,7 +693,7 @@ I32 flags; /* See G_* flags in cop.h */ SV** sp = stack_sp; I32 oldmark = TOPMARK; I32 retval; - jmp_buf oldtop; + Sigjmp_buf oldtop; I32 oldscope; if (flags & G_DISCARD) { @@ -667,15 +716,33 @@ I32 flags; /* See G_* flags in cop.h */ myop.op_flags |= OPf_LIST; if (flags & G_EVAL) { - Copy(top_env, oldtop, 1, jmp_buf); + Copy(top_env, oldtop, 1, Sigjmp_buf); cLOGOP->op_other = op; markstack_ptr--; - pp_entertry(); + /* we're trying to emulate pp_entertry() here */ + { + register CONTEXT *cx; + I32 gimme = GIMME; + + ENTER; + SAVETMPS; + + push_return(op->op_next); + PUSHBLOCK(cx, CXt_EVAL, stack_sp); + PUSHEVAL(cx, 0, 0); + eval_root = op; /* Only needed so that goto works right. */ + + in_eval = 1; + if (flags & G_KEEPERR) + in_eval |= 4; + else + sv_setpv(GvSV(errgv),""); + } markstack_ptr++; restart: - switch (setjmp(top_env)) { + switch (Sigsetjmp(top_env,1)) { case 0: break; case 1: @@ -689,7 +756,7 @@ I32 flags; /* See G_* flags in cop.h */ /* my_exit() was called */ curstash = defstash; FREETMPS; - Copy(oldtop, top_env, 1, jmp_buf); + Copy(oldtop, top_env, 1, Sigjmp_buf); if (statusvalue) croak("Callback called exit"); my_exit(statusvalue); @@ -714,10 +781,10 @@ I32 flags; /* See G_* flags in cop.h */ if (op == (OP*)&myop) op = pp_entersub(); if (op) - run(); + runops(); retval = stack_sp - (stack_base + oldmark); - if (flags & G_EVAL) - sv_setpv(GvSV(gv_fetchpv("@",TRUE, SVt_PV)),""); + if ((flags & G_EVAL) && !(flags & G_KEEPERR)) + sv_setpv(GvSV(errgv),""); cleanup: if (flags & G_EVAL) { @@ -734,7 +801,7 @@ I32 flags; /* See G_* flags in cop.h */ curpm = newpm; LEAVE; } - Copy(oldtop, top_env, 1, jmp_buf); + Copy(oldtop, top_env, 1, Sigjmp_buf); } if (flags & G_DISCARD) { stack_sp = stack_base + oldmark; @@ -745,78 +812,107 @@ I32 flags; /* See G_* flags in cop.h */ return retval; } -/* Older forms, here grandfathered. */ +/* Eval a string. */ -#ifdef DEPRECATED I32 -perl_callargv(subname, spix, gimme, argv) -char *subname; -register I32 spix; /* current stack pointer index */ -I32 gimme; /* See G_* flags in cop.h */ -register char **argv; /* null terminated arg list, NULL for no arglist */ -{ - stack_sp = stack_base + spix; - return spix + perl_call_argv(subname, gimme, argv); -} - -I32 -perl_callpv(subname, spix, gimme, hasargs, numargs) -char *subname; -I32 spix; /* stack pointer index after args are pushed */ -I32 gimme; /* See G_* flags in cop.h */ -I32 hasargs; /* whether to create a @_ array for routine */ -I32 numargs; /* how many args are pushed on the stack */ -{ - stack_sp = stack_base + spix; - PUSHMARK(stack_sp - numargs); - return spix - numargs + perl_call_sv((SV*)perl_get_cv(subname, TRUE), - gimme, hasargs, numargs); -} - -I32 -perl_callsv(sv, spix, gimme, hasargs, numargs) +perl_eval_sv(sv, flags) SV* sv; -I32 spix; /* stack pointer index after args are pushed */ -I32 gimme; /* See G_* flags in cop.h */ -I32 hasargs; /* whether to create a @_ array for routine */ -I32 numargs; /* how many args are pushed on the stack */ -{ - stack_sp = stack_base + spix; - PUSHMARK(stack_sp - numargs); - return spix - numargs + perl_call_sv(sv, gimme, hasargs, numargs); -} -#endif - -/* Require a module. */ - -void -perl_requirepv(pv) -char* pv; +I32 flags; /* See G_* flags in cop.h */ { UNOP myop; /* fake syntax tree node */ - SV* sv; - dSP; + SV** sp = stack_sp; + I32 oldmark = sp - stack_base; + I32 retval; + Sigjmp_buf oldtop; + I32 oldscope; - ENTER; - SAVETMPS; + if (flags & G_DISCARD) { + ENTER; + SAVETMPS; + } + SAVESPTR(op); - sv = sv_newmortal(); - sv_setpv(sv, pv); op = (OP*)&myop; Zero(op, 1, UNOP); - XPUSHs(sv); + EXTEND(stack_sp, 1); + *++stack_sp = sv; + oldscope = scopestack_ix; - myop.op_type = OP_REQUIRE; + if (!(flags & G_NOARGS)) + myop.op_flags = OPf_STACKED; myop.op_next = Nullop; - myop.op_private = 1; - myop.op_flags = OPf_KNOW; + myop.op_flags |= OPf_KNOW; + if (flags & G_ARRAY) + myop.op_flags |= OPf_LIST; - PUTBACK; - if (op = pp_require()) - run(); - stack_sp--; - FREETMPS; - LEAVE; + Copy(top_env, oldtop, 1, Sigjmp_buf); + +restart: + switch (Sigsetjmp(top_env,1)) { + case 0: + break; + case 1: +#ifdef VMS + statusvalue = 255; /* XXX I don't think we use 1 anymore. */ +#else + statusvalue = 1; +#endif + /* FALL THROUGH */ + case 2: + /* my_exit() was called */ + curstash = defstash; + FREETMPS; + Copy(oldtop, top_env, 1, Sigjmp_buf); + if (statusvalue) + croak("Callback called exit"); + my_exit(statusvalue); + /* NOTREACHED */ + case 3: + if (restartop) { + op = restartop; + restartop = 0; + goto restart; + } + stack_sp = stack_base + oldmark; + if (flags & G_ARRAY) + retval = 0; + else { + retval = 1; + *++stack_sp = &sv_undef; + } + goto cleanup; + } + + if (op == (OP*)&myop) + op = pp_entereval(); + if (op) + runops(); + retval = stack_sp - (stack_base + oldmark); + if ((flags & G_EVAL) && !(flags & G_KEEPERR)) + sv_setpv(GvSV(errgv),""); + + cleanup: + Copy(oldtop, top_env, 1, Sigjmp_buf); + if (flags & G_DISCARD) { + stack_sp = stack_base + oldmark; + retval = 0; + FREETMPS; + LEAVE; + } + return retval; +} + +/* Require a module. */ + +void +perl_require_pv(pv) +char* pv; +{ + SV* sv = sv_newmortal(); + sv_setpv(sv, "require '"); + sv_catpv(sv, pv); + sv_catpv(sv, "'"); + perl_eval_sv(sv, G_DISCARD); } void @@ -868,6 +964,41 @@ char *p; } } +static void +usage(name) /* XXX move this out into a module ? */ +char *name; +{ + /* This message really ought to be max 23 lines. + * Removed -h because the user already knows that opton. Others? */ + printf("\nUsage: %s [switches] [--] [programfile] [arguments]", name); + printf("\n -0[octal] specify record separator (\\0, if no argument)"); + printf("\n -a autosplit mode with -n or -p (splits $_ into @F)"); + printf("\n -c check syntax only (runs BEGIN and END blocks)"); + printf("\n -d[:debugger] run scripts under debugger"); + printf("\n -D[number/list] set debugging flags (argument is a bit mask or flags)"); + printf("\n -e 'command' one line of script. Several -e's allowed. Omit [programfile]."); + printf("\n -F/pattern/ split() pattern for autosplit (-a). The //'s are optional."); + printf("\n -i[extension] edit <> files in place (make backup if extension supplied)"); + printf("\n -Idirectory specify @INC/#include directory (may be used more then once)"); + printf("\n -l[octal] enable line ending processing, specifies line teminator"); + printf("\n -[mM][-]module.. executes `use/no module...' before executing your script."); + printf("\n -n assume 'while (<>) { ... }' loop arround your script"); + printf("\n -p assume loop like -n but print line also like sed"); + printf("\n -P run script through C preprocessor before compilation"); +#ifdef OS2 + printf("\n -R enable REXX variable pool"); +#endif + printf("\n -s enable some switch parsing for switches after script name"); + printf("\n -S look for the script using PATH environment variable"); + printf("\n -T turn on tainting checks"); + printf("\n -u dump core after parsing script"); + printf("\n -U allow unsafe operations"); + printf("\n -v print version number and patchlevel of perl"); + printf("\n -V[:variable] print perl configuration information"); + printf("\n -w TURN WARNINGS ON FOR COMPILATION OF YOUR SCRIPT."); + printf("\n -x[directory] strip off text before #!perl line and perhaps cd to directory\n"); +} + /* This routine handles any switches that can be given during run */ char * @@ -875,20 +1006,19 @@ moreswitches(s) char *s; { I32 numlen; + U32 rschar; switch (*s) { case '0': - nrschar = scan_oct(s, 4, &numlen); - nrs = savepvn("\n",1); - *nrs = nrschar; - if (nrschar > 0377) { - nrslen = 0; - nrs = ""; - } - else if (!nrschar && numlen >= 2) { - nrslen = 2; - nrs = "\n\n"; - nrschar = '\n'; + rschar = scan_oct(s, 4, &numlen); + SvREFCNT_dec(nrs); + if (rschar & ~((U8)~0)) + nrs = &sv_undef; + else if (!rschar && numlen >= 2) + nrs = newSVpv("", 0); + else { + char ch = rschar; + nrs = newSVpv(&ch, 1); } return s + numlen; case 'F': @@ -906,11 +1036,16 @@ char *s; return s; case 'd': taint_not("-d"); + s++; + if (*s == ':' || *s == '=') { + sprintf(buf, "use Devel::%s;", ++s); + s += strlen(s); + my_setenv("PERL5DB",buf); + } if (!perldb) { perldb = TRUE; init_debugger(); } - s++; return s; case 'D': #ifdef DEBUGGING @@ -933,6 +1068,9 @@ char *s; #endif /*SUPPRESS 530*/ return s; + case 'h': + usage(origargv[0]); + exit(0); case 'i': if (inplace) Safefree(inplace); @@ -965,9 +1103,48 @@ char *s; s += numlen; } else { - ors = savepvn(nrs,nrslen); - orslen = nrslen; + if (RsPARA(nrs)) { + ors = savepvn("\n\n", 2); + orslen = 2; + } + else + ors = SvPV(nrs, orslen); + } + return s; + case 'M': + taint_not("-M"); /* XXX ? */ + /* FALL THROUGH */ + case 'm': + taint_not("-m"); /* XXX ? */ + if (*++s) { + char *start; + char *use = "use "; + /* -M-foo == 'no foo' */ + if (*s == '-') { use = "no "; ++s; } + Sv = newSVpv(use,0); + start = s; + /* We allow -M'Module qw(Foo Bar)' */ + while(isALNUM(*s) || *s==':') ++s; + if (*s != '=') { + sv_catpv(Sv, start); + if (*(start-1) == 'm') { + if (*s != '\0') + croak("Can't use '%c' after -mname", *s); + sv_catpv( Sv, " ()"); + } + } else { + sv_catpvn(Sv, start, s-start); + sv_catpv(Sv, " split(/,/,q{"); + sv_catpv(Sv, ++s); + sv_catpv(Sv, "})"); + } + s += strlen(s); + if (preambleav == NULL) + preambleav = newAV(); + av_push(preambleav, Sv); } + else + croak("No space allowed after -%c", *(s-1)); return s; case 'n': minus_n = TRUE; @@ -995,23 +1172,58 @@ char *s; s++; return s; case 'v': - printf("\nThis is perl, version %s\n\n",patchlevel); - fputs("\tUnofficial patchlevel 1e.\n",stdout); - fputs("\nCopyright 1987-1994, Larry Wall\n",stdout); +#if defined(SUBVERSION) && SUBVERSION > 0 + printf("\nThis is perl, version 5.%03d_%02d", PATCHLEVEL, SUBVERSION); +#else + printf("\nThis is perl, version %s",patchlevel); +#endif + +#if defined(DEBUGGING) || defined(EMBED) || defined(MULTIPLICITY) + fputs(" with", stdout); +#ifdef DEBUGGING + fputs(" DEBUGGING", stdout); +#endif +#ifdef EMBED + fputs(" EMBED", stdout); +#endif +#ifdef MULTIPLICITY + fputs(" MULTIPLICITY", stdout); +#endif +#endif + +#if defined(LOCAL_PATCH_COUNT) + if (LOCAL_PATCH_COUNT > 0) + { int i; + fputs("\n\tLocally applied patches:\n", stdout); + for (i = 1; i <= LOCAL_PATCH_COUNT; i++) { + if (Ilocalpatches[i]) + fprintf(stdout, "\t %s\n", Ilocalpatches[i]); + } + } +#endif + printf("\n\tbuilt under %s",OSNAME); +#ifdef __DATE__ +# ifdef __TIME__ + printf(" at %s %s",__DATE__,__TIME__); +# else + printf(" on %s",__DATE__); +# endif +#endif + fputs("\n\nCopyright 1987-1996, Larry Wall\n",stdout); #ifdef MSDOS fputs("MS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n", stdout); -#ifdef OS2 - fputs("OS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n", - stdout); #endif +#ifdef OS2 + fputs("OS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n" + "Version 5 port Copyright (c) 1994-1995, Andreas Kaiser\n", stdout); #endif #ifdef atarist - fputs("atariST series port, ++jrb bammi@cadence.com\n", stdout); + fputs("atariST series port, ++jrb bammi@cadence.com\n", stdout); #endif fputs("\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",stdout); +GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n",stdout); #ifdef MSDOS usage(origargv[0]); #endif @@ -1059,8 +1271,13 @@ my_unexec() fprintf(stderr, "unexec of %s into %s failed!\n", tokenbuf, buf); exit(status); #else +# ifdef VMS +# include + lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */ +#else ABORT(); /* for use with undump */ #endif +#endif } static void @@ -1075,11 +1292,15 @@ init_main_stash() SvREADONLY_on(gv); HvNAME(defstash) = savepv("main"); incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV))); - SvMULTI_on(incgv); + GvMULTI_on(incgv); defgv = gv_fetchpv("_",TRUE, SVt_PVAV); + errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV)); + GvMULTI_on(errgv); curstash = defstash; compiling.cop_stash = defstash; debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV)); + /* We must init $/ before switches are processed. */ + sv_setpvn(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), "\n", 1); } #ifdef CAN_PROTOTYPE @@ -1097,7 +1318,26 @@ SV *sv; char *xfailed = Nullch; register char *s; I32 len; + int retval; +#if defined(DOSISH) && !defined(OS2) && !defined(atarist) +#define SEARCH_EXTS ".bat", ".cmd", NULL +#endif +#ifdef VMS +# define SEARCH_EXTS ".pl", ".com", NULL +#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 */ +#endif + +#ifdef VMS + if (dosearch && !strpbrk(scriptname,":[ 0) /* reset after previous loop */ + extidx = 0; + do { +#endif + DEBUG_p(fprintf(stderr,"Looking for %s\n",tokenbuf)); + retval = Stat(tokenbuf,&statbuf); +#ifdef SEARCH_EXTS + } while ( retval < 0 /* not there */ + && extidx>=0 && ext[extidx] /* try an extension? */ + && strcpy(tokenbuf+len, ext[extidx++]) + ); +#endif + if (retval < 0) continue; if (S_ISREG(statbuf.st_mode) && cando(S_IRUSR,TRUE,&statbuf) && cando(S_IXUSR,TRUE,&statbuf)) { @@ -1144,7 +1399,7 @@ SV *sv; scriptname = xfound; } - origfilename = savepv(e_fp ? "-e" : scriptname); + origfilename = savepv(e_tmpname ? "-e" : scriptname); curcop->cop_filegv = gv_fetchfile(origfilename); if (strEQ(origfilename,"-")) scriptname = ""; @@ -1491,7 +1746,7 @@ init_ids() uid |= gid << 16; euid |= egid << 16; #endif - tainting |= (euid != uid || egid != gid); + tainting |= (uid && (euid != uid || egid != gid)); } static void @@ -1504,8 +1759,11 @@ init_debugger() DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV); DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV)); DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV))); + sv_setiv(DBsingle, 0); DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV))); + sv_setiv(DBtrace, 0); DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV))); + sv_setiv(DBsignal, 0); curstash = defstash; } @@ -1537,9 +1795,9 @@ init_stacks() retstack_ix = 0; retstack_max = 16; - New(50,cxstack,128,CONTEXT); + cxstack_max = 8192 / sizeof(CONTEXT) - 2; /* Use most of 8K. */ + New(50,cxstack,cxstack_max + 1,CONTEXT); cxstack_ix = -1; - cxstack_max = 128; New(50,tmps_stack,128,SV*); tmps_ix = -1; @@ -1571,28 +1829,30 @@ init_predump_symbols() sv_setpvn(GvSV(gv_fetchpv("\"", TRUE, SVt_PV)), " ", 1); stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO); - SvMULTI_on(stdingv); + GvMULTI_on(stdingv); IoIFP(GvIOp(stdingv)) = stdin; tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV); + GvMULTI_on(tmpgv); GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(stdingv)); - SvMULTI_on(tmpgv); tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO); - SvMULTI_on(tmpgv); + GvMULTI_on(tmpgv); IoOFP(GvIOp(tmpgv)) = IoIFP(GvIOp(tmpgv)) = stdout; - defoutgv = tmpgv; + setdefout(tmpgv); tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV); + GvMULTI_on(tmpgv); GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(defoutgv)); - SvMULTI_on(tmpgv); othergv = gv_fetchpv("STDERR",TRUE, SVt_PVIO); - SvMULTI_on(othergv); + GvMULTI_on(othergv); IoOFP(GvIOp(othergv)) = IoIFP(GvIOp(othergv)) = stderr; tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV); + GvMULTI_on(tmpgv); GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(othergv)); - SvMULTI_on(tmpgv); statname = NEWSV(66,0); /* last filename we did stat on */ + + osname = savepv(OSNAME); } static void @@ -1640,7 +1900,7 @@ register char **env; if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV)) sv_setpv(GvSV(tmpgv),origargv[0]); if (argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) { - SvMULTI_on(argvgv); + GvMULTI_on(argvgv); (void)gv_AVadd(argvgv); av_clear(GvAVn(argvgv)); for (; argc > 0; argc--,argv++) { @@ -1649,18 +1909,21 @@ register char **env; } if (envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) { HV *hv; - SvMULTI_on(envgv); + GvMULTI_on(envgv); hv = GvHVn(envgv); hv_clear(hv); #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 + if the environment has been modified since. To avoid this + problem we treat env==NULL as meaning 'use the default' + */ + if (!env) + env = environ; if (env != environ) { environ[0] = Nullch; hv_magic(hv, envgv, 'E'); } -#endif -#ifdef DYNAMIC_ENV_FETCH - HvNAME(hv) = savepv(ENV_HV_NAME); -#endif for (; *env; env++) { if (!(s = strchr(*env,'='))) continue; @@ -1670,6 +1933,10 @@ register char **env; (void)hv_store(hv, *env, s - *env, sv, 0); *s = '='; } +#endif +#ifdef DYNAMIC_ENV_FETCH + HvNAME(hv) = savepv(ENV_HV_NAME); +#endif hv_magic(hv, envgv, 'E'); } tainted = 0; @@ -1690,6 +1957,10 @@ init_perllib() incpush(getenv("PERLLIB")); } +#ifdef APPLLIB_EXP + incpush(APPLLIB_EXP); +#endif + #ifdef ARCHLIB_EXP incpush(ARCHLIB_EXP); #endif @@ -1697,33 +1968,44 @@ init_perllib() #define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl" #endif incpush(PRIVLIB_EXP); + +#ifdef SITEARCH_EXP + incpush(SITEARCH_EXP); +#endif +#ifdef SITELIB_EXP + incpush(SITELIB_EXP); +#endif +#ifdef OLDARCHLIB_EXP /* 5.00[01] compatibility */ + incpush(OLDARCHLIB_EXP); +#endif - av_push(GvAVn(incgv),newSVpv(".",1)); + if (!tainting) + incpush("."); } void calllist(list) AV* list; { - jmp_buf oldtop; + Sigjmp_buf oldtop; STRLEN len; line_t oldline = curcop->cop_line; - Copy(top_env, oldtop, 1, jmp_buf); + Copy(top_env, oldtop, 1, Sigjmp_buf); while (AvFILL(list) >= 0) { CV *cv = (CV*)av_shift(list); SAVEFREESV(cv); - switch (setjmp(top_env)) { + switch (Sigsetjmp(top_env,1)) { case 0: { - SV* atsv = GvSV(gv_fetchpv("@",TRUE, SVt_PV)); + 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, jmp_buf); + Copy(oldtop, top_env, 1, Sigjmp_buf); curcop = &compiling; curcop->cop_line = oldline; if (list == beginav) @@ -1747,7 +2029,7 @@ AV* list; if (endav) calllist(endav); FREETMPS; - Copy(oldtop, top_env, 1, jmp_buf); + Copy(oldtop, top_env, 1, Sigjmp_buf); curcop = &compiling; curcop->cop_line = oldline; if (statusvalue) { @@ -1765,13 +2047,13 @@ AV* list; FREETMPS; break; } - Copy(oldtop, top_env, 1, jmp_buf); + Copy(oldtop, top_env, 1, Sigjmp_buf); curcop = &compiling; curcop->cop_line = oldline; - longjmp(top_env, 3); + Siglongjmp(top_env, 3); } } - Copy(oldtop, top_env, 1, jmp_buf); + Copy(oldtop, top_env, 1, Sigjmp_buf); }