ext/XS/APItest/t/hash.t

   1 #!perl -w
   2
   3 BEGIN {
   4   chdir 't' if -d 't';
   5   @INC = '../lib';
   6   push @INC, "::lib:$MacPerl::Architecture:" if $^O eq 'MacOS';
   7   require Config; import Config;
   8   if ($Config{'extensions'} !~ /\bXS\/APItest\b/) {
   9     # Look, I'm using this fully-qualified variable more than once!
  10     my $arch = $MacPerl::Architecture;
  11     print "1..0 # Skip: XS::APItest was not built\n";
  12     exit 0;
  13   }
  14 }
  15
  16 use strict;
  17 use utf8;
  18 use Tie::Hash;
  19 use Test::More 'no_plan';
  20
  21 BEGIN {use_ok('XS::APItest')};
  22
  23 sub preform_test;
  24 sub test_present;
  25 sub test_absent;
  26 sub test_delete_present;
  27 sub test_delete_absent;
  28 sub brute_force_exists;
  29 sub test_store;
  30 sub test_fetch_present;
  31 sub test_fetch_absent;
  32
  33 my $utf8_for_258 = chr 258;
  34 utf8::encode $utf8_for_258;
  35
  36 my @testkeys = ('N', chr 198, chr 256);
  37 my @keys = (@testkeys, $utf8_for_258);
  38
  39 foreach (@keys) {
  40   utf8::downgrade $_, 1;
  41 }
  42 main_tests (\@keys, \@testkeys, '');
  43
  44 foreach (@keys) {
  45   utf8::upgrade $_;
  46 }
  47 main_tests (\@keys, \@testkeys, ' [utf8 hash]');
  48
  49 {
  50   my %h = (a=>'cheat');
  51   tie %h, 'Tie::StdHash';
  52   is (XS::APItest::Hash::store(\%h, chr 258,  1), undef);
  53
  54   ok (!exists $h{$utf8_for_258},
  55       "hv_store doesn't insert a key with the raw utf8 on a tied hash");
  56 }
  57
  58 {
  59     my $strtab = strtab();
  60     is (ref $strtab, 'HASH', "The shared string table quacks like a hash");
  61     my $wibble = "\0";
  62     eval {
  63         $strtab->{$wibble}++;
  64     };
  65     my $prefix = "Cannot modify shared string table in hv_";
  66     my $what = $prefix . 'fetch';
  67     like ($@, qr/^$what/,$what);
  68     eval {
  69         XS::APItest::Hash::store($strtab, 'Boom!',  1)
  70     };
  71     $what = $prefix . 'store';
  72     like ($@, qr/^$what/, $what);
  73     if (0) {
  74         A::B->method();
  75     }
  76     # DESTROY should be in there.
  77     eval {
  78         delete $strtab->{DESTROY};
  79     };
  80     $what = $prefix . 'delete';
  81     like ($@, qr/^$what/, $what);
  82     # I can't work out how to get to the code that flips the wasutf8 flag on
  83     # the hash key without some ikcy XS
  84 }
  85
  86 {
  87     is_deeply([&XS::APItest::Hash::test_hv_free_ent], [2,2,1,1],
  88               "hv_free_ent frees the value immediately");
  89     is_deeply([&XS::APItest::Hash::test_hv_delayfree_ent], [2,2,2,1],
  90               "hv_delayfree_ent keeps the value around until FREETMPS");
  91 }
  92
  93 foreach my $in ("", "N", "a\0b") {
  94     my $got = XS::APItest::Hash::test_share_unshare_pvn($in);
  95     is ($got, $in, "test_share_unshare_pvn");
  96 }
  97
  98 if ($] > 5.009) {
  99     foreach ([\&XS::APItest::Hash::rot13_hash, \&rot13, "rot 13"],
 100              [\&XS::APItest::Hash::bitflip_hash, \&bitflip, "bitflip"],
 101             ) {
 102         my ($setup, $mapping, $name) = @$_;
 103         my %hash;
 104         my %placebo = (a => 1, p => 2, i => 4, e => 8);
 105         $setup->(\%hash);
 106         $hash{a}++; @hash{qw(p i e)} = (2, 4, 8);
 107
 108         test_U_hash(\%hash, \%placebo, [f => 9, g => 10, h => 11], $mapping,
 109                     $name);
 110     }
 111 }
 112
 113 exit;
 114
 115 ################################   The End   ################################
 116
 117 sub test_U_hash {
 118     my ($hash, $placebo, $new, $mapping, $message) = @_;
 119     my @hitlist = keys %$placebo;
 120     print "# $message\n";
 121
 122     my @keys = sort keys %$hash;
 123     is ("@keys", join(' ', sort($mapping->(keys %$placebo))),
 124         "uvar magic called exactly once on store");
 125
 126     is (keys %$hash, 4);
 127
 128     my $victim = shift @hitlist;
 129     is (delete $hash->{$victim}, delete $placebo->{$victim});
 130
 131     is (keys %$hash, 3);
 132     @keys = sort keys %$hash;
 133     is ("@keys", join(' ', sort($mapping->(keys %$placebo))));
 134
 135     $victim = shift @hitlist;
 136     is (XS::APItest::Hash::delete_ent ($hash, $victim,
 137                                        XS::APItest::HV_DISABLE_UVAR_XKEY),
 138         undef, "Deleting a known key with conversion disabled fails (ent)");
 139     is (keys %$hash, 3);
 140
 141     is (XS::APItest::Hash::delete_ent ($hash, $victim, 0),
 142         delete $placebo->{$victim},
 143         "Deleting a known key with conversion enabled works (ent)");
 144     is (keys %$hash, 2);
 145     @keys = sort keys %$hash;
 146     is ("@keys", join(' ', sort($mapping->(keys %$placebo))));
 147
 148     $victim = shift @hitlist;
 149     is (XS::APItest::Hash::delete ($hash, $victim,
 150                                    XS::APItest::HV_DISABLE_UVAR_XKEY),
 151         undef, "Deleting a known key with conversion disabled fails");
 152     is (keys %$hash, 2);
 153
 154     is (XS::APItest::Hash::delete ($hash, $victim, 0),
 155         delete $placebo->{$victim},
 156         "Deleting a known key with conversion enabled works");
 157     is(keys %$hash, 1);
 158     @keys = sort keys %$hash;
 159     is ("@keys", join(' ', sort($mapping->(keys %$placebo))));
 160
 161     my ($k, $v) = splice @$new, 0, 2;
 162     $hash->{$k} = $v;
 163     $placebo->{$k} = $v;
 164     is(keys %$hash, 2);
 165     @keys = sort keys %$hash;
 166     is ("@keys", join(' ', sort($mapping->(keys %$placebo))));
 167
 168     ($k, $v) = splice @$new, 0, 2;
 169     is (XS::APItest::Hash::store_ent($hash, $k, $v), $v, "store_ent");
 170     $placebo->{$k} = $v;
 171     is (keys %$hash, 3);
 172     @keys = sort keys %$hash;
 173     is ("@keys", join(' ', sort($mapping->(keys %$placebo))));
 174
 175     ($k, $v) = splice @$new, 0, 2;
 176     is (XS::APItest::Hash::store($hash, $k, $v), $v, "store");
 177     is (keys %$hash, 4);
 178     $placebo->{$k} = $v;
 179     @keys = sort keys %$hash;
 180     is ("@keys", join(' ', sort($mapping->(keys %$placebo))));
 181
 182     @hitlist = keys %$placebo;
 183     $victim = shift @hitlist;
 184     is (XS::APItest::Hash::fetch_ent($hash, $victim), $placebo->{$victim},
 185         "fetch_ent");
 186     is (XS::APItest::Hash::fetch_ent($hash, $mapping->($victim)), undef,
 187         "fetch_ent (missing)");
 188
 189     $victim = shift @hitlist;
 190     is (XS::APItest::Hash::fetch($hash, $victim), $placebo->{$victim},
 191         "fetch");
 192     is (XS::APItest::Hash::fetch($hash, $mapping->($victim)), undef,
 193         "fetch (missing)");
 194
 195     $victim = shift @hitlist;
 196     ok (XS::APItest::Hash::exists_ent($hash, $victim), "exists_ent");
 197     ok (!XS::APItest::Hash::exists_ent($hash, $mapping->($victim)),
 198         "exists_ent (missing)");
 199
 200     $victim = shift @hitlist;
 201     ok (XS::APItest::Hash::exists($hash, $victim), "exists");
 202     ok (!XS::APItest::Hash::exists($hash, $mapping->($victim)),
 203         "exists (missing)");
 204 }
 205
 206 sub main_tests {
 207   my ($keys, $testkeys, $description) = @_;
 208   foreach my $key (@$testkeys) {
 209     my $lckey = ($key eq chr 198) ? chr 230 : lc $key;
 210     my $unikey = $key;
 211     utf8::encode $unikey;
 212
 213     utf8::downgrade $key, 1;
 214     utf8::downgrade $lckey, 1;
 215     utf8::downgrade $unikey, 1;
 216     main_test_inner ($key, $lckey, $unikey, $keys, $description);
 217
 218     utf8::upgrade $key;
 219     utf8::upgrade $lckey;
 220     utf8::upgrade $unikey;
 221     main_test_inner ($key, $lckey, $unikey, $keys,
 222                      $description . ' [key utf8 on]');
 223   }
 224
 225   # hv_exists was buggy for tied hashes, in that the raw utf8 key was being
 226   # used - the utf8 flag was being lost.
 227   perform_test (\&test_absent, (chr 258), $keys, '');
 228
 229   perform_test (\&test_fetch_absent, (chr 258), $keys, '');
 230   perform_test (\&test_delete_absent, (chr 258), $keys, '');
 231 }
 232
 233 sub main_test_inner {
 234   my ($key, $lckey, $unikey, $keys, $description) = @_;
 235   perform_test (\&test_present, $key, $keys, $description);
 236   perform_test (\&test_fetch_present, $key, $keys, $description);
 237   perform_test (\&test_delete_present, $key, $keys, $description);
 238
 239   perform_test (\&test_store, $key, $keys, $description, [a=>'cheat']);
 240   perform_test (\&test_store, $key, $keys, $description, []);
 241
 242   perform_test (\&test_absent, $lckey, $keys, $description);
 243   perform_test (\&test_fetch_absent, $lckey, $keys, $description);
 244   perform_test (\&test_delete_absent, $lckey, $keys, $description);
 245
 246   return if $unikey eq $key;
 247
 248   perform_test (\&test_absent, $unikey, $keys, $description);
 249   perform_test (\&test_fetch_absent, $unikey, $keys, $description);
 250   perform_test (\&test_delete_absent, $unikey, $keys, $description);
 251 }
 252
 253 sub perform_test {
 254   my ($test_sub, $key, $keys, $message, @other) = @_;
 255   my $printable = join ',', map {ord} split //, $key;
 256
 257   my (%hash, %tiehash);
 258   tie %tiehash, 'Tie::StdHash';
 259
 260   @hash{@$keys} = @$keys;
 261   @tiehash{@$keys} = @$keys;
 262
 263   &$test_sub (\%hash, $key, $printable, $message, @other);
 264   &$test_sub (\%tiehash, $key, $printable, "$message tie", @other);
 265 }
 266
 267 sub test_present {
 268   my ($hash, $key, $printable, $message) = @_;
 269
 270   ok (exists $hash->{$key}, "hv_exists_ent present$message $printable");
 271   ok (XS::APItest::Hash::exists ($hash, $key),
 272       "hv_exists present$message $printable");
 273 }
 274
 275 sub test_absent {
 276   my ($hash, $key, $printable, $message) = @_;
 277
 278   ok (!exists $hash->{$key}, "hv_exists_ent absent$message $printable");
 279   ok (!XS::APItest::Hash::exists ($hash, $key),
 280       "hv_exists absent$message $printable");
 281 }
 282
 283 sub test_delete_present {
 284   my ($hash, $key, $printable, $message) = @_;
 285
 286   my $copy = {};
 287   my $class = tied %$hash;
 288   if (defined $class) {
 289     tie %$copy, ref $class;
 290   }
 291   $copy = {%$hash};
 292   ok (brute_force_exists ($copy, $key),
 293       "hv_delete_ent present$message $printable");
 294   is (delete $copy->{$key}, $key, "hv_delete_ent present$message $printable");
 295   ok (!brute_force_exists ($copy, $key),
 296       "hv_delete_ent present$message $printable");
 297   $copy = {%$hash};
 298   ok (brute_force_exists ($copy, $key),
 299       "hv_delete present$message $printable");
 300   is (XS::APItest::Hash::delete ($copy, $key), $key,
 301       "hv_delete present$message $printable");
 302   ok (!brute_force_exists ($copy, $key),
 303       "hv_delete present$message $printable");
 304 }
 305
 306 sub test_delete_absent {
 307   my ($hash, $key, $printable, $message) = @_;
 308
 309   my $copy = {};
 310   my $class = tied %$hash;
 311   if (defined $class) {
 312     tie %$copy, ref $class;
 313   }
 314   $copy = {%$hash};
 315   is (delete $copy->{$key}, undef, "hv_delete_ent absent$message $printable");
 316   $copy = {%$hash};
 317   is (XS::APItest::Hash::delete ($copy, $key), undef,
 318       "hv_delete absent$message $printable");
 319 }
 320
 321 sub test_store {
 322   my ($hash, $key, $printable, $message, $defaults) = @_;
 323   my $HV_STORE_IS_CRAZY = 1;
 324
 325   # We are cheating - hv_store returns NULL for a store into an empty
 326   # tied hash. This isn't helpful here.
 327
 328   my $class = tied %$hash;
 329
 330   my %h1 = @$defaults;
 331   my %h2 = @$defaults;
 332   if (defined $class) {
 333     tie %h1, ref $class;
 334     tie %h2, ref $class;
 335     $HV_STORE_IS_CRAZY = undef;
 336   }
 337   is (XS::APItest::Hash::store_ent(\%h1, $key, 1), $HV_STORE_IS_CRAZY,
 338       "hv_store_ent$message $printable");
 339   ok (brute_force_exists (\%h1, $key), "hv_store_ent$message $printable");
 340   is (XS::APItest::Hash::store(\%h2, $key,  1), $HV_STORE_IS_CRAZY,
 341       "hv_store$message $printable");
 342   ok (brute_force_exists (\%h2, $key), "hv_store$message $printable");
 343 }
 344
 345 sub test_fetch_present {
 346   my ($hash, $key, $printable, $message) = @_;
 347
 348   is ($hash->{$key}, $key, "hv_fetch_ent present$message $printable");
 349   is (XS::APItest::Hash::fetch ($hash, $key), $key,
 350       "hv_fetch present$message $printable");
 351 }
 352
 353 sub test_fetch_absent {
 354   my ($hash, $key, $printable, $message) = @_;
 355
 356   is ($hash->{$key}, undef, "hv_fetch_ent absent$message $printable");
 357   is (XS::APItest::Hash::fetch ($hash, $key), undef,
 358       "hv_fetch absent$message $printable");
 359 }
 360
 361 sub brute_force_exists {
 362   my ($hash, $key) = @_;
 363   foreach (keys %$hash) {
 364     return 1 if $key eq $_;
 365   }
 366   return 0;
 367 }
 368
 369 sub rot13 {
 370     my @results = map {my $a = $_; $a =~ tr/A-Za-z/N-ZA-Mn-za-m/; $a} @_;
 371     wantarray ? @results : $results[0];
 372 }
 373
 374 sub bitflip {
 375     my @results = map {join '', map {chr(32 ^ ord $_)} split '', $_} @_;
 376     wantarray ? @results : $results[0];
 377 }