X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=perl.c;h=be381b9ce6bcd4e003ec0d7e1b546e9155c82037;hb=c372d929e82a56503fe8b3b070d05d130fc3d0d9;hp=3229e16fccb61f74a8b678e0140c15d40f1ab68c;hpb=a0714e2c8319bd04d1f7d262de652b6b5ec054f7;p=p5sagit%2Fp5-mst-13.2.git diff --git a/perl.c b/perl.c index 3229e16..be381b9 100644 --- a/perl.c +++ b/perl.c @@ -137,6 +137,22 @@ static I32 read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen); #endif #endif +#define CALL_BODY_EVAL(myop) \ + if (PL_op == (myop)) \ + PL_op = Perl_pp_entereval(aTHX); \ + if (PL_op) \ + CALLRUNOPS(aTHX); + +#define CALL_BODY_SUB(myop) \ + if (PL_op == (myop)) \ + PL_op = Perl_pp_entersub(aTHX); \ + if (PL_op) \ + CALLRUNOPS(aTHX); + +#define CALL_LIST_BODY(cv) \ + PUSHMARK(PL_stack_sp); \ + call_sv((SV*)(cv), G_EVAL|G_DISCARD); + static void S_init_tls_and_interp(PerlInterpreter *my_perl) { @@ -148,6 +164,7 @@ S_init_tls_and_interp(PerlInterpreter *my_perl) ALLOC_THREAD_KEY; PERL_SET_THX(my_perl); OP_REFCNT_INIT; + HINTS_REFCNT_INIT; MUTEX_INIT(&PL_dollarzero_mutex); # endif #ifdef PERL_IMPLICIT_CONTEXT @@ -181,6 +198,7 @@ perl_alloc_using(struct IPerlMem* ipM, struct IPerlMem* ipMS, PL_Dir = ipD; PL_Sock = ipS; PL_Proc = ipP; + INIT_TRACK_MEMPOOL(PL_memory_debug_header, my_perl); return my_perl; } @@ -205,7 +223,13 @@ perl_alloc(void) my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter)); S_init_tls_and_interp(my_perl); +#ifndef PERL_TRACK_MEMPOOL return (PerlInterpreter *) ZeroD(my_perl, 1, PerlInterpreter); +#else + Zero(my_perl, 1, PerlInterpreter); + INIT_TRACK_MEMPOOL(PL_memory_debug_header, my_perl); + return my_perl; +#endif } #endif /* PERL_IMPLICIT_SYS */ @@ -353,7 +377,7 @@ perl_construct(pTHXx) if ((long) PL_mmap_page_size < 0) { if (errno) { SV * const error = ERRSV; - (void) SvUPGRADE(error, SVt_PV); + SvUPGRADE(error, SVt_PV); Perl_croak(aTHX_ "panic: sysconf: %s", SvPV_nolen_const(error)); } else @@ -382,6 +406,10 @@ perl_construct(pTHXx) PL_timesbase.tms_cstime = 0; #endif +#ifdef PERL_MAD + PL_curforce = -1; +#endif + ENTER; } @@ -397,6 +425,7 @@ no threads. int Perl_nothreadhook(pTHX) { + PERL_UNUSED_CONTEXT; return 0; } @@ -722,9 +751,9 @@ perl_destruct(pTHXx) PAD_SET_CUR_NOSAVE(CvPADLIST(PL_main_cv), 1); } op_free(PL_main_root); - PL_main_root = Nullop; + PL_main_root = NULL; } - PL_main_start = Nullop; + PL_main_start = NULL; SvREFCNT_dec(PL_main_cv); PL_main_cv = NULL; PL_dirty = TRUE; @@ -845,7 +874,7 @@ perl_destruct(pTHXx) if(PL_rsfp) { (void)PerlIO_close(PL_rsfp); - PL_rsfp = Nullfp; + PL_rsfp = NULL; } /* Filters for program text */ @@ -887,7 +916,6 @@ perl_destruct(pTHXx) SvREFCNT_dec(PL_rs); /* $/ */ PL_rs = NULL; - PL_multiline = 0; /* $* */ Safefree(PL_osname); /* $^O */ PL_osname = NULL; @@ -1023,11 +1051,10 @@ perl_destruct(pTHXx) PL_utf8_idcont = NULL; if (!specialWARN(PL_compiling.cop_warnings)) - SvREFCNT_dec(PL_compiling.cop_warnings); + PerlMemShared_free(PL_compiling.cop_warnings); PL_compiling.cop_warnings = NULL; - if (!specialCopIO(PL_compiling.cop_io)) - SvREFCNT_dec(PL_compiling.cop_io); - PL_compiling.cop_io = NULL; + Perl_refcounted_he_free(aTHX_ PL_compiling.cop_hints_hash); + PL_compiling.cop_hints_hash = NULL; CopFILE_free(&PL_compiling); CopSTASH_free(&PL_compiling); @@ -1244,6 +1271,12 @@ perl_destruct(pTHXx) sv_free_arenas(); + while (PL_regmatch_slab) { + regmatch_slab *s = PL_regmatch_slab; + PL_regmatch_slab = PL_regmatch_slab->next; + Safefree(s); + } + /* As the absolutely last thing, free the non-arena SV for mess() */ if (PL_mess_sv) { @@ -1280,19 +1313,37 @@ Releases a Perl interpreter. See L. void perl_free(pTHXx) { +#ifdef PERL_TRACK_MEMPOOL + { + /* + * Don't free thread memory if PERL_DESTRUCT_LEVEL is set to a non-zero + * value as we're probably hunting memory leaks then + */ + const char * const s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL"); + if (!s || atoi(s) == 0) { + /* Emulate the PerlHost behaviour of free()ing all memory allocated in this + thread at thread exit. */ + while(aTHXx->Imemory_debug_header.next != &(aTHXx->Imemory_debug_header)) + safesysfree(sTHX + (char *)(aTHXx->Imemory_debug_header.next)); + } + } +#endif + #if defined(WIN32) || defined(NETWARE) # if defined(PERL_IMPLICIT_SYS) + { # ifdef NETWARE - void *host = nw_internal_host; + void *host = nw_internal_host; # else - void *host = w32_internal_host; + void *host = w32_internal_host; # endif - PerlMem_free(aTHXx); + PerlMem_free(aTHXx); # ifdef NETWARE - nw_delete_internal_host(host); + nw_delete_internal_host(host); # else - win32_delete_internal_host(host); + win32_delete_internal_host(host); # endif + } # else PerlMem_free(aTHXx); # endif @@ -1301,12 +1352,14 @@ perl_free(pTHXx) #endif } -#if defined(USE_5005THREADS) || defined(USE_ITHREADS) +#if defined(USE_ITHREADS) /* provide destructors to clean up the thread key when libperl is unloaded */ #ifndef WIN32 /* handled during DLL_PROCESS_DETACH in win32/perllib.c */ -#if defined(__hpux) && __ux_version > 1020 && !defined(__GNUC__) +#if defined(__hpux) && !(defined(__ux_version) && __ux_version <= 1020) && !defined(__GNUC__) #pragma fini "perl_fini" +#elif defined(__sun) && !defined(__GNUC__) +#pragma fini (perl_fini) #endif static void @@ -1401,7 +1454,7 @@ perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env) int ret; dJMPENV; - PERL_UNUSED_VAR(my_perl); + PERL_UNUSED_ARG(my_perl); #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW #ifdef IAMSUID @@ -1538,9 +1591,9 @@ setuid perl scripts securely.\n"); if (PL_main_root) { op_free(PL_main_root); - PL_main_root = Nullop; + PL_main_root = NULL; } - PL_main_start = Nullop; + PL_main_start = NULL; SvREFCNT_dec(PL_main_cv); PL_main_cv = NULL; @@ -1594,8 +1647,6 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) bool minus_f = FALSE; #endif - PL_fdscript = -1; - PL_suidscript = -1; sv_setpvn(PL_linestr,"",0); sv = newSVpvs(""); /* first used for -I flags */ SAVEFREESV(sv); @@ -1673,7 +1724,7 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) if (argv[1] && !strcmp(argv[1], "Dev:Pseudo")) break; #endif - forbid_setid("-e"); + forbid_setid('e', -1); if (!PL_e_script) { PL_e_script = newSVpvs(""); filter_add(read_e_script, NULL); @@ -1697,7 +1748,7 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) goto reswitch; case 'I': /* -I handled both here and in moreswitches() */ - forbid_setid("-I"); + forbid_setid('I', -1); if (!*++s && (s=argv[1]) != NULL) { argc--,argv++; } @@ -1714,12 +1765,12 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) Perl_croak(aTHX_ "No directory specified for -I"); break; case 'P': - forbid_setid("-P"); + forbid_setid('P', -1); PL_preprocess = TRUE; s++; goto reswitch; case 'S': - forbid_setid("-S"); + forbid_setid('S', -1); dosearch = TRUE; s++; goto reswitch; @@ -1776,6 +1827,9 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) # ifdef PERL_IMPLICIT_SYS " PERL_IMPLICIT_SYS" # endif +# ifdef PERL_MAD + " PERL_MAD" +# endif # ifdef PERL_MALLOC_WRAP " PERL_MALLOC_WRAP" # endif @@ -1803,9 +1857,6 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) # ifdef THREADS_HAVE_PIDS " THREADS_HAVE_PIDS" # endif -# ifdef USE_5005THREADS - " USE_5005THREADS" -# endif # ifdef USE_64_BIT_ALL " USE_64_BIT_ALL" # endif @@ -1999,7 +2050,8 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) #endif if (PL_taint_warn && PL_dowarn != G_WARN_ALL_OFF) { - PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize); + PL_compiling.cop_warnings + = Perl_new_warnings_bitfield(aTHX_ NULL, WARN_TAINTstring, WARNsize); } if (!scriptname) @@ -2023,36 +2075,45 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) TAINT_NOT; init_perllib(); - open_script(scriptname,dosearch,sv); + { + int suidscript; + const int fdscript + = open_script(scriptname, dosearch, sv, &suidscript); - validate_suid(validarg, scriptname); + validate_suid(validarg, scriptname, fdscript, suidscript); #ifndef PERL_MICRO -#if defined(SIGCHLD) || defined(SIGCLD) - { -#ifndef SIGCHLD -# define SIGCHLD SIGCLD -#endif - Sighandler_t sigstate = rsignal_state(SIGCHLD); - if (sigstate == (Sighandler_t) SIG_IGN) { - if (ckWARN(WARN_SIGNAL)) - Perl_warner(aTHX_ packWARN(WARN_SIGNAL), - "Can't ignore signal CHLD, forcing to default"); - (void)rsignal(SIGCHLD, (Sighandler_t)SIG_DFL); +# if defined(SIGCHLD) || defined(SIGCLD) + { +# ifndef SIGCHLD +# define SIGCHLD SIGCLD +# endif + Sighandler_t sigstate = rsignal_state(SIGCHLD); + if (sigstate == (Sighandler_t) SIG_IGN) { + if (ckWARN(WARN_SIGNAL)) + Perl_warner(aTHX_ packWARN(WARN_SIGNAL), + "Can't ignore signal CHLD, forcing to default"); + (void)rsignal(SIGCHLD, (Sighandler_t)SIG_DFL); + } } - } -#endif +# endif #endif + if (PL_doextract #ifdef MACOS_TRADITIONAL - if (PL_doextract || gMacPerl_AlwaysExtract) { -#else - if (PL_doextract) { + || gMacPerl_AlwaysExtract #endif - find_beginning(); - if (cddir && PerlDir_chdir( (char *)cddir ) < 0) - Perl_croak(aTHX_ "Can't chdir to %s",cddir); + ) { + /* This will croak if suidscript is >= 0, as -x cannot be used with + setuid scripts. */ + forbid_setid('x', suidscript); + /* Hence you can't get here if suidscript >= 0 */ + + find_beginning(); + if (cddir && PerlDir_chdir( (char *)cddir ) < 0) + Perl_croak(aTHX_ "Can't chdir to %s",cddir); + } } PL_main_cv = PL_compcv = (CV*)newSV(0); @@ -2060,11 +2121,6 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) CvUNIQUE_on(PL_compcv); CvPADLIST(PL_compcv) = pad_new(0); -#ifdef USE_5005THREADS - CvOWNER(PL_compcv) = 0; - Newx(CvMUTEXP(PL_compcv), 1, perl_mutex); - MUTEX_INIT(CvMUTEXP(PL_compcv)); -#endif /* USE_5005THREADS */ boot_core_PerlIO(); boot_core_UNIVERSAL(); @@ -2148,6 +2204,25 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) Perl_croak(aTHX_ "PERL_SIGNALS illegal: \"%s\"", s); } +#ifdef PERL_MAD + if ((s = PerlEnv_getenv("PERL_XMLDUMP"))) { + PL_madskills = 1; + PL_minus_c = 1; + if (!s || !s[0]) + PL_xmlfp = PerlIO_stdout(); + else { + PL_xmlfp = PerlIO_open(s, "w"); + if (!PL_xmlfp) + Perl_croak(aTHX_ "Can't open %s", s); + } + my_setenv("PERL_XMLDUMP", Nullch); /* hide from subprocs */ + } + if ((s = PerlEnv_getenv("PERL_MADSKILLS"))) { + PL_madskills = atoi(s); + my_setenv("PERL_MADSKILLS", Nullch); /* hide from subprocs */ + } +#endif + init_lexer(); /* now parse the script */ @@ -2273,6 +2348,12 @@ S_run_body(pTHX_ I32 oldscope) PL_sawampersand ? "Enabling" : "Omitting")); if (!PL_restartop) { +#ifdef PERL_MAD + if (PL_xmlfp) { + xmldump_all(); + exit(0); /* less likely to core dump than my_exit(0) */ + } +#endif DEBUG_x(dump_all()); #ifdef DEBUGGING if (!DEBUG_q_TEST) @@ -2329,13 +2410,6 @@ SV* Perl_get_sv(pTHX_ const char *name, I32 create) { GV *gv; -#ifdef USE_5005THREADS - if (name[1] == '\0' && !isALPHA(name[0])) { - PADOFFSET tmp = find_threadsv(name); - if (tmp != NOT_IN_PAD) - return THREADSV(tmp); - } -#endif /* USE_5005THREADS */ gv = gv_fetchpv(name, create, SVt_PV); if (gv) return GvSV(gv); @@ -2412,8 +2486,7 @@ Perl_get_cv(pTHX_ const char *name, I32 create) if (create && !GvCVu(gv)) return newSUB(start_subparse(FALSE, 0), newSVOP(OP_CONST, 0, newSVpv(name,0)), - Nullop, - Nullop); + NULL, NULL); if (gv) return GvCVu(gv); return NULL; @@ -2516,7 +2589,7 @@ Perl_call_sv(pTHX_ SV *sv, I32 flags) } Zero(&myop, 1, LOGOP); - myop.op_next = Nullop; + myop.op_next = NULL; if (!(flags & G_NOARGS)) myop.op_flags |= OPf_STACKED; myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID : @@ -2549,38 +2622,22 @@ Perl_call_sv(pTHX_ SV *sv, I32 flags) if (!(flags & G_EVAL)) { CATCH_SET(TRUE); - call_body((OP*)&myop, FALSE); + CALL_BODY_SUB((OP*)&myop); retval = PL_stack_sp - (PL_stack_base + oldmark); CATCH_SET(oldcatch); } else { myop.op_other = (OP*)&myop; PL_markstack_ptr--; - /* we're trying to emulate pp_entertry() here */ - { - register PERL_CONTEXT *cx; - const I32 gimme = GIMME_V; - - ENTER; - SAVETMPS; - - PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp); - PUSHEVAL(cx, 0, 0); - PL_eval_root = PL_op; /* Only needed so that goto works right. */ - - PL_in_eval = EVAL_INEVAL; - if (flags & G_KEEPERR) - PL_in_eval |= EVAL_KEEPERR; - else - sv_setpvn(ERRSV,"",0); - } + create_eval_scope(flags|G_FAKINGEVAL); PL_markstack_ptr++; JMPENV_PUSH(ret); + switch (ret) { case 0: redo_body: - call_body((OP*)&myop, FALSE); + CALL_BODY_SUB((OP*)&myop); retval = PL_stack_sp - (PL_stack_base + oldmark); if (!(flags & G_KEEPERR)) sv_setpvn(ERRSV,"",0); @@ -2613,21 +2670,8 @@ Perl_call_sv(pTHX_ SV *sv, I32 flags) break; } - if (PL_scopestack_ix > oldscope) { - SV **newsp; - PMOP *newpm; - I32 gimme; - register PERL_CONTEXT *cx; - I32 optype; - - POPBLOCK(cx,newpm); - POPEVAL(cx); - PL_curpm = newpm; - LEAVE; - PERL_UNUSED_VAR(newsp); - PERL_UNUSED_VAR(gimme); - PERL_UNUSED_VAR(optype); - } + if (PL_scopestack_ix > oldscope) + delete_eval_scope(); JMPENV_POP; } @@ -2641,20 +2685,6 @@ Perl_call_sv(pTHX_ SV *sv, I32 flags) return retval; } -STATIC void -S_call_body(pTHX_ const OP *myop, bool is_eval) -{ - dVAR; - if (PL_op == myop) { - if (is_eval) - PL_op = Perl_pp_entereval(aTHX); /* this doesn't do a POPMARK */ - else - PL_op = Perl_pp_entersub(aTHX); /* this does */ - } - if (PL_op) - CALLRUNOPS(aTHX); -} - /* Eval a string. The G_EVAL flag is always assumed. */ /* @@ -2692,7 +2722,7 @@ Perl_eval_sv(pTHX_ SV *sv, I32 flags) if (!(flags & G_NOARGS)) myop.op_flags = OPf_STACKED; - myop.op_next = Nullop; + myop.op_next = NULL; myop.op_type = OP_ENTEREVAL; myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID : (flags & G_ARRAY) ? OPf_WANT_LIST : @@ -2708,7 +2738,7 @@ Perl_eval_sv(pTHX_ SV *sv, I32 flags) switch (ret) { case 0: redo_body: - call_body((OP*)&myop,TRUE); + CALL_BODY_EVAL((OP*)&myop); retval = PL_stack_sp - (PL_stack_base + oldmark); if (!(flags & G_KEEPERR)) sv_setpvn(ERRSV,"",0); @@ -2985,13 +3015,14 @@ Perl_moreswitches(pTHX_ char *s) case 'C': s++; PL_unicode = parse_unicode_opts( (const char **)&s ); + if (PL_unicode & PERL_UNICODE_UTF8CACHEASSERT_FLAG) + PL_utf8cache = -1; return s; case 'F': PL_minus_F = TRUE; PL_splitstr = ++s; while (*s && !isSPACE(*s)) ++s; - *s = '\0'; - PL_splitstr = savepv(PL_splitstr); + PL_splitstr = savepvn(PL_splitstr, s - PL_splitstr); return s; case 'a': PL_minus_a = TRUE; @@ -3002,7 +3033,7 @@ Perl_moreswitches(pTHX_ char *s) s++; return s; case 'd': - forbid_setid("-d"); + forbid_setid('d', -1); s++; /* -dt indicates to the debugger that threads will be used */ @@ -3023,7 +3054,9 @@ Perl_moreswitches(pTHX_ char *s) sv_catpv(sv, start); else { sv_catpvn(sv, start, s-start); - Perl_sv_catpvf(aTHX_ sv, " split(/,/,q%c%s%c)", 0, ++s, 0); + /* Don't use NUL as q// delimiter here, this string goes in the + * environment. */ + Perl_sv_catpvf(aTHX_ sv, " split(/,/,q{%s});", ++s); } s += strlen(s); my_setenv("PERL5DB", SvPV_nolen_const(sv)); @@ -3036,7 +3069,7 @@ Perl_moreswitches(pTHX_ char *s) case 'D': { #ifdef DEBUGGING - forbid_setid("-D"); + forbid_setid('D', -1); s++; PL_debug = get_debug_opts( (const char **)&s, 1) | DEBUG_TOP_FLAG; #else /* !DEBUGGING */ @@ -3058,17 +3091,21 @@ Perl_moreswitches(pTHX_ char *s) return s+1; } #endif /* __CYGWIN__ */ - PL_inplace = savepv(s+1); - for (s = PL_inplace; *s && !isSPACE(*s); s++) - ; + { + const char * const start = ++s; + while (*s && !isSPACE(*s)) + ++s; + + PL_inplace = savepvn(start, s - start); + } if (*s) { - *s++ = '\0'; + ++s; if (*s == '-') /* Additional switches on #! line. */ - s++; + s++; } return s; case 'I': /* -I handled both here and in parse_body() */ - forbid_setid("-I"); + forbid_setid('I', -1); ++s; while (*s && isSPACE(*s)) ++s; @@ -3117,7 +3154,7 @@ Perl_moreswitches(pTHX_ char *s) } return s; case 'A': - forbid_setid("-A"); + forbid_setid('A', -1); if (!PL_preambleav) PL_preambleav = newAV(); s++; @@ -3140,10 +3177,10 @@ Perl_moreswitches(pTHX_ char *s) return s; } case 'M': - forbid_setid("-M"); /* XXX ? */ + forbid_setid('M', -1); /* XXX ? */ /* FALL THROUGH */ case 'm': - forbid_setid("-m"); /* XXX ? */ + forbid_setid('m', -1); /* XXX ? */ if (*++s) { char *start; SV *sv; @@ -3190,7 +3227,7 @@ Perl_moreswitches(pTHX_ char *s) s++; return s; case 's': - forbid_setid("-s"); + forbid_setid('s', -1); PL_doswitches = TRUE; s++; return s; @@ -3225,8 +3262,8 @@ Perl_moreswitches(pTHX_ char *s) " DEVEL" STRINGIFY(PERL_PATCHNUM) #endif " built for %s", - vstringify(PL_patchlevel), - ARCHNAME)); + (void*)vstringify(PL_patchlevel), + ARCHNAME)); #else /* DGUX */ /* Adjust verbose output as in the perl that ships with the DG/UX OS from EMC */ PerlIO_printf(PerlIO_stdout(), @@ -3245,7 +3282,7 @@ Perl_moreswitches(pTHX_ char *s) PerlIO_printf(PerlIO_stdout(), "\n(with %d registered patch%s, " "see perl -V for more detail)", - (int)LOCAL_PATCH_COUNT, + LOCAL_PATCH_COUNT, (LOCAL_PATCH_COUNT!=1) ? "es" : ""); #endif @@ -3334,14 +3371,14 @@ Internet, point your browser at http://www.perl.org/, the Perl Home Page.\n\n"); case 'W': PL_dowarn = G_WARN_ALL_ON|G_WARN_ON; if (!specialWARN(PL_compiling.cop_warnings)) - SvREFCNT_dec(PL_compiling.cop_warnings); + PerlMemShared_free(PL_compiling.cop_warnings); PL_compiling.cop_warnings = pWARN_ALL ; s++; return s; case 'X': PL_dowarn = G_WARN_ALL_OFF; if (!specialWARN(PL_compiling.cop_warnings)) - SvREFCNT_dec(PL_compiling.cop_warnings); + PerlMemShared_free(PL_compiling.cop_warnings); PL_compiling.cop_warnings = pWARN_NONE ; s++; return s; @@ -3380,15 +3417,14 @@ Internet, point your browser at http://www.perl.org/, the Perl Home Page.\n\n"); void Perl_my_unexec(pTHX) { + PERL_UNUSED_CONTEXT; #ifdef UNEXEC - SV* prog; - SV* file; + SV * prog = newSVpv(BIN_EXP, 0); + SV * file = newSVpv(PL_origfilename, 0); int status = 1; extern int etext; - prog = newSVpv(BIN_EXP, 0); sv_catpvs(prog, "/perl"); - file = newSVpv(PL_origfilename, 0); sv_catpvs(file, ".perldump"); unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0); @@ -3415,21 +3451,14 @@ S_init_interp(pTHX) # define PERLVAR(var,type) # define PERLVARA(var,n,type) # if defined(PERL_IMPLICIT_CONTEXT) -# if defined(USE_5005THREADS) -# define PERLVARI(var,type,init) PERL_GET_INTERP->var = init; -# define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init; -# else /* !USE_5005THREADS */ -# define PERLVARI(var,type,init) aTHX->var = init; -# define PERLVARIC(var,type,init) aTHX->var = init; -# endif /* USE_5005THREADS */ +# define PERLVARI(var,type,init) aTHX->var = init; +# define PERLVARIC(var,type,init) aTHX->var = init; # else # define PERLVARI(var,type,init) PERL_GET_INTERP->var = init; # define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init; # endif # include "intrpvar.h" -# ifndef USE_5005THREADS -# include "thrdvar.h" -# endif +# include "thrdvar.h" # undef PERLVAR # undef PERLVARA # undef PERLVARI @@ -3440,15 +3469,18 @@ S_init_interp(pTHX) # define PERLVARI(var,type,init) PL_##var = init; # define PERLVARIC(var,type,init) PL_##var = init; # include "intrpvar.h" -# ifndef USE_5005THREADS -# include "thrdvar.h" -# endif +# include "thrdvar.h" # undef PERLVAR # undef PERLVARA # undef PERLVARI # undef PERLVARIC #endif + /* As these are inside a structure, PERLVARI isn't capable of initialising + them */ + PL_regindent = 0; + PL_reg_oldcurpm = PL_reg_curpm = NULL; + PL_reg_poscache = PL_reg_starttry = NULL; } STATIC void @@ -3469,18 +3501,18 @@ S_init_main_stash(pTHX) of the SvREFCNT_dec, only to add it again with hv_name_set */ SvREFCNT_dec(GvHV(gv)); hv_name_set(PL_defstash, "main", 4, 0); - GvHV(gv) = (HV*)SvREFCNT_inc(PL_defstash); + GvHV(gv) = (HV*)SvREFCNT_inc_simple(PL_defstash); SvREADONLY_on(gv); PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpvs("INC", GV_ADD|GV_NOTQUAL, SVt_PVAV))); - SvREFCNT_inc(PL_incgv); /* Don't allow it to be freed */ + SvREFCNT_inc_simple(PL_incgv); /* Don't allow it to be freed */ GvMULTI_on(PL_incgv); PL_hintgv = gv_fetchpvs("\010", GV_ADD|GV_NOTQUAL, SVt_PV); /* ^H */ GvMULTI_on(PL_hintgv); PL_defgv = gv_fetchpvs("_", GV_ADD|GV_NOTQUAL, SVt_PVAV); - SvREFCNT_inc(PL_defgv); + SvREFCNT_inc_simple(PL_defgv); PL_errgv = gv_HVadd(gv_fetchpvs("@", GV_ADD|GV_NOTQUAL, SVt_PV)); - SvREFCNT_inc(PL_errgv); + SvREFCNT_inc_simple(PL_errgv); GvMULTI_on(PL_errgv); PL_replgv = gv_fetchpvs("\022", GV_ADD|GV_NOTQUAL, SVt_PV); /* ^R */ GvMULTI_on(PL_replgv); @@ -3499,9 +3531,9 @@ S_init_main_stash(pTHX) sv_setpvn(get_sv("/", TRUE), "\n", 1); } -/* PSz 18 Nov 03 fdscript now global but do not change prototype */ -STATIC void -S_open_script(pTHX_ const char *scriptname, bool dosearch, SV *sv) +STATIC int +S_open_script(pTHX_ const char *scriptname, bool dosearch, SV *sv, + int *suidscript) { #ifndef IAMSUID const char *quote; @@ -3509,10 +3541,10 @@ S_open_script(pTHX_ const char *scriptname, bool dosearch, SV *sv) const char *cpp_discard_flag; const char *perl; #endif + int fdscript = -1; dVAR; - PL_fdscript = -1; - PL_suidscript = -1; + *suidscript = -1; if (PL_e_script) { PL_origfilename = savepvs("-e"); @@ -3523,7 +3555,7 @@ S_open_script(pTHX_ const char *scriptname, bool dosearch, SV *sv) if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) { const char *s = scriptname + 8; - PL_fdscript = atoi(s); + fdscript = atoi(s); while (isDIGIT(*s)) s++; if (*s) { @@ -3536,7 +3568,7 @@ S_open_script(pTHX_ const char *scriptname, bool dosearch, SV *sv) * Is it a mistake to use a similar /dev/fd/ construct for * suidperl? */ - PL_suidscript = 1; + *suidscript = 1; /* PSz 20 Feb 04 * Be supersafe and do some sanity-checks. * Still, can we be sure we got the right thing? @@ -3558,8 +3590,8 @@ S_open_script(pTHX_ const char *scriptname, bool dosearch, SV *sv) CopFILE_set(PL_curcop, PL_origfilename); if (*PL_origfilename == '-' && PL_origfilename[1] == '\0') scriptname = (char *)""; - if (PL_fdscript >= 0) { - PL_rsfp = PerlIO_fdopen(PL_fdscript,PERL_SCRIPT_MODE); + if (fdscript >= 0) { + PL_rsfp = PerlIO_fdopen(fdscript,PERL_SCRIPT_MODE); # if defined(HAS_FCNTL) && defined(F_SETFD) if (PL_rsfp) /* ensure close-on-exec */ @@ -3579,7 +3611,7 @@ S_open_script(pTHX_ const char *scriptname, bool dosearch, SV *sv) * perl with that fd as it has always done. */ } - if (PL_suidscript != 1) { + if (*suidscript != 1) { Perl_croak(aTHX_ "suidperl needs (suid) fd script\n"); } #else /* IAMSUID */ @@ -3636,8 +3668,8 @@ S_open_script(pTHX_ const char *scriptname, bool dosearch, SV *sv) Perl_sv_setpvf(aTHX_ cmd, "\ %s -ne%s%s%s %s | %"SVf" %s %"SVf" %s", - perl, quote, code, quote, scriptname, cpp, - cpp_discard_flag, sv, CPPMINUS); + perl, quote, code, quote, scriptname, (void*)cpp, + cpp_discard_flag, (void*)sv, CPPMINUS); PL_doextract = FALSE; @@ -3650,7 +3682,7 @@ S_open_script(pTHX_ const char *scriptname, bool dosearch, SV *sv) SvREFCNT_dec(cpp); } else if (!*scriptname) { - forbid_setid("program input from stdin"); + forbid_setid(0, *suidscript); PL_rsfp = PerlIO_stdin(); } else { @@ -3670,6 +3702,7 @@ S_open_script(pTHX_ const char *scriptname, bool dosearch, SV *sv) Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n", CopFILE(PL_curcop), Strerror(errno)); } + return fdscript; } /* Mention @@ -3807,7 +3840,8 @@ S_fd_on_nosuid_fs(pTHX_ int fd) #endif /* IAMSUID */ STATIC void -S_validate_suid(pTHX_ const char *validarg, const char *scriptname) +S_validate_suid(pTHX_ const char *validarg, const char *scriptname, + int fdscript, int suidscript) { dVAR; #ifdef IAMSUID @@ -3852,7 +3886,7 @@ S_validate_suid(pTHX_ const char *validarg, const char *scriptname) const char *s_end; #ifdef IAMSUID - if (PL_fdscript < 0 || PL_suidscript != 1) + if (fdscript < 0 || suidscript != 1) Perl_croak(aTHX_ "Need (suid) fdscript in suidperl\n"); /* We already checked this */ /* PSz 11 Nov 03 * Since the script is opened by perl, not suidperl, some of these @@ -4002,7 +4036,7 @@ S_validate_suid(pTHX_ const char *validarg, const char *scriptname) Perl_croak(aTHX_ "Args must match #! line"); #ifndef IAMSUID - if (PL_fdscript < 0 && + if (fdscript < 0 && PL_euid != PL_uid && (PL_statbuf.st_mode & S_ISUID) && PL_euid == PL_statbuf.st_uid) if (!PL_do_undump) @@ -4010,7 +4044,7 @@ S_validate_suid(pTHX_ const char *validarg, const char *scriptname) FIX YOUR KERNEL, OR PUT A C WRAPPER AROUND THIS SCRIPT!\n"); #endif /* IAMSUID */ - if (PL_fdscript < 0 && + if (fdscript < 0 && PL_euid) { /* oops, we're not the setuid root perl */ /* PSz 18 Feb 04 * When root runs a setuid script, we do not go through the same @@ -4023,7 +4057,7 @@ FIX YOUR KERNEL, OR PUT A C WRAPPER AROUND THIS SCRIPT!\n"); * might run also non-setuid ones, and deserves what he gets. * * Or, we might drop the PL_euid check above (and rely just on - * PL_fdscript to avoid loops), and do the execs + * fdscript to avoid loops), and do the execs * even for root. */ #ifndef IAMSUID @@ -4131,7 +4165,7 @@ FIX YOUR KERNEL, OR PUT A C WRAPPER AROUND THIS SCRIPT!\n"); #ifdef IAMSUID else if (PL_preprocess) /* PSz 13 Nov 03 Caught elsewhere, useless(?!) here */ Perl_croak(aTHX_ "-P not allowed for setuid/setgid script\n"); - else if (PL_fdscript < 0 || PL_suidscript != 1) + else if (fdscript < 0 || suidscript != 1) /* PSz 13 Nov 03 Caught elsewhere, useless(?!) here */ Perl_croak(aTHX_ "(suid) fdscript needed in suidperl\n"); else { @@ -4195,6 +4229,8 @@ FIX YOUR KERNEL, OR PUT A C WRAPPER AROUND THIS SCRIPT!\n"); Perl_croak(aTHX_ "Can't do setuid (suidperl cannot exec perl)\n"); #endif /* IAMSUID */ #else /* !DOSUID */ + PERL_UNUSED_ARG(fdscript); + PERL_UNUSED_ARG(suidscript); if (PL_euid != PL_uid || PL_egid != PL_gid) { /* (suidperl doesn't exist, in fact) */ #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf); /* may be either wrapped or real suid */ @@ -4209,8 +4245,8 @@ FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n"); /* not set-id, must be wrapped */ } #endif /* DOSUID */ - (void)validarg; - (void)scriptname; + PERL_UNUSED_ARG(validarg); + PERL_UNUSED_ARG(scriptname); } STATIC void @@ -4225,7 +4261,6 @@ S_find_beginning(pTHX) /* skip forward in input to the real script? */ - forbid_setid("-x"); #ifdef MACOS_TRADITIONAL /* Since the Mac OS does not honor #! arguments for us, we do it ourselves */ @@ -4346,15 +4381,27 @@ Perl_doing_taint(int argc, char *argv[], char *envp[]) return 0; } +/* Passing the flag as a single char rather than a string is a slight space + optimisation. The only message that isn't /^-.$/ is + "program input from stdin", which is substituted in place of '\0', which + could never be a command line flag. */ STATIC void -S_forbid_setid(pTHX_ const char *s) +S_forbid_setid(pTHX_ const char flag, const int suidscript) { dVAR; + char string[3] = "-x"; + const char *message = "program input from stdin"; + + if (flag) { + string[1] = flag; + message = string; + } + #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW if (PL_euid != PL_uid) - Perl_croak(aTHX_ "No %s allowed while running setuid", s); + Perl_croak(aTHX_ "No %s allowed while running setuid", message); if (PL_egid != PL_gid) - Perl_croak(aTHX_ "No %s allowed while running setgid", s); + Perl_croak(aTHX_ "No %s allowed while running setgid", message); #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */ /* PSz 29 Feb 04 * Checks for UID/GID above "wrong": why disallow @@ -4378,11 +4425,11 @@ S_forbid_setid(pTHX_ const char *s) * * Also see comments about root running a setuid script, elsewhere. */ - if (PL_suidscript >= 0) - Perl_croak(aTHX_ "No %s allowed with (suid) fdscript", s); + if (suidscript >= 0) + Perl_croak(aTHX_ "No %s allowed with (suid) fdscript", message); #ifdef IAMSUID /* PSz 11 Nov 03 Catch it in suidperl, always! */ - Perl_croak(aTHX_ "No %s allowed in suidperl", s); + Perl_croak(aTHX_ "No %s allowed in suidperl", message); #endif /* IAMSUID */ } @@ -4478,7 +4525,7 @@ S_init_lexer(pTHX) dVAR; PerlIO *tmpfp; tmpfp = PL_rsfp; - PL_rsfp = Nullfp; + PL_rsfp = NULL; lex_start(PL_linestr); PL_rsfp = tmpfp; PL_subname = newSVpvs("main"); @@ -4499,7 +4546,7 @@ S_init_predump_symbols(pTHX) IoIFP(io) = PerlIO_stdin(); tmpgv = gv_fetchpvs("stdin", GV_ADD|GV_NOTQUAL, SVt_PV); GvMULTI_on(tmpgv); - GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io); + GvIOp(tmpgv) = (IO*)SvREFCNT_inc_simple(io); tmpgv = gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVIO); GvMULTI_on(tmpgv); @@ -4509,7 +4556,7 @@ S_init_predump_symbols(pTHX) setdefout(tmpgv); tmpgv = gv_fetchpvs("stdout", GV_ADD|GV_NOTQUAL, SVt_PV); GvMULTI_on(tmpgv); - GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io); + GvIOp(tmpgv) = (IO*)SvREFCNT_inc_simple(io); PL_stderrgv = gv_fetchpvs("STDERR", GV_ADD|GV_NOTQUAL, SVt_PVIO); GvMULTI_on(PL_stderrgv); @@ -4518,7 +4565,7 @@ S_init_predump_symbols(pTHX) IoOFP(io) = IoIFP(io) = PerlIO_stderr(); tmpgv = gv_fetchpvs("stderr", GV_ADD|GV_NOTQUAL, SVt_PV); GvMULTI_on(tmpgv); - GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io); + GvIOp(tmpgv) = (IO*)SvREFCNT_inc_simple(io); PL_statname = newSV(0); /* last filename we did stat on */ @@ -4752,7 +4799,8 @@ S_init_perllib(pTHX) # endif #endif -#ifdef SITELIB_STEM /* Search for version-specific dirs below here */ +#if defined(SITELIB_STEM) && defined(PERL_INC_VERSION_LIST) + /* Search for version-specific dirs below here */ incpush(SITELIB_STEM, FALSE, TRUE, TRUE, TRUE); #endif @@ -5000,19 +5048,21 @@ S_incpush(pTHX_ const char *dir, bool addsubdirs, bool addoldvers, bool usesep, #endif /* .../version/archname if -d .../version/archname */ Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT_PATH PERL_ARCH_FMT, - libdir, + (void*)libdir, (int)PERL_REVISION, (int)PERL_VERSION, (int)PERL_SUBVERSION, ARCHNAME); subdir = S_incpush_if_exists(aTHX_ subdir); /* .../version if -d .../version */ - Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT_PATH, libdir, + Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT_PATH, + (void*)libdir, (int)PERL_REVISION, (int)PERL_VERSION, (int)PERL_SUBVERSION); subdir = S_incpush_if_exists(aTHX_ subdir); /* .../archname if -d .../archname */ - Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT, libdir, ARCHNAME); + Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT, + (void*)libdir, ARCHNAME); subdir = S_incpush_if_exists(aTHX_ subdir); } @@ -5021,7 +5071,7 @@ S_incpush(pTHX_ const char *dir, bool addsubdirs, bool addoldvers, bool usesep, if (addoldvers) { for (incver = incverlist; *incver; incver++) { /* .../xxx if -d .../xxx */ - Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT, libdir, *incver); + Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT, (void *)libdir, *incver); subdir = S_incpush_if_exists(aTHX_ subdir); } } @@ -5037,85 +5087,6 @@ S_incpush(pTHX_ const char *dir, bool addsubdirs, bool addoldvers, bool usesep, } } -#ifdef USE_5005THREADS -STATIC struct perl_thread * -S_init_main_thread(pTHX) -{ -#if !defined(PERL_IMPLICIT_CONTEXT) - struct perl_thread *thr; -#endif - XPV *xpv; - - Newxz(thr, 1, struct perl_thread); - PL_curcop = &PL_compiling; - thr->interp = PERL_GET_INTERP; - thr->cvcache = newHV(); - thr->threadsv = newAV(); - /* thr->threadsvp is set when find_threadsv is called */ - thr->specific = newAV(); - thr->flags = THRf_R_JOINABLE; - MUTEX_INIT(&thr->mutex); - /* Handcraft thrsv similarly to mess_sv */ - Newx(PL_thrsv, 1, SV); - Newxz(xpv, 1, XPV); - SvFLAGS(PL_thrsv) = SVt_PV; - SvANY(PL_thrsv) = (void*)xpv; - SvREFCNT(PL_thrsv) = 1 << 30; /* practically infinite */ - SvPV_set(PL_thrsvr, (char*)thr); - SvCUR_set(PL_thrsv, sizeof(thr)); - SvLEN_set(PL_thrsv, sizeof(thr)); - *SvEND(PL_thrsv) = '\0'; /* in the trailing_nul field */ - thr->oursv = PL_thrsv; - PL_chopset = " \n-"; - PL_dumpindent = 4; - - MUTEX_LOCK(&PL_threads_mutex); - PL_nthreads++; - thr->tid = 0; - thr->next = thr; - thr->prev = thr; - thr->thr_done = 0; - MUTEX_UNLOCK(&PL_threads_mutex); - -#ifdef HAVE_THREAD_INTERN - Perl_init_thread_intern(thr); -#endif - -#ifdef SET_THREAD_SELF - SET_THREAD_SELF(thr); -#else - thr->self = pthread_self(); -#endif /* SET_THREAD_SELF */ - PERL_SET_THX(thr); - - /* - * These must come after the thread self setting - * because sv_setpvn does SvTAINT and the taint - * fields thread selfness being set. - */ - PL_toptarget = newSV(0); - sv_upgrade(PL_toptarget, SVt_PVFM); - sv_setpvn(PL_toptarget, "", 0); - PL_bodytarget = newSV(0); - sv_upgrade(PL_bodytarget, SVt_PVFM); - sv_setpvn(PL_bodytarget, "", 0); - PL_formtarget = PL_bodytarget; - thr->errsv = newSVpvs(""); - (void) find_threadsv("@"); /* Ensure $@ is initialised early */ - - PL_maxscream = -1; - PL_peepp = MEMBER_TO_FPTR(Perl_peep); - PL_regcompp = MEMBER_TO_FPTR(Perl_pregcomp); - PL_regexecp = MEMBER_TO_FPTR(Perl_regexec_flags); - PL_regint_start = MEMBER_TO_FPTR(Perl_re_intuit_start); - PL_regint_string = MEMBER_TO_FPTR(Perl_re_intuit_string); - PL_regfree = MEMBER_TO_FPTR(Perl_pregfree); - PL_regindent = 0; - PL_reginterp_cnt = 0; - - return thr; -} -#endif /* USE_5005THREADS */ void Perl_call_list(pTHX_ I32 oldscope, AV *paramList) @@ -5144,14 +5115,25 @@ Perl_call_list(pTHX_ I32 oldscope, AV *paramList) av_push(PL_checkav_save, (SV*)cv); } } else { - SAVEFREESV(cv); + if (!PL_madskills) + SAVEFREESV(cv); } JMPENV_PUSH(ret); switch (ret) { case 0: - call_list_body(cv); +#ifdef PERL_MAD + if (PL_madskills) + PL_madskills |= 16384; +#endif + CALL_LIST_BODY(cv); +#ifdef PERL_MAD + if (PL_madskills) + PL_madskills &= ~16384; +#endif atsv = ERRSV; (void)SvPV_const(atsv, len); + if (PL_madskills && PL_minus_c && paramList == PL_beginav) + break; /* not really trying to run, so just wing it */ if (len) { PL_curcop = &PL_compiling; CopLINE_set(PL_curcop, oldline); @@ -5166,7 +5148,7 @@ Perl_call_list(pTHX_ I32 oldscope, AV *paramList) while (PL_scopestack_ix > oldscope) LEAVE; JMPENV_POP; - Perl_croak(aTHX_ "%"SVf"", atsv); + Perl_croak(aTHX_ "%"SVf"", (void*)atsv); } break; case 1: @@ -5181,6 +5163,8 @@ Perl_call_list(pTHX_ I32 oldscope, AV *paramList) PL_curcop = &PL_compiling; CopLINE_set(PL_curcop, oldline); JMPENV_POP; + if (PL_madskills && PL_minus_c && paramList == PL_beginav) + return; /* not really trying to run, so just wing it */ if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED)) { if (paramList == PL_beginav) Perl_croak(aTHX_ "BEGIN failed--compilation aborted"); @@ -5206,15 +5190,6 @@ Perl_call_list(pTHX_ I32 oldscope, AV *paramList) } } -STATIC void * -S_call_list_body(pTHX_ CV *cv) -{ - dVAR; - PUSHMARK(PL_stack_sp); - call_sv((SV*)cv, G_EVAL|G_DISCARD); - return NULL; -} - void Perl_my_exit(pTHX_ U32 status) { @@ -5313,9 +5288,6 @@ STATIC void S_my_exit_jump(pTHX) { dVAR; - register PERL_CONTEXT *cx; - I32 gimme; - SV **newsp; if (PL_e_script) { SvREFCNT_dec(PL_e_script); @@ -5323,16 +5295,10 @@ S_my_exit_jump(pTHX) } POPSTACK_TO(PL_mainstack); - if (cxstack_ix >= 0) { - if (cxstack_ix > 0) - dounwind(0); - POPBLOCK(cx,PL_curpm); - LEAVE; - } + dounwind(-1); + LEAVE_SCOPE(0); JMPENV_JUMP(2); - PERL_UNUSED_VAR(gimme); - PERL_UNUSED_VAR(newsp); } static I32