Integrate:

[ 21762]
Refactor hash API tests (prior to some additions)

[ 21763]
Test all permuations of utf8 flags on hashes and keys
p4raw-link: @21763 on //depot/maint-5.8/perl: b523355a616afbca2ac499d0cedc220495b1a655
p4raw-link: @21762 on //depot/maint-5.8/perl: 96d477294435bb735f0ee986438f4e7d6ddbee31

p4raw-id: //depot/perl@21764
p4raw-integrated: from //depot/maint-5.8/perl@21760 'copy in'
	ext/XS/APItest/t/hash.t (@21761..)

diff --git a/ext/XS/APItest/t/hash.t b/ext/XS/APItest/t/hash.t
index c4fa712..2d3f19d 100644 (file)
--- a/ext/XS/APItest/t/hash.t
+++ b/ext/XS/APItest/t/hash.t
@@ -13,182 +13,203 @@ BEGIN {
   }
 }
 
+use strict;
+use utf8;
 use Tie::Hash;
+use Test::More 'no_plan';
+
+use_ok('XS::APItest');
 
-my @testkeys = ('N', chr 256);
+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);
-my (%hash, %tiehash);
-tie %tiehash, 'Tie::StdHash';
 
-@hash{@keys} = @keys;
-@tiehash{@keys} = @keys;
+foreach (@keys) {
+  utf8::downgrade $_, 1;
+}
+main_tests (\@keys, \@testkeys, '');
 
+foreach (@keys) {
+  utf8::upgrade $_;
+}
+main_tests (\@keys, \@testkeys, ' [utf8 hash]');
 
-use Test::More 'no_plan';
+{
+  my %h = (a=>'cheat');
+  tie %h, 'Tie::StdHash';
+  is (XS::APItest::Hash::store(\%h, chr 258,  1), 1);
+    
+  ok (!exists $h{$utf8_for_258},
+      "hv_store doesn't insert a key with the raw utf8 on a tied hash");
+}
 
-use_ok('XS::APItest');
+exit;
 
-sub test_present {
-  my $key = shift;
-  my $printable = join ',', map {ord} split //, $key;
+################################   The End   ################################
 
-  ok (exists $hash{$key}, "hv_exists_ent present $printable");
-  ok (XS::APItest::Hash::exists (\%hash, $key), "hv_exists present $printable");
+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;
 
-  ok (exists $tiehash{$key}, "hv_exists_ent tie present  $printable");
-  ok (XS::APItest::Hash::exists (\%tiehash, $key),
-      "hv_exists tie present $printable");
-}
+    utf8::downgrade $key, 1;
+    utf8::downgrade $lckey, 1;
+    utf8::downgrade $unikey, 1;
+    main_test_inner ($key, $lckey, $unikey, $keys, $description);
 
-sub test_absent {
-  my $key = shift;
-  my $printable = join ',', map {ord} split //, $key;
+    utf8::upgrade $key;
+    utf8::upgrade $lckey;
+    utf8::upgrade $unikey;
+    main_test_inner ($key, $lckey, $unikey, $keys,
+                    $description . ' [key utf8 on]');
+  }
 
-  ok (!exists $hash{$key}, "hv_exists_ent absent $printable");
-  ok (!XS::APItest::Hash::exists (\%hash, $key), "hv_exists absent $printable");
+  # 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, '');
 
-  ok (!exists $tiehash{$key}, "hv_exists_ent tie absent  $printable");
-  ok (!XS::APItest::Hash::exists (\%tiehash, $key),
-      "hv_exists tie absent $printable");
+  perform_test (\&test_fetch_absent, (chr 258), $keys, '');
+  perform_test (\&test_delete_absent, (chr 258), $keys, '');
 }
 
-sub test_delete_present {
-  my $key = shift;
-  my $printable = join ',', map {ord} split //, $key;
+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);
 
-  my $copy = {%hash};
-  is (delete $copy->{$key}, $key, "hv_delete_ent present $printable");
-  $copy = {%hash};
-  is (XS::APItest::Hash::delete ($copy, $key), $key,
-      "hv_delete present $printable");
+  perform_test (\&test_store, $key, $keys, $description, [a=>'cheat']);
+  perform_test (\&test_store, $key, $keys, $description, []);
 
