Gecko [ www.blackthorn-inc.com ]

Name	Size	Permission	Date
BHK.pm	260 B	-r--r--r--	2014-12-27 11:48
Block.pm	9 B	-r--r--r--	2014-12-27 11:48
Markers.pm	245 B	-r--r--r--	2014-12-27 11:48
Null.pm	3 B	-r--r--r--	2014-12-27 11:48
addissub.t	481 B	-r--r--r--	2014-12-27 11:48
arrayexpr.t	7.85 KB	-r--r--r--	2014-12-27 11:48
autoload.t	4.03 KB	-r--r--r--	2014-12-27 11:48
blockasexpr.t	1.46 KB	-r--r--r--	2014-12-27 11:48
blockhooks-csc.t	2.26 KB	-r--r--r--	2014-12-27 11:48
blockhooks.t	5.21 KB	-r--r--r--	2014-12-27 11:48
call.t	8.9 KB	-r--r--r--	2014-12-27 11:49
call_checker.t	4.03 KB	-r--r--r--	2014-12-27 11:49
caller.t	1.78 KB	-r--r--r--	2014-12-27 11:48
callregexec.t	2.46 KB	-r--r--r--	2014-12-27 11:49
check_warnings.t	495 B	-r--r--r--	2014-12-27 11:48
cleanup.t	1.41 KB	-r--r--r--	2014-12-27 11:48
clone-with-stack.t	1.45 KB	-r--r--r--	2015-01-10 12:06
cophh.t	280 B	-r--r--r--	2014-12-27 11:48
coplabel.t	112 B	-r--r--r--	2014-12-27 11:48
copstash.t	156 B	-r--r--r--	2014-12-27 11:48
copyhints.t	123 B	-r--r--r--	2014-12-27 11:48
customop.t	2.42 KB	-r--r--r--	2014-12-27 11:49
eval-filter.t	743 B	-r--r--r--	2014-12-27 11:48
exception.t	616 B	-r--r--r--	2014-12-27 11:48
fetch_pad_names.t	10.58 KB	-r--r--r--	2014-12-27 11:49
gotosub.t	351 B	-r--r--r--	2014-12-27 11:48
grok.t	2.07 KB	-r--r--r--	2014-12-27 11:49
gv_autoload4.t	2.01 KB	-r--r--r--	2014-12-27 11:48
gv_fetchmeth.t	2.3 KB	-r--r--r--	2014-12-27 11:48
gv_fetchmeth_autoload.t	3.38 KB	-r--r--r--	2014-12-27 11:48
gv_fetchmethod_flags.t	1.86 KB	-r--r--r--	2014-12-27 11:48
gv_init.t	489 B	-r--r--r--	2014-12-27 11:48
handy.t	15.33 KB	-r--r--r--	2014-12-27 11:49
hash.t	17.07 KB	-r--r--r--	2014-12-27 11:48
keyword_multiline.t	259 B	-r--r--r--	2014-12-27 11:48
keyword_plugin.t	1.15 KB	-r--r--r--	2014-12-27 11:48
labelconst.aux	146 B	-r--r--r--	2014-12-27 11:48
labelconst.t	2.63 KB	-r--r--r--	2014-12-27 11:48
labelconst_utf8.aux	194 B	-r--r--r--	2014-12-27 11:48
lexsub.t	524 B	-r--r--r--	2014-12-27 11:48
loopblock.t	1.46 KB	-r--r--r--	2014-12-27 11:48
looprest.t	1.39 KB	-r--r--r--	2014-12-27 11:48
lvalue.t	800 B	-r--r--r--	2014-12-27 11:48
magic.t	804 B	-r--r--r--	2014-12-27 11:49
magic_chain.t	115 B	-r--r--r--	2014-12-27 11:48
mro.t	237 B	-r--r--r--	2014-12-27 11:48
multicall.t	1.32 KB	-r--r--r--	2014-12-27 11:48
my_cxt.t	1.28 KB	-r--r--r--	2014-12-27 11:48
my_exit.t	790 B	-r--r--r--	2014-12-27 11:48
newCONSTSUB.t	2.58 KB	-r--r--r--	2014-12-27 11:48
op.t	359 B	-r--r--r--	2014-12-27 11:48
op_contextualize.t	120 B	-r--r--r--	2014-12-27 11:48
op_list.t	151 B	-r--r--r--	2014-12-27 11:48
overload.t	2.21 KB	-r--r--r--	2014-12-27 11:48
pad_scalar.t	1.83 KB	-r--r--r--	2014-12-27 11:48
peep.t	1013 B	-r--r--r--	2014-12-27 11:48
pmflag.t	192 B	-r--r--r--	2014-12-27 11:48
postinc.t	800 B	-r--r--r--	2014-12-27 11:48
printf.t	1.05 KB	-r--r--r--	2014-12-27 11:49
ptr_table.t	916 B	-r--r--r--	2014-12-27 11:48
push.t	746 B	-r--r--r--	2014-12-27 11:48
refs.t	578 B	-r--r--r--	2014-12-27 11:48
rmagical.t	823 B	-r--r--r--	2014-12-27 11:48
rv2cv_op_cv.t	115 B	-r--r--r--	2014-12-27 11:48
savehints.t	123 B	-r--r--r--	2014-12-27 11:48
scopelessblock.t	1.59 KB	-r--r--r--	2014-12-27 11:48
sort.t	411 B	-r--r--r--	2014-12-27 11:48
stmtasexpr.t	893 B	-r--r--r--	2014-12-27 11:48
stmtsasexpr.t	949 B	-r--r--r--	2014-12-27 11:48
stuff_modify_bug.t	151 B	-r--r--r--	2014-12-27 11:48
stuff_svcur_bug.t	260 B	-r--r--r--	2014-12-27 11:48
subcall.t	179 B	-r--r--r--	2014-12-27 11:48
sviscow.t	229 B	-r--r--r--	2014-12-27 11:48
svpeek.t	3.16 KB	-r--r--r--	2014-12-27 11:49
svpv.t	1.01 KB	-r--r--r--	2014-12-27 11:48
svpv_magic.t	1.29 KB	-r--r--r--	2014-12-27 11:48
svsetsv.t	1015 B	-r--r--r--	2014-12-27 11:48
swaplabel.t	7.06 KB	-r--r--r--	2014-12-27 11:48
swaptwostmts.t	2.79 KB	-r--r--r--	2014-12-27 11:48
sym-hook.t	730 B	-r--r--r--	2014-12-27 11:48
temp_lv_sub.t	532 B	-r--r--r--	2014-12-27 11:48
underscore_length.t	338 B	-r--r--r--	2014-12-27 11:48
utf16_to_utf8.t	2.09 KB	-r--r--r--	2014-12-27 11:48
utf8.t	13.46 KB	-r--r--r--	2014-12-27 11:48
whichsig.t	653 B	-r--r--r--	2014-12-27 11:48
xs_special_subs.t	6.54 KB	-r--r--r--	2014-12-27 11:48
xs_special_subs_require.t	7.46 KB	-r--r--r--	2014-12-27 11:48
xsub_h.t	2.81 KB	-r--r--r--	2014-12-27 11:48

