ext/XS-APItest/t/hash.t

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