This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
toke.c: Some simple mending to get readline() working with UTF-8 filehandles
[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..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'