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;
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);
#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
#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
#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)
#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)
#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
#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
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
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:
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++;
/* 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);
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;
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;
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;
}
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));
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)
{
register OP* oldop = 0;
STRLEN n_a;
- OP *last_composite = Nullop;
if (!o || o->op_seq)
return;
case OP_DBSTATE:
PL_curcop = ((COP*)o); /* for warnings */
o->op_seq = PL_op_seqmax++;
- last_composite = Nullop;
break;
case OP_CONST:
(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)
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;
/* 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 */
"method lookup",
"subroutine entry",
"subroutine exit",
- "lvalue subroutine exit",
+ "lvalue subroutine return",
"caller",
"warn",
"die",
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 */
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
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}
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
=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
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
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;
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());
{
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);
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);
}
pos -= arybase;
rem = curlen-pos;
fail = rem;
- if (MAXARG > 2) {
+ if (num_args > 2) {
if (len < 0) {
rem += len;
if (rem < 0)
}
else {
pos += curlen;
- if (MAXARG < 3)
+ if (num_args < 3)
rem = curlen;
else if (len >= 0) {
rem = pos+len;
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! */
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;
{
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)
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_ck_open
Perl_ck_repeat
Perl_ck_require
+Perl_ck_return
Perl_ck_rfun
Perl_ck_rvconst
Perl_ck_sassign
}
}
+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)
{
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) {
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;
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;
+ }
}
}
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) {
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;
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;
+ }
}
}
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;
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_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)
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);
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;
}
-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.
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;
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;
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;
unless /Can\'t return a readonly value from lvalue subroutine/;
print "ok 40\n";
-=for disabled constructs
-
sub lva : lvalue {@a}
$_ = undef;
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;
print "# '$_'.\nnot " unless "'@a' $_" eq "'2 3' ";
print "ok 43\n";
-=cut
-
-print "ok $_\n" for 41..43;
-
sub lv1n : lvalue { $newvar }
$_ = undef;
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";
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] != ':')
projects / p5sagit/p5-mst-13.2.git / commitdiff