Commit | Line | Data |
e16e2ff8 |
1 | #!./perl |
e16e2ff8 |
2 | |
3 | sub BEGIN { |
4 | if ($] < 5.007) { |
5 | print "1..0 # Skip: no utf8 hash key support\n"; |
6 | exit 0; |
7 | } |
48c887dd |
8 | unshift @INC, 't'; |
e16e2ff8 |
9 | require Config; import Config; |
10 | if ($ENV{PERL_CORE}){ |
11 | if($Config{'extensions'} !~ /\bStorable\b/) { |
12 | print "1..0 # Skip: Storable was not built\n"; |
13 | exit 0; |
14 | } |
15 | } |
e16e2ff8 |
16 | } |
17 | |
18 | use strict; |
19 | our $DEBUGME = shift || 0; |
20 | use Storable qw(store nstore retrieve thaw freeze); |
21 | { |
22 | no warnings; |
23 | $Storable::DEBUGME = ($DEBUGME > 1); |
24 | } |
25 | # Better than no plan, because I was getting out of memory errors, at which |
26 | # point Test::More tidily prints up 1..79 as if I meant to finish there. |
1651fc44 |
27 | use Test::More tests=>144; |
e16e2ff8 |
28 | use bytes (); |
e16e2ff8 |
29 | my %utf8hash; |
30 | |
530b72ba |
31 | $Storable::canonical = $Storable::canonical; # Shut up a used only once warning. |
32 | |
e16e2ff8 |
33 | for $Storable::canonical (0, 1) { |
34 | |
35 | # first we generate a nasty hash which keys include both utf8 |
36 | # on and off with identical PVs |
37 | |
de726223 |
38 | no utf8; # we have a naked 8-bit byte below (in Latin 1, anyway) |
39 | |
40 | # In Latin 1 -ese the below ord() should end up 0xc0 (192), |
41 | # in EBCDIC 0x64 (100). Both should end up being UTF-8/UTF-EBCDIC. |
e16e2ff8 |
42 | my @ords = ( |
de726223 |
43 | ord("Á"), # LATIN CAPITAL LETTER A WITH GRAVE |
e16e2ff8 |
44 | 0x3000, #IDEOGRAPHIC SPACE |
45 | ); |
46 | |
47 | foreach my $i (@ords){ |
48 | my $u = chr($i); utf8::upgrade($u); |
49 | # warn sprintf "%d,%d", bytes::length($u), is_utf8($u); |
1651fc44 |
50 | my $b = chr($i); utf8::encode($b); |
e16e2ff8 |
51 | # warn sprintf "%d,%d" ,bytes::length($b), is_utf8($b); |
52 | |
1651fc44 |
53 | isnt($u, $b, "equivalence - with utf8flag"); |
e16e2ff8 |
54 | |
55 | $utf8hash{$u} = $utf8hash{$b} = $i; |
56 | } |
57 | |
58 | sub nkeys($){ |
59 | my $href = shift; |
60 | return scalar keys %$href; |
61 | } |
62 | |
63 | my $nk; |
64 | is($nk = nkeys(\%utf8hash), scalar(@ords)*2, |
65 | "nasty hash generated (nkeys=$nk)"); |
66 | |
67 | # now let the show begin! |
68 | |
69 | my $thawed = thaw(freeze(\%utf8hash)); |
70 | |
71 | is($nk = nkeys($thawed), |
72 | nkeys(\%utf8hash), |
73 | "scalar keys \%{\$thawed} (nkeys=$nk)"); |
74 | for my $k (sort keys %$thawed){ |
75 | is($utf8hash{$k}, $thawed->{$k}, "frozen item chr($utf8hash{$k})"); |
76 | } |
77 | |
78 | my $storage = "utfhash.po"; # po = perl object! |
79 | my $retrieved; |
80 | |
81 | ok((nstore \%utf8hash, $storage), "nstore to $storage"); |
82 | ok(($retrieved = retrieve($storage)), "retrieve from $storage"); |
83 | |
84 | is($nk = nkeys($retrieved), |
85 | nkeys(\%utf8hash), |
86 | "scalar keys \%{\$retrieved} (nkeys=$nk)"); |
87 | for my $k (sort keys %$retrieved){ |
88 | is($utf8hash{$k}, $retrieved->{$k}, "nstored item chr($utf8hash{$k})"); |
89 | } |
90 | unlink $storage; |
91 | |
92 | |
93 | ok((store \%utf8hash, $storage), "store to $storage"); |
94 | ok(($retrieved = retrieve($storage)), "retrieve from $storage"); |
95 | is($nk = nkeys($retrieved), |
96 | nkeys(\%utf8hash), |
97 | "scalar keys \%{\$retrieved} (nkeys=$nk)"); |
98 | for my $k (sort keys %$retrieved){ |
99 | is($utf8hash{$k}, $retrieved->{$k}, "stored item chr($utf8hash{$k})"); |
100 | } |
101 | $DEBUGME or unlink $storage; |
102 | |
103 | # On the premis that more tests are good, here are NWC's tests: |
104 | |
105 | package Hash_Test; |
106 | |
107 | sub me_second { |
108 | return (undef, $_[0]); |
109 | } |
110 | |
111 | package main; |
112 | |
113 | my $utf8 = "Schlo\xdf" . chr 256; |
114 | chop $utf8; |
115 | |
116 | # Set this to 1 to test the test by bypassing Storable. |
117 | my $bypass = 0; |
118 | |
119 | sub class_test { |
120 | my ($object, $package) = @_; |
121 | unless ($package) { |
122 | is ref $object, 'HASH', "$object is unblessed"; |
123 | return; |
124 | } |
125 | isa_ok ($object, $package); |
126 | my ($garbage, $copy) = eval {$object->me_second}; |
127 | is $@, "", "check it has correct method"; |
128 | cmp_ok $copy, '==', $object, "and that it returns the same object"; |
129 | } |
130 | |
131 | # Thanks to Dan Kogai for the Kanji for "castle" (which he informs me also |
132 | # means 'a city' in Mandarin). |
133 | my %hash = (map {$_, $_} 'castle', "ch\xe5teau", $utf8, "\x{57CE}"); |
134 | |
135 | for my $package ('', 'Hash_Test') { |
136 | # Run through and sanity check these. |
137 | if ($package) { |
138 | bless \%hash, $package; |
139 | } |
140 | for (keys %hash) { |
141 | my $l = 0 + /^\w+$/; |
142 | my $r = 0 + $hash{$_} =~ /^\w+$/; |
143 | cmp_ok ($l, '==', $r); |
144 | } |
145 | |
146 | # Grr. This cperl mode thinks that ${ is a punctuation variable. |
147 | # I presume it's punishment for using xemacs rather than emacs. Or OS/2 :-) |
148 | my $copy = $bypass ? \%hash : ${thaw freeze \\%hash}; |
149 | class_test ($copy, $package); |
150 | |
151 | for (keys %$copy) { |
152 | my $l = 0 + /^\w+$/; |
153 | my $r = 0 + $copy->{$_} =~ /^\w+$/; |
154 | cmp_ok ($l, '==', $r, sprintf "key length %d", length $_); |
155 | } |
156 | |
157 | |
158 | my $bytes = my $char = chr 27182; |
159 | utf8::encode ($bytes); |
160 | |
161 | my $orig = {$char => 1}; |
162 | if ($package) { |
163 | bless $orig, $package; |
164 | } |
165 | my $just_utf8 = $bypass ? $orig : ${thaw freeze \$orig}; |
166 | class_test ($just_utf8, $package); |
167 | cmp_ok (scalar keys %$just_utf8, '==', 1, "1 key in utf8?"); |
168 | cmp_ok ($just_utf8->{$char}, '==', 1, "utf8 key present?"); |
169 | ok (!exists $just_utf8->{$bytes}, "bytes key absent?"); |
170 | |
171 | $orig = {$bytes => 1}; |
172 | if ($package) { |
173 | bless $orig, $package; |
174 | } |
175 | my $just_bytes = $bypass ? $orig : ${thaw freeze \$orig}; |
176 | class_test ($just_bytes, $package); |
177 | |
178 | cmp_ok (scalar keys %$just_bytes, '==', 1, "1 key in bytes?"); |
179 | cmp_ok ($just_bytes->{$bytes}, '==', 1, "bytes key present?"); |
180 | ok (!exists $just_bytes->{$char}, "utf8 key absent?"); |
181 | |
182 | die sprintf "Both have length %d, which is crazy", length $char |
183 | if length $char == length $bytes; |
184 | |
185 | $orig = {$bytes => length $bytes, $char => length $char}; |
186 | if ($package) { |
187 | bless $orig, $package; |
188 | } |
189 | my $both = $bypass ? $orig : ${thaw freeze \$orig}; |
190 | class_test ($both, $package); |
191 | |
192 | cmp_ok (scalar keys %$both, '==', 2, "2 keys?"); |
193 | cmp_ok ($both->{$bytes}, '==', length $bytes, "bytes key present?"); |
194 | cmp_ok ($both->{$char}, '==', length $char, "utf8 key present?"); |
195 | } |
196 | |
197 | } |