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

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

13 files changed, 116 insertions, 35 deletions

diff --git a/MANIFEST b/MANIFEST
index 2fb8ee096f..a5daf74be1 100644
--- 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 fc19494e25..3633e9d353 100644
--- 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 e7f5a1df01..c891b2fc2a 100644
--- 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 67a79f551e..33774c77d6 100644
--- 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 b042886901..5968fb6228 100644
--- 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 5cfa8cb920..c15119fd55 100644
--- 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 75c52e7420..136bd53b07 100644
--- 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 2b6fd8cef8..afc69aef0b 100644
--- 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 35e3436cb4..0eb513f9a3 100644
--- 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 1b9367347f..5fe779ae81 100644
--- 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 b8daf81546..b9f682cb63 100644
--- 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
index 0000000000..79b6deed8c
--- /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 55aeb7169e..b19fc5fdfe 100644
--- 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";
+}