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