Simple package scalar lvalue refs
authorFather Chrysostomos <sprout@cpan.org>
Sun, 21 Sep 2014 20:56:01 +0000 (13:56 -0700)
committerFather Chrysostomos <sprout@cpan.org>
Sat, 11 Oct 2014 04:54:08 +0000 (21:54 -0700)
\$::x = ... works, but not \local $x yet.

embed.fnc
embed.h
op.c
pp.c
proto.h
sv.c
t/op/lvref.t

index 0da1b26..9046b38 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -554,6 +554,7 @@ Ap  |void   |gv_name_set    |NN GV* gv|NN const char *name|U32 len|U32 flags
 px     |GV *   |gv_override    |NN const char * const name \
                                |const STRLEN len
 XMpd   |void   |gv_try_downgrade|NN GV* gv
+p      |void   |gv_setref      |NN SV *const dstr|NN SV *const sstr
 Apd    |HV*    |gv_stashpv     |NN const char* name|I32 flags
 Apd    |HV*    |gv_stashpvn    |NN const char* name|U32 namelen|I32 flags
 #if defined(PERL_IN_GV_C)
@@ -2350,7 +2351,6 @@ s |SV *   |more_sv
 s      |bool   |sv_2iuv_common |NN SV *const sv
 s      |void   |glob_assign_glob|NN SV *const dstr|NN SV *const sstr \
                |const int dtype
-s      |void   |glob_assign_ref|NN SV *const dstr|NN SV *const sstr
 sRn    |PTR_TBL_ENT_t *|ptr_table_find|NN PTR_TBL_t *const tbl|NULLOK const void *const sv
 s      |void   |anonymise_cv_maybe     |NN GV *gv|NN CV *cv
 #endif
diff --git a/embed.h b/embed.h
index 039961e..cb6281f 100644 (file)
--- a/embed.h
+++ b/embed.h
 #define get_no_modify()                Perl_get_no_modify(aTHX)
 #define get_opargs()           Perl_get_opargs(aTHX)
 #define gv_override(a,b)       Perl_gv_override(aTHX_ a,b)
+#define gv_setref(a,b)         Perl_gv_setref(aTHX_ a,b)
 #define gv_try_downgrade(a)    Perl_gv_try_downgrade(aTHX_ a)
 #define hv_ename_add(a,b,c,d)  Perl_hv_ename_add(aTHX_ a,b,c,d)
 #define hv_ename_delete(a,b,c,d)       Perl_hv_ename_delete(aTHX_ a,b,c,d)
 #define find_uninit_var(a,b,c) S_find_uninit_var(aTHX_ a,b,c)
 #define glob_2number(a)                S_glob_2number(aTHX_ a)
 #define glob_assign_glob(a,b,c)        S_glob_assign_glob(aTHX_ a,b,c)
-#define glob_assign_ref(a,b)   S_glob_assign_ref(aTHX_ a,b)
 #define more_sv()              S_more_sv(aTHX)
 #define not_a_number(a)                S_not_a_number(aTHX_ a)
 #define not_incrementable(a)   S_not_incrementable(aTHX_ a)
diff --git a/op.c b/op.c
index bd85fd2..dac6054 100644 (file)
--- a/op.c
+++ b/op.c
@@ -9867,7 +9867,7 @@ Perl_ck_refassign(pTHX_ OP *o)
     OP * const right = cLISTOPo->op_first;
     OP * const left = OP_SIBLING(right);
     OP * const varop = cUNOPx(cUNOPx(left)->op_first)->op_first;
-    PADOFFSET targ;
+    bool stacked = 0;
 
     PERL_ARGS_ASSERT_CK_REFASSIGN;
     assert (left);
@@ -9877,9 +9877,17 @@ Perl_ck_refassign(pTHX_ OP *o)
     case OP_PADSV:
        if (varop->op_private & OPpLVAL_INTRO)
            goto bad; /* XXX temporary */
-       targ = varop->op_targ;
+       o->op_targ = varop->op_targ;
        varop->op_targ = 0;
        break;
+    case OP_RV2SV:
+       if (cUNOPx(varop)->op_first->op_type != OP_GV) goto bad;
+       if (varop->op_private & OPpLVAL_INTRO)
+           goto bad; /* XXX temporary */
+       op_null(varop);
+       op_null(left);
+       stacked = TRUE;
+       break;
     default:
       bad:
        op_lvalue(left, OP_SASSIGN);
@@ -9891,9 +9899,12 @@ Perl_ck_refassign(pTHX_ OP *o)
     Perl_ck_warner_d(aTHX_
                     packWARN(WARN_EXPERIMENTAL__LVALUE_REFS),
                    "Lvalue references are experimental");
-    o->op_targ = targ;
-    op_sibling_splice(o, right, 1, NULL);
-    op_free(left);
+    if (stacked) o->op_flags |= OPf_STACKED;
+    else {
+       o->op_flags &=~ OPf_STACKED;
+       op_sibling_splice(o, right, 1, NULL);
+       op_free(left);
+    }
     return o;
 }
 