Rename

#!perl -w

use strict;
use utf8;
use Tie::Hash;
use Test::More;

BEGIN {use_ok('XS::APItest')};

sub preform_test;
sub test_present;
sub test_absent;
sub test_delete_present;
sub test_delete_absent;
sub brute_force_exists;
sub test_store;
sub test_fetch_present;
sub test_fetch_absent;

my $utf8_for_258 = chr 258;
utf8::encode $utf8_for_258;

my @testkeys = ('N', chr 198, chr 256);
my @keys = (@testkeys, $utf8_for_258);

foreach (@keys) {
  utf8::downgrade $_, 1;
}
main_tests (\@keys, \@testkeys, '');

foreach (@keys) {
  utf8::upgrade $_;
}
main_tests (\@keys, \@testkeys, ' [utf8 hash]');

{
  my %h = (a=>'cheat');
  tie %h, 'Tie::StdHash';
  # is bug 36327 fixed?
  my $result = ($] > 5.009) ? undef : 1;

is (XS::APItest::Hash::store(\%h, chr 258,  1), $result);

ok (!exists $h{$utf8_for_258},
      "hv_store doesn't insert a key with the raw utf8 on a tied hash");
}

{
    my $strtab = strtab();
    is (ref $strtab, 'HASH', "The shared string table quacks like a hash");
    my $wibble = "\0";
    eval {
	$strtab->{$wibble}++;
    };
    my $prefix = "Cannot modify shared string table in hv_";
    my $what = $prefix . 'fetch';
    like ($@, qr/^$what/,$what);
    eval {
	XS::APItest::Hash::store($strtab, 'Boom!',  1)
    };
    $what = $prefix . 'store';
    like ($@, qr/^$what/, $what);
    if (0) {
	A::B->method();
    }
    # DESTROY should be in there.
    eval {
	delete $strtab->{DESTROY};
    };
    $what = $prefix . 'delete';
    like ($@, qr/^$what/, $what);
    # I can't work out how to get to the code that flips the wasutf8 flag on
    # the hash key without some ikcy XS
}

