Small optimisations, by Brandon Black
[p5sagit/p5-mst-13.2.git] / t / op / utfhash.t
1 #!./perl -w
2
3 BEGIN {
4     chdir 't' if -d 't';
5     @INC = '../lib';
6     require './test.pl';
7
8     plan(tests => 97);
9 }
10
11 use strict;
12
13 # Two hashes one will all keys 8-bit possible (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 litterals
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 $utf8      = <DATA>;
180     my $utfebcdic = <DATA>;
181     if (ord('A') == 65) {
182         eval $utf8;
183     } elsif (ord('A') == 193) {
184         eval $utfebcdic;
185     }
186 }
187 __END__
188 {
189   # See if utf8 barewords work [perl #22969]
190   use utf8;
191   my %hash = (тест => 123);
192   is($hash{тест}, $hash{'тест'});
193   is($hash{тест}, 123);
194   is($hash{'тест'}, 123);
195   %hash = (тест => 123);
196   is($hash{тест}, $hash{'тест'});
197   is($hash{тест}, 123);
198   is($hash{'тест'}, 123);
199 }
200 __END__
201 {
202   # See if utf8 barewords work [perl #22969]
203   use utf8; # UTF-EBCDIC, really.
204   my %hash = (½ää½âÀ½äâ½ää => 123);
205   is($hash{½ää½âÀ½äâ½ää}, $hash{'½ää½âÀ½äâ½ää'});
206   is($hash{½ää½âÀ½äâ½ää}, 123);
207   is($hash{'½ää½âÀ½äâ½ää'}, 123);
208   %hash = (½ää½âÀ½äâ½ää => 123);
209   is($hash{½ää½âÀ½äâ½ää}, $hash{'½ää½âÀ½äâ½ää'});
210   is($hash{½ää½âÀ½äâ½ää}, 123);
211   is($hash{'½ää½âÀ½äâ½ää'}, 123);
212 }