From: Nicholas Clark <nick@ccl4.org>
Date: Wed, 19 Sep 2007 21:01:26 +0000 (+0000)
Subject: Parameterise the code that tests the rot13 hash, and add a second
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=53c40a8fd46e24a1d1e4bce188f973172eb1a279;p=p5sagit%2Fp5-mst-13.2.git

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
--- 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
--- 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];
+}