X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/cf93a474d4757162f972857eb69a670bf2aad44d..43275f00a97a14a80f9493c38895a5c77f0fc88a:/perl.c diff --git a/perl.c b/perl.c index 2b754ff..eb875fc 100644 --- a/perl.c +++ b/perl.c @@ -33,19 +33,12 @@ #include "perl.h" #include "patchlevel.h" /* for local_patches */ #include "XSUB.h" +#include "charclass_invlists.h" #ifdef NETWARE #include "nwutil.h" #endif -#ifdef USE_KERN_PROC_PATHNAME -# include -#endif - -#ifdef USE_NSGETEXECUTABLEPATH -# include -#endif - #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP # ifdef I_SYSUIO # include @@ -144,7 +137,7 @@ Perl_sys_init3(int* argc, char*** argv, char*** env) } void -Perl_sys_term() +Perl_sys_term(void) { dVAR; if (!PL_veto_cleanup) { @@ -262,7 +255,6 @@ perl_construct(pTHXx) STATUS_ALL_SUCCESS; init_i18nl10n(1); - SET_NUMERIC_STANDARD(); #if defined(LOCAL_PATCH_COUNT) PL_localpatches = local_patches; /* For possible -v */ @@ -314,11 +306,6 @@ perl_construct(pTHXx) Zero(PL_sv_consts, SV_CONSTS_COUNT, SV*); -#if defined(__DYNAMIC__) && (defined(NeXT) || defined(__NeXT__)) - _dyld_lookup_and_bind - ("__environ", (unsigned long *) &environ_pointer, NULL); -#endif /* environ */ - #ifndef PERL_MICRO # ifdef USE_ENVIRON_ARRAY PL_origenviron = environ; @@ -338,7 +325,6 @@ perl_construct(pTHXx) PL_stashcache = newHV(); PL_patchlevel = newSVpvs("v" PERL_VERSION_STRING); - PL_apiversion = newSVpvs("v" PERL_API_VERSION_STRING); #ifdef HAS_MMAP if (!PL_mmap_page_size) { @@ -388,6 +374,24 @@ perl_construct(pTHXx) /* Start with 1 bucket, for DFS. It's unlikely we'll need more. */ HvMAX(PL_registered_mros) = 0; + PL_XPosix_ptrs[_CC_ASCII] = _new_invlist_C_array(ASCII_invlist); + PL_XPosix_ptrs[_CC_ALPHANUMERIC] = _new_invlist_C_array(XPosixAlnum_invlist); + PL_XPosix_ptrs[_CC_ALPHA] = _new_invlist_C_array(XPosixAlpha_invlist); + PL_XPosix_ptrs[_CC_BLANK] = _new_invlist_C_array(XPosixBlank_invlist); + PL_XPosix_ptrs[_CC_CASED] = _new_invlist_C_array(Cased_invlist); + PL_XPosix_ptrs[_CC_CNTRL] = _new_invlist_C_array(XPosixCntrl_invlist); + PL_XPosix_ptrs[_CC_DIGIT] = _new_invlist_C_array(XPosixDigit_invlist); + PL_XPosix_ptrs[_CC_GRAPH] = _new_invlist_C_array(XPosixGraph_invlist); + PL_XPosix_ptrs[_CC_LOWER] = _new_invlist_C_array(XPosixLower_invlist); + PL_XPosix_ptrs[_CC_PRINT] = _new_invlist_C_array(XPosixPrint_invlist); + PL_XPosix_ptrs[_CC_PUNCT] = _new_invlist_C_array(XPosixPunct_invlist); + PL_XPosix_ptrs[_CC_SPACE] = _new_invlist_C_array(XPerlSpace_invlist); + PL_XPosix_ptrs[_CC_PSXSPC] = _new_invlist_C_array(XPosixSpace_invlist); + PL_XPosix_ptrs[_CC_UPPER] = _new_invlist_C_array(XPosixUpper_invlist); + PL_XPosix_ptrs[_CC_VERTSPACE] = _new_invlist_C_array(VertSpace_invlist); + PL_XPosix_ptrs[_CC_WORDCHAR] = _new_invlist_C_array(XPosixWord_invlist); + PL_XPosix_ptrs[_CC_XDIGIT] = _new_invlist_C_array(XPosixXDigit_invlist); + ENTER; } @@ -541,13 +545,18 @@ perl_destruct(pTHXx) { const char * const s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL"); if (s) { - const int i = atoi(s); + int i; + if (strEQ(s, "-1")) { /* Special case: modperl folklore. */ + i = -1; + } else { + i = grok_atou(s, NULL); + } #ifdef DEBUGGING if (destruct_level < i) destruct_level = i; #endif #ifdef PERL_TRACK_MEMPOOL - /* RT #114496, for perl_free */ - PL_perl_destruct_level = i; + /* RT #114496, for perl_free */ + PL_perl_destruct_level = i; #endif } } @@ -660,7 +669,7 @@ perl_destruct(pTHXx) msg.msg_name = NULL; msg.msg_namelen = 0; msg.msg_iov = vec; - msg.msg_iovlen = sizeof(vec)/sizeof(vec[0]); + msg.msg_iovlen = C_ARRAY_LENGTH(vec); vec[0].iov_base = (void*)⌖ vec[0].iov_len = sizeof(target); @@ -896,7 +905,6 @@ perl_destruct(pTHXx) Safefree(PL_inplace); PL_inplace = NULL; SvREFCNT_dec(PL_patchlevel); - SvREFCNT_dec(PL_apiversion); if (PL_e_script) { SvREFCNT_dec(PL_e_script); @@ -949,27 +957,33 @@ perl_destruct(pTHXx) PL_initav = NULL; /* shortcuts just get cleared */ - PL_incgv = NULL; PL_hintgv = NULL; PL_errgv = NULL; - PL_argvgv = NULL; PL_argvoutgv = NULL; PL_stdingv = NULL; PL_stderrgv = NULL; PL_last_in_gv = NULL; - PL_replgv = NULL; PL_DBsingle = NULL; PL_DBtrace = NULL; PL_DBsignal = NULL; + PL_DBsingle_iv = 0; + PL_DBtrace_iv = 0; + PL_DBsignal_iv = 0; PL_DBcv = NULL; PL_dbargs = NULL; PL_debstash = NULL; SvREFCNT_dec(PL_envgv); + SvREFCNT_dec(PL_incgv); + SvREFCNT_dec(PL_argvgv); + SvREFCNT_dec(PL_replgv); SvREFCNT_dec(PL_DBgv); SvREFCNT_dec(PL_DBline); SvREFCNT_dec(PL_DBsub); PL_envgv = NULL; + PL_incgv = NULL; + PL_argvgv = NULL; + PL_replgv = NULL; PL_DBgv = NULL; PL_DBline = NULL; PL_DBsub = NULL; @@ -1018,8 +1032,10 @@ perl_destruct(pTHXx) SvREFCNT_dec(PL_utf8_tofold); SvREFCNT_dec(PL_utf8_idstart); SvREFCNT_dec(PL_utf8_idcont); + SvREFCNT_dec(PL_utf8_foldable); SvREFCNT_dec(PL_utf8_foldclosures); SvREFCNT_dec(PL_AboveLatin1); + SvREFCNT_dec(PL_InBitmap); SvREFCNT_dec(PL_UpperLatin1); SvREFCNT_dec(PL_Latin1); SvREFCNT_dec(PL_NonL1NonFinalFold); @@ -1033,17 +1049,12 @@ perl_destruct(pTHXx) PL_utf8_idcont = NULL; PL_utf8_foldclosures = NULL; PL_AboveLatin1 = NULL; + PL_InBitmap = NULL; PL_HasMultiCharFold = NULL; PL_Latin1 = NULL; PL_NonL1NonFinalFold = NULL; PL_UpperLatin1 = NULL; for (i = 0; i < POSIX_CC_COUNT; i++) { - SvREFCNT_dec(PL_Posix_ptrs[i]); - PL_Posix_ptrs[i] = NULL; - - SvREFCNT_dec(PL_L1Posix_ptrs[i]); - PL_L1Posix_ptrs[i] = NULL; - SvREFCNT_dec(PL_XPosix_ptrs[i]); PL_XPosix_ptrs[i] = NULL; } @@ -1353,8 +1364,11 @@ perl_free(pTHXx) "free this thread's memory\n"); PL_debug &= ~ DEBUG_m_FLAG; } - while(aTHXx->Imemory_debug_header.next != &(aTHXx->Imemory_debug_header)) - safesysfree(sTHX + (char *)(aTHXx->Imemory_debug_header.next)); + while(aTHXx->Imemory_debug_header.next != &(aTHXx->Imemory_debug_header)){ + char * next = (char *)(aTHXx->Imemory_debug_header.next); + Malloc_t ptr = PERL_MEMORY_DEBUG_HEADER_SIZE + next; + safesysfree(ptr); + } PL_debug = old_debug; } } @@ -1412,92 +1426,12 @@ perl_fini(void) void Perl_call_atexit(pTHX_ ATEXIT_t fn, void *ptr) { - dVAR; Renew(PL_exitlist, PL_exitlistlen+1, PerlExitListEntry); PL_exitlist[PL_exitlistlen].fn = fn; PL_exitlist[PL_exitlistlen].ptr = ptr; ++PL_exitlistlen; } -STATIC void -S_set_caret_X(pTHX) { - dVAR; - GV* tmpgv = gv_fetchpvs("\030", GV_ADD|GV_NOTQUAL, SVt_PV); /* $^X */ - if (tmpgv) { - SV *const caret_x = GvSV(tmpgv); -#if defined(OS2) - sv_setpv(caret_x, os2_execname(aTHX)); -#else -# ifdef USE_KERN_PROC_PATHNAME - size_t size = 0; - int mib[4]; - mib[0] = CTL_KERN; - mib[1] = KERN_PROC; - mib[2] = KERN_PROC_PATHNAME; - mib[3] = -1; - - if (sysctl(mib, 4, NULL, &size, NULL, 0) == 0 - && size > 0 && size < MAXPATHLEN * MAXPATHLEN) { - sv_grow(caret_x, size); - - if (sysctl(mib, 4, SvPVX(caret_x), &size, NULL, 0) == 0 - && size > 2) { - SvPOK_only(caret_x); - SvCUR_set(caret_x, size - 1); - SvTAINT(caret_x); - return; - } - } -# elif defined(USE_NSGETEXECUTABLEPATH) - char buf[1]; - uint32_t size = sizeof(buf); - - _NSGetExecutablePath(buf, &size); - if (size < MAXPATHLEN * MAXPATHLEN) { - sv_grow(caret_x, size); - if (_NSGetExecutablePath(SvPVX(caret_x), &size) == 0) { - char *const tidied = realpath(SvPVX(caret_x), NULL); - if (tidied) { - sv_setpv(caret_x, tidied); - free(tidied); - } else { - SvPOK_only(caret_x); - SvCUR_set(caret_x, size); - } - return; - } - } -# elif defined(HAS_PROCSELFEXE) - char buf[MAXPATHLEN]; - int len = readlink(PROCSELFEXE_PATH, buf, sizeof(buf) - 1); - - /* On Playstation2 Linux V1.0 (kernel 2.2.1) readlink(/proc/self/exe) - includes a spurious NUL which will cause $^X to fail in system - or backticks (this will prevent extensions from being built and - many tests from working). readlink is not meant to add a NUL. - Normal readlink works fine. - */ - if (len > 0 && buf[len-1] == '\0') { - len--; - } - - /* FreeBSD's implementation is acknowledged to be imperfect, sometimes - returning the text "unknown" from the readlink rather than the path - to the executable (or returning an error from the readlink). Any - valid path has a '/' in it somewhere, so use that to validate the - result. See http://www.freebsd.org/cgi/query-pr.cgi?pr=35703 - */ - if (len > 0 && memchr(buf, '/', len)) { - sv_setpvn(caret_x, buf, len); - return; - } -# endif - /* Fallback to this: */ - sv_setpv(caret_x, PL_origargv[0]); -#endif - } -} - /* =for apidoc perl_parse @@ -1528,7 +1462,7 @@ perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env) { const char * const s = PerlEnv_getenv("PERL_HASH_SEED_DEBUG"); - if (s && (atoi(s) == 1)) { + if (s && (grok_atou(s, NULL) == 1)) { unsigned char *seed= PERL_HASH_SEED; unsigned char *seed_end= PERL_HASH_SEED + PERL_HASH_SEED_BYTES; PerlIO_printf(Perl_debug_log, "HASH_FUNCTION = %s HASH_SEED = 0x", PERL_HASH_FUNC); @@ -1560,8 +1494,7 @@ perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env) * --jhi */ const char *s = NULL; int i; - const UV mask = - ~(UV)(PTRSIZE == 4 ? 3 : PTRSIZE == 8 ? 7 : PTRSIZE == 16 ? 15 : 0); + const UV mask = ~(UV)(PTRSIZE-1); /* Do the mask check only if the args seem like aligned. */ const UV aligned = (mask < ~(UV)0) && ((PTR2UV(argv[0]) & mask) == PTR2UV(argv[0])); @@ -1647,7 +1580,7 @@ perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env) init_ids(); assert (!TAINT_get); TAINT; - S_set_caret_X(aTHX); + set_caret_X(); TAINT_NOT; init_postdump_symbols(argc,argv,env); return 0; @@ -1680,7 +1613,7 @@ perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env) break; case 1: STATUS_ALL_FAILURE; - /* FALL THROUGH */ + /* FALLTHROUGH */ case 2: /* my_exit() was called */ while (PL_scopestack_ix > oldscope) @@ -1734,6 +1667,9 @@ S_Internals_V(pTHX_ CV *cv) # ifdef NO_TAINT_SUPPORT " NO_TAINT_SUPPORT" # endif +# ifdef PERL_BOOL_AS_CHAR + " PERL_BOOL_AS_CHAR" +# endif # ifdef PERL_DISABLE_PMC " PERL_DISABLE_PMC" # endif @@ -1928,9 +1864,9 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) break; case 't': -#if SILENT_NO_TAINT_SUPPORT +#if defined(SILENT_NO_TAINT_SUPPORT) /* silently ignore */ -#elif NO_TAINT_SUPPORT +#elif defined(NO_TAINT_SUPPORT) Perl_croak_nocontext("This perl was compiled without taint support. " "Cowardly refusing to run with -t or -T flags"); #else @@ -1943,9 +1879,9 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) s++; goto reswitch; case 'T': -#if SILENT_NO_TAINT_SUPPORT +#if defined(SILENT_NO_TAINT_SUPPORT) /* silently ignore */ -#elif NO_TAINT_SUPPORT +#elif defined(NO_TAINT_SUPPORT) Perl_croak_nocontext("This perl was compiled without taint support. " "Cowardly refusing to run with -t or -T flags"); #else @@ -1958,7 +1894,7 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) case 'E': PL_minus_E = TRUE; - /* FALL THROUGH */ + /* FALLTHROUGH */ case 'e': forbid_setid('e', FALSE); if (!PL_e_script) { @@ -2039,7 +1975,7 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) if (strEQ(s, "help")) usage(); s--; - /* FALL THROUGH */ + /* FALLTHROUGH */ default: Perl_croak(aTHX_ "Unrecognized switch: -%s (-h will show valid options)",s); } @@ -2060,9 +1996,9 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) while (isSPACE(*s)) s++; if (*s == '-' && *(s+1) == 'T') { -#if SILENT_NO_TAINT_SUPPORT +#if defined(SILENT_NO_TAINT_SUPPORT) /* silently ignore */ -#elif NO_TAINT_SUPPORT +#elif defined(NO_TAINT_SUPPORT) Perl_croak_nocontext("This perl was compiled without taint support. " "Cowardly refusing to run with -t or -T flags"); #else @@ -2099,9 +2035,9 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) } } if (*d == 't') { -#if SILENT_NO_TAINT_SUPPORT +#if defined(SILENT_NO_TAINT_SUPPORT) /* silently ignore */ -#elif NO_TAINT_SUPPORT +#elif defined(NO_TAINT_SUPPORT) Perl_croak_nocontext("This perl was compiled without taint support. " "Cowardly refusing to run with -t or -T flags"); #else @@ -2122,7 +2058,7 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) /* and for SITELIB_EXP in USE_SITECUSTOMIZE */ assert (!TAINT_get); TAINT; - S_set_caret_X(aTHX); + set_caret_X(); TAINT_NOT; #if defined(USE_SITECUSTOMIZE) @@ -2140,9 +2076,10 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) it should be reported immediately as a build failure. */ (void)Perl_av_create_and_unshift_one(aTHX_ &PL_preambleav, Perl_newSVpvf(aTHX_ - "BEGIN { do {local $!; -f q%c%"SVf"/buildcustomize.pl%c} and do q%c%"SVf"/buildcustomize.pl%c || die $@ }", - 0, *inc0, 0, - 0, *inc0, 0)); + "BEGIN { my $f = q%c%s%"SVf"/buildcustomize.pl%c; " + "do {local $!; -f $f }" + " and do $f || die $@ || qq '$f: $!' }", + 0, (TAINTING_get ? "./" : ""), SVfARG(*inc0), 0)); } # else /* SITELIB_EXP is a function call on Win32. */ @@ -2155,8 +2092,8 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) (void)Perl_av_create_and_unshift_one(aTHX_ &PL_preambleav, Perl_newSVpvf(aTHX_ "BEGIN { do {local $!; -f q%c%s/sitecustomize.pl%c} && do q%c%s/sitecustomize.pl%c }", - 0, sitelib, 0, - 0, sitelib, 0)); + 0, SVfARG(sitelib), 0, + 0, SVfARG(sitelib), 0)); assert (SvREFCNT(sitelib_sv) == 1); SvREFCNT_dec(sitelib_sv); } @@ -2226,7 +2163,7 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) PL_main_cv = PL_compcv = MUTABLE_CV(newSV_type(SVt_PVCV)); CvUNIQUE_on(PL_compcv); - CvPADLIST(PL_compcv) = pad_new(0); + CvPADLIST_set(PL_compcv, pad_new(0)); PL_isarev = newHV(); @@ -2318,32 +2255,6 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) } } -#ifdef PERL_MAD - { - const char *s; - if (!TAINTING_get && - (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", NULL); /* hide from subprocs */ - } - } - - { - const char *s; - if ((s = PerlEnv_getenv("PERL_MADSKILLS"))) { - PL_madskills = atoi(s); - my_setenv("PERL_MADSKILLS", NULL); /* hide from subprocs */ - } - } -#endif lex_start(linestr_sv, rsfp, lex_start_flags); SvREFCNT_dec(linestr_sv); @@ -2386,8 +2297,8 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) #ifdef MYMALLOC { const char *s; - if ((s=PerlEnv_getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2) - dump_mstats("after compilation:"); + if ((s=PerlEnv_getenv("PERL_DEBUG_MSTATS")) && grok_atou(s, NULL) >= 2) + dump_mstats("after compilation:"); } #endif @@ -2408,7 +2319,6 @@ Tells a Perl interpreter to run. See L. int perl_run(pTHXx) { - dVAR; I32 oldscope; int ret = 0; dJMPENV; @@ -2431,7 +2341,7 @@ perl_run(pTHXx) case 0: /* normal completion */ redo_body: run_body(oldscope); - /* FALL THROUGH */ + /* FALLTHROUGH */ case 2: /* my_exit() */ while (PL_scopestack_ix > oldscope) LEAVE; @@ -2466,18 +2376,11 @@ perl_run(pTHXx) STATIC void S_run_body(pTHX_ I32 oldscope) { - dVAR; DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support (0x%x).\n", PL_sawampersand ? "Enabling" : "Omitting", (unsigned int)(PL_sawampersand))); if (!PL_restartop) { -#ifdef PERL_MAD - if (PL_xmlfp) { - xmldump_all(); - exit(0); /* less likely to core dump than my_exit(0) */ - } -#endif #ifdef DEBUGGING if (DEBUG_x_TEST || DEBUG_B_TEST) dump_all_perl(!DEBUG_B_TEST); @@ -2490,7 +2393,7 @@ S_run_body(pTHX_ I32 oldscope) my_exit(0); } if (PERLDB_SINGLE && PL_DBsingle) - sv_setiv(PL_DBsingle, 1); + PL_DBsingle_iv = 1; if (PL_initav) { PERL_SET_PHASE(PERL_PHASE_INIT); call_list(oldscope, PL_initav); @@ -2526,7 +2429,7 @@ S_run_body(pTHX_ I32 oldscope) =for apidoc p||get_sv Returns the SV of the specified Perl scalar. C are passed to -C. If C is set and the +C. If C is set and the Perl variable does not exist then it will be created. If C is zero and the variable does not exist then NULL is returned. @@ -2553,7 +2456,7 @@ Perl_get_sv(pTHX_ const char *name, I32 flags) Returns the AV of the specified Perl global or package array with the given name (so it won't work on lexical variables). C are passed -to C. If C is set and the +to C. If C is set and the Perl variable does not exist then it will be created. If C is zero and the variable does not exist then NULL is returned. @@ -2582,7 +2485,7 @@ Perl_get_av(pTHX_ const char *name, I32 flags) =for apidoc p||get_hv Returns the HV of the specified Perl hash. C are passed to -C. If C is set and the +C. If C is set and the Perl variable does not exist then it will be created. If C is zero and the variable does not exist then NULL is returned. @@ -2609,7 +2512,7 @@ Perl_get_hv(pTHX_ const char *name, I32 flags) =for apidoc p||get_cvn_flags Returns the CV of the specified Perl subroutine. C are passed to -C. If C is set and the Perl subroutine does not +C. If C is set and the Perl subroutine does not exist then it will be declared (which has the same effect as saying C). If C is not set and the subroutine does not exist then NULL is returned. @@ -2658,7 +2561,8 @@ Perl_get_cv(pTHX_ const char *name, I32 flags) =for apidoc p||call_argv Performs a callback to the specified named and package-scoped Perl subroutine -with C (a NULL-terminated array of strings) as arguments. See L. +with C (a NULL-terminated array of strings) as arguments. See +L. Approximate Perl equivalent: C<&{"$sub_name"}(@$argv)>. @@ -2671,7 +2575,6 @@ Perl_call_argv(pTHX_ const char *sub_name, I32 flags, char **argv) /* See G_* flags in cop.h */ /* null terminated arg list */ { - dVAR; dSP; PERL_ARGS_ASSERT_CALL_ARGV; @@ -2747,8 +2650,7 @@ Perl_call_sv(pTHX_ SV *sv, VOL I32 flags) { dVAR; dSP; LOGOP myop; /* fake syntax tree node */ - UNOP method_unop; - SVOP method_svop; + METHOP method_op; I32 oldmark; VOL I32 retval = 0; I32 oldscope; @@ -2792,23 +2694,19 @@ Perl_call_sv(pTHX_ SV *sv, VOL I32 flags) myop.op_private |= OPpENTERSUB_DB; if (flags & (G_METHOD|G_METHOD_NAMED)) { + Zero(&method_op, 1, METHOP); + method_op.op_next = (OP*)&myop; + PL_op = (OP*)&method_op; if ( flags & G_METHOD_NAMED ) { - Zero(&method_svop, 1, SVOP); - method_svop.op_next = (OP*)&myop; - method_svop.op_ppaddr = PL_ppaddr[OP_METHOD_NAMED]; - method_svop.op_type = OP_METHOD_NAMED; - method_svop.op_sv = sv; - PL_op = (OP*)&method_svop; + method_op.op_ppaddr = PL_ppaddr[OP_METHOD_NAMED]; + method_op.op_type = OP_METHOD_NAMED; + method_op.op_u.op_meth_sv = sv; } else { - Zero(&method_unop, 1, UNOP); - method_unop.op_next = (OP*)&myop; - method_unop.op_ppaddr = PL_ppaddr[OP_METHOD]; - method_unop.op_type = OP_METHOD; - PL_op = (OP*)&method_unop; + method_op.op_ppaddr = PL_ppaddr[OP_METHOD]; + method_op.op_type = OP_METHOD; } myop.op_ppaddr = PL_ppaddr[OP_ENTERSUB]; myop.op_type = OP_ENTERSUB; - } if (!(flags & G_EVAL)) { @@ -2836,7 +2734,7 @@ Perl_call_sv(pTHX_ SV *sv, VOL I32 flags) break; case 1: STATUS_ALL_FAILURE; - /* FALL THROUGH */ + /* FALLTHROUGH */ case 2: /* my_exit() was called */ SET_CURSTASH(PL_defstash); @@ -2881,8 +2779,8 @@ Perl_call_sv(pTHX_ SV *sv, VOL I32 flags) /* =for apidoc p||eval_sv -Tells Perl to C the string in the SV. It supports the same flags -as C, with the obvious exception of G_EVAL. See L. +Tells Perl to C the string in the SV. It supports the same flags +as C, with the obvious exception of G_EVAL. See L. =cut */ @@ -2945,7 +2843,7 @@ Perl_eval_sv(pTHX_ SV *sv, I32 flags) break; case 1: STATUS_ALL_FAILURE; - /* FALL THROUGH */ + /* FALLTHROUGH */ case 2: /* my_exit() was called */ SET_CURSTASH(PL_defstash); @@ -2985,7 +2883,7 @@ Perl_eval_sv(pTHX_ SV *sv, I32 flags) /* =for apidoc p||eval_pv -Tells Perl to C the given string and return an SV* result. +Tells Perl to C the given string in scalar context and return an SV* result. =cut */ @@ -2993,7 +2891,6 @@ Tells Perl to C the given string and return an SV* result. SV* Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error) { - dVAR; SV* sv = newSVpv(p, 0); PERL_ARGS_ASSERT_EVAL_PV; @@ -3034,17 +2931,14 @@ implemented that way; consider using load_module instead. void Perl_require_pv(pTHX_ const char *pv) { - dVAR; dSP; SV* sv; PERL_ARGS_ASSERT_REQUIRE_PV; PUSHSTACKi(PERLSI_REQUIRE); - PUTBACK; sv = Perl_newSVpvf(aTHX_ "require q%c%s%c", 0, pv, 0); eval_sv(sv_2mortal(sv), G_DISCARD); - SPAGAIN; POPSTACK; } @@ -3134,6 +3028,7 @@ Perl_get_debug_opts(pTHX_ const char **s, bool givehelp) " q quiet - currently only suppresses the 'EXECUTING' message\n" " M trace smart match resolution\n" " B dump suBroutine definitions, including special Blocks like BEGIN\n", + " L trace some locale setting information--for Perl core development\n", NULL }; int i = 0; @@ -3142,7 +3037,7 @@ Perl_get_debug_opts(pTHX_ const char **s, bool givehelp) if (isALPHA(**s)) { /* if adding extra options, remember to update DEBUG_MASK */ - static const char debopts[] = "psltocPmfrxuUHXDSTRJvCAqMB"; + static const char debopts[] = "psltocPmfrxuUHXDSTRJvCAqMBL"; for (; isWORDCHAR(**s); (*s)++) { const char * const d = strchr(debopts,**s); @@ -3154,7 +3049,10 @@ Perl_get_debug_opts(pTHX_ const char **s, bool givehelp) } } else if (isDIGIT(**s)) { - i = atoi(*s); + const char* e; + i = grok_atou(*s, &e); + if (e) + *s = e; for (; isWORDCHAR(**s); (*s)++) ; } else if (givehelp) { @@ -3380,7 +3278,7 @@ Perl_moreswitches(pTHX_ const char *s) return s; case 'M': forbid_setid('M', FALSE); /* XXX ? */ - /* FALL THROUGH */ + /* FALLTHROUGH */ case 'm': forbid_setid('m', FALSE); /* XXX ? */ if (*++s) { @@ -3448,9 +3346,9 @@ Perl_moreswitches(pTHX_ const char *s) return s; case 't': case 'T': -#if SILENT_NO_TAINT_SUPPORT +#if defined(SILENT_NO_TAINT_SUPPORT) /* silently ignore */ -#elif NO_TAINT_SUPPORT +#elif defined(NO_TAINT_SUPPORT) Perl_croak_nocontext("This perl was compiled without taint support. " "Cowardly refusing to run with -t or -T flags"); #else @@ -3527,38 +3425,43 @@ STATIC void S_minus_v(pTHX) { PerlIO * PIO_stdout; - if (!sv_derived_from(PL_patchlevel, "version")) - upg_version(PL_patchlevel, TRUE); { - SV* level= vstringify(PL_patchlevel); + const char * const level_str = "v" PERL_VERSION_STRING; + const STRLEN level_len = sizeof("v" PERL_VERSION_STRING)-1; #ifdef PERL_PATCHNUM + SV* level; # ifdef PERL_GIT_UNCOMMITTED_CHANGES - SV *num = newSVpvs(PERL_PATCHNUM "*"); + static const char num [] = PERL_PATCHNUM "*"; # else - SV *num = newSVpvs(PERL_PATCHNUM); + static const char num [] = PERL_PATCHNUM; # endif { - STRLEN level_len, num_len; - char * level_str, * num_str; - num_str = SvPV(num, num_len); - level_str = SvPV(level, level_len); - if (num_len>=level_len && strnEQ(num_str,level_str,level_len)) { - SvREFCNT_dec(level); - level= num; + const STRLEN num_len = sizeof(num)-1; + /* A very advanced compiler would fold away the strnEQ + and this whole conditional, but most (all?) won't do it. + SV level could also be replaced by with preprocessor + catenation. + */ + if (num_len >= level_len && strnEQ(num,level_str,level_len)) { + /* per 46807d8e80, PERL_PATCHNUM is outside of the control + of the interp so it might contain format characters + */ + level = newSVpvn(num, num_len); } else { - Perl_sv_catpvf(aTHX_ level, " (%"SVf")", num); - SvREFCNT_dec(num); + level = Perl_newSVpvf_nocontext("%s (%s)", level_str, num); } } - #endif +#else + SV* level = newSVpvn(level_str, level_len); +#endif /* #ifdef PERL_PATCHNUM */ PIO_stdout = PerlIO_stdout(); PerlIO_printf(PIO_stdout, "\nThis is perl " STRINGIFY(PERL_REVISION) ", version " STRINGIFY(PERL_VERSION) ", subversion " STRINGIFY(PERL_SUBVERSION) - " (%"SVf") built for " ARCHNAME, level + " (%"SVf") built for " ARCHNAME, SVfARG(level) ); - SvREFCNT_dec(level); + SvREFCNT_dec_NN(level); } #if defined(LOCAL_PATCH_COUNT) if (LOCAL_PATCH_COUNT > 0) @@ -3570,7 +3473,7 @@ S_minus_v(pTHX) #endif PerlIO_printf(PIO_stdout, - "\n\nCopyright 1987-2013, Larry Wall\n"); + "\n\nCopyright 1987-2014, Larry Wall\n"); #ifdef MSDOS PerlIO_printf(PIO_stdout, "\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n"); @@ -3632,7 +3535,6 @@ 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 = newSVpv(BIN_EXP, 0); SV * file = newSVpv(PL_origfilename, 0); @@ -3646,10 +3548,11 @@ Perl_my_unexec(pTHX) /* unexec prints msg to stderr in case of failure */ PerlProc_exit(status); #else + PERL_UNUSED_CONTEXT; # ifdef VMS lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */ # elif defined(WIN32) || defined(__CYGWIN__) - Perl_croak(aTHX_ "dump is not supported"); + Perl_croak_nocontext("dump is not supported"); # else ABORT(); /* for use with undump */ # endif @@ -3660,7 +3563,6 @@ Perl_my_unexec(pTHX) STATIC void S_init_interp(pTHX) { - dVAR; #ifdef MULTIPLICITY # define PERLVAR(prefix,var,type) # define PERLVARA(prefix,var,n,type) @@ -3693,7 +3595,6 @@ S_init_interp(pTHX) STATIC void S_init_main_stash(pTHX) { - dVAR; GV *gv; PL_curstash = PL_defstash = (HV *)SvREFCNT_inc_simple_NN(newHV()); @@ -3715,13 +3616,15 @@ S_init_main_stash(pTHX) SvREFCNT_inc_simple_void(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 */ + SvREFCNT_inc_simple_void(PL_hintgv); GvMULTI_on(PL_hintgv); PL_defgv = gv_fetchpvs("_", GV_ADD|GV_NOTQUAL, SVt_PVAV); SvREFCNT_inc_simple_void(PL_defgv); - PL_errgv = gv_HVadd(gv_fetchpvs("@", GV_ADD|GV_NOTQUAL, SVt_PV)); + PL_errgv = gv_fetchpvs("@", GV_ADD|GV_NOTQUAL, SVt_PV); SvREFCNT_inc_simple_void(PL_errgv); GvMULTI_on(PL_errgv); PL_replgv = gv_fetchpvs("\022", GV_ADD|GV_NOTQUAL, SVt_PV); /* ^R */ + SvREFCNT_inc_simple_void(PL_replgv); GvMULTI_on(PL_replgv); (void)Perl_form(aTHX_ "%240s",""); /* Preallocate temp - for immediate signals. */ #ifdef PERL_DONT_CREATE_GVSV @@ -3743,8 +3646,8 @@ S_open_script(pTHX_ const char *scriptname, bool dosearch, bool *suidscript) { int fdscript = -1; PerlIO *rsfp = NULL; - dVAR; Stat_t tmpstatbuf; + int fd; PERL_ARGS_ASSERT_OPEN_SCRIPT; @@ -3757,9 +3660,9 @@ S_open_script(pTHX_ const char *scriptname, bool dosearch, bool *suidscript) if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) { const char *s = scriptname + 8; - fdscript = atoi(s); - while (isDIGIT(*s)) - s++; + const char* e; + fdscript = grok_atou(s, &e); + s = e; if (*s) { /* PSz 18 Feb 04 * Tell apart "normal" usage of fdscript, e.g. @@ -3817,7 +3720,9 @@ S_open_script(pTHX_ const char *scriptname, bool dosearch, bool *suidscript) const char * const err = "Failed to create a fake bit bucket"; if (strEQ(scriptname, BIT_BUCKET)) { #ifdef HAS_MKSTEMP /* Hopefully mkstemp() is safe here. */ + int old_umask = umask(0600); int tmpfd = mkstemp(tmpname); + umask(old_umask); if (tmpfd > -1) { scriptname = tmpname; close(tmpfd); @@ -3850,13 +3755,20 @@ S_open_script(pTHX_ const char *scriptname, bool dosearch, bool *suidscript) Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n", CopFILE(PL_curcop), Strerror(errno)); } + fd = PerlIO_fileno(rsfp); #if defined(HAS_FCNTL) && defined(F_SETFD) - /* ensure close-on-exec */ - fcntl(PerlIO_fileno(rsfp), F_SETFD, 1); + if (fd >= 0) { + /* ensure close-on-exec */ + if (fcntl(fd, F_SETFD, 1) < 0) { + Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n", + CopFILE(PL_curcop), Strerror(errno)); + } + } #endif - if (PerlLIO_fstat(PerlIO_fileno(rsfp), &tmpstatbuf) >= 0 - && S_ISDIR(tmpstatbuf.st_mode)) + if (fd < 0 || + (PerlLIO_fstat(fd, &tmpstatbuf) >= 0 + && S_ISDIR(tmpstatbuf.st_mode))) Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n", CopFILE(PL_curcop), Strerror(EISDIR)); @@ -3887,12 +3799,18 @@ S_validate_suid(pTHX_ PerlIO *rsfp) if (my_euid != my_uid || my_egid != my_gid) { /* (suidperl doesn't exist, in fact) */ dVAR; - - PerlLIO_fstat(PerlIO_fileno(rsfp),&PL_statbuf); /* may be either wrapped or real suid */ - if ((my_euid != my_uid && my_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID) - || - (my_egid != my_gid && my_egid == PL_statbuf.st_gid && PL_statbuf.st_mode & S_ISGID) - ) + int fd = PerlIO_fileno(rsfp); + if (fd < 0) { + Perl_croak(aTHX_ "Illegal suidscript"); + } else { + if (PerlLIO_fstat(fd, &PL_statbuf) < 0) { /* may be either wrapped or real suid */ + Perl_croak(aTHX_ "Illegal suidscript"); + } + } + if ((my_euid != my_uid && my_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID) + || + (my_egid != my_gid && my_egid == PL_statbuf.st_gid && PL_statbuf.st_mode & S_ISGID) + ) if (!PL_do_undump) Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\ FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n"); @@ -3904,7 +3822,6 @@ FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n"); STATIC void S_find_beginning(pTHX_ SV* linestr_sv, PerlIO *rsfp) { - dVAR; const char *s; const char *s2; @@ -3936,13 +3853,14 @@ S_init_ids(pTHX) { /* no need to do anything here any more if we don't * do tainting. */ -#if !NO_TAINT_SUPPORT - dVAR; +#ifndef NO_TAINT_SUPPORT const Uid_t my_uid = PerlProc_getuid(); const Uid_t my_euid = PerlProc_geteuid(); const Gid_t my_gid = PerlProc_getgid(); const Gid_t my_egid = PerlProc_getegid(); + PERL_UNUSED_CONTEXT; + /* Should not happen: */ CHECK_MALLOC_TAINT(my_uid && (my_euid != my_uid || my_egid != my_gid)); TAINTING_set( TAINTING_get | (my_uid && (my_euid != my_uid || my_egid != my_gid)) ); @@ -3990,7 +3908,7 @@ Perl_doing_taint(int argc, char *argv[], char *envp[]) * if -T are the first chars together; otherwise one gets * "Too late" message. */ if ( argc > 1 && argv[1][0] == '-' - && (argv[1][1] == 't' || argv[1][1] == 'T') ) + && isALPHA_FOLD_EQ(argv[1][1], 't')) return 1; return 0; } @@ -4002,10 +3920,10 @@ Perl_doing_taint(int argc, char *argv[], char *envp[]) STATIC void S_forbid_setid(pTHX_ const char flag, const bool suidscript) /* g */ { - dVAR; char string[3] = "-x"; const char *message = "program input from stdin"; + PERL_UNUSED_CONTEXT; if (flag) { string[1] = flag; message = string; @@ -4042,8 +3960,8 @@ Perl_init_dbargs(pTHX) void Perl_init_debugger(pTHX) { - dVAR; HV * const ostash = PL_curstash; + MAGIC *mg; PL_curstash = (HV *)SvREFCNT_inc_simple(PL_debstash); @@ -4060,26 +3978,39 @@ Perl_init_debugger(pTHX) PL_DBsingle = GvSV((gv_fetchpvs("DB::single", GV_ADDMULTI, SVt_PV))); if (!SvIOK(PL_DBsingle)) sv_setiv(PL_DBsingle, 0); + mg = sv_magicext(PL_DBsingle, NULL, PERL_MAGIC_debugvar, &PL_vtbl_debugvar, 0, 0); + mg->mg_private = DBVARMG_SINGLE; + SvSETMAGIC(PL_DBsingle); + PL_DBtrace = GvSV((gv_fetchpvs("DB::trace", GV_ADDMULTI, SVt_PV))); if (!SvIOK(PL_DBtrace)) sv_setiv(PL_DBtrace, 0); + mg = sv_magicext(PL_DBtrace, NULL, PERL_MAGIC_debugvar, &PL_vtbl_debugvar, 0, 0); + mg->mg_private = DBVARMG_TRACE; + SvSETMAGIC(PL_DBtrace); + PL_DBsignal = GvSV((gv_fetchpvs("DB::signal", GV_ADDMULTI, SVt_PV))); if (!SvIOK(PL_DBsignal)) sv_setiv(PL_DBsignal, 0); + mg = sv_magicext(PL_DBsignal, NULL, PERL_MAGIC_debugvar, &PL_vtbl_debugvar, 0, 0); + mg->mg_private = DBVARMG_SIGNAL; + SvSETMAGIC(PL_DBsignal); + SvREFCNT_dec(PL_curstash); PL_curstash = ostash; } #ifndef STRESS_REALLOC #define REASONABLE(size) (size) +#define REASONABLE_but_at_least(size,min) (size) #else #define REASONABLE(size) (1) /* unreasonable */ +#define REASONABLE_but_at_least(size,min) (min) #endif void Perl_init_stacks(pTHX) { - dVAR; /* start with 128-item stack and 8K cxstack */ PL_curstackinfo = new_stackinfo(REASONABLE(128), REASONABLE(8192/sizeof(PERL_CONTEXT) - 1)); @@ -4109,9 +4040,9 @@ Perl_init_stacks(pTHX) PL_scopestack_ix = 0; PL_scopestack_max = REASONABLE(32); - Newx(PL_savestack,REASONABLE(128),ANY); + Newx(PL_savestack,REASONABLE_but_at_least(128,SS_MAXPUSH),ANY); PL_savestack_ix = 0; - PL_savestack_max = REASONABLE(128); + PL_savestack_max = REASONABLE_but_at_least(128,SS_MAXPUSH); } #undef REASONABLE @@ -4119,7 +4050,6 @@ Perl_init_stacks(pTHX) STATIC void S_nuke_stacks(pTHX) { - dVAR; while (PL_curstackinfo->si_next) PL_curstackinfo = PL_curstackinfo->si_next; while (PL_curstackinfo) { @@ -4175,7 +4105,6 @@ Perl_populate_isa(pTHX_ const char *name, STRLEN len, ...) STATIC void S_init_predump_symbols(pTHX) { - dVAR; GV *tmpgv; IO *io; @@ -4236,8 +4165,6 @@ S_init_predump_symbols(pTHX) void Perl_init_argv_symbols(pTHX_ int argc, char **argv) { - dVAR; - PERL_ARGS_ASSERT_INIT_ARGV_SYMBOLS; argc--,argv++; /* skip name of script */ @@ -4260,6 +4187,7 @@ Perl_init_argv_symbols(pTHX_ int argc, char **argv) } } if ((PL_argvgv = gv_fetchpvs("ARGV", GV_ADD|GV_NOTQUAL, SVt_PVAV))) { + SvREFCNT_inc_simple_void_NN(PL_argvgv); GvMULTI_on(PL_argvgv); av_clear(GvAVn(PL_argvgv)); for (; argc > 0; argc--,argv++) { @@ -4283,7 +4211,9 @@ Perl_init_argv_symbols(pTHX_ int argc, char **argv) STATIC void S_init_postdump_symbols(pTHX_ int argc, char **argv, char **env) { +#ifdef USE_ITHREADS dVAR; +#endif GV* tmpgv; PERL_ARGS_ASSERT_INIT_POSTDUMP_SYMBOLS; @@ -4360,7 +4290,6 @@ S_init_postdump_symbols(pTHX_ int argc, char **argv, char **env) STATIC void S_init_perllib(pTHX) { - dVAR; #ifndef VMS const char *perl5lib = NULL; #endif @@ -4566,7 +4495,6 @@ S_init_perllib(pTHX) STATIC SV * S_incpush_if_exists(pTHX_ AV *const av, SV *dir, SV *const stem) { - dVAR; Stat_t tmpstatbuf; PERL_ARGS_ASSERT_INCPUSH_IF_EXISTS; @@ -4605,7 +4533,7 @@ S_mayberelocate(pTHX_ const char *const dir, STRLEN len, U32 flags) if ((unix = tounixspec_ts(SvPV(libdir,len),NULL)) != NULL) { len = strlen(unix); - while (unix[len-1] == '/') len--; /* Cosmetic */ + while (len > 1 && unix[len-1] == '/') len--; /* Cosmetic */ sv_usepvn(libdir,unix,len); } else @@ -4721,7 +4649,6 @@ S_mayberelocate(pTHX_ const char *const dir, STRLEN len, U32 flags) STATIC void S_incpush(pTHX_ const char *const dir, STRLEN len, U32 flags) { - dVAR; #ifndef PERL_IS_MINIPERL const U8 using_sub_dirs = (U8)flags & (INCPUSH_ADD_VERSIONED_SUB_DIRS @@ -4803,7 +4730,7 @@ S_incpush(pTHX_ const char *const dir, STRLEN len, U32 flags) #ifdef PERL_IS_MINIPERL const Size_t extra = 0; #else - Size_t extra = av_len(av) + 1; + Size_t extra = av_tindex(av) + 1; #endif av_unshift(inc, extra + push_basedir); if (push_basedir) @@ -4880,7 +4807,6 @@ S_incpush_use_sep(pTHX_ const char *p, STRLEN len, U32 flags) void Perl_call_list(pTHX_ I32 oldscope, AV *paramList) { - dVAR; SV *atsv; volatile const line_t oldline = PL_curcop ? CopLINE(PL_curcop) : 0; CV *cv; @@ -4890,7 +4816,7 @@ Perl_call_list(pTHX_ I32 oldscope, AV *paramList) PERL_ARGS_ASSERT_CALL_LIST; - while (av_len(paramList) >= 0) { + while (av_tindex(paramList) >= 0) { cv = MUTABLE_CV(av_shift(paramList)); if (PL_savebegin) { if (paramList == PL_beginav) { @@ -4906,21 +4832,12 @@ Perl_call_list(pTHX_ I32 oldscope, AV *paramList) Perl_av_create_and_push(aTHX_ &PL_unitcheckav_save, MUTABLE_SV(cv)); } } else { - if (!PL_madskills) - SAVEFREESV(cv); + SAVEFREESV(cv); } JMPENV_PUSH(ret); switch (ret) { case 0: -#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 (len) { @@ -4943,7 +4860,7 @@ Perl_call_list(pTHX_ I32 oldscope, AV *paramList) break; case 1: STATUS_ALL_FAILURE; - /* FALL THROUGH */ + /* FALLTHROUGH */ case 2: /* my_exit() was called */ while (PL_scopestack_ix > oldscope) @@ -4972,13 +4889,12 @@ Perl_call_list(pTHX_ I32 oldscope, AV *paramList) void Perl_my_exit(pTHX_ U32 status) { - dVAR; if (PL_exit_flags & PERL_EXIT_ABORT) { abort(); } if (PL_exit_flags & PERL_EXIT_WARN) { PL_exit_flags |= PERL_EXIT_ABORT; /* Protect against reentrant calls */ - Perl_warn(aTHX_ "Unexpected exit %u", status); + Perl_warn(aTHX_ "Unexpected exit %lu", (unsigned long)status); PL_exit_flags &= ~PERL_EXIT_ABORT; } switch (status) { @@ -4998,7 +4914,6 @@ Perl_my_exit(pTHX_ U32 status) void Perl_my_failure_exit(pTHX) { - dVAR; #ifdef VMS /* We have been called to fall on our sword. The desired exit code * should be already set in STATUS_UNIX, but could be shifted over @@ -5083,7 +4998,7 @@ Perl_my_failure_exit(pTHX) } if (PL_exit_flags & PERL_EXIT_WARN) { PL_exit_flags |= PERL_EXIT_ABORT; /* Protect against reentrant calls */ - Perl_warn(aTHX_ "Unexpected exit failure %u", PL_statusvalue); + Perl_warn(aTHX_ "Unexpected exit failure %ld", (long)PL_statusvalue); PL_exit_flags &= ~PERL_EXIT_ABORT; } my_exit_jump(); @@ -5092,8 +5007,6 @@ Perl_my_failure_exit(pTHX) STATIC void S_my_exit_jump(pTHX) { - dVAR; - if (PL_e_script) { SvREFCNT_dec(PL_e_script); PL_e_script = NULL; @@ -5109,7 +5022,6 @@ S_my_exit_jump(pTHX) static I32 read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen) { - dVAR; const char * const p = SvPVX_const(PL_e_script); const char *nl = strchr(p, '\n'); @@ -5126,6 +5038,15 @@ read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen) return 1; } +/* removes boilerplate code at the end of each boot_Module xsub */ +void +Perl_xs_boot_epilog(pTHX_ const U32 ax) +{ + if (PL_unitcheckav) + call_list(PL_scopestack_ix, PL_unitcheckav); + XSRETURN_YES; +} + /* * Local variables: * c-indentation-style: bsd