X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=op.c;h=90a0c52976940af547010d5f4595aa7bcf0ed2ff;hb=ea726b52599b52cf534201a46ec3455418c9eb8e;hp=6823cc991e880b75c653fd3cd660f44df18bbbde;hpb=c53f1caa29d8829011cc4dd8948bd9947d957fba;p=p5sagit%2Fp5-mst-13.2.git diff --git a/op.c b/op.c index 6823cc9..90a0c52 100644 --- a/op.c +++ b/op.c @@ -1,7 +1,7 @@ /* op.c * - * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, - * 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, by Larry Wall and others + * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, + * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -502,7 +502,10 @@ Perl_op_free(pTHX_ OP *o) /* COP* is not cleared by op_clear() so that we may track line * numbers etc even after null() */ - if (type == OP_NEXTSTATE || type == OP_DBSTATE) { + if (type == OP_NEXTSTATE || type == OP_DBSTATE + || (type == OP_NULL /* the COP might have been null'ed */ + && ((OPCODE)o->op_targ == OP_NEXTSTATE + || (OPCODE)o->op_targ == OP_DBSTATE))) { cop_free((COP*)o); } @@ -1135,6 +1138,20 @@ Perl_scalarvoid(pTHX_ OP *o) case OP_OR: case OP_AND: + kid = cLOGOPo->op_first; + if (kid->op_type == OP_NOT + && (kid->op_flags & OPf_KIDS) + && !PL_madskills) { + if (o->op_type == OP_AND) { + o->op_type = OP_OR; + o->op_ppaddr = PL_ppaddr[OP_OR]; + } else { + o->op_type = OP_AND; + o->op_ppaddr = PL_ppaddr[OP_AND]; + } + op_null(kid); + } + case OP_DOR: case OP_COND_EXPR: case OP_ENTERGIVEN: @@ -2518,7 +2535,7 @@ Perl_fold_constants(pTHX_ register OP *o) case 3: /* Something tried to die. Abandon constant folding. */ /* Pretend the error never happened. */ - sv_setpvn(ERRSV,"",0); + CLEAR_ERRSV(); o->op_next = old_next; break; default: @@ -3344,7 +3361,7 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) SvREFCNT_dec(transv); if (!del && havefinal && rlen) - (void)hv_store((HV*)SvRV(swash), "FINAL", 5, + (void)hv_store(MUTABLE_HV(SvRV(swash)), "FINAL", 5, newSVuv((UV)final), 0); if (grows) @@ -4416,6 +4433,8 @@ Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o) } } + if (flags & OPf_SPECIAL) + op_null((OP*)cop); return prepend_elem(OP_LINESEQ, (OP*)cop, o); } @@ -4431,46 +4450,95 @@ Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other) } STATIC OP * +S_search_const(pTHX_ OP *o) +{ + PERL_ARGS_ASSERT_SEARCH_CONST; + + switch (o->op_type) { + case OP_CONST: + return o; + case OP_NULL: + if (o->op_flags & OPf_KIDS) + return search_const(cUNOPo->op_first); + break; + case OP_LEAVE: + case OP_SCOPE: + case OP_LINESEQ: + { + OP *kid; + if (!(o->op_flags & OPf_KIDS)) + return NULL; + kid = cLISTOPo->op_first; + do { + switch (kid->op_type) { + case OP_ENTER: + case OP_NULL: + case OP_NEXTSTATE: + kid = kid->op_sibling; + break; + default: + if (kid != cLISTOPo->op_last) + return NULL; + goto last; + } + } while (kid); + if (!kid) + kid = cLISTOPo->op_last; +last: + return search_const(kid); + } + } + + return NULL; +} + +STATIC OP * S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp) { dVAR; LOGOP *logop; OP *o; - OP *first = *firstp; - OP * const other = *otherp; + OP *first; + OP *other; + OP *cstop = NULL; + int prepend_not = 0; PERL_ARGS_ASSERT_NEW_LOGOP; + first = *firstp; + other = *otherp; + if (type == OP_XOR) /* Not short circuit, but here by precedence. */ return newBINOP(type, flags, scalar(first), scalar(other)); scalarboolean(first); - /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */ + /* optimize AND and OR ops that have NOTs as children */ if (first->op_type == OP_NOT - && (first->op_flags & OPf_SPECIAL) && (first->op_flags & OPf_KIDS) + && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */ + || (other->op_type == OP_NOT)) /* if (!$x && !$y) { } */ && !PL_madskills) { if (type == OP_AND || type == OP_OR) { if (type == OP_AND) type = OP_OR; else type = OP_AND; - o = first; - first = *firstp = cUNOPo->op_first; - if (o->op_next) - first->op_next = o->op_next; - cUNOPo->op_first = NULL; - op_free(o); + op_null(first); + if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */ + op_null(other); + prepend_not = 1; /* prepend a NOT op later */ + } } } - if (first->op_type == OP_CONST) { - if (first->op_private & OPpCONST_STRICT) - no_bareword_allowed(first); - else if ((first->op_private & OPpCONST_BARE) && ckWARN(WARN_BAREWORD)) + /* search for a constant op that could let us fold the test */ + if ((cstop = search_const(first))) { + if (cstop->op_private & OPpCONST_STRICT) + no_bareword_allowed(cstop); + else if ((cstop->op_private & OPpCONST_BARE) && ckWARN(WARN_BAREWORD)) Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional"); - if ((type == OP_AND && SvTRUE(((SVOP*)first)->op_sv)) || - (type == OP_OR && !SvTRUE(((SVOP*)first)->op_sv)) || - (type == OP_DOR && !SvOK(((SVOP*)first)->op_sv))) { + if ((type == OP_AND && SvTRUE(((SVOP*)cstop)->op_sv)) || + (type == OP_OR && !SvTRUE(((SVOP*)cstop)->op_sv)) || + (type == OP_DOR && !SvOK(((SVOP*)cstop)->op_sv))) { *firstp = NULL; if (other->op_type == OP_CONST) other->op_private |= OPpCONST_SHORTCIRCUIT; @@ -4577,7 +4645,7 @@ S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp) CHECKOP(type,logop); - o = newUNOP(OP_NULL, 0, (OP*)logop); + o = newUNOP(prepend_not ? OP_NOT : OP_NULL, 0, (OP*)logop); other->op_next = o; return o; @@ -4590,6 +4658,7 @@ Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop) LOGOP *logop; OP *start; OP *o; + OP *cstop; PERL_ARGS_ASSERT_NEWCONDOP; @@ -4599,14 +4668,14 @@ Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop) return newLOGOP(OP_OR, 0, first, falseop); scalarboolean(first); - if (first->op_type == OP_CONST) { + if ((cstop = search_const(first))) { /* Left or right arm of the conditional? */ - const bool left = SvTRUE(((SVOP*)first)->op_sv); + const bool left = SvTRUE(((SVOP*)cstop)->op_sv); OP *live = left ? trueop : falseop; OP *const dead = left ? falseop : trueop; - if (first->op_private & OPpCONST_BARE && - first->op_private & OPpCONST_STRICT) { - no_bareword_allowed(first); + if (cstop->op_private & OPpCONST_BARE && + cstop->op_private & OPpCONST_STRICT) { + no_bareword_allowed(cstop); } if (PL_madskills) { /* This is all dead code when PERL_MAD is not defined. */ @@ -5316,7 +5385,7 @@ L. =cut */ SV * -Perl_cv_const_sv(pTHX_ CV *cv) +Perl_cv_const_sv(pTHX_ const CV *const cv) { PERL_UNUSED_CONTEXT; if (!cv) @@ -5500,7 +5569,7 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) { Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype"); } - cv_ckproto_len((CV*)gv, NULL, ps, ps_len); + cv_ckproto_len((const CV *)gv, NULL, ps, ps_len); } if (ps) sv_setpvn((SV*)gv, ps, ps_len); @@ -6034,7 +6103,7 @@ Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename) if (cv) /* must reuse cv if autoloaded */ cv_undef(cv); else { - cv = (CV*)newSV_type(SVt_PVCV); + cv = MUTABLE_CV(newSV_type(SVt_PVCV)); if (name) { GvCV(gv) = cv; GvCVGEN(gv) = 0; @@ -6551,7 +6620,7 @@ Perl_ck_exists(pTHX_ OP *o) else if (kid->op_type == OP_AELEM) o->op_flags |= OPf_SPECIAL; else if (kid->op_type != OP_HELEM) - Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element", + Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or a subroutine", OP_DESC(o)); op_null(kid); } @@ -7410,7 +7479,9 @@ Perl_ck_open(pTHX_ OP *o) if (table) { SV **svp = hv_fetchs(table, "open_IN", FALSE); if (svp && *svp) { - const I32 mode = mode_from_discipline(*svp); + STRLEN len = 0; + const char *d = SvPV_const(*svp, len); + const I32 mode = mode_from_discipline(d, len); if (mode & O_BINARY) o->op_private |= OPpOPEN_IN_RAW; else if (mode & O_TEXT) @@ -7419,7 +7490,9 @@ Perl_ck_open(pTHX_ OP *o) svp = hv_fetchs(table, "open_OUT", FALSE); if (svp && *svp) { - const I32 mode = mode_from_discipline(*svp); + STRLEN len = 0; + const char *d = SvPV_const(*svp, len); + const I32 mode = mode_from_discipline(d, len); if (mode & O_BINARY) o->op_private |= OPpOPEN_OUT_RAW; else if (mode & O_TEXT)