ext/XS-APItest/t/hash.t

   1 #!perl -w
   2
   3 BEGIN {
   4   chdir 't' if -d 't';
   5   @INC = '../lib';
   6   push @INC, "::lib:$MacPerl::Architecture:" if $^O eq 'MacOS';
   7   require Config; import Config;
   8   if ($Config{'extensions'} !~ /\bXS\/APItest\b/) {
   9     # Look, I'm using this fully-qualified variable more than once!
  10     my $arch = $MacPerl::Architecture;
  11     print "1..0 # Skip: XS::APItest was not built\n";
  12     exit 0;
  13   }
  14 }
  15
  16 use strict;
  17 use utf8;
  18 use Tie::Hash;
  19 use Test::More 'no_plan';
  20
  21 BEGIN {use_ok('XS::APItest')};
  22
  23 sub preform_test;
  24 sub test_present;
  25 sub test_absent;
  26 sub test_delete_present;
  27 sub test_delete_absent;
  28 sub brute_force_exists;
  29 sub test_store;
  30 sub test_fetch_present;
  31 sub test_fetch_absent;
  32
  33 my $utf8_for_258 = chr 258;
  34 utf8::encode $utf8_for_258;
  35
  36 my @testkeys = ('N', chr 198, chr 256);
  37 my @keys = (@testkeys, $utf8_for_258);
  38
  39 foreach (@keys) {
  40   utf8::downgrade $_, 1;
  41 }
  42 main_tests (\@keys, \@testkeys, '');
  43
  44 foreach (@keys) {
  45   utf8::upgrade $_;
  46 }
  47 main_tests (\@keys, \@testkeys, ' [utf8 hash]');
  48
  49 {
  50   my %h = (a=>'cheat');
  51   tie %h, 'Tie::StdHash';
  52   # is bug 36327 fixed?
  53   my $result = ($] > 5.009) ? undef : 1;
  54
  55   is (XS::APItest::Hash::store(\%h, chr 258,  1), $result);
  56
  57   ok (!exists $h{$utf8_for_258},
  58       "hv_store doesn't insert a key with the raw utf8 on a tied hash");
  59 }
  60
  61 if ($] > 5.009) {
  62     my $strtab = strtab();
  63     is (ref $strtab, 'HASH', "The shared string table quacks like a hash");
  64     my $wibble = "\0";
  65     eval {
  66         $strtab->{$wibble}++;
  67     };
  68     my $prefix = "Cannot modify shared string table in hv_";
  69     my $what = $prefix . 'fetch';
  70     like ($@, qr/^$what/,$what);
  71     eval {
  72         XS::APItest::Hash::store($strtab, 'Boom!',  1)
  73     };
  74     $what = $prefix . 'store';
  75     like ($@, qr/^$what/, $what);
  76     if (0) {
  77         A::B->method();
  78     }
  79     # DESTROY should be in there.
  80     eval {
  81         delete $strtab->{DESTROY};
  82     };
  83     $what = $prefix . 'delete';
  84     like ($@, qr/^$what/, $what);
  85     # I can't work out how to get to the code that flips the wasutf8 flag on
  86     # the hash key without some ikcy XS
  87 }
  88
  89 {
  90     is_deeply([&XS::APItest::Hash::test_hv_free_ent], [2,2,1,1],
  91               "hv_free_ent frees the value immediately");
  92     is_deeply([&XS::APItest::Hash::test_hv_delayfree_ent], [2,2,2,1],
  93               "hv_delayfree_ent keeps the value around until FREETMPS");
  94 }
  95
  96 foreach my $in ("", "N", "a\0b") {
  97     my $got = XS::APItest::Hash::test_share_unshare_pvn($in);
  98     is ($got, $in, "test_share_unshare_pvn");
  99 }
 100
 101 if ($] > 5.009) {
 102     foreach ([\&XS::APItest::Hash::rot13_hash, \&rot13, "rot 13"],
 103              [\&XS::APItest::Hash::bitflip_hash, \&bitflip, "bitflip"],
 104             ) {
 105         my ($setup, $mapping, $name) = @$_;
 106         my %hash;
 107         my %placebo = (a => 1, p => 2, i => 4, e => 8);
 108         $setup->(\%hash);
 109         $hash{a}++; @hash{qw(p i e)} = (2, 4, 8);
 110
 111         test_U_hash(\%hash, \%placebo, [f => 9, g => 10, h => 11], $mapping,
 112                     $name);
 113     }
 114     foreach my $upgrade_o (0, 1) {
 115         foreach my $upgrade_n (0, 1) {
 116             my (%hash, %placebo);
 117             XS::APItest::Hash::bitflip_hash(\%hash);
 118             foreach my $new (["7", 65, 67, 80],
 119                              ["8", 163, 171, 215],
 120                              ["U", 2603, 2604, 2604],
 121                             ) {
 122                 foreach my $code (78, 240, 256, 1336) {
 123                     my $key = chr $code;
 124                     # This is the UTF-8 byte sequence for the key.
 125                     my $key_utf8 = $key;
 126                     utf8::encode($key_utf8);
 127                     if ($upgrade_o) {
 128                         $key .= chr 256;
 129                         chop $key;
 130                     }
 131                     $hash{$key} = $placebo{$key} = $code;
 132                     $hash{$key_utf8} = $placebo{$key_utf8} = "$code as UTF-8";
 133                 }
 134                 my $name = 'bitflip ' . shift @$new;
 135                 my @new_kv;
 136                 foreach my $code (@$new) {
 137                     my $key = chr $code;
 138                     if ($upgrade_n) {
 139                         $key .= chr 256;
 140                         chop $key;
 141                     }
 142                     push @new_kv, $key, $_;
 143                 }
 144
 145                 $name .= ' upgraded(orig) ' if $upgrade_o;
 146                 $name .= ' upgraded(new) ' if $upgrade_n;
 147                 test_U_hash(\%hash, \%placebo, \@new_kv, \&bitflip, $name);
 148             }
 149         }
 150     }
 151 }
 152
 153 sub test_precomputed_hashes {
 154     my $what = shift;
 155     my $hash_it = shift;
 156     my $ord = shift;
 157     my $key_copy = $_[0];
 158     $key_copy .= '';
 159
 160     my %hash;
 161     is (XS::APItest::Hash::common({hv => \%hash,
 162                                    "key$what" => $_[0],
 163                                    val => $ord,
 164                                    "hash_$what" => $hash_it,
 165                                    action => XS::APItest::HV_FETCH_ISSTORE}),
 166         $ord, "store $ord with $what \$hash_it = $hash_it");
 167     is_deeply ([each %hash], [$_[0], $ord], "First key read is good");
 168     is_deeply ([each %hash], [], "No second key good");
 169
 170     is ($hash{$_[0]}, $ord, "Direct hash read finds $ord");
 171
 172     is_deeply ([each %hash], [$key_copy, $ord],
 173                "First key read is good with a copy");
 174     is_deeply ([each %hash], [], "No second key good");
 175
 176     is ($hash{$key_copy}, $ord, "Direct hash read finds $ord");
 177 }
 178
 179 {
 180     my $as_utf8 = "\241" . chr 256;
 181     chop $as_utf8;
 182     my $as_bytes = "\243";
 183     foreach my $key ('N', $as_bytes, $as_utf8, "\x{2623}") {
 184         my $ord = ord $key;
 185         foreach my $hash_it (0, 1) {
 186             foreach my $what (qw(pv sv)) {
 187                 test_precomputed_hashes($what, $hash_it, $ord, $key);
 188             }
 189             # Generate a shared hash key scalar
 190             my %h = ($key => 1);
 191             test_precomputed_hashes('sv', $hash_it, $ord, (keys %h)[0]);
 192         }
 193     }
 194 }
 195
 196 exit;
 197
 198 ################################   The End   ################################
 199
 200 sub test_U_hash {
 201     my ($hash, $placebo, $new, $mapping, $message) = @_;
 202     my @hitlist = keys %$placebo;
 203     print "# $message\n";
 204
 205     my @keys = sort keys %$hash;
 206     is ("@keys", join(' ', sort($mapping->(keys %$placebo))),
 207         "uvar magic called exactly once on store");
 208
 209     is (keys %$hash, keys %$placebo);
 210
 211     my $victim = shift @hitlist;
 212     is (delete $hash->{$victim}, delete $placebo->{$victim});
 213
 214     is (keys %$hash, keys %$placebo);
 215     @keys = sort keys %$hash;
 216     is ("@keys", join(' ', sort($mapping->(keys %$placebo))));
 217
 218     $victim = shift @hitlist;
 219     is (XS::APItest::Hash::delete_ent ($hash, $victim,
 220                                        XS::APItest::HV_DISABLE_UVAR_XKEY),
 221         undef, "Deleting a known key with conversion disabled fails (ent)");
 222     is (keys %$hash, keys %$placebo);
 223
 224     is (XS::APItest::Hash::delete_ent ($hash, $victim, 0),
 225         delete $placebo->{$victim},
 226         "Deleting a known key with conversion enabled works (ent)");
 227     is (keys %$hash, keys %$placebo);
 228     @keys = sort keys %$hash;
 229     is ("@keys", join(' ', sort($mapping->(keys %$placebo))));
 230
 231     $victim = shift @hitlist;
 232     is (XS::APItest::Hash::delete ($hash, $victim,
 233                                    XS::APItest::HV_DISABLE_UVAR_XKEY),
 234         undef, "Deleting a known key with conversion disabled fails");
 235     is (keys %$hash, keys %$placebo);
 236
 237     is (XS::APItest::Hash::delete ($hash, $victim, 0),
 238         delete $placebo->{$victim},
 239         "Deleting a known key with conversion enabled works");
 240     is (keys %$hash, keys %$placebo);
 241     @keys = sort keys %$hash;
 242     is ("@keys", join(' ', sort($mapping->(keys %$placebo))));
 243
 244     my ($k, $v) = splice @$new, 0, 2;
 245     $hash->{$k} = $v;
 246     $placebo->{$k} = $v;
 247     is (keys %$hash, keys %$placebo);
 248     @keys = sort keys %$hash;
 249     is ("@keys", join(' ', sort($mapping->(keys %$placebo))));
 250
 251     ($k, $v) = splice @$new, 0, 2;
 252     is (XS::APItest::Hash::store_ent($hash, $k, $v), $v, "store_ent");
 253     $placebo->{$k} = $v;
 254     is (keys %$hash, keys %$placebo);
 255     @keys = sort keys %$hash;
 256     is ("@keys", join(' ', sort($mapping->(keys %$placebo))));
 257
 258     ($k, $v) = splice @$new, 0, 2;
 259     is (XS::APItest::Hash::store($hash, $k, $v), $v, "store");
 260     $placebo->{$k} = $v;
 261     is (keys %$hash, keys %$placebo);
 262     @keys = sort keys %$hash;
 263     is ("@keys", join(' ', sort($mapping->(keys %$placebo))));
 264
 265     @hitlist = keys %$placebo;
 266     $victim = shift @hitlist;
 267     is (XS::APItest::Hash::fetch_ent($hash, $victim), $placebo->{$victim},
 268         "fetch_ent");
 269     is (XS::APItest::Hash::fetch_ent($hash, $mapping->($victim)), undef,
 270         "fetch_ent (missing)");
 271
 272     $victim = shift @hitlist;
 273     is (XS::APItest::Hash::fetch($hash, $victim), $placebo->{$victim},
 274         "fetch");
 275     is (XS::APItest::Hash::fetch($hash, $mapping->($victim)), undef,
 276         "fetch (missing)");
 277
 278     $victim = shift @hitlist;
 279     ok (XS::APItest::Hash::exists_ent($hash, $victim), "exists_ent");
 280     ok (!XS::APItest::Hash::exists_ent($hash, $mapping->($victim)),
 281         "exists_ent (missing)");
 282
 283     $victim = shift @hitlist;
 284     die "Need a victim" unless defined $victim;
 285     ok (XS::APItest::Hash::exists($hash, $victim), "exists");
 286     ok (!XS::APItest::Hash::exists($hash, $mapping->($victim)),
 287         "exists (missing)");
 288
 289     is (XS::APItest::Hash::common({hv => $hash, keysv => $victim}),
 290         $placebo->{$victim}, "common (fetch)");
 291     is (XS::APItest::Hash::common({hv => $hash, keypv => $victim}),
 292         $placebo->{$victim}, "common (fetch pv)");
 293     is (XS::APItest::Hash::common({hv => $hash, keysv => $victim,
 294                                    action => XS::APItest::HV_DISABLE_UVAR_XKEY}),
 295         undef, "common (fetch) missing");
 296     is (XS::APItest::Hash::common({hv => $hash, keypv => $victim,
 297                                    action => XS::APItest::HV_DISABLE_UVAR_XKEY}),
 298         undef, "common (fetch pv) missing");
 299     is (XS::APItest::Hash::common({hv => $hash, keysv => $mapping->($victim),
 300                                    action => XS::APItest::HV_DISABLE_UVAR_XKEY}),
 301         $placebo->{$victim}, "common (fetch) missing mapped");
 302     is (XS::APItest::Hash::common({hv => $hash, keypv => $mapping->($victim),
 303                                    action => XS::APItest::HV_DISABLE_UVAR_XKEY}),
 304         $placebo->{$victim}, "common (fetch pv) missing mapped");
 305 }
 306
 307 sub main_tests {
 308   my ($keys, $testkeys, $description) = @_;
 309   foreach my $key (@$testkeys) {
 310     my $lckey = ($key eq chr 198) ? chr 230 : lc $key;
 311     my $unikey = $key;
 312     utf8::encode $unikey;
 313
 314     utf8::downgrade $key, 1;
 315     utf8::downgrade $lckey, 1;
 316     utf8::downgrade $unikey, 1;
 317     main_test_inner ($key, $lckey, $unikey, $keys, $description);
 318
 319     utf8::upgrade $key;
 320     utf8::upgrade $lckey;
 321     utf8::upgrade $unikey;
 322     main_test_inner ($key, $lckey, $unikey, $keys,
 323                      $description . ' [key utf8 on]');
 324   }
 325
 326   # hv_exists was buggy for tied hashes, in that the raw utf8 key was being
 327   # used - the utf8 flag was being lost.
 328   perform_test (\&test_absent, (chr 258), $keys, '');
 329
 330   perform_test (\&test_fetch_absent, (chr 258), $keys, '');
 331   perform_test (\&test_delete_absent, (chr 258), $keys, '');
 332 }
 333
 334 sub main_test_inner {
 335   my ($key, $lckey, $unikey, $keys, $description) = @_;
 336   perform_test (\&test_present, $key, $keys, $description);
 337   perform_test (\&test_fetch_present, $key, $keys, $description);
 338   perform_test (\&test_delete_present, $key, $keys, $description);
 339
 340   perform_test (\&test_store, $key, $keys, $description, [a=>'cheat']);
 341   perform_test (\&test_store, $key, $keys, $description, []);
 342
 343   perform_test (\&test_absent, $lckey, $keys, $description);
 344   perform_test (\&test_fetch_absent, $lckey, $keys, $description);
 345   perform_test (\&test_delete_absent, $lckey, $keys, $description);
 346
 347   return if $unikey eq $key;
 348
 349   perform_test (\&test_absent, $unikey, $keys, $description);
 350   perform_test (\&test_fetch_absent, $unikey, $keys, $description);
 351   perform_test (\&test_delete_absent, $unikey, $keys, $description);
 352 }
 353
 354 sub perform_test {
 355   my ($test_sub, $key, $keys, $message, @other) = @_;
 356   my $printable = join ',', map {ord} split //, $key;
 357
 358   my (%hash, %tiehash);
 359   tie %tiehash, 'Tie::StdHash';
 360
 361   @hash{@$keys} = @$keys;
 362   @tiehash{@$keys} = @$keys;
 363
 364   &$test_sub (\%hash, $key, $printable, $message, @other);
 365   &$test_sub (\%tiehash, $key, $printable, "$message tie", @other);
 366 }
 367
 368 sub test_present {
 369   my ($hash, $key, $printable, $message) = @_;
 370
 371   ok (exists $hash->{$key}, "hv_exists_ent present$message $printable");
 372   ok (XS::APItest::Hash::exists ($hash, $key),
 373       "hv_exists present$message $printable");
 374 }
 375
 376 sub test_absent {
 377   my ($hash, $key, $printable, $message) = @_;
 378
 379   ok (!exists $hash->{$key}, "hv_exists_ent absent$message $printable");
 380   ok (!XS::APItest::Hash::exists ($hash, $key),
 381       "hv_exists absent$message $printable");
 382 }
 383
 384 sub test_delete_present {
 385   my ($hash, $key, $printable, $message) = @_;
 386
 387   my $copy = {};
 388   my $class = tied %$hash;
 389   if (defined $class) {
 390     tie %$copy, ref $class;
 391   }
 392   $copy = {%$hash};
 393   ok (brute_force_exists ($copy, $key),
 394       "hv_delete_ent present$message $printable");
 395   is (delete $copy->{$key}, $key, "hv_delete_ent present$message $printable");
 396   ok (!brute_force_exists ($copy, $key),
 397       "hv_delete_ent present$message $printable");
 398   $copy = {%$hash};
 399   ok (brute_force_exists ($copy, $key),
 400       "hv_delete present$message $printable");
 401   is (XS::APItest::Hash::delete ($copy, $key), $key,
 402       "hv_delete present$message $printable");
 403   ok (!brute_force_exists ($copy, $key),
 404       "hv_delete present$message $printable");
 405 }
 406
 407 sub test_delete_absent {
 408   my ($hash, $key, $printable, $message) = @_;
 409
 410   my $copy = {};
 411   my $class = tied %$hash;
 412   if (defined $class) {
 413     tie %$copy, ref $class;
 414   }
 415   $copy = {%$hash};
 416   is (delete $copy->{$key}, undef, "hv_delete_ent absent$message $printable");
 417   $copy = {%$hash};
 418   is (XS::APItest::Hash::delete ($copy, $key), undef,
 419       "hv_delete absent$message $printable");
 420 }
 421
 422 sub test_store {
 423   my ($hash, $key, $printable, $message, $defaults) = @_;
 424   my $HV_STORE_IS_CRAZY = 1;
 425
 426   # We are cheating - hv_store returns NULL for a store into an empty
 427   # tied hash. This isn't helpful here.
 428
 429   my $class = tied %$hash;
 430
 431   # It's important to do this with nice new hashes created each time round
 432   # the loop, rather than hashes in the pad, which get recycled, and may have
 433   # xhv_array non-NULL
 434   my $h1 = {@$defaults};
 435   my $h2 = {@$defaults};
 436   if (defined $class) {
 437     tie %$h1, ref $class;
 438     tie %$h2, ref $class;
 439     if ($] > 5.009) {
 440       # bug 36327 is fixed
 441       $HV_STORE_IS_CRAZY = undef;
 442     } else {
 443       # HV store_ent returns 1 if there was already underlying hash storage
 444       $HV_STORE_IS_CRAZY = undef unless @$defaults;
 445     }
 446   }
 447   is (XS::APItest::Hash::store_ent($h1, $key, 1), $HV_STORE_IS_CRAZY,
 448       "hv_store_ent$message $printable");
 449   ok (brute_force_exists ($h1, $key), "hv_store_ent$message $printable");
 450   is (XS::APItest::Hash::store($h2, $key,  1), $HV_STORE_IS_CRAZY,
 451       "hv_store$message $printable");
 452   ok (brute_force_exists ($h2, $key), "hv_store$message $printable");
 453 }
 454
 455 sub test_fetch_present {
 456   my ($hash, $key, $printable, $message) = @_;
 457
 458   is ($hash->{$key}, $key, "hv_fetch_ent present$message $printable");
 459   is (XS::APItest::Hash::fetch ($hash, $key), $key,
 460       "hv_fetch present$message $printable");
 461 }
 462
 463 sub test_fetch_absent {
 464   my ($hash, $key, $printable, $message) = @_;
 465
 466   is ($hash->{$key}, undef, "hv_fetch_ent absent$message $printable");
 467   is (XS::APItest::Hash::fetch ($hash, $key), undef,
 468       "hv_fetch absent$message $printable");
 469 }
 470
 471 sub brute_force_exists {
 472   my ($hash, $key) = @_;
 473   foreach (keys %$hash) {
 474     return 1 if $key eq $_;
 475   }
 476   return 0;
 477 }
 478
 479 sub rot13 {
 480     my @results = map {my $a = $_; $a =~ tr/A-Za-z/N-ZA-Mn-za-m/; $a} @_;
 481     wantarray ? @results : $results[0];
 482 }
 483
 484 sub bitflip {
 485     my @results = map {join '', map {chr(32 ^ ord $_)} split '', $_} @_;
 486     wantarray ? @results : $results[0];
 487 }