Add clear magic to %^H so that the HE chain is reset when you empty it.

This fixes [perl #68590] : %^H not lexical enough.

diff --git a/MANIFEST b/MANIFEST
index 2fb8ee0..a5daf74 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -3929,6 +3929,7 @@ t/comp/cmdopt.t                   See if command optimization works
 t/comp/colon.t                 See if colons are parsed correctly
 t/comp/decl.t                  See if declarations work
 t/comp/fold.t                  See if constant folding works
+t/comp/hints.aux               Auxillary file for %^H test
 t/comp/hints.t                 See if %^H works
 t/comp/multiline.t             See if multiline strings work
 t/comp/opsubs.t                        See if q() etc. are not parsed as functions

diff --git a/cop.h b/cop.h
index fc19494..3633e9d 100644 (file)
--- a/cop.h
+++ b/cop.h
@@ -246,12 +246,17 @@ struct cop {
 #define CopARYBASE_set(c, b) STMT_START { \
        if (b || ((c)->cop_hints & HINT_ARYBASE)) {                     \
            (c)->cop_hints |= HINT_ARYBASE;                             \
-           if ((c) == &PL_compiling)                                   \
-               PL_hints |= HINT_LOCALIZE_HH | HINT_ARYBASE;            \
-           (c)->cop_hints_hash                                         \
-              = Perl_refcounted_he_new(aTHX_ (c)->cop_hints_hash,      \
+           if ((c) == &PL_compiling) {                                 \
+               SV *val = newSViv(b);                                   \
+               (void)hv_stores(GvHV(PL_hintgv), "$[", val);            \
+               mg_set(val);                                            \
+               PL_hints |= HINT_ARYBASE;                               \
+           } else {                                                    \
+               (c)->cop_hints_hash                                     \
+                  = Perl_refcounted_he_new(aTHX_ (c)->cop_hints_hash,  \
                                        newSVpvs_flags("$[", SVs_TEMP), \
                                        sv_2mortal(newSViv(b)));        \
+           }                                                           \
        }                                                               \
     } STMT_END
 

diff --git a/dump.c b/dump.c
index e7f5a1d..c891b2f 100644 (file)
--- a/dump.c
+++ b/dump.c
@@ -1261,6 +1261,7 @@ Perl_do_magic_dump(pTHX_ I32 level, PerlIO *file, const MAGIC *mg, I32 nest, I32
            else if (v == &PL_vtbl_utf8)       s = "utf8";
             else if (v == &PL_vtbl_arylen_p)   s = "arylen_p";
             else if (v == &PL_vtbl_hintselem)  s = "hintselem";
+            else if (v == &PL_vtbl_hints)      s = "hints";
            else                               s = NULL;
            if (s)
                Perl_dump_indent(aTHX_ level, file, "    MG_VIRTUAL = &PL_vtbl_%s\n", s);

diff --git a/embed.fnc b/embed.fnc
index 67a79f5..33774c7 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -535,6 +535,7 @@ Apd |UV     |grok_oct       |NN const char* start|NN STRLEN* len_p|NN I32* flags|NULLOK NV
 p      |int    |magic_clearenv |NN SV* sv|NN MAGIC* mg
 p      |int    |magic_clear_all_env|NN SV* sv|NN MAGIC* mg
 dp     |int    |magic_clearhint|NN SV* sv|NN MAGIC* mg
+dp     |int    |magic_clearhints|NN SV* sv|NN MAGIC* mg
 p      |int    |magic_clearisa |NULLOK SV* sv|NN MAGIC* mg
 p      |int    |magic_clearpack|NN SV* sv|NN MAGIC* mg
 p      |int    |magic_clearsig |NN SV* sv|NN MAGIC* mg

diff --git a/embed.h b/embed.h
index b042886..5968fb6 100644 (file)
--- a/embed.h
+++ b/embed.h
@@ -423,6 +423,7 @@
 #define magic_clearenv         Perl_magic_clearenv
 #define magic_clear_all_env    Perl_magic_clear_all_env
 #define magic_clearhint                Perl_magic_clearhint
+#define magic_clearhints       Perl_magic_clearhints
 #define magic_clearisa         Perl_magic_clearisa
 #define magic_clearpack                Perl_magic_clearpack
 #define magic_clearsig         Perl_magic_clearsig
@@ -2759,6 +2760,7 @@
 #define magic_clearenv(a,b)    Perl_magic_clearenv(aTHX_ a,b)
 #define magic_clear_all_env(a,b)       Perl_magic_clear_all_env(aTHX_ a,b)
 #define magic_clearhint(a,b)   Perl_magic_clearhint(aTHX_ a,b)
+#define magic_clearhints(a,b)  Perl_magic_clearhints(aTHX_ a,b)
 #define magic_clearisa(a,b)    Perl_magic_clearisa(aTHX_ a,b)
 #define magic_clearpack(a,b)   Perl_magic_clearpack(aTHX_ a,b)
 #define magic_clearsig(a,b)    Perl_magic_clearsig(aTHX_ a,b)

diff --git a/mg.c b/mg.c
index 5cfa8cb..c15119f 100644 (file)
--- a/mg.c
+++ b/mg.c
@@ -2391,31 +2391,23 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
            const char *const start = SvPV(sv, len);
            const char *out = (const char*)memchr(start, '\0', len);
            SV *tmp;
-           struct refcounted_he *tmp_he;
 
 
            PL_compiling.cop_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
-           PL_hints
-               |= HINT_LOCALIZE_HH | HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
+           PL_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
 
            /* Opening for input is more common than opening for output, so
               ensure that hints for input are sooner on linked list.  */
            tmp = out ? newSVpvn_flags(out + 1, start + len - out - 1,
-                                      SVs_TEMP | SvUTF8(sv))
-               : newSVpvs_flags("", SVs_TEMP | SvUTF8(sv));
+                                      SvUTF8(sv))
+               : newSVpvs_flags("", SvUTF8(sv));
+           (void)hv_stores(GvHV(PL_hintgv), "open>", tmp);
+           mg_set(tmp);
 
-           tmp_he
-               = Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints_hash, 
-                                        newSVpvs_flags("open>", SVs_TEMP),
-                                        tmp);
-
-           /* The UTF-8 setting is carried over  */
-           sv_setpvn(tmp, start, out ? (STRLEN)(out - start) : len);
-
-           PL_compiling.cop_hints_hash
-               = Perl_refcounted_he_new(aTHX_ tmp_he,
-                                        newSVpvs_flags("open<", SVs_TEMP),
-                                        tmp);
+           tmp = newSVpvn_flags(start, out ? (STRLEN)(out - start) : len,
+                                       SvUTF8(sv));
+           (void)hv_stores(GvHV(PL_hintgv), "open<", tmp);
+           mg_set(tmp);
        }
        break;
     case '\020':       /* ^P */
