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