List assignment to package scalar ref

\ on the lhs returns a special magical scalar with set-magic that does
the aliasing.

I considered having a separate abind op that would be like aassign,
but different.  However, I realised that for ($x, \$y) = ... to work
it would have to duplicate all of aassign.  So I went with the sim-
pler magic implementation.

4 files changed, 67 insertions, 11 deletions

diff --git a/mg.c b/mg.c
index e271f883b2..2284783625 100644
--- a/mg.c
+++ b/mg.c
@@ -2465,7 +2465,14 @@ int
 Perl_magic_setlvref(pTHX_ SV *sv, MAGIC *mg)
 {
     PERL_ARGS_ASSERT_MAGIC_SETLVREF;
-    Perl_croak(aTHX_ "Unimplemented");
+    if (!SvROK(sv)) Perl_croak(aTHX_ "Assigned value is not a reference");
+    if (SvTYPE(SvRV(sv)) > SVt_PVLV)
+	/* diag_listed_as: Assigned value is not %s reference */
+	Perl_croak(aTHX_ "Assigned value is not a SCALAR reference");
+    assert(isGV(mg->mg_obj));
+    gv_setref(mg->mg_obj, sv);
+    SvSETMAGIC(mg->mg_obj);
+    sv_unmagic(sv, PERL_MAGIC_lvref);
     return 0;
 }
 
diff --git a/op.c b/op.c
index 70e1df7cdf..7752486c90 100644
--- a/op.c
+++ b/op.c
@@ -2626,6 +2626,34 @@ Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
 	 || !S_vivifies(OP_SIBLING(cLOGOPo->op_first)->op_type))
 	    op_lvalue(OP_SIBLING(cLOGOPo->op_first), type);
 	goto nomod;
+
+    case OP_SREFGEN:
+	if (type != OP_AASSIGN) goto nomod;
+	kid = cUNOPx(cUNOPo->op_first)->op_first;
+	switch (kid->op_type) {
+	case OP_RV2SV:
+	    if (kUNOP->op_first->op_type != OP_GV) goto badref;
+	    if (kid->op_private & OPpLVAL_INTRO)
+		goto badref; /* XXX temporary */
+	    op_null(kid);
+	    o->op_type = OP_LVREF;
+	    o->op_ppaddr = PL_ppaddr[OP_LVREF];
+	    o->op_flags |= OPf_STACKED;
+	    break;
+	default:
+	  badref:
+	    yyerror(Perl_form(aTHX_ "Can't modify reference to %s in list "
+				    "assignment",
+		     o->op_type == OP_NULL && o->op_flags & OPf_SPECIAL
+		      ? "do block"
+		      : OP_DESC(kid)));
+	    return o;
+	}
+	if (!FEATURE_LVREF_IS_ENABLED)
+	    Perl_croak(aTHX_ "Experimental lvalue references not enabled");
+	Perl_ck_warner_d(aTHX_ packWARN(WARN_EXPERIMENTAL__LVALUE_REFS),
+			      "Lvalue references are experimental");
+	return o;
     }
 
     /* [20011101.069] File test operators interpret OPf_REF to mean that
@@ -5669,6 +5697,7 @@ S_assignment_type(pTHX_ const OP *o)
 {
     unsigned type;
     U8 flags;
+    U8 ret;
 
     if (!o)
 	return TRUE;
@@ -5691,12 +5720,17 @@ S_assignment_type(pTHX_ const OP *o)
     }
 
     if (type == OP_SREFGEN)
-	return ASSIGN_REF;
+    {
+	ret = ASSIGN_REF;
+	type = cUNOPx(cUNOPo->op_first)->op_first->op_type;
+	flags |= cUNOPx(cUNOPo->op_first)->op_first->op_flags;
+    }
+    else ret = 0;
 
     if (type == OP_LIST &&
 	(flags & OPf_WANT) == OPf_WANT_SCALAR &&
 	o->op_private & OPpLVAL_INTRO)
-	return FALSE;
+	return ret;
 
     if (type == OP_LIST || flags & OPf_PARENS ||
 	type == OP_RV2AV || type == OP_RV2HV ||
@@ -5708,9 +5742,9 @@ S_assignment_type(pTHX_ const OP *o)
 	return TRUE;
 
     if (type == OP_RV2SV)
-	return FALSE;
+	return ret;
 
-    return FALSE;
+    return ret;
 }
 
 /*
diff --git a/pp.c b/pp.c
index 1afacd4df7..bcfd217fa8 100644
--- a/pp.c
+++ b/pp.c
@@ -6192,7 +6192,11 @@ PP(pp_refassign)
 
 PP(pp_lvref)
 {
-    DIE(aTHX_ "Unimplemented");
+    dSP;
+    SV * const ret = sv_2mortal(newSV_type(SVt_PVMG));
+    sv_magic(ret, TOPs, PERL_MAGIC_lvref, NULL, 0);
+    SETs(ret);
+    return NORMAL;
 }
 
 /*
diff --git a/t/op/lvref.t b/t/op/lvref.t
index 1353c31b94..1fe91bd98e 100644
--- a/t/op/lvref.t
+++ b/t/op/lvref.t
@@ -4,7 +4,7 @@ BEGIN {
     set_up_inc("../lib");
 }
 
-plan 34;
+plan 37;
 
 sub on { $::TODO = ' ' }
 sub off{ $::TODO = ''  }
@@ -12,6 +12,9 @@ sub off{ $::TODO = ''  }
 eval '\$x = \$y';
 like $@, qr/^Experimental lvalue references not enabled/,
     'error when feature is disabled';
+eval '\($x) = \$y';
+like $@, qr/^Experimental lvalue references not enabled/,
+    'error when feature is disabled (aassign)';
 
 use feature 'lvalue_refs';
 
@@ -22,6 +25,11 @@ use feature 'lvalue_refs';
     is $c, 1, 'one warning from lv ref assignment';
     like $w, qr/^Lvalue references are experimental/,
         'experimental warning';
+    undef $c;
+    eval '\($x) = \$y';
+    is $c, 1, 'one warning from lv ref list assignment';
+    like $w, qr/^Lvalue references are experimental/,
+        'experimental warning';
 }
 
 no warnings 'experimental::lvalue_refs';
@@ -35,16 +43,17 @@ my $m;
 is \$m, \$y, '\$lexical = ...';
 \my $n = \$y;
 is \$n, \$y, '\my $lexical = ...';
-on;
 @_ = \$_;
-eval '\($x) = @_';
+\($x) = @_;
 is \$x, \$_, '\($pkgvar) = ... gives list context';
 undef *x;
-eval '(\$x) = @_';
+(\$x) = @_;
 is \$x, \$_, '(\$pkgvar) = ... gives list context';
+on;
 my $o;
 eval '\($o) = @_';
 is \$o, \$_, '\($lexical) = ... gives list cx';
+my $q;
 eval '(\$q) = @_';
 is \$q, \$_, '(\$lexical) = ... gives list cx';
 eval '\(my $p) = @_';
@@ -88,9 +97,11 @@ on;
 
 # Mixed (List) Assignments
 
-eval '(\$tahi, $rua) = \(1,2)';
+off;
+(\$tahi, $rua) = \(1,2);
 is join(' ', $tahi, $$rua), '1 2',
   'mixed scalar ref and scalar list assignment';
+on;
 $_ = 3;
 eval '$_ == 3 ? \$tahi : $rua = \3';
 is $tahi, 3, 'cond assignment resolving to scalar ref';