{
    is_deeply([&XS::APItest::Hash::test_hv_free_ent], [2,2,1,1],
	      "hv_free_ent frees the value immediately");
    is_deeply([&XS::APItest::Hash::test_hv_delayfree_ent], [2,2,2,1],
	      "hv_delayfree_ent keeps the value around until FREETMPS");
}

foreach my $in ("", "N", "a\0b") {
    my $got = XS::APItest::Hash::test_share_unshare_pvn($in);
    is ($got, $in, "test_share_unshare_pvn");
}

{
    foreach ([\&XS::APItest::Hash::rot13_hash, \&rot13, "rot 13"],
	     [\&XS::APItest::Hash::bitflip_hash, \&bitflip, "bitflip"],
	    ) {
	my ($setup, $mapping, $name) = @$_;
	my %hash;
	my %placebo = (a => 1, p => 2, i => 4, e => 8);
	$setup->(\%hash);
	$hash{a}++; @hash{qw(p i e)} = (2, 4, 8);

test_U_hash(\%hash, \%placebo, [f => 9, g => 10, h => 11], $mapping,
		    $name);
    }
    foreach my $upgrade_o (0, 1) {
	foreach my $upgrade_n (0, 1) {
	    my (%hash, %placebo);
	    XS::APItest::Hash::bitflip_hash(\%hash);
	    foreach my $new (["7", 65, 67, 80],
			     ["8", 163, 171, 215],
			     ["U", 2603, 2604, 2604],
			    ) {
		foreach my $code (78, 240, 256, 1336) {
		    my $key = chr $code;
		    # This is the UTF-8 byte sequence for the key.
		    my $key_utf8 = $key;
		    utf8::encode($key_utf8);
		    if ($upgrade_o) {
			$key .= chr 256;
			chop $key;
		    }
		    $hash{$key} = $placebo{$key} = $code;
		    $hash{$key_utf8} = $placebo{$key_utf8} = "$code as UTF-8";
		}
		my $name = 'bitflip ' . shift @$new;
		my @new_kv;
		foreach my $code (@$new) {
		    my $key = chr $code;
		    if ($upgrade_n) {
			$key .= chr 256;
			chop $key;
		    }
		    push @new_kv, $key, $_;
		}

$name .= ' upgraded(orig) ' if $upgrade_o;
		$name .= ' upgraded(new) ' if $upgrade_n;
		test_U_hash(\%hash, \%placebo, \@new_kv, \&bitflip, $name);
	    }
	}
    }
}

sub test_precomputed_hashes {
    my $what = shift;
    my $hash_it = shift;
    my $ord = shift;
    my $key_copy = $_[0];
    $key_copy .= '';

my %hash;
    is (XS::APItest::Hash::common({hv => \%hash,
				   "key$what" => $_[0],
				   val => $ord,
				   "hash_$what" => $hash_it,
				   action => XS::APItest::HV_FETCH_ISSTORE}),
	$ord, "store $ord with $what \$hash_it = $hash_it");
    is_deeply ([each %hash], [$_[0], $ord], "First key read is good");
    is_deeply ([each %hash], [], "No second key good");
    
    is ($hash{$_[0]}, $ord, "Direct hash read finds $ord");

is_deeply ([each %hash], [$key_copy, $ord],
	       "First key read is good with a copy");
    is_deeply ([each %hash], [], "No second key good");
    
    is ($hash{$key_copy}, $ord, "Direct hash read finds $ord");
}

