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 }