This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
[perl #106282] Don’t crash cloning tied %^H
[perl5.git] / t / comp / hints.t
index 7796727..b70f15e 100644 (file)
@@ -6,7 +6,7 @@ BEGIN {
     @INC = qw(. ../lib);
 }
 
-BEGIN { print "1..24\n"; }
+BEGIN { print "1..25\n"; }
 BEGIN {
     print "not " if exists $^H{foo};
     print "ok 1 - \$^H{foo} doesn't exist initially\n";
@@ -128,6 +128,29 @@ BEGIN {
        "ok 23 - \$^H{foo} correct after /unicode/i (res=$res)\n";
 }
 
+# [perl #106282] Crash when tying %^H
+# Tying %^H does not and cannot work, but it should not crash.
+eval q`
+    # Do something naughty enough, and you get your module mentioned in the
+    # test suite. :-)
+    package namespace::clean::_TieHintHash;
+
+    sub TIEHASH  { bless[] }
+    sub STORE    { $_[0][0]{$_[1]} = $_[2] }
+    sub FETCH    { $_[0][0]{$_[1]} }
+    sub FIRSTKEY { my $a = scalar keys %{$_[0][0]}; each %{$_[0][0]} }
+    sub NEXTKEY  { each %{$_[0][0]} }
+
+    package main;
+
+    BEGIN {
+       $^H{foo} = "bar"; # activate localisation magic
+       tie( %^H, 'namespace::clean::_TieHintHash' ); # sabotage %^H
+       $^H{foo} = "bar"; # create an element in the tied hash
+    }
+    { ; } # clone the tied hint hash
+`;
+print "ok 24 - no crash when cloning a tied hint hash\n";
 
 
 # Add new tests above this require, in case it fails.
@@ -139,7 +162,7 @@ my $result = runperl(
     stderr => 1
 );
 print "not " if length $result;
-print "ok 24 - double-freeing hints hash\n";
+print "ok 25 - double-freeing hints hash\n";
 print "# got: $result\n" if length $result;
 
 __END__