{
    my $as_utf8 = "\241" . chr 256;
    chop $as_utf8;
    my $as_bytes = "\243";
    foreach my $key ('N', $as_bytes, $as_utf8, "\x{2623}") {
	my $ord = ord $key;
	foreach my $hash_it (0, 1) {
	    foreach my $what (qw(pv sv)) {
		test_precomputed_hashes($what, $hash_it, $ord, $key);
	    }
	    # Generate a shared hash key scalar
	    my %h = ($key => 1);
	    test_precomputed_hashes('sv', $hash_it, $ord, (keys %h)[0]);
	}
    }
}

{
    use Scalar::Util 'weaken';
    my %h;
    fill_hash_with_nulls(\%h);
    my @objs;
    for("a".."z","A".."Z") {
	weaken($objs[@objs] = $h{$_} = []);
    }
    undef %h;
    no warnings 'uninitialized';
    local $" = "";
    is "@objs", "",
      'explicitly undeffing a hash with nulls frees all entries';

my $h = {};
    fill_hash_with_nulls($h);
    @objs = ();
    for("a".."z","A".."Z") {
	weaken($objs[@objs] = $$h{$_} = []);
    }
    undef $h;
    is "@objs", "", 'freeing a hash with nulls frees all entries';
}

# Tests for HvENAME and UTF8
{
    no strict;
    no warnings 'void';
    my $hvref;

*{"\xff::bar"}; # autovivify %ÿ:: without UTF8
    *{"\xff::bαr::"} = $hvref = \%foo::;
    undef *foo::;
    is HvENAME($hvref), "\xff::bαr",
	'stash alias (utf8 inside bytes) does not create malformed UTF8';

*{"é::foo"}; # autovivify %é:: with UTF8
    *{"\xe9::\xe9::"} = $hvref = \%bar::;
    undef *bar::;
    is HvENAME($hvref), "\xe9::\xe9",
	'stash alias (bytes inside utf8) does not create malformed UTF8';

*{"\xfe::bar"}; *{"\xfd::bar"};
    *{"\xfe::bαr::"} = \%goo::;
    *{"\xfd::bαr::"} = $hvref = \%goo::;
    undef *goo::;
    like HvENAME($hvref), qr/^[\xfe\xfd]::bαr\z/,
	'multiple stash aliases (utf8 inside bytes) do not cause bad UTF8';

*{"è::foo"}; *{"ë::foo"};
    *{"\xe8::\xe9::"} = $hvref = \%bear::;
    *{"\xeb::\xe9::"} = \%bear::;
    undef *bear::;
    like HvENAME($hvref), qr"^[\xe8\xeb]::\xe9\z",
	'multiple stash aliases (bytes inside utf8) do not cause bad UTF8';
}

{ # newHVhv
    use Tie::Hash;
    tie my %h, 'Tie::StdHash';
    %h = 1..10;
    is join(' ', sort %{newHVhv \%h}), '1 10 2 3 4 5 6 7 8 9',
      'newHVhv on tied hash';
}

# helem and hslice on entry with null value
# This is actually a test for a Perl operator, not an XS API test.  But it
# requires a hash that can only be produced by XS (although recently it
# could be encountered when tying hint hashes).
{
    my %h;
    fill_hash_with_nulls(\%h);
    eval{ $h{84} = 1 };
    pass 'no crash when writing to hash elem with null value';
    eval{ no # silly
	  warnings; # thank you!
	  @h{85} = 1 };
    pass 'no crash when writing to hash elem with null value via slice';
    eval { delete local $h{86} };
    pass 'no crash during local deletion of hash elem with null value';
    eval { delete local @h{87,88} };
    pass 'no crash during local deletion of hash slice with null values';
}