@@ -3096,6 +3088,26 @@ Perl_magic_clearhint(pTHX_ SV *sv, MAGIC *mg)
 }
 
 /*
+=for apidoc magic_clearhints
+
+Triggered by clearing %^H, resets C<PL_compiling.cop_hints_hash>.
+
+=cut
+*/
+int
+Perl_magic_clearhints(pTHX_ SV *sv, MAGIC *mg)
+{
+    PERL_ARGS_ASSERT_MAGIC_CLEARHINTS;
+    PERL_UNUSED_ARG(sv);
+    PERL_UNUSED_ARG(mg);
+    if (PL_compiling.cop_hints_hash) {
+       Perl_refcounted_he_free(aTHX_ PL_compiling.cop_hints_hash);
+       PL_compiling.cop_hints_hash = NULL;
+    }
+    return 0;
+}
+
+/*
  * Local variables:
  * c-indentation-style: bsd
  * c-basic-offset: 4

diff --git a/perl.h b/perl.h
index 75c52e7..136bd53 100644 (file)
--- a/perl.h
+++ b/perl.h
@@ -4645,7 +4645,8 @@ enum {            /* pass one of these to get_vtbl */
     want_vtbl_utf8,
     want_vtbl_symtab,
     want_vtbl_arylen_p,
-    want_vtbl_hintselem
+    want_vtbl_hintselem,
+    want_vtbl_hints
 };
 
 
@@ -4950,7 +4951,6 @@ MGVTBL_SET(
     0
 );
 
