X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/7a2bbcbfd710ce2d3775c2437dc7726a21f742e8..5f81fa4069cb15ccd77b1c4253c870df84c1788a:/perl.c diff --git a/perl.c b/perl.c index 17de92c..1d8876b 100644 --- a/perl.c +++ b/perl.c @@ -93,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 @@ -585,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 @@ -1771,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 @@ -2711,7 +2737,6 @@ Perl_call_sv(pTHX_ SV *sv, VOL I32 flags) METHOP method_op; I32 oldmark; VOL I32 retval = 0; - I32 oldscope; bool oldcatch = CATCH_GET; int ret; OP* const oldop = PL_op; @@ -2743,7 +2768,6 @@ Perl_call_sv(pTHX_ SV *sv, VOL I32 flags) PUTBACK; } oldmark = TOPMARK; - oldscope = PL_scopestack_ix; if (PERLDB_SUB && PL_curstash != PL_debstash /* Handle first BEGIN of -d. */ @@ -2777,9 +2801,11 @@ Perl_call_sv(pTHX_ SV *sv, VOL I32 flags) CATCH_SET(oldcatch); } else { + I32 old_cxix; myop.op_other = (OP*)&myop; (void)POPMARK; - create_eval_scope(flags|G_FAKINGEVAL); + old_cxix = cxstack_ix; + create_eval_scope(NULL, flags|G_FAKINGEVAL); (void)INCMARK; JMPENV_PUSH(ret); @@ -2820,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; } @@ -2888,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); @@ -3785,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) { @@ -4073,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)); @@ -4102,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 @@ -4320,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 */ @@ -4386,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 */ @@ -4497,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 */ } @@ -4870,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; @@ -5075,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);