Re: [Another bug] Re: about Storable perl module (again)
[p5sagit/p5-mst-13.2.git] / ext / Storable / t / utf8hash.t
1 #!./perl
2 #
3 # $Id: utf8.t,v 1.0.1.2 2000/09/28 21:44:17 ram Exp $
4 #
5 #
6
7 sub BEGIN {
8     if ($] < 5.007) {
9         print "1..0 # Skip: no utf8 hash key support\n";
10         exit 0;
11     }
12     if ($ENV{PERL_CORE}){
13         chdir('t') if -d 't';
14         @INC = ('.', '../lib');
15     } else {
16         unshift @INC, 't';
17     }
18     require Config; import Config;
19     if ($ENV{PERL_CORE}){
20         if($Config{'extensions'} !~ /\bStorable\b/) {
21             print "1..0 # Skip: Storable was not built\n";
22             exit 0;
23         }
24     }
25 }
26
27 use strict;
28 our $DEBUGME = shift || 0;
29 use Storable qw(store nstore retrieve thaw freeze);
30 {
31     no warnings;
32     $Storable::DEBUGME = ($DEBUGME > 1);
33 }
34 # Better than no plan, because I was getting out of memory errors, at which
35 # point Test::More tidily prints up 1..79 as if I meant to finish there.
36 use Test::More tests=>148;
37 use bytes ();
38 use Encode qw(is_utf8);
39 my %utf8hash;
40
41 $Storable::canonical = $Storable::canonical; # Shut up a used only once warning.
42
43 for $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
48 no 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.
52 my @ords = (
53             ord("Á"), # LATIN CAPITAL LETTER A WITH GRAVE
54             0x3000, #IDEOGRAPHIC SPACE
55            );
56
57 foreach 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
71 sub nkeys($){
72     my $href = shift;
73     return scalar keys %$href; 
74 }
75
76 my $nk;
77 is($nk = nkeys(\%utf8hash), scalar(@ords)*2, 
78    "nasty hash generated (nkeys=$nk)");
79
80 # now let the show begin!
81
82 my $thawed = thaw(freeze(\%utf8hash));
83
84 is($nk = nkeys($thawed),
85    nkeys(\%utf8hash),
86    "scalar keys \%{\$thawed} (nkeys=$nk)");
87 for my $k (sort keys %$thawed){
88     is($utf8hash{$k}, $thawed->{$k}, "frozen item chr($utf8hash{$k})");
89 }
90
91 my $storage = "utfhash.po"; # po = perl object!
92 my $retrieved;
93
94 ok((nstore \%utf8hash, $storage), "nstore to $storage");
95 ok(($retrieved = retrieve($storage)), "retrieve from $storage");
96
97 is($nk = nkeys($retrieved),
98    nkeys(\%utf8hash),
99    "scalar keys \%{\$retrieved} (nkeys=$nk)");
100 for my $k (sort keys %$retrieved){
101     is($utf8hash{$k}, $retrieved->{$k}, "nstored item chr($utf8hash{$k})");
102 }
103 unlink $storage;
104
105
106 ok((store \%utf8hash, $storage), "store to $storage");
107 ok(($retrieved = retrieve($storage)), "retrieve from $storage");
108 is($nk = nkeys($retrieved),
109    nkeys(\%utf8hash),
110    "scalar keys \%{\$retrieved} (nkeys=$nk)");
111 for 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
118 package Hash_Test;
119
120 sub me_second {
121   return (undef, $_[0]);
122 }
123
124 package main;
125
126 my $utf8 = "Schlo\xdf" . chr 256;
127 chop $utf8;
128
129 # Set this to 1 to test the test by bypassing Storable.
130 my $bypass = 0;
131
132 sub 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).
146 my %hash = (map {$_, $_} 'castle', "ch\xe5teau", $utf8, "\x{57CE}");
147
148 for 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 }