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 }
 262
 263 # [perl #111000] Bug number eleventy-one thousand:
 264 #                hv_store should work on hint hashes
 265 eval q{
 266     BEGIN {
 267         XS::APItest::Hash::store \%^H, "XS::APItest/hash.t", undef;
 268         delete $^H{"XS::APItest/hash.t"};
 269     }
 270 };
 271 pass("hv_store works on the hint hash");
 272
 273 done_testing;
 274 exit;
 275
 276 ################################   The End   ################################
 277
 278 sub test_U_hash {
 279     my ($hash, $placebo, $new, $mapping, $message) = @_;
 280     my @hitlist = keys %$placebo;
 281     print "# $message\n";
 282
 283     my @keys = sort keys %$hash;
 284     is ("@keys", join(' ', sort($mapping->(keys %$placebo))),
 285         "uvar magic called exactly once on store");
 286
 287     is (keys %$hash, keys %$placebo);
 288
 289     my $victim = shift @hitlist;
 290     is (delete $hash->{$victim}, delete $placebo->{$victim});
 291
 292     is (keys %$hash, keys %$placebo);
 293     @keys = sort keys %$hash;
 294     is ("@keys", join(' ', sort($mapping->(keys %$placebo))));
 295
 296     $victim = shift @hitlist;
 297     is (XS::APItest::Hash::delete_ent ($hash, $victim,
 298                                        XS::APItest::HV_DISABLE_UVAR_XKEY),
 299         undef, "Deleting a known key with conversion disabled fails (ent)");
 300     is (keys %$hash, keys %$placebo);
 301
 302     is (XS::APItest::Hash::delete_ent ($hash, $victim, 0),
 303         delete $placebo->{$victim},
 304         "Deleting a known key with conversion enabled works (ent)");
 305     is (keys %$hash, keys %$placebo);
 306     @keys = sort keys %$hash;
 307     is ("@keys", join(' ', sort($mapping->(keys %$placebo))));
 308
 309     $victim = shift @hitlist;
 310     is (XS::APItest::Hash::delete ($hash, $victim,
 311                                    XS::APItest::HV_DISABLE_UVAR_XKEY),
 312         undef, "Deleting a known key with conversion disabled fails");
 313     is (keys %$hash, keys %$placebo);
 314
 315     is (XS::APItest::Hash::delete ($hash, $victim, 0),
 316         delete $placebo->{$victim},
 317         "Deleting a known key with conversion enabled works");
 318     is (keys %$hash, keys %$placebo);
 319     @keys = sort keys %$hash;
 320     is ("@keys", join(' ', sort($mapping->(keys %$placebo))));
 321
 322     my ($k, $v) = splice @$new, 0, 2;
 323     $hash->{$k} = $v;
 324     $placebo->{$k} = $v;
 325     is (keys %$hash, keys %$placebo);
 326     @keys = sort keys %$hash;
 327     is ("@keys", join(' ', sort($mapping->(keys %$placebo))));
 328
 329     ($k, $v) = splice @$new, 0, 2;
 330     is (XS::APItest::Hash::store_ent($hash, $k, $v), $v, "store_ent");
 331     $placebo->{$k} = $v;
 332     is (keys %$hash, keys %$placebo);
 333     @keys = sort keys %$hash;
 334     is ("@keys", join(' ', sort($mapping->(keys %$placebo))));
 335
 336     ($k, $v) = splice @$new, 0, 2;
 337     is (XS::APItest::Hash::store($hash, $k, $v), $v, "store");
 338     $placebo->{$k} = $v;
 339     is (keys %$hash, keys %$placebo);
 340     @keys = sort keys %$hash;
 341     is ("@keys", join(' ', sort($mapping->(keys %$placebo))));
 342
 343     @hitlist = keys %$placebo;
 344     $victim = shift @hitlist;
 345     is (XS::APItest::Hash::fetch_ent($hash, $victim), $placebo->{$victim},
 346         "fetch_ent");
 347     is (XS::APItest::Hash::fetch_ent($hash, $mapping->($victim)), undef,
 348         "fetch_ent (missing)");
 349
 350     $victim = shift @hitlist;
 351     is (XS::APItest::Hash::fetch($hash, $victim), $placebo->{$victim},
 352         "fetch");
 353     is (XS::APItest::Hash::fetch($hash, $mapping->($victim)), undef,
 354         "fetch (missing)");
 355
 356     $victim = shift @hitlist;
 357     ok (XS::APItest::Hash::exists_ent($hash, $victim), "exists_ent");
 358     ok (!XS::APItest::Hash::exists_ent($hash, $mapping->($victim)),
 359         "exists_ent (missing)");
 360
 361     $victim = shift @hitlist;
 362     die "Need a victim" unless defined $victim;
 363     ok (XS::APItest::Hash::exists($hash, $victim), "exists");
 364     ok (!XS::APItest::Hash::exists($hash, $mapping->($victim)),
 365         "exists (missing)");
 366
 367     is (XS::APItest::Hash::common({hv => $hash, keysv => $victim}),
 368         $placebo->{$victim}, "common (fetch)");
 369     is (XS::APItest::Hash::common({hv => $hash, keypv => $victim}),
 370         $placebo->{$victim}, "common (fetch pv)");
 371     is (XS::APItest::Hash::common({hv => $hash, keysv => $victim,
 372                                    action => XS::APItest::HV_DISABLE_UVAR_XKEY}),
 373         undef, "common (fetch) missing");
 374     is (XS::APItest::Hash::common({hv => $hash, keypv => $victim,
 375                                    action => XS::APItest::HV_DISABLE_UVAR_XKEY}),
 376         undef, "common (fetch pv) missing");
 377     is (XS::APItest::Hash::common({hv => $hash, keysv => $mapping->($victim),
 378                                    action => XS::APItest::HV_DISABLE_UVAR_XKEY}),
 379         $placebo->{$victim}, "common (fetch) missing mapped");
 380     is (XS::APItest::Hash::common({hv => $hash, keypv => $mapping->($victim),
 381                                    action => XS::APItest::HV_DISABLE_UVAR_XKEY}),
 382         $placebo->{$victim}, "common (fetch pv) missing mapped");
 383 }
 384
 385 sub main_tests {
 386   my ($keys, $testkeys, $description) = @_;
 387   foreach my $key (@$testkeys) {
 388     my $lckey = ($key eq chr 198) ? chr 230 : lc $key;
 389     my $unikey = $key;
 390     utf8::encode $unikey;
 391
 392     utf8::downgrade $key, 1;
 393     utf8::downgrade $lckey, 1;
 394     utf8::downgrade $unikey, 1;
 395     main_test_inner ($key, $lckey, $unikey, $keys, $description);
 396
 397     utf8::upgrade $key;
 398     utf8::upgrade $lckey;
 399     utf8::upgrade $unikey;
 400     main_test_inner ($key, $lckey, $unikey, $keys,
 401                      $description . ' [key utf8 on]');
 402   }
 403
 404   # hv_exists was buggy for tied hashes, in that the raw utf8 key was being
 405   # used - the utf8 flag was being lost.
 406   perform_test (\&test_absent, (chr 258), $keys, '');
 407
 408   perform_test (\&test_fetch_absent, (chr 258), $keys, '');
 409   perform_test (\&test_delete_absent, (chr 258), $keys, '');
 410 }
 411
 412 sub main_test_inner {
 413   my ($key, $lckey, $unikey, $keys, $description) = @_;
 414   perform_test (\&test_present, $key, $keys, $description);
 415   perform_test (\&test_fetch_present, $key, $keys, $description);
 416   perform_test (\&test_delete_present, $key, $keys, $description);
 417
 418   perform_test (\&test_store, $key, $keys, $description, [a=>'cheat']);
 419   perform_test (\&test_store, $key, $keys, $description, []);
 420
 421   perform_test (\&test_absent, $lckey, $keys, $description);
 422   perform_test (\&test_fetch_absent, $lckey, $keys, $description);
 423   perform_test (\&test_delete_absent, $lckey, $keys, $description);
 424
 425   return if $unikey eq $key;
 426
 427   perform_test (\&test_absent, $unikey, $keys, $description);
 428   perform_test (\&test_fetch_absent, $unikey, $keys, $description);
 429   perform_test (\&test_delete_absent, $unikey, $keys, $description);
 430 }
 431
 432 sub perform_test {
 433   my ($test_sub, $key, $keys, $message, @other) = @_;
 434   my $printable = join ',', map {ord} split //, $key;
 435
 436   my (%hash, %tiehash);
 437   tie %tiehash, 'Tie::StdHash';
 438
 439   @hash{@$keys} = @$keys;
 440   @tiehash{@$keys} = @$keys;
 441
 442   &$test_sub (\%hash, $key, $printable, $message, @other);
 443   &$test_sub (\%tiehash, $key, $printable, "$message tie", @other);
 444 }
 445
 446 sub test_present {
 447   my ($hash, $key, $printable, $message) = @_;
 448
 449   ok (exists $hash->{$key}, "hv_exists_ent present$message $printable");
 450   ok (XS::APItest::Hash::exists ($hash, $key),
 451       "hv_exists present$message $printable");
 452 }
 453
 454 sub test_absent {
 455   my ($hash, $key, $printable, $message) = @_;
 456
 457   ok (!exists $hash->{$key}, "hv_exists_ent absent$message $printable");
 458   ok (!XS::APItest::Hash::exists ($hash, $key),
 459       "hv_exists absent$message $printable");
 460 }
 461
 462 sub test_delete_present {
 463   my ($hash, $key, $printable, $message) = @_;
 464
 465   my $copy = {};
 466   my $class = tied %$hash;
 467   if (defined $class) {
 468     tie %$copy, ref $class;
 469   }
 470   $copy = {%$hash};
 471   ok (brute_force_exists ($copy, $key),
 472       "hv_delete_ent present$message $printable");
 473   is (delete $copy->{$key}, $key, "hv_delete_ent present$message $printable");
 474   ok (!brute_force_exists ($copy, $key),
 475       "hv_delete_ent present$message $printable");
 476   $copy = {%$hash};
 477   ok (brute_force_exists ($copy, $key),
 478       "hv_delete present$message $printable");
 479   is (XS::APItest::Hash::delete ($copy, $key), $key,
 480       "hv_delete present$message $printable");
 481   ok (!brute_force_exists ($copy, $key),
 482       "hv_delete present$message $printable");
 483 }
 484
 485 sub test_delete_absent {
 486   my ($hash, $key, $printable, $message) = @_;
 487
 488   my $copy = {};
 489   my $class = tied %$hash;
 490   if (defined $class) {
 491     tie %$copy, ref $class;
 492   }
 493   $copy = {%$hash};
 494   is (delete $copy->{$key}, undef, "hv_delete_ent absent$message $printable");
 495   $copy = {%$hash};
 496   is (XS::APItest::Hash::delete ($copy, $key), undef,
 497       "hv_delete absent$message $printable");
 498 }
 499
 500 sub test_store {
 501   my ($hash, $key, $printable, $message, $defaults) = @_;
 502   my $HV_STORE_IS_CRAZY = 1;
 503
 504   # We are cheating - hv_store returns NULL for a store into an empty
 505   # tied hash. This isn't helpful here.
 506
 507   my $class = tied %$hash;
 508
 509   # It's important to do this with nice new hashes created each time round
 510   # the loop, rather than hashes in the pad, which get recycled, and may have
 511   # xhv_array non-NULL
 512   my $h1 = {@$defaults};
 513   my $h2 = {@$defaults};
 514   if (defined $class) {
 515     tie %$h1, ref $class;
 516     tie %$h2, ref $class;
 517     if ($] > 5.009) {
 518       # bug 36327 is fixed
 519       $HV_STORE_IS_CRAZY = undef;
 520     } else {
 521       # HV store_ent returns 1 if there was already underlying hash storage
 522       $HV_STORE_IS_CRAZY = undef unless @$defaults;
 523     }
 524   }
 525   is (XS::APItest::Hash::store_ent($h1, $key, 1), $HV_STORE_IS_CRAZY,
 526       "hv_store_ent$message $printable");
 527   ok (brute_force_exists ($h1, $key), "hv_store_ent$message $printable");
 528   is (XS::APItest::Hash::store($h2, $key,  1), $HV_STORE_IS_CRAZY,
 529       "hv_store$message $printable");
 530   ok (brute_force_exists ($h2, $key), "hv_store$message $printable");
 531 }
 532
 533 sub test_fetch_present {
 534   my ($hash, $key, $printable, $message) = @_;
 535
 536   is ($hash->{$key}, $key, "hv_fetch_ent present$message $printable");
 537   is (XS::APItest::Hash::fetch ($hash, $key), $key,
 538       "hv_fetch present$message $printable");
 539 }
 540
 541 sub test_fetch_absent {
 542   my ($hash, $key, $printable, $message) = @_;
 543
 544   is ($hash->{$key}, undef, "hv_fetch_ent absent$message $printable");
 545   is (XS::APItest::Hash::fetch ($hash, $key), undef,
 546       "hv_fetch absent$message $printable");
 547 }
 548
 549 sub brute_force_exists {
 550   my ($hash, $key) = @_;
 551   foreach (keys %$hash) {
 552     return 1 if $key eq $_;
 553   }
 554   return 0;
 555 }
 556
 557 sub rot13 {
 558     my @results = map {my $a = $_; $a =~ tr/A-Za-z/N-ZA-Mn-za-m/; $a} @_;
 559     wantarray ? @results : $results[0];
 560 }
 561
 562 sub bitflip {
 563     my @results = map {join '', map {chr(32 ^ ord $_)} split '', $_} @_;
 564     wantarray ? @results : $results[0];
 565 }