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