# [perl #111000] Bug number eleventy-one thousand:
#                hv_store should work on hint hashes
eval q{
    BEGIN {
	XS::APItest::Hash::store \%^H, "XS::APItest/hash.t", undef;
	delete $^H{"XS::APItest/hash.t"};
    }
};
pass("hv_store works on the hint hash");

{
    # [perl #79074] HeSVKEY_force loses UTF8ness
    my %hash = ( "\xff" => 1, "\x{100}" => 1 );
    my @keys = sort ( XS::APItest::Hash::test_force_keys(\%hash) );
    is_deeply(\@keys, [ sort keys %hash ], "check HeSVKEY_force()");
}

done_testing;
exit;

################################   The End   ################################

sub test_U_hash {
    my ($hash, $placebo, $new, $mapping, $message) = @_;
    my @hitlist = keys %$placebo;
    print "# $message\n";

my @keys = sort keys %$hash;
    is ("@keys", join(' ', sort($mapping->(keys %$placebo))),
	"uvar magic called exactly once on store");

is (keys %$hash, keys %$placebo);

my $victim = shift @hitlist;
    is (delete $hash->{$victim}, delete $placebo->{$victim});

is (keys %$hash, keys %$placebo);
    @keys = sort keys %$hash;
    is ("@keys", join(' ', sort($mapping->(keys %$placebo))));

$victim = shift @hitlist;
    is (XS::APItest::Hash::delete_ent ($hash, $victim,
				       XS::APItest::HV_DISABLE_UVAR_XKEY),
	undef, "Deleting a known key with conversion disabled fails (ent)");
    is (keys %$hash, keys %$placebo);

is (XS::APItest::Hash::delete_ent ($hash, $victim, 0),
	delete $placebo->{$victim},
	"Deleting a known key with conversion enabled works (ent)");
    is (keys %$hash, keys %$placebo);
    @keys = sort keys %$hash;
    is ("@keys", join(' ', sort($mapping->(keys %$placebo))));

$victim = shift @hitlist;
    is (XS::APItest::Hash::delete ($hash, $victim,
				   XS::APItest::HV_DISABLE_UVAR_XKEY),
	undef, "Deleting a known key with conversion disabled fails");
    is (keys %$hash, keys %$placebo);

is (XS::APItest::Hash::delete ($hash, $victim, 0),
	delete $placebo->{$victim},
	"Deleting a known key with conversion enabled works");
    is (keys %$hash, keys %$placebo);
    @keys = sort keys %$hash;
    is ("@keys", join(' ', sort($mapping->(keys %$placebo))));

my ($k, $v) = splice @$new, 0, 2;
    $hash->{$k} = $v;
    $placebo->{$k} = $v;
    is (keys %$hash, keys %$placebo);
    @keys = sort keys %$hash;
    is ("@keys", join(' ', sort($mapping->(keys %$placebo))));

($k, $v) = splice @$new, 0, 2;
    is (XS::APItest::Hash::store_ent($hash, $k, $v), $v, "store_ent");
    $placebo->{$k} = $v;
    is (keys %$hash, keys %$placebo);
    @keys = sort keys %$hash;
    is ("@keys", join(' ', sort($mapping->(keys %$placebo))));

($k, $v) = splice @$new, 0, 2;
    is (XS::APItest::Hash::store($hash, $k, $v), $v, "store");
    $placebo->{$k} = $v;
    is (keys %$hash, keys %$placebo);
    @keys = sort keys %$hash;
    is ("@keys", join(' ', sort($mapping->(keys %$placebo))));

@hitlist = keys %$placebo;
    $victim = shift @hitlist;
    is (XS::APItest::Hash::fetch_ent($hash, $victim), $placebo->{$victim},
	"fetch_ent");
    is (XS::APItest::Hash::fetch_ent($hash, $mapping->($victim)), undef,
	"fetch_ent (missing)");

$victim = shift @hitlist;
    is (XS::APItest::Hash::fetch($hash, $victim), $placebo->{$victim},
	"fetch");
    is (XS::APItest::Hash::fetch($hash, $mapping->($victim)), undef,
	"fetch (missing)");

$victim = shift @hitlist;
    ok (XS::APItest::Hash::exists_ent($hash, $victim), "exists_ent");
    ok (!XS::APItest::Hash::exists_ent($hash, $mapping->($victim)),
	"exists_ent (missing)");

$victim = shift @hitlist;
    die "Need a victim" unless defined $victim;
    ok (XS::APItest::Hash::exists($hash, $victim), "exists");
    ok (!XS::APItest::Hash::exists($hash, $mapping->($victim)),
	"exists (missing)");

is (XS::APItest::Hash::common({hv => $hash, keysv => $victim}),
	$placebo->{$victim}, "common (fetch)");
    is (XS::APItest::Hash::common({hv => $hash, keypv => $victim}),
	$placebo->{$victim}, "common (fetch pv)");
    is (XS::APItest::Hash::common({hv => $hash, keysv => $victim,
				   action => XS::APItest::HV_DISABLE_UVAR_XKEY}),
	undef, "common (fetch) missing");
    is (XS::APItest::Hash::common({hv => $hash, keypv => $victim,
				   action => XS::APItest::HV_DISABLE_UVAR_XKEY}),
	undef, "common (fetch pv) missing");
    is (XS::APItest::Hash::common({hv => $hash, keysv => $mapping->($victim),
				   action => XS::APItest::HV_DISABLE_UVAR_XKEY}),
	$placebo->{$victim}, "common (fetch) missing mapped");
    is (XS::APItest::Hash::common({hv => $hash, keypv => $mapping->($victim),
				   action => XS::APItest::HV_DISABLE_UVAR_XKEY}),
	$placebo->{$victim}, "common (fetch pv) missing mapped");
}

