X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/7399586d384137f7ae66bcc82a83b0df7dd429e5..564319723c2c18fa4801cd77e0d203a582b4d5a3:/op.c diff --git a/op.c b/op.c index 21df282..0053bdd 100644 --- a/op.c +++ b/op.c @@ -19,12 +19,6 @@ #define PERL_IN_OP_C #include "perl.h" -#ifdef PERL_OBJECT -#define CHECKCALL this->*PL_check -#else -#define CHECKCALL *PL_check -#endif - /* #define PL_OP_SLAB_ALLOC */ #ifdef PL_OP_SLAB_ALLOC @@ -57,7 +51,7 @@ S_Slab_Alloc(pTHX_ int m, size_t sz) ? ( op_free((OP*)o), \ Perl_croak(aTHX_ "%s trapped by operation mask", PL_op_desc[type]), \ Nullop ) \ - : (CHECKCALL[type])(aTHX_ (OP*)o)) + : CALL_FPTR(PL_check[type])(aTHX_ (OP*)o)) #define PAD_MAX 999999999 @@ -107,27 +101,6 @@ S_no_bareword_allowed(pTHX_ OP *o) ++PL_error_count; } -void -Perl_assertref(pTHX_ OP *o) -{ - int type = o->op_type; - if (type != OP_AELEM && type != OP_HELEM && type != OP_GELEM) { - yyerror(Perl_form(aTHX_ "Can't use subscript on %s", PL_op_desc[type])); - if (type == OP_ENTERSUB || type == OP_RV2HV || type == OP_PADHV) { - dTHR; - SV *msg = sv_2mortal( - Perl_newSVpvf(aTHX_ "(Did you mean $ or @ instead of %c?)\n", - type == OP_ENTERSUB ? '&' : '%')); - if (PL_in_eval & EVAL_WARNONLY) - Perl_warn(aTHX_ "%_", msg); - else if (PL_in_eval) - sv_catsv(GvSV(PL_errgv), msg); - else - PerlIO_write(PerlIO_stderr(), SvPVX(msg), SvCUR(msg)); - } - } -} - /* "register" allocation */ PADOFFSET @@ -648,6 +621,7 @@ void Perl_op_free(pTHX_ OP *o) { register OP *kid, *nextkid; + OPCODE type; if (!o || o->op_seq == (U16)-1) return; @@ -658,22 +632,42 @@ Perl_op_free(pTHX_ OP *o) op_free(kid); } } + type = o->op_type; + if (type == OP_NULL) + type = o->op_targ; + + /* COP* is not cleared by op_clear() so that we may track line + * numbers etc even after null() */ + if (type == OP_NEXTSTATE || type == OP_SETSTATE || type == OP_DBSTATE) + cop_free((COP*)o); + + op_clear(o); + +#ifdef PL_OP_SLAB_ALLOC + if ((char *) o == PL_OpPtr) + { + } +#else + Safefree(o); +#endif +} +STATIC void +S_op_clear(pTHX_ OP *o) +{ switch (o->op_type) { - case OP_NULL: - o->op_targ = 0; /* Was holding old type, if any. */ - break; - case OP_ENTEREVAL: - o->op_targ = 0; /* Was holding hints. */ + case OP_NULL: /* Was holding old type, if any. */ + case OP_ENTEREVAL: /* Was holding hints. */ +#ifdef USE_THREADS + case OP_THREADSV: /* Was holding index into thr->threadsv AV. */ +#endif + o->op_targ = 0; break; #ifdef USE_THREADS case OP_ENTERITER: if (!(o->op_flags & OPf_SPECIAL)) break; /* FALL THROUGH */ - case OP_THREADSV: - o->op_targ = 0; /* Was holding index into thr->threadsv AV. */ - break; #endif /* USE_THREADS */ default: if (!(o->op_flags & OPf_REF) @@ -684,16 +678,11 @@ Perl_op_free(pTHX_ OP *o) case OP_GV: case OP_AELEMFAST: SvREFCNT_dec(cGVOPo->op_gv); - break; - case OP_SETSTATE: - o->op_targ = 0; /* Was holding old type. */ - /* FALL THROUGH */ - case OP_NEXTSTATE: - case OP_DBSTATE: - cop_free((COP*)o); + cGVOPo->op_gv = Nullgv; break; case OP_CONST: SvREFCNT_dec(cSVOPo->op_sv); + cSVOPo->op_sv = Nullsv; break; case OP_GOTO: case OP_NEXT: @@ -703,31 +692,29 @@ Perl_op_free(pTHX_ OP *o) break; /* FALL THROUGH */ case OP_TRANS: - if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) + if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) { SvREFCNT_dec(cSVOPo->op_sv); - else + cSVOPo->op_sv = Nullsv; + } + else { Safefree(cPVOPo->op_pv); + cPVOPo->op_pv = Nullch; + } break; case OP_SUBST: op_free(cPMOPo->op_pmreplroot); + cPMOPo->op_pmreplroot = Nullop; /* FALL THROUGH */ case OP_PUSHRE: case OP_MATCH: case OP_QR: ReREFCNT_dec(cPMOPo->op_pmregexp); + cPMOPo->op_pmregexp = (REGEXP*)NULL; break; } if (o->op_targ > 0) pad_free(o->op_targ); - -#ifdef PL_OP_SLAB_ALLOC - if ((char *) o == PL_OpPtr) - { - } -#else - Safefree(o); -#endif } STATIC void @@ -742,10 +729,9 @@ S_cop_free(pTHX_ COP* cop) STATIC void S_null(pTHX_ OP *o) { - if (o->op_type == OP_NEXTSTATE || o->op_type == OP_DBSTATE) - cop_free((COP*)o); - if (o->op_type != OP_NULL && o->op_type != OP_THREADSV && o->op_targ > 0) - pad_free(o->op_targ); + if (o->op_type == OP_NULL) + return; + op_clear(o); o->op_targ = o->op_type; o->op_type = OP_NULL; o->op_ppaddr = PL_ppaddr[OP_NULL]; @@ -886,9 +872,12 @@ Perl_scalarvoid(pTHX_ OP *o) SV* sv; U8 want; - if (o->op_type == OP_NEXTSTATE || o->op_type == OP_DBSTATE || - (o->op_type == OP_NULL && - (o->op_targ == OP_NEXTSTATE || o->op_targ == OP_DBSTATE))) + if (o->op_type == OP_NEXTSTATE + || o->op_type == OP_SETSTATE + || o->op_type == OP_DBSTATE + || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE + || o->op_targ == OP_SETSTATE + || o->op_targ == OP_DBSTATE))) { dTHR; PL_curcop = (COP*)o; /* for warning below */ @@ -1018,8 +1007,7 @@ Perl_scalarvoid(pTHX_ OP *o) } } } - null(o); /* don't execute a constant */ - SvREFCNT_dec(sv); /* don't even remember it */ + null(o); /* don't execute or even remember it */ break; case OP_POSTINC: @@ -1251,6 +1239,91 @@ Perl_mod(pTHX_ OP *o, I32 type) null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */ break; } + else { /* lvalue subroutine call */ + o->op_private |= OPpLVAL_INTRO; + if (type == OP_GREPSTART || type == OP_ENTERSUB) { + /* Backward compatibility mode: */ + o->op_private |= OPpENTERSUB_INARGS; + break; + } + else { /* Compile-time error message: */ + OP *kid = cUNOPo->op_first; + CV *cv; + OP *okid; + + if (kid->op_type == OP_PUSHMARK) + goto skip_kids; + if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST) + Perl_croak(aTHX_ + "panic: unexpected lvalue entersub " + "args: type/targ %ld:%ld", + (long)kid->op_type,kid->op_targ); + kid = kLISTOP->op_first; + skip_kids: + while (kid->op_sibling) + kid = kid->op_sibling; + if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) { + /* Indirect call */ + if (kid->op_type == OP_METHOD_NAMED + || kid->op_type == OP_METHOD) + { + OP *newop; + + if (kid->op_sibling || kid->op_next != kid) { + yyerror("panic: unexpected optree near method call"); + break; + } + + NewOp(1101, newop, 1, OP); + newop->op_type = OP_RV2CV; + newop->op_ppaddr = PL_ppaddr[OP_RV2CV]; + newop->op_next = newop; + kid->op_sibling = newop; + newop->op_private |= OPpLVAL_INTRO; + break; + } + + if (kid->op_type != OP_RV2CV) + Perl_croak(aTHX_ + "panic: unexpected lvalue entersub " + "entry via type/targ %ld:%ld", + (long)kid->op_type,kid->op_targ); + kid->op_private |= OPpLVAL_INTRO; + break; /* Postpone until runtime */ + } + + okid = kid; + kid = kUNOP->op_first; + if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV) + kid = kUNOP->op_first; + if (kid->op_type == OP_NULL) + Perl_croak(aTHX_ + "Unexpected constant lvalue entersub " + "entry via type/targ %ld:%ld", + (long)kid->op_type,kid->op_targ); + if (kid->op_type != OP_GV) { + /* Restore RV2CV to check lvalueness */ + restore_2cv: + if (kid->op_next && kid->op_next != kid) { /* Happens? */ + okid->op_next = kid->op_next; + kid->op_next = okid; + } + else + okid->op_next = Nullop; + okid->op_type = OP_RV2CV; + okid->op_targ = 0; + okid->op_ppaddr = PL_ppaddr[OP_RV2CV]; + okid->op_private |= OPpLVAL_INTRO; + break; + } + + cv = GvCV(kGVOP->op_gv); + if (!cv) + goto restore_2cv; + if (CvLVALUE(cv)) + break; + } + } /* FALL THROUGH */ default: nomod: @@ -1259,7 +1332,10 @@ Perl_mod(pTHX_ OP *o, I32 type) break; yyerror(Perl_form(aTHX_ "Can't modify %s in %s", (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL) - ? "do block" : PL_op_desc[o->op_type]), + ? "do block" + : (o->op_type == OP_ENTERSUB + ? "non-lvalue subroutine call" + : PL_op_desc[o->op_type])), type ? PL_op_desc[type] : "local")); return o; @@ -1588,8 +1664,60 @@ Perl_ref(pTHX_ OP *o, I32 type) } -OP * -Perl_my(pTHX_ OP *o) +STATIC OP * +S_dup_attrlist(pTHX_ OP *o) +{ + OP *rop = Nullop; + + /* An attrlist is either a simple OP_CONST or an OP_LIST with kids, + * where the first kid is OP_PUSHMARK and the remaining ones + * are OP_CONST. We need to push the OP_CONST values. + */ + if (o->op_type == OP_CONST) + rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc(cSVOPo->op_sv)); + else { + assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS)); + for (o = cLISTOPo->op_first; o; o=o->op_sibling) { + if (o->op_type == OP_CONST) + rop = append_elem(OP_LIST, rop, + newSVOP(OP_CONST, o->op_flags, + SvREFCNT_inc(cSVOPo->op_sv))); + } + } + return rop; +} + +STATIC void +S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs) +{ + OP *modname; /* for 'use' */ + SV *stashsv; + + /* fake up C */ + ENTER; /* need to protect against side-effects of 'use' */ + SAVEINT(PL_expect); + if (stash && HvNAME(stash)) + stashsv = newSVpv(HvNAME(stash), 0); + else + stashsv = &PL_sv_no; +#define ATTRSMODULE "attributes" + modname = newSVOP(OP_CONST, 0, + newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1)); + modname->op_private |= OPpCONST_BARE; + /* that flag is required to make 'use' work right */ + utilize(1, start_subparse(FALSE, 0), + Nullop, /* version */ + modname, + prepend_elem(OP_LIST, + newSVOP(OP_CONST, 0, stashsv), + prepend_elem(OP_LIST, + newSVOP(OP_CONST, 0, newRV(target)), + dup_attrlist(attrs)))); + LEAVE; +} + +STATIC OP * +S_my_kid(pTHX_ OP *o, OP *attrs) { OP *kid; I32 type; @@ -1600,7 +1728,7 @@ Perl_my(pTHX_ OP *o) type = o->op_type; if (type == OP_LIST) { for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) - my(kid); + my_kid(kid, attrs); } else if (type == OP_UNDEF) { return o; } else if (type != OP_PADSV && @@ -1611,12 +1739,44 @@ Perl_my(pTHX_ OP *o) yyerror(Perl_form(aTHX_ "Can't declare %s in my", PL_op_desc[o->op_type])); return o; } + else if (attrs && type != OP_PUSHMARK) { + HV *stash; + SV *padsv; + SV **namesvp; + + /* check for C when deciding package */ + namesvp = av_fetch(PL_comppad_name, o->op_targ, FALSE); + if (namesvp && *namesvp && SvOBJECT(*namesvp) && HvNAME(SvSTASH(*namesvp))) + stash = SvSTASH(*namesvp); + else + stash = PL_curstash; + padsv = PAD_SV(o->op_targ); + apply_attrs(stash, padsv, attrs); + } o->op_flags |= OPf_MOD; o->op_private |= OPpLVAL_INTRO; return o; } OP * +Perl_my_attrs(pTHX_ OP *o, OP *attrs) +{ + if (o->op_flags & OPf_PARENS) + list(o); + PL_in_my = FALSE; + PL_in_my_stash = Nullhv; + if (attrs) + SAVEFREEOP(attrs); + return my_kid(o, attrs); +} + +OP * +Perl_my(pTHX_ OP *o) +{ + return my_kid(o, Nullop); +} + +OP * Perl_sawparens(pTHX_ OP *o) { if (o) @@ -1690,9 +1850,6 @@ Perl_scope(pTHX_ OP *o) o->op_ppaddr = PL_ppaddr[OP_SCOPE]; kid = ((LISTOP*)o)->op_first; if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE){ - if (kid->op_targ > 0) - pad_free(kid->op_targ); - kid->op_targ = kid->op_type; kid->op_type = OP_SETSTATE; kid->op_ppaddr = PL_ppaddr[OP_SETSTATE]; } @@ -1899,7 +2056,8 @@ Perl_fold_constants(pTHX_ register OP *o) goto nope; /* Don't try to run w/ errors */ for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) { - if (curop->op_type != OP_CONST && + if ((curop->op_type != OP_CONST || + (curop->op_private & OPpCONST_BARE)) && curop->op_type != OP_LIST && curop->op_type != OP_SCALAR && curop->op_type != OP_NULL && @@ -2771,7 +2929,6 @@ Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *id, OP *arg) } else { OP *pack; - OP *meth; if (version->op_type != OP_CONST || !SvNIOK(vesv)) Perl_croak(aTHX_ "Version number must be constant number"); @@ -2780,11 +2937,11 @@ Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *id, OP *arg) pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv)); /* Fake up a method call to VERSION */ - meth = newSVOP(OP_CONST, 0, newSVpvn("VERSION", 7)); veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL, append_elem(OP_LIST, prepend_elem(OP_LIST, pack, list(version)), - newUNOP(OP_METHOD, 0, meth))); + newSVOP(OP_METHOD_NAMED, 0, + newSVpvn("VERSION", 7)))); } } @@ -2797,15 +2954,12 @@ Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *id, OP *arg) else { /* Make copy of id so we don't free it twice */ pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv)); - meth = newSVOP(OP_CONST, 0, - aver - ? newSVpvn("import", 6) - : newSVpvn("unimport", 8) - ); imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL, append_elem(OP_LIST, prepend_elem(OP_LIST, pack, list(arg)), - newUNOP(OP_METHOD, 0, meth))); + newSVOP(OP_METHOD_NAMED, 0, + aver ? newSVpvn("import", 6) + : newSVpvn("unimport", 8)))); } /* Fake up a require, handle override, if any */ @@ -2825,9 +2979,10 @@ Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *id, OP *arg) } /* Fake up the BEGIN {}, which does its thing immediately. */ - newSUB(floor, + newATTRSUB(floor, newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)), Nullop, + Nullop, append_elem(OP_LINESEQ, append_elem(OP_LINESEQ, newSTATEOP(0, Nullch, rqop), @@ -3890,7 +4045,7 @@ Perl_op_const_sv(pTHX_ OP *o, CV *cv) for (; o; o = o->op_next) { OPCODE type = o->op_type; - if(sv && o->op_next == o) + if (sv && o->op_next == o) return sv; if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK) continue; @@ -3914,14 +4069,35 @@ Perl_op_const_sv(pTHX_ OP *o, CV *cv) return sv; } +void +Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) +{ + if (o) + SAVEFREEOP(o); + if (proto) + SAVEFREEOP(proto); + if (attrs) + SAVEFREEOP(attrs); + if (block) + SAVEFREEOP(block); + Perl_croak(aTHX_ "\"my sub\" not yet implemented"); +} + CV * Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block) { + return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block); +} + +CV * +Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) +{ dTHR; STRLEN n_a; char *name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch; GV *gv = gv_fetchpv(name ? name : "__ANON__", - GV_ADDMULTI | (block ? 0 : GV_NOINIT), SVt_PVCV); + GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT), + SVt_PVCV); char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, n_a) : Nullch; register CV *cv=0; I32 ix; @@ -3930,8 +4106,10 @@ Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block) SAVEFREEOP(o); if (proto) SAVEFREEOP(proto); + if (attrs) + SAVEFREEOP(attrs); - if (SvTYPE(gv) != SVt_PVGV) { /* Prototype now, and had + if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at maximum a prototype before. */ if (SvTYPE(gv) > SVt_NULL) { if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1) @@ -3959,7 +4137,7 @@ Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block) if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) { SV* const_sv; bool const_changed = TRUE; - if (!block) { + if (!block && !attrs) { /* just a "sub foo;" when &foo is already defined */ SAVEFREESV(PL_compcv); goto done; @@ -3967,6 +4145,8 @@ Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block) /* ahem, death to those who redefine active sort subs */ if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv)) Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name); + if (!block) + goto withattrs; if(const_sv = cv_const_sv(cv)) const_changed = sv_cmp(const_sv, op_const_sv(block, Nullcv)); if ((const_sv && const_changed) || ckWARN(WARN_REDEFINE) @@ -3978,14 +4158,46 @@ Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block) PL_curcop->cop_line = PL_copline; Perl_warner(aTHX_ WARN_REDEFINE, const_sv ? "Constant subroutine %s redefined" - : "Subroutine %s redefined", name); + : "Subroutine %s redefined", name); PL_curcop->cop_line = oldline; } SvREFCNT_dec(cv); cv = Nullcv; } } + withattrs: + if (attrs) { + HV *stash; + SV *rcv; + + /* Need to do a C + * before we clobber PL_compcv. + */ + if (cv && !block) { + rcv = (SV*)cv; + if (CvGV(cv) && GvSTASH(CvGV(cv)) && HvNAME(GvSTASH(CvGV(cv)))) + stash = GvSTASH(CvGV(cv)); + else if (CvSTASH(cv) && HvNAME(CvSTASH(cv))) + stash = CvSTASH(cv); + else + stash = PL_curstash; + } + else { + /* possibly about to re-define existing subr -- ignore old cv */ + rcv = (SV*)PL_compcv; + if (name && GvSTASH(gv) && HvNAME(GvSTASH(gv))) + stash = GvSTASH(gv); + else + stash = PL_curstash; + } + apply_attrs(stash, rcv, attrs); + } if (cv) { /* must reuse cv if autoloaded */ + if (!block) { + /* got here with just attrs -- work done, so bug out */ + SAVEFREESV(PL_compcv); + goto done; + } cv_undef(cv); CvFLAGS(cv) = CvFLAGS(PL_compcv); CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv); @@ -4083,7 +4295,12 @@ Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block) } } - CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block)); + if(CvLVALUE(cv)) { + CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0, scalarseq(block)); + } + else { + CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block)); + } CvSTART(cv) = LINKLIST(CvROOT(cv)); CvROOT(cv)->op_next = 0; peep(CvSTART(cv)); @@ -4173,10 +4390,11 @@ Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv) if(stash) PL_curstash = PL_curcop->cop_stash = stash; - newSUB( + newATTRSUB( start_subparse(FALSE, 0), newSVOP(OP_CONST, 0, newSVpv(name,0)), newSVOP(OP_CONST, 0, &PL_sv_no), /* SvPV(&PL_sv_no) == "" -- GMB */ + Nullop, newSTATEOP(0, Nullch, newSVOP(OP_CONST, 0, sv)) ); @@ -4329,8 +4547,15 @@ Perl_newANONHASH(pTHX_ OP *o) OP * Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block) { + return newANONATTRSUB(floor, proto, Nullop, block); +} + +OP * +Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block) +{ return newUNOP(OP_REFGEN, 0, - newSVOP(OP_ANONCODE, 0, (SV*)newSUB(floor, 0, proto, block))); + newSVOP(OP_ANONCODE, 0, + (SV*)newATTRSUB(floor, 0, proto, attrs, block))); } OP * @@ -4811,10 +5036,17 @@ Perl_ck_fun(pTHX_ OP *o) char *name = SvPVx(((SVOP*)kid)->op_sv, n_a); OP *newop = newAVREF(newGVOP(OP_GV, 0, gv_fetchpv(name, TRUE, SVt_PVAV) )); +#ifdef IV_IS_QUAD + if (ckWARN(WARN_SYNTAX)) + Perl_warner(aTHX_ WARN_SYNTAX, + "Array @%s missing the @ in argument %" PERL_PRId64 " of %s()", + name, (IV)numargs, PL_op_desc[type]); +#else if (ckWARN(WARN_SYNTAX)) Perl_warner(aTHX_ WARN_SYNTAX, "Array @%s missing the @ in argument %ld of %s()", name, (long)numargs, PL_op_desc[type]); +#endif op_free(kid); kid = newop; kid->op_sibling = sibl; @@ -4831,10 +5063,17 @@ Perl_ck_fun(pTHX_ OP *o) char *name = SvPVx(((SVOP*)kid)->op_sv, n_a); OP *newop = newHVREF(newGVOP(OP_GV, 0, gv_fetchpv(name, TRUE, SVt_PVHV) )); +#ifdef IV_IS_QUAD + if (ckWARN(WARN_SYNTAX)) + Perl_warner(aTHX_ WARN_SYNTAX, + "Hash %%%s missing the %% in argument %" PERL_PRId64 " of %s()", + name, (IV)numargs, PL_op_desc[type]); +#else if (ckWARN(WARN_SYNTAX)) Perl_warner(aTHX_ WARN_SYNTAX, "Hash %%%s missing the %% in argument %ld of %s()", name, (long)numargs, PL_op_desc[type]); +#endif op_free(kid); kid = newop; kid->op_sibling = sibl; @@ -5044,6 +5283,7 @@ Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */ if ((o->op_flags & OPf_KIDS) && ckWARN(WARN_DEPRECATED)) { switch (cUNOPo->op_first->op_type) { case OP_RV2AV: + break; /* Globals via GV can be undef */ case OP_PADAV: case OP_AASSIGN: /* Is this a good idea? */ Perl_warner(aTHX_ WARN_DEPRECATED, @@ -5052,6 +5292,7 @@ Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */ "(Maybe you should just omit the defined()?)\n"); break; case OP_RV2HV: + break; /* Globals via GV can be undef */ case OP_PADHV: Perl_warner(aTHX_ WARN_DEPRECATED, "defined(%hash) is deprecated"); @@ -5136,13 +5377,33 @@ Perl_ck_sassign(pTHX_ OP *o) OP *kkid = kid->op_sibling; /* Can just relocate the target. */ - if (kkid && kkid->op_type == OP_PADSV) { + if (kkid && kkid->op_type == OP_PADSV + && !(kkid->op_private & OPpLVAL_INTRO)) + { /* Concat has problems if target is equal to right arg. */ - if (kid->op_type == OP_CONCAT - && kLISTOP->op_first->op_sibling->op_type == OP_PADSV - && kLISTOP->op_first->op_sibling->op_targ == kkid->op_targ) - { - return o; + if (kid->op_type == OP_CONCAT) { + if (kLISTOP->op_first->op_sibling->op_type == OP_PADSV + && kLISTOP->op_first->op_sibling->op_targ == kkid->op_targ) + return o; + } + else if (kid->op_type == OP_JOIN) { + /* do_join has problems if the arguments coincide with target. + In fact the second argument *can* safely coincide, + but ignore=pessimize this rare occasion. */ + OP *arg = kLISTOP->op_first->op_sibling; /* Skip PUSHMARK */ + + while (arg) { + if (arg->op_type == OP_PADSV + && arg->op_targ == kkid->op_targ) + return o; + arg = arg->op_sibling; + } + } + else if (kid->op_type == OP_QUOTEMETA) { + /* quotemeta has problems if the argument coincides with target. */ + if (kLISTOP->op_first->op_type == OP_PADSV + && kLISTOP->op_first->op_targ == kkid->op_targ) + return o; } kid->op_targ = kkid->op_targ; /* Now we do not need PADSV and SASSIGN. */ @@ -5177,6 +5438,26 @@ Perl_ck_match(pTHX_ OP *o) } OP * +Perl_ck_method(pTHX_ OP *o) +{ + OP *kid = cUNOPo->op_first; + if (kid->op_type == OP_CONST) { + SV* sv = kSVOP->op_sv; + if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) { + OP *cmop; + sv_upgrade(sv, SVt_PVIV); + SvIOK_on(sv); + PERL_HASH(SvUVX(sv), SvPVX(sv), SvCUR(sv)); + cmop = newSVOP(OP_METHOD_NAMED, 0, sv); + kSVOP->op_sv = Nullsv; + op_free(o); + return cmop; + } + } + return o; +} + +OP * Perl_ck_null(pTHX_ OP *o) { return o; @@ -5383,9 +5664,10 @@ S_simplify_sort(pTHX_ OP *o) o->op_private |= OPpSORT_NUMERIC; if (k->op_type == OP_I_NCMP) o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER; - op_free(cLISTOPo->op_first->op_sibling); /* delete comparison block */ - cLISTOPo->op_first->op_sibling = cLISTOPo->op_last; - cLISTOPo->op_children = 1; + kid = cLISTOPo->op_first->op_sibling; + cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */ + op_free(kid); /* then delete it */ + cLISTOPo->op_children--; } OP * @@ -5440,6 +5722,23 @@ Perl_ck_split(pTHX_ OP *o) } OP * +Perl_ck_join(pTHX_ OP *o) +{ + if (ckWARN(WARN_SYNTAX)) { + OP *kid = cLISTOPo->op_first->op_sibling; + if (kid && kid->op_type == OP_MATCH) { + char *pmstr = "STRING"; + if (kPMOP->op_pmregexp) + pmstr = kPMOP->op_pmregexp->precomp; + Perl_warner(aTHX_ WARN_SYNTAX, + "/%s/ should probably be written as \"%s\"", + pmstr, pmstr); + } + } + return ck_fun(o); +} + +OP * Perl_ck_subr(pTHX_ OP *o) { dTHR; @@ -5454,6 +5753,7 @@ Perl_ck_subr(pTHX_ OP *o) I32 arg = 0; STRLEN n_a; + o->op_private |= OPpENTERSUB_HASTARG; for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ; if (cvop->op_type == OP_RV2CV) { SVOP* tmpop; @@ -5470,7 +5770,7 @@ Perl_ck_subr(pTHX_ OP *o) } } } - else if (cvop->op_type == OP_METHOD) { + else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) { if (o2->op_type == OP_CONST) o2->op_private &= ~OPpCONST_STRICT; else if (o2->op_type == OP_LIST) { @@ -5640,6 +5940,7 @@ Perl_peep(pTHX_ register OP *o) dTHR; register OP* oldop = 0; STRLEN n_a; + OP *last_composite = Nullop; if (!o || o->op_seq) return; @@ -5653,10 +5954,12 @@ Perl_peep(pTHX_ register OP *o) PL_op_seqmax++; PL_op = o; switch (o->op_type) { + case OP_SETSTATE: case OP_NEXTSTATE: case OP_DBSTATE: PL_curcop = ((COP*)o); /* for warnings */ o->op_seq = PL_op_seqmax++; + last_composite = Nullop; break; case OP_CONST: @@ -5685,8 +5988,10 @@ Perl_peep(pTHX_ register OP *o) && (((LISTOP*)o)->op_first->op_sibling->op_targ == o->op_next->op_targ))) { goto ignore_optimization; - } else { + } + else { o->op_targ = o->op_next->op_targ; + o->op_private |= OPpTARGET_MY; } } null(o->op_next); @@ -5701,8 +6006,12 @@ Perl_peep(pTHX_ register OP *o) } goto nothin; case OP_NULL: - if (o->op_targ == OP_NEXTSTATE || o->op_targ == OP_DBSTATE) + if (o->op_targ == OP_NEXTSTATE + || o->op_targ == OP_DBSTATE + || o->op_targ == OP_SETSTATE) + { PL_curcop = ((COP*)o); + } goto nothin; case OP_SCALAR: case OP_LINESEQ: @@ -5737,7 +6046,6 @@ Perl_peep(pTHX_ register OP *o) <= 255 && i >= 0) { - SvREFCNT_dec(((SVOP*)pop)->op_sv); null(o->op_next); null(pop->op_next); null(pop); @@ -5768,6 +6076,8 @@ Perl_peep(pTHX_ register OP *o) case OP_GREPWHILE: case OP_AND: case OP_OR: + case OP_ANDASSIGN: + case OP_ORASSIGN: case OP_COND_EXPR: case OP_RANGE: o->op_seq = PL_op_seqmax++; @@ -5848,6 +6158,40 @@ 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->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;