t/op/utfhash.t

   1 #!./perl -w
   2
   3 BEGIN {
   4     chdir 't' if -d 't';
   5     @INC = '../lib';
   6     require './test.pl';
   7
   8     plan(tests => 97);
   9 }
  10
  11 use strict;
  12
  13 # Two hashes one will all keys 8-bit possible (initially), other
  14 # with a utf8 requiring key from the outset.
  15
  16 my %hash8 = ( "\xff" => 0xff,
  17               "\x7f" => 0x7f,
  18             );
  19 my %hashu = ( "\xff" => 0xff,
  20               "\x7f" => 0x7f,
  21               "\x{1ff}" => 0x1ff,
  22             );
  23
  24 # Check that we can find the 8-bit things by various litterals
  25 is($hash8{"\x{00ff}"},0xFF);
  26 is($hash8{"\x{007f}"},0x7F);
  27 is($hash8{"\xff"},0xFF);
  28 is($hash8{"\x7f"},0x7F);
  29 is($hashu{"\x{00ff}"},0xFF);
  30 is($hashu{"\x{007f}"},0x7F);
  31 is($hashu{"\xff"},0xFF);
  32 is($hashu{"\x7f"},0x7F);
  33
  34 # Now try same thing with variables forced into various forms.
  35 foreach ("\x7f","\xff")
  36  {
  37   my $a = $_; # Force a copy
  38   utf8::upgrade($a);
  39   is($hash8{$a},ord($a));
  40   is($hashu{$a},ord($a));
  41   utf8::downgrade($a);
  42   is($hash8{$a},ord($a));
  43   is($hashu{$a},ord($a));
  44   my $b = $a.chr(100);
  45   chop($b);
  46   is($hash8{$b},ord($b));
  47   is($hashu{$b},ord($b));
  48  }
  49
  50 # Check we have not got an spurious extra keys
  51 is(join('',sort { ord $a <=> ord $b } keys %hash8),"\x7f\xff");
  52 is(join('',sort { ord $a <=> ord $b } keys %hashu),"\x7f\xff\x{1ff}");
  53
  54 # Now add a utf8 key to the 8-bit hash
  55 $hash8{chr(0x1ff)} = 0x1ff;
  56
  57 # Check we have not got an spurious extra keys
  58 is(join('',sort { ord $a <=> ord $b } keys %hash8),"\x7f\xff\x{1ff}");
  59
  60 foreach ("\x7f","\xff","\x{1ff}")
  61  {
  62   my $a = $_;
  63   utf8::upgrade($a);
  64   is($hash8{$a},ord($a));
  65   my $b = $a.chr(100);
  66   chop($b);
  67   is($hash8{$b},ord($b));
  68  }
  69
  70 # and remove utf8 from the other hash
  71 is(delete $hashu{chr(0x1ff)},0x1ff);
  72 is(join('',sort keys %hashu),"\x7f\xff");
  73
  74 foreach ("\x7f","\xff")
  75  {
  76   my $a = $_;
  77   utf8::upgrade($a);
  78   is($hashu{$a},ord($a));
  79   utf8::downgrade($a);
  80   is($hashu{$a},ord($a));
  81   my $b = $a.chr(100);
  82   chop($b);
  83   is($hashu{$b},ord($b));
  84  }
  85
  86
  87
  88 {
  89   print "# Unicode hash keys and \\w\n";
  90   # This is not really a regex test but regexes bring
  91   # out the issue nicely.
  92   use strict;
  93   my $u3 = "f\x{df}\x{100}";
  94   my $u2 = substr($u3,0,2);
  95   my $u1 = substr($u2,0,1);
  96   my $u0 = chr (0xdf)x4; # Make this 4 chars so that all lengths are distinct.
  97
  98   my @u = ($u0, $u1, $u2, $u3);
  99
 100   while (@u) {
 101     my %u = (map {( $_, $_)} @u);
 102     my $keys = scalar @u;
 103     $keys .= ($keys == 1) ? " key" : " keys";
 104
 105     for (keys %u) {
 106         my $l = 0 + /^\w+$/;
 107         my $r = 0 + $u{$_} =~ /^\w+$/;
 108         is ($l, $r, "\\w on keys with $keys, key of length " . length $_);
 109     }
 110
 111     my $more;
 112     do {
 113       $more = 0;
 114       # Want to do this direct, rather than copying to a temporary variable
 115       # The first time each will return key and value at the start of the hash.
 116       # each will return () after we've done the last pair. $more won't get
 117       # set then, and the do will exit.
 118       for (each %u) {
 119         $more = 1;
 120         my $l = 0 + /^\w+$/;
 121         my $r = 0 + $u{$_} =~ /^\w+$/;
 122         is ($l, $r, "\\w on each, with $keys, key of length " . length $_);
 123       }
 124     } while ($more);
 125
 126     for (%u) {
 127       my $l = 0 + /^\w+$/;
 128       my $r = 0 + $u{$_} =~ /^\w+$/;
 129       is ($l, $r, "\\w on hash with $keys, key of length " . length $_);
 130     }
 131     pop @u;
 132     undef %u;
 133   }
 134 }
 135
 136 {
 137   my $utf8_sz = my $bytes_sz = "\x{df}";
 138   $utf8_sz .= chr 256;
 139   chop ($utf8_sz);
 140
 141   my (%bytes_first, %utf8_first);
 142
 143   $bytes_first{$bytes_sz} = $bytes_sz;
 144
 145   for (keys %bytes_first) {
 146     my $l = 0 + /^\w+$/;
 147     my $r = 0 + $bytes_first{$_} =~ /^\w+$/;
 148     is ($l, $r, "\\w on each, bytes");
 149   }
 150
 151   $bytes_first{$utf8_sz} = $utf8_sz;
 152
 153   for (keys %bytes_first) {
 154     my $l = 0 + /^\w+$/;
 155     my $r = 0 + $bytes_first{$_} =~ /^\w+$/;
 156     is ($l, $r, "\\w on each, bytes now utf8");
 157   }
 158
 159   $utf8_first{$utf8_sz} = $utf8_sz;
 160
 161   for (keys %utf8_first) {
 162     my $l = 0 + /^\w+$/;
 163     my $r = 0 + $utf8_first{$_} =~ /^\w+$/;
 164     is ($l, $r, "\\w on each, utf8");
 165   }
 166
 167   $utf8_first{$bytes_sz} = $bytes_sz;
 168
 169   for (keys %utf8_first) {
 170     my $l = 0 + /^\w+$/;
 171     my $r = 0 + $utf8_first{$_} =~ /^\w+$/;
 172     is ($l, $r, "\\w on each, utf8 now bytes");
 173   }
 174
 175 }
 176
 177 {
 178     local $/; # Slurp.
 179     my $utf8      = <DATA>;
 180     my $utfebcdic = <DATA>;
 181     if (ord('A') == 65) {
 182         eval $utf8;
 183     } elsif (ord('A') == 193) {
 184         eval $utfebcdic;
 185     }
 186 }
 187 __END__
 188 {
 189   # See if utf8 barewords work [perl #22969]
 190   use utf8;
 191   my %hash = (тест => 123);
 192   is($hash{тест}, $hash{'тест'});
 193   is($hash{тест}, 123);
 194   is($hash{'тест'}, 123);
 195   %hash = (тест => 123);
 196   is($hash{тест}, $hash{'тест'});
 197   is($hash{тест}, 123);
 198   is($hash{'тест'}, 123);
 199 }
 200 __END__
 201 {
 202   # See if utf8 barewords work [perl #22969]
 203   use utf8; # UTF-EBCDIC, really.
 204   my %hash = (½ää½âÀ½äâ½ää => 123);
 205   is($hash{½ää½âÀ½äâ½ää}, $hash{'½ää½âÀ½äâ½ää'});
 206   is($hash{½ää½âÀ½äâ½ää}, 123);
 207   is($hash{'½ää½âÀ½äâ½ää'}, 123);
 208   %hash = (½ää½âÀ½äâ½ää => 123);
 209   is($hash{½ää½âÀ½äâ½ää}, $hash{'½ää½âÀ½äâ½ää'});
 210   is($hash{½ää½âÀ½äâ½ää}, 123);
 211   is($hash{'½ää½âÀ½äâ½ää'}, 123);
 212 }