ext/XS-APItest/t/hash.t

   1 #!perl -w
   2
   3 BEGIN {
   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
  14 use strict;
  15 use utf8;
  16 use Tie::Hash;
  17 use Test::More 'no_plan';
  18
  19 BEGIN {use_ok('XS::APItest')};
  20
  21 sub preform_test;
  22 sub test_present;
  23 sub test_absent;
  24 sub test_delete_present;
  25 sub test_delete_absent;
  26 sub brute_force_exists;
  27 sub test_store;
  28 sub test_fetch_present;
  29 sub test_fetch_absent;
  30
  31 my $utf8_for_258 = chr 258;
  32 utf8::encode $utf8_for_258;
  33
  34 my @testkeys = ('N', chr 198, chr 256);
  35 my @keys = (@testkeys, $utf8_for_258);
  36
  37 foreach (@keys) {
  38   utf8::downgrade $_, 1;
  39 }
  40 main_tests (\@keys, \@testkeys, '');
  41
  42 foreach (@keys) {
  43   utf8::upgrade $_;
  44 }
  45 main_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
  59 if ($] > 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
  94 foreach 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
  99 if ($] > 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
 151 sub 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
 194 exit;
 195
 196 ################################   The End   ################################
 197
 198 sub 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
 305 sub 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
 332 sub 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
 352 sub 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
 366 sub 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
 374 sub 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
 382 sub 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
 405 sub 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
 420 sub 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
 453 sub 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
 461 sub 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
 469 sub brute_force_exists {
 470   my ($hash, $key) = @_;
 471   foreach (keys %$hash) {
 472     return 1 if $key eq $_;
 473   }
 474   return 0;
 475 }
 476
 477 sub 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
 482 sub bitflip {
 483     my @results = map {join '', map {chr(32 ^ ord $_)} split '', $_} @_;
 484     wantarray ? @results : $results[0];
 485 }