ext/Storable/t/utf8hash.t

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