[p5sagit/p5-mst-13.2.git] / ext / XS-APItest / t / hash.t

#!perl -w

BEGIN {
  push @INC, "::lib:$MacPerl::Architecture:" if $^O eq 'MacOS';
  require Config; import Config;
  if ($Config{'extensions'} !~ /\bXS\/APItest\b/) {
    # Look, I'm using this fully-qualified variable more than once!
    my $arch = $MacPerl::Architecture;
    print "1..0 # Skip: XS::APItest was not built\n";
    exit 0;
  }
}

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

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");
}

if ($] > 5.009) {
    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");
}

if ($] > 5.009) {
    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]);
	}
    }
}

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];
}
Commit	Line	Data
0314122a	1	#!perl -w
	2
	3	BEGIN {
0314122a	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
3128e575	14	use strict;
3128e575	15	use utf8;
0314122a	16	use Tie::Hash;
3128e575	17	use Test::More 'no_plan';
3128e575	18
55289a74	19	BEGIN {use_ok('XS::APItest')};
0314122a	20
3128e575	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;
0314122a	30
b60cf05a	31	my $utf8_for_258 = chr 258;
b60cf05a	32	utf8::encode $utf8_for_258;
0314122a	33
3128e575	34	my @testkeys = ('N', chr 198, chr 256);
b60cf05a	35	my @keys = (@testkeys, $utf8_for_258);
0314122a	36
3128e575	37	foreach (@keys) {
	38	utf8::downgrade $_, 1;
	39	}
	40	main_tests (\@keys, \@testkeys, '');
0314122a	41
3128e575	42	foreach (@keys) {
	43	utf8::upgrade $_;
	44	}
	45	main_tests (\@keys, \@testkeys, ' [utf8 hash]');
0314122a	46
3128e575	47	{
	48	my %h = (a=>'cheat');
	49	tie %h, 'Tie::StdHash';
9568a123	50	# is bug 36327 fixed?
	51	my $result = ($] > 5.009) ? undef : 1;
	52
	53	is (XS::APItest::Hash::store(\%h, chr 258, 1), $result);
3128e575	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	}
0314122a	58
9568a123	59	if ($] > 5.009) {
5d2b1485	60	my $strtab = strtab();
5d2b1485	61	is (ref $strtab, 'HASH', "The shared string table quacks like a hash");
8ca60cef	62	my $wibble = "\0";
5d2b1485	63	eval {
8ca60cef	64	$strtab->{$wibble}++;
5d2b1485	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	}
2dc92170	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	}
35ab5632	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
55289a74	99	if ($] > 5.009) {
53c40a8f	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	}
850f5f16	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	}
53c40a8f	149	}
53c40a8f	150
90acdc2a	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
527df579	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;
58ca560a	183	foreach my $hash_it (0, 1) {
58ca560a	184	foreach my $what (qw(pv sv)) {
90acdc2a	185	test_precomputed_hashes($what, $hash_it, $ord, $key);
58ca560a	186	}
90acdc2a	187	# Generate a shared hash key scalar
	188	my %h = ($key => 1);
	189	test_precomputed_hashes('sv', $hash_it, $ord, (keys %h)[0]);
527df579	190	}
	191	}
	192	}
	193
53c40a8f	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";
b54b4831	202
53c40a8f	203	my @keys = sort keys %$hash;
	204	is ("@keys", join(' ', sort($mapping->(keys %$placebo))),
	205	"uvar magic called exactly once on store");
b54b4831	206
850f5f16	207	is (keys %$hash, keys %$placebo);
55289a74	208
53c40a8f	209	my $victim = shift @hitlist;
53c40a8f	210	is (delete $hash->{$victim}, delete $placebo->{$victim});
55289a74	211
850f5f16	212	is (keys %$hash, keys %$placebo);
53c40a8f	213	@keys = sort keys %$hash;
53c40a8f	214	is ("@keys", join(' ', sort($mapping->(keys %$placebo))));
55289a74	215
53c40a8f	216	$victim = shift @hitlist;
53c40a8f	217	is (XS::APItest::Hash::delete_ent ($hash, $victim,
55289a74	218	XS::APItest::HV_DISABLE_UVAR_XKEY),
55289a74	219	undef, "Deleting a known key with conversion disabled fails (ent)");
850f5f16	220	is (keys %$hash, keys %$placebo);
55289a74	221
53c40a8f	222	is (XS::APItest::Hash::delete_ent ($hash, $victim, 0),
	223	delete $placebo->{$victim},
	224	"Deleting a known key with conversion enabled works (ent)");
850f5f16	225	is (keys %$hash, keys %$placebo);
53c40a8f	226	@keys = sort keys %$hash;
53c40a8f	227	is ("@keys", join(' ', sort($mapping->(keys %$placebo))));
55289a74	228
53c40a8f	229	$victim = shift @hitlist;
53c40a8f	230	is (XS::APItest::Hash::delete ($hash, $victim,
55289a74	231	XS::APItest::HV_DISABLE_UVAR_XKEY),
55289a74	232	undef, "Deleting a known key with conversion disabled fails");
850f5f16	233	is (keys %$hash, keys %$placebo);
53c40a8f	234
	235	is (XS::APItest::Hash::delete ($hash, $victim, 0),
	236	delete $placebo->{$victim},
	237	"Deleting a known key with conversion enabled works");
