In perl.git, the branch blead has been updated <http://perl5.git.perl.org/perl.git/commitdiff/7d279cabb7b2168bc324f9c63b1e89c02412259e?hp=d4431b89a00a340cc459be515feeb6c274012420>
- Log ----------------------------------------------------------------- commit 7d279cabb7b2168bc324f9c63b1e89c02412259e Author: Father Chrysostomos <[email protected]> Date: Mon Jul 15 23:52:44 2013 -0700 perldelta for #27010 M pod/perldelta.pod commit 13733cde3fe669aafa0a2a598b5b45d024fb3b86 Author: Father Chrysostomos <[email protected]> Date: Mon Jul 15 23:51:15 2013 -0700 [perl #27010] Make tie work through defelems When elements of @_ refer to nonexistent hash or array elements, then the magic scalar in $_[0] delegates all set/get actions to the element in represents, vivifying it if needed. tie/tied/untie, however, were not delegating to the element, but were tying the the magical âdeferred elementâ scalar itself. M embed.fnc M embed.h M mg.c M pp_sys.c M proto.h M t/op/tie.t ----------------------------------------------------------------------- Summary of changes: embed.fnc | 1 + embed.h | 1 + mg.c | 22 +++++++++++++++------- pod/perldelta.pod | 5 +++-- pp_sys.c | 10 ++++++++++ proto.h | 6 ++++++ t/op/tie.t | 28 ++++++++++++++++++++++++++++ 7 files changed, 64 insertions(+), 9 deletions(-) diff --git a/embed.fnc b/embed.fnc index ffbb7f6..778edd6 100644 --- a/embed.fnc +++ b/embed.fnc @@ -323,6 +323,7 @@ Ap |void |debprofdump Ap |I32 |debop |NN const OP* o Ap |I32 |debstack Ap |I32 |debstackptrs +pR |SV * |defelem_target |NN SV *sv|NULLOK MAGIC *mg Anp |char* |delimcpy |NN char* to|NN const char* toend|NN const char* from \ |NN const char* fromend|int delim|NN I32* retlen : Used in op.c, perl.c diff --git a/embed.h b/embed.h index 1550817..58b7b35 100644 --- a/embed.h +++ b/embed.h @@ -1073,6 +1073,7 @@ #define cvgv_set(a,b) Perl_cvgv_set(aTHX_ a,b) #define cvstash_set(a,b) Perl_cvstash_set(aTHX_ a,b) #define deb_stack_all() Perl_deb_stack_all(aTHX) +#define defelem_target(a,b) Perl_defelem_target(aTHX_ a,b) #define delete_eval_scope() Perl_delete_eval_scope(aTHX) #define die_unwind(a) Perl_die_unwind(aTHX_ a) #define do_aexec5(a,b,c,d,e) Perl_do_aexec5(aTHX_ a,b,c,d,e) diff --git a/mg.c b/mg.c index 99169cc..0dd23f6 100644 --- a/mg.c +++ b/mg.c @@ -2301,14 +2301,14 @@ Perl_magic_setvec(pTHX_ SV *sv, MAGIC *mg) return 0; } -int -Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg) +SV * +Perl_defelem_target(pTHX_ SV *sv, MAGIC *mg) { dVAR; SV *targ = NULL; - - PERL_ARGS_ASSERT_MAGIC_GETDEFELEM; - + PERL_ARGS_ASSERT_DEFELEM_TARGET; + if (!mg) mg = mg_find(sv, PERL_MAGIC_defelem); + assert(mg); if (LvTARGLEN(sv)) { if (mg->mg_obj) { SV * const ahv = LvTARG(sv); @@ -2330,10 +2330,18 @@ Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg) mg->mg_obj = NULL; mg->mg_flags &= ~MGf_REFCOUNTED; } + return targ; } else - targ = LvTARG(sv); - sv_setsv(sv, targ ? targ : &PL_sv_undef); + return LvTARG(sv); +} + +int +Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg) +{ + PERL_ARGS_ASSERT_MAGIC_GETDEFELEM; + + sv_setsv(sv, defelem_target(sv, mg)); return 0; } diff --git a/pod/perldelta.pod b/pod/perldelta.pod index ef8d64a..085603b 100644 --- a/pod/perldelta.pod +++ b/pod/perldelta.pod @@ -626,8 +626,9 @@ vstring into a regular string. =item * -C<pos> did not work properly on subroutine arguments aliased to nonexistent -hash and array elements [perl #77814]. +C<pos>, C<tie>, C<tied> and C<untie> did not work +properly on subroutine arguments aliased to nonexistent +hash and array elements [perl #77814, #27010]. =back diff --git a/pp_sys.c b/pp_sys.c index 793de40..2aa83a8 100644 --- a/pp_sys.c +++ b/pp_sys.c @@ -899,6 +899,10 @@ PP(pp_tie) varsv = MUTABLE_SV(GvIOp(varsv)); break; } + if (SvTYPE(varsv) == SVt_PVLV && LvTYPE(varsv) == 'y') { + vivify_defelem(varsv); + varsv = LvTARG(varsv); + } /* FALL THROUGH */ default: methname = "TIESCALAR"; @@ -967,6 +971,9 @@ PP(pp_untie) if (isGV_with_GP(sv) && !SvFAKE(sv) && !(sv = MUTABLE_SV(GvIOp(sv)))) RETPUSHYES; + if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y' && + !(sv = defelem_target(sv, NULL))) RETPUSHUNDEF; + if ((mg = SvTIED_mg(sv, how))) { SV * const obj = SvRV(SvTIED_obj(sv, mg)); if (obj) { @@ -1005,6 +1012,9 @@ PP(pp_tied) if (isGV_with_GP(sv) && !SvFAKE(sv) && !(sv = MUTABLE_SV(GvIOp(sv)))) RETPUSHUNDEF; + if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y' && + !(sv = defelem_target(sv, NULL))) RETPUSHUNDEF; + if ((mg = SvTIED_mg(sv, how))) { PUSHs(SvTIED_obj(sv, mg)); RETURN; diff --git a/proto.h b/proto.h index cbb8664..5c21bf7 100644 --- a/proto.h +++ b/proto.h @@ -803,6 +803,12 @@ PERL_CALLCONV I32 Perl_debop(pTHX_ const OP* o) PERL_CALLCONV void Perl_debprofdump(pTHX); PERL_CALLCONV I32 Perl_debstack(pTHX); PERL_CALLCONV I32 Perl_debstackptrs(pTHX); +PERL_CALLCONV SV * Perl_defelem_target(pTHX_ SV *sv, MAGIC *mg) + __attribute__warn_unused_result__ + __attribute__nonnull__(pTHX_1); +#define PERL_ARGS_ASSERT_DEFELEM_TARGET \ + assert(sv) + PERL_CALLCONV void Perl_delete_eval_scope(pTHX); PERL_CALLCONV char* Perl_delimcpy(char* to, const char* toend, const char* from, const char* fromend, int delim, I32* retlen) __attribute__nonnull__(1) diff --git a/t/op/tie.t b/t/op/tie.t index 6ff5870..668e919 100644 --- a/t/op/tie.t +++ b/t/op/tie.t @@ -1340,3 +1340,31 @@ sub STORE { print ref \$_[1], "\n" } tie $x, ""; $x = v3; EXPECT VSTRING +######## + +# [perl #27010] Tying deferred elements +$\="\n"; +sub TIESCALAR{bless[]}; +sub { + tie $_[0], ""; + print ref tied $h{k}; + tie $h{l}, ""; + print ref tied $_[1]; + untie $h{k}; + print tied $_[0] // 'undef'; + untie $_[1]; + print tied $h{l} // 'undef'; + # check that tied and untie do not autovivify + # XXX should they autovivify? + tied $_[2]; + print exists $h{m} ? "yes" : "no"; + untie $_[2]; + print exists $h{m} ? "yes" : "no"; +}->($h{k}, $h{l}, $h{m}); +EXPECT +main +main +undef +undef +no +no -- Perl5 Master Repository
