X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/c69f6586a27b86846a13e0177336730d72b33c95..ea7c11a37de2088ba174a077e567a01d0e73d0ca:/perl.c diff --git a/perl.c b/perl.c index f4a9526..db78b4e 100644 --- a/perl.c +++ b/perl.c @@ -24,6 +24,13 @@ char *getenv _((char *)); /* Usually in */ #endif +#ifdef I_FCNTL +#include +#endif +#ifdef I_SYS_FILE +#include +#endif + dEXTCONST char rcsid[] = "perl.c\nPatch level: ###\n"; #ifdef IAMSUID @@ -38,34 +45,13 @@ dEXTCONST 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; \ - mess_sv = Nullsv; \ - } STMT_END - -#ifndef PERL_OBJECT +#ifdef PERL_OBJECT +static I32 read_e_script _((CPerlObj* pPerl, int idx, SV *buf_sv, int maxlen)); +#else static void find_beginning _((void)); static void forbid_setid _((char *)); static void incpush _((char *, int)); +static void init_interp _((void)); static void init_ids _((void)); static void init_debugger _((void)); static void init_lexer _((void)); @@ -78,35 +64,21 @@ static void init_postdump_symbols _((int, char **, char **)); static void init_predump_symbols _((void)); static void my_exit_jump _((void)) __attribute__((noreturn)); static void nuke_stacks _((void)); -static void open_script _((char *, bool, SV *)); +static void open_script _((char *, bool, SV *, int *fd)); static void usage _((char *)); -static void validate_suid _((char *, char*)); -#endif - -static int fdscript = -1; - -#if defined(DEBUGGING) && defined(USE_THREADS) && defined(__linux__) -#include -STATIC void -catch_sigsegv(int signo, struct sigcontext_struct sc) -{ - PerlProc_signal(SIGSEGV, SIG_DFL); - fprintf(stderr, "Segmentation fault dereferencing 0x%lx\n" - "return_address = 0x%lx, eip = 0x%lx\n", - sc.cr2, __builtin_return_address(0), sc.eip); - fprintf(stderr, "thread = 0x%lx\n", (unsigned long)THR); -} +static void validate_suid _((char *, char*, int)); +static I32 read_e_script _((int idx, SV *buf_sv, int maxlen)); #endif #ifdef PERL_OBJECT CPerlObj* perl_alloc(IPerlMem* ipM, IPerlEnv* ipE, IPerlStdIO* ipStd, IPerlLIO* ipLIO, IPerlDir* ipD, IPerlSock* ipS, IPerlProc* ipP) { - CPerlObj* pPerl = new(ipM) CPerlObj(ipM, ipE, ipStd, ipLIO, ipD, ipS, ipP); - if(pPerl != NULL) - pPerl->Init(); + CPerlObj* pPerl = new(ipM) CPerlObj(ipM, ipE, ipStd, ipLIO, ipD, ipS, ipP); + if(pPerl != NULL) + pPerl->Init(); - return pPerl; + return pPerl; } #else PerlInterpreter * @@ -118,7 +90,7 @@ perl_alloc(void) New(53, sv_interp, 1, PerlInterpreter); return sv_interp; } -#endif +#endif /* PERL_OBJECT */ void #ifdef PERL_OBJECT @@ -140,6 +112,7 @@ perl_construct(register PerlInterpreter *sv_interp) #endif #ifdef MULTIPLICITY + ++ninterps; Zero(sv_interp, 1, PerlInterpreter); #endif @@ -163,11 +136,14 @@ perl_construct(register PerlInterpreter *sv_interp) COND_INIT(&eval_cond); MUTEX_INIT(&threads_mutex); COND_INIT(&nthreads_cond); - +#ifdef EMULATE_ATOMIC_REFCOUNTS + MUTEX_INIT(&svref_mutex); +#endif /* EMULATE_ATOMIC_REFCOUNTS */ + thr = init_main_thread(); #endif /* USE_THREADS */ - linestr = NEWSV(65,80); + linestr = NEWSV(65,79); sv_upgrade(linestr,SVt_PVIV); if (!SvREADONLY(&sv_undef)) { @@ -204,12 +180,13 @@ perl_construct(register PerlInterpreter *sv_interp) #endif } + init_stacks(ARGS); #ifdef MULTIPLICITY - I_REINIT; + init_interp(); perl_destruct_level = 1; #else - if(perl_destruct_level > 0) - I_REINIT; + if (perl_destruct_level > 0) + init_interp(); #endif init_ids(); @@ -235,11 +212,11 @@ perl_construct(register PerlInterpreter *sv_interp) localpatches = local_patches; /* For possible -v */ #endif - PerlIO_init(); /* Hook to IO system */ + PerlIO_init(); /* Hook to IO system */ - fdpid = newAV(); /* for remembering popen pids by fd */ + fdpid = newAV(); /* for remembering popen pids by fd */ + modglobal = newHV(); /* pointers to per-interpreter module globals */ - init_stacks(ARGS); DEBUG( { New(51,debname,128,char); New(52,debdelim,128,char); @@ -353,6 +330,10 @@ perl_destruct(register PerlInterpreter *sv_interp) LEAVE; FREETMPS; +#ifdef MULTIPLICITY + --ninterps; +#endif + /* We must account for everything. */ /* Destroy the main CV and syntax tree */ @@ -361,6 +342,7 @@ perl_destruct(register PerlInterpreter *sv_interp) op_free(main_root); main_root = Nullop; } + curcop = &compiling; main_start = Nullop; SvREFCNT_dec(main_cv); main_cv = Nullcv; @@ -384,6 +366,12 @@ perl_destruct(register PerlInterpreter *sv_interp) SvREFCNT_dec(parsehook); parsehook = Nullsv; + /* call exit list functions */ + while (exitlistlen-- > 0) + exitlist[exitlistlen].fn(PERL_OBJECT_THIS_ exitlist[exitlistlen].ptr); + + Safefree(exitlist); + if (destruct_level == 0){ DEBUG_P(debprofdump()); @@ -421,12 +409,9 @@ perl_destruct(register PerlInterpreter *sv_interp) Safefree(inplace); inplace = Nullch; - Safefree(e_tmpname); - e_tmpname = Nullch; - - if (e_fp) { - PerlIO_close(e_fp); - e_fp = Nullfp; + if (e_script) { + SvREFCNT_dec(e_script); + e_script = Nullsv; } /* magical thingies */ @@ -464,10 +449,6 @@ perl_destruct(register PerlInterpreter *sv_interp) endav = Nullav; initav = Nullav; - /* temp stack during pp_sort() */ - SvREFCNT_dec(sortstack); - sortstack = Nullav; - /* shortcuts just get cleared */ envgv = Nullgv; siggv = Nullgv; @@ -477,6 +458,7 @@ perl_destruct(register PerlInterpreter *sv_interp) argvoutgv = Nullgv; stdingv = Nullgv; last_in_gv = Nullgv; + replgv = Nullgv; /* reset so print() ends up where we expect */ setdefout(Nullgv); @@ -551,8 +533,11 @@ perl_destruct(register PerlInterpreter *sv_interp) /* No SVs have survived, need to clean out */ linestr = NULL; pidstatus = Nullhv; - if (origfilename) - Safefree(origfilename); + Safefree(origfilename); + Safefree(archpat_auto); + Safefree(reg_start_tmp); + Safefree(HeKEY_hek(&hv_fetch_ent_mh)); + Safefree(op_mask); nuke_stacks(); hints = 0; /* Reset hints. Should hints be per-interpreter ? */ @@ -597,6 +582,19 @@ perl_free(PerlInterpreter *sv_interp) #endif } +void +#ifdef PERL_OBJECT +CPerlObj::perl_atexit(void (*fn) (CPerlObj*,void *), void *ptr) +#else +perl_atexit(void (*fn) (void *), void *ptr) +#endif +{ + Renew(exitlist, exitlistlen+1, PerlExitListEntry); + exitlist[exitlistlen].fn = fn; + exitlist[exitlistlen].ptr = ptr; + ++exitlistlen; +} + int #ifdef PERL_OBJECT CPerlObj::perl_parse(void (*xsinit) (CPerlObj*), int argc, char **argv, char **env) @@ -614,6 +612,7 @@ perl_parse(PerlInterpreter *sv_interp, void (*xsinit) (void), int argc, char **a AV* comppadlist; dJMPENV; int ret; + int fdscript = -1; #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW #ifdef IAMSUID @@ -638,7 +637,6 @@ setuid perl scripts securely.\n"); #ifndef VMS /* VMS doesn't have environ array */ origenviron = environ; #endif - e_tmpname = Nullch; if (do_undump) { @@ -702,6 +700,7 @@ setuid perl scripts securely.\n"); s = argv[0]+1; reswitch: switch (*s) { + case ' ': case '0': case 'F': case 'a': @@ -732,25 +731,21 @@ setuid perl scripts securely.\n"); case 'e': if (euid != uid || egid != gid) croak("No -e allowed in setuid scripts"); - if (!e_fp) { - e_tmpname = savepv(TMPPATH); - (void)PerlLIO_mktemp(e_tmpname); - if (!*e_tmpname) - croak("Can't mktemp()"); - e_fp = PerlIO_open(e_tmpname,"w"); - if (!e_fp) - croak("Cannot open temporary file"); + if (!e_script) { + e_script = newSVpv("",0); + filter_add(read_e_script, NULL); } if (*++s) - PerlIO_puts(e_fp,s); + sv_catpv(e_script, s); else if (argv[1]) { - PerlIO_puts(e_fp,argv[1]); + sv_catpv(e_script, argv[1]); argc--,argv++; } else croak("No code specified for -e"); - (void)PerlIO_putc(e_fp,'\n'); + sv_catpv(e_script, "\n"); break; + case 'I': /* -I handled both here and in moreswitches() */ forbid_setid("-I"); if (!*++s && (s=argv[1]) != Nullch) { @@ -885,16 +880,9 @@ print \" \\@INC:\\n @INC\\n\";"); if (!scriptname) scriptname = argv[0]; - if (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; + if (e_script) { argc++,argv--; - scriptname = e_tmpname; + scriptname = BIT_BUCKET; /* don't look for script or read stdin */ } else if (scriptname == Nullch) { #ifdef MSDOS @@ -906,9 +894,9 @@ print \" \\@INC:\\n @INC\\n\";"); init_perllib(); - open_script(scriptname,dosearch,sv); + open_script(scriptname,dosearch,sv,&fdscript); - validate_suid(validarg, scriptname); + validate_suid(validarg, scriptname,fdscript); if (doextract) find_beginning(); @@ -942,16 +930,15 @@ print \" \\@INC:\\n @INC\\n\";"); boot_core_UNIVERSAL(); if (xsinit) - (*xsinit)(THIS); /* in case linked C routines want magical variables */ + (*xsinit)(PERL_OBJECT_THIS); /* in case linked C routines want magical variables */ #if defined(VMS) || defined(WIN32) || defined(DJGPP) init_os_extras(); #endif -#if defined(DEBUGGING) && defined(USE_THREADS) && defined(__linux__) - DEBUG_L(PerlProc_signal(SIGSEGV, (void(*)(int))catch_sigsegv);); -#endif - init_predump_symbols(); + /* init_postdump_symbols not currently designed to be called */ + /* more than once (ENV isn't cleared first, for example) */ + /* But running with -u leaves %ENV & @ARGV undefined! XXX */ if (!do_undump) init_postdump_symbols(argc,argv,env); @@ -972,10 +959,9 @@ print \" \\@INC:\\n @INC\\n\";"); curcop->cop_line = 0; curstash = defstash; preprocess = FALSE; - if (e_tmpname) { - (void)UNLINK(e_tmpname); - Safefree(e_tmpname); - e_tmpname = Nullch; + if (e_script) { + SvREFCNT_dec(e_script); + e_script = Nullsv; } /* now that script is parsed, we can modify record separator */ @@ -1009,7 +995,7 @@ CPerlObj::perl_run(void) perl_run(PerlInterpreter *sv_interp) #endif { - dTHR; + dSP; I32 oldscope; dJMPENV; int ret; @@ -1047,10 +1033,7 @@ perl_run(PerlInterpreter *sv_interp) JMPENV_POP; return 1; } - if (curstack != mainstack) { - dSP; - SWITCHSTACK(curstack, mainstack); - } + POPSTACK_TO(mainstack); break; } @@ -1158,7 +1141,7 @@ perl_call_argv(char *sub_name, I32 flags, register char **argv) { dSP; - PUSHMARK(sp); + PUSHMARK(SP); if (argv) { while (*argv) { XPUSHs(sv_2mortal(newSVpv(*argv,0))); @@ -1189,6 +1172,8 @@ perl_call_method(char *methname, I32 flags) XPUSHs(sv_2mortal(newSVpv(methname,0))); PUTBACK; pp_method(ARGS); + if(op == &myop) + op = Nullop; return perl_call_sv(*stack_sp--, flags); } @@ -1198,9 +1183,8 @@ perl_call_sv(SV *sv, I32 flags) /* See G_* flags in cop.h */ { - dTHR; + dSP; LOGOP myop; /* fake syntax tree node */ - SV** sp = stack_sp; I32 oldmark; I32 retval; I32 oldscope; @@ -1234,7 +1218,8 @@ perl_call_sv(SV *sv, I32 flags) && (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)) + && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != debstash) + && !(flags & G_NODEBUG)) op->op_private |= OPpENTERSUB_DB; if (flags & G_EVAL) { @@ -1341,10 +1326,9 @@ perl_eval_sv(SV *sv, I32 flags) /* See G_* flags in cop.h */ { - dTHR; + dSP; UNOP myop; /* fake syntax tree node */ - SV** sp = stack_sp; - I32 oldmark = sp - stack_base; + I32 oldmark = SP - stack_base; I32 retval; I32 oldscope; dJMPENV; @@ -1431,7 +1415,7 @@ perl_eval_pv(char *p, I32 croak_on_error) dSP; SV* sv = newSVpv(p, 0); - PUSHMARK(sp); + PUSHMARK(SP); perl_eval_sv(sv, G_SCALAR); SvREFCNT_dec(sv); @@ -1493,7 +1477,7 @@ usage(char *name) /* XXX move this out into a module ? */ "-T turn on tainting checks", "-u dump core after parsing script", "-U allow unsafe operations", -"-v print version number and patchlevel of perl", +"-v print version number, patchlevel plus VERY IMPORTANT perl info", "-V[:variable] print perl configuration information", "-w TURN WARNINGS ON FOR COMPILATION OF YOUR SCRIPT. Recommended.", "-x[directory] strip off text before #!perl line and perhaps cd to directory", @@ -1586,8 +1570,11 @@ moreswitches(char *s) inplace = savepv(s+1); /*SUPPRESS 530*/ for (s = inplace; *s && !isSPACE(*s); s++) ; - if (*s) + if (*s) { *s++ = '\0'; + if (*s == '-') /* Additional switches on #! line. */ + s++; + } return s; case 'I': /* -I handled both here and in parse_perl() */ forbid_setid("-I"); @@ -1709,7 +1696,7 @@ moreswitches(char *s) #endif #ifdef DJGPP printf("djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n"); - printf("djgpp v2 port (perl5004) by Laszlo Molnar, 1997\n"); + printf("djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1998\n"); #endif #ifdef OS2 printf("\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n" @@ -1720,7 +1707,10 @@ moreswitches(char *s) #endif 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"); +GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n\ +Complete documentation for Perl, including FAQ lists, should be found on\n\ +this system using `man perl' or `perldoc perl'. If you have access to the\n\ +Internet, point your browser at http://www.perl.com/, the Perl Home Page.\n\n"); PerlProc_exit(0); case 'w': dowarn = TRUE; @@ -1756,6 +1746,7 @@ GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n") /* compliments of Tom Christiansen */ /* unexec() can be found in the Gnu emacs distribution */ +/* Known to work with -DUNEXEC and using unexelf.c from GNU emacs-20.2 */ void my_unexec(void) @@ -1763,18 +1754,16 @@ my_unexec(void) #ifdef UNEXEC SV* prog; SV* file; - int status; + int status = 1; extern int etext; - prog = newSVpv(BIN_EXP); + prog = newSVpv(BIN_EXP, 0); sv_catpv(prog, "/perl"); - file = newSVpv(origfilename); + file = newSVpv(origfilename, 0); sv_catpv(file, ".perldump"); - status = unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0); - if (status) - PerlIO_printf(PerlIO_stderr(), "unexec of %s into %s failed!\n", - SvPVX(prog), SvPVX(file)); + unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0); + /* unexec prints msg to stderr in case of failure */ PerlProc_exit(status); #else # ifdef VMS @@ -1786,6 +1775,72 @@ my_unexec(void) #endif } +/* initialize curinterp */ +STATIC void +init_interp(void) +{ + +#ifdef PERL_OBJECT /* XXX kludge */ +#define I_REINIT \ + STMT_START { \ + chopset = " \n-"; \ + copline = NOLINE; \ + curcop = &compiling; \ + curcopdb = NULL; \ + 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; \ + mess_sv = Nullsv; \ + splitstr = " "; \ + generation = 100; \ + exitlist = NULL; \ + exitlistlen = 0; \ + regindent = 0; \ + in_clean_objs = FALSE; \ + in_clean_all= FALSE; \ + profiledata = NULL; \ + rsfp = Nullfp; \ + rsfp_filters= Nullav; \ + } STMT_END + I_REINIT; +#else +# ifdef MULTIPLICITY +# define PERLVAR(var,type) +# define PERLVARI(var,type,init) curinterp->var = init; +# define PERLVARIC(var,type,init) curinterp->var = init; +# include "intrpvar.h" +# ifndef USE_THREADS +# include "thrdvar.h" +# endif +# undef PERLVAR +# undef PERLVARI +# undef PERLVARIC +# else +# define PERLVAR(var,type) +# define PERLVARI(var,type,init) var = init; +# define PERLVARIC(var,type,init) var = init; +# include "intrpvar.h" +# ifndef USE_THREADS +# include "thrdvar.h" +# endif +# undef PERLVAR +# undef PERLVARI +# undef PERLVARIC +# endif +#endif + +} + STATIC void init_main_stash(void) { @@ -1812,6 +1867,8 @@ init_main_stash(void) defgv = gv_fetchpv("_",TRUE, SVt_PVAV); errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV)); GvMULTI_on(errgv); + replgv = gv_fetchpv("\022", TRUE, SVt_PV); /* ^R */ + GvMULTI_on(replgv); (void)form("%240s",""); /* Preallocate temp - for immediate signals. */ sv_grow(ERRSV, 240); /* Preallocate - for immediate signals. */ sv_setpvn(ERRSV, "", 0); @@ -1823,230 +1880,31 @@ init_main_stash(void) sv_setpvn(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), "\n", 1); } -#ifdef CAN_PROTOTYPE STATIC void -open_script(char *scriptname, bool dosearch, SV *sv) -#else -STATIC void -open_script(scriptname,dosearch,sv) -char *scriptname; -bool dosearch; -SV *sv; -#endif +open_script(char *scriptname, bool dosearch, SV *sv, int *fdscript) { dTHR; - char *xfound = Nullch; - char *xfailed = Nullch; register char *s; - I32 len; - int retval; -#if defined(DOSISH) && !defined(OS2) && !defined(atarist) -# define SEARCH_EXTS ".bat", ".cmd", NULL -# define MAX_EXT_LEN 4 -#endif -#ifdef OS2 -# define SEARCH_EXTS ".cmd", ".btm", ".bat", ".pl", 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 = 0, i = 0; - char *curext = Nullch; -#else -# define MAX_EXT_LEN 0 -#endif - /* - * If dosearch is true and if scriptname does not contain path - * delimiters, search the PATH for scriptname. - * - * If SEARCH_EXTS is also defined, will look for each - * scriptname{SEARCH_EXTS} whenever scriptname is not found - * while searching the PATH. - * - * Assuming SEARCH_EXTS is C<".foo",".bar",NULL>, PATH search - * proceeds as follows: - * If DOSISH or VMSISH: - * + look for ./scriptname{,.foo,.bar} - * + search the PATH for scriptname{,.foo,.bar} - * - * If !DOSISH: - * + look *only* in the PATH for scriptname{,.foo,.bar} (note - * this will not look in '.' if it's not in the PATH) - */ - -#ifdef VMS -# ifdef ALWAYS_DEFTYPES - len = strlen(scriptname); - if (!(len == 1 && *scriptname == '-') && scriptname[len-1] != ':') { - int hasdir, idx = 0, deftypes = 1; - bool seen_dot = 1; - - hasdir = !dosearch || (strpbrk(scriptname,":[= sizeof tokenbuf) - continue; /* don't search dir with too-long name */ - strcat(tokenbuf, scriptname); -#else /* !VMS */ - -#ifdef DOSISH - if (strEQ(scriptname, "-")) - dosearch = 0; - if (dosearch) { /* Look in '.' first. */ - char *cur = scriptname; -#ifdef SEARCH_EXTS - if ((curext = strrchr(scriptname,'.'))) /* possible current ext */ - while (ext[i]) - if (strEQ(ext[i++],curext)) { - extidx = -1; /* already has an ext */ - break; - } - do { -#endif - DEBUG_p(PerlIO_printf(Perl_debug_log, - "Looking for %s\n",cur)); - if (PerlLIO_stat(cur,&statbuf) >= 0) { - dosearch = 0; - scriptname = cur; -#ifdef SEARCH_EXTS - break; -#endif - } -#ifdef SEARCH_EXTS - if (cur == scriptname) { - len = strlen(scriptname); - if (len+MAX_EXT_LEN+1 >= sizeof(tokenbuf)) - break; - cur = strcpy(tokenbuf, scriptname); - } - } while (extidx >= 0 && ext[extidx] /* try an extension? */ - && strcpy(tokenbuf+len, ext[extidx++])); -#endif - } -#endif - - if (dosearch && !strchr(scriptname, '/') -#ifdef DOSISH - && !strchr(scriptname, '\\') -#endif - && (s = PerlEnv_getenv("PATH"))) { - bool seen_dot = 0; - - bufend = s + strlen(s); - while (s < bufend) { -#if defined(atarist) || defined(DOSISH) - for (len = 0; *s -# ifdef atarist - && *s != ',' -# endif - && *s != ';'; len++, s++) { - if (len < sizeof tokenbuf) - tokenbuf[len] = *s; - } - if (len < sizeof tokenbuf) - tokenbuf[len] = '\0'; -#else /* ! (atarist || DOSISH) */ - s = delimcpy(tokenbuf, tokenbuf + sizeof tokenbuf, s, bufend, - ':', - &len); -#endif /* ! (atarist || DOSISH) */ - if (s < bufend) - s++; - 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] != '/' - && tokenbuf[len - 1] != '\\' -#endif - ) - tokenbuf[len++] = '/'; - if (len == 2 && tokenbuf[0] == '.') - seen_dot = 1; - (void)strcpy(tokenbuf + len, scriptname); -#endif /* !VMS */ - -#ifdef SEARCH_EXTS - len = strlen(tokenbuf); - if (extidx > 0) /* reset after previous loop */ - extidx = 0; - do { -#endif - DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tokenbuf)); - retval = PerlLIO_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) -#ifndef DOSISH - && cando(S_IXUSR,TRUE,&statbuf) -#endif - ) - { - xfound = tokenbuf; /* bingo! */ - break; - } - if (!xfailed) - xfailed = savepv(tokenbuf); - } -#ifndef DOSISH - if (!xfound && !seen_dot && !xfailed && (PerlLIO_stat(scriptname,&statbuf) < 0)) -#endif - seen_dot = 1; /* Disable message. */ - if (!xfound) - croak("Can't %s %s%s%s", - (xfailed ? "execute" : "find"), - (xfailed ? xfailed : scriptname), - (xfailed ? "" : " on PATH"), - (xfailed || seen_dot) ? "" : ", '.' not in PATH"); - if (xfailed) - Safefree(xfailed); - scriptname = xfound; - } + /* scriptname will be non-NULL if find_script() returns */ + scriptname = find_script(scriptname, dosearch, NULL, 1); if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) { char *s = scriptname + 8; - fdscript = atoi(s); + *fdscript = atoi(s); while (isDIGIT(*s)) s++; if (*s) scriptname = s + 1; } else - fdscript = -1; - origfilename = savepv(e_tmpname ? "-e" : scriptname); + *fdscript = -1; + origfilename = (e_script ? savepv("-e") : scriptname); curcop->cop_filegv = gv_fetchfile(origfilename); if (strEQ(origfilename,"-")) scriptname = ""; - if (fdscript >= 0) { - rsfp = PerlIO_fdopen(fdscript,PERL_SCRIPT_MODE); + if (*fdscript >= 0) { + rsfp = PerlIO_fdopen(*fdscript,PERL_SCRIPT_MODE); #if defined(HAS_FCNTL) && defined(F_SETFD) if (rsfp) fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */ @@ -2054,7 +1912,7 @@ SV *sv; } else if (preprocess) { char *cpp_cfg = CPPSTDIN; - SV *cpp = NEWSV(0,0); + SV *cpp = newSVpv("",0); SV *cmd = NEWSV(0,0); if (strEQ(cpp_cfg, "cppstdin")) @@ -2136,9 +1994,6 @@ sed %s -e \"/^[^#]/b\" \ fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */ #endif } - if (e_tmpname) { - e_fp = rsfp; - } if (!rsfp) { #ifdef DOSUID #ifndef IAMSUID /* in case script is not readable before setuid */ @@ -2156,7 +2011,7 @@ sed %s -e \"/^[^#]/b\" \ } STATIC void -validate_suid(char *validarg, char *scriptname) +validate_suid(char *validarg, char *scriptname, int fdscript) { int which; @@ -2424,6 +2279,7 @@ find_beginning(void) } } + STATIC void init_ids(void) { @@ -2466,71 +2322,70 @@ init_debugger(void) curstash = defstash; } +#ifndef STRESS_REALLOC +#define REASONABLE(size) (size) +#else +#define REASONABLE(size) (1) /* unreasonable */ +#endif + void init_stacks(ARGSproto) { - curstack = newAV(); + /* start with 128-item stack and 8K cxstack */ + curstackinfo = new_stackinfo(REASONABLE(128), + REASONABLE(8192/sizeof(PERL_CONTEXT) - 1)); + curstackinfo->si_type = SI_MAIN; + curstack = curstackinfo->si_stack; 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; - - cxstack_max = 8192 / sizeof(PERL_CONTEXT) - 2; /* Use most of 8K. */ - New(50,cxstack,cxstack_max + 1,PERL_CONTEXT); - cxstack_ix = -1; + stack_max = stack_base + AvMAX(curstack); - New(50,tmps_stack,128,SV*); + New(50,tmps_stack,REASONABLE(128),SV*); tmps_floor = -1; tmps_ix = -1; - tmps_max = 128; + tmps_max = REASONABLE(128); - /* - * The following stacks almost certainly should be per-interpreter, - * but for now they're not. XXX - */ + New(54,markstack,REASONABLE(32),I32); + markstack_ptr = markstack; + markstack_max = markstack + REASONABLE(32); - if (markstack) { - markstack_ptr = markstack; - } else { - New(54,markstack,64,I32); - markstack_ptr = markstack; - markstack_max = markstack + 64; - } + SET_MARKBASE; - if (scopestack) { - scopestack_ix = 0; - } else { - New(54,scopestack,32,I32); - scopestack_ix = 0; - scopestack_max = 32; - } + New(54,scopestack,REASONABLE(32),I32); + scopestack_ix = 0; + scopestack_max = REASONABLE(32); - if (savestack) { - savestack_ix = 0; - } else { - New(54,savestack,128,ANY); - savestack_ix = 0; - savestack_max = 128; - } + New(54,savestack,REASONABLE(128),ANY); + savestack_ix = 0; + savestack_max = REASONABLE(128); - if (retstack) { - retstack_ix = 0; - } else { - New(54,retstack,16,OP*); - retstack_ix = 0; - retstack_max = 16; - } + New(54,retstack,REASONABLE(16),OP*); + retstack_ix = 0; + retstack_max = REASONABLE(16); } +#undef REASONABLE + STATIC void nuke_stacks(void) { dTHR; - Safefree(cxstack); + while (curstackinfo->si_next) + curstackinfo = curstackinfo->si_next; + while (curstackinfo) { + PERL_SI *p = curstackinfo->si_prev; + /* curstackinfo->si_stack got nuked by sv_free_arenas() */ + Safefree(curstackinfo->si_cxstack); + Safefree(curstackinfo); + curstackinfo = p; + } Safefree(tmps_stack); + Safefree(markstack); + Safefree(scopestack); + Safefree(savestack); + Safefree(retstack); DEBUG( { Safefree(debname); Safefree(debdelim); @@ -2657,7 +2512,7 @@ init_postdump_symbols(register int argc, register char **argv, register char **e if (!(s = strchr(*env,'='))) continue; *s++ = '\0'; -#if defined(WIN32) || defined(MSDOS) +#if defined(MSDOS) (void)strupr(*env); #endif sv = newSVpv(s--,0); @@ -2704,10 +2559,10 @@ init_perllib(void) } /* Use the ~-expanded versions of APPLLIB (undocumented), - ARCHLIB PRIVLIB SITEARCH SITELIB and OLDARCHLIB + ARCHLIB PRIVLIB SITEARCH and SITELIB */ #ifdef APPLLIB_EXP - incpush(APPLLIB_EXP, FALSE); + incpush(APPLLIB_EXP, TRUE); #endif #ifdef ARCHLIB_EXP @@ -2716,18 +2571,22 @@ init_perllib(void) #ifndef PRIVLIB_EXP #define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl" #endif +#if defined(WIN32) + incpush(PRIVLIB_EXP, TRUE); +#else incpush(PRIVLIB_EXP, FALSE); +#endif #ifdef SITEARCH_EXP incpush(SITEARCH_EXP, FALSE); #endif #ifdef SITELIB_EXP +#if defined(WIN32) + incpush(SITELIB_EXP, TRUE); +#else incpush(SITELIB_EXP, FALSE); #endif -#ifdef OLDARCHLIB_EXP /* 5.00[01] compatibility */ - incpush(OLDARCHLIB_EXP, FALSE); #endif - if (!tainting) incpush(".", FALSE); } @@ -2754,7 +2613,7 @@ incpush(char *p, int addsubdirs) return; if (addsubdirs) { - subdir = NEWSV(55,0); + subdir = sv_newmortal(); if (!archpat_auto) { STRLEN len = (sizeof(ARCHNAME) + strlen(patchlevel) + sizeof("//auto")); @@ -2830,8 +2689,6 @@ incpush(char *p, int addsubdirs) /* finally push this lib directory on the end of @INC */ av_push(GvAVn(incgv), libdir); } - - SvREFCNT_dec(subdir); } #ifdef USE_THREADS @@ -2861,7 +2718,6 @@ init_main_thread() SvLEN_set(thrsv, sizeof(thr)); *SvEND(thrsv) = '\0'; /* in the trailing_nul field */ thr->oursv = thrsv; - curcop = &compiling; chopset = " \n-"; MUTEX_LOCK(&threads_mutex); @@ -3009,10 +2865,16 @@ my_failure_exit(void) STATUS_NATIVE_SET(vaxc$errno); } #else + int exitstatus; if (errno & 255) STATUS_POSIX_SET(errno); - else if (STATUS_POSIX == 0) - STATUS_POSIX_SET(255); + else { + exitstatus = STATUS_POSIX >> 8; + if (exitstatus & 255) + STATUS_POSIX_SET(exitstatus); + else + STATUS_POSIX_SET(255); + } #endif my_exit_jump(); } @@ -3020,21 +2882,17 @@ my_failure_exit(void) STATIC void my_exit_jump(void) { - dTHR; + dSP; register PERL_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 (e_script) { + SvREFCNT_dec(e_script); + e_script = Nullsv; } + POPSTACK_TO(mainstack); if (cxstack_ix >= 0) { if (cxstack_ix > 0) dounwind(0); @@ -3046,4 +2904,24 @@ my_exit_jump(void) } +#include "XSUB.h" + +static I32 +#ifdef PERL_OBJECT +read_e_script(CPerlObj *pPerl, int idx, SV *buf_sv, int maxlen) +#else +read_e_script(int idx, SV *buf_sv, int maxlen) +#endif +{ + char *p, *nl; + p = SvPVX(e_script); + nl = strchr(p, '\n'); + nl = (nl) ? nl+1 : SvEND(e_script); + if (nl-p == 0) + return 0; + sv_catpvn(buf_sv, p, nl-p); + sv_chop(e_script, nl); + return 1; +} +