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