X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/fc3381af5499bfa816caad84f7e643c1a710c049..a5e668419a0ce5ec48b3586fb224eed5ace5d64c:/perl.c diff --git a/perl.c b/perl.c index a65dcb6..8271915 100644 --- a/perl.c +++ b/perl.c @@ -38,14 +38,6 @@ #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 @@ -58,10 +50,6 @@ union control_un { #endif -#ifdef __BEOS__ -# define HZ 1000000 -#endif - #ifndef HZ # ifdef CLK_TCK # define HZ CLK_TCK @@ -242,10 +230,14 @@ perl_construct(pTHXx) #endif PL_curcop = &PL_compiling; /* needed by ckWARN, right away */ +#ifdef PERL_TRACE_OPS + Zero(PL_op_exec_cnt, OP_max+2, UV); +#endif + init_constants(); SvREADONLY_on(&PL_sv_placeholder); - SvREFCNT(&PL_sv_placeholder) = (~(U32)0)/2; + SvREFCNT(&PL_sv_placeholder) = SvREFCNT_IMMORTAL; PL_sighandlerp = (Sighandler_t) Perl_sighandler; #ifdef PERL_USES_PL_PIDSTATUS @@ -290,6 +282,19 @@ perl_construct(pTHXx) #ifdef USE_REENTRANT_API Perl_reentrant_init(aTHX); #endif +#if defined(USE_HASH_SEED) || defined(USE_HASH_SEED_EXPLICIT) + /* [perl #22371] Algorimic Complexity Attack on Perl 5.6.1, 5.8.0 + * This MUST be done before any hash stores or fetches take place. + * If you set PL_hash_seed (and presumably also PL_hash_seed_set) + * yourself, it is your responsibility to provide a good random seed! + * You can also define PERL_HASH_SEED in compile time, see hv.h. + * + * XXX: fix this comment */ + if (PL_hash_seed_set == FALSE) { + Perl_get_hash_seed(aTHX_ PL_hash_seed); + PL_hash_seed_set= TRUE; + } +#endif /* #if defined(USE_HASH_SEED) || defined(USE_HASH_SEED_EXPLICIT) */ /* Note that strtab is a rather special HV. Assumptions are made about not iterating on it, and not adding tie magic to it. @@ -299,6 +304,8 @@ perl_construct(pTHXx) HvSHAREKEYS_off(PL_strtab); /* mandatory */ hv_ksplit(PL_strtab, 512); + 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); @@ -312,10 +319,9 @@ perl_construct(pTHXx) /* Use sysconf(_SC_CLK_TCK) if available, if not * available or if the sysconf() fails, use the HZ. - * BeOS has those, but returns the wrong value. * The HZ if not originally defined has been by now * been defined as CLK_TCK, if available. */ -#if defined(HAS_SYSCONF) && defined(_SC_CLK_TCK) && !defined(__BEOS__) +#if defined(HAS_SYSCONF) && defined(_SC_CLK_TCK) PL_clocktick = sysconf(_SC_CLK_TCK); if (PL_clocktick <= 0) #endif @@ -488,7 +494,7 @@ Perl_dump_sv_child(pTHX_ SV *sv) if (returned_errno || *buffer) { Perl_warn(aTHX_ "Debug leaking scalars child failed%s%.*s with errno" " %d: %s", (*buffer ? " at " : ""), (int) *buffer, buffer + 1, - returned_errno, strerror(returned_errno)); + returned_errno, Strerror(returned_errno)); } } #endif @@ -510,6 +516,7 @@ perl_destruct(pTHXx) #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP pid_t child; #endif + int i; PERL_ARGS_ASSERT_PERL_DESTRUCT; #ifndef MULTIPLICITY @@ -526,13 +533,13 @@ perl_destruct(pTHXx) { const char * const s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL"); if (s) { - const int i = atoi(s); + const int i = atoi(s); #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 } } @@ -557,6 +564,20 @@ perl_destruct(pTHXx) /* Need to flush since END blocks can produce output */ my_fflush_all(); +#ifdef PERL_TRACE_OPS + /* If we traced all Perl OP usage, report and clean up */ + PerlIO_printf(Perl_debug_log, "Trace of all OPs executed:\n"); + for (i = 0; i <= OP_max; ++i) { + PerlIO_printf(Perl_debug_log, " %s: %"UVuf"\n", PL_op_name[i], PL_op_exec_cnt[i]); + PL_op_exec_cnt[i] = 0; + } + /* Utility slot for easily doing little tracing experiments in the runloop: */ + if (PL_op_exec_cnt[OP_max+1] != 0) + PerlIO_printf(Perl_debug_log, " SPECIAL: %"UVuf"\n", PL_op_exec_cnt[OP_max+1]); + PerlIO_printf(Perl_debug_log, "\n"); +#endif + + if (PL_threadhook(aTHX)) { /* Threads hook has vetoed further cleanup */ PL_veto_cleanup = TRUE; @@ -729,6 +750,7 @@ perl_destruct(pTHXx) /* ensure comppad/curpad to refer to main's pad */ if (CvPADLIST(PL_main_cv)) { PAD_SET_CUR_NOSAVE(CvPADLIST(PL_main_cv), 1); + PL_comppad_name = PadlistNAMES(CvPADLIST(PL_main_cv)); } op_free(PL_main_root); PL_main_root = NULL; @@ -749,15 +771,12 @@ perl_destruct(pTHXx) PerlIO_destruct(aTHX); - if (PL_sv_objcount) { - /* - * Try to destruct global references. We do this first so that the - * destructors and destructees still exist. Some sv's might remain. - * Non-referenced objects are on their own. - */ - sv_clean_objs(); - PL_sv_objcount = 0; - } + /* + * Try to destruct global references. We do this first so that the + * destructors and destructees still exist. Some sv's might remain. + * Non-referenced objects are on their own. + */ + sv_clean_objs(); /* unhook hooks which will soon be, or use, destroyed data */ SvREFCNT_dec(PL_warnhook); @@ -817,6 +836,8 @@ perl_destruct(pTHXx) return STATUS_EXIT; } + /* Below, do clean up for when PERL_DESTRUCT_LEVEL is not 0 */ + #ifdef USE_ITHREADS /* the syntax tree is shared between clones * so op_free(PL_main_root) only ReREFCNT_dec's @@ -832,7 +853,6 @@ perl_destruct(pTHXx) ary[i] = &PL_sv_undef; } } - Safefree(PL_stashpad); #endif @@ -860,7 +880,9 @@ perl_destruct(pTHXx) PL_minus_F = FALSE; PL_doswitches = FALSE; PL_dowarn = G_WARN_OFF; +#ifdef PERL_SAWAMPERSAND PL_sawampersand = 0; /* must save all match strings */ +#endif PL_unsafe = FALSE; Safefree(PL_inplace); @@ -919,19 +941,12 @@ perl_destruct(pTHXx) PL_initav = NULL; /* shortcuts just get cleared */ - PL_envgv = NULL; - 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_DBgv = NULL; - PL_DBline = NULL; - PL_DBsub = NULL; PL_DBsingle = NULL; PL_DBtrace = NULL; PL_DBsignal = NULL; @@ -939,6 +954,21 @@ perl_destruct(pTHXx) 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; + SvREFCNT_dec(PL_argvout_stack); PL_argvout_stack = NULL; @@ -971,18 +1001,11 @@ perl_destruct(pTHXx) PL_numeric_radix_sv = NULL; #endif - /* clear utf8 character classes */ - SvREFCNT_dec(PL_utf8_alnum); - SvREFCNT_dec(PL_utf8_alpha); - SvREFCNT_dec(PL_utf8_blank); - SvREFCNT_dec(PL_utf8_space); - SvREFCNT_dec(PL_utf8_graph); - SvREFCNT_dec(PL_utf8_digit); - SvREFCNT_dec(PL_utf8_upper); - SvREFCNT_dec(PL_utf8_lower); - SvREFCNT_dec(PL_utf8_print); - SvREFCNT_dec(PL_utf8_punct); - SvREFCNT_dec(PL_utf8_xdigit); + /* clear character classes */ + for (i = 0; i < POSIX_SWASH_COUNT; i++) { + SvREFCNT_dec(PL_utf8_swash_ptrs[i]); + PL_utf8_swash_ptrs[i] = NULL; + } SvREFCNT_dec(PL_utf8_mark); SvREFCNT_dec(PL_utf8_toupper); SvREFCNT_dec(PL_utf8_totitle); @@ -991,17 +1014,11 @@ perl_destruct(pTHXx) SvREFCNT_dec(PL_utf8_idstart); SvREFCNT_dec(PL_utf8_idcont); SvREFCNT_dec(PL_utf8_foldclosures); - PL_utf8_alnum = NULL; - PL_utf8_alpha = NULL; - PL_utf8_blank = NULL; - PL_utf8_space = NULL; - PL_utf8_graph = NULL; - PL_utf8_digit = NULL; - PL_utf8_upper = NULL; - PL_utf8_lower = NULL; - PL_utf8_print = NULL; - PL_utf8_punct = NULL; - PL_utf8_xdigit = NULL; + SvREFCNT_dec(PL_AboveLatin1); + SvREFCNT_dec(PL_UpperLatin1); + SvREFCNT_dec(PL_Latin1); + SvREFCNT_dec(PL_NonL1NonFinalFold); + SvREFCNT_dec(PL_HasMultiCharFold); PL_utf8_mark = NULL; PL_utf8_toupper = NULL; PL_utf8_totitle = NULL; @@ -1010,6 +1027,21 @@ perl_destruct(pTHXx) PL_utf8_idstart = NULL; PL_utf8_idcont = NULL; PL_utf8_foldclosures = NULL; + PL_AboveLatin1 = 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; + } if (!specialWARN(PL_compiling.cop_warnings)) PerlMemShared_free(PL_compiling.cop_warnings); @@ -1070,6 +1102,10 @@ perl_destruct(pTHXx) while (sv_clean_all() > 2) ; +#ifdef USE_ITHREADS + Safefree(PL_stashpad); /* must come after sv_clean_all */ +#endif + AvREAL_off(PL_fdpid); /* no surviving entries */ SvREFCNT_dec(PL_fdpid); /* needed in io_close() */ PL_fdpid = NULL; @@ -1078,6 +1114,12 @@ perl_destruct(pTHXx) sys_intern_clear(); #endif + /* constant strings */ + for (i = 0; i < SV_CONSTS_COUNT; i++) { + SvREFCNT_dec(PL_sv_consts[i]); + PL_sv_consts[i] = NULL; + } + /* Destruct the global string table. */ { /* Yell and reset the HeVAL() slots that are still holding refcounts, @@ -1216,7 +1258,6 @@ perl_destruct(pTHXx) Safefree(PL_origfilename); PL_origfilename = NULL; Safefree(PL_reg_curpm); - Safefree(PL_reg_poscache); free_tied_hv_pool(); Safefree(PL_op_mask); Safefree(PL_psig_name); @@ -1230,8 +1271,8 @@ perl_destruct(pTHXx) Safefree(psig_save); } nuke_stacks(); - PL_tainting = FALSE; - PL_taint_warn = FALSE; + TAINTING_set(FALSE); + TAINT_WARN_set(FALSE); PL_hints = 0; /* Reset hints. Should hints be per-interpreter ? */ PL_debug = 0; @@ -1319,13 +1360,11 @@ perl_free(pTHXx) { # ifdef NETWARE void *host = nw_internal_host; -# else - void *host = w32_internal_host; -# endif PerlMem_free(aTHXx); -# ifdef NETWARE nw_delete_internal_host(host); # else + void *host = w32_internal_host; + PerlMem_free(aTHXx); win32_delete_internal_host(host); # endif } @@ -1354,7 +1393,11 @@ __attribute__((destructor)) perl_fini(void) { dVAR; - if (PL_curinterp && !PL_veto_cleanup) + if ( +#ifdef PERL_GLOBAL_STRUCT_PRIVATE + my_vars && +#endif + PL_curinterp && !PL_veto_cleanup) FREE_THREAD_KEY; } @@ -1371,85 +1414,6 @@ Perl_call_atexit(pTHX_ ATEXIT_t fn, void *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 @@ -1476,23 +1440,26 @@ perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env) #ifndef MULTIPLICITY PERL_UNUSED_ARG(my_perl); #endif - -#if defined(USE_HASH_SEED) || defined(USE_HASH_SEED_EXPLICIT) - /* [perl #22371] Algorimic Complexity Attack on Perl 5.6.1, 5.8.0 - * This MUST be done before any hash stores or fetches take place. - * If you set PL_rehash_seed (and presumably also PL_rehash_seed_set) - * yourself, it is your responsibility to provide a good random seed! - * You can also define PERL_HASH_SEED in compile time, see hv.h. */ - if (!PL_rehash_seed_set) - PL_rehash_seed = get_hash_seed(); +#if defined(USE_HASH_SEED) || defined(USE_HASH_SEED_EXPLICIT) || defined(USE_HASH_SEED_DEBUG) { - const char * const s = PerlEnv_getenv("PERL_HASH_SEED_DEBUG"); - - if (s && (atoi(s) == 1)) - PerlIO_printf(Perl_debug_log, "HASH_SEED = %"UVuf"\n", PL_rehash_seed); + const char * const s = PerlEnv_getenv("PERL_HASH_SEED_DEBUG"); + + if (s && (atoi(s) == 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); + while (seed < seed_end) { + PerlIO_printf(Perl_debug_log, "%02x", *seed++); + } +#ifdef PERL_HASH_RANDOMIZE_KEYS + PerlIO_printf(Perl_debug_log, " PERTURB_KEYS = %d (%s)", + PL_HASH_RAND_BITS_ENABLED, + PL_HASH_RAND_BITS_ENABLED == 0 ? "NO" : PL_HASH_RAND_BITS_ENABLED == 1 ? "RANDOM" : "DETERMINISTIC"); +#endif + PerlIO_printf(Perl_debug_log, "\n"); + } } #endif /* #if defined(USE_HASH_SEED) || defined(USE_HASH_SEED_EXPLICIT) */ - PL_origargc = argc; PL_origargv = argv; @@ -1594,9 +1561,9 @@ perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env) PL_do_undump = FALSE; cxstack_ix = -1; /* start label stack again */ init_ids(); - assert (!PL_tainted); + assert (!TAINT_get); TAINT; - S_set_caret_X(aTHX); + set_caret_X(); TAINT_NOT; init_postdump_symbols(argc,argv,env); return 0; @@ -1670,13 +1637,19 @@ S_Internals_V(pTHX_ CV *cv) #endif const int entries = 3 + local_patch_count; int i; - static char non_bincompat_options[] = + static const char non_bincompat_options[] = # ifdef DEBUGGING " DEBUGGING" # endif # ifdef NO_MATHOMS " NO_MATHOMS" # endif +# ifdef NO_HASH_SEED + " NO_HASH_SEED" +# endif +# ifdef NO_TAINT_SUPPORT + " NO_TAINT_SUPPORT" +# endif # ifdef PERL_DISABLE_PMC " PERL_DISABLE_PMC" # endif @@ -1686,6 +1659,30 @@ S_Internals_V(pTHX_ CV *cv) # ifdef PERL_EXTERNAL_GLOB " PERL_EXTERNAL_GLOB" # endif +# ifdef PERL_HASH_FUNC_SIPHASH + " PERL_HASH_FUNC_SIPHASH" +# endif +# ifdef PERL_HASH_FUNC_SDBM + " PERL_HASH_FUNC_SDBM" +# endif +# ifdef PERL_HASH_FUNC_DJB2 + " PERL_HASH_FUNC_DJB2" +# endif +# ifdef PERL_HASH_FUNC_SUPERFAST + " PERL_HASH_FUNC_SUPERFAST" +# endif +# ifdef PERL_HASH_FUNC_MURMUR3 + " PERL_HASH_FUNC_MURMUR3" +# endif +# ifdef PERL_HASH_FUNC_ONE_AT_A_TIME + " PERL_HASH_FUNC_ONE_AT_A_TIME" +# endif +# ifdef PERL_HASH_FUNC_ONE_AT_A_TIME_HARD + " PERL_HASH_FUNC_ONE_AT_A_TIME_HARD" +# endif +# ifdef PERL_HASH_FUNC_ONE_AT_A_TIME_OLD + " PERL_HASH_FUNC_ONE_AT_A_TIME_OLD" +# endif # ifdef PERL_IS_MINIPERL " PERL_IS_MINIPERL" # endif @@ -1698,6 +1695,18 @@ S_Internals_V(pTHX_ CV *cv) # ifdef PERL_MEM_LOG_NOIMPL " PERL_MEM_LOG_NOIMPL" # endif +# ifdef PERL_NEW_COPY_ON_WRITE + " PERL_NEW_COPY_ON_WRITE" +# endif +# ifdef PERL_PERTURB_KEYS_DETERMINISTIC + " PERL_PERTURB_KEYS_DETERMINISTIC" +# endif +# ifdef PERL_PERTURB_KEYS_DISABLED + " PERL_PERTURB_KEYS_DISABLED" +# endif +# ifdef PERL_PERTURB_KEYS_RANDOM + " PERL_PERTURB_KEYS_RANDOM" +# endif # ifdef PERL_PRESERVE_IVUV " PERL_PRESERVE_IVUV" # endif @@ -1719,6 +1728,9 @@ S_Internals_V(pTHX_ CV *cv) # ifdef USE_FAST_STDIO " USE_FAST_STDIO" # endif +# ifdef USE_HASH_SEED_EXPLICIT + " USE_HASH_SEED_EXPLICIT" +# endif # ifdef USE_LOCALE " USE_LOCALE" # endif @@ -1832,17 +1844,31 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) break; case 't': +#if SILENT_NO_TAINT_SUPPORT + /* silently ignore */ +#elif NO_TAINT_SUPPORT + Perl_croak_nocontext("This perl was compiled without taint support. " + "Cowardly refusing to run with -t or -T flags"); +#else CHECK_MALLOC_TOO_LATE_FOR('t'); - if( !PL_tainting ) { - PL_taint_warn = TRUE; - PL_tainting = TRUE; + if( !TAINTING_get ) { + TAINT_WARN_set(TRUE); + TAINTING_set(TRUE); } +#endif s++; goto reswitch; case 'T': +#if SILENT_NO_TAINT_SUPPORT + /* silently ignore */ +#elif NO_TAINT_SUPPORT + Perl_croak_nocontext("This perl was compiled without taint support. " + "Cowardly refusing to run with -t or -T flags"); +#else CHECK_MALLOC_TOO_LATE_FOR('T'); - PL_tainting = TRUE; - PL_taint_warn = FALSE; + TAINTING_set(TRUE); + TAINT_WARN_set(FALSE); +#endif s++; goto reswitch; @@ -1943,16 +1969,23 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) if ( #ifndef SECURE_INTERNAL_GETENV - !PL_tainting && + !TAINTING_get && #endif (s = PerlEnv_getenv("PERL5OPT"))) { while (isSPACE(*s)) s++; if (*s == '-' && *(s+1) == 'T') { +#if SILENT_NO_TAINT_SUPPORT + /* silently ignore */ +#elif NO_TAINT_SUPPORT + Perl_croak_nocontext("This perl was compiled without taint support. " + "Cowardly refusing to run with -t or -T flags"); +#else CHECK_MALLOC_TOO_LATE_FOR('T'); - PL_tainting = TRUE; - PL_taint_warn = FALSE; + TAINTING_set(TRUE); + TAINT_WARN_set(FALSE); +#endif } else { char *popt_copy = NULL; @@ -1982,10 +2015,17 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) } } if (*d == 't') { - if( !PL_tainting ) { - PL_taint_warn = TRUE; - PL_tainting = TRUE; +#if SILENT_NO_TAINT_SUPPORT + /* silently ignore */ +#elif NO_TAINT_SUPPORT + Perl_croak_nocontext("This perl was compiled without taint support. " + "Cowardly refusing to run with -t or -T flags"); +#else + if( !TAINTING_get) { + TAINT_WARN_set(TRUE); + TAINTING_set(TRUE); } +#endif } else { moreswitches(d); } @@ -1996,9 +2036,9 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) /* Set $^X early so that it can be used for relocatable paths in @INC */ /* and for SITELIB_EXP in USE_SITECUSTOMIZE */ - assert (!PL_tainted); + assert (!TAINT_get); TAINT; - S_set_caret_X(aTHX); + set_caret_X(); TAINT_NOT; #if defined(USE_SITECUSTOMIZE) @@ -2012,9 +2052,11 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) SV **const inc0 = inc ? av_fetch(inc, 0, FALSE) : NULL; if (inc0) { + /* if lib/buildcustomize.pl exists, it should not fail. If it does, + 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} && do q%c%"SVf"/buildcustomize.pl%c }", + "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)); } @@ -2052,7 +2094,7 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) scriptname = "-"; } - assert (!PL_tainted); + assert (!TAINT_get); init_perllib(); { @@ -2112,7 +2154,7 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) if (xsinit) (*xsinit)(aTHX); /* in case linked C routines want magical variables */ #ifndef PERL_MICRO -#if defined(VMS) || defined(WIN32) || defined(DJGPP) || defined(__CYGWIN__) || defined(EPOC) || defined(SYMBIAN) +#if defined(VMS) || defined(WIN32) || defined(DJGPP) || defined(__CYGWIN__) || defined(SYMBIAN) init_os_extras(); #endif #endif @@ -2195,7 +2237,7 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) #ifdef PERL_MAD { const char *s; - if (!PL_tainting && + if (!TAINTING_get && (s = PerlEnv_getenv("PERL_XMLDUMP"))) { PL_madskills = 1; PL_minus_c = 1; @@ -2220,8 +2262,7 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) #endif lex_start(linestr_sv, rsfp, lex_start_flags); - if(linestr_sv) - SvREFCNT_dec(linestr_sv); + SvREFCNT_dec(linestr_sv); PL_subname = newSVpvs("main"); @@ -2541,7 +2582,7 @@ Approximate Perl equivalent: C<&{"$sub_name"}(@$argv)>. */ I32 -Perl_call_argv(pTHX_ const char *sub_name, I32 flags, register char **argv) +Perl_call_argv(pTHX_ const char *sub_name, I32 flags, char **argv) /* See G_* flags in cop.h */ /* null terminated arg list */ @@ -2595,12 +2636,15 @@ Perl_call_method(pTHX_ const char *methname, I32 flags) /* See G_* flags in cop.h */ { STRLEN len; + SV* sv; PERL_ARGS_ASSERT_CALL_METHOD; len = strlen(methname); + sv = flags & G_METHOD_NAMED + ? sv_2mortal(newSVpvn_share(methname, len,0)) + : newSVpvn_flags(methname, len, SVs_TEMP); - /* XXX: sv_2mortal(newSVpvn_share(methname, len)) can be faster */ - return call_sv(newSVpvn_flags(methname, len, SVs_TEMP), flags | G_METHOD); + return call_sv(sv, flags | G_METHOD); } /* May be called with any of a CV, a GV, or an SV containing the name. */ @@ -2619,7 +2663,8 @@ Perl_call_sv(pTHX_ SV *sv, VOL I32 flags) { dVAR; dSP; LOGOP myop; /* fake syntax tree node */ - UNOP method_op; + UNOP method_unop; + SVOP method_svop; I32 oldmark; VOL I32 retval = 0; I32 oldscope; @@ -2648,7 +2693,8 @@ Perl_call_sv(pTHX_ SV *sv, VOL I32 flags) PL_op = (OP*)&myop; EXTEND(PL_stack_sp, 1); - *++PL_stack_sp = sv; + if (!(flags & G_METHOD_NAMED)) + *++PL_stack_sp = sv; oldmark = TOPMARK; oldscope = PL_scopestack_ix; @@ -2661,14 +2707,24 @@ Perl_call_sv(pTHX_ SV *sv, VOL I32 flags) && !(flags & G_NODEBUG)) myop.op_private |= OPpENTERSUB_DB; - if (flags & G_METHOD) { - Zero(&method_op, 1, UNOP); - method_op.op_next = (OP*)&myop; - 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; - PL_op = (OP*)&method_op; + if (flags & (G_METHOD|G_METHOD_NAMED)) { + 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; + } 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; + } + myop.op_ppaddr = PL_ppaddr[OP_ENTERSUB]; + myop.op_type = OP_ENTERSUB; + } if (!(flags & G_EVAL)) { @@ -2780,8 +2836,9 @@ Perl_eval_sv(pTHX_ SV *sv, I32 flags) myop.op_flags |= OP_GIMME_REVERSE(flags); if (flags & G_KEEPERR) myop.op_flags |= OPf_SPECIAL; - if (PL_reg_state.re_reparsing) - myop.op_private = OPpEVAL_COPHH; + + if (flags & G_RE_REPARSING) + myop.op_private = (OPpEVAL_COPHH | OPpEVAL_RE_REPARSING); /* fail now; otherwise we could fail after the JMPENV_PUSH but * before a PUSHEVAL, which corrupts the stack after a croak */ @@ -2853,7 +2910,6 @@ SV* Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error) { dVAR; - dSP; SV* sv = newSVpv(p, 0); PERL_ARGS_ASSERT_EVAL_PV; @@ -2861,12 +2917,18 @@ Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error) eval_sv(sv, G_SCALAR); SvREFCNT_dec(sv); - SPAGAIN; - sv = POPs; - PUTBACK; + { + dSP; + sv = POPs; + PUTBACK; + } - if (croak_on_error && SvTRUE(ERRSV)) { - Perl_croak(aTHX_ "%s", SvPVx_nolen_const(ERRSV)); + /* just check empty string or undef? */ + if (croak_on_error) { + SV * const errsv = ERRSV; + if(SvTRUE_NN(errsv)) + /* replace with croak_sv? */ + Perl_croak_nocontext("%s", SvPV_nolen_const(errsv)); } return sv; @@ -2895,10 +2957,8 @@ Perl_require_pv(pTHX_ const char *pv) 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; } @@ -2998,7 +3058,7 @@ Perl_get_debug_opts(pTHX_ const char **s, bool givehelp) /* if adding extra options, remember to update DEBUG_MASK */ static const char debopts[] = "psltocPmfrxuUHXDSTRJvCAqMB"; - for (; isALNUM(**s); (*s)++) { + for (; isWORDCHAR(**s); (*s)++) { const char * const d = strchr(debopts,**s); if (d) i |= 1 << (d - debopts); @@ -3009,7 +3069,7 @@ Perl_get_debug_opts(pTHX_ const char **s, bool givehelp) } else if (isDIGIT(**s)) { i = atoi(*s); - for (; isALNUM(**s); (*s)++) ; + for (; isWORDCHAR(**s); (*s)++) ; } else if (givehelp) { const char *const *p = usage_msgd; @@ -3085,13 +3145,16 @@ Perl_moreswitches(pTHX_ const char *s) PL_utf8cache = -1; return s; case 'F': + PL_minus_a = TRUE; PL_minus_F = TRUE; + PL_minus_n = TRUE; PL_splitstr = ++s; while (*s && !isSPACE(*s)) ++s; PL_splitstr = savepvn(PL_splitstr, s - PL_splitstr); return s; case 'a': PL_minus_a = TRUE; + PL_minus_n = TRUE; s++; return s; case 'c': @@ -3103,7 +3166,7 @@ Perl_moreswitches(pTHX_ const char *s) s++; /* -dt indicates to the debugger that threads will be used */ - if (*s == 't' && !isALNUM(s[1])) { + if (*s == 't' && !isWORDCHAR(s[1])) { ++s; my_setenv("PERL5DB_THREADED", "1"); } @@ -3126,7 +3189,7 @@ Perl_moreswitches(pTHX_ const char *s) end = s + strlen(s); /* We now allow -d:Module=Foo,Bar and -d:-Module */ - while(isALNUM(*s) || *s==':') ++s; + while(isWORDCHAR(*s) || *s==':') ++s; if (*s != '=') sv_catpvn(sv, start, end - start); else { @@ -3154,7 +3217,7 @@ Perl_moreswitches(pTHX_ const char *s) if (ckWARN_d(WARN_DEBUGGING)) Perl_warner(aTHX_ packWARN(WARN_DEBUGGING), "Recompile perl with -DDEBUGGING to use -D switch (did you mean -d ?)\n"); - for (s++; isALNUM(*s); s++) ; + for (s++; isWORDCHAR(*s); s++) ; #endif return s; } @@ -3247,7 +3310,7 @@ Perl_moreswitches(pTHX_ const char *s) sv = newSVpvn(use,4); start = s; /* We allow -M'Module qw(Foo Bar)' */ - while(isALNUM(*s) || *s==':') { + while(isWORDCHAR(*s) || *s==':') { if( *s++ == ':' ) { if( *s == ':' ) s++; @@ -3299,8 +3362,15 @@ Perl_moreswitches(pTHX_ const char *s) return s; case 't': case 'T': - if (!PL_tainting) +#if SILENT_NO_TAINT_SUPPORT + /* silently ignore */ +#elif NO_TAINT_SUPPORT + Perl_croak_nocontext("This perl was compiled without taint support. " + "Cowardly refusing to run with -t or -T flags"); +#else + if (!TAINTING_get) TOO_LATE_FOR(*s); +#endif s++; return s; case 'u': @@ -3371,31 +3441,35 @@ STATIC void S_minus_v(pTHX) { PerlIO * PIO_stdout; - if (!sv_derived_from(PL_patchlevel, "version")) - upg_version(PL_patchlevel, TRUE); -#if !defined(DGUX) { - 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) @@ -3403,21 +3477,8 @@ S_minus_v(pTHX) ", subversion " STRINGIFY(PERL_SUBVERSION) " (%"SVf") built for " ARCHNAME, level ); - SvREFCNT_dec(level); + SvREFCNT_dec_NN(level); } -#else /* DGUX */ - PIO_stdout = PerlIO_stdout(); -/* Adjust verbose output as in the perl that ships with the DG/UX OS from EMC */ - PerlIO_printf(PIO_stdout, - Perl_form(aTHX_ "\nThis is perl, %"SVf"\n", - SVfARG(vstringify(PL_patchlevel)))); - PerlIO_printf(PIO_stdout, - Perl_form(aTHX_ " built under %s at %s %s\n", - OSNAME, __DATE__, __TIME__)); - PerlIO_printf(PIO_stdout, - Perl_form(aTHX_ " OS Specific Release: %s\n", - OSVERS)); -#endif /* !DGUX */ #if defined(LOCAL_PATCH_COUNT) if (LOCAL_PATCH_COUNT > 0) PerlIO_printf(PIO_stdout, @@ -3428,7 +3489,7 @@ S_minus_v(pTHX) #endif PerlIO_printf(PIO_stdout, - "\n\nCopyright 1987-2012, Larry Wall\n"); + "\n\nCopyright 1987-2013, Larry Wall\n"); #ifdef MSDOS PerlIO_printf(PIO_stdout, "\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n"); @@ -3443,26 +3504,18 @@ S_minus_v(pTHX) "\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n" "Version 5 port Copyright (c) 1994-2002, Andreas Kaiser, Ilya Zakharevich\n"); #endif -#ifdef __BEOS__ - PerlIO_printf(PIO_stdout, - "BeOS port Copyright Tom Spindler, 1997-1999\n"); -#endif #ifdef OEMVS PerlIO_printf(PIO_stdout, "MVS (OS390) port by Mortice Kern Systems, 1997-1999\n"); #endif #ifdef __VOS__ PerlIO_printf(PIO_stdout, - "Stratus VOS port by Paul.Green@stratus.com, 1997-2002\n"); + "Stratus OpenVOS port by Paul.Green@stratus.com, 1997-2013\n"); #endif #ifdef POSIX_BC PerlIO_printf(PIO_stdout, "BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n"); #endif -#ifdef EPOC - PerlIO_printf(PIO_stdout, - "EPOC port by Olaf Flebbe, 1999-2002\n"); -#endif #ifdef UNDER_CE PerlIO_printf(PIO_stdout, "WINCE port by Rainer Keuchel, 2001-2002\n" @@ -3554,10 +3607,6 @@ S_init_interp(pTHX) # undef PERLVARIC #endif - /* As these are inside a structure, PERLVARI isn't capable of initialising - them */ - PL_reg_oldcurpm = PL_reg_curpm = NULL; - PL_reg_poscache = PL_reg_starttry = NULL; } STATIC void @@ -3585,13 +3634,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 @@ -3614,6 +3665,7 @@ S_open_script(pTHX_ const char *scriptname, bool dosearch, bool *suidscript) int fdscript = -1; PerlIO *rsfp = NULL; dVAR; + Stat_t tmpstatbuf; PERL_ARGS_ASSERT_OPEN_SCRIPT; @@ -3723,6 +3775,13 @@ S_open_script(pTHX_ const char *scriptname, bool dosearch, bool *suidscript) /* ensure close-on-exec */ fcntl(PerlIO_fileno(rsfp), F_SETFD, 1); #endif + + if (PerlLIO_fstat(PerlIO_fileno(rsfp), &tmpstatbuf) >= 0 + && S_ISDIR(tmpstatbuf.st_mode)) + Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n", + CopFILE(PL_curcop), + Strerror(EISDIR)); + return rsfp; } @@ -3740,10 +3799,10 @@ S_open_script(pTHX_ const char *scriptname, bool dosearch, bool *suidscript) STATIC void S_validate_suid(pTHX_ PerlIO *rsfp) { - const UV my_uid = PerlProc_getuid(); - const UV my_euid = PerlProc_geteuid(); - const UV my_gid = PerlProc_getgid(); - const UV my_egid = PerlProc_getegid(); + 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_ARGS_ASSERT_VALIDATE_SUID; @@ -3796,15 +3855,19 @@ S_find_beginning(pTHX_ SV* linestr_sv, PerlIO *rsfp) STATIC void S_init_ids(pTHX) { + /* no need to do anything here any more if we don't + * do tainting. */ +#if !NO_TAINT_SUPPORT dVAR; - const UV my_uid = PerlProc_getuid(); - const UV my_euid = PerlProc_geteuid(); - const UV my_gid = PerlProc_getgid(); - const UV my_egid = PerlProc_getegid(); + 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(); /* Should not happen: */ CHECK_MALLOC_TAINT(my_uid && (my_euid != my_uid || my_egid != my_gid)); - PL_tainting |= (my_uid && (my_euid != my_uid || my_egid != my_gid)); + TAINTING_set( TAINTING_get | (my_uid && (my_euid != my_uid || my_egid != my_gid)) ); +#endif /* BUG */ /* PSz 27 Feb 04 * Should go by suidscript, not uid!=euid: why disallow @@ -3831,10 +3894,10 @@ Perl_doing_taint(int argc, char *argv[], char *envp[]) * have to add your own checks somewhere in here. The two most * known samples of 'implicitness' are Win32 and NetWare, neither * of which has much of concept of 'uids'. */ - int uid = PerlProc_getuid(); - int euid = PerlProc_geteuid(); - int gid = PerlProc_getgid(); - int egid = PerlProc_getegid(); + Uid_t uid = PerlProc_getuid(); + Uid_t euid = PerlProc_geteuid(); + Gid_t gid = PerlProc_getgid(); + Gid_t egid = PerlProc_getegid(); (void)envp; #ifdef VMS @@ -3906,9 +3969,15 @@ Perl_init_debugger(pTHX) PL_curstash = (HV *)SvREFCNT_inc_simple(PL_debstash); Perl_init_dbargs(aTHX); - PL_DBgv = gv_fetchpvs("DB::DB", GV_ADDMULTI, SVt_PVGV); - PL_DBline = gv_fetchpvs("DB::dbline", GV_ADDMULTI, SVt_PVAV); - PL_DBsub = gv_HVadd(gv_fetchpvs("DB::sub", GV_ADDMULTI, SVt_PVHV)); + PL_DBgv = MUTABLE_GV( + SvREFCNT_inc(gv_fetchpvs("DB::DB", GV_ADDMULTI, SVt_PVGV)) + ); + PL_DBline = MUTABLE_GV( + SvREFCNT_inc(gv_fetchpvs("DB::dbline", GV_ADDMULTI, SVt_PVAV)) + ); + PL_DBsub = MUTABLE_GV(SvREFCNT_inc( + gv_HVadd(gv_fetchpvs("DB::sub", GV_ADDMULTI, SVt_PVHV)) + )); PL_DBsingle = GvSV((gv_fetchpvs("DB::single", GV_ADDMULTI, SVt_PV))); if (!SvIOK(PL_DBsingle)) sv_setiv(PL_DBsingle, 0); @@ -3924,8 +3993,10 @@ Perl_init_debugger(pTHX) #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 @@ -3961,9 +4032,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 @@ -4086,7 +4157,7 @@ S_init_predump_symbols(pTHX) } void -Perl_init_argv_symbols(pTHX_ register int argc, register char **argv) +Perl_init_argv_symbols(pTHX_ int argc, char **argv) { dVAR; @@ -4112,12 +4183,12 @@ Perl_init_argv_symbols(pTHX_ register int argc, register 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); - (void)gv_AVadd(PL_argvgv); av_clear(GvAVn(PL_argvgv)); for (; argc > 0; argc--,argv++) { SV * const sv = newSVpv(argv[0],0); - av_push(GvAVn(PL_argvgv),sv); + av_push(GvAV(PL_argvgv),sv); if (!(PL_unicode & PERL_UNICODE_LOCALE_FLAG) || PL_utf8locale) { if (PL_unicode & PERL_UNICODE_ARGV_FLAG) SvUTF8_on(sv); @@ -4134,7 +4205,7 @@ Perl_init_argv_symbols(pTHX_ register int argc, register char **argv) } STATIC void -S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register char **env) +S_init_postdump_symbols(pTHX_ int argc, char **argv, char **env) { dVAR; GV* tmpgv; @@ -4157,6 +4228,7 @@ S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register if ((PL_envgv = gv_fetchpvs("ENV", GV_ADD|GV_NOTQUAL, SVt_PVHV))) { HV *hv; bool env_is_not_environ; + SvREFCNT_inc_simple_void_NN(PL_envgv); GvMULTI_on(PL_envgv); hv = GvHVn(PL_envgv); hv_magic(hv, NULL, PERL_MAGIC_env); @@ -4221,7 +4293,7 @@ S_init_perllib(pTHX) STRLEN len; #endif - if (!PL_tainting) { + if (!TAINTING_get) { #ifndef VMS perl5lib = PerlEnv_getenv("PERL5LIB"); /* @@ -4337,7 +4409,7 @@ S_init_perllib(pTHX) |INCPUSH_CAN_RELOCATE); #endif - if (!PL_tainting) { + if (!TAINTING_get) { #ifndef VMS /* * It isn't possible to delete an environment variable with @@ -4394,11 +4466,11 @@ S_init_perllib(pTHX) #endif #endif /* !PERL_IS_MINIPERL */ - if (!PL_tainting) + if (!TAINTING_get) S_incpush(aTHX_ STR_WITH_LEN("."), 0); } -#if defined(DOSISH) || defined(EPOC) || defined(__SYMBIAN32__) +#if defined(DOSISH) || defined(__SYMBIAN32__) # define PERLLIB_SEP ';' #else # if defined(VMS) @@ -4444,16 +4516,12 @@ S_mayberelocate(pTHX_ const char *const dir, STRLEN len, U32 flags) PERL_ARGS_ASSERT_MAYBERELOCATE; assert(len > 0); - if (len) { - /* I am not convinced that this is valid when PERLLIB_MANGLE is - defined to so something (in os2/os2.c), but the code has been - this way, ignoring any possible changed of length, since - 760ac839baf413929cd31cc32ffd6dba6b781a81 (5.003_02) so I'll leave - it be. */ - libdir = newSVpvn(PERLLIB_MANGLE(dir, len), len); - } else { - libdir = newSVpv(PERLLIB_MANGLE(dir, 0), 0); - } + /* I am not convinced that this is valid when PERLLIB_MANGLE is + defined to so something (in os2/os2.c), but the code has been + this way, ignoring any possible changed of length, since + 760ac839baf413929cd31cc32ffd6dba6b781a81 (5.003_02) so I'll leave + it be. */ + libdir = newSVpvn(PERLLIB_MANGLE(dir, len), len); #ifdef VMS { @@ -4461,7 +4529,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 @@ -4560,7 +4628,7 @@ S_mayberelocate(pTHX_ const char *const dir, STRLEN len, U32 flags) SvREFCNT_dec(libdir); /* And this is the new libdir. */ libdir = tempsv; - if (PL_tainting && + if (TAINTING_get && (PerlProc_getuid() != PerlProc_geteuid() || PerlProc_getgid() != PerlProc_getegid())) { /* Need to taint relocated paths if running set ID */ @@ -4657,9 +4725,9 @@ S_incpush(pTHX_ const char *const dir, STRLEN len, U32 flags) /* finally add this lib directory at the end of @INC */ if (unshift) { #ifdef PERL_IS_MINIPERL - const U32 extra = 0; + const Size_t extra = 0; #else - U32 extra = av_len(av) + 1; + Size_t extra = av_len(av) + 1; #endif av_unshift(inc, extra + push_basedir); if (push_basedir) @@ -4829,6 +4897,14 @@ 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 %lu", (unsigned long)status); + PL_exit_flags &= ~PERL_EXIT_ABORT; + } switch (status) { case 0: STATUS_ALL_SUCCESS; @@ -4926,6 +5002,14 @@ Perl_my_failure_exit(pTHX) STATUS_UNIX_SET(255); } #endif + 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 failure %ld", (long)PL_statusvalue); + PL_exit_flags &= ~PERL_EXIT_ABORT; + } my_exit_jump(); }