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