This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
[perl #27010] Make tie work through defelems
authorFather Chrysostomos <sprout@cpan.org>
Tue, 16 Jul 2013 06:51:15 +0000 (23:51 -0700)
committerFather Chrysostomos <sprout@cpan.org>
Tue, 16 Jul 2013 07:26:02 +0000 (00:26 -0700)
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.

embed.fnc
embed.h
mg.c
pp_sys.c
proto.h
t/op/tie.t

index ffbb7f6..778edd6 100644 (file)
--- 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 (file)
--- a/embed.h
+++ b/embed.h
 #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 (file)
--- 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;
 }
 
index 793de40..2aa83a8 100644 (file)
--- 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 (file)
--- 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)
index 6ff5870..668e919 100644 (file)
@@ -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