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