For an LVALUE fetch, "hv_fetch()" will recurse into "hv_store()" for a

hash with magic. Field hashes have u magic, so this recursion triggers.
However, key conversion replaces the original key with the converted
key, so we need to ensure that conversion happens exactly once, else
for a non-idempotent key conversion routine (eg ROT13) we will see
double conversion in this case.

p4raw-id: //depot/perl@31898

3 files changed, 130 insertions, 15 deletions

diff --git a/ext/Hash/Util/FieldHash/t/05_perlhook.t b/ext/Hash/Util/FieldHash/t/05_perlhook.t
index 9901e81443..dd61540969 100644
--- a/ext/Hash/Util/FieldHash/t/05_perlhook.t
+++ b/ext/Hash/Util/FieldHash/t/05_perlhook.t
@@ -76,50 +76,50 @@ use Scalar::Util qw( weaken);
     is( $counter, 1, "list assign triggers");
 
     $h{ def} = 456;
-    is( $counter, 3, "lvalue assign triggers twice");
+    is( $counter, 2, "lvalue assign triggers twice");
 
     exists $h{ def};
-    is( $counter, 4, "good exists triggers");
+    is( $counter, 3, "good exists triggers");
 
     exists $h{ xyz};
-    is( $counter, 5, "bad exists triggers");
+    is( $counter, 4, "bad exists triggers");
 
     delete $h{ def};
-    is( $counter, 6, "good delete triggers");
+    is( $counter, 5, "good delete triggers");
 
     delete $h{ xyz};
-    is( $counter, 7, "bad delete triggers");
+    is( $counter, 6, "bad delete triggers");
 
     my $x = $h{ abc};
-    is( $counter, 8, "good read triggers");
+    is( $counter, 7, "good read triggers");
 
     $x = $h{ xyz};
-    is( $counter, 9, "bad read triggers");
+    is( $counter, 8, "bad read triggers");
 
     bless \ %h;
-    is( $counter, 9, "bless triggers(!)");
+    is( $counter, 8, "bless triggers(!)"); # XXX, this description seems bogus
 
 
     $x = keys %h;
-    is( $counter, 9, "scalar keys doesn't trigger");
+    is( $counter, 8, "scalar keys doesn't trigger");
 
     () = keys %h;
-    is( $counter, 9, "list keys doesn't trigger");
+    is( $counter, 8, "list keys doesn't trigger");
 
     $x = values %h;
-    is( $counter, 9, "scalar values doesn't trigger");
+    is( $counter, 8, "scalar values doesn't trigger");
 
     () = values %h;
-    is( $counter, 9, "list values doesn't trigger");
+    is( $counter, 8, "list values doesn't trigger");
 
     $x = each %h;
-    is( $counter, 9, "scalar each doesn't trigger");
+    is( $counter, 8, "scalar each doesn't trigger");
 
     () = each %h;
-    is( $counter, 9, "list each doesn't trigger");
+    is( $counter, 8, "list each doesn't trigger");
 
     bless \ %h, 'xyz';
-    is( $counter, 9, "bless doesn't trigger");
+    is( $counter, 8, "bless doesn't trigger");
 
     # see that normal set magic doesn't trigger (identity condition)
     my %i;
diff --git a/ext/XS/APItest/APItest.xs b/ext/XS/APItest/APItest.xs
index b01ae55f78..da865e693d 100644
--- a/ext/XS/APItest/APItest.xs
+++ b/ext/XS/APItest/APItest.xs
@@ -110,8 +110,106 @@ test_freeent(freeent_function *f) {
     SvREFCNT_dec(test_scalar);
 }
 
