X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/422791e4eb03a12d17c98eb1787351280ae59789..5f81fa4069cb15ccd77b1c4253c870df84c1788a:/perl.c diff --git a/perl.c b/perl.c index 8df24db..1d8876b 100644 --- a/perl.c +++ b/perl.c @@ -3,7 +3,7 @@ * * Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001 * 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012 - * by Larry Wall and others + * 2013, 2014, 2015, 2016 by Larry Wall and others * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -33,7 +33,6 @@ #include "perl.h" #include "patchlevel.h" /* for local_patches */ #include "XSUB.h" -#include "charclass_invlists.h" #ifdef NETWARE #include "nwutil.h" @@ -94,6 +93,7 @@ S_init_tls_and_interp(PerlInterpreter *my_perl) OP_REFCNT_INIT; OP_CHECK_MUTEX_INIT; HINTS_REFCNT_INIT; + LOCALE_INIT; MUTEX_INIT(&PL_dollarzero_mutex); MUTEX_INIT(&PL_my_ctx_mutex); # endif @@ -325,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) { @@ -387,11 +386,14 @@ perl_construct(pTHXx) 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); + PL_GCB_invlist = _new_invlist_C_array(_Perl_GCB_invlist); + PL_SB_invlist = _new_invlist_C_array(_Perl_SB_invlist); + PL_WB_invlist = _new_invlist_C_array(_Perl_WB_invlist); + PL_LB_invlist = _new_invlist_C_array(_Perl_LB_invlist); ENTER; } @@ -550,7 +552,11 @@ perl_destruct(pTHXx) if (strEQ(s, "-1")) { /* Special case: modperl folklore. */ i = -1; } else { - i = grok_atou(s, NULL); + UV uv; + if (grok_atoUV(s, &uv, NULL) && uv <= INT_MAX) + i = (int)uv; + else + i = 0; } #ifdef DEBUGGING if (destruct_level < i) destruct_level = i; @@ -580,19 +586,41 @@ perl_destruct(pTHXx) assert(PL_scopestack_ix == 0); /* Need to flush since END blocks can produce output */ + /* flush stdout separately, since we can identify it */ +#ifdef USE_PERLIO + { + PerlIO *stdo = PerlIO_stdout(); + if (*stdo && PerlIO_flush(stdo)) { + PerlIO_restore_errno(stdo); + PerlIO_printf(PerlIO_stderr(), "Unable to flush stdout: %s", + Strerror(errno)); + if (!STATUS_UNIX) + STATUS_ALL_FAILURE; + } + } +#endif my_fflush_all(); #ifdef PERL_TRACE_OPS - /* If we traced all Perl OP usage, report and clean up */ + /* dump OP-counts if $ENV{PERL_TRACE_OPS} > 0 */ + { + const char * const ptoenv = PerlEnv_getenv("PERL_TRACE_OPS"); + UV uv; + + if (!ptoenv || !Perl_grok_atoUV(ptoenv, &uv, NULL) + || !(uv > 0)) + goto no_trace_out; + } 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; + if (PL_op_exec_cnt[i]) + PerlIO_printf(Perl_debug_log, " %s: %"UVuf"\n", PL_op_name[i], PL_op_exec_cnt[i]); } /* 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"); + no_trace_out: #endif @@ -906,7 +934,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); @@ -968,6 +995,9 @@ perl_destruct(pTHXx) 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; @@ -1034,10 +1064,14 @@ perl_destruct(pTHXx) 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); SvREFCNT_dec(PL_HasMultiCharFold); +#ifdef USE_LOCALE_CTYPE + SvREFCNT_dec(PL_warn_locale); +#endif PL_utf8_mark = NULL; PL_utf8_toupper = NULL; PL_utf8_totitle = NULL; @@ -1047,7 +1081,11 @@ perl_destruct(pTHXx) PL_utf8_idcont = NULL; PL_utf8_foldclosures = NULL; PL_AboveLatin1 = NULL; + PL_InBitmap = NULL; PL_HasMultiCharFold = NULL; +#ifdef USE_LOCALE_CTYPE + PL_warn_locale = NULL; +#endif PL_Latin1 = NULL; PL_NonL1NonFinalFold = NULL; PL_UpperLatin1 = NULL; @@ -1055,6 +1093,10 @@ perl_destruct(pTHXx) SvREFCNT_dec(PL_XPosix_ptrs[i]); PL_XPosix_ptrs[i] = NULL; } + PL_GCB_invlist = NULL; + PL_LB_invlist = NULL; + PL_SB_invlist = NULL; + PL_WB_invlist = NULL; if (!specialWARN(PL_compiling.cop_warnings)) PerlMemShared_free(PL_compiling.cop_warnings); @@ -1287,14 +1329,22 @@ perl_destruct(pTHXx) TAINTING_set(FALSE); TAINT_WARN_set(FALSE); PL_hints = 0; /* Reset hints. Should hints be per-interpreter ? */ - PL_debug = 0; DEBUG_P(debprofdump()); + PL_debug = 0; + #ifdef USE_REENTRANT_API Perl_reentrant_free(aTHX); #endif + /* These all point to HVs that are about to be blown away. + Code in core and on CPAN assumes that if the interpreter is re-started + that they will be cleanly NULL or pointing to a valid HV. */ + PL_custom_op_names = NULL; + PL_custom_op_descs = NULL; + PL_custom_ops = NULL; + sv_free_arenas(); while (PL_regmatch_slab) { @@ -1361,8 +1411,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(PERL_MEMORY_DEBUG_HEADER_SIZE + (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; } } @@ -1456,9 +1509,9 @@ perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env) { const char * const s = PerlEnv_getenv("PERL_HASH_SEED_DEBUG"); - if (s && (grok_atou(s, NULL) == 1)) { - unsigned char *seed= PERL_HASH_SEED; - unsigned char *seed_end= PERL_HASH_SEED + PERL_HASH_SEED_BYTES; + if (s && strEQ(s, "1")) { + const unsigned char *seed= PERL_HASH_SEED; + const 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++); @@ -1472,6 +1525,14 @@ perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env) } } #endif /* #if defined(USE_HASH_SEED) || defined(USE_HASH_SEED_EXPLICIT) */ + +#ifdef __amigaos4__ + { + struct NameTranslationInfo nti; + __translate_amiga_to_unix_path_name(&argv[0],&nti); + } +#endif + PL_origargc = argc; PL_origargv = argv; @@ -1664,6 +1725,9 @@ S_Internals_V(pTHX_ CV *cv) # ifdef PERL_BOOL_AS_CHAR " PERL_BOOL_AS_CHAR" # endif +# ifdef PERL_COPY_ON_WRITE + " PERL_COPY_ON_WRITE" +# endif # ifdef PERL_DISABLE_PMC " PERL_DISABLE_PMC" # endif @@ -1709,9 +1773,6 @@ 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 @@ -1733,6 +1794,9 @@ S_Internals_V(pTHX_ CV *cv) # ifdef PERL_USE_SAFE_PUTENV " PERL_USE_SAFE_PUTENV" # endif +# ifdef SILENT_NO_TAINT_SUPPORT + " SILENT_NO_TAINT_SUPPORT" +# endif # ifdef UNLINK_ALL_VERSIONS " UNLINK_ALL_VERSIONS" # endif @@ -1751,6 +1815,9 @@ S_Internals_V(pTHX_ CV *cv) # ifdef USE_LOCALE_CTYPE " USE_LOCALE_CTYPE" # endif +# ifdef WIN32_NO_REGISTRY + " USE_NO_REGISTRY" +# endif # ifdef USE_PERL_ATOF " USE_PERL_ATOF" # endif @@ -1759,7 +1826,7 @@ S_Internals_V(pTHX_ CV *cv) # endif ; PERL_UNUSED_ARG(cv); - PERL_UNUSED_ARG(items); + PERL_UNUSED_VAR(items); EXTEND(SP, entries); @@ -1767,15 +1834,20 @@ S_Internals_V(pTHX_ CV *cv) PUSHs(Perl_newSVpvn_flags(aTHX_ non_bincompat_options, sizeof(non_bincompat_options) - 1, SVs_TEMP)); -#ifdef __DATE__ -# ifdef __TIME__ +#ifndef PERL_BUILD_DATE +# ifdef __DATE__ +# ifdef __TIME__ +# define PERL_BUILD_DATE __DATE__ " " __TIME__ +# else +# define PERL_BUILD_DATE __DATE__ +# endif +# endif +#endif + +#ifdef PERL_BUILD_DATE PUSHs(Perl_newSVpvn_flags(aTHX_ - STR_WITH_LEN("Compiled at " __DATE__ " " __TIME__), - SVs_TEMP)); -# else - PUSHs(Perl_newSVpvn_flags(aTHX_ STR_WITH_LEN("Compiled on " __DATE__), + STR_WITH_LEN("Compiled at " PERL_BUILD_DATE), SVs_TEMP)); -# endif #else PUSHs(&PL_sv_undef); #endif @@ -1805,7 +1877,7 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) int argc = PL_origargc; char **argv = PL_origargv; const char *scriptname = NULL; - VOL bool dosearch = FALSE; + bool dosearch = FALSE; char c; bool doextract = FALSE; const char *cddir = NULL; @@ -1987,6 +2059,10 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) #endif (s = PerlEnv_getenv("PERL5OPT"))) { + /* s points to static memory in getenv(), which may be overwritten at + * any time; use a mortal copy instead */ + s = SvPVX(sv_2mortal(newSVpv(s, 0))); + while (isSPACE(*s)) s++; if (*s == '-' && *(s+1) == 'T') { @@ -2070,9 +2146,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, SVfARG(*inc0), 0, - 0, SVfARG(*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. */ @@ -2156,7 +2233,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(); @@ -2290,7 +2367,9 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) #ifdef MYMALLOC { const char *s; - if ((s=PerlEnv_getenv("PERL_DEBUG_MSTATS")) && grok_atou(s, NULL) >= 2) + UV uv; + s = PerlEnv_getenv("PERL_DEBUG_MSTATS"); + if (s && grok_atoUV(s, &uv, NULL) && uv >= 2) dump_mstats("after compilation:"); } #endif @@ -2386,7 +2465,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); @@ -2413,7 +2492,7 @@ S_run_body(pTHX_ I32 oldscope) CALLRUNOPS(aTHX); } my_exit(0); - assert(0); /* NOTREACHED */ + NOT_REACHED; /* NOTREACHED */ } /* @@ -2480,7 +2559,7 @@ Perl_get_av(pTHX_ const char *name, I32 flags) Returns the HV of the specified Perl hash. C are passed 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. +and the variable does not exist then C is returned. =cut */ @@ -2554,7 +2633,7 @@ 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 +with C (a C-terminated array of strings) as arguments. See L. Approximate Perl equivalent: C<&{"$sub_name"}(@$argv)>. @@ -2573,13 +2652,11 @@ Perl_call_argv(pTHX_ const char *sub_name, I32 flags, char **argv) PERL_ARGS_ASSERT_CALL_ARGV; PUSHMARK(SP); - if (argv) { - while (*argv) { - mXPUSHs(newSVpv(*argv,0)); - argv++; - } - PUTBACK; + while (*argv) { + mXPUSHs(newSVpv(*argv,0)); + argv++; } + PUTBACK; return call_pv(sub_name, flags); } @@ -2631,8 +2708,22 @@ Perl_call_method(pTHX_ const char *methname, I32 flags) /* =for apidoc p||call_sv -Performs a callback to the Perl sub whose name is in the SV. See -L. +Performs a callback to the Perl sub specified by the SV. + +If neither the C nor C flag is supplied, the +SV may be any of a CV, a GV, a reference to a CV, a reference to a GV +or C will be used as the name of the sub to call. + +If the C flag is supplied, the SV may be a reference to a CV or +C will be used as the name of the method to call. + +If the C flag is supplied, C will be used as +the name of the method to call. + +Some other values are treated specially for internal use and should +not be depended on. + +See L. =cut */ @@ -2641,13 +2732,11 @@ I32 Perl_call_sv(pTHX_ SV *sv, VOL I32 flags) /* See G_* flags in cop.h */ { - dVAR; dSP; + dVAR; LOGOP myop; /* fake syntax tree node */ - UNOP method_unop; - SVOP method_svop; + METHOP method_op; I32 oldmark; VOL I32 retval = 0; - I32 oldscope; bool oldcatch = CATCH_GET; int ret; OP* const oldop = PL_op; @@ -2672,11 +2761,13 @@ Perl_call_sv(pTHX_ SV *sv, VOL I32 flags) SAVEOP(); PL_op = (OP*)&myop; - EXTEND(PL_stack_sp, 1); - if (!(flags & G_METHOD_NAMED)) - *++PL_stack_sp = sv; + if (!(flags & G_METHOD_NAMED)) { + dSP; + EXTEND(SP, 1); + PUSHs(sv); + PUTBACK; + } oldmark = TOPMARK; - oldscope = PL_scopestack_ix; if (PERLDB_SUB && PL_curstash != PL_debstash /* Handle first BEGIN of -d. */ @@ -2688,23 +2779,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)) { @@ -2714,10 +2801,12 @@ Perl_call_sv(pTHX_ SV *sv, VOL I32 flags) CATCH_SET(oldcatch); } else { + I32 old_cxix; myop.op_other = (OP*)&myop; - PL_markstack_ptr--; - create_eval_scope(flags|G_FAKINGEVAL); - PL_markstack_ptr++; + (void)POPMARK; + old_cxix = cxstack_ix; + create_eval_scope(NULL, flags|G_FAKINGEVAL); + (void)INCMARK; JMPENV_PUSH(ret); @@ -2739,7 +2828,7 @@ Perl_call_sv(pTHX_ SV *sv, VOL I32 flags) FREETMPS; JMPENV_POP; my_exit_jump(); - assert(0); /* NOTREACHED */ + NOT_REACHED; /* NOTREACHED */ case 3: if (PL_restartop) { PL_restartjmpenv = NULL; @@ -2757,8 +2846,13 @@ Perl_call_sv(pTHX_ SV *sv, VOL I32 flags) break; } - if (PL_scopestack_ix > oldscope) + /* if we croaked, depending on how we croaked the eval scope + * may or may not have already been popped */ + if (cxstack_ix > old_cxix) { + assert(cxstack_ix == old_cxix + 1); + assert(CxTYPE(CX_CUR()) == CXt_EVAL); delete_eval_scope(); + } JMPENV_POP; } @@ -2778,7 +2872,7 @@ 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. +as C, with the obvious exception of C. See L. =cut */ @@ -2789,9 +2883,8 @@ Perl_eval_sv(pTHX_ SV *sv, I32 flags) /* See G_* flags in cop.h */ { dVAR; - dSP; UNOP myop; /* fake syntax tree node */ - VOL I32 oldmark = SP - PL_stack_base; + VOL I32 oldmark; VOL I32 retval = 0; int ret; OP* const oldop = PL_op; @@ -2807,8 +2900,13 @@ Perl_eval_sv(pTHX_ SV *sv, I32 flags) SAVEOP(); PL_op = (OP*)&myop; Zero(&myop, 1, UNOP); - EXTEND(PL_stack_sp, 1); - *++PL_stack_sp = sv; + { + dSP; + oldmark = SP - PL_stack_base; + EXTEND(SP, 1); + PUSHs(sv); + PUTBACK; + } if (!(flags & G_NOARGS)) myop.op_flags = OPf_STACKED; @@ -2821,7 +2919,7 @@ Perl_eval_sv(pTHX_ SV *sv, I32 flags) 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 */ + * before a cx_pusheval(), which corrupts the stack after a croak */ TAINT_PROPER("eval_sv()"); JMPENV_PUSH(ret); @@ -2848,7 +2946,7 @@ Perl_eval_sv(pTHX_ SV *sv, I32 flags) FREETMPS; JMPENV_POP; my_exit_jump(); - assert(0); /* NOTREACHED */ + NOT_REACHED; /* NOTREACHED */ case 3: if (PL_restartop) { PL_restartjmpenv = NULL; @@ -3029,7 +3127,7 @@ Perl_get_debug_opts(pTHX_ const char **s, bool givehelp) " L trace some locale setting information--for Perl core development\n", NULL }; - int i = 0; + UV uv = 0; PERL_ARGS_ASSERT_GET_DEBUG_OPTS; @@ -3040,7 +3138,7 @@ Perl_get_debug_opts(pTHX_ const char **s, bool givehelp) for (; isWORDCHAR(**s); (*s)++) { const char * const d = strchr(debopts,**s); if (d) - i |= 1 << (d - debopts); + uv |= 1 << (d - debopts); else if (ckWARN_d(WARN_DEBUGGING)) Perl_warner(aTHX_ packWARN(WARN_DEBUGGING), "invalid option -D%c, use -D'' to see choices\n", **s); @@ -3048,8 +3146,7 @@ Perl_get_debug_opts(pTHX_ const char **s, bool givehelp) } else if (isDIGIT(**s)) { const char* e; - i = grok_atou(*s, &e); - if (e) + if (grok_atoUV(*s, &uv, &e)) *s = e; for (; isWORDCHAR(**s); (*s)++) ; } @@ -3057,12 +3154,7 @@ Perl_get_debug_opts(pTHX_ const char **s, bool givehelp) const char *const *p = usage_msgd; while (*p) PerlIO_puts(PerlIO_stdout(), *p++); } -# ifdef EBCDIC - if ((i & DEBUG_p_FLAG) && ckWARN_d(WARN_DEBUGGING)) - Perl_warner(aTHX_ packWARN(WARN_DEBUGGING), - "-Dp not implemented on this platform\n"); -# endif - return i; + return (int)uv; /* ignore any UV->int conversion loss */ } #endif @@ -3099,10 +3191,10 @@ Perl_moreswitches(pTHX_ const char *s) s--; } PL_rs = newSVpvs(""); - SvGROW(PL_rs, (STRLEN)(UNISKIP(rschar) + 1)); + SvGROW(PL_rs, (STRLEN)(UVCHR_SKIP(rschar) + 1)); tmps = (U8*)SvPVX(PL_rs); uvchr_to_utf8(tmps, rschar); - SvCUR_set(PL_rs, UNISKIP(rschar)); + SvCUR_set(PL_rs, UVCHR_SKIP(rschar)); SvUTF8_on(PL_rs); } else { @@ -3202,9 +3294,12 @@ Perl_moreswitches(pTHX_ const char *s) for (s++; isWORDCHAR(*s); s++) ; #endif return s; + NOT_REACHED; /* NOTREACHED */ } case 'h': usage(); + NOT_REACHED; /* NOTREACHED */ + case 'i': Safefree(PL_inplace); #if defined(__CYGWIN__) /* do backup extension automagically */ @@ -3471,7 +3566,7 @@ S_minus_v(pTHX) #endif PerlIO_printf(PIO_stdout, - "\n\nCopyright 1987-2014, Larry Wall\n"); + "\n\nCopyright 1987-2016, Larry Wall\n"); #ifdef MSDOS PerlIO_printf(PIO_stdout, "\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n"); @@ -3626,7 +3721,7 @@ S_init_main_stash(pTHX) GvMULTI_on(PL_replgv); (void)Perl_form(aTHX_ "%240s",""); /* Preallocate temp - for immediate signals. */ #ifdef PERL_DONT_CREATE_GVSV - gv_SVadd(PL_errgv); + (void)gv_SVadd(PL_errgv); #endif sv_grow(ERRSV, 240); /* Preallocate - for immediate signals. */ CLEAR_ERRSV(); @@ -3653,14 +3748,17 @@ S_open_script(pTHX_ const char *scriptname, bool dosearch, bool *suidscript) PL_origfilename = savepvs("-e"); } else { + const char *s; + UV uv; /* if find_script() returns, it returns a malloc()-ed value */ scriptname = PL_origfilename = find_script(scriptname, dosearch, NULL, 1); - if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) { - const char *s = scriptname + 8; - const char* e; - fdscript = grok_atou(s, &e); - s = e; + if (strnEQ(scriptname, "/dev/fd/", 8) + && isDIGIT(scriptname[8]) + && grok_atoUV(scriptname + 8, &uv, &s) + && uv <= PERL_INT_MAX + ) { + fdscript = (int)uv; if (*s) { /* PSz 18 Feb 04 * Tell apart "normal" usage of fdscript, e.g. @@ -3718,7 +3816,7 @@ 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 old_umask = umask(0177); int tmpfd = mkstemp(tmpname); umask(old_umask); if (tmpfd > -1) { @@ -3754,10 +3852,10 @@ S_open_script(pTHX_ const char *scriptname, bool dosearch, bool *suidscript) CopFILE(PL_curcop), Strerror(errno)); } fd = PerlIO_fileno(rsfp); -#if defined(HAS_FCNTL) && defined(F_SETFD) +#if defined(HAS_FCNTL) && defined(F_SETFD) && defined(FD_CLOEXEC) if (fd >= 0) { /* ensure close-on-exec */ - if (fcntl(fd, F_SETFD, 1) < 0) { + if (fcntl(fd, F_SETFD, FD_CLOEXEC) < 0) { Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n", CopFILE(PL_curcop), Strerror(errno)); } @@ -3798,16 +3896,13 @@ S_validate_suid(pTHX_ PerlIO *rsfp) if (my_euid != my_uid || my_egid != my_gid) { /* (suidperl doesn't exist, in fact) */ dVAR; 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"); - } + Stat_t statbuf; + if (fd < 0 || PerlLIO_fstat(fd, &statbuf) < 0) { /* may be either wrapped or real suid */ + Perl_croak_nocontext( "Illegal suidscript"); } - if ((my_euid != my_uid && my_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID) + if ((my_euid != my_uid && my_euid == statbuf.st_uid && statbuf.st_mode & S_ISUID) || - (my_egid != my_gid && my_egid == PL_statbuf.st_gid && PL_statbuf.st_mode & S_ISGID) + (my_egid != my_gid && my_egid == statbuf.st_gid && statbuf.st_mode & S_ISGID) ) if (!PL_do_undump) Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\ @@ -3959,6 +4054,7 @@ void Perl_init_debugger(pTHX) { HV * const ostash = PL_curstash; + MAGIC *mg; PL_curstash = (HV *)SvREFCNT_inc_simple(PL_debstash); @@ -3975,12 +4071,24 @@ 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; } @@ -3996,6 +4104,8 @@ Perl_init_debugger(pTHX) void Perl_init_stacks(pTHX) { + SSize_t size; + /* start with 128-item stack and 8K cxstack */ PL_curstackinfo = new_stackinfo(REASONABLE(128), REASONABLE(8192/sizeof(PERL_CONTEXT) - 1)); @@ -4025,9 +4135,11 @@ Perl_init_stacks(pTHX) PL_scopestack_ix = 0; PL_scopestack_max = REASONABLE(32); - Newx(PL_savestack,REASONABLE_but_at_least(128,SS_MAXPUSH),ANY); + size = REASONABLE_but_at_least(128,SS_MAXPUSH); + Newx(PL_savestack, size, ANY); PL_savestack_ix = 0; - PL_savestack_max = REASONABLE_but_at_least(128,SS_MAXPUSH); + /*PL_savestack_max lies: it always has SS_MAXPUSH more than it claims */ + PL_savestack_max = size - SS_MAXPUSH; } #undef REASONABLE @@ -4243,23 +4355,70 @@ S_init_postdump_symbols(pTHX_ int argc, char **argv, char **env) } if (env) { char *s, *old_var; + STRLEN nlen; SV *sv; + HV *dups = newHV(); + for (; *env; env++) { old_var = *env; if (!(s = strchr(old_var,'=')) || s == old_var) continue; + nlen = s - old_var; #if defined(MSDOS) && !defined(DJGPP) *s = '\0'; (void)strupr(old_var); *s = '='; #endif - sv = newSVpv(s+1, 0); - (void)hv_store(hv, old_var, s - old_var, sv, 0); + if (hv_exists(hv, old_var, nlen)) { + const char *name = savepvn(old_var, nlen); + + /* make sure we use the same value as getenv(), otherwise code that + uses getenv() (like setlocale()) might see a different value to %ENV + */ + sv = newSVpv(PerlEnv_getenv(name), 0); + + /* keep a count of the dups of this name so we can de-dup environ later */ + if (hv_exists(dups, name, nlen)) + ++SvIVX(*hv_fetch(dups, name, nlen, 0)); + else + (void)hv_store(dups, name, nlen, newSViv(1), 0); + + Safefree(name); + } + else { + sv = newSVpv(s+1, 0); + } + (void)hv_store(hv, old_var, nlen, sv, 0); if (env_is_not_environ) mg_set(sv); } + if (HvKEYS(dups)) { + /* environ has some duplicate definitions, remove them */ + HE *entry; + hv_iterinit(dups); + while ((entry = hv_iternext_flags(dups, 0))) { + STRLEN nlen; + const char *name = HePV(entry, nlen); + IV count = SvIV(HeVAL(entry)); + IV i; + SV **valp = hv_fetch(hv, name, nlen, 0); + + assert(valp); + + /* try to remove any duplicate names, depending on the + * implementation used in my_setenv() the iteration might + * not be necessary, but let's be safe. + */ + for (i = 0; i < count; ++i) + my_setenv(name, 0); + + /* and set it back to the value we set $ENV{name} to */ + my_setenv(name, SvPV_nolen(*valp)); + } + } + SvREFCNT_dec_NN(dups); } #endif /* USE_ENVIRON_ARRAY */ #endif /* !PERL_MICRO */ @@ -4309,12 +4468,12 @@ S_init_perllib(pTHX) */ char buf[256]; int idx = 0; - if (my_trnlnm("PERL5LIB",buf,0)) + if (vmstrnenv("PERL5LIB",buf,0,NULL,0)) do { incpush_use_sep(buf, 0, INCPUSH_ADD_SUB_DIRS); - } while (my_trnlnm("PERL5LIB",buf,++idx)); + } while (vmstrnenv("PERL5LIB",buf,++idx,NULL,0)); else { - while (my_trnlnm("PERLLIB",buf,idx++)) + while (vmstrnenv("PERLLIB",buf,idx++,NULL,0)) incpush_use_sep(buf, 0, 0); } #endif /* VMS */ @@ -4344,7 +4503,7 @@ S_init_perllib(pTHX) #ifdef SITELIB_EXP # if defined(WIN32) /* this picks up sitearch as well */ - s = win32_get_sitelib(PERL_FS_VERSION, &len); + s = PerlEnv_sitelib_path(PERL_FS_VERSION, &len); if (s) incpush_use_sep(s, len, INCPUSH_ADD_SUB_DIRS|INCPUSH_CAN_RELOCATE); # else @@ -4364,7 +4523,7 @@ S_init_perllib(pTHX) #ifdef PERL_VENDORLIB_EXP # if defined(WIN32) /* this picks up vendorarch as well */ - s = win32_get_vendorlib(PERL_FS_VERSION, &len); + s = PerlEnv_vendorlib_path(PERL_FS_VERSION, &len); if (s) incpush_use_sep(s, len, INCPUSH_ADD_SUB_DIRS|INCPUSH_CAN_RELOCATE); # else @@ -4382,7 +4541,7 @@ S_init_perllib(pTHX) #endif #if defined(WIN32) - s = win32_get_privlib(PERL_FS_VERSION, &len); + s = PerlEnv_lib_path(PERL_FS_VERSION, &len); if (s) incpush_use_sep(s, len, INCPUSH_ADD_SUB_DIRS|INCPUSH_CAN_RELOCATE); #else @@ -4420,11 +4579,11 @@ S_init_perllib(pTHX) */ char buf[256]; int idx = 0; - if (my_trnlnm("PERL5LIB",buf,0)) + if (vmstrnenv("PERL5LIB",buf,0,NULL,0)) do { incpush_use_sep(buf, 0, INCPUSH_ADD_OLD_VERS|INCPUSH_NOT_BASEDIR); - } while (my_trnlnm("PERL5LIB",buf,++idx)); + } while (vmstrnenv("PERL5LIB",buf,++idx,NULL,0)); #endif /* VMS */ } @@ -4793,7 +4952,7 @@ void Perl_call_list(pTHX_ I32 oldscope, AV *paramList) { SV *atsv; - volatile const line_t oldline = PL_curcop ? CopLINE(PL_curcop) : 0; + VOL const line_t oldline = PL_curcop ? CopLINE(PL_curcop) : 0; CV *cv; STRLEN len; int ret; @@ -4856,7 +5015,7 @@ Perl_call_list(pTHX_ I32 oldscope, AV *paramList) CopLINE_set(PL_curcop, oldline); JMPENV_POP; my_exit_jump(); - assert(0); /* NOTREACHED */ + NOT_REACHED; /* NOTREACHED */ case 3: if (PL_restartop) { PL_curcop = &PL_compiling; @@ -4998,7 +5157,10 @@ S_my_exit_jump(pTHX) } POPSTACK_TO(PL_mainstack); - dounwind(-1); + if (cxstack_ix >= 0) { + dounwind(-1); + cx_popblock(cxstack); + } LEAVE_SCOPE(0); JMPENV_JUMP(2); @@ -5023,12 +5185,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 I32 ax) +{ + if (PL_unitcheckav) + call_list(PL_scopestack_ix, PL_unitcheckav); + XSRETURN_YES; +} + /* - * Local variables: - * c-indentation-style: bsd - * c-basic-offset: 4 - * indent-tabs-mode: nil - * End: - * * ex: set ts=8 sts=4 sw=4 et: */