Perl_op_sibling_splice(0 remove dead code
[perl.git] / t / op / utfhash.t
1 #!./perl -w
2
3 BEGIN {
4     chdir 't' if -d 't';
5     require './test.pl';
6     set_up_inc('../lib');
7 }
8
9 plan(tests => 99);
10
11 use strict;
12
13 # Two hashes one with all 8-bit possible keys (initially), other
14 # with a utf8 requiring key from the outset.
15
16 my %hash8 = ( "\xff" => 0xff,
17               "\x7f" => 0x7f,
18             );
19 my %hashu = ( "\xff" => 0xff,
20               "\x7f" => 0x7f,
21               "\x{1ff}" => 0x1ff,
22             );
23
24 # Check that we can find the 8-bit things by various literals
25 is($hash8{"\x{00ff}"},0xFF);
26 is($hash8{"\x{007f}"},0x7F);
27 is($hash8{"\xff"},0xFF);
28 is($hash8{"\x7f"},0x7F);
29 is($hashu{"\x{00ff}"},0xFF);
30 is($hashu{"\x{007f}"},0x7F);
31 is($hashu{"\xff"},0xFF);
32 is($hashu{"\x7f"},0x7F);
33
34 # Now try same thing with variables forced into various forms.
35 foreach ("\x7f","\xff")
36  {
37   my $a = $_; # Force a copy
38   utf8::upgrade($a);
39   is($hash8{$a},ord($a));
40   is($hashu{$a},ord($a));
41   utf8::downgrade($a);
42   is($hash8{$a},ord($a));
43   is($hashu{$a},ord($a));
44   my $b = $a.chr(100);
45   chop($b);
46   is($hash8{$b},ord($b));
47   is($hashu{$b},ord($b));
48  }
49
50 # Check we have not got an spurious extra keys
51 is(join('',sort { ord $a <=> ord $b } keys %hash8),"\x7f\xff");
52 is(join('',sort { ord $a <=> ord $b } keys %hashu),"\x7f\xff\x{1ff}");
53
54 # Now add a utf8 key to the 8-bit hash
55 $hash8{chr(0x1ff)} = 0x1ff;
56
57 # Check we have not got an spurious extra keys
58 is(join('',sort { ord $a <=> ord $b } keys %hash8),"\x7f\xff\x{1ff}");
59
60 foreach ("\x7f","\xff","\x{1ff}")
61  {
62   my $a = $_;
63   utf8::upgrade($a);
64   is($hash8{$a},ord($a));
65   my $b = $a.chr(100);
66   chop($b);
67   is($hash8{$b},ord($b));
68  }
69
70 # and remove utf8 from the other hash
71 is(delete $hashu{chr(0x1ff)},0x1ff);
72 is(join('',sort keys %hashu),"\x7f\xff");
73
74 foreach ("\x7f","\xff")
75  {
76   my $a = $_;
77   utf8::upgrade($a);
78   is($hashu{$a},ord($a));
79   utf8::downgrade($a);
80   is($hashu{$a},ord($a));
81   my $b = $a.chr(100);
82   chop($b);
83   is($hashu{$b},ord($b));
84  }
85
86
87
88 {
89   print "# Unicode hash keys and \\w\n";
90   # This is not really a regex test but regexes bring
91   # out the issue nicely.
92   use strict;
93   my $u3 = "f\x{df}\x{100}";
94   my $u2 = substr($u3,0,2);
95   my $u1 = substr($u2,0,1);
96   my $u0 = chr (0xdf)x4; # Make this 4 chars so that all lengths are distinct.
97
98   my @u = ($u0, $u1, $u2, $u3);
99
100   while (@u) {
101     my %u = (map {( $_, $_)} @u);
102     my $keys = scalar @u;
103     $keys .= ($keys == 1) ? " key" : " keys";
104
105     for (keys %u) {
106         my $l = 0 + /^\w+$/;
107         my $r = 0 + $u{$_} =~ /^\w+$/;
108         is ($l, $r, "\\w on keys with $keys, key of length " . length $_);
109     }
110
111     my $more;
112     do {
113       $more = 0;
114       # Want to do this direct, rather than copying to a temporary variable
115       # The first time each will return key and value at the start of the hash.
116       # each will return () after we've done the last pair. $more won't get
117       # set then, and the do will exit.
118       for (each %u) {
119         $more = 1;
120         my $l = 0 + /^\w+$/;
121         my $r = 0 + $u{$_} =~ /^\w+$/;
122         is ($l, $r, "\\w on each, with $keys, key of length " . length $_);
123       }
124     } while ($more);
125
126     for (%u) {
127       my $l = 0 + /^\w+$/;
128       my $r = 0 + $u{$_} =~ /^\w+$/;
129       is ($l, $r, "\\w on hash with $keys, key of length " . length $_);
130     }
131     pop @u;
132     undef %u;
133   }
134 }
135
136 {
137   my $utf8_sz = my $bytes_sz = "\x{df}";
138   $utf8_sz .= chr 256;
139   chop ($utf8_sz);
140
141   my (%bytes_first, %utf8_first);
142
143   $bytes_first{$bytes_sz} = $bytes_sz;
144
145   for (keys %bytes_first) {
146     my $l = 0 + /^\w+$/;
147     my $r = 0 + $bytes_first{$_} =~ /^\w+$/;
148     is ($l, $r, "\\w on each, bytes");
149   }
150
151   $bytes_first{$utf8_sz} = $utf8_sz;
152
153   for (keys %bytes_first) {
154     my $l = 0 + /^\w+$/;
155     my $r = 0 + $bytes_first{$_} =~ /^\w+$/;
156     is ($l, $r, "\\w on each, bytes now utf8");
157   }
158
159   $utf8_first{$utf8_sz} = $utf8_sz;
160
161   for (keys %utf8_first) {
162     my $l = 0 + /^\w+$/;
163     my $r = 0 + $utf8_first{$_} =~ /^\w+$/;
164     is ($l, $r, "\\w on each, utf8");
165   }
166
167   $utf8_first{$bytes_sz} = $bytes_sz;
168
169   for (keys %utf8_first) {
170     my $l = 0 + /^\w+$/;
171     my $r = 0 + $utf8_first{$_} =~ /^\w+$/;
172     is ($l, $r, "\\w on each, utf8 now bytes");
173   }
174
175 }
176
177 {
178     local $/; # Slurp.
179     my $data = <DATA>;
180     my ($utf8, $utf1047ebcdic) = split /__SPLIT__/, $data;
181     $utf8 = $utf1047ebcdic if $::IS_EBCDIC;
182     eval $utf8;
183 }
184 __END__
185 {
186   # See if utf8 barewords work [perl #22969]
187   use utf8;
188   my %hash = (тест => 123);
189   is($hash{тест}, $hash{'тест'});
190   is($hash{тест}, 123);
191   is($hash{'тест'}, 123);
192   %hash = (тест => 123);
193   is($hash{тест}, $hash{'тест'});
194   is($hash{тест}, 123);
195   is($hash{'тест'}, 123);
196
197   # See if plain ASCII strings quoted with '=>' erroneously get utf8 flag [perl #68812]
198   my %foo = (a => 'b', 'c' => 'd');
199   for my $key (keys %foo) {
200     ok !utf8::is_utf8($key), "'$key' shouldn't have utf8 flag";
201   }
202 }
203 __SPLIT__
204 {   # This is 1047 UTF-EBCDIC; won't work on other code pages.
205   # See if utf8 barewords work [perl #22969]
206   use utf8; # UTF-EBCDIC, really.
207   my %hash = (������������ => 123);
208   is($hash{������������}, $hash{'������������'});
209   is($hash{������������}, 123);
210   is($hash{'������������'}, 123);
211   %hash = (������������ => 123);
212   is($hash{������������}, $hash{'������������'});
213   is($hash{������������}, 123);
214   is($hash{'������������'}, 123);
215
216   # See if plain ASCII strings quoted with '=>' erroneously get utf8 flag [perl #68812]
217   my %foo = (a => 'b', 'c' => 'd');
218   for my $key (keys %foo) {
219     ok !utf8::is_utf8($key), "'$key' shouldn't have utf8 flag";
220   }
221 }