1N/A#!./perl
1N/A
1N/Asub BEGIN {
1N/A if ($] < 5.007) {
1N/A print "1..0 # Skip: no utf8 hash key support\n";
1N/A exit 0;
1N/A }
1N/A if ($ENV{PERL_CORE}){
1N/A chdir('t') if -d 't';
1N/A @INC = ('.', '../lib');
1N/A if ($^O eq 'MacOS') {
1N/A # Look, I'm using this fully-qualified variable more than once!
1N/A my $arch = $MacPerl::Architecture;
1N/A push @INC, "::lib:${MacPerl::Architecture}:";
1N/A }
1N/A } else {
1N/A unshift @INC, 't';
1N/A }
1N/A require Config; import Config;
1N/A if ($ENV{PERL_CORE}){
1N/A if($Config{'extensions'} !~ /\bStorable\b/) {
1N/A print "1..0 # Skip: Storable was not built\n";
1N/A exit 0;
1N/A }
1N/A }
1N/A}
1N/A
1N/Ause strict;
1N/Aour $DEBUGME = shift || 0;
1N/Ause Storable qw(store nstore retrieve thaw freeze);
1N/A{
1N/A no warnings;
1N/A $Storable::DEBUGME = ($DEBUGME > 1);
1N/A}
1N/A# Better than no plan, because I was getting out of memory errors, at which
1N/A# point Test::More tidily prints up 1..79 as if I meant to finish there.
1N/Ause Test::More tests=>148;
1N/Ause bytes ();
1N/Amy %utf8hash;
1N/A
1N/A$Storable::canonical = $Storable::canonical; # Shut up a used only once warning.
1N/A
1N/Afor $Storable::canonical (0, 1) {
1N/A
1N/A# first we generate a nasty hash which keys include both utf8
1N/A# on and off with identical PVs
1N/A
1N/Ano utf8; # we have a naked 8-bit byte below (in Latin 1, anyway)
1N/A
1N/A# In Latin 1 -ese the below ord() should end up 0xc0 (192),
1N/A# in EBCDIC 0x64 (100). Both should end up being UTF-8/UTF-EBCDIC.
1N/Amy @ords = (
1N/A ord("�"), # LATIN CAPITAL LETTER A WITH GRAVE
1N/A 0x3000, #IDEOGRAPHIC SPACE
1N/A );
1N/A
1N/Aforeach my $i (@ords){
1N/A my $u = chr($i); utf8::upgrade($u);
1N/A # warn sprintf "%d,%d", bytes::length($u), is_utf8($u);
1N/A my $b = pack("C*", unpack("C*", $u));
1N/A # warn sprintf "%d,%d" ,bytes::length($b), is_utf8($b);
1N/A
1N/A isnt($u, $b,
1N/A "equivalence - with utf8flag");
1N/A is (pack("C*", unpack("C*", $u)), pack("C*", unpack("C*", $b)),
1N/A "equivalence - without utf8flag");
1N/A
1N/A $utf8hash{$u} = $utf8hash{$b} = $i;
1N/A}
1N/A
1N/Asub nkeys($){
1N/A my $href = shift;
1N/A return scalar keys %$href;
1N/A}
1N/A
1N/Amy $nk;
1N/Ais($nk = nkeys(\%utf8hash), scalar(@ords)*2,
1N/A "nasty hash generated (nkeys=$nk)");
1N/A
1N/A# now let the show begin!
1N/A
1N/Amy $thawed = thaw(freeze(\%utf8hash));
1N/A
1N/Ais($nk = nkeys($thawed),
1N/A nkeys(\%utf8hash),
1N/A "scalar keys \%{\$thawed} (nkeys=$nk)");
1N/Afor my $k (sort keys %$thawed){
1N/A is($utf8hash{$k}, $thawed->{$k}, "frozen item chr($utf8hash{$k})");
1N/A}
1N/A
1N/Amy $storage = "utfhash.po"; # po = perl object!
1N/Amy $retrieved;
1N/A
1N/Aok((nstore \%utf8hash, $storage), "nstore to $storage");
1N/Aok(($retrieved = retrieve($storage)), "retrieve from $storage");
1N/A
1N/Ais($nk = nkeys($retrieved),
1N/A nkeys(\%utf8hash),
1N/A "scalar keys \%{\$retrieved} (nkeys=$nk)");
1N/Afor my $k (sort keys %$retrieved){
1N/A is($utf8hash{$k}, $retrieved->{$k}, "nstored item chr($utf8hash{$k})");
1N/A}
1N/Aunlink $storage;
1N/A
1N/A
1N/Aok((store \%utf8hash, $storage), "store to $storage");
1N/Aok(($retrieved = retrieve($storage)), "retrieve from $storage");
1N/Ais($nk = nkeys($retrieved),
1N/A nkeys(\%utf8hash),
1N/A "scalar keys \%{\$retrieved} (nkeys=$nk)");
1N/Afor my $k (sort keys %$retrieved){
1N/A is($utf8hash{$k}, $retrieved->{$k}, "stored item chr($utf8hash{$k})");
1N/A}
1N/A$DEBUGME or unlink $storage;
1N/A
1N/A# On the premis that more tests are good, here are NWC's tests:
1N/A
1N/Apackage Hash_Test;
1N/A
1N/Asub me_second {
1N/A return (undef, $_[0]);
1N/A}
1N/A
1N/Apackage main;
1N/A
1N/Amy $utf8 = "Schlo\xdf" . chr 256;
1N/Achop $utf8;
1N/A
1N/A# Set this to 1 to test the test by bypassing Storable.
1N/Amy $bypass = 0;
1N/A
1N/Asub class_test {
1N/A my ($object, $package) = @_;
1N/A unless ($package) {
1N/A is ref $object, 'HASH', "$object is unblessed";
1N/A return;
1N/A }
1N/A isa_ok ($object, $package);
1N/A my ($garbage, $copy) = eval {$object->me_second};
1N/A is $@, "", "check it has correct method";
1N/A cmp_ok $copy, '==', $object, "and that it returns the same object";
1N/A}
1N/A
1N/A# Thanks to Dan Kogai for the Kanji for "castle" (which he informs me also
1N/A# means 'a city' in Mandarin).
1N/Amy %hash = (map {$_, $_} 'castle', "ch\xe5teau", $utf8, "\x{57CE}");
1N/A
1N/Afor my $package ('', 'Hash_Test') {
1N/A # Run through and sanity check these.
1N/A if ($package) {
1N/A bless \%hash, $package;
1N/A }
1N/A for (keys %hash) {
1N/A my $l = 0 + /^\w+$/;
1N/A my $r = 0 + $hash{$_} =~ /^\w+$/;
1N/A cmp_ok ($l, '==', $r);
1N/A }
1N/A
1N/A # Grr. This cperl mode thinks that ${ is a punctuation variable.
1N/A # I presume it's punishment for using xemacs rather than emacs. Or OS/2 :-)
1N/A my $copy = $bypass ? \%hash : ${thaw freeze \\%hash};
1N/A class_test ($copy, $package);
1N/A
1N/A for (keys %$copy) {
1N/A my $l = 0 + /^\w+$/;
1N/A my $r = 0 + $copy->{$_} =~ /^\w+$/;
1N/A cmp_ok ($l, '==', $r, sprintf "key length %d", length $_);
1N/A }
1N/A
1N/A
1N/A my $bytes = my $char = chr 27182;
1N/A utf8::encode ($bytes);
1N/A
1N/A my $orig = {$char => 1};
1N/A if ($package) {
1N/A bless $orig, $package;
1N/A }
1N/A my $just_utf8 = $bypass ? $orig : ${thaw freeze \$orig};
1N/A class_test ($just_utf8, $package);
1N/A cmp_ok (scalar keys %$just_utf8, '==', 1, "1 key in utf8?");
1N/A cmp_ok ($just_utf8->{$char}, '==', 1, "utf8 key present?");
1N/A ok (!exists $just_utf8->{$bytes}, "bytes key absent?");
1N/A
1N/A $orig = {$bytes => 1};
1N/A if ($package) {
1N/A bless $orig, $package;
1N/A }
1N/A my $just_bytes = $bypass ? $orig : ${thaw freeze \$orig};
1N/A class_test ($just_bytes, $package);
1N/A
1N/A cmp_ok (scalar keys %$just_bytes, '==', 1, "1 key in bytes?");
1N/A cmp_ok ($just_bytes->{$bytes}, '==', 1, "bytes key present?");
1N/A ok (!exists $just_bytes->{$char}, "utf8 key absent?");
1N/A
1N/A die sprintf "Both have length %d, which is crazy", length $char
1N/A if length $char == length $bytes;
1N/A
1N/A $orig = {$bytes => length $bytes, $char => length $char};
1N/A if ($package) {
1N/A bless $orig, $package;
1N/A }
1N/A my $both = $bypass ? $orig : ${thaw freeze \$orig};
1N/A class_test ($both, $package);
1N/A
1N/A cmp_ok (scalar keys %$both, '==', 2, "2 keys?");
1N/A cmp_ok ($both->{$bytes}, '==', length $bytes, "bytes key present?");
1N/A cmp_ok ($both->{$char}, '==', length $char, "utf8 key present?");
1N/A}
1N/A
1N/A}