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

6 files changed, 163 insertions, 28 deletions

diff --git a/cop.h b/cop.h
index 725aab460e..554d4fc1da 100644
--- a/cop.h
+++ b/cop.h
@@ -716,7 +716,9 @@ L<perlcall>.
 #define G_VOID		128	/* skip this bit when adding flags below */
 
 /* extra flags for Perl_call_* routines */
-#define G_DISCARD	2	/* Call FREETMPS. */
+#define G_DISCARD	2	/* Call FREETMPS.
+				   Don't change this without consulting the
+				   hash actions codes defined in hv.h */
 #define G_EVAL		4	/* Assume eval {} around subroutine call. */
 #define G_NOARGS	8	/* Don't construct a @_ array. */
 #define G_KEEPERR      16	/* Append errors to $@, don't overwrite it */
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];
+}
diff --git a/hv.c b/hv.c
index cf0f3f4524..634d0e63d5 100644
--- a/hv.c
+++ b/hv.c
@@ -424,8 +424,16 @@ S_hv_fetch_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen,
 	return NULL;
 
     if (keysv) {
-	if (SvSMAGICAL(hv) && SvGMAGICAL(hv))
+	if (SvSMAGICAL(hv) && SvGMAGICAL(hv)
+	    && !(action & HV_DISABLE_UVAR_XKEY)) {
 	    keysv = hv_magic_uvar_xkey(hv, keysv, action);
+	    /* If a fetch-as-store fails on the fetch, then the action is to
+	       recurse once into "hv_store". If we didn't do this, then that
+	       recursive call would call the key conversion routine again.
+	       However, as we replace the original key with the converted
+	       key, this would result in a double conversion, which would show
+	       up as a bug if the conversion routine is not idempotent.  */
+	}
 	if (flags & HVhek_FREEKEY)
 	    Safefree(key);
 	key = SvPV_const(keysv, klen);
@@ -489,7 +497,8 @@ S_hv_fetch_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen,
 			   key) whereas the store is for key (the original)  */
 			entry = hv_fetch_common(hv, NULL, nkey, klen,
 						HVhek_FREEKEY, /* free nkey */
-						0 /* non-LVAL fetch */,
+						0 /* non-LVAL fetch */
+						| HV_DISABLE_UVAR_XKEY,
 						NULL /* no value */,
 						0 /* compute hash */);
 			if (!entry && (action & HV_FETCH_LVALUE)) {
@@ -497,7 +506,9 @@ S_hv_fetch_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen,
 			       Do it this way to encourage compiler to tail
 			       call optimise.  */
 			    entry = hv_fetch_common(hv, keysv, key, klen,
-						    flags, HV_FETCH_ISSTORE,
+						    flags,
+						    HV_FETCH_ISSTORE
+						    | HV_DISABLE_UVAR_XKEY,
 						    newSV(0), hash);
 			} else {
 			    if (flags & HVhek_FREEKEY)
@@ -747,7 +758,8 @@ S_hv_fetch_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen,
 	if (env) {
 	    sv = newSVpvn(env,len);
 	    SvTAINTED_on(sv);
-	    return hv_fetch_common(hv,keysv,key,klen,flags,HV_FETCH_ISSTORE,sv,
+	    return hv_fetch_common(hv, keysv, key, klen, flags,
+				   HV_FETCH_ISSTORE|HV_DISABLE_UVAR_XKEY, sv,
 				   hash);
 	}
     }
@@ -772,7 +784,8 @@ S_hv_fetch_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen,
 	       magic check happen.  */
 	    /* gonna assign to this, so it better be there */
 	    return hv_fetch_common(hv, keysv, key, klen, flags,
-				   HV_FETCH_ISSTORE, val, hash);
+				   HV_FETCH_ISSTORE|HV_DISABLE_UVAR_XKEY, val,
+				   hash);
 	    /* XXX Surely that could leak if the fetch-was-store fails?
 	       Just like the hv_fetch.  */
 	}
@@ -954,7 +967,8 @@ S_hv_delete_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen,
 	return NULL;
 
     if (keysv) {
-	if (SvSMAGICAL(hv) && SvGMAGICAL(hv))
+	if (SvSMAGICAL(hv) && SvGMAGICAL(hv)
+	    && !(d_flags & HV_DISABLE_UVAR_XKEY))
 	    keysv = hv_magic_uvar_xkey(hv, keysv, HV_DELETE);
 	if (k_flags & HVhek_FREEKEY)
 	    Safefree(key);
@@ -973,7 +987,8 @@ S_hv_delete_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen,
 	if (needs_copy) {
 	    SV *sv;
 	    entry = hv_fetch_common(hv, keysv, key, klen,
-				    k_flags & ~HVhek_FREEKEY, HV_FETCH_LVALUE,
+				    k_flags & ~HVhek_FREEKEY,
+				    HV_FETCH_LVALUE|HV_DISABLE_UVAR_XKEY,
 				    NULL, hash);
 	    sv = entry ? HeVAL(entry) : NULL;
 	    if (sv) {
diff --git a/hv.h b/hv.h
index f8e38a1dec..dfcc59158d 100644
--- a/hv.h
+++ b/hv.h
@@ -482,11 +482,14 @@ struct refcounted_he {
 /* Hash actions
  * Passed in PERL_MAGIC_uvar calls
  */
-#define HV_DELETE          -1
-#define HV_FETCH_ISSTORE   0x01
-#define HV_FETCH_ISEXISTS  0x02
-#define HV_FETCH_LVALUE    0x04
-#define HV_FETCH_JUST_SV   0x08
+#define HV_DELETE		-1
+#define HV_DISABLE_UVAR_XKEY	0x01
+/* We need to ensure that these don't clash with G_DISCARD, which is 2, as it
+   is documented as being passed to hv_delete().  */
+#define HV_FETCH_ISSTORE	0x04
+#define HV_FETCH_ISEXISTS	0x08
+#define HV_FETCH_LVALUE		0x10
+#define HV_FETCH_JUST_SV	0x20
 
 /*
  * Local variables: