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