X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/4b026b9ec580787cd32d43ab9381ecc2040179be..6c72d195a44add86e50e54c2c80795702dc3fc9f:/perl.c diff --git a/perl.c b/perl.c index 2e2435e..14357b7 100644 --- a/perl.c +++ b/perl.c @@ -1,6 +1,6 @@ /* perl.c * - * Copyright (c) 1987-1997 Larry Wall + * Copyright (c) 1987-1998 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. @@ -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,64 +45,42 @@ 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 - +#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)); static void init_main_stash _((void)); #ifdef USE_THREADS -static struct thread * init_main_thread _((void)); +static struct perl_thread * init_main_thread _((void)); #endif /* USE_THREADS */ static void init_perllib _((void)); 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*)); - -static int fdscript = -1; +static void validate_suid _((char *, char*, int)); +static I32 read_e_script _((int idx, SV *buf_sv, int maxlen)); +#endif -#if defined(DEBUGGING) && defined(USE_THREADS) && defined(__linux__) -#include -static void -catch_sigsegv(int signo, struct sigcontext_struct sc) +#ifdef PERL_OBJECT +CPerlObj* perl_alloc(IPerlMem* ipM, IPerlEnv* ipE, IPerlStdIO* ipStd, + IPerlLIO* ipLIO, IPerlDir* ipD, IPerlSock* ipS, IPerlProc* ipP) { - 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); -} -#endif + CPerlObj* pPerl = new(ipM) CPerlObj(ipM, ipE, ipStd, ipLIO, ipD, ipS, ipP); + if(pPerl != NULL) + pPerl->Init(); + return pPerl; +} +#else PerlInterpreter * perl_alloc(void) { @@ -105,21 +90,29 @@ perl_alloc(void) New(53, sv_interp, 1, PerlInterpreter); return sv_interp; } +#endif /* PERL_OBJECT */ void +#ifdef PERL_OBJECT +CPerlObj::perl_construct(void) +#else perl_construct(register PerlInterpreter *sv_interp) +#endif { #ifdef USE_THREADS int i; #ifndef FAKE_THREADS - struct thread *thr; + struct perl_thread *thr; #endif /* FAKE_THREADS */ #endif /* USE_THREADS */ +#ifndef PERL_OBJECT if (!(curinterp = sv_interp)) return; +#endif #ifdef MULTIPLICITY + ++ninterps; Zero(sv_interp, 1, PerlInterpreter); #endif @@ -134,7 +127,6 @@ perl_construct(register PerlInterpreter *sv_interp) if (pthread_key_create(&thr_key, 0)) croak("panic: pthread_key_create"); #endif - MUTEX_INIT(&malloc_mutex); MUTEX_INIT(&sv_mutex); /* * Safe to use basic SV functions from now on (though @@ -144,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)) { @@ -166,7 +161,12 @@ perl_construct(register PerlInterpreter *sv_interp) nrs = newSVpv("\n", 1); rs = SvREFCNT_inc(nrs); +#ifdef PERL_OBJECT + /* TODO: */ + /* sighandlerp = sighandler; */ +#else sighandlerp = sighandler; +#endif pidstatus = newHV(); #ifdef MSDOS @@ -180,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(); @@ -211,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); @@ -225,7 +226,11 @@ perl_construct(register PerlInterpreter *sv_interp) } void +#ifdef PERL_OBJECT +CPerlObj::perl_destruct(void) +#else perl_destruct(register PerlInterpreter *sv_interp) +#endif { dTHR; int destruct_level; /* 0=none, 1=full, 2=full with checks */ @@ -235,8 +240,10 @@ perl_destruct(register PerlInterpreter *sv_interp) Thread t; #endif /* USE_THREADS */ +#ifndef PERL_OBJECT if (!(curinterp = sv_interp)) return; +#endif #ifdef USE_THREADS #ifndef FAKE_THREADS @@ -312,7 +319,7 @@ perl_destruct(register PerlInterpreter *sv_interp) #ifdef DEBUGGING { char *s; - if (s = getenv("PERL_DESTRUCT_LEVEL")) { + if (s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL")) { int i = atoi(s); if (destruct_level < i) destruct_level = i; @@ -323,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 */ @@ -331,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; @@ -354,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()); @@ -391,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 */ @@ -418,36 +433,6 @@ perl_destruct(register PerlInterpreter *sv_interp) /* 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; @@ -464,19 +449,17 @@ 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; incgv = Nullgv; + hintgv = Nullgv; errgv = Nullgv; argvgv = Nullgv; argvoutgv = Nullgv; stdingv = Nullgv; last_in_gv = Nullgv; + replgv = Nullgv; /* reset so print() ends up where we expect */ setdefout(Nullgv); @@ -551,15 +534,17 @@ 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 ? */ DEBUG_P(debprofdump()); #ifdef USE_THREADS MUTEX_DESTROY(&sv_mutex); - MUTEX_DESTROY(&malloc_mutex); MUTEX_DESTROY(&eval_mutex); COND_DESTROY(&eval_cond); @@ -583,15 +568,40 @@ perl_destruct(register PerlInterpreter *sv_interp) } void +#ifdef PERL_OBJECT +CPerlObj::perl_free(void) +#else perl_free(PerlInterpreter *sv_interp) +#endif { +#ifdef PERL_OBJECT + Safefree(this); +#else if (!(curinterp = sv_interp)) return; Safefree(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) +#else perl_parse(PerlInterpreter *sv_interp, void (*xsinit) (void), int argc, char **argv, char **env) +#endif { dTHR; register SV *sv; @@ -603,6 +613,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 @@ -612,8 +623,10 @@ setuid perl scripts securely.\n"); #endif #endif +#ifndef PERL_OBJECT if (!(curinterp = sv_interp)) return 255; +#endif #if defined(NeXT) && defined(__DYNAMIC__) _dyld_lookup_and_bind @@ -625,7 +638,6 @@ setuid perl scripts securely.\n"); #ifndef VMS /* VMS doesn't have environ array */ origenviron = environ; #endif - e_tmpname = Nullch; if (do_undump) { @@ -689,6 +701,7 @@ setuid perl scripts securely.\n"); s = argv[0]+1; reswitch: switch (*s) { + case ' ': case '0': case 'F': case 'a': @@ -719,25 +732,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)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) { @@ -853,7 +862,7 @@ print \" \\@INC:\\n @INC\\n\";"); } switch_end: - if (!tainting && (s = getenv("PERL5OPT"))) { + if (!tainting && (s = PerlEnv_getenv("PERL5OPT"))) { while (s && *s) { while (isSPACE(*s)) s++; @@ -872,20 +881,13 @@ 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 - if ( isatty(PerlIO_fileno(PerlIO_stdin())) ) + if ( PerlLIO_isatty(PerlIO_fileno(PerlIO_stdin())) ) moreswitches("h"); #endif scriptname = "-"; @@ -893,9 +895,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(); @@ -927,17 +929,17 @@ print \" \\@INC:\\n @INC\\n\";"); CvPADLIST(compcv) = comppadlist; boot_core_UNIVERSAL(); + if (xsinit) - (*xsinit)(); /* in case linked C routines want magical variables */ -#if defined(VMS) || defined(WIN32) + (*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(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); @@ -945,6 +947,7 @@ print \" \\@INC:\\n @INC\\n\";"); /* now parse the script */ + SETERRNO(0,SS$_NORMAL); error_count = 0; if (yyparse() || error_count) { if (minus_c) @@ -957,20 +960,15 @@ 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 */ SvREFCNT_dec(rs); rs = SvREFCNT_inc(nrs); -#ifdef USE_THREADS - sv_setsv(*av_fetch(thr->magicals, find_thread_magical("/"), FALSE), rs); -#else - sv_setsv(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), rs); -#endif /* USE_THREADS */ + sv_setsv(perl_get_sv("/", TRUE), rs); if (do_undump) my_unexec(); @@ -981,7 +979,7 @@ print \" \\@INC:\\n @INC\\n\";"); FREETMPS; #ifdef MYMALLOC - if ((s=getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2) + if ((s=PerlEnv_getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2) dump_mstats("after compilation:"); #endif @@ -992,15 +990,21 @@ print \" \\@INC:\\n @INC\\n\";"); } int +#ifdef PERL_OBJECT +CPerlObj::perl_run(void) +#else perl_run(PerlInterpreter *sv_interp) +#endif { - dTHR; + dSP; I32 oldscope; dJMPENV; int ret; +#ifndef PERL_OBJECT if (!(curinterp = sv_interp)) return 255; +#endif oldscope = scopestack_ix; @@ -1018,7 +1022,7 @@ perl_run(PerlInterpreter *sv_interp) if (endav) call_list(oldscope, endav); #ifdef MYMALLOC - if (getenv("PERL_DEBUG_MSTATS")) + if (PerlEnv_getenv("PERL_DEBUG_MSTATS")) dump_mstats("after execution: "); #endif JMPENV_POP; @@ -1030,10 +1034,7 @@ perl_run(PerlInterpreter *sv_interp) JMPENV_POP; return 1; } - if (curstack != mainstack) { - dSP; - SWITCHSTACK(curstack, mainstack); - } + POPSTACK_TO(mainstack); break; } @@ -1063,12 +1064,12 @@ perl_run(PerlInterpreter *sv_interp) if (restartop) { op = restartop; restartop = 0; - runops(); + CALLRUNOPS(); } else if (main_start) { CvDEPTH(main_cv) = 1; op = main_start; - runops(); + CALLRUNOPS(); } my_exit(0); @@ -1082,10 +1083,10 @@ perl_get_sv(char *name, I32 create) GV *gv; #ifdef USE_THREADS if (name[1] == '\0' && !isALPHA(name[0])) { - PADOFFSET tmp = find_thread_magical(name); + PADOFFSET tmp = find_threadsv(name); if (tmp != NOT_IN_PAD) { dTHR; - return *av_fetch(thr->magicals, tmp, FALSE); + return THREADSV(tmp); } } #endif /* USE_THREADS */ @@ -1134,14 +1135,14 @@ perl_get_cv(char *name, I32 create) /* Be sure to refetch the stack pointer after calling these routines. */ I32 -perl_call_argv(char *subname, I32 flags, register char **argv) +perl_call_argv(char *sub_name, I32 flags, register char **argv) /* See G_* flags in cop.h */ /* null terminated arg list */ { dSP; - PUSHMARK(sp); + PUSHMARK(SP); if (argv) { while (*argv) { XPUSHs(sv_2mortal(newSVpv(*argv,0))); @@ -1149,15 +1150,15 @@ perl_call_argv(char *subname, I32 flags, register char **argv) } PUTBACK; } - return perl_call_pv(subname, flags); + return perl_call_pv(sub_name, flags); } I32 -perl_call_pv(char *subname, I32 flags) +perl_call_pv(char *sub_name, I32 flags) /* name of the subroutine */ /* See G_* flags in cop.h */ { - return perl_call_sv((SV*)perl_get_cv(subname, TRUE), flags); + return perl_call_sv((SV*)perl_get_cv(sub_name, TRUE), flags); } I32 @@ -1172,6 +1173,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); } @@ -1181,13 +1184,11 @@ 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; - static CV *DBcv; bool oldcatch = CATCH_GET; dJMPENV; int ret; @@ -1218,7 +1219,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) { @@ -1226,7 +1228,7 @@ perl_call_sv(SV *sv, I32 flags) markstack_ptr--; /* we're trying to emulate pp_entertry() here */ { - register CONTEXT *cx; + register PERL_CONTEXT *cx; I32 gimme = GIMME_V; ENTER; @@ -1283,7 +1285,7 @@ perl_call_sv(SV *sv, I32 flags) if (op == (OP*)&myop) op = pp_entersub(ARGS); if (op) - runops(); + CALLRUNOPS(); retval = stack_sp - (stack_base + oldmark); if ((flags & G_EVAL) && !(flags & G_KEEPERR)) sv_setpv(ERRSV,""); @@ -1294,7 +1296,7 @@ perl_call_sv(SV *sv, I32 flags) SV **newsp; PMOP *newpm; I32 gimme; - register CONTEXT *cx; + register PERL_CONTEXT *cx; I32 optype; POPBLOCK(cx,newpm); @@ -1325,10 +1327,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; @@ -1392,7 +1393,7 @@ perl_eval_sv(SV *sv, I32 flags) if (op == (OP*)&myop) op = pp_entereval(ARGS); if (op) - runops(); + CALLRUNOPS(); retval = stack_sp - (stack_base + oldmark); if (!(flags & G_KEEPERR)) sv_setpv(ERRSV,""); @@ -1415,7 +1416,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); @@ -1434,11 +1435,17 @@ perl_eval_pv(char *p, I32 croak_on_error) void perl_require_pv(char *pv) { - SV* sv = sv_newmortal(); + SV* sv; + dSP; + PUSHSTACKi(SI_REQUIRE); + PUTBACK; + sv = sv_newmortal(); sv_setpv(sv, "require '"); sv_catpv(sv, pv); sv_catpv(sv, "'"); perl_eval_sv(sv, G_DISCARD); + SPAGAIN; + POPSTACK; } void @@ -1450,14 +1457,14 @@ magicname(char *sym, char *name, I32 namlen) sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen); } -static void +STATIC void usage(char *name) /* XXX move this out into a module ? */ { /* This message really ought to be max 23 lines. * Removed -h because the user already knows that opton. Others? */ - static char *usage[] = { + static char *usage_msg[] = { "-0[octal] specify record separator (\\0, if no argument)", "-a autosplit mode with -n or -p (splits $_ into @F)", "-c check syntax only (runs BEGIN and END blocks)", @@ -1477,14 +1484,14 @@ 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", "\n", NULL }; - char **p = usage; + char **p = usage_msg; printf("\nUsage: %s [switches] [--] [programfile] [arguments]", name); while (*p) @@ -1563,15 +1570,18 @@ moreswitches(char *s) return s; case 'h': usage(origargv[0]); - exit(0); + PerlProc_exit(0); case 'i': if (inplace) Safefree(inplace); 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"); @@ -1687,24 +1697,28 @@ moreswitches(char *s) LOCAL_PATCH_COUNT, (LOCAL_PATCH_COUNT!=1) ? "es" : ""); #endif - printf("\n\nCopyright 1987-1997, Larry Wall\n"); + printf("\n\nCopyright 1987-1998, Larry Wall\n"); #ifdef MSDOS printf("\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n"); #endif #ifdef DJGPP printf("djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\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" - "Version 5 port Copyright (c) 1994-1997, Andreas Kaiser, Ilya Zakharevich\n"); + "Version 5 port Copyright (c) 1994-1998, Andreas Kaiser, Ilya Zakharevich\n"); #endif #ifdef atarist printf("atariST series port, ++jrb bammi@cadence.com\n"); #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"); - exit(0); +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; s++; @@ -1716,6 +1730,9 @@ GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n") break; case '-': case 0: +#ifdef WIN32 + case '\r': +#endif case '\n': case '\t': break; @@ -1736,6 +1753,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) @@ -1743,19 +1761,17 @@ 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)); - exit(status); + unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0); + /* unexec prints msg to stderr in case of failure */ + PerlProc_exit(status); #else # ifdef VMS # include @@ -1766,7 +1782,73 @@ my_unexec(void) #endif } -static void +/* 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) { dTHR; @@ -1789,9 +1871,13 @@ init_main_stash(void) HvNAME(defstash) = savepv("main"); incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV))); GvMULTI_on(incgv); + hintgv = gv_fetchpv("\010",TRUE, SVt_PV); /* ^H */ + GvMULTI_on(hintgv); 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); @@ -1803,221 +1889,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 +STATIC void +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: - * + 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 - if (dosearch) { - int hasdir, idx = 0, deftypes = 1; - bool seen_dot = 1; - - hasdir = (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 (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 = 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 = 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 && (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,"r"); + 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 */ @@ -2025,7 +1921,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")) @@ -2084,15 +1980,15 @@ sed %s -e \"/^[^#]/b\" \ #ifdef HAS_SETRESUID (void)setresuid((Uid_t)-1, uid, (Uid_t)-1); #else - setuid(uid); + PerlProc_setuid(uid); #endif #endif #endif - if (geteuid() != uid) + if (PerlProc_geteuid() != uid) croak("Can't do seteuid!\n"); } #endif /* IAMSUID */ - rsfp = my_popen(SvPVX(cmd), "r"); + rsfp = PerlProc_popen(SvPVX(cmd), "r"); SvREFCNT_dec(cmd); SvREFCNT_dec(cpp); } @@ -2101,22 +1997,19 @@ sed %s -e \"/^[^#]/b\" \ rsfp = PerlIO_stdin(); } else { - rsfp = PerlIO_open(scriptname,"r"); + rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE); #if defined(HAS_FCNTL) && defined(F_SETFD) if (rsfp) 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 */ - if (euid && Stat(SvPVX(GvSV(curcop->cop_filegv)),&statbuf) >= 0 && + if (euid && PerlLIO_stat(SvPVX(GvSV(curcop->cop_filegv)),&statbuf) >= 0 && statbuf.st_mode & (S_ISUID|S_ISGID)) { /* try again */ - execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv); + PerlProc_execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv); croak("Can't do setuid\n"); } #endif @@ -2126,8 +2019,8 @@ sed %s -e \"/^[^#]/b\" \ } } -static void -validate_suid(char *validarg, char *scriptname) +STATIC void +validate_suid(char *validarg, char *scriptname, int fdscript) { int which; @@ -2155,7 +2048,7 @@ validate_suid(char *validarg, char *scriptname) dTHR; char *s, *s2; - if (Fstat(PerlIO_fileno(rsfp),&statbuf) < 0) /* normal stat is insecure */ + if (PerlLIO_fstat(PerlIO_fileno(rsfp),&statbuf) < 0) /* normal stat is insecure */ croak("Can't stat script \"%s\"",origfilename); if (fdscript < 0 && statbuf.st_mode & (S_ISUID|S_ISGID)) { I32 len; @@ -2170,7 +2063,7 @@ validate_suid(char *validarg, char *scriptname) * But I don't think it's too important. The manual lies when * it says access() is useful in setuid programs. */ - if (access(SvPVX(GvSV(curcop->cop_filegv)),1)) /*double check*/ + if (PerlLIO_access(SvPVX(GvSV(curcop->cop_filegv)),1)) /*double check*/ croak("Permission denied"); #else /* If we can swap euid and uid, then we can determine access rights @@ -2189,14 +2082,14 @@ validate_suid(char *validarg, char *scriptname) setresuid(euid,uid,(Uid_t)-1) < 0 # endif #endif - || getuid() != euid || geteuid() != uid) + || PerlProc_getuid() != euid || PerlProc_geteuid() != uid) croak("Can't swap uid and euid"); /* really paranoid */ - if (Stat(SvPVX(GvSV(curcop->cop_filegv)),&tmpstatbuf) < 0) + if (PerlLIO_stat(SvPVX(GvSV(curcop->cop_filegv)),&tmpstatbuf) < 0) croak("Permission denied"); /* testing full pathname here */ if (tmpstatbuf.st_dev != statbuf.st_dev || tmpstatbuf.st_ino != statbuf.st_ino) { (void)PerlIO_close(rsfp); - if (rsfp = my_popen("/bin/mail root","w")) { /* heh, heh */ + if (rsfp = PerlProc_popen("/bin/mail root","w")) { /* heh, heh */ PerlIO_printf(rsfp, "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", @@ -2204,7 +2097,7 @@ validate_suid(char *validarg, char *scriptname) (long)statbuf.st_dev, (long)statbuf.st_ino, SvPVX(GvSV(curcop->cop_filegv)), (long)statbuf.st_uid, (long)statbuf.st_gid); - (void)my_pclose(rsfp); + (void)PerlProc_pclose(rsfp); } croak("Permission denied\n"); } @@ -2216,7 +2109,7 @@ validate_suid(char *validarg, char *scriptname) setresuid(uid,euid,(Uid_t)-1) < 0 # endif #endif - || getuid() != uid || geteuid() != euid) + || PerlProc_getuid() != uid || PerlProc_geteuid() != euid) croak("Can't reswap uid and euid"); if (!cando(S_IXUSR,FALSE,&statbuf)) /* can real uid exec? */ croak("Permission denied\n"); @@ -2263,7 +2156,7 @@ FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n"); (void)PerlIO_close(rsfp); #ifndef IAMSUID /* try again */ - execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv); + PerlProc_execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv); #endif croak("Can't do setuid\n"); } @@ -2278,11 +2171,11 @@ FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n"); #ifdef HAS_SETRESGID (void)setresgid((Gid_t)-1,statbuf.st_gid,(Gid_t)-1); #else - setgid(statbuf.st_gid); + PerlProc_setgid(statbuf.st_gid); #endif #endif #endif - if (getegid() != statbuf.st_gid) + if (PerlProc_getegid() != statbuf.st_gid) croak("Can't do setegid!\n"); } if (statbuf.st_mode & S_ISUID) { @@ -2296,11 +2189,11 @@ FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n"); #ifdef HAS_SETRESUID (void)setresuid((Uid_t)-1,statbuf.st_uid,(Uid_t)-1); #else - setuid(statbuf.st_uid); + PerlProc_setuid(statbuf.st_uid); #endif #endif #endif - if (geteuid() != statbuf.st_uid) + if (PerlProc_geteuid() != statbuf.st_uid) croak("Can't do seteuid!\n"); } else if (uid) { /* oops, mustn't run as root */ @@ -2313,11 +2206,11 @@ FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n"); #ifdef HAS_SETRESUID (void)setresuid((Uid_t)-1,(Uid_t)uid,(Uid_t)-1); #else - setuid((Uid_t)uid); + PerlProc_setuid((Uid_t)uid); #endif #endif #endif - if (geteuid() != uid) + if (PerlProc_geteuid() != uid) croak("Can't do seteuid!\n"); } init_ids(); @@ -2336,7 +2229,7 @@ FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n"); /* exec the real perl, substituting fd script for scriptname. */ /* (We pass script name as "subdir" of fd, which perl will grok.) */ PerlIO_rewind(rsfp); - lseek(PerlIO_fileno(rsfp),(Off_t)0,0); /* just in case rewind didn't */ + PerlLIO_lseek(PerlIO_fileno(rsfp),(Off_t)0,0); /* just in case rewind didn't */ for (which = 1; origargv[which] && origargv[which] != scriptname; which++) ; if (!origargv[which]) croak("Permission denied"); @@ -2345,14 +2238,14 @@ FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n"); #if defined(HAS_FCNTL) && defined(F_SETFD) fcntl(PerlIO_fileno(rsfp),F_SETFD,0); /* ensure no close-on-exec */ #endif - execv(form("%s/perl%s", BIN_EXP, patchlevel), origargv); /* try again */ + PerlProc_execv(form("%s/perl%s", BIN_EXP, patchlevel), origargv); /* try again */ croak("Can't do setuid\n"); #endif /* IAMSUID */ #else /* !DOSUID */ if (euid != uid || egid != gid) { /* (suidperl doesn't exist, in fact) */ #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW dTHR; - Fstat(PerlIO_fileno(rsfp),&statbuf); /* may be either wrapped or real suid */ + PerlLIO_fstat(PerlIO_fileno(rsfp),&statbuf); /* may be either wrapped or real suid */ if ((euid != uid && euid == statbuf.st_uid && statbuf.st_mode & S_ISUID) || (egid != gid && egid == statbuf.st_gid && statbuf.st_mode & S_ISGID) @@ -2366,7 +2259,7 @@ FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n"); #endif /* DOSUID */ } -static void +STATIC void find_beginning(void) { register char *s, *s2; @@ -2389,19 +2282,20 @@ find_beginning(void) /*SUPPRESS 530*/ while (s = moreswitches(s)) ; } - if (cddir && chdir(cddir) < 0) + if (cddir && PerlDir_chdir(cddir) < 0) croak("Can't chdir to %s",cddir); } } } -static void + +STATIC void init_ids(void) { - uid = (int)getuid(); - euid = (int)geteuid(); - gid = (int)getgid(); - egid = (int)getegid(); + uid = (int)PerlProc_getuid(); + euid = (int)PerlProc_geteuid(); + gid = (int)PerlProc_getgid(); + egid = (int)PerlProc_getegid(); #ifdef VMS uid |= gid << 16; euid |= egid << 16; @@ -2409,7 +2303,7 @@ init_ids(void) tainting |= (uid && (euid != uid || egid != gid)); } -static void +STATIC void forbid_setid(char *s) { if (euid != uid) @@ -2418,7 +2312,7 @@ forbid_setid(char *s) croak("No %s allowed while running setgid", s); } -static void +STATIC void init_debugger(void) { dTHR; @@ -2437,82 +2331,86 @@ 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(CONTEXT) - 2; /* Use most of 8K. */ - New(50,cxstack,cxstack_max + 1,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); } -static void +#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); } ) } +#ifndef PERL_OBJECT static PerlIO *tmpfp; /* moved outside init_lexer() because of UNICOS bug */ +#endif -static void +STATIC void init_lexer(void) { +#ifdef PERL_OBJECT + PerlIO *tmpfp; +#endif tmpfp = rsfp; rsfp = Nullfp; lex_start(linestr); @@ -2520,19 +2418,14 @@ init_lexer(void) subname = newSVpv("main",4); } -static void +STATIC void init_predump_symbols(void) { dTHR; GV *tmpgv; GV *othergv; -#ifdef USE_THREADS - sv_setpvn(*av_fetch(thr->magicals,find_thread_magical("\""),FALSE)," ", 1); -#else - sv_setpvn(GvSV(gv_fetchpv("\"", TRUE, SVt_PV)), " ", 1); -#endif /* USE_THREADS */ - + sv_setpvn(perl_get_sv("\"", TRUE), " ", 1); stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO); GvMULTI_on(stdingv); IoIFP(GvIOp(stdingv)) = PerlIO_stdin(); @@ -2561,7 +2454,7 @@ init_predump_symbols(void) osname = savepv(OSNAME); } -static void +STATIC void init_postdump_symbols(register int argc, register char **argv, register char **env) { dTHR; @@ -2628,7 +2521,7 @@ init_postdump_symbols(register int argc, register char **argv, register char **e if (!(s = strchr(*env,'='))) continue; *s++ = '\0'; -#ifdef WIN32 +#if defined(MSDOS) (void)strupr(*env); #endif sv = newSVpv(s--,0); @@ -2636,7 +2529,7 @@ init_postdump_symbols(register int argc, register char **argv, register char **e *s = '='; #if defined(__BORLANDC__) && defined(USE_WIN32_RTL_ENV) /* Sins of the RTL. See note in my_setenv(). */ - (void)putenv(savepv(*env)); + (void)PerlEnv_putenv(savepv(*env)); #endif } #endif @@ -2649,17 +2542,17 @@ init_postdump_symbols(register int argc, register char **argv, register char **e sv_setiv(GvSV(tmpgv), (IV)getpid()); } -static void +STATIC void init_perllib(void) { char *s; if (!tainting) { #ifndef VMS - s = getenv("PERL5LIB"); + s = PerlEnv_getenv("PERL5LIB"); if (s) incpush(s, TRUE); else - incpush(getenv("PERLLIB"), FALSE); + incpush(PerlEnv_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 @@ -2675,10 +2568,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 @@ -2687,18 +2580,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); } @@ -2716,17 +2613,16 @@ init_perllib(void) # define PERLLIB_MANGLE(s,n) (s) #endif -static void +STATIC void incpush(char *p, int addsubdirs) { SV *subdir = Nullsv; - static char *archpat_auto; if (!p) return; if (addsubdirs) { - subdir = newSV(0); + subdir = sv_newmortal(); if (!archpat_auto) { STRLEN len = (sizeof(ARCHNAME) + strlen(patchlevel) + sizeof("//auto")); @@ -2742,7 +2638,7 @@ incpush(char *p, int addsubdirs) /* Break at all separators */ while (p && *p) { - SV *libdir = newSV(0); + SV *libdir = NEWSV(55,0); char *s; /* skip any consecutive separators */ @@ -2785,7 +2681,7 @@ incpush(char *p, int addsubdirs) /* .../archname/version if -d .../archname/version/auto */ sv_setsv(subdir, libdir); sv_catpv(subdir, archpat_auto); - if (Stat(SvPVX(subdir), &tmpstatbuf) >= 0 && + if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 && S_ISDIR(tmpstatbuf.st_mode)) av_push(GvAVn(incgv), newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto")); @@ -2793,7 +2689,7 @@ incpush(char *p, int addsubdirs) /* .../archname if -d .../archname/auto */ sv_insert(subdir, SvCUR(libdir) + sizeof(ARCHNAME), strlen(patchlevel) + 1, "", 0); - if (Stat(SvPVX(subdir), &tmpstatbuf) >= 0 && + if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 && S_ISDIR(tmpstatbuf.st_mode)) av_push(GvAVn(incgv), newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto")); @@ -2802,21 +2698,20 @@ 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 -static struct thread * +STATIC struct perl_thread * init_main_thread() { - struct thread *thr; + struct perl_thread *thr; XPV *xpv; - Newz(53, thr, 1, struct thread); + Newz(53, thr, 1, struct perl_thread); curcop = &compiling; thr->cvcache = newHV(); - thr->magicals = newAV(); + thr->threadsv = newAV(); + /* thr->threadsvp is set when find_threadsv is called */ thr->specific = newAV(); thr->errhv = newHV(); thr->flags = THRf_R_JOINABLE; @@ -2832,7 +2727,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); @@ -2844,9 +2738,13 @@ init_main_thread() #ifdef HAVE_THREAD_INTERN init_thread_intern(thr); +#endif + +#ifdef SET_THREAD_SELF + SET_THREAD_SELF(thr); #else thr->self = pthread_self(); -#endif /* HAVE_THREAD_INTERN */ +#endif /* SET_THREAD_SELF */ SET_THR(thr); /* @@ -2861,12 +2759,13 @@ init_main_thread() sv_setpvn(bodytarget, "", 0); formtarget = bodytarget; thr->errsv = newSVpv("", 0); + (void) find_threadsv("@"); /* Ensure $@ is initialised early */ return thr; } #endif /* USE_THREADS */ void -call_list(I32 oldscope, AV *list) +call_list(I32 oldscope, AV *paramList) { dTHR; line_t oldline = curcop->cop_line; @@ -2874,8 +2773,8 @@ call_list(I32 oldscope, AV *list) dJMPENV; int ret; - while (AvFILL(list) >= 0) { - CV *cv = (CV*)av_shift(list); + while (AvFILL(paramList) >= 0) { + CV *cv = (CV*)av_shift(paramList); SAVEFREESV(cv); @@ -2890,7 +2789,7 @@ call_list(I32 oldscope, AV *list) JMPENV_POP; curcop = &compiling; curcop->cop_line = oldline; - if (list == beginav) + if (paramList == beginav) sv_catpv(atsv, "BEGIN failed--compilation aborted"); else sv_catpv(atsv, "END failed--cleanup aborted"); @@ -2915,7 +2814,7 @@ call_list(I32 oldscope, AV *list) curcop = &compiling; curcop->cop_line = oldline; if (statusvalue) { - if (list == beginav) + if (paramList == beginav) croak("BEGIN failed--compilation aborted"); else croak("END failed--cleanup aborted"); @@ -2975,32 +2874,34 @@ 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(); } -static void +STATIC void my_exit_jump(void) { - dTHR; - register CONTEXT *cx; + 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); @@ -3012,3 +2913,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; +} + +