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
#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 */
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;
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
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 ################################
}
return 0;
}
+
+sub rot13 {
+ my @results = map {my $a = $_; $a =~ tr/A-Za-z/N-ZA-Mn-za-m/; $a} @_;
+ wantarray ? @results : $results[0];
+}
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);
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)) {
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)
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);
}
}
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. */
}
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);
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) {
/* 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:
projects / p5sagit/p5-mst-13.2.git / commitdiff