[perl #70151] eval localises %^H at runtime

It doesn’t any more.

Now the hints are localised in a separate inner scope surrounding the
call to yyparse.  This meant moving hint-handling code from pp_require
and pp_entereval into S_doeval.

Some tests in t/comp/hints.t were testing for the buggy behaviour, so
they have been adjusted.

Basically, this fixes

    sub import {
        eval "strict->import"
    }

which should work the same way as

    sub import {
        strict->import
    }

but was not working because %^H and $^H were being localised to
the eval at its run time, not just its compilation.  So the values
assigned to %^H and $^H at the eval’s run time would simply be lost.

diff --git a/embed.fnc b/embed.fnc
index 394e86a..0857dd8 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -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

diff --git a/embed.h b/embed.h
index 4aada86..8ed8d32 100644 (file)
--- a/embed.h
+++ b/embed.h
@@ -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)

diff --git a/pp_ctl.c b/pp_ctl.c
index 98a280f..23e4d9d 100644 (file)
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -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) {

diff --git a/proto.h b/proto.h
index b5747f6..61bab08 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -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 b81028a..7796727 100644 (file)
--- 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 07ac51b..d704762 100644 (file)
--- 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 91361c1..f8e23e3 100644 (file)
--- 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';
+}