+
+static I32
+rot13_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);
+
+	    /* There's a deliberate fencepost error here to loop len + 1 times
+	       to copy the trailing \0  */
+	    do {
+		char new_c = *p++;
+		/* Try doing this cleanly and clearly in EBCDIC another way: */
+		switch (new_c) {
+		case 'A': new_c = 'N'; break;
+		case 'B': new_c = 'O'; break;
+		case 'C': new_c = 'P'; break;
+		case 'D': new_c = 'Q'; break;
+		case 'E': new_c = 'R'; break;
+		case 'F': new_c = 'S'; break;
+		case 'G': new_c = 'T'; break;
+		case 'H': new_c = 'U'; break;
+		case 'I': new_c = 'V'; break;
+		case 'J': new_c = 'W'; break;
+		case 'K': new_c = 'X'; break;
+		case 'L': new_c = 'Y'; break;
+		case 'M': new_c = 'Z'; break;
+		case 'N': new_c = 'A'; break;
+		case 'O': new_c = 'B'; break;
+		case 'P': new_c = 'C'; break;
+		case 'Q': new_c = 'D'; break;
+		case 'R': new_c = 'E'; break;
+		case 'S': new_c = 'F'; break;
+		case 'T': new_c = 'G'; break;
+		case 'U': new_c = 'H'; break;
+		case 'V': new_c = 'I'; break;
+		case 'W': new_c = 'J'; break;
+		case 'X': new_c = 'K'; break;
+		case 'Y': new_c = 'L'; break;
+		case 'Z': new_c = 'M'; break;
+		case 'a': new_c = 'n'; break;
+		case 'b': new_c = 'o'; break;
+		case 'c': new_c = 'p'; break;
+		case 'd': new_c = 'q'; break;
+		case 'e': new_c = 'r'; break;
+		case 'f': new_c = 's'; break;
+		case 'g': new_c = 't'; break;
+		case 'h': new_c = 'u'; break;
+		case 'i': new_c = 'v'; break;
+		case 'j': new_c = 'w'; break;
+		case 'k': new_c = 'x'; break;
+		case 'l': new_c = 'y'; break;
+		case 'm': new_c = 'z'; break;
+		case 'n': new_c = 'a'; break;
+		case 'o': new_c = 'b'; break;
+		case 'p': new_c = 'c'; break;
+		case 'q': new_c = 'd'; break;
+		case 'r': new_c = 'e'; break;
+		case 's': new_c = 'f'; break;
+		case 't': new_c = 'g'; break;
+		case 'u': new_c = 'h'; break;
+		case 'v': new_c = 'i'; break;
+		case 'w': new_c = 'j'; break;
+		case 'x': new_c = 'k'; break;
+		case 'y': new_c = 'l'; break;
+		case 'z': new_c = 'm'; break;
+		}
+		*new_p++ = new_c;
+	    } while (len--);
+	    SvCUR_set(newkey, SvCUR(keysv));
+	    SvPOK_on(newkey);
+	    if (SvUTF8(keysv))
+		SvUTF8_on(newkey);
+
+	    mg->mg_obj = newkey;
+	}
+    }
+    return 0;
+}
+
 MODULE = XS::APItest:Hash		PACKAGE = XS::APItest::Hash
 
+void
+rot13_hash(hash)
+	HV *hash
+	CODE:
+	{
+	    struct ufuncs uf;
+	    uf.uf_val = rot13_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 2a0f9f86ec..4af7f88ad6 100644
--- a/ext/XS/APItest/t/hash.t
+++ b/ext/XS/APItest/t/hash.t
@@ -95,6 +95,18 @@ foreach my $in ("", "N", "a\0b") {
     is ($got, $in, "test_share_unshare_pvn");
 }
 
+{
+    my %hash;
+    XS::APItest::Hash::rot13_hash(\%hash);
+    $hash{a}++; @hash{qw(p i e)} = (2, 4, 8);
+
+    my @keys = sort keys %hash;
+    is("@keys", join(' ', sort(rot13(qw(a p i e)))),
+       "uvar magic called exactly once on store");
+
+    is($hash{i}, 4);
+}
+
 exit;
 
 ################################   The End   ################################
@@ -261,3 +273,8 @@ sub brute_force_exists {
   }
   return 0;
 }
+
+sub rot13 {
+    my @results = map {my $a = $_; $a =~ tr/A-Za-z/N-ZA-Mn-za-m/; $a} @_;
+    wantarray ? @results : $results[0];
+}