X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/503de4705ff6537018ae94e9179e16636748b2a6..e28bb1d52bee845e0aab3d253cd27698a545c674:/op.c diff --git a/op.c b/op.c index ada5a3d..a74743e 100644 --- a/op.c +++ b/op.c @@ -363,10 +363,12 @@ Perl_allocmy(pTHX_ const char *const name) { /* name[2] is true if strlen(name) > 2 */ if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) { - yyerror(Perl_form(aTHX_ "Can't use global %c^%c%s in \"my\"", - name[0], toCTRL(name[1]), name + 2)); + yyerror(Perl_form(aTHX_ "Can't use global %c^%c%s in \"%s\"", + name[0], toCTRL(name[1]), name + 2, + PL_parser->in_my == KEY_state ? "state" : "my")); } else { - yyerror(Perl_form(aTHX_ "Can't use global %s in \"my\"",name)); + yyerror(Perl_form(aTHX_ "Can't use global %s in \"%s\"",name, + PL_parser->in_my == KEY_state ? "state" : "my")); } } @@ -393,6 +395,12 @@ Perl_allocmy(pTHX_ const char *const name) 0, /* not fake */ PL_parser->in_my == KEY_state ); + /* anon sub prototypes contains state vars should always be cloned, + * otherwise the state var would be shared between anon subs */ + + if (PL_parser->in_my == KEY_state && CvANON(PL_compcv)) + CvCLONE_on(PL_compcv); + return off; } @@ -2810,7 +2818,7 @@ Perl_newMADsv(pTHX_ char key, SV* sv) } MADPROP * -Perl_newMADPROP(pTHX_ char key, char type, void* val, I32 vlen) +Perl_newMADPROP(pTHX_ char key, char type, const void* val, I32 vlen) { MADPROP *mp; Newxz(mp, 1, MADPROP); @@ -3966,12 +3974,14 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right) } if (is_list_assignment(left)) { + static const char no_list_state[] = "Initialization of state variables" + " in list context currently forbidden"; OP *curop; PL_modcount = 0; /* Grandfathering $[ assignment here. Bletch.*/ /* Only simple assignments like C<< ($[) = 1 >> are allowed */ - PL_eval_start = (left->op_type == OP_CONST) ? right : 0; + PL_eval_start = (left->op_type == OP_CONST) ? right : NULL; left = mod(left, OP_AASSIGN); if (PL_eval_start) PL_eval_start = 0; @@ -4059,6 +4069,54 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right) o->op_private |= OPpASSIGN_COMMON; } + if ((left->op_type == OP_LIST + || (left->op_type == OP_NULL && left->op_targ == OP_LIST))) { + OP* lop = ((LISTOP*)left)->op_first; + while (lop) { + if (lop->op_type == OP_PADSV || + lop->op_type == OP_PADAV || + lop->op_type == OP_PADHV || + lop->op_type == OP_PADANY) { + if (lop->op_private & OPpPAD_STATE) { + if (left->op_private & OPpLVAL_INTRO) { + /* Each variable in state($a, $b, $c) = ... */ + } + else { + /* Each state variable in + (state $a, my $b, our $c, $d, undef) = ... */ + } + yyerror(no_list_state); + } else { + /* Each my variable in + (state $a, my $b, our $c, $d, undef) = ... */ + } + } else { + /* Other ops in the list. undef may be interesting in + (state $a, undef, state $c) */ + } + lop = lop->op_sibling; + } + } + else if (((left->op_private & (OPpLVAL_INTRO | OPpPAD_STATE)) + == (OPpLVAL_INTRO | OPpPAD_STATE)) + && ( left->op_type == OP_PADSV + || left->op_type == OP_PADAV + || left->op_type == OP_PADHV + || left->op_type == OP_PADANY)) + { + /* All single variable list context state assignments, hence + state ($a) = ... + (state $a) = ... + state @a = ... + state (@a) = ... + (state @a) = ... + state %a = ... + state (%a) = ... + (state %a) = ... + */ + yyerror(no_list_state); + } + if (right && right->op_type == OP_SPLIT && !PL_madskills) { OP* tmpop = ((LISTOP*)right)->op_first; if (tmpop && (tmpop->op_type == OP_PUSHRE)) { @@ -4269,6 +4327,7 @@ S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp) if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV || o2->op_type == OP_PADHV) && o2->op_private & OPpLVAL_INTRO + && !(o2->op_private & OPpPAD_STATE) && ckWARN(WARN_DEPRECATED)) { Perl_warner(aTHX_ packWARN(WARN_DEPRECATED), @@ -5521,7 +5580,8 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) CopFILE(PL_curcop), (long)PL_subline, (long)CopLINE(PL_curcop)); gv_efullname3(tmpstr, gv, NULL); - hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr), SvCUR(tmpstr), sv, 0); + (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr), + SvCUR(tmpstr), sv, 0); hv = GvHVn(db_postponed); if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) { CV * const pcv = GvCV(db_postponed); @@ -6986,6 +7046,34 @@ Perl_ck_sassign(pTHX_ OP *o) return kid; } } + if (kid->op_sibling) { + OP *kkid = kid->op_sibling; + if (kkid->op_type == OP_PADSV + && (kkid->op_private & OPpLVAL_INTRO) + && SvPAD_STATE(*av_fetch(PL_comppad_name, kkid->op_targ, FALSE))) { + const PADOFFSET target = kkid->op_targ; + OP *const other = newOP(OP_PADSV, + kkid->op_flags + | ((kkid->op_private & ~OPpLVAL_INTRO) << 8)); + OP *const first = newOP(OP_NULL, 0); + OP *const nullop = newCONDOP(0, first, o, other); + OP *const condop = first->op_next; + /* hijacking PADSTALE for uninitialized state variables */ + SvPADSTALE_on(PAD_SVl(target)); + + condop->op_type = OP_ONCE; + condop->op_ppaddr = PL_ppaddr[OP_ONCE]; + condop->op_targ = target; + other->op_targ = target; + + /* Because we change the type of the op here, we will skip the + assinment binop->op_last = binop->op_first->op_sibling; at the + end of Perl_newBINOP(). So need to do it here. */ + cBINOPo->op_last = cBINOPo->op_first->op_sibling; + + return nullop; + } + } return o; } @@ -7984,6 +8072,7 @@ Perl_peep(pTHX_ register OP *o) case OP_DORASSIGN: case OP_COND_EXPR: case OP_RANGE: + case OP_ONCE: while (cLOGOP->op_other->op_type == OP_NULL) cLOGOP->op_other = cLOGOP->op_other->op_next; peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */