X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pp_hot.c;h=7cbc00b22b5b61d1ebfa9ca6436631a50b014297;hb=73c20b238d7378e539b3486e16ad5c6e46696374;hp=a8b9dff79d254fff1886f83347de7100b343bfce;hpb=7e8961ecc77ac069ddd54d220ef48fd89f1122d6;p=p5sagit%2Fp5-mst-13.2.git diff --git a/pp_hot.c b/pp_hot.c index a8b9dff..7cbc00b 100644 --- a/pp_hot.c +++ b/pp_hot.c @@ -1,6 +1,7 @@ /* pp_hot.c * - * Copyright (c) 1991-2003, Larry Wall + * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, + * 2000, 2001, 2002, 2003, 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. @@ -140,7 +141,7 @@ PP(pp_concat) if (TARG == right && right != left) { right = sv_2mortal(newSVpvn(rpv, rlen)); - rpv = SvPV(right, rlen); /* no point setting UTF8 here */ + rpv = SvPV(right, rlen); /* no point setting UTF-8 here */ rcopied = TRUE; } @@ -807,7 +808,7 @@ PP(pp_rv2hv) RETURN; } else if (LVRET) { - if (GIMME == G_SCALAR) + if (GIMME != G_SCALAR) Perl_croak(aTHX_ "Can't return hash to lvalue scalar context"); SETs((SV*)hv); RETURN; @@ -1233,7 +1234,7 @@ PP(pp_match) if (SvSCREAM(TARG)) r_flags |= REXEC_SCREAM; - if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) { + if ((int)(pm->op_pmflags & PMf_MULTILINE) != PL_multiline) { SAVEINT(PL_multiline); PL_multiline = pm->op_pmflags & PMf_MULTILINE; } @@ -1405,7 +1406,7 @@ yup: /* Confirmed by INTUIT */ rx->startp[0] = s - truebase; rx->endp[0] = s - truebase + rx->minlen; } - rx->nparens = rx->lastparen = 0; /* used by @- and @+ */ + rx->nparens = rx->lastparen = rx->lastcloseparen = 0; /* used by @-, @+, and $^N */ LEAVE_SCOPE(oldsave); RETPUSHYES; @@ -1496,7 +1497,7 @@ Perl_do_readline(pTHX) /* undef TARG, and push that undefined value */ if (type != OP_RCATLINE) { SV_CHECK_THINKFIRST_COW_DROP(TARG); - SvOK_off(TARG); + (void)SvOK_off(TARG); } PUSHTARG; } @@ -1560,7 +1561,7 @@ Perl_do_readline(pTHX) if (gimme == G_SCALAR) { if (type != OP_RCATLINE) { SV_CHECK_THINKFIRST_COW_DROP(TARG); - SvOK_off(TARG); + (void)SvOK_off(TARG); } SPAGAIN; PUSHTARG; @@ -1592,6 +1593,17 @@ Perl_do_readline(pTHX) (void)POPs; /* Unmatched wildcard? Chuck it... */ continue; } + } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */ + U8 *s = (U8*)SvPVX(sv) + offset; + STRLEN len = SvCUR(sv) - offset; + U8 *f; + + if (ckWARN(WARN_UTF8) && + !Perl_is_utf8_string_loc(aTHX_ s, len, &f)) + /* Emulate :encoding(utf8) warning in the same case. */ + Perl_warner(aTHX_ packWARN(WARN_UTF8), + "utf8 \"\\x%02X\" does not map to Unicode", + f < (U8*)SvEND(sv) ? *f : 0); } if (gimme == G_ARRAY) { if (SvLEN(sv) - SvCUR(sv) > 20) { @@ -1858,6 +1870,11 @@ PP(pp_iter) else { sv = AvARRAY(av)[++cx->blk_loop.iterix]; } + if (sv && SvREFCNT(sv) == 0) { + *itersvp = Nullsv; + Perl_croak(aTHX_ "Use of freed value in iteration"); + } + if (sv) SvTEMP_off(sv); else @@ -1972,7 +1989,7 @@ PP(pp_subst) ? REXEC_COPY_STR : 0; if (SvSCREAM(TARG)) r_flags |= REXEC_SCREAM; - if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) { + if ((int)(pm->op_pmflags & PMf_MULTILINE) != PL_multiline) { SAVEINT(PL_multiline); PL_multiline = pm->op_pmflags & PMf_MULTILINE; } @@ -2154,6 +2171,7 @@ PP(pp_subst) if (!c) { register PERL_CONTEXT *cx; SPAGAIN; + ReREFCNT_inc(rx); PUSHSUBST(cx); RETURNOP(cPMOP->op_pmreplroot); } @@ -2283,6 +2301,7 @@ PP(pp_leavesub) SV *sv; POPBLOCK(cx,newpm); + cxstack_ix++; /* temporarily protect top context */ TAINT_NOT; if (gimme == G_SCALAR) { @@ -2321,6 +2340,7 @@ PP(pp_leavesub) PUTBACK; LEAVE; + cxstack_ix--; POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */ PL_curpm = newpm; /* ... and pop $1 et al */ @@ -2341,6 +2361,7 @@ PP(pp_leavesublv) SV *sv; POPBLOCK(cx,newpm); + cxstack_ix++; /* temporarily protect top context */ TAINT_NOT; @@ -2377,6 +2398,7 @@ PP(pp_leavesublv) * TEMP, so sv_2mortal is out of question. */ if (!CvLVALUE(cx->blk_sub.cv)) { LEAVE; + cxstack_ix--; POPSUB(cx,sv); PL_curpm = newpm; LEAVESUB(sv); @@ -2388,6 +2410,7 @@ PP(pp_leavesublv) if (MARK == SP) { if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) { LEAVE; + cxstack_ix--; POPSUB(cx,sv); PL_curpm = newpm; LEAVESUB(sv); @@ -2403,6 +2426,7 @@ PP(pp_leavesublv) } else { /* Should not happen? */ LEAVE; + cxstack_ix--; POPSUB(cx,sv); PL_curpm = newpm; LEAVESUB(sv); @@ -2419,6 +2443,7 @@ PP(pp_leavesublv) /* Might be flattened array after $#array = */ PUTBACK; LEAVE; + cxstack_ix--; POPSUB(cx,sv); PL_curpm = newpm; LEAVESUB(sv); @@ -2473,6 +2498,7 @@ PP(pp_leavesublv) PUTBACK; LEAVE; + cxstack_ix--; POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */ PL_curpm = newpm; /* ... and pop $1 et al */ @@ -2931,7 +2957,7 @@ S_method_common(pTHX_ SV* meth, U32* hashp) HE* he; he = hv_fetch_ent(PL_stashcache, sv, 0, 0); if (he) { - stash = (HV*)SvIV(HeVAL(he)); + stash = INT2PTR(HV*,SvIV(HeVAL(he))); goto fetch; } } @@ -2957,7 +2983,7 @@ S_method_common(pTHX_ SV* meth, U32* hashp) if (!stash) packsv = sv; else { - SV* ref = newSViv((IV)stash); + SV* ref = newSViv(PTR2IV(stash)); hv_store(PL_stashcache, packname, packlen, ref, 0); } goto fetch; @@ -3016,7 +3042,11 @@ S_method_common(pTHX_ SV* meth, U32* hashp) /* the method name is unqualified or starts with SUPER:: */ packname = sep ? CopSTASHPV(PL_curcop) : stash ? HvNAME(stash) : packname; - packlen = strlen(packname); + if (!packname) + Perl_croak(aTHX_ + "Can't use anonymous symbol table for method lookup"); + else + packlen = strlen(packname); } else { /* the method name is qualified */