This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Update the warning message.
[perl5.git] / t / op / utfhash.t
CommitLineData
cb0a5b5c
NIS
1BEGIN {
2 chdir 't' if -d 't';
3 @INC = '../lib';
4 require './test.pl';
5
4c79aee6 6 plan(tests => 48);
cb0a5b5c
NIS
7}
8
9# Two hashes one will all keys 8-bit possible (initially), other
10# with a utf8 requiring key from the outset.
11
12my %hash8 = ( "\xff" => 0xff,
13 "\x7f" => 0x7f,
14 );
15my %hashu = ( "\xff" => 0xff,
16 "\x7f" => 0x7f,
17 "\x{1ff}" => 0x1ff,
18 );
19
20# Check that we can find the 8-bit things by various litterals
21is($hash8{"\x{00ff}"},0xFF);
22is($hash8{"\x{007f}"},0x7F);
23is($hash8{"\xff"},0xFF);
24is($hash8{"\x7f"},0x7F);
25is($hashu{"\x{00ff}"},0xFF);
26is($hashu{"\x{007f}"},0x7F);
27is($hashu{"\xff"},0xFF);
28is($hashu{"\x7f"},0x7F);
29
30# Now try same thing with variables forced into various forms.
31foreach my $a ("\x7f","\xff")
32 {
33 utf8::upgrade($a);
34 is($hash8{$a},ord($a));
35 is($hashu{$a},ord($a));
36 utf8::downgrade($a);
37 is($hash8{$a},ord($a));
38 is($hashu{$a},ord($a));
39 my $b = $a.chr(100);
40 chop($b);
41 is($hash8{$b},ord($b));
42 is($hashu{$b},ord($b));
43 }
44
45# Check we have not got an spurious extra keys
20b5b8d0
JH
46is(join('',sort { ord $a <=> ord $b } keys %hash8),"\x7f\xff");
47is(join('',sort { ord $a <=> ord $b } keys %hashu),"\x7f\xff\x{1ff}");
cb0a5b5c
NIS
48
49# Now add a utf8 key to the 8-bit hash
50$hash8{chr(0x1ff)} = 0x1ff;
51
52# Check we have not got an spurious extra keys
20b5b8d0 53is(join('',sort { ord $a <=> ord $b } keys %hash8),"\x7f\xff\x{1ff}");
cb0a5b5c
NIS
54
55foreach my $a ("\x7f","\xff","\x{1ff}")
56 {
57 utf8::upgrade($a);
58 is($hash8{$a},ord($a));
59 my $b = $a.chr(100);
60 chop($b);
61 is($hash8{$b},ord($b));
62 }
63
64# and remove utf8 from the other hash
65is(delete $hashu{chr(0x1ff)},0x1ff);
66is(join('',sort keys %hashu),"\x7f\xff");
67
68foreach my $a ("\x7f","\xff")
69 {
70 utf8::upgrade($a);
71 is($hashu{$a},ord($a));
72 utf8::downgrade($a);
73 is($hashu{$a},ord($a));
74 my $b = $a.chr(100);
75 chop($b);
76 is($hashu{$b},ord($b));
77 }
78
79
4c79aee6
NC
80
81{
82 print "# Unicode hash keys and \\w\n";
83 # This is not really a regex test but regexes bring
84 # out the issue nicely.
85 use strict;
86 my $u3 = "f\x{df}\x{100}";
87 my $u2 = substr($u3,0,2);
88 my $u1 = substr($u2,0,1);
89 my %u = ( $u1 => $u1, $u2 => $u2, $u3 => $u3 );
90
91 for (keys %u) {
92 ok (/^\w+$/ && $u{$_} =~ /^\w+$/, "\\w on keys");
93 }
94
95 for (each %u) {
96 ok (/^\w+$/ && $u{$_} =~ /^\w+$/, "\\w on each");
97 }
98
99 for (%u) {
100 ok (/^\w+$/ && $u{$_} =~ /^\w+$/, "\\w on hash");
101 }
102}