Commit | Line | Data |
---|---|---|
e16e2ff8 | 1 | #!./perl |
e16e2ff8 NC |
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 NC |
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 NC |
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 NC |
29 | my %utf8hash; |
30 | ||
530b72ba NC |
31 | $Storable::canonical = $Storable::canonical; # Shut up a used only once warning. |
32 | ||
e16e2ff8 NC |
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 JH |
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 NC |
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 NC |
51 | # warn sprintf "%d,%d" ,bytes::length($b), is_utf8($b); |
52 | ||
1651fc44 | 53 | isnt($u, $b, "equivalence - with utf8flag"); |
e16e2ff8 NC |
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 | } |