t/comp/hints.t

   1 #!./perl
   2
   3 # Tests the scoping of $^H and %^H
   4
   5 BEGIN {
   6     chdir 't' if -d 't';
   7     @INC = qw(. ../lib);
   8 }
   9
  10
  11 BEGIN { print "1..32\n"; }
  12 BEGIN {
  13     print "not " if exists $^H{foo};
  14     print "ok 1 - \$^H{foo} doesn't exist initially\n";
  15     if (${^OPEN}) {
  16         print "not " unless $^H & 0x00020000;
  17         print "ok 2 - \$^H contains HINT_LOCALIZE_HH initially with ${^OPEN}\n";
  18     } else {
  19         print "not " if $^H & 0x00020000;
  20         print "ok 2 - \$^H doesn't contain HINT_LOCALIZE_HH initially\n";
  21     }
  22 }
  23 {
  24     # simulate a pragma -- don't forget HINT_LOCALIZE_HH
  25     BEGIN { $^H |= 0x04020000; $^H{foo} = "a"; }
  26     BEGIN {
  27         print "not " if $^H{foo} ne "a";
  28         print "ok 3 - \$^H{foo} is now 'a'\n";
  29         print "not " unless $^H & 0x00020000;
  30         print "ok 4 - \$^H contains HINT_LOCALIZE_HH while compiling\n";
  31     }
  32     {
  33         BEGIN { $^H |= 0x00020000; $^H{foo} = "b"; }
  34         BEGIN {
  35             print "not " if $^H{foo} ne "b";
  36             print "ok 5 - \$^H{foo} is now 'b'\n";
  37         }
  38     }
  39     BEGIN {
  40         print "not " if $^H{foo} ne "a";
  41         print "ok 6 - \$^H{foo} restored to 'a'\n";
  42     }
  43     # The pragma settings disappear after compilation
  44     # (test at CHECK-time and at run-time)
  45     CHECK {
  46         print "not " if exists $^H{foo};
  47         print "ok 9 - \$^H{foo} doesn't exist when compilation complete\n";
  48         if (${^OPEN}) {
  49             print "not " unless $^H & 0x00020000;
  50             print "ok 10 - \$^H contains HINT_LOCALIZE_HH when compilation complete with ${^OPEN}\n";
  51         } else {
  52             print "not " if $^H & 0x00020000;
  53             print "ok 10 - \$^H doesn't contain HINT_LOCALIZE_HH when compilation complete\n";
  54         }
  55     }
  56     print "not " if exists $^H{foo};
  57     print "ok 11 - \$^H{foo} doesn't exist at runtime\n";
  58     if (${^OPEN}) {
  59         print "not " unless $^H & 0x00020000;
  60         print "ok 12 - \$^H contains HINT_LOCALIZE_HH at run-time with ${^OPEN}\n";
  61     } else {
  62         print "not " if $^H & 0x00020000;
  63         print "ok 12 - \$^H doesn't contain HINT_LOCALIZE_HH at run-time\n";
  64     }
  65     # op_entereval should keep the pragmas it was compiled with
  66     eval q*
  67         print "not " if $^H{foo} ne "a";
  68         print "ok 13 - \$^H{foo} is 'a' at eval-\"\" time\n";
  69         print "not " unless $^H & 0x00020000;
  70         print "ok 14 - \$^H contains HINT_LOCALIZE_HH at eval\"\"-time\n";
  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 require 'test.pl';
  86
  87 # bug #27040: hints hash was being double-freed
  88 my $result = runperl(
  89     prog => '$^H |= 0x20000; eval q{BEGIN { $^H |= 0x20000 }}',
  90     stderr => 1
  91 );
  92 print "not " if length $result;
  93 print "ok 15 - double-freeing hints hash\n";
  94 print "# got: $result\n" if length $result;
  95
  96 {
  97     BEGIN{$^H{x}=1};
  98     for my $tno (16..17) {
  99         eval q(
 100             print $^H{x}==1 && !$^H{y} ? "ok $tno\n" : "not ok $tno\n";
 101             $^H{y} = 1;
 102         );
 103         if ($@) {
 104             (my $str = $@)=~s/^/# /gm;
 105             print "not ok $tno\n$str\n";
 106         }
 107     }
 108 }
 109
 110 {
 111     $[ = 11;
 112     print +($[ == 11 ? "" : "not "), "ok 18 - setting \$[ affects \$[\n";
 113     our $t11; BEGIN { $t11 = $^H{'$['} }
 114     print +($t11 == 11 ? "" : "not "), "ok 19 - setting \$[ affects \$^H{'\$['}\n";
 115
 116     BEGIN { $^H{'$['} = 22 }
 117     print +($[ == 22 ? "" : "not "), "ok 20 - setting \$^H{'\$['} affects \$[\n";
 118     our $t22; BEGIN { $t22 = $^H{'$['} }
 119     print +($t22 == 22 ? "" : "not "), "ok 21 - setting \$^H{'\$['} affects \$^H{'\$['}\n";
 120
 121     BEGIN { %^H = () }
 122     print +($[ == 0 ? "" : "not "), "ok 22 - clearing \%^H affects \$[\n";
 123     our $t0; BEGIN { $t0 = $^H{'$['} }
 124     print +($t0 == 0 ? "" : "not "), "ok 23 - clearing \%^H affects \$^H{'\$['}\n";
 125 }
 126
 127 {
 128     $[ = 13;
 129     BEGIN { $^H |= 0x04000000; $^H{foo} = "z"; }
 130
 131     our($ri0, $rf0); BEGIN { $ri0 = $^H; $rf0 = $^H{foo}; }
 132     print +($[ == 13 ? "" : "not "), "ok 24 - \$[ correct before require\n";
 133     print +($ri0 & 0x04000000 ? "" : "not "), "ok 25 - \$^H correct before require\n";
 134     print +($rf0 eq "z" ? "" : "not "), "ok 26 - \$^H{foo} correct before require\n";
 135
 136     our($ra1, $ri1, $rf1, $rfe1);
 137     BEGIN { require "comp/hints.aux"; }
 138     print +($ra1 == 0 ? "" : "not "), "ok 27 - \$[ cleared for require\n";
 139     print +(!($ri1 & 0x04000000) ? "" : "not "), "ok 28 - \$^H cleared for require\n";
 140     print +(!defined($rf1) && !$rfe1 ? "" : "not "), "ok 29 - \$^H{foo} cleared for require\n";
 141
 142     our($ri2, $rf2); BEGIN { $ri2 = $^H; $rf2 = $^H{foo}; }
 143     print +($[ == 13 ? "" : "not "), "ok 30 - \$[ correct after require\n";
 144     print +($ri2 & 0x04000000 ? "" : "not "), "ok 31 - \$^H correct after require\n";
 145     print +($rf2 eq "z" ? "" : "not "), "ok 32 - \$^H{foo} correct after require\n";
 146 }