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..24\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         print "not " if $^H{foo} ne "a";
  66         print "ok 13 - \$^H{foo} is 'a' at eval-\"\" time\n";
  67         print "not " unless $^H & 0x00020000;
  68         print "ok 14 - \$^H contains HINT_LOCALIZE_HH at eval\"\"-time\n";
  69     *;
  70 }
  71 BEGIN {
  72     print "not " if exists $^H{foo};
  73     print "ok 7 - \$^H{foo} doesn't exist while finishing compilation\n";
  74     if (${^OPEN}) {
  75         print "not " unless $^H & 0x00020000;
  76         print "ok 8 - \$^H contains HINT_LOCALIZE_HH while finishing compilation with ${^OPEN}\n";
  77     } else {
  78         print "not " if $^H & 0x00020000;
  79         print "ok 8 - \$^H doesn't contain HINT_LOCALIZE_HH while finishing compilation\n";
  80     }
  81 }
  82
  83 {
  84     BEGIN{$^H{x}=1};
  85     for my $tno (15..16) {
  86         eval q(
  87             print $^H{x}==1 && !$^H{y} ? "ok $tno\n" : "not ok $tno\n";
  88             $^H{y} = 1;
  89         );
  90         if ($@) {
  91             (my $str = $@)=~s/^/# /gm;
  92             print "not ok $tno\n$str\n";
  93         }
  94     }
  95 }
  96
  97 {
  98     BEGIN { $^H |= 0x04000000; $^H{foo} = "z"; }
  99
 100     our($ri0, $rf0); BEGIN { $ri0 = $^H; $rf0 = $^H{foo}; }
 101     print +($ri0 & 0x04000000 ? "" : "not "), "ok 17 - \$^H correct before require\n";
 102     print +($rf0 eq "z" ? "" : "not "), "ok 18 - \$^H{foo} correct before require\n";
 103
 104     our($ra1, $ri1, $rf1, $rfe1);
 105     BEGIN { require "comp/hints.aux"; }
 106     print +(!($ri1 & 0x04000000) ? "" : "not "), "ok 19 - \$^H cleared for require\n";
 107     print +(!defined($rf1) && !$rfe1 ? "" : "not "), "ok 20 - \$^H{foo} cleared for require\n";
 108
 109     our($ri2, $rf2); BEGIN { $ri2 = $^H; $rf2 = $^H{foo}; }
 110     print +($ri2 & 0x04000000 ? "" : "not "), "ok 21 - \$^H correct after require\n";
 111     print +($rf2 eq "z" ? "" : "not "), "ok 22 - \$^H{foo} correct after require\n";
 112 }
 113
 114 # [perl #73174]
 115
 116 {
 117     my $res;
 118     BEGIN { $^H{73174} = "foo" }
 119     BEGIN { $res = ($^H{73174} // "") }
 120     "" =~ /\x{100}/i;   # forces loading of utf8.pm, which used to reset %^H
 121     BEGIN { $res .= '-' . ($^H{73174} // "")}
 122     $res .= '-' . ($^H{73174} // "");
 123     print $res eq "foo-foo-" ? "" : "not ",
 124         "ok 23 - \$^H{foo} correct after /unicode/i (res=$res)\n";
 125 }
 126
 127
 128
 129 # Add new tests above this require, in case it fails.
 130 require './test.pl';
 131
 132 # bug #27040: hints hash was being double-freed
 133 my $result = runperl(
 134     prog => '$^H |= 0x20000; eval q{BEGIN { $^H |= 0x20000 }}',
 135     stderr => 1
 136 );
 137 print "not " if length $result;
 138 print "ok 24 - double-freeing hints hash\n";
 139 print "# got: $result\n" if length $result;
 140
 141 __END__
 142 # Add new tests above require 'test.pl'