1#!./perl 2 3# Tests the scoping of $^H and %^H 4 5BEGIN { 6 @INC = qw(. ../lib); 7} 8 9BEGIN { print "1..24\n"; } 10BEGIN { 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} 71BEGIN { 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. 130require './test.pl'; 131 132# bug #27040: hints hash was being double-freed 133my $result = runperl( 134 prog => '$^H |= 0x20000; eval q{BEGIN { $^H |= 0x20000 }}', 135 stderr => 1 136); 137print "not " if length $result; 138print "ok 24 - double-freeing hints hash\n"; 139print "# got: $result\n" if length $result; 140 141__END__ 142# Add new tests above require 'test.pl' 143