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 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 exit;
  93
  94 ################################   The End   ################################
  95
  96 sub main_tests {
  97   my ($keys, $testkeys, $description) = @_;
  98   foreach my $key (@$testkeys) {
  99     my $lckey = ($key eq chr 198) ? chr 230 : lc $key;
 100     my $unikey = $key;
 101     utf8::encode $unikey;
 102
 103     utf8::downgrade $key, 1;
 104     utf8::downgrade $lckey, 1;
 105     utf8::downgrade $unikey, 1;
 106     main_test_inner ($key, $lckey, $unikey, $keys, $description);
 107
 108     utf8::upgrade $key;
 109     utf8::upgrade $lckey;
 110     utf8::upgrade $unikey;
 111     main_test_inner ($key, $lckey, $unikey, $keys,
 112                      $description . ' [key utf8 on]');
 113   }
 114
 115   # hv_exists was buggy for tied hashes, in that the raw utf8 key was being
 116   # used - the utf8 flag was being lost.
 117   perform_test (\&test_absent, (chr 258), $keys, '');
 118
 119   perform_test (\&test_fetch_absent, (chr 258), $keys, '');
 120   perform_test (\&test_delete_absent, (chr 258), $keys, '');
 121 }
 122
 123 sub main_test_inner {
 124   my ($key, $lckey, $unikey, $keys, $description) = @_;
 125   perform_test (\&test_present, $key, $keys, $description);
 126   perform_test (\&test_fetch_present, $key, $keys, $description);
 127   perform_test (\&test_delete_present, $key, $keys, $description);
 128
 129   perform_test (\&test_store, $key, $keys, $description, [a=>'cheat']);
 130   perform_test (\&test_store, $key, $keys, $description, []);
 131
 132   perform_test (\&test_absent, $lckey, $keys, $description);
 133   perform_test (\&test_fetch_absent, $lckey, $keys, $description);
 134   perform_test (\&test_delete_absent, $lckey, $keys, $description);
 135
 136   return if $unikey eq $key;
 137
 138   perform_test (\&test_absent, $unikey, $keys, $description);
 139   perform_test (\&test_fetch_absent, $unikey, $keys, $description);
 140   perform_test (\&test_delete_absent, $unikey, $keys, $description);
 141 }
 142
 143 sub perform_test {
 144   my ($test_sub, $key, $keys, $message, @other) = @_;
 145   my $printable = join ',', map {ord} split //, $key;
 146
 147   my (%hash, %tiehash);
 148   tie %tiehash, 'Tie::StdHash';
 149
 150   @hash{@$keys} = @$keys;
 151   @tiehash{@$keys} = @$keys;
 152
 153   &$test_sub (\%hash, $key, $printable, $message, @other);
 154   &$test_sub (\%tiehash, $key, $printable, "$message tie", @other);
 155 }
 156
 157 sub test_present {
 158   my ($hash, $key, $printable, $message) = @_;
 159
 160   ok (exists $hash->{$key}, "hv_exists_ent present$message $printable");
 161   ok (XS::APItest::Hash::exists ($hash, $key),
 162       "hv_exists present$message $printable");
 163 }
 164
 165 sub test_absent {
 166   my ($hash, $key, $printable, $message) = @_;
 167
 168   ok (!exists $hash->{$key}, "hv_exists_ent absent$message $printable");
 169   ok (!XS::APItest::Hash::exists ($hash, $key),
 170       "hv_exists absent$message $printable");
 171 }
 172
 173 sub test_delete_present {
 174   my ($hash, $key, $printable, $message) = @_;
 175
 176   my $copy = {};
 177   my $class = tied %$hash;
 178   if (defined $class) {
 179     tie %$copy, ref $class;
 180   }
 181   $copy = {%$hash};
 182   ok (brute_force_exists ($copy, $key),
 183       "hv_delete_ent present$message $printable");
 184   is (delete $copy->{$key}, $key, "hv_delete_ent present$message $printable");
 185   ok (!brute_force_exists ($copy, $key),
 186       "hv_delete_ent present$message $printable");
 187   $copy = {%$hash};
 188   ok (brute_force_exists ($copy, $key),
 189       "hv_delete present$message $printable");
 190   is (XS::APItest::Hash::delete ($copy, $key), $key,
 191       "hv_delete present$message $printable");
 192   ok (!brute_force_exists ($copy, $key),
 193       "hv_delete present$message $printable");
 194 }
 195
 196 sub test_delete_absent {
 197   my ($hash, $key, $printable, $message) = @_;
 198
 199   my $copy = {};
 200   my $class = tied %$hash;
 201   if (defined $class) {
 202     tie %$copy, ref $class;
 203   }
 204   $copy = {%$hash};
 205   is (delete $copy->{$key}, undef, "hv_delete_ent absent$message $printable");
 206   $copy = {%$hash};
 207   is (XS::APItest::Hash::delete ($copy, $key), undef,
 208       "hv_delete absent$message $printable");
 209 }
 210
 211 sub test_store {
 212   my ($hash, $key, $printable, $message, $defaults) = @_;
 213   my $HV_STORE_IS_CRAZY = 1;
 214
 215   # We are cheating - hv_store returns NULL for a store into an empty
 216   # tied hash. This isn't helpful here.
 217
 218   my $class = tied %$hash;
 219
 220   my %h1 = @$defaults;
 221   my %h2 = @$defaults;
 222   if (defined $class) {
 223     tie %h1, ref $class;
 224     tie %h2, ref $class;
 225     $HV_STORE_IS_CRAZY = undef;
 226   }
 227   is (XS::APItest::Hash::store_ent(\%h1, $key, 1), $HV_STORE_IS_CRAZY,
 228       "hv_store_ent$message $printable");
 229   ok (brute_force_exists (\%h1, $key), "hv_store_ent$message $printable");
 230   is (XS::APItest::Hash::store(\%h2, $key,  1), $HV_STORE_IS_CRAZY,
 231       "hv_store$message $printable");
 232   ok (brute_force_exists (\%h2, $key), "hv_store$message $printable");
 233 }
 234
 235 sub test_fetch_present {
 236   my ($hash, $key, $printable, $message) = @_;
 237
 238   is ($hash->{$key}, $key, "hv_fetch_ent present$message $printable");
 239   is (XS::APItest::Hash::fetch ($hash, $key), $key,
 240       "hv_fetch present$message $printable");
 241 }
 242
 243 sub test_fetch_absent {
 244   my ($hash, $key, $printable, $message) = @_;
 245
 246   is ($hash->{$key}, undef, "hv_fetch_ent absent$message $printable");
 247   is (XS::APItest::Hash::fetch ($hash, $key), undef,
 248       "hv_fetch absent$message $printable");
 249 }
 250
 251 sub brute_force_exists {
 252   my ($hash, $key) = @_;
 253   foreach (keys %$hash) {
 254     return 1 if $key eq $_;
 255   }
 256   return 0;
 257 }