diff --git a/pp.c b/pp.c
index 55c1c94..9822410 100644 (file)
--- a/pp.c
+++ b/pp.c
@@ -6163,13 +6163,21 @@ PP(pp_runcv)
 PP(pp_refassign)
 {
     dSP;
+    SV * const left = PL_op->op_flags & OPf_STACKED ? POPs : NULL;
     dTOPss;
     if (!SvROK(sv)) DIE(aTHX_ "Assigned value is not a reference");
     if (SvTYPE(SvRV(sv)) > SVt_PVLV)
        /* diag_listed_as: Assigned value is not %s reference */
        DIE(aTHX_ "Assigned value is not a SCALAR reference");
-    SvREFCNT_dec(PAD_SV(ARGTARG));
-    PAD_SETSV(ARGTARG, SvREFCNT_inc_NN(SvRV(sv)));
+    switch (left ? SvTYPE(left) : 0) {
+    case 0:
+       SvREFCNT_dec(PAD_SV(ARGTARG));
+       PAD_SETSV(ARGTARG, SvREFCNT_inc_NN(SvRV(sv)));
+       break;
+    case SVt_PVGV:
+       gv_setref(left, sv);
+       SvSETMAGIC(left);
+    }
     if (PL_op->op_flags & OPf_MOD)
        SETs(sv_2mortal(newSVsv(sv)));
     /* XXX else can weak references go stale before they are read, e.g.,
diff --git a/proto.h b/proto.h
index dd90f3f..8fa7f1e 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -1571,6 +1571,12 @@ PERL_CALLCONV GV *       Perl_gv_override(pTHX_ const char * const name, const STRLEN
 #define PERL_ARGS_ASSERT_GV_OVERRIDE   \
        assert(name)
 
+PERL_CALLCONV void     Perl_gv_setref(pTHX_ SV *const dstr, SV *const sstr)
+                       __attribute__nonnull__(pTHX_1)
+                       __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_GV_SETREF     \
+       assert(dstr); assert(sstr)
+
 PERL_CALLCONV HV*      Perl_gv_stashpv(pTHX_ const char* name, I32 flags)
                        __attribute__nonnull__(pTHX_1);
 #define PERL_ARGS_ASSERT_GV_STASHPV    \
@@ -7488,12 +7494,6 @@ STATIC void      S_glob_assign_glob(pTHX_ SV *const dstr, SV *const sstr, const int d
 #define PERL_ARGS_ASSERT_GLOB_ASSIGN_GLOB      \
        assert(dstr); assert(sstr)
 
-STATIC void    S_glob_assign_ref(pTHX_ SV *const dstr, SV *const sstr)
-                       __attribute__nonnull__(pTHX_1)
-                       __attribute__nonnull__(pTHX_2);
-#define PERL_ARGS_ASSERT_GLOB_ASSIGN_REF       \
-       assert(dstr); assert(sstr)
-
 STATIC SV *    S_more_sv(pTHX);
 STATIC void    S_not_a_number(pTHX_ SV *const sv)
                        __attribute__nonnull__(pTHX_1);
diff --git a/sv.c b/sv.c
index 665a0f6..36dc003 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -3973,8 +3973,8 @@ S_glob_assign_glob(pTHX_ SV *const dstr, SV *const sstr, const int dtype)
     return;
 }
 
-static void
-S_glob_assign_ref(pTHX_ SV *const dstr, SV *const sstr)
+void
+Perl_gv_setref(pTHX_ SV *const dstr, SV *const sstr)
 {
     SV * const sref = SvRV(sstr);
     SV *dref;
@@ -3983,7 +3983,7 @@ S_glob_assign_ref(pTHX_ SV *const dstr, SV *const sstr)
     U8 import_flag = 0;
     const U32 stype = SvTYPE(sref);
 
-    PERL_ARGS_ASSERT_GLOB_ASSIGN_REF;
+    PERL_ARGS_ASSERT_GV_SETREF;
 
     if (intro) {
        GvINTRO_off(dstr);      /* one-shot flag */
@@ -4170,7 +4170,7 @@ S_glob_assign_ref(pTHX_ SV *const dstr, SV *const sstr)
            Perl_magic_clearisa(aTHX_ NULL, mg);
        }
         else if (stype == SVt_PVIO) {
-            DEBUG_o(Perl_deb(aTHX_ "glob_assign_ref clearing PL_stashcache\n"));
+            DEBUG_o(Perl_deb(aTHX_ "gv_setref clearing PL_stashcache\n"));
             /* It's a cache. It will rebuild itself quite happily.
                It's a lot of effort to work out exactly which key (or keys)
                might be invalidated by the creation of the this file handle.
@@ -4429,7 +4429,7 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, SV* sstr, const I32 flags)
 
        if (dtype >= SVt_PV) {
            if (isGV_with_GP(dstr)) {
-               glob_assign_ref(dstr, sstr);
+               gv_setref(dstr, sstr);
                return;
            }
            if (SvPVX_const(dstr)) {
index 1b66e2d..759507e 100644 (file)
@@ -4,11 +4,10 @@ BEGIN {
     set_up_inc("../lib");
 }
 
-plan 17;
+plan 18;
 
 sub on { $::TODO = ' ' }
 sub off{ $::TODO = ''  }
-on;
 
 eval '\$x = \$y';
 like $@, qr/^Experimental lvalue references not enabled/,
@@ -31,7 +30,6 @@ no warnings 'experimental::lvalue_refs';
 
 eval '\$x = \$y';
 is \$x, \$y, '\$pkg_scalar = ...';
-off;
 my $m;
 \$m = \$y;
 is \$m, \$y, '\$lexical = ...';
@@ -85,6 +83,9 @@ like $@, qr/^Assigned value is not a reference at/, 'assigning non-ref';
 eval { my $x; \$x = [] };
 like $@, qr/^Assigned value is not a SCALAR reference at/,
     'assigning non-scalar ref to scalar ref';
+eval { \$::x = [] };
+like $@, qr/^Assigned value is not a SCALAR reference at/,
+    'assigning non-scalar ref to package scalar ref';
 on;
 
 # Miscellaneous