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