sub main_tests {
  my ($keys, $testkeys, $description) = @_;
  foreach my $key (@$testkeys) {
    my $lckey = ($key eq chr 198) ? chr 230 : lc $key;
    my $unikey = $key;
    utf8::encode $unikey;

utf8::downgrade $key, 1;
    utf8::downgrade $lckey, 1;
    utf8::downgrade $unikey, 1;
    main_test_inner ($key, $lckey, $unikey, $keys, $description);

utf8::upgrade $key;
    utf8::upgrade $lckey;
    utf8::upgrade $unikey;
    main_test_inner ($key, $lckey, $unikey, $keys,
		     $description . ' [key utf8 on]');
  }

# hv_exists was buggy for tied hashes, in that the raw utf8 key was being
  # used - the utf8 flag was being lost.
  perform_test (\&test_absent, (chr 258), $keys, '');

perform_test (\&test_fetch_absent, (chr 258), $keys, '');
  perform_test (\&test_delete_absent, (chr 258), $keys, '');
}

sub main_test_inner {
  my ($key, $lckey, $unikey, $keys, $description) = @_;
  perform_test (\&test_present, $key, $keys, $description);
  perform_test (\&test_fetch_present, $key, $keys, $description);
  perform_test (\&test_delete_present, $key, $keys, $description);

perform_test (\&test_store, $key, $keys, $description, [a=>'cheat']);
  perform_test (\&test_store, $key, $keys, $description, []);

perform_test (\&test_absent, $lckey, $keys, $description);
  perform_test (\&test_fetch_absent, $lckey, $keys, $description);
  perform_test (\&test_delete_absent, $lckey, $keys, $description);

return if $unikey eq $key;

perform_test (\&test_absent, $unikey, $keys, $description);
  perform_test (\&test_fetch_absent, $unikey, $keys, $description);
  perform_test (\&test_delete_absent, $unikey, $keys, $description);
}

sub perform_test {
  my ($test_sub, $key, $keys, $message, @other) = @_;
  my $printable = join ',', map {ord} split //, $key;

my (%hash, %tiehash);
  tie %tiehash, 'Tie::StdHash';

@hash{@$keys} = @$keys;
  @tiehash{@$keys} = @$keys;

&$test_sub (\%hash, $key, $printable, $message, @other);
  &$test_sub (\%tiehash, $key, $printable, "$message tie", @other);
}

sub test_present {
  my ($hash, $key, $printable, $message) = @_;

ok (exists $hash->{$key}, "hv_exists_ent present$message $printable");
  ok (XS::APItest::Hash::exists ($hash, $key),
      "hv_exists present$message $printable");
}

