Parameterise the code that tests the rot13 hash, and add a second

hashtype to test - bitflip (that xors code point with 32).

p4raw-id: //depot/perl@31914

diff --git a/ext/XS/APItest/APItest.xs b/ext/XS/APItest/APItest.xs
index 5bb0d9d..334c376 100644 (file)
--- a/ext/XS/APItest/APItest.xs
+++ b/ext/XS/APItest/APItest.xs
@@ -112,6 +112,41 @@ test_freeent(freeent_function *f) {
 
 
 static I32
+bitflip_key(pTHX_ IV action, SV *field) {
+    MAGIC *mg = mg_find(field, PERL_MAGIC_uvar);
+    SV *keysv;
+    if (mg && (keysv = mg->mg_obj)) {
+       STRLEN len;
+       const char *p = SvPV(keysv, len);
+
+       if (len) {
+           SV *newkey = newSV(len);
+           char *new_p = SvPVX(newkey);
+
+           if (SvUTF8(keysv)) {
+               const char *const end = p + len;
+               while (p < end) {
+                   STRLEN len;
+                   UV chr = utf8_to_uvuni(p, &len);
+                   new_p = uvuni_to_utf8(new_p, chr ^ 32);
+                   p += len;
+               }
+               SvUTF8_on(newkey);
+           } else {
+               while (len--)
+                   *new_p++ = *p++ ^ 32;
+           }
+           *new_p = '\0';
+           SvCUR_set(newkey, SvCUR(keysv));
+           SvPOK_on(newkey);
+
+           mg->mg_obj = newkey;
+       }
+    }
+    return 0;
+}
+
+static I32
 rot13_key(pTHX_ IV action, SV *field) {
     MAGIC *mg = mg_find(field, PERL_MAGIC_uvar);
     SV *keysv;
@@ -214,6 +249,19 @@ rot13_hash(hash)
            sv_magic((SV*)hash, NULL, PERL_MAGIC_uvar, (char*)&uf, sizeof(uf));
        }
 
+void
+bitflip_hash(hash)
+       HV *hash
+       CODE:
+       {
+           struct ufuncs uf;
+           uf.uf_val = bitflip_key;
+           uf.uf_set = 0;
+           uf.uf_index = 0;
+
+           sv_magic((SV*)hash, NULL, PERL_MAGIC_uvar, (char*)&uf, sizeof(uf));
+       }
+
 #define UTF8KLEN(sv, len)   (SvUTF8(sv) ? -(I32)len : (I32)len)
 
 bool

diff --git a/ext/XS/APItest/t/hash.t b/ext/XS/APItest/t/hash.t
index 28441c5..349f054 100644 (file)
--- a/ext/XS/APItest/t/hash.t
+++ b/ext/XS/APItest/t/hash.t
@@ -96,79 +96,113 @@ foreach my $in ("", "N", "a\0b") {
 }
 
 if ($] > 5.009) {
-    my %hash;
-    XS::APItest::Hash::rot13_hash(\%hash);
-    $hash{a}++; @hash{qw(p i e)} = (2, 4, 8);
+    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);
+    }
+}
+
+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(rot13(qw(a p i e)))),
-       "uvar magic called exactly once on store");
+    my @keys = sort keys %$hash;
+    is ("@keys", join(' ', sort($mapping->(keys %$placebo))),
+       "uvar magic called exactly once on store");
 
-    is($hash{i}, 4);
+    is (keys %$hash, 4);
 
-    is(delete $hash{a}, 1);
+    my $victim = shift @hitlist;
+    is (delete $hash->{$victim}, delete $placebo->{$victim});
 
-    is(keys %hash, 3);
-    @keys = sort keys %hash;
-    is("@keys", join(' ', sort(rot13(qw(p i e)))));
+    is (keys %$hash, 3);
+    @keys = sort keys %$hash;
+    is ("@keys", join(' ', sort($mapping->(keys %$placebo))));
 
-    is (XS::APItest::Hash::delete_ent (\%hash, 'p',
+    $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, 3);
+    is (keys %$hash, 3);
 
-    is (XS::APItest::Hash::delete_ent (\%hash, 'p', 0),
-       2, "Deleting a known key with conversion enabled works (ent)");
-    is(keys %hash, 2);
-    @keys = sort keys %hash;
-    is("@keys", join(' ', sort(rot13(qw(i e)))));
+    is (XS::APItest::Hash::delete_ent ($hash, $victim, 0),
+       delete $placebo->{$victim},
+       "Deleting a known key with conversion enabled works (ent)");
+    is (keys %$hash, 2);
+    @keys = sort keys %$hash;
+    is ("@keys", join(' ', sort($mapping->(keys %$placebo))));
 
-    is (XS::APItest::Hash::delete (\%hash, 'i',
+    $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, 2);
-
-    is (XS::APItest::Hash::delete (\%hash, 'i', 0),
-       4, "Deleting a known key with conversion enabled works");
-    is(keys %hash, 1);
-    @keys = sort keys %hash;
-    is("@keys", join(' ', sort(rot13(qw(e)))));
-
-    $hash{f} = 9;
-    is(keys %hash, 2);
-    @keys = sort keys %hash;
-    is("@keys", join(' ', sort(rot13(qw(e f)))));
-
-    is (XS::APItest::Hash::store_ent(\%hash, 'g', 10), 10, "store_ent");
-    is(keys %hash, 3);
-    @keys = sort keys %hash;
-    is("@keys", join(' ', sort(rot13(qw(e f g)))));
-
-    is (XS::APItest::Hash::store(\%hash, 'h', 11), 11, "store");
-    is(keys %hash, 4);
-    @keys = sort keys %hash;
-    is("@keys", join(' ', sort(rot13(qw(e f g h)))));
-
-    is (XS::APItest::Hash::fetch_ent(\%hash, 'g'), 10, "fetch_ent");
-    is (XS::APItest::Hash::fetch_ent(\%hash, rot13('g')), undef,
+    is (keys %$hash, 2);
+
+    is (XS::APItest::Hash::delete ($hash, $victim, 0),
+       delete $placebo->{$victim},
+       "Deleting a known key with conversion enabled works");
+    is(keys %$hash, 1);
+    @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, 2);
+    @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, 3);
+    @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");
+    is (keys %$hash, 4);
+    $placebo->{$k} = $v;
+    @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)");
 
-    is (XS::APItest::Hash::fetch(\%hash, 'h'), 11, "fetch");
-    is (XS::APItest::Hash::fetch(\%hash, rot13('h')), undef,
+    $victim = shift @hitlist;
+    is (XS::APItest::Hash::fetch($hash, $victim), $placebo->{$victim},
+       "fetch");
+    is (XS::APItest::Hash::fetch($hash, $mapping->($victim)), undef,
        "fetch (missing)");
 
-    ok (XS::APItest::Hash::exists_ent(\%hash, 'e'), "exists_ent");
-    ok (!XS::APItest::Hash::exists_ent(\%hash, rot13('e')),
+    $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)");
 
-    ok (XS::APItest::Hash::exists(\%hash, 'f'), "exists");
-    ok (!XS::APItest::Hash::exists(\%hash, rot13('f')), "exists (missing)");
+    $victim = shift @hitlist;
+    ok (XS::APItest::Hash::exists($hash, $victim), "exists");
+    ok (!XS::APItest::Hash::exists($hash, $mapping->($victim)),
+       "exists (missing)");
 }
 
-exit;
-
-################################   The End   ################################
-
 sub main_tests {
   my ($keys, $testkeys, $description) = @_;
   foreach my $key (@$testkeys) {
@@ -336,3 +370,8 @@ 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];
+}