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
1 #!./perl
2
3 # Tests the scoping of $^H and %^H
4
5 BEGIN {
6     @INC = qw(. ../lib);
7 }
8
9 BEGIN { print "1..25\n"; }
10 BEGIN {
11     print "not " if exists $^H{foo};
12     print "ok 1 - \$^H{foo} doesn't exist initially\n";
13     if (${^OPEN}) {
14         print "not " unless $^H & 0x00020000;
15         print "ok 2 - \$^H contains HINT_LOCALIZE_HH initially with ${^OPEN}\n";
16     } else {
17         print "not " if $^H & 0x00020000;
18         print "ok 2 - \$^H doesn't contain HINT_LOCALIZE_HH initially\n";
19     }
20 }
21 {
22     # simulate a pragma -- don't forget HINT_LOCALIZE_HH
23     BEGIN { $^H |= 0x04020000; $^H{foo} = "a"; }
24     BEGIN {
25         print "not " if $^H{foo} ne "a";
26         print "ok 3 - \$^H{foo} is now 'a'\n";
27         print "not " unless $^H & 0x00020000;
28         print "ok 4 - \$^H contains HINT_LOCALIZE_HH while compiling\n";
29     }
30     {
31         BEGIN { $^H |= 0x00020000; $^H{foo} = "b"; }
32         BEGIN {
33             print "not " if $^H{foo} ne "b";
34             print "ok 5 - \$^H{foo} is now 'b'\n";
35         }
36     }
37     BEGIN {
38         print "not " if $^H{foo} ne "a";
39         print "ok 6 - \$^H{foo} restored to 'a'\n";
40     }
41     # The pragma settings disappear after compilation
42     # (test at CHECK-time and at run-time)
43     CHECK {
44         print "not " if exists $^H{foo};
45         print "ok 9 - \$^H{foo} doesn't exist when compilation complete\n";
46         if (${^OPEN}) {
47             print "not " unless $^H & 0x00020000;
48             print "ok 10 - \$^H contains HINT_LOCALIZE_HH when compilation complete with ${^OPEN}\n";
49         } else {
50             print "not " if $^H & 0x00020000;
51             print "ok 10 - \$^H doesn't contain HINT_LOCALIZE_HH when compilation complete\n";
52         }
53     }
54     print "not " if exists $^H{foo};
55     print "ok 11 - \$^H{foo} doesn't exist at runtime\n";
56     if (${^OPEN}) {
57         print "not " unless $^H & 0x00020000;
58         print "ok 12 - \$^H contains HINT_LOCALIZE_HH at run-time with ${^OPEN}\n";
59     } else {
60         print "not " if $^H & 0x00020000;
61         print "ok 12 - \$^H doesn't contain HINT_LOCALIZE_HH at run-time\n";
62     }
63     # op_entereval should keep the pragmas it was compiled with
64     eval q*
65       BEGIN {
66         print "not " if $^H{foo} ne "a";
67         print "ok 13 - \$^H{foo} is 'a' at eval-\"\" time\n";
68         print "not " unless $^H & 0x00020000;
69         print "ok 14 - \$^H contains HINT_LOCALIZE_HH at eval\"\"-time\n";
70       }
71     *;
72 }
73 BEGIN {
74     print "not " if exists $^H{foo};
75     print "ok 7 - \$^H{foo} doesn't exist while finishing compilation\n";
76     if (${^OPEN}) {
77         print "not " unless $^H & 0x00020000;
78         print "ok 8 - \$^H contains HINT_LOCALIZE_HH while finishing compilation with ${^OPEN}\n";
79     } else {
80         print "not " if $^H & 0x00020000;
81         print "ok 8 - \$^H doesn't contain HINT_LOCALIZE_HH while finishing compilation\n";
82     }
83 }
84
85 {
86     BEGIN{$^H{x}=1};
87     for my $tno (15..16) {
88         eval q(
89             BEGIN {
90                 print $^H{x}==1 && !$^H{y} ? "ok $tno\n" : "not ok $tno\n";
91             }
92             $^H{y} = 1;
93         );
94         if ($@) {
95             (my $str = $@)=~s/^/# /gm;
96             print "not ok $tno\n$str\n";
97         }
98     }
99 }
100
101 {
102     BEGIN { $^H |= 0x04000000; $^H{foo} = "z"; }
103
104     our($ri0, $rf0); BEGIN { $ri0 = $^H; $rf0 = $^H{foo}; }
105     print +($ri0 & 0x04000000 ? "" : "not "), "ok 17 - \$^H correct before require\n";
106     print +($rf0 eq "z" ? "" : "not "), "ok 18 - \$^H{foo} correct before require\n";
107
108     our($ra1, $ri1, $rf1, $rfe1);
109     BEGIN { require "comp/hints.aux"; }
110     print +(!($ri1 & 0x04000000) ? "" : "not "), "ok 19 - \$^H cleared for require\n";
111     print +(!defined($rf1) && !$rfe1 ? "" : "not "), "ok 20 - \$^H{foo} cleared for require\n";
112
113     our($ri2, $rf2); BEGIN { $ri2 = $^H; $rf2 = $^H{foo}; }
114     print +($ri2 & 0x04000000 ? "" : "not "), "ok 21 - \$^H correct after require\n";
115     print +($rf2 eq "z" ? "" : "not "), "ok 22 - \$^H{foo} correct after require\n";
116 }
117
118 # [perl #73174]
119
120 {
121     my $res;
122     BEGIN { $^H{73174} = "foo" }
123     BEGIN { $res = ($^H{73174} // "") }
124     "" =~ /\x{100}/i;   # forces loading of utf8.pm, which used to reset %^H
125     BEGIN { $res .= '-' . ($^H{73174} // "")}
126     $res .= '-' . ($^H{73174} // "");
127     print $res eq "foo-foo-" ? "" : "not ",
128         "ok 23 - \$^H{foo} correct after /unicode/i (res=$res)\n";
129 }
130
131 # [perl #106282] Crash when tying %^H
132 # Tying %^H does not and cannot work, but it should not crash.
133 eval q`
134     # Do something naughty enough, and you get your module mentioned in the
135     # test suite. :-)
136     package namespace::clean::_TieHintHash;
137
138     sub TIEHASH  { bless[] }
139     sub STORE    { $_[0][0]{$_[1]} = $_[2] }
140     sub FETCH    { $_[0][0]{$_[1]} }
141     sub FIRSTKEY { my $a = scalar keys %{$_[0][0]}; each %{$_[0][0]} }
142     sub NEXTKEY  { each %{$_[0][0]} }
143
144     package main;
145
146     BEGIN {
147         $^H{foo} = "bar"; # activate localisation magic
148         tie( %^H, 'namespace::clean::_TieHintHash' ); # sabotage %^H
149         $^H{foo} = "bar"; # create an element in the tied hash
150     }
151     { ; } # clone the tied hint hash
152 `;
153 print "ok 24 - no crash when cloning a tied hint hash\n";
154
155
156 # Add new tests above this require, in case it fails.
157 require './test.pl';
158
159 # bug #27040: hints hash was being double-freed
160 my $result = runperl(
161     prog => '$^H |= 0x20000; eval q{BEGIN { $^H |= 0x20000 }}',
162     stderr => 1
163 );
164 print "not " if length $result;
165 print "ok 25 - double-freeing hints hash\n";
166 print "# got: $result\n" if length $result;
167
168 __END__
169 # Add new tests above require 'test.pl'