X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/83ee9e095f68fdbdc131f9a00306fb151d58abe2..701a9a0591208e3474da393677b933a2a31fefaa:/op.c?ds=sidebyside diff --git a/op.c b/op.c index fb696a7..ed5a7eb 100644 --- a/op.c +++ b/op.c @@ -1,6 +1,6 @@ /* op.c * - * Copyright (c) 1991-1999, Larry Wall + * Copyright (c) 1991-2000, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -151,7 +151,7 @@ Perl_pad_allocmy(pTHX_ char *name) } yyerror(Perl_form(aTHX_ "Can't use global %s in \"my\"",name)); } - if (ckWARN(WARN_UNSAFE) && AvFILLp(PL_comppad_name) >= 0) { + if (ckWARN(WARN_MISC) && AvFILLp(PL_comppad_name) >= 0) { SV **svp = AvARRAY(PL_comppad_name); HV *ourstash = (PL_curstash ? PL_curstash : PL_defstash); PADOFFSET top = AvFILLp(PL_comppad_name); @@ -163,7 +163,7 @@ Perl_pad_allocmy(pTHX_ char *name) || ((SvFLAGS(sv) & SVpad_OUR) && GvSTASH(sv) == ourstash)) && strEQ(name, SvPVX(sv))) { - Perl_warner(aTHX_ WARN_UNSAFE, + Perl_warner(aTHX_ WARN_MISC, "\"%s\" variable %s masks earlier declaration in same %s", (PL_in_my == KEY_our ? "our" : "my"), name, @@ -179,9 +179,9 @@ Perl_pad_allocmy(pTHX_ char *name) && ((SvFLAGS(sv) & SVpad_OUR) && GvSTASH(sv) == ourstash) && strEQ(name, SvPVX(sv))) { - Perl_warner(aTHX_ WARN_UNSAFE, + Perl_warner(aTHX_ WARN_MISC, "\"our\" variable %s redeclared", name); - Perl_warner(aTHX_ WARN_UNSAFE, + Perl_warner(aTHX_ WARN_MISC, "(Did you mean \"local\" instead of \"our\"?)\n"); break; } @@ -204,7 +204,7 @@ Perl_pad_allocmy(pTHX_ char *name) } if (PL_in_my == KEY_our) { (void)SvUPGRADE(sv, SVt_PVGV); - GvSTASH(sv) = (HV*)SvREFCNT_inc(PL_curstash ? PL_curstash : PL_defstash); + GvSTASH(sv) = (HV*)SvREFCNT_inc(PL_curstash ? (SV*)PL_curstash : (SV*)PL_defstash); SvFLAGS(sv) |= SVpad_OUR; } av_store(PL_comppad_name, off, sv); @@ -1412,18 +1412,19 @@ Perl_mod(pTHX_ OP *o, I32 type) if (kid->op_type == OP_METHOD_NAMED || kid->op_type == OP_METHOD) { - OP *newop; + UNOP *newop; if (kid->op_sibling || kid->op_next != kid) { yyerror("panic: unexpected optree near method call"); break; } - NewOp(1101, newop, 1, OP); + NewOp(1101, newop, 1, UNOP); newop->op_type = OP_RV2CV; newop->op_ppaddr = PL_ppaddr[OP_RV2CV]; - newop->op_next = newop; - kid->op_sibling = newop; + newop->op_first = Nullop; + newop->op_next = (OP*)newop; + kid->op_sibling = (OP*)newop; newop->op_private |= OPpLVAL_INTRO; break; } @@ -1946,7 +1947,7 @@ Perl_bind_match(pTHX_ I32 type, OP *left, OP *right) dTHR; OP *o; - if (ckWARN(WARN_UNSAFE) && + if (ckWARN(WARN_MISC) && (left->op_type == OP_RV2AV || left->op_type == OP_RV2HV || left->op_type == OP_PADAV || @@ -1957,7 +1958,7 @@ Perl_bind_match(pTHX_ I32 type, OP *left, OP *right) const char *sample = ((left->op_type == OP_RV2AV || left->op_type == OP_PADAV) ? "@array" : "%hash"); - Perl_warner(aTHX_ WARN_UNSAFE, + Perl_warner(aTHX_ WARN_MISC, "Applying %s to %s will act on scalar(%s)", desc, sample, sample); } @@ -2606,7 +2607,7 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) I32 to_utf = o->op_private & OPpTRANS_TO_UTF; if (complement) { - U8 tmpbuf[10]; + U8 tmpbuf[UTF8_MAXLEN]; U8** cp; UV nextmin = 0; New(1109, cp, tlen, U8*); @@ -3105,45 +3106,55 @@ Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *id, OP *arg) veop = Nullop; - if(version != Nullop) { + if (version != Nullop) { SV *vesv = ((SVOP*)version)->op_sv; - if (arg == Nullop && !SvNIOK(vesv)) { + if (arg == Nullop && !SvNIOKp(vesv)) { arg = version; } else { OP *pack; + SV *meth; - if (version->op_type != OP_CONST || !SvNIOK(vesv)) + if (version->op_type != OP_CONST || !SvNIOKp(vesv)) Perl_croak(aTHX_ "Version number must be constant number"); /* Make copy of id so we don't free it twice */ pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv)); /* Fake up a method call to VERSION */ + meth = newSVpvn("VERSION",7); + sv_upgrade(meth, SVt_PVIV); + SvIOK_on(meth); + PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth)); veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL, append_elem(OP_LIST, - prepend_elem(OP_LIST, pack, list(version)), - newSVOP(OP_METHOD_NAMED, 0, - newSVpvn("VERSION", 7)))); + prepend_elem(OP_LIST, pack, list(version)), + newSVOP(OP_METHOD_NAMED, 0, meth))); } } /* Fake up an import/unimport */ if (arg && arg->op_type == OP_STUB) imop = arg; /* no import on explicit () */ - else if(SvNIOK(((SVOP*)id)->op_sv)) { + else if (SvNIOKp(((SVOP*)id)->op_sv)) { imop = Nullop; /* use 5.0; */ } else { + SV *meth; + /* Make copy of id so we don't free it twice */ pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv)); + + /* Fake up a method call to import/unimport */ + meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);; + sv_upgrade(meth, SVt_PVIV); + SvIOK_on(meth); + PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth)); imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL, - append_elem(OP_LIST, - prepend_elem(OP_LIST, pack, list(arg)), - newSVOP(OP_METHOD_NAMED, 0, - aver ? newSVpvn("import", 6) - : newSVpvn("unimport", 8)))); + append_elem(OP_LIST, + prepend_elem(OP_LIST, pack, list(arg)), + newSVOP(OP_METHOD_NAMED, 0, meth))); } /* Fake up a require, handle override, if any */ @@ -3504,9 +3515,8 @@ S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp) } } if (first->op_type == OP_CONST) { - if (ckWARN(WARN_PRECEDENCE) && (first->op_private & OPpCONST_BARE)) - Perl_warner(aTHX_ WARN_PRECEDENCE, "Probable precedence problem on %s", - PL_op_desc[type]); + if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE)) + Perl_warner(aTHX_ WARN_BAREWORD, "Bareword found in conditional"); if ((type == OP_AND) == (SvTRUE(((SVOP*)first)->op_sv))) { op_free(first); *firstp = Nullop; @@ -3524,7 +3534,7 @@ S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp) else scalar(other); } - else if (ckWARN(WARN_UNSAFE) && (first->op_flags & OPf_KIDS)) { + else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS)) { OP *k1 = ((UNOP*)first)->op_first; OP *k2 = k1->op_sibling; OPCODE warnop = 0; @@ -3553,7 +3563,7 @@ S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp) if (warnop) { line_t oldline = CopLINE(PL_curcop); CopLINE_set(PL_curcop, PL_copline); - Perl_warner(aTHX_ WARN_UNSAFE, + Perl_warner(aTHX_ WARN_MISC, "Value of %s%s can be \"0\"; test with defined()", PL_op_desc[warnop], ((warnop == OP_READLINE || warnop == OP_GLOB) @@ -3754,6 +3764,7 @@ Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP * OP *listop; OP *o; OP *condop; + U8 loopflags = 0; if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) { @@ -3786,8 +3797,10 @@ Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP * block = scope(block); } - if (cont) + if (cont) { next = LINKLIST(cont); + loopflags |= OPpLOOP_CONTINUE; + } if (expr) { cont = append_elem(OP_LINESEQ, cont, newOP(OP_UNSTACK, 0)); if ((line_t)whileline != NOLINE) { @@ -3830,6 +3843,7 @@ Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP * loop->op_redoop = redo; loop->op_lastop = o; + o->op_private |= loopflags; if (next) loop->op_nextop = next; @@ -4214,7 +4228,7 @@ Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p) { dTHR; - if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_UNSAFE)) { + if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) { SV* msg = sv_newmortal(); SV* name = Nullsv; @@ -4230,7 +4244,7 @@ Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p) Perl_sv_catpvf(aTHX_ msg, "(%s)", p); else sv_catpv(msg, "none"); - Perl_warner(aTHX_ WARN_UNSAFE, "%"SVf, msg); + Perl_warner(aTHX_ WARN_PROTOTYPE, "%"SVf, msg); } } @@ -4247,10 +4261,10 @@ Perl_op_const_sv(pTHX_ OP *o, CV *cv) { SV *sv = Nullsv; - if(!o) + if (!o) return Nullsv; - if(o->op_type == OP_LINESEQ && cLISTOPo->op_first) + if (o->op_type == OP_LINESEQ && cLISTOPo->op_first) o = cLISTOPo->op_first->op_sibling; for (; o; o = o->op_next) { @@ -4336,9 +4350,9 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) maximum a prototype before. */ if (SvTYPE(gv) > SVt_NULL) { if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1) - && ckWARN_d(WARN_UNSAFE)) + && ckWARN_d(WARN_PROTOTYPE)) { - Perl_warner(aTHX_ WARN_UNSAFE, "Runaway prototype"); + Perl_warner(aTHX_ WARN_PROTOTYPE, "Runaway prototype"); } cv_ckproto((CV*)gv, NULL, ps); } @@ -4370,13 +4384,9 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name); if (!block) goto withattrs; - if(const_sv = cv_const_sv(cv)) + 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) - && !(CvGV(cv) && GvSTASH(CvGV(cv)) - && HvNAME(GvSTASH(CvGV(cv))) - && strEQ(HvNAME(GvSTASH(CvGV(cv))), - "autouse"))) + if ((const_sv || const_changed) && ckWARN(WARN_REDEFINE)) { line_t oldline = CopLINE(PL_curcop); CopLINE_set(PL_curcop, PL_copline); @@ -5354,8 +5364,8 @@ 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) )); - if (ckWARN(WARN_SYNTAX)) - Perl_warner(aTHX_ WARN_SYNTAX, + if (ckWARN(WARN_DEPRECATED)) + Perl_warner(aTHX_ WARN_DEPRECATED, "Array @%s missing the @ in argument %"IVdf" of %s()", name, (IV)numargs, PL_op_desc[type]); op_free(kid); @@ -5374,8 +5384,8 @@ 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) )); - if (ckWARN(WARN_SYNTAX)) - Perl_warner(aTHX_ WARN_SYNTAX, + if (ckWARN(WARN_DEPRECATED)) + Perl_warner(aTHX_ WARN_DEPRECATED, "Hash %%%s missing the %% in argument %"IVdf" of %s()", name, (IV)numargs, PL_op_desc[type]); op_free(kid); @@ -5494,6 +5504,7 @@ Perl_ck_glob(pTHX_ OP *o) { GV *gv; + o = ck_fun(o); if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling) append_elem(OP_GLOB, o, newDEFSVOP()); @@ -5532,7 +5543,7 @@ Perl_ck_glob(pTHX_ OP *o) gv_IOadd(gv); append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv)); scalarkids(o); - return ck_fun(o); + return o; } OP * @@ -5709,7 +5720,9 @@ Perl_ck_sassign(pTHX_ OP *o) OP *kid = cLISTOPo->op_first; /* has a disposable target? */ if ((PL_opargs[kid->op_type] & OA_TARGLEX) - && !(kid->op_flags & OPf_STACKED)) + && !(kid->op_flags & OPf_STACKED) + /* Cannot steal the second time! */ + && !(kid->op_private & OPpTARGET_MY)) { OP *kkid = kid->op_sibling; @@ -5956,7 +5969,7 @@ S_simplify_sort(pTHX_ OP *o) return; if (strEQ(GvNAME(gv), "a")) reversed = 0; - else if(strEQ(GvNAME(gv), "b")) + else if (strEQ(GvNAME(gv), "b")) reversed = 1; else return; @@ -6379,13 +6392,13 @@ Perl_peep(pTHX_ register OP *o) GvAVn(gv); } } - else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_UNSAFE)) { + else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) { GV *gv = cGVOPo_gv; if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) { /* XXX could check prototype here instead of just carping */ SV *sv = sv_newmortal(); gv_efullname3(sv, gv, Nullch); - Perl_warner(aTHX_ WARN_UNSAFE, + Perl_warner(aTHX_ WARN_PROTOTYPE, "%s() called too early to check prototype", SvPV_nolen(sv)); } @@ -6446,11 +6459,12 @@ Perl_peep(pTHX_ register OP *o) UNOP *rop; SV *lexname; GV **fields; - SV **svp, **indsvp; + SV **svp, **indsvp, *sv; I32 ind; char *key; STRLEN keylen; + o->op_seq = PL_op_seqmax++; if ((o->op_private & (OPpLVAL_INTRO)) || ((BINOP*)o)->op_last->op_type != OP_CONST) break; @@ -6477,8 +6491,76 @@ Perl_peep(pTHX_ register OP *o) rop->op_ppaddr = PL_ppaddr[OP_RV2AV]; o->op_type = OP_AELEM; o->op_ppaddr = PL_ppaddr[OP_AELEM]; + sv = newSViv(ind); + if (SvREADONLY(*svp)) + SvREADONLY_on(sv); + SvFLAGS(sv) |= (SvFLAGS(*svp) + & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY)); SvREFCNT_dec(*svp); - *svp = newSViv(ind); + *svp = sv; + break; + } + + case OP_HSLICE: { + UNOP *rop; + SV *lexname; + GV **fields; + SV **svp, **indsvp, *sv; + I32 ind; + char *key; + STRLEN keylen; + SVOP *first_key_op, *key_op; + + o->op_seq = PL_op_seqmax++; + if ((o->op_private & (OPpLVAL_INTRO)) + /* I bet there's always a pushmark... */ + || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST) + /* hmmm, no optimization if list contains only one key. */ + break; + rop = (UNOP*)((LISTOP*)o)->op_last; + if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV) + break; + lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE); + if (!SvOBJECT(lexname)) + break; + fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE); + if (!fields || !GvHV(*fields)) + break; + /* Again guessing that the pushmark can be jumped over.... */ + first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling) + ->op_first->op_sibling; + /* Check that the key list contains only constants. */ + for (key_op = first_key_op; key_op; + key_op = (SVOP*)key_op->op_sibling) + if (key_op->op_type != OP_CONST) + break; + if (key_op) + break; + rop->op_type = OP_RV2AV; + rop->op_ppaddr = PL_ppaddr[OP_RV2AV]; + o->op_type = OP_ASLICE; + o->op_ppaddr = PL_ppaddr[OP_ASLICE]; + for (key_op = first_key_op; key_op; + key_op = (SVOP*)key_op->op_sibling) { + svp = cSVOPx_svp(key_op); + key = SvPV(*svp, keylen); + indsvp = hv_fetch(GvHV(*fields), key, keylen, FALSE); + if (!indsvp) { + Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" " + "in variable %s of type %s", + key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname))); + } + ind = SvIV(*indsvp); + if (ind < 1) + Perl_croak(aTHX_ "Bad index while coercing array into hash"); + sv = newSViv(ind); + if (SvREADONLY(*svp)) + SvREADONLY_on(sv); + SvFLAGS(sv) |= (SvFLAGS(*svp) + & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY)); + SvREFCNT_dec(*svp); + *svp = sv; + } break; }