sub test_absent {
  my ($hash, $key, $printable, $message) = @_;

ok (!exists $hash->{$key}, "hv_exists_ent absent$message $printable");
  ok (!XS::APItest::Hash::exists ($hash, $key),
      "hv_exists absent$message $printable");
}

sub test_delete_present {
  my ($hash, $key, $printable, $message) = @_;

my $copy = {};
  my $class = tied %$hash;
  if (defined $class) {
    tie %$copy, ref $class;
  }
  $copy = {%$hash};
  ok (brute_force_exists ($copy, $key),
      "hv_delete_ent present$message $printable");
  is (delete $copy->{$key}, $key, "hv_delete_ent present$message $printable");
  ok (!brute_force_exists ($copy, $key),
      "hv_delete_ent present$message $printable");
  $copy = {%$hash};
  ok (brute_force_exists ($copy, $key),
      "hv_delete present$message $printable");
  is (XS::APItest::Hash::delete ($copy, $key), $key,
      "hv_delete present$message $printable");
  ok (!brute_force_exists ($copy, $key),
      "hv_delete present$message $printable");
}

sub test_delete_absent {
  my ($hash, $key, $printable, $message) = @_;

my $copy = {};
  my $class = tied %$hash;
  if (defined $class) {
    tie %$copy, ref $class;
  }
  $copy = {%$hash};
  is (delete $copy->{$key}, undef, "hv_delete_ent absent$message $printable");
  $copy = {%$hash};
  is (XS::APItest::Hash::delete ($copy, $key), undef,
      "hv_delete absent$message $printable");
}

sub test_store {
  my ($hash, $key, $printable, $message, $defaults) = @_;
  my $HV_STORE_IS_CRAZY = 1;

# We are cheating - hv_store returns NULL for a store into an empty
  # tied hash. This isn't helpful here.

my $class = tied %$hash;

# It's important to do this with nice new hashes created each time round
  # the loop, rather than hashes in the pad, which get recycled, and may have
  # xhv_array non-NULL
  my $h1 = {@$defaults};
  my $h2 = {@$defaults};
  if (defined $class) {
    tie %$h1, ref $class;
    tie %$h2, ref $class;
    if ($] > 5.009) {
      # bug 36327 is fixed
      $HV_STORE_IS_CRAZY = undef;
    } else {
      # HV store_ent returns 1 if there was already underlying hash storage
      $HV_STORE_IS_CRAZY = undef unless @$defaults;
    }
  }
  is (XS::APItest::Hash::store_ent($h1, $key, 1), $HV_STORE_IS_CRAZY,
      "hv_store_ent$message $printable");
  ok (brute_force_exists ($h1, $key), "hv_store_ent$message $printable");
  is (XS::APItest::Hash::store($h2, $key,  1), $HV_STORE_IS_CRAZY,
      "hv_store$message $printable");
  ok (brute_force_exists ($h2, $key), "hv_store$message $printable");
}

sub test_fetch_present {
  my ($hash, $key, $printable, $message) = @_;

is ($hash->{$key}, $key, "hv_fetch_ent present$message $printable");
  is (XS::APItest::Hash::fetch ($hash, $key), $key,
      "hv_fetch present$message $printable");
}

sub test_fetch_absent {
  my ($hash, $key, $printable, $message) = @_;

is ($hash->{$key}, undef, "hv_fetch_ent absent$message $printable");
  is (XS::APItest::Hash::fetch ($hash, $key), undef,
      "hv_fetch absent$message $printable");
}

sub brute_force_exists {
  my ($hash, $key) = @_;
  foreach (keys %$hash) {
    return 1 if $key eq $_;
  }
  return 0;
}

sub rot13 {
    my @results = map {my $a = $_; $a =~ tr/A-Za-z/N-ZA-Mn-za-m/; $a} @_;
    wantarray ? @results : $results[0];
}

sub bitflip {
    my @results = map {join '', map {chr(32 ^ ord $_)} split '', $_} @_;
    wantarray ? @results : $results[0];
}