Consolidated lvalue sub changes

Message-ID: <14941.16925.736415.785818@soda.csua.berkeley.edu>

p4raw-id: //depot/perl@8417

20 files changed, 271 insertions, 93 deletions

diff --git a/doop.c b/doop.c
index 526409c16c..1495953955 100644
--- a/doop.c
+++ b/doop.c
@@ -1206,7 +1206,7 @@ Perl_do_kv(pTHX)
 	dokeys = dovalues = TRUE;
 
     if (!hv) {
-	if (PL_op->op_flags & OPf_MOD) {	/* lvalue */
+	if (PL_op->op_flags & OPf_MOD || LVRET) {	/* lvalue */
 	    dTARGET;		/* make sure to clear its target here */
 	    if (SvTYPE(TARG) == SVt_PVLV)
 		LvTARG(TARG) = Nullsv;
@@ -1225,7 +1225,7 @@ Perl_do_kv(pTHX)
 	IV i;
 	dTARGET;
 
-	if (PL_op->op_flags & OPf_MOD) {	/* lvalue */
+	if (PL_op->op_flags & OPf_MOD || LVRET) {	/* lvalue */
 	    if (SvTYPE(TARG) < SVt_PVLV) {
 		sv_upgrade(TARG, SVt_PVLV);
 		sv_magic(TARG, Nullsv, 'k', Nullch, 0);
diff --git a/embed.h b/embed.h
index 76bb2d87e8..81af43e037 100644
--- a/embed.h
+++ b/embed.h
@@ -274,6 +274,7 @@
 #define io_close		Perl_io_close
 #define invert			Perl_invert
 #define is_gv_magical		Perl_is_gv_magical
+#define is_lvalue_sub		Perl_is_lvalue_sub
 #define is_uni_alnum		Perl_is_uni_alnum
 #define is_uni_alnumc		Perl_is_uni_alnumc
 #define is_uni_idfirst		Perl_is_uni_idfirst
@@ -1181,6 +1182,7 @@
 #define ck_open			Perl_ck_open
 #define ck_repeat		Perl_ck_repeat
 #define ck_require		Perl_ck_require
+#define ck_return		Perl_ck_return
 #define ck_rfun			Perl_ck_rfun
 #define ck_rvconst		Perl_ck_rvconst
 #define ck_sassign		Perl_ck_sassign
@@ -1752,6 +1754,7 @@
 #define io_close(a,b)		Perl_io_close(aTHX_ a,b)
 #define invert(a)		Perl_invert(aTHX_ a)
 #define is_gv_magical(a,b,c)	Perl_is_gv_magical(aTHX_ a,b,c)
+#define is_lvalue_sub()		Perl_is_lvalue_sub(aTHX)
 #define is_uni_alnum(a)		Perl_is_uni_alnum(aTHX_ a)
 #define is_uni_alnumc(a)	Perl_is_uni_alnumc(aTHX_ a)
 #define is_uni_idfirst(a)	Perl_is_uni_idfirst(aTHX_ a)
@@ -2647,6 +2650,7 @@
 #define ck_open(a)		Perl_ck_open(aTHX_ a)
 #define ck_repeat(a)		Perl_ck_repeat(aTHX_ a)
 #define ck_require(a)		Perl_ck_require(aTHX_ a)
+#define ck_return(a)		Perl_ck_return(aTHX_ a)
 #define ck_rfun(a)		Perl_ck_rfun(aTHX_ a)
 #define ck_rvconst(a)		Perl_ck_rvconst(aTHX_ a)
 #define ck_sassign(a)		Perl_ck_sassign(aTHX_ a)
@@ -3433,6 +3437,8 @@
 #define invert			Perl_invert
 #define Perl_is_gv_magical	CPerlObj::Perl_is_gv_magical
 #define is_gv_magical		Perl_is_gv_magical
+#define Perl_is_lvalue_sub	CPerlObj::Perl_is_lvalue_sub
+#define is_lvalue_sub		Perl_is_lvalue_sub
 #define Perl_is_uni_alnum	CPerlObj::Perl_is_uni_alnum
 #define is_uni_alnum		Perl_is_uni_alnum
 #define Perl_is_uni_alnumc	CPerlObj::Perl_is_uni_alnumc
@@ -5136,6 +5142,8 @@
 #define ck_repeat		Perl_ck_repeat
 #define Perl_ck_require		CPerlObj::Perl_ck_require
 #define ck_require		Perl_ck_require
+#define Perl_ck_return		CPerlObj::Perl_ck_return
+#define ck_return		Perl_ck_return
 #define Perl_ck_rfun		CPerlObj::Perl_ck_rfun
 #define ck_rfun			Perl_ck_rfun
 #define Perl_ck_rvconst		CPerlObj::Perl_ck_rvconst
diff --git a/embed.pl b/embed.pl
index 3b5b6df998..7621f661c4 100755
--- a/embed.pl
+++ b/embed.pl
@@ -1593,6 +1593,7 @@ Ap	|char*	|instr		|const char* big|const char* little
 p	|bool	|io_close	|IO* io|bool not_implicit
 p	|OP*	|invert		|OP* cmd
 dp	|bool	|is_gv_magical	|char *name|STRLEN len|U32 flags
+p	|I32	|is_lvalue_sub
 Ap	|bool	|is_uni_alnum	|U32 c
 Ap	|bool	|is_uni_alnumc	|U32 c
 Ap	|bool	|is_uni_idfirst	|U32 c
diff --git a/op.c b/op.c
index d12eecc471..74859345e5 100644
--- a/op.c
+++ b/op.c
@@ -1559,9 +1559,12 @@ Perl_mod(pTHX_ OP *o, I32 type)
 	    goto nomod;
 	ref(cUNOPo->op_first, o->op_type);
 	/* FALL THROUGH */
-    case OP_AASSIGN:
     case OP_ASLICE:
     case OP_HSLICE:
+	if (type == OP_LEAVESUBLV)
+	    o->op_private |= OPpMAYBE_LVSUB;
+	/* FALL THROUGH */
+    case OP_AASSIGN:
     case OP_NEXTSTATE:
     case OP_DBSTATE:
     case OP_REFGEN:
@@ -1590,6 +1593,8 @@ Perl_mod(pTHX_ OP *o, I32 type)
 	    return o;		/* Treat \(@foo) like ordinary list. */
 	if (scalar_mod_type(o, type))
 	    goto nomod;
+	if (type == OP_LEAVESUBLV)
+	    o->op_private |= OPpMAYBE_LVSUB;
 	/* FALL THROUGH */
     case OP_PADSV:
 	PL_modcount++;
@@ -1617,6 +1622,8 @@ Perl_mod(pTHX_ OP *o, I32 type)
 	/* FALL THROUGH */
     case OP_POS:
     case OP_VEC:
+	if (type == OP_LEAVESUBLV)
+	    o->op_private |= OPpMAYBE_LVSUB;
       lvalue_func:
 	pad_free(o->op_targ);
 	o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
@@ -1631,12 +1638,15 @@ Perl_mod(pTHX_ OP *o, I32 type)
 	if (type == OP_ENTERSUB &&
 	     !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
 	    o->op_private |= OPpLVAL_DEFER;
+	if (type == OP_LEAVESUBLV)
+	    o->op_private |= OPpMAYBE_LVSUB;
 	PL_modcount++;
 	break;
 
     case OP_SCOPE:
     case OP_LEAVE:
     case OP_ENTER:
+    case OP_LINESEQ:
 	if (o->op_flags & OPf_KIDS)
 	    mod(cLISTOPo->op_last, type);
 	break;
@@ -1655,8 +1665,14 @@ Perl_mod(pTHX_ OP *o, I32 type)
 	for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
 	    mod(kid, type);
 	break;
+
+    case OP_RETURN:
+	if (type != OP_LEAVESUBLV)
+	    goto nomod;
+	break; /* mod()ing was handled by ck_return() */
     }
-    o->op_flags |= OPf_MOD;
+    if (type != OP_LEAVESUBLV)
+        o->op_flags |= OPf_MOD;
 
     if (type == OP_AASSIGN || type == OP_SASSIGN)
 	o->op_flags |= OPf_SPECIAL|OPf_REF;
@@ -1665,7 +1681,8 @@ Perl_mod(pTHX_ OP *o, I32 type)
 	o->op_flags &= ~OPf_SPECIAL;
 	PL_hints |= HINT_BLOCK_SCOPE;
     }
-    else if (type != OP_GREPSTART && type != OP_ENTERSUB)
+    else if (type != OP_GREPSTART && type != OP_ENTERSUB
+             && type != OP_LEAVESUBLV)
 	o->op_flags |= OPf_REF;
     return o;
 }
@@ -4689,7 +4706,8 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
 	av_store(PL_comppad_name, AvFILLp(PL_comppad), Nullsv);
 
     if (CvLVALUE(cv)) {
-	CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0, scalarseq(block));
+	CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
+			     mod(scalarseq(block), OP_LEAVESUBLV));
     }
     else {
 	CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
@@ -6090,6 +6108,17 @@ Perl_ck_require(pTHX_ OP *o)
     return ck_fun(o);
 }
 
+OP *
+Perl_ck_return(pTHX_ OP *o)
+{
+    OP *kid;
+    if (CvLVALUE(PL_compcv)) {
+	for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
+	    mod(kid, OP_LEAVESUBLV);
+    }
+    return o;
+}
+
 #if 0
 OP *
 Perl_ck_retarget(pTHX_ OP *o)
@@ -6569,7 +6598,6 @@ Perl_peep(pTHX_ register OP *o)
 {
     register OP* oldop = 0;
     STRLEN n_a;
-    OP *last_composite = Nullop;
 
     if (!o || o->op_seq)
 	return;
@@ -6588,7 +6616,6 @@ Perl_peep(pTHX_ register OP *o)
 	case OP_DBSTATE:
 	    PL_curcop = ((COP*)o);		/* for warnings */
 	    o->op_seq = PL_op_seqmax++;
-	    last_composite = Nullop;
 	    break;
 
 	case OP_CONST:
@@ -6681,7 +6708,7 @@ Perl_peep(pTHX_ register OP *o)
 		    (PL_op = pop->op_next) &&
 		    pop->op_next->op_type == OP_AELEM &&
 		    !(pop->op_next->op_private &
-		      (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF)) &&
+		      (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
 		    (i = SvIV(((SVOP*)pop)->op_sv) - PL_compiling.cop_arybase)
 				<= 255 &&
 		    i >= 0)
@@ -6898,42 +6925,6 @@ Perl_peep(pTHX_ register OP *o)
 	    break;
 	}
 
-	case OP_RV2AV:
-	case OP_RV2HV:
-	    if (!(o->op_flags & OPf_WANT)
-		|| (o->op_flags & OPf_WANT) == OPf_WANT_LIST)
-	    {
-		last_composite = o;
-	    }
-	    o->op_seq = PL_op_seqmax++;
-	    break;
-
-	case OP_RETURN:
-	    if (o->op_next && o->op_next->op_type != OP_LEAVESUBLV) {
-		o->op_seq = PL_op_seqmax++;
-		break;
-	    }
-	    /* FALL THROUGH */
-
-	case OP_LEAVESUBLV:
-	    if (last_composite) {
-		OP *r = last_composite;
-
-		while (r->op_sibling)
-		   r = r->op_sibling;
-		if (r->op_next == o
-		    || (r->op_next->op_type == OP_LIST
-			&& r->op_next->op_next == o))
-		{
-		    if (last_composite->op_type == OP_RV2AV)
-			yyerror("Lvalue subs returning arrays not implemented yet");
-		    else
-			yyerror("Lvalue subs returning hashes not implemented yet");
-			;
-		}		
-	    }
-	    /* FALL THROUGH */
-
 	default:
 	    o->op_seq = PL_op_seqmax++;
 	    break;
diff --git a/op.h b/op.h
index 7dc118e2fb..a484992ff1 100644
--- a/op.h
+++ b/op.h
@@ -156,7 +156,9 @@ Deprecated.  Use C<GIMME_V> instead.
   /* OP_?ELEM only */
 #define OPpLVAL_DEFER		16	/* Defer creation of array/hash elem */
   /* OP_RV2?V, OP_GVSV only */
-#define OPpOUR_INTRO		16	/* Defer creation of array/hash elem */
+#define OPpOUR_INTRO		16	/* Variable was in an our() */
+  /* OP_RV2[AH]V, OP_PAD[AH]V, OP_[AH]ELEM */
+#define OPpMAYBE_LVSUB		8	/* We might be an lvalue to return */
   /* for OP_RV2?V, lower bits carry hints (currently only HINT_STRICT_REFS) */
 
 /* Private for OPs with TARGLEX */
diff --git a/opcode.h b/opcode.h
index 8dc8b7ae6b..542ec60c8b 100644
--- a/opcode.h
+++ b/opcode.h
@@ -541,7 +541,7 @@ EXT char *PL_op_desc[] = {
 	"method lookup",
 	"subroutine entry",
 	"subroutine exit",
-	"lvalue subroutine exit",
+	"lvalue subroutine return",
 	"caller",
 	"warn",
 	"die",
@@ -1278,7 +1278,7 @@ EXT OP * (CPERLscope(*PL_check)[]) (pTHX_ OP *op) = {
 	MEMBER_TO_FPTR(Perl_ck_null),	/* iter */
 	MEMBER_TO_FPTR(Perl_ck_null),	/* enterloop */
 	MEMBER_TO_FPTR(Perl_ck_null),	/* leaveloop */
-	MEMBER_TO_FPTR(Perl_ck_null),	/* return */
+	MEMBER_TO_FPTR(Perl_ck_return),	/* return */
 	MEMBER_TO_FPTR(Perl_ck_null),	/* last */
 	MEMBER_TO_FPTR(Perl_ck_null),	/* next */
 	MEMBER_TO_FPTR(Perl_ck_null),	/* redo */
diff --git a/opcode.pl b/opcode.pl
index 22bffb8216..2e6ae01a1d 100755
--- a/opcode.pl
+++ b/opcode.pl
@@ -599,7 +599,7 @@ orassign	logical or assignment (||=)	ck_null		s|
 method		method lookup		ck_method	d1
 entersub	subroutine entry	ck_subr		dmt1	L
 leavesub	subroutine exit		ck_null		1	
-leavesublv	lvalue subroutine exit	ck_null		1	
+leavesublv	lvalue subroutine return	ck_null		1	
 caller		caller			ck_fun		t%	S?
 warn		warn			ck_fun		imst@	L
 die		die			ck_fun		dimst@	L
@@ -616,7 +616,7 @@ enteriter	foreach loop entry	ck_null		d{
 iter		foreach loop iterator	ck_null		0	
 enterloop	loop entry		ck_null		d{	
 leaveloop	loop exit		ck_null		2	
-return		return			ck_null		dm@	L
+return		return			ck_return	dm@	L
 last		last			ck_null		ds}	
 next		next			ck_null		ds}	
 redo		redo			ck_null		ds}	
diff --git a/pod/perldiag.pod b/pod/perldiag.pod
index 22a24bece6..597473f047 100644
--- a/pod/perldiag.pod
+++ b/pod/perldiag.pod
@@ -929,6 +929,14 @@ suidperl.
 temporary or readonly values) from a subroutine used as an lvalue.  This
 is not allowed.
 
+=item Can't return %s to lvalue scalar context
+
+(F) You tried to return a complete array or hash from an lvalue subroutine,
+but you called the subroutine in a way that made Perl think you meant
+to return only one value. You probably meant to write parentheses around
+the call to the subroutine, which tell Perl that the call should be in
+list context.
+
 =item Can't return outside a subroutine
 
 (F) The return statement was executed in mainline code, that is, where
diff --git a/pod/perlintern.pod b/pod/perlintern.pod
index b63b694131..6af18b507c 100644
--- a/pod/perlintern.pod
+++ b/pod/perlintern.pod
@@ -39,6 +39,13 @@ allow selecting particular classes of magical variable.
 =for hackers
 Found in file gv.c
 
+=item LVRET
+
+True if this op will be the return value of an lvalue subroutine
+
+=for hackers
+Found in file pp.h
+
 =item start_glob
 
 Function called by C<do_readline> to spawn a glob (or do the glob inside
diff --git a/pod/perlsub.pod b/pod/perlsub.pod
index cef8050731..b440cd1d93 100644
--- a/pod/perlsub.pod
+++ b/pod/perlsub.pod
@@ -645,10 +645,6 @@ and in:
 
 all the subroutines are called in a list context.
 
-The current implementation does not allow arrays and hashes to be
-returned from lvalue subroutines directly.  You may return a
-reference instead.  This restriction may be lifted in future.
-
 =head2 Passing Symbol Table Entries (typeglobs)
 
 B<WARNING>: The mechanism described in this section was originally
diff --git a/pp.c b/pp.c
index 784c7bf4b1..ba6c17a773 100644
--- a/pp.c
+++ b/pp.c
@@ -114,6 +114,11 @@ PP(pp_padav)
     if (PL_op->op_flags & OPf_REF) {
 	PUSHs(TARG);
 	RETURN;
+    } else if (LVRET) {
+	if (GIMME == G_SCALAR)
+	    Perl_croak(aTHX_ "Can't return array to lvalue scalar context");
+	PUSHs(TARG);
+	RETURN;
     }
     if (GIMME == G_ARRAY) {
 	I32 maxarg = AvFILL((AV*)TARG) + 1;
@@ -149,6 +154,11 @@ PP(pp_padhv)
 	SAVECLEARSV(PL_curpad[PL_op->op_targ]);
     if (PL_op->op_flags & OPf_REF)
 	RETURN;
+    else if (LVRET) {
+	if (GIMME == G_SCALAR)
+	    Perl_croak(aTHX_ "Can't return hash to lvalue scalar context");
+	RETURN;
+    }
     gimme = GIMME_V;
     if (gimme == G_ARRAY) {
 	RETURNOP(do_kv());
@@ -341,7 +351,7 @@ PP(pp_pos)
 {
     djSP; dTARGET; dPOPss;
 
-    if (PL_op->op_flags & OPf_MOD) {
+    if (PL_op->op_flags & OPf_MOD || LVRET) {
 	if (SvTYPE(TARG) < SVt_PVLV) {
 	    sv_upgrade(TARG, SVt_PVLV);
 	    sv_magic(TARG, Nullsv, '.', Nullch, 0);
@@ -2711,16 +2721,17 @@ PP(pp_substr)
     I32 pos;
     I32 rem;
     I32 fail;
-    I32 lvalue = PL_op->op_flags & OPf_MOD;
+    I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
     char *tmps;
     I32 arybase = PL_curcop->cop_arybase;
     char *repl = 0;
     STRLEN repl_len;
+    int num_args = PL_op->op_private & 7;
 
     SvTAINTED_off(TARG);			/* decontaminate */
     SvUTF8_off(TARG);				/* decontaminate */
-    if (MAXARG > 2) {
-	if (MAXARG > 3) {
+    if (num_args > 2) {
+	if (num_args > 3) {
 	    sv = POPs;
 	    repl = SvPV(sv, repl_len);
 	}
@@ -2744,7 +2755,7 @@ PP(pp_substr)
 	pos -= arybase;
 	rem = curlen-pos;
 	fail = rem;
-	if (MAXARG > 2) {
+	if (num_args > 2) {
 	    if (len < 0) {
 		rem += len;
 		if (rem < 0)
@@ -2756,7 +2767,7 @@ PP(pp_substr)
     }
     else {
 	pos += curlen;
-	if (MAXARG < 3)
+	if (num_args < 3)
 	    rem = curlen;
 	else if (len >= 0) {
 	    rem = pos+len;
@@ -2830,7 +2841,7 @@ PP(pp_vec)
     register IV size   = POPi;
     register IV offset = POPi;
     register SV *src = POPs;
-    I32 lvalue = PL_op->op_flags & OPf_MOD;
+    I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
 
     SvTAINTED_off(TARG);		/* decontaminate */
     if (lvalue) {			/* it's an lvalue! */
@@ -3329,7 +3340,7 @@ PP(pp_aslice)
     djSP; dMARK; dORIGMARK;
     register SV** svp;
     register AV* av = (AV*)POPs;
-    register I32 lval = PL_op->op_flags & OPf_MOD;
+    register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
     I32 arybase = PL_curcop->cop_arybase;
     I32 elem;
 
@@ -3516,7 +3527,7 @@ PP(pp_hslice)
 {
     djSP; dMARK; dORIGMARK;
     register HV *hv = (HV*)POPs;
-    register I32 lval = PL_op->op_flags & OPf_MOD;
+    register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
     I32 realhv = (SvTYPE(hv) == SVt_PVHV);
 
     if (!realhv && PL_op->op_private & OPpLVAL_INTRO)
diff --git a/pp.h b/pp.h
index 2905e17df0..81bf0225a1 100644
--- a/pp.h
+++ b/pp.h
@@ -380,3 +380,10 @@ See C<PUSHu>.
     SvREFCNT_dec(tmpRef);                   \
     SvRV(rv)=AMG_CALLun(rv,copy);        \
   } } STMT_END
+
+/*
+=for apidoc mU||LVRET
+True if this op will be the return value of an lvalue subroutine
+
+=cut */
+#define LVRET ((PL_op->op_private & OPpMAYBE_LVSUB) && Perl_is_lvalue_sub())
diff --git a/pp.sym b/pp.sym
index 42b29f6967..2bd3922153 100644
--- a/pp.sym
+++ b/pp.sym
@@ -30,6 +30,7 @@ Perl_ck_null
 Perl_ck_open
 Perl_ck_repeat
 Perl_ck_require
+Perl_ck_return
 Perl_ck_rfun
 Perl_ck_rvconst
 Perl_ck_sassign
diff --git a/pp_ctl.c b/pp_ctl.c
index 70c3ea3e73..07545dc28a 100644
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -1240,6 +1240,20 @@ Perl_block_gimme(pTHX)
     }
 }
 
+I32
+Perl_is_lvalue_sub(pTHX)
+{
+    I32 cxix;
+
+    cxix = dopoptosub(cxstack_ix);
+    assert(cxix >= 0);  /* We should only be called from inside subs */
+
+    if (cxstack[cxix].blk_sub.lval && CvLVALUE(cxstack[cxix].blk_sub.cv))
+	return cxstack[cxix].blk_sub.lval;
+    else
+	return 0;
+}
+
 STATIC I32
 S_dopoptosub(pTHX_ I32 startingblock)
 {
diff --git a/pp_hot.c b/pp_hot.c
index df666473ad..3a1e08daaf 100644
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -611,6 +611,12 @@ PP(pp_rv2av)
 	    SETs((SV*)av);
 	    RETURN;
 	}
+	else if (LVRET) {
+	    if (GIMME == G_SCALAR)
+		Perl_croak(aTHX_ "Can't return array to lvalue scalar context");
+	    SETs((SV*)av);
+	    RETURN;
+	}
     }
     else {
 	if (SvTYPE(sv) == SVt_PVAV) {
@@ -619,6 +625,13 @@ PP(pp_rv2av)
 		SETs((SV*)av);
 		RETURN;
 	    }
+	    else if (LVRET) {
+		if (GIMME == G_SCALAR)
+		    Perl_croak(aTHX_ "Can't return array to lvalue"
+			       " scalar context");
+		SETs((SV*)av);
+		RETURN;
+	    }
 	}
 	else {
 	    GV *gv;
@@ -672,6 +685,13 @@ PP(pp_rv2av)
 		SETs((SV*)av);
 		RETURN;
 	    }
+	    else if (LVRET) {
+		if (GIMME == G_SCALAR)
+		    Perl_croak(aTHX_ "Can't return array to lvalue"
+			       " scalar context");
+		SETs((SV*)av);
+		RETURN;
+	    }
 	}
     }
 
@@ -715,6 +735,12 @@ PP(pp_rv2hv)
 	    SETs((SV*)hv);
 	    RETURN;
 	}
+	else if (LVRET) {
+	    if (GIMME == G_SCALAR)
+		Perl_croak(aTHX_ "Can't return hash to lvalue scalar context");
+	    SETs((SV*)hv);
+	    RETURN;
+	}
     }
     else {
 	if (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV) {
@@ -723,6 +749,13 @@ PP(pp_rv2hv)
 		SETs((SV*)hv);
 		RETURN;
 	    }
+	    else if (LVRET) {
+		if (GIMME == G_SCALAR)
+		    Perl_croak(aTHX_ "Can't return hash to lvalue"
+			       " scalar context");
+		SETs((SV*)hv);
+		RETURN;
+	    }
 	}
 	else {
 	    GV *gv;
@@ -776,6 +809,13 @@ PP(pp_rv2hv)
 		SETs((SV*)hv);
 		RETURN;
 	    }
+	    else if (LVRET) {
+		if (GIMME == G_SCALAR)
+		    Perl_croak(aTHX_ "Can't return hash to lvalue"
+			       " scalar context");
+		SETs((SV*)hv);
+		RETURN;
+	    }
 	}
     }
 
@@ -1532,7 +1572,7 @@ PP(pp_helem)
     SV **svp;
     SV *keysv = POPs;
     HV *hv = (HV*)POPs;
-    U32 lval = PL_op->op_flags & OPf_MOD;
+    U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
     U32 defer = PL_op->op_private & OPpLVAL_DEFER;
     SV *sv;
     U32 hash = (SvFAKE(keysv) && SvREADONLY(keysv)) ? SvUVX(keysv) : 0;
@@ -2785,7 +2825,7 @@ PP(pp_aelem)
     SV* elemsv = POPs;
     IV elem = SvIV(elemsv);
     AV* av = (AV*)POPs;
-    U32 lval = PL_op->op_flags & OPf_MOD;
+    U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
     U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > AvFILL(av));
     SV *sv;
 
diff --git a/pp_proto.h b/pp_proto.h
index c249ecbdd7..c3b24e864b 100644
--- a/pp_proto.h
+++ b/pp_proto.h
@@ -29,6 +29,7 @@ PERL_CKDEF(Perl_ck_null)
 PERL_CKDEF(Perl_ck_open)
 PERL_CKDEF(Perl_ck_repeat)
 PERL_CKDEF(Perl_ck_require)
+PERL_CKDEF(Perl_ck_return)
 PERL_CKDEF(Perl_ck_rfun)
 PERL_CKDEF(Perl_ck_rvconst)
 PERL_CKDEF(Perl_ck_sassign)
diff --git a/proto.h b/proto.h
index e83d8fd8ec..a8e849e941 100644
--- a/proto.h
+++ b/proto.h
@@ -332,6 +332,7 @@ PERL_CALLCONV char*	Perl_instr(pTHX_ const char* big, const char* little);
 PERL_CALLCONV bool	Perl_io_close(pTHX_ IO* io, bool not_implicit);
 PERL_CALLCONV OP*	Perl_invert(pTHX_ OP* cmd);
 PERL_CALLCONV bool	Perl_is_gv_magical(pTHX_ char *name, STRLEN len, U32 flags);
+PERL_CALLCONV I32	Perl_is_lvalue_sub(pTHX);
 PERL_CALLCONV bool	Perl_is_uni_alnum(pTHX_ U32 c);
 PERL_CALLCONV bool	Perl_is_uni_alnumc(pTHX_ U32 c);
 PERL_CALLCONV bool	Perl_is_uni_idfirst(pTHX_ U32 c);
diff --git a/t/lib/b.t b/t/lib/b.t
index 4329d717d7..42760c8f15 100755
--- a/t/lib/b.t
+++ b/t/lib/b.t
@@ -34,21 +34,21 @@ ok;
 my $a = <<'EOF';
 {
     $test = sub : lvalue {
-        1;
+        my $x;
     }
     ;
 }
 EOF
 chomp $a;
-print "not " if $deparse->coderef2text(sub{$test = sub : lvalue { 1 }}) ne $a;
+print "not " if $deparse->coderef2text(sub{$test = sub : lvalue{my $x}}) ne $a;
 ok;
 
 $a =~ s/lvalue/method/;
-print "not " if $deparse->coderef2text(sub{$test = sub : method { 1 }}) ne $a;
+print "not " if $deparse->coderef2text(sub{$test = sub : method{my $x}}) ne $a;
 ok;
 
 $a =~ s/method/locked method/;
-print "not " if $deparse->coderef2text(sub{$test = sub : method locked { 1 }})
+print "not " if $deparse->coderef2text(sub{$test = sub : method locked {my $x}})
                                      ne $a;
 ok;
 }
diff --git a/t/pragma/sub_lval.t b/t/pragma/sub_lval.t
index a54075dd64..00080c121d 100755
--- a/t/pragma/sub_lval.t
+++ b/t/pragma/sub_lval.t
@@ -1,12 +1,12 @@
-print "1..49\n";
+print "1..63\n";
 
 BEGIN {
     chdir 't' if -d 't';
     @INC = '../lib';
 }
 
-sub a : lvalue { my $a = 34; bless \$a }  # Return a temporary
-sub b : lvalue { shift }
+sub a : lvalue { my $a = 34; ${\(bless \$a)} }  # Return a temporary
+sub b : lvalue { ${\shift} }
 
 my $out = a(b());		# Check that temporaries are allowed.
 print "# `$out'\nnot " unless ref $out eq 'main'; # Not reached if error.
@@ -34,9 +34,9 @@ print "ok 3\n";
 
 sub get_lex : lvalue { $in }
 sub get_st : lvalue { $blah }
-sub id : lvalue { shift }
+sub id : lvalue { ${\shift} }
 sub id1 : lvalue { $_[0] }
-sub inc : lvalue { ++$_[0] }
+sub inc : lvalue { ${\++$_[0]} }
 
 $in = 5;
 $blah = 3;
@@ -288,40 +288,41 @@ print "# '$_'.\nnot "
 print "ok 34\n";
 
 $x = '1234567';
-sub lv1t : lvalue { index $x, 2 }
 
 $_ = undef;
 eval <<'EOE' or $_ = $@;
+  sub lv1t : lvalue { index $x, 2 }
   lv1t = (2,3);
   1;
 EOE
 
 print "# '$_'.\nnot "
-  unless /Can\'t return a temporary from lvalue subroutine/;
+  unless /Can\'t modify index in lvalue subroutine return/;
 print "ok 35\n";
 
 $_ = undef;
 eval <<'EOE' or $_ = $@;
-  (lv1t) = (2,3);
+  sub lv2t : lvalue { shift }
+  (lv2t) = (2,3);
   1;
 EOE
 
 print "# '$_'.\nnot "
-  unless /Can\'t return a temporary from lvalue subroutine/;
+  unless /Can\'t modify shift in lvalue subroutine return/;
 print "ok 36\n";
 
 $xxx = 'xxx';
 sub xxx () { $xxx }  # Not lvalue
-sub lv1tmp : lvalue { xxx }			# is it a TEMP?
 
 $_ = undef;
 eval <<'EOE' or $_ = $@;
+  sub lv1tmp : lvalue { xxx }			# is it a TEMP?
   lv1tmp = (2,3);
   1;
 EOE
 
 print "# '$_'.\nnot "
-  unless /Can\'t return a temporary from lvalue subroutine/;
+  unless /Can\'t modify non-lvalue subroutine call in lvalue subroutine return/;
 print "ok 37\n";
 
 $_ = undef;
@@ -335,16 +336,16 @@ print "# '$_'.\nnot "
 print "ok 38\n";
 
 sub yyy () { 'yyy' } # Const, not lvalue
-sub lv1tmpr : lvalue { yyy }			# is it read-only?
 
 $_ = undef;
 eval <<'EOE' or $_ = $@;
+  sub lv1tmpr : lvalue { yyy }			# is it read-only?
   lv1tmpr = (2,3);
   1;
 EOE
 
 print "# '$_'.\nnot "
-  unless /Can\'t return a readonly value from lvalue subroutine/;
+  unless /Can\'t modify constant item in lvalue subroutine return/;
 print "ok 39\n";
 
 $_ = undef;
@@ -357,8 +358,6 @@ print "# '$_'.\nnot "
   unless /Can\'t return a readonly value from lvalue subroutine/;
 print "ok 40\n";
 
-=for disabled constructs
-
 sub lva : lvalue {@a}
 
 $_ = undef;
@@ -369,8 +368,7 @@ eval <<'EOE' or $_ = $@;
   1;
 EOE
 
-print "# '$_'.\nnot "
-  unless /Can\'t return an uninitialized value from lvalue subroutine/;
+print "# '$_'.\nnot " unless "'@a' $_" eq "'2 3' ";
 print "ok 41\n";
 
 $_ = undef;
@@ -397,10 +395,6 @@ EOE
 print "# '$_'.\nnot " unless "'@a' $_" eq "'2 3' ";
 print "ok 43\n";
 
-=cut
-
-print "ok $_\n" for 41..43;
-
 sub lv1n : lvalue { $newvar }
 
 $_ = undef;
@@ -449,3 +443,87 @@ bar = *STDOUT;
 print bar "ok 49\n";
 unlink "nothing";
 
+{
+my %hash; my @array;
+sub alv : lvalue { $array[1] }
+sub alv2 : lvalue { $array[$_[0]] }
+sub hlv : lvalue { $hash{"foo"} }
+sub hlv2 : lvalue { $hash{$_[0]} }
+$array[1] = "not ok 51\n";
+alv() = "ok 50\n";
+print alv();
+
+alv2(20) = "ok 51\n";
+print $array[20];
+
+$hash{"foo"} = "not ok 52\n";
+hlv() = "ok 52\n";
+print $hash{foo};
+
+$hash{bar} = "not ok 53\n";
+hlv("bar") = "ok 53\n";
+print hlv("bar");
+
+sub array : lvalue  { @array  }
+sub array2 : lvalue { @array2 } # This is a global.
+sub hash : lvalue   { %hash   }
+sub hash2 : lvalue  { %hash2  } # So's this.
+@array2 = qw(foo bar);
+%hash2 = qw(foo bar);
+
+(array()) = qw(ok 54);
+print "not " unless "@array" eq "ok 54";
+print "ok 54\n";
+
+(array2()) = qw(ok 55);
+print "not " unless "@array2" eq "ok 55";
+print "ok 55\n";
+
+(hash()) = qw(ok 56);
+print "not " unless $hash{ok} == 56;
+print "ok 56\n";
+
+(hash2()) = qw(ok 57);
+print "not " unless $hash2{ok} == 57;
+print "ok 57\n";
+
+@array = qw(a b c d);
+sub aslice1 : lvalue { @array[0,2] };
+(aslice1()) = ("ok", "already");
+print "# @array\nnot " unless "@array" eq "ok b already d";
+print "ok 58\n";
+
+@array2 = qw(a B c d);
+sub aslice2 : lvalue { @array2[0,2] };
+(aslice2()) = ("ok", "already");
+print "not " unless "@array2" eq "ok B already d";
+print "ok 59\n";
+
+%hash = qw(a Alpha b Beta c Gamma);
+sub hslice : lvalue { @hash{"c", "b"} }
+(hslice()) = ("CISC", "BogoMIPS");
+print "not " unless join("/",@hash{"c","a","b"}) eq "CISC/Alpha/BogoMIPS";
+print "ok 60\n";
+}
+
+$str = "Hello, world!";
+sub sstr : lvalue { substr($str, 1, 4) }
+sstr() = "i";
+print "not " unless $str eq "Hi, world!";
+print "ok 61\n";
+
+$str = "Made w/ JavaScript";
+sub veclv : lvalue { vec($str, 2, 32) }
+veclv() = 0x5065726C;
+print "# $str\nnot " unless $str eq "Made w/ PerlScript";
+print "ok 62\n";
+
+sub position : lvalue { pos }
+@p = ();
+$_ = "fee fi fo fum";
+while (/f/g) {
+    push @p, position;
+    position() += 6;
+}
+print "# @p\nnot " unless "@p" eq "1 8";
+print "ok 63\n";
diff --git a/toke.c b/toke.c
index 62850846a7..b82a7c4e9b 100644
--- a/toke.c
+++ b/toke.c
@@ -3024,9 +3024,21 @@ Perl_yylex(pTHX)
 		    PL_lex_stuff = Nullsv;
 		}
 		else {
-		    attrs = append_elem(OP_LIST, attrs,
-					newSVOP(OP_CONST, 0,
-						newSVpvn(s, len)));
+		    if (!PL_in_my && len == 6 && strnEQ(s, "lvalue", len))
+			CvLVALUE_on(PL_compcv);
+		    else if (!PL_in_my && len == 6 && strnEQ(s, "locked", len))
+			CvLOCKED_on(PL_compcv);
+		    else if (!PL_in_my && len == 6 && strnEQ(s, "method", len))
+			CvMETHOD_on(PL_compcv);
+		    /* After we've set the flags, it could be argued that
+		       we don't need to do the attributes.pm-based setting
+		       process, and shouldn't bother appending recognized
+		       flags. To experiment with that, uncomment the
+		       following "else": */
+		    /* else */
+		        attrs = append_elem(OP_LIST, attrs,
+					    newSVOP(OP_CONST, 0,
+					      	    newSVpvn(s, len)));
 		}
 		s = skipspace(d);
 		if (*s == ':' && s[1] != ':')