diff options
| -rw-r--r-- | doop.c | 4 | ||||
| -rw-r--r-- | embed.h | 8 | ||||
| -rwxr-xr-x | embed.pl | 1 | ||||
| -rw-r--r-- | op.c | 77 | ||||
| -rw-r--r-- | op.h | 4 | ||||
| -rw-r--r-- | opcode.h | 4 | ||||
| -rwxr-xr-x | opcode.pl | 4 | ||||
| -rw-r--r-- | pod/perldiag.pod | 8 | ||||
| -rw-r--r-- | pod/perlintern.pod | 7 | ||||
| -rw-r--r-- | pod/perlsub.pod | 4 | ||||
| -rw-r--r-- | pp.c | 29 | ||||
| -rw-r--r-- | pp.h | 7 | ||||
| -rw-r--r-- | pp.sym | 1 | ||||
| -rw-r--r-- | pp_ctl.c | 14 | ||||
| -rw-r--r-- | pp_hot.c | 44 | ||||
| -rw-r--r-- | pp_proto.h | 1 | ||||
| -rw-r--r-- | proto.h | 1 | ||||
| -rwxr-xr-x | t/lib/b.t | 8 | ||||
| -rwxr-xr-x | t/pragma/sub_lval.t | 120 | ||||
| -rw-r--r-- | toke.c | 18 |
20 files changed, 271 insertions, 93 deletions
@@ -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); @@ -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 @@ -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 @@ -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; @@ -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 */ @@ -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 */ @@ -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 @@ -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) @@ -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()) @@ -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 @@ -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) { @@ -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) @@ -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); @@ -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"; @@ -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] != ':') |