-/* For now, hints magic will also use vtbl_sig, because it is all 0  */
 MGVTBL_SET(
     PL_vtbl_sig,
     0,
@@ -5315,6 +5315,18 @@ MGVTBL_SET(
     0
 );
 
+MGVTBL_SET(
+    PL_vtbl_hints,
+    0,
+    0,
+    0,
+    MEMBER_TO_FPTR(Perl_magic_clearhints),
+    0,
+    0,
+    0,
+    0
+);
+
 #include "overload.h"
 
 END_EXTERN_C

diff --git a/pod/perlguts.pod b/pod/perlguts.pod
index 2b6fd8c..afc69ae 100644 (file)
--- a/pod/perlguts.pod
+++ b/pod/perlguts.pod
@@ -1038,7 +1038,7 @@ The current kinds of Magic Virtual Tables are:
     e  PERL_MAGIC_envelem        vtbl_envelem    %ENV hash element
     f  PERL_MAGIC_fm             vtbl_fm         Formline ('compiled' format)
     g  PERL_MAGIC_regex_global   vtbl_mglob      m//g target / study()ed string
-    H  PERL_MAGIC_hints          vtbl_sig        %^H hash
+    H  PERL_MAGIC_hints          vtbl_hints      %^H hash
     h  PERL_MAGIC_hintselem      vtbl_hintselem  %^H hash element
     I  PERL_MAGIC_isa            vtbl_isa        @ISA array
     i  PERL_MAGIC_isaelem        vtbl_isaelem    @ISA array element

diff --git a/pp_ctl.c b/pp_ctl.c
index 35e3436..0eb513f 100644 (file)
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -3568,10 +3568,7 @@ PP(pp_require)
 
     SAVEHINTS();
     PL_hints = 0;
-    if (PL_compiling.cop_hints_hash) {
-       Perl_refcounted_he_free(aTHX_ PL_compiling.cop_hints_hash);
-       PL_compiling.cop_hints_hash = NULL;
-    }
+    hv_clear(GvHV(PL_hintgv));
 
     SAVECOMPILEWARNINGS();
     if (PL_dowarn & G_WARN_ALL_ON)

diff --git a/proto.h b/proto.h
index 1b93673..5fe779a 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -1504,6 +1504,12 @@ PERL_CALLCONV int        Perl_magic_clearhint(pTHX_ SV* sv, MAGIC* mg)
 #define PERL_ARGS_ASSERT_MAGIC_CLEARHINT       \
        assert(sv); assert(mg)
 
+PERL_CALLCONV int      Perl_magic_clearhints(pTHX_ SV* sv, MAGIC* mg)
+                       __attribute__nonnull__(pTHX_1)
+                       __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_MAGIC_CLEARHINTS      \
+       assert(sv); assert(mg)
+
 PERL_CALLCONV int      Perl_magic_clearisa(pTHX_ SV* sv, MAGIC* mg)
                        __attribute__nonnull__(pTHX_2);
 #define PERL_ARGS_ASSERT_MAGIC_CLEARISA        \

diff --git a/sv.c b/sv.c
index b8daf81..b9f682c 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -5096,8 +5096,6 @@ Perl_sv_magic(pTHX_ register SV *const sv, SV *const obj, const int how,
     case PERL_MAGIC_qr:
        vtable = &PL_vtbl_regexp;
        break;
-    case PERL_MAGIC_hints:
-       /* As this vtable is all NULL, we can reuse it.  */
     case PERL_MAGIC_sig:
        vtable = &PL_vtbl_sig;
        break;
@@ -5140,6 +5138,9 @@ Perl_sv_magic(pTHX_ register SV *const sv, SV *const obj, const int how,
     case PERL_MAGIC_hintselem:
        vtable = &PL_vtbl_hintselem;
        break;
+    case PERL_MAGIC_hints:
+       vtable = &PL_vtbl_hints;
+       break;
     case PERL_MAGIC_ext:
        /* Reserved for use by extensions not perl internals.           */
        /* Useful for attaching extension internal data to perl vars.   */

diff --git a/t/comp/hints.aux b/t/comp/hints.aux
new file mode 100644 (file)
index 0000000..79b6dee
--- /dev/null
+++ b/t/comp/hints.aux
@@ -0,0 +1,5 @@
+our($ra1, $ri1, $rf1, $rfe1);
+$ra1 = $[;
+BEGIN { $ri1 = $^H; $rf1 = $^H{foo}; $rfe1 = exists($^H{foo}); }
+
+1;

diff --git a/t/comp/hints.t b/t/comp/hints.t
index 55aeb71..b19fc5f 100644 (file)
--- a/t/comp/hints.t
+++ b/t/comp/hints.t
@@ -8,7 +8,7 @@ BEGIN {
 }
 
 
-BEGIN { print "1..17\n"; }
+BEGIN { print "1..32\n"; }
 BEGIN {
     print "not " if exists $^H{foo};
     print "ok 1 - \$^H{foo} doesn't exist initially\n";
@@ -38,7 +38,7 @@ BEGIN {
     }
     BEGIN {
        print "not " if $^H{foo} ne "a";
-       print "ok 6 - \$H^{foo} restored to 'a'\n";
+       print "ok 6 - \$^H{foo} restored to 'a'\n";
     }
     # The pragma settings disappear after compilation
     # (test at CHECK-time and at run-time)
@@ -95,14 +95,52 @@ print "# got: $result\n" if length $result;
 
 {
     BEGIN{$^H{x}=1};
-    for(1..2) {
+    for my $tno (16..17) {
         eval q(
-            print $^H{x}==1 && !$^H{y} ? "ok\n" : "not ok\n";
+            print $^H{x}==1 && !$^H{y} ? "ok $tno\n" : "not ok $tno\n";
             $^H{y} = 1;
         );
         if ($@) {
             (my $str = $@)=~s/^/# /gm;
-            print "not ok\n$str\n";
+            print "not ok $tno\n$str\n";
         }
     }
 }
+
+{
+    $[ = 11;
+    print +($[ == 11 ? "" : "not "), "ok 18 - setting \$[ affects \$[\n";
+    our $t11; BEGIN { $t11 = $^H{'$['} }
+    print +($t11 == 11 ? "" : "not "), "ok 19 - setting \$[ affects \$^H{'\$['}\n";
+
+    BEGIN { $^H{'$['} = 22 }
+    print +($[ == 22 ? "" : "not "), "ok 20 - setting \$^H{'\$['} affects \$[\n";
+    our $t22; BEGIN { $t22 = $^H{'$['} }
+    print +($t22 == 22 ? "" : "not "), "ok 21 - setting \$^H{'\$['} affects \$^H{'\$['}\n";
+
+    BEGIN { %^H = () }
+    print +($[ == 0 ? "" : "not "), "ok 22 - clearing \%^H affects \$[\n";
+    our $t0; BEGIN { $t0 = $^H{'$['} }
+    print +($t0 == 0 ? "" : "not "), "ok 23 - clearing \%^H affects \$^H{'\$['}\n";
+}
+
+{
+    $[ = 13;
+    BEGIN { $^H |= 0x04000000; $^H{foo} = "z"; }
+
+    our($ri0, $rf0); BEGIN { $ri0 = $^H; $rf0 = $^H{foo}; }
+    print +($[ == 13 ? "" : "not "), "ok 24 - \$[ correct before require\n";
+    print +($ri0 & 0x04000000 ? "" : "not "), "ok 25 - \$^H correct before require\n";
+    print +($rf0 eq "z" ? "" : "not "), "ok 26 - \$^H{foo} correct before require\n";
+
+    our($ra1, $ri1, $rf1, $rfe1);
+    BEGIN { require "comp/hints.aux"; }
+    print +($ra1 == 0 ? "" : "not "), "ok 27 - \$[ cleared for require\n";
+    print +(!($ri1 & 0x04000000) ? "" : "not "), "ok 28 - \$^H cleared for require\n";
+    print +(!defined($rf1) && !$rfe1 ? "" : "not "), "ok 29 - \$^H{foo} cleared for require\n";
+
+    our($ri2, $rf2); BEGIN { $ri2 = $^H; $rf2 = $^H{foo}; }
+    print +($[ == 13 ? "" : "not "), "ok 30 - \$[ correct after require\n";
+    print +($ri2 & 0x04000000 ? "" : "not "), "ok 31 - \$^H correct after require\n";
+    print +($rf2 eq "z" ? "" : "not "), "ok 32 - \$^H{foo} correct after require\n";
+}