diff options
| -rw-r--r-- | embed.fnc | 3 | ||||
| -rw-r--r-- | embed.h | 2 | ||||
| -rw-r--r-- | pp_ctl.c | 90 | ||||
| -rw-r--r-- | proto.h | 2 | ||||
| -rw-r--r-- | t/comp/hints.t | 6 | ||||
| -rw-r--r-- | t/comp/require.t | 10 | ||||
| -rw-r--r-- | t/op/eval.t | 8 |
7 files changed, 76 insertions, 45 deletions
@@ -1797,7 +1797,8 @@ sR |I32 |dopoptoloop |I32 startingblock sR |I32 |dopoptosub_at |NN const PERL_CONTEXT* cxstk|I32 startingblock sR |I32 |dopoptowhen |I32 startingblock s |void |save_lines |NULLOK AV *array|NN SV *sv -s |bool |doeval |int gimme|NULLOK OP** startop|NULLOK CV* outside|U32 seq +s |bool |doeval |int gimme|NULLOK OP** startop \ + |NULLOK CV* outside|U32 seq|NULLOK HV* hh sR |PerlIO *|check_type_and_open|NN SV *name #ifndef PERL_DISABLE_PMC sR |PerlIO *|doopen_pm |NN SV *name @@ -1428,7 +1428,7 @@ #define destroy_matcher(a) S_destroy_matcher(aTHX_ a) #define do_smartmatch(a,b,c) S_do_smartmatch(aTHX_ a,b,c) #define docatch(a) S_docatch(aTHX_ a) -#define doeval(a,b,c,d) S_doeval(aTHX_ a,b,c,d) +#define doeval(a,b,c,d,e) S_doeval(aTHX_ a,b,c,d,e) #define dofindlabel(a,b,c,d) S_dofindlabel(aTHX_ a,b,c,d) #define doparseform(a) S_doparseform(aTHX_ a) #define dopoptoeval(a) S_dopoptoeval(aTHX_ a) @@ -3352,9 +3352,9 @@ Perl_sv_compile_2op_is_broken(pTHX_ SV *sv, OP **startop, const char *code, CATCH_SET(TRUE); if (runtime) - (void) doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq); + (void) doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq, NULL); else - (void) doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax); + (void) doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax, NULL); CATCH_SET(need_catch); POPBLOCK(cx,PL_curpm); POPEVAL(cx); @@ -3456,10 +3456,11 @@ S_try_yyparse(pTHX_ int gramtype) */ STATIC bool -S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq) +S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq, HV *hh) { dVAR; dSP; OP * const saveop = PL_op; + COP * const oldcurcop = PL_curcop; bool in_require = (saveop && saveop->op_type == OP_REQUIRE); int yystatus; @@ -3516,6 +3517,49 @@ S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq) else CLEAR_ERRSV(); + if (!startop) { + ENTER_with_name("evalcomp"); + SAVEHINTS(); + if (in_require) { + PL_hints = 0; + hv_clear(GvHV(PL_hintgv)); + } + else { + PL_hints = saveop->op_private & OPpEVAL_COPHH + ? oldcurcop->cop_hints : saveop->op_targ; + if (hh) { + /* SAVEHINTS created a new HV in PL_hintgv, which we need to GC */ + SvREFCNT_dec(GvHV(PL_hintgv)); + GvHV(PL_hintgv) = hh; + } + } + SAVECOMPILEWARNINGS(); + if (in_require) { + if (PL_dowarn & G_WARN_ALL_ON) + PL_compiling.cop_warnings = pWARN_ALL ; + else if (PL_dowarn & G_WARN_ALL_OFF) + PL_compiling.cop_warnings = pWARN_NONE ; + else + PL_compiling.cop_warnings = pWARN_STD ; + } + else { + PL_compiling.cop_warnings = + DUP_WARNINGS(oldcurcop->cop_warnings); + cophh_free(CopHINTHASH_get(&PL_compiling)); + if (Perl_cop_fetch_label(aTHX_ oldcurcop, NULL, NULL)) { + /* The label, if present, is the first entry on the chain. So rather + than writing a blank label in front of it (which involves an + allocation), just use the next entry in the chain. */ + PL_compiling.cop_hints_hash + = cophh_copy(oldcurcop->cop_hints_hash->refcounted_he_next); + /* Check the assumption that this removed the label. */ + assert(Perl_cop_fetch_label(aTHX_ &PL_compiling, NULL, NULL) == NULL); + } + else + PL_compiling.cop_hints_hash = cophh_copy(oldcurcop->cop_hints_hash); + } + } + CALL_BLOCK_HOOKS(bhk_eval, saveop); /* note that yyparse() may raise an exception, e.g. C<BEGIN{die}>, @@ -3523,6 +3567,8 @@ S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq) yystatus = (!in_require && CATCH_GET) ? S_try_yyparse(aTHX_ GRAMPROG) : yyparse(GRAMPROG); + if (!startop && yystatus != 3) LEAVE_with_name("evalcomp"); + if (yystatus || PL_parser->error_count || !PL_eval_root) { SV **newsp; /* Used by POPBLOCK. */ PERL_CONTEXT *cx; @@ -4051,18 +4097,6 @@ PP(pp_require) CopFILE_set(&PL_compiling, tryname); lex_start(NULL, tryrsfp, 0); - SAVEHINTS(); - PL_hints = 0; - hv_clear(GvHV(PL_hintgv)); - - SAVECOMPILEWARNINGS(); - if (PL_dowarn & G_WARN_ALL_ON) - PL_compiling.cop_warnings = pWARN_ALL ; - else if (PL_dowarn & G_WARN_ALL_OFF) - PL_compiling.cop_warnings = pWARN_NONE ; - else - PL_compiling.cop_warnings = pWARN_STD ; - if (filter_sub || filter_cache) { /* We can use the SvPV of the filter PVIO itself as our cache, rather than hanging another SV from it. In turn, filter_add() optionally @@ -4088,7 +4122,7 @@ PP(pp_require) encoding = PL_encoding; PL_encoding = NULL; - if (doeval(gimme, NULL, NULL, PL_curcop->cop_seq)) + if (doeval(gimme, NULL, NULL, PL_curcop->cop_seq, NULL)) op = DOCATCH(PL_eval_start); else op = PL_op->op_next; @@ -4188,28 +4222,6 @@ PP(pp_entereval) CopFILE_set(&PL_compiling, tmpbuf+2); SAVECOPLINE(&PL_compiling); CopLINE_set(&PL_compiling, 1); - SAVEHINTS(); - PL_hints = PL_op->op_private & OPpEVAL_COPHH - ? PL_curcop->cop_hints : PL_op->op_targ; - if (saved_hh) { - /* SAVEHINTS created a new HV in PL_hintgv, which we need to GC */ - SvREFCNT_dec(GvHV(PL_hintgv)); - GvHV(PL_hintgv) = saved_hh; - } - SAVECOMPILEWARNINGS(); - PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings); - cophh_free(CopHINTHASH_get(&PL_compiling)); - if (Perl_cop_fetch_label(aTHX_ PL_curcop, NULL, NULL)) { - /* The label, if present, is the first entry on the chain. So rather - than writing a blank label in front of it (which involves an - allocation), just use the next entry in the chain. */ - PL_compiling.cop_hints_hash - = cophh_copy(PL_curcop->cop_hints_hash->refcounted_he_next); - /* Check the assumption that this removed the label. */ - assert(Perl_cop_fetch_label(aTHX_ &PL_compiling, NULL, NULL) == NULL); - } - else - PL_compiling.cop_hints_hash = cophh_copy(PL_curcop->cop_hints_hash); /* special case: an eval '' executed within the DB package gets lexically * placed in the first non-DB CV rather than the current CV - this * allows the debugger to execute code, find lexicals etc, in the @@ -4238,7 +4250,7 @@ PP(pp_entereval) PUTBACK; - if (doeval(gimme, NULL, runcv, seq)) { + if (doeval(gimme, NULL, runcv, seq, saved_hh)) { if (was != PL_breakable_sub_gen /* Some subs defined here. */ ? (PERLDB_LINE || PERLDB_SAVESRC) : PERLDB_SAVESRC_NOSUBS) { @@ -5909,7 +5909,7 @@ STATIC OP* S_do_smartmatch(pTHX_ HV* seen_this, HV* seen_other, const bool copie STATIC OP* S_docatch(pTHX_ OP *o) __attribute__warn_unused_result__; -STATIC bool S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq); +STATIC bool S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq, HV* hh); STATIC OP* S_dofindlabel(pTHX_ OP *o, const char *label, OP **opstack, OP **oplimit) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1) diff --git a/t/comp/hints.t b/t/comp/hints.t index b81028a83d..7796727aee 100644 --- a/t/comp/hints.t +++ b/t/comp/hints.t @@ -62,10 +62,12 @@ BEGIN { } # op_entereval should keep the pragmas it was compiled with eval q* + BEGIN { print "not " if $^H{foo} ne "a"; print "ok 13 - \$^H{foo} is 'a' at eval-\"\" time\n"; print "not " unless $^H & 0x00020000; print "ok 14 - \$^H contains HINT_LOCALIZE_HH at eval\"\"-time\n"; + } *; } BEGIN { @@ -84,7 +86,9 @@ BEGIN { BEGIN{$^H{x}=1}; for my $tno (15..16) { eval q( - print $^H{x}==1 && !$^H{y} ? "ok $tno\n" : "not ok $tno\n"; + BEGIN { + print $^H{x}==1 && !$^H{y} ? "ok $tno\n" : "not ok $tno\n"; + } $^H{y} = 1; ); if ($@) { diff --git a/t/comp/require.t b/t/comp/require.t index 07ac51bfe1..d704762bae 100644 --- a/t/comp/require.t +++ b/t/comp/require.t @@ -22,7 +22,7 @@ krunch.pm krunch.pmc whap.pm whap.pmc); my $Is_EBCDIC = (ord('A') == 193) ? 1 : 0; my $Is_UTF8 = (${^OPEN} || "") =~ /:utf8/; -my $total_tests = 52; +my $total_tests = 53; if ($Is_EBCDIC || $Is_UTF8) { $total_tests -= 3; } print "1..$total_tests\n"; @@ -286,6 +286,14 @@ if (defined &DynaLoader::boot_DynaLoader) { print "${not}ok $i - require ignores I/O layers\n"; } +{ + BEGIN { ${^OPEN} = ":utf8\0"; } + %INC = (); + write_file('bleah.pm',"require re; re->import('/x'); 1;\n"); + my $not = eval 'use bleah; "ab" =~ /a b/' ? "" : "not "; + $i++; + print "${not}ok $i - require does not localise %^H at run time\n"; +} ########################################## # What follows are UTF-8 specific tests. # diff --git a/t/op/eval.t b/t/op/eval.t index 91361c136c..f8e23e3295 100644 --- a/t/op/eval.t +++ b/t/op/eval.t @@ -6,7 +6,7 @@ BEGIN { require './test.pl'; } -plan(tests => 119); +plan(tests => 120); eval 'pass();'; @@ -580,3 +580,9 @@ fresh_perl_is(<<'EOP', "ok\nok\nok\n", undef, 'eval clears %^H'); } print "ab" =~ /a b/ ? "ok\n" : "nokay\n"; EOP + +# [perl #70151] +{ + BEGIN { eval 'require re; import re "/x"' } + ok "ab" =~ /a b/, 'eval does not localise %^H at run time'; +} |