-  $copy = {};
-  tie %$copy, 'Tie::StdHash';
-  %$copy = %tiehash;
-  is (delete $copy->{$key}, $key, "hv_delete_ent tie present $printable");
+  perform_test (\&test_absent, $lckey, $keys, $description);
+  perform_test (\&test_fetch_absent, $lckey, $keys, $description);
+  perform_test (\&test_delete_absent, $lckey, $keys, $description);
 
-  %$copy = %tiehash;
-  is (XS::APItest::Hash::delete ($copy, $key), $key,
-      "hv_delete tie present $printable");
+  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 test_delete_absent {
-  my $key = shift;
+sub perform_test {
+  my ($test_sub, $key, $keys, $message, @other) = @_;
   my $printable = join ',', map {ord} split //, $key;
 
-  my $copy = {%hash};
-  is (delete $copy->{$key}, undef, "hv_delete_ent absent $printable");
-  $copy = {%hash};
-  is (XS::APItest::Hash::delete ($copy, $key), undef,
-      "hv_delete absent $printable");
+  my (%hash, %tiehash);
+  tie %tiehash, 'Tie::StdHash';
 
-  $copy = {};
-  tie %$copy, 'Tie::StdHash';
-  %$copy = %tiehash;
-  is (delete $copy->{$key}, undef, "hv_delete_ent tie absent $printable");
+  @hash{@$keys} = @$keys;
+  @tiehash{@$keys} = @$keys;
 
-  %$copy = %tiehash;
-  is (XS::APItest::Hash::delete ($copy, $key), undef,
-      "hv_delete tie absent $printable");
+  &$test_sub (\%hash, $key, $printable, $message, @other);
+  &$test_sub (\%tiehash, $key, $printable, "$message tie", @other);
 }
 
-sub brute_force_exists {
-  my ($hash, $key) = @_;
-  foreach (keys %$hash) {
-    return 1 if $key eq $_;
-  }
-  return 0;
+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_store {
-  my $key = shift;
-  my $defaults = shift;
-  my $HV_STORE_IS_CRAZY = @$defaults ? 1 : undef;
-  my $name = join ',', map {ord} split //, $key;
-  $name .= ' (hash starts empty)' unless @$defaults;
+sub test_absent {
+  my ($hash, $key, $printable, $message) = @_;
 
-  my %h1 = @$defaults;
-  is (XS::APItest::Hash::store_ent (\%h1, $key, 1), 1, "hv_store_ent $name"); 
-  ok (brute_force_exists (\%h1, $key), "hv_store_ent $name");
-  my %h2 = @$defaults;
-  is (XS::APItest::Hash::store(\%h2, $key,  1), 1, "hv_store $name");
-  ok (brute_force_exists (\%h2, $key), "hv_store $name");
-  my %h3 = @$defaults;
-  tie %h3, 'Tie::StdHash';
-  is (XS::APItest::Hash::store_ent (\%h3, $key, 1), 1,
-      "hv_store_ent tie $name");
-  ok (brute_force_exists (\%h3, $key), "hv_store_ent tie $name");
-  my %h4 = @$defaults;
-  tie %h4, 'Tie::StdHash';
-  is (XS::APItest::Hash::store(\%h4, $key, 1), $HV_STORE_IS_CRAZY,
-      "hv_store tie $name");
-  ok (brute_force_exists (\%h4, $key), "hv_store tie $name");
+  ok (!exists $hash->{$key}, "hv_exists_ent absent$message $printable");
+  ok (!XS::APItest::Hash::exists ($hash, $key),
+      "hv_exists absent$message $printable");
 }
 
-sub test_fetch_present {
-  my $key = shift;
-  my $printable = join ',', map {ord} split //, $key;
-
-  is ($hash{$key}, $key, "hv_fetch_ent present $printable");
-  is (XS::APItest::Hash::fetch (\%hash, $key), $key,
-      "hv_fetch present $printable");
+sub test_delete_present {
+  my ($hash, $key, $printable, $message) = @_;
 
-  is ($tiehash{$key}, $key, "hv_fetch_ent tie  present $printable");
-  is (XS::APItest::Hash::fetch (\%tiehash, $key), $key,
-      "hv_fetch tie present $printable");
+  my $copy = {};
+  my $class = tied %$hash;
+  if (defined $class) {
+    tie %$copy, ref $class;
+  }
+  $copy = {%$hash};
+  is (delete $copy->{$key}, $key, "hv_delete_ent present$message $printable");
+  $copy = {%$hash};
+  is (XS::APItest::Hash::delete ($copy, $key), $key,
+      "hv_delete present$message $printable");
 }
 
-sub test_fetch_absent {
-  my $key = shift;
-  my $printable = join ',', map {ord} split //, $key;
-
-  is ($hash{$key}, undef, "hv_fetch_ent absent $printable");
-  is (XS::APItest::Hash::fetch (\%hash, $key), undef,
-      "hv_fetch absent $printable");
+sub test_delete_absent {
+  my ($hash, $key, $printable, $message) = @_;
 
-  is ($tiehash{$key}, undef, "hv_fetch_ent tie  absent $printable");
-  is (XS::APItest::Hash::fetch (\%tiehash, $key), undef,
-      "hv_fetch tie absent $printable");
+  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");
 }
 
-foreach my $key (@testkeys) {
-  test_present ($key);
-  test_fetch_present ($key);
-  test_delete_present ($key);
+sub test_store {
+  my ($hash, $key, $printable, $message, $defaults) = @_;
+  my $HV_STORE_IS_CRAZY = 1;
 
-  test_store ($key, [a=>'cheat']);
-  test_store ($key, []);
+  # We are cheating - hv_store returns NULL for a store into an empty
+  # tied hash. This isn't helpful here.
 
-  my $lckey = lc $key;
-  test_absent ($lckey);
-  test_fetch_absent ($lckey);
-  test_delete_absent ($lckey);
+  my $class = tied %$hash;
 
-  my $unikey = $key;
-  utf8::encode $unikey;
+  my %h1 = @$defaults;
+  my %h2 = @$defaults;
+  if (defined $class) {
+    tie %h1, ref $class;
+    tie %h2, ref $class;
+    $HV_STORE_IS_CRAZY = undef unless @$defaults;
+  }
+  is (XS::APItest::Hash::store_ent(\%h1, $key, 1), 1,
+      "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");
+}
 
-  next if $unikey eq $key;
+sub test_fetch_present {
+  my ($hash, $key, $printable, $message) = @_;
 
-  test_absent ($unikey);
-  test_fetch_absent ($unikey);
-  test_delete_absent ($unikey);
+  is ($hash->{$key}, $key, "hv_fetch_ent present$message $printable");
+  is (XS::APItest::Hash::fetch ($hash, $key), $key,
+      "hv_fetch present$message $printable");
 }
 
-# hv_exists was buggy for tied hashes, in that the raw utf8 key was being
-# used - the utf8 flag was being lost.
-test_absent (chr 258);
-test_fetch_absent (chr 258);
-test_delete_absent (chr 258);
+sub test_fetch_absent {
+  my ($hash, $key, $printable, $message) = @_;
 
-{
-  my %h = (a=>'cheat');
-  tie %h, 'Tie::StdHash';
-  is (XS::APItest::Hash::store(\%h, chr 258,  1), 1);
+  is ($hash->{$key}, undef, "hv_fetch_ent absent$message $printable");
+  is (XS::APItest::Hash::fetch ($hash, $key), undef,
+      "hv_fetch absent$message $printable");
+}
 
-  ok (!exists $h{$utf8_for_258},
-      "hv_store doesn't insert a key with the raw utf8 on a tied hash");
+sub brute_force_exists {
+  my ($hash, $key) = @_;
+  foreach (keys %$hash) {
+    return 1 if $key eq $_;
+  }
+  return 0;
 }