850f5f16	238	is (keys %$hash, keys %$placebo);
53c40a8f	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;
850f5f16	245	is (keys %$hash, keys %$placebo);
53c40a8f	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;
850f5f16	252	is (keys %$hash, keys %$placebo);
53c40a8f	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");
53c40a8f	258	$placebo->{$k} = $v;
850f5f16	259	is (keys %$hash, keys %$placebo);
53c40a8f	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,
bdee33e4	268	"fetch_ent (missing)");
bdee33e4	269
53c40a8f	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,
bdee33e4	274	"fetch (missing)");
bdee33e4	275
53c40a8f	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)),
bdee33e4	279	"exists_ent (missing)");
bdee33e4	280
53c40a8f	281	$victim = shift @hitlist;
6b4de907	282	die "Need a victim" unless defined $victim;
53c40a8f	283	ok (XS::APItest::Hash::exists($hash, $victim), "exists");
	284	ok (!XS::APItest::Hash::exists($hash, $mapping->($victim)),
	285	"exists (missing)");
6b4de907	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");
b54b4831	303	}
b54b4831	304
3128e575	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;
0314122a	311
3128e575	312	utf8::downgrade $key, 1;
	313	utf8::downgrade $lckey, 1;
	314	utf8::downgrade $unikey, 1;
	315	main_test_inner ($key, $lckey, $unikey, $keys, $description);
0314122a	316
3128e575	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	}
0314122a	323
3128e575	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, '');
0314122a	327
3128e575	328	perform_test (\&test_fetch_absent, (chr 258), $keys, '');
3128e575	329	perform_test (\&test_delete_absent, (chr 258), $keys, '');
0314122a	330	}
0314122a	331
3128e575	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);
b60cf05a	337
3128e575	338	perform_test (\&test_store, $key, $keys, $description, [a=>'cheat']);
3128e575	339	perform_test (\&test_store, $key, $keys, $description, []);
b60cf05a	340
3128e575	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);
b60cf05a	344
3128e575	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);
b60cf05a	350	}
b60cf05a	351
3128e575	352	sub perform_test {
3128e575	353	my ($test_sub, $key, $keys, $message, @other) = @_;
b60cf05a	354	my $printable = join ',', map {ord} split //, $key;
b60cf05a	355
3128e575	356	my (%hash, %tiehash);
3128e575	357	tie %tiehash, 'Tie::StdHash';
b60cf05a	358
3128e575	359	@hash{@$keys} = @$keys;
3128e575	360	@tiehash{@$keys} = @$keys;
b60cf05a	361
3128e575	362	&$test_sub (\%hash, $key, $printable, $message, @other);
3128e575	363	&$test_sub (\%tiehash, $key, $printable, "$message tie", @other);
b60cf05a	364	}
b60cf05a	365
3128e575	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");
b60cf05a	372	}
b60cf05a	373
3128e575	374	sub test_absent {
3128e575	375	my ($hash, $key, $printable, $message) = @_;
858117f8	376
3128e575	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");
b60cf05a	380	}
b60cf05a	381
3128e575	382	sub test_delete_present {
3128e575	383	my ($hash, $key, $printable, $message) = @_;
b60cf05a	384
3128e575	385	my $copy = {};
	386	my $class = tied %$hash;
	387	if (defined $class) {
	388	tie %$copy, ref $class;
	389	}
	390	$copy = {%$hash};
8829b5e2	391	ok (brute_force_exists ($copy, $key),
8829b5e2	392	"hv_delete_ent present$message $printable");
3128e575	393	is (delete $copy->{$key}, $key, "hv_delete_ent present$message $printable");
8829b5e2	394	ok (!brute_force_exists ($copy, $key),
8829b5e2	395	"hv_delete_ent present$message $printable");
3128e575	396	$copy = {%$hash};
8829b5e2	397	ok (brute_force_exists ($copy, $key),
8829b5e2	398	"hv_delete present$message $printable");
3128e575	399	is (XS::APItest::Hash::delete ($copy, $key), $key,
3128e575	400	"hv_delete present$message $printable");
8829b5e2	401	ok (!brute_force_exists ($copy, $key),
8829b5e2	402	"hv_delete present$message $printable");
b60cf05a	403	}
b60cf05a	404
3128e575	405	sub test_delete_absent {
3128e575	406	my ($hash, $key, $printable, $message) = @_;
b60cf05a	407
3128e575	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");
b60cf05a	418	}
b60cf05a	419
3128e575	420	sub test_store {
	421	my ($hash, $key, $printable, $message, $defaults) = @_;
	422	my $HV_STORE_IS_CRAZY = 1;
b60cf05a	423
3128e575	424	# We are cheating - hv_store returns NULL for a store into an empty
3128e575	425	# tied hash. This isn't helpful here.
0314122a	426
3128e575	427	my $class = tied %$hash;
0314122a	428
9568a123	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};
3128e575	434	if (defined $class) {
9568a123	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	}
3128e575	444	}
9568a123	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,
3128e575	449	"hv_store$message $printable");
9568a123	450	ok (brute_force_exists ($h2, $key), "hv_store$message $printable");
3128e575	451	}
0314122a	452
3128e575	453	sub test_fetch_present {
3128e575	454	my ($hash, $key, $printable, $message) = @_;
b60cf05a	455
3128e575	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");
0314122a	459	}
0314122a	460
3128e575	461	sub test_fetch_absent {
3128e575	462	my ($hash, $key, $printable, $message) = @_;
b60cf05a	463
3128e575	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	}
b60cf05a	468
3128e575	469	sub brute_force_exists {
	470	my ($hash, $key) = @_;
	471	foreach (keys %$hash) {
	472	return 1 if $key eq $_;
	473	}
	474	return 0;
b60cf05a	475	}
b54b4831	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	}
53c40a8f	481
	482	sub bitflip {
	483	my @results = map {join '', map {chr(32 ^ ord $_)} split '', $_} @_;
	484	wantarray ? @results : $results[0];
	485	}