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