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