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..31\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 should not result in a crash when the hint hash is cloned.
 133 # Hints should also be copied properly to inner scopes.  See also
 134 # [rt.cpan.org #73402].
 135 eval q`
 136     # Do something naughty enough, and you get your module mentioned in the
 137     # test suite. :-)
 138     package namespace::clean::_TieHintHash;
 139
 140     sub TIEHASH  { bless[] }
 141     sub STORE    { $_[0][0]{$_[1]} = $_[2] }
 142     sub FETCH    { $_[0][0]{$_[1]} }
 143     sub FIRSTKEY { my $a = scalar keys %{$_[0][0]}; each %{$_[0][0]} }
 144     sub NEXTKEY  { each %{$_[0][0]} }
 145
 146     package main;
 147
 148     BEGIN {
 149         $^H{foo} = "bar"; # activate localisation magic
 150         tie( %^H, 'namespace::clean::_TieHintHash' ); # sabotage %^H
 151         $^H{foo} = "bar"; # create an element in the tied hash
 152     }
 153     { # clone the tied hint hash on scope entry
 154         BEGIN {
 155             print "not " x ($^H{foo} ne 'bar'),
 156                   "ok 24 - tied hint hash is copied to inner scope\n";
 157             %^H = ();
 158             tie( %^H, 'namespace::clean::_TieHintHash' );
 159             $^H{foo} = "bar";
 160         }
 161         {
 162             BEGIN{
 163                 print
 164                   "not " x ($^H{foo} ne 'bar'),
 165                   "ok 25 - tied empty hint hash is copied to inner scope\n"
 166             }
 167         }
 168         1;
 169     }
 170     1;
 171 ` or warn $@;
 172 print "ok 26 - no crash when cloning a tied hint hash\n";
 173
 174 {
 175     my $w;
 176     local $SIG{__WARN__} = sub { $w = shift };
 177     eval q`
 178         package namespace::clean::_TieHintHasi;
 179
 180         sub TIEHASH  { bless[] }
 181         sub STORE    { $_[0][0]{$_[1]} = $_[2] }
 182         sub FETCH    { $_[0][0]{$_[1]} }
 183         sub FIRSTKEY { my $a = scalar keys %{$_[0][0]}; each %{$_[0][0]} }
 184       # Intentionally commented out:
 185       #  sub NEXTKEY  { each %{$_[0][0]} }
 186
 187         package main;
 188
 189         BEGIN {
 190             $^H{foo} = "bar"; # activate localisation magic
 191             tie( %^H, 'namespace::clean::_TieHintHasi' ); # sabotage %^H
 192             $^H{foo} = "bar"; # create an element in the tied hash
 193         }
 194         { ; } # clone the tied hint hash
 195     `;
 196     print "not " if $w;
 197     print "ok 27 - double-freeing explosive tied hints hash\n";
 198     print "# got: $w" if $w;
 199 }
 200
 201 # Setting ${^WARNING_HINTS} to its own value should not change things.
 202 {
 203     my $w;
 204     local $SIG{__WARN__} = sub { $w++ };
 205     BEGIN {
 206         # should have no effect:
 207         my $x = ${^WARNING_BITS};
 208         ${^WARNING_BITS} = $x;
 209     }
 210     {
 211         local $^W = 1;
 212         () = 1 + undef;
 213     }
 214     print "# ", $w//'no', " warnings\nnot " unless $w == 1;
 215     print "ok 28 - ",
 216           "setting \${^WARNING_BITS} to its own value has no effect\n";
 217 }
 218
 219 # [perl #112326]
 220 # this code could cause a crash, due to PL_hints continuing to point to th
 221 # hints hash currently being freed
 222
 223 {
 224     package Foo;
 225     my @h = qw(a 1 b 2);
 226     BEGIN {
 227         $^H{FOO} = bless {};
 228     }
 229     sub DESTROY {
 230         @h = %^H;
 231         delete $INC{strict}; require strict; # boom!
 232     }
 233     my $h = join ':', %h;
 234     # this isn't the main point of the test; the main point is that
 235     # it doesn't crash!
 236     print "not " if $h ne '';
 237     print "ok 29 - #112326\n";
 238 }
 239
 240
 241 # [perl #112444]
 242 # A destructor called while %^H is freed should not be able to stop %^H
 243 # from being magical (due to *^H{HASH} being undef).
 244 {
 245     BEGIN {
 246         # Make sure %^H is clear and not localised, to begin with
 247         %^H = ();
 248         $^H = 0;
 249     }
 250     DESTROY { %^H }
 251     {
 252         {
 253             BEGIN {
 254                 $^H{foom} = bless[];
 255             }
 256         } # scope exit triggers destructor, which autovivifies a non-
 257           # magical %^H
 258         BEGIN {
 259             # Here we have the %^H created by DESTROY, which is
 260             # not localised
 261             $^H{112444} = 'baz';
 262         }
 263     } # %^H leaks on scope exit
 264     BEGIN { @keez = keys %^H }
 265 }
 266 print "not " if @keez;
 267 print "ok 30 - %^H does not leak when autovivified in destructor\n";
 268 print "# keys are: @keez\n" if @keez;
 269
 270
 271 # Add new tests above this require, in case it fails.
 272 require './test.pl';
 273
 274 # bug #27040: hints hash was being double-freed
 275 my $result = runperl(
 276     prog => '$^H |= 0x20000; eval q{BEGIN { $^H |= 0x20000 }}',
 277     stderr => 1
 278 );
 279 print "not " if length $result;
 280 print "ok 31 - double-freeing hints hash\n";
 281 print "# got: $result\n" if length $result;
 282
 283 __END__
 284 # Add new tests above require 'test.pl'