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