develooper Front page | perl.perl5.porters | Postings from January 2001

[PATCH @8404] Consolidated lvalue sub changes

Thread Next
From:
Stephen McCamant
Date:
January 10, 2001 21:36
Subject:
[PATCH @8404] Consolidated lvalue sub changes
Message ID:
14941.16925.736415.785818@soda.csua.berkeley.edu
Whew. The following patch against perl-current subsumes Simon's two
recent lvalue subroutine patch (array and hash elements, and whole
arrays and hashes), plus the everything from the working snapshot I
posted earlier, plus croaks to keep returning an array to scalar
lvalue context from segfaulting, plus a change to set attributes
earlier (but keeping the later setting too, for the
backwards-compatibility police), plus changes to enable lvalue returns 
of array and hash slices and lvalue calls to substr(), pos() and
vec(), and tests.

I didn't feel like there was a consensus about stronger compile-time
checking of lvalue returns, so I just followed my own tastes and left
the code in the strict-checking mode. The tests were updated to match
the new behavior.

This code sets flags for the arguments to return, but since the
version I'm patching against doesn't do leavesublv-ish things in
pp_return, lvalue return()s don't really work, and aren't tested.

 -- Stephen McC

--- perl-current/opcode.pl	Sun Dec 31 09:27:14 2000
+++ perl+lval2/opcode.pl	Wed Jan 10 20:24:56 2001
@@ -599,7 +599,7 @@
 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 @@
 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}	
--- perl-current/embed.pl	Tue Jan  9 09:07:51 2001
+++ perl+lval2/embed.pl	Wed Jan 10 17:48:45 2001
@@ -1593,6 +1593,7 @@
 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
--- perl-current/op.h	Thu Jan  4 12:54:19 2001
+++ perl+lval2/op.h	Wed Jan 10 18:01:17 2001
@@ -156,7 +156,9 @@
   /* 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 */
--- perl-current/pp.h	Sun Dec 31 18:02:31 2000
+++ perl+lval2/pp.h	Wed Jan 10 17:57:56 2001
@@ -380,3 +380,10 @@
     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())
--- perl-current/op.c	Tue Jan  9 09:07:51 2001
+++ perl+lval2/op.c	Wed Jan 10 22:53:22 2001
@@ -1558,9 +1558,12 @@
 	    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:
@@ -1589,6 +1592,8 @@
 	    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++;
@@ -1616,6 +1621,8 @@
 	/* 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);
@@ -1630,12 +1637,15 @@
 	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;
@@ -1654,8 +1664,14 @@
 	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;
@@ -1664,7 +1680,8 @@
 	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;
 }
@@ -4688,7 +4705,8 @@
 	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));
@@ -6089,6 +6107,17 @@
     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)
@@ -6568,7 +6597,6 @@
 {
     register OP* oldop = 0;
     STRLEN n_a;
-    OP *last_composite = Nullop;
 
     if (!o || o->op_seq)
 	return;
@@ -6587,7 +6615,6 @@
 	case OP_DBSTATE:
 	    PL_curcop = ((COP*)o);		/* for warnings */
 	    o->op_seq = PL_op_seqmax++;
-	    last_composite = Nullop;
 	    break;
 
 	case OP_CONST:
@@ -6680,7 +6707,7 @@
 		    (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)
@@ -6896,42 +6923,6 @@
 	    }
 	    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++;
--- perl-current/toke.c	Tue Jan  9 09:07:51 2001
+++ perl+lval2/toke.c	Wed Jan 10 17:22:07 2001
@@ -3023,9 +3023,21 @@
 		    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] != ':')
--- perl-current/doop.c	Tue Jan  9 21:18:13 2001
+++ perl+lval2/doop.c	Wed Jan 10 22:09:53 2001
@@ -1206,7 +1206,7 @@
 	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 @@
 	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);
--- perl-current/pp.c	Tue Jan  9 15:08:01 2001
+++ perl+lval2/pp.c	Wed Jan 10 22:22:55 2001
@@ -114,6 +114,11 @@
     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 @@
 	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 @@
 {
     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 @@
     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 @@
 	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 @@
     }
     else {
 	pos += curlen;
-	if (MAXARG < 3)
+	if (num_args < 3)
 	    rem = curlen;
 	else if (len >= 0) {
 	    rem = pos+len;
@@ -2830,7 +2841,7 @@
     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 @@
     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 @@
 {
     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)
--- perl-current/pp_hot.c	Tue Jan  9 15:08:01 2001
+++ perl+lval2/pp_hot.c	Wed Jan 10 20:59:04 2001
@@ -611,6 +611,12 @@
 	    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 @@
 		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 @@
 		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 @@
 	    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 @@
 		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 @@
 		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 @@
     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 @@
     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;
 
--- perl-current/pp_ctl.c	Fri Jan  5 00:44:57 2001
+++ perl+lval2/pp_ctl.c	Wed Jan 10 17:47:07 2001
@@ -1240,6 +1240,20 @@
     }
 }
 
+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)
 {
--- perl-current/pod/perlsub.pod	Fri Dec 22 09:33:01 2000
+++ perl+lval2/pod/perlsub.pod	Wed Jan 10 20:32:13 2001
@@ -645,10 +645,6 @@
 
 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
--- perl-current/pod/perldiag.pod	Thu Dec 28 17:35:12 2000
+++ perl+lval2/pod/perldiag.pod	Wed Jan 10 21:12:45 2001
@@ -929,6 +929,14 @@
 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
--- perl-current/t/pragma/sub_lval.t	Fri Dec 29 11:45:46 2000
+++ perl+lval2/t/pragma/sub_lval.t	Wed Jan 10 22:53:35 2001
@@ -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 @@
 
 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 "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 "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 @@
   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 @@
   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 @@
 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 @@
 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";
--- perl-current/t/lib/b.t	Thu Jan  4 12:54:19 2001
+++ perl+lval2/t/lib/b.t	Wed Jan 10 23:01:38 2001
@@ -34,21 +34,21 @@
 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;
 }

Thread Next


nntp.perl.org: Perl Programming lists via nntp and http.
Comments to Ask Bjørn Hansen at ask@perl.org | Group listing | About