From: Nicholas Clark Date: Wed, 19 Sep 2007 08:12:09 +0000 (+0000) Subject: For an LVALUE fetch, "hv_fetch()" will recurse into "hv_store()" for a X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=b54b4831042e3002a143d3fcff13b3bad5088c70;p=p5sagit%2Fp5-mst-13.2.git 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 --- diff --git a/cop.h b/cop.h index 725aab4..554d4fc 100644 --- a/cop.h +++ b/cop.h @@ -716,7 +716,9 @@ L. #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 9901e81..dd61540 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 b01ae55..da865e6 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 2a0f9f8..4af7f88 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 cf0f3f4..634d0e6 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 f8e38a1..dfcc591 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: