X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pp_ctl.c;h=d20396009dbccac48d3ee869266422eef9885a4d;hb=c86ffc3299ed26fc3616b4d2bb0abdf2e70a0ad1;hp=dc6c215ffae521b95cbed041e55a2712bb99d8cd;hpb=e8e72d41921b8365de491c29d17ce128c04ed94d;p=p5sagit%2Fp5-mst-13.2.git diff --git a/pp_ctl.c b/pp_ctl.c index dc6c215..d203960 100644 --- a/pp_ctl.c +++ b/pp_ctl.c @@ -1,7 +1,7 @@ /* pp_ctl.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. @@ -9,12 +9,14 @@ */ /* - * Now far ahead the Road has gone, - * And I must follow, if I can, - * Pursuing it with eager feet, - * Until it joins some larger way - * Where many paths and errands meet. - * And whither then? I cannot say. + * Now far ahead the Road has gone, + * And I must follow, if I can, + * Pursuing it with eager feet, + * Until it joins some larger way + * Where many paths and errands meet. + * And whither then? I cannot say. + * + * [Bilbo on p.35 of _The Lord of the Rings_, I/i: "A Long-Expected Party"] */ /* This file contains control-oriented pp ("push/pop") functions that @@ -91,36 +93,84 @@ PP(pp_regcomp) RETURN; } #endif + +#define tryAMAGICregexp(rx) \ + STMT_START { \ + if (SvROK(rx) && SvAMAGIC(rx)) { \ + SV *sv = AMG_CALLun(rx, regexp); \ + if (sv) { \ + if (SvROK(sv)) \ + sv = SvRV(sv); \ + if (SvTYPE(sv) != SVt_REGEXP) \ + Perl_croak(aTHX_ "Overloaded qr did not return a REGEXP"); \ + rx = sv; \ + } \ + } \ + } STMT_END + + if (PL_op->op_flags & OPf_STACKED) { /* multiple args; concatentate them */ dMARK; dORIGMARK; tmpstr = PAD_SV(ARGTARG); - sv_setpvn(tmpstr, "", 0); + sv_setpvs(tmpstr, ""); while (++MARK <= SP) { + SV *msv = *MARK; if (PL_amagic_generation) { SV *sv; - if ((SvAMAGIC(tmpstr) || SvAMAGIC(*MARK)) && - (sv = amagic_call(tmpstr, *MARK, concat_amg, AMGf_assign))) + + tryAMAGICregexp(msv); + + if ((SvAMAGIC(tmpstr) || SvAMAGIC(msv)) && + (sv = amagic_call(tmpstr, msv, concat_amg, AMGf_assign))) { sv_setsv(tmpstr, sv); continue; } } - sv_catsv(tmpstr, *MARK); + sv_catsv(tmpstr, msv); } SvSETMAGIC(tmpstr); SP = ORIGMARK; } - else + else { tmpstr = POPs; + tryAMAGICregexp(tmpstr); + } + +#undef tryAMAGICregexp if (SvROK(tmpstr)) { SV * const sv = SvRV(tmpstr); if (SvTYPE(sv) == SVt_REGEXP) re = (REGEXP*) sv; } + else if (SvTYPE(tmpstr) == SVt_REGEXP) + re = (REGEXP*) tmpstr; + if (re) { - re = reg_temp_copy(re); + /* The match's LHS's get-magic might need to access this op's reg- + exp (as is sometimes the case with $'; see bug 70764). So we + must call get-magic now before we replace the regexp. Hopeful- + ly this hack can be replaced with the approach described at + http://www.nntp.perl.org/group/perl.perl5.porters/2007/03 + /msg122415.html some day. */ + if(pm->op_type == OP_MATCH) { + SV *lhs; + const bool was_tainted = PL_tainted; + if (pm->op_flags & OPf_STACKED) + lhs = TOPs; + else if (pm->op_private & OPpTARGET_MY) + lhs = PAD_SV(pm->op_targ); + else lhs = DEFSV; + SvGETMAGIC(lhs); + /* Restore the previous value of PL_tainted (which may have been + modified by get-magic), to avoid incorrectly setting the + RXf_TAINTED flag further down. */ + PL_tainted = was_tainted; + } + + re = reg_temp_copy(NULL, re); ReREFCNT_dec(PM_GETRE(pm)); PM_SETRE(pm, re); } @@ -214,6 +264,9 @@ PP(pp_substcont) register REGEXP * const rx = cx->sb_rx; SV *nsv = NULL; REGEXP *old = PM_GETRE(pm); + + PERL_ASYNC_CHECK(); + if(old != rx) { if(old) ReREFCNT_dec(old); @@ -228,16 +281,21 @@ PP(pp_substcont) if (cx->sb_iters > cx->sb_maxiters) DIE(aTHX_ "Substitution loop"); + SvGETMAGIC(TOPs); /* possibly clear taint on $1 etc: #67962 */ + if (!(cx->sb_rxtainted & 2) && SvTAINTED(TOPs)) cx->sb_rxtainted |= 2; - sv_catsv(dstr, POPs); + sv_catsv_nomg(dstr, POPs); + /* XXX: adjust for positive offsets of \G for instance s/(.)\G//g with positive pos() */ + s -= RX_GOFS(rx); /* Are we done */ - if (CxONCE(cx) || !CALLREGEXEC(rx, s, cx->sb_strend, orig, - s == m, cx->sb_targ, NULL, - ((cx->sb_rflags & REXEC_COPY_STR) - ? (REXEC_IGNOREPOS|REXEC_NOT_FIRST) - : (REXEC_COPY_STR|REXEC_IGNOREPOS|REXEC_NOT_FIRST)))) + if (CxONCE(cx) || s < orig || + !CALLREGEXEC(rx, s, cx->sb_strend, orig, + (s == m) + RX_GOFS(rx), cx->sb_targ, NULL, + ((cx->sb_rflags & REXEC_COPY_STR) + ? (REXEC_IGNOREPOS|REXEC_NOT_FIRST) + : (REXEC_COPY_STR|REXEC_IGNOREPOS|REXEC_NOT_FIRST)))) { SV * const targ = cx->sb_targ; @@ -355,8 +413,8 @@ Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx) } } -void -Perl_rxres_restore(pTHX_ void **rsp, REGEXP *rx) +static void +S_rxres_restore(pTHX_ void **rsp, REGEXP *rx) { UV *p = (UV*)*rsp; U32 i; @@ -385,8 +443,8 @@ Perl_rxres_restore(pTHX_ void **rsp, REGEXP *rx) } } -void -Perl_rxres_free(pTHX_ void **rsp) +static void +S_rxres_free(pTHX_ void **rsp) { UV * const p = (UV*)*rsp; @@ -509,8 +567,7 @@ PP(pp_formline) if (!targ_is_utf8 && DO_UTF8(tmpForm)) { SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget)); *t = '\0'; - sv_utf8_upgrade(PL_formtarget); - SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1); + sv_utf8_upgrade_flags_grow(PL_formtarget, SV_GMAGIC, fudge + 1); t = SvEND(PL_formtarget); targ_is_utf8 = TRUE; } @@ -531,8 +588,7 @@ PP(pp_formline) sv = *++MARK; else { sv = &PL_sv_no; - if (ckWARN(WARN_SYNTAX)) - Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Not enough format arguments"); + Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "Not enough format arguments"); } break; @@ -693,8 +749,8 @@ PP(pp_formline) if (!targ_is_utf8) { SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget)); *t = '\0'; - sv_utf8_upgrade(PL_formtarget); - SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1); + sv_utf8_upgrade_flags_grow(PL_formtarget, SV_GMAGIC, + fudge + 1); t = SvEND(PL_formtarget); targ_is_utf8 = TRUE; } @@ -773,7 +829,7 @@ PP(pp_formline) if (itemsize) { STRLEN to_copy = itemsize; const char *const send = s + len; - const U8 *source; + const U8 *source = (const U8 *) s; U8 *tmp = NULL; gotsome = TRUE; @@ -794,7 +850,7 @@ PP(pp_formline) } } if (targ_is_utf8 && !item_is_utf8) { - source = tmp = bytes_to_utf8((U8*)SvPVX(sv), &to_copy); + source = tmp = bytes_to_utf8(source, &to_copy); SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget)); } else { @@ -805,12 +861,11 @@ PP(pp_formline) t - SvPVX_const(PL_formtarget)); targ_is_utf8 = TRUE; /* Don't need get magic. */ - sv_utf8_upgrade_flags(PL_formtarget, 0); + sv_utf8_upgrade_nomg(PL_formtarget); } else { SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget)); } - source = (U8 *) SvPVX(sv); /* Easy. They agree. */ assert (item_is_utf8 == targ_is_utf8); @@ -901,11 +956,6 @@ PP(pp_formline) *t = '\0'; SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget)); lines += FmLINES(PL_formtarget); - if (lines == 200) { - arg = t - linemark; - if (strnEQ(linemark, linemark - arg, arg)) - DIE(aTHX_ "Runaway format"); - } if (targ_is_utf8) SvUTF8_on(PL_formtarget); FmLINES(PL_formtarget) = lines; @@ -972,14 +1022,14 @@ PP(pp_grepstart) PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1; pp_pushmark(); /* push dst */ pp_pushmark(); /* push src */ - ENTER; /* enter outer scope */ + ENTER_with_name("grep"); /* enter outer scope */ SAVETMPS; if (PL_op->op_private & OPpGREP_LEX) SAVESPTR(PAD_SVl(PL_op->op_targ)); else SAVE_DEFSV; - ENTER; /* enter inner scope */ + ENTER_with_name("grep_item"); /* enter inner scope */ SAVEVPTR(PL_curpm); src = PL_stack_base[*PL_markstack_ptr]; @@ -987,7 +1037,7 @@ PP(pp_grepstart) if (PL_op->op_private & OPpGREP_LEX) PAD_SVl(PL_op->op_targ) = src; else - DEFSV = src; + DEFSV_set(src); PUTBACK; if (PL_op->op_type == OP_MAPSTART) @@ -1060,13 +1110,13 @@ PP(pp_mapwhile) } } } - LEAVE; /* exit inner scope */ + LEAVE_with_name("grep_item"); /* exit inner scope */ /* All done yet? */ if (PL_markstack_ptr[-1] > *PL_markstack_ptr) { (void)POPMARK; /* pop top */ - LEAVE; /* exit outer scope */ + LEAVE_with_name("grep"); /* exit outer scope */ (void)POPMARK; /* pop src */ items = --*PL_markstack_ptr - PL_markstack_ptr[-1]; (void)POPMARK; /* pop dst */ @@ -1089,7 +1139,7 @@ PP(pp_mapwhile) else { SV *src; - ENTER; /* enter inner scope */ + ENTER_with_name("grep_item"); /* enter inner scope */ SAVEVPTR(PL_curpm); /* set $_ to the new source item */ @@ -1098,7 +1148,7 @@ PP(pp_mapwhile) if (PL_op->op_private & OPpGREP_LEX) PAD_SVl(PL_op->op_targ) = src; else - DEFSV = src; + DEFSV_set(src); RETURNOP(cLOGOP->op_other); } @@ -1155,7 +1205,7 @@ PP(pp_flip) RETURNOP(((LOGOP*)cUNOP->op_first)->op_other); } } - sv_setpvn(TARG, "", 0); + sv_setpvs(TARG, ""); SETs(targ); RETURN; } @@ -1251,9 +1301,9 @@ PP(pp_flop) static const char * const context_name[] = { "pseudo-block", - "when", + NULL, /* CXt_WHEN never actually needs "block" */ NULL, /* CXt_BLOCK never actually needs "block" */ - "given", + NULL, /* CXt_GIVEN never actually needs "block" */ NULL, /* CXt_LOOP_FOR never actually needs "loop" */ NULL, /* CXt_LOOP_PLAIN never actually needs "loop" */ NULL, /* CXt_LOOP_LAZYSV never actually needs "loop" */ @@ -1280,11 +1330,8 @@ S_dopoptolabel(pTHX_ const char *label) case CXt_FORMAT: case CXt_EVAL: case CXt_NULL: - case CXt_GIVEN: - case CXt_WHEN: - if (ckWARN(WARN_EXITING)) - Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s", - context_name[CxTYPE(cx)], OP_NAME(PL_op)); + Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s", + context_name[CxTYPE(cx)], OP_NAME(PL_op)); if (CxTYPE(cx) == CXt_NULL) return -1; break; @@ -1292,13 +1339,16 @@ S_dopoptolabel(pTHX_ const char *label) case CXt_LOOP_LAZYSV: case CXt_LOOP_FOR: case CXt_LOOP_PLAIN: - if ( !CxLABEL(cx) || strNE(label, CxLABEL(cx)) ) { - DEBUG_l(Perl_deb(aTHX_ "(Skipping label #%ld %s)\n", - (long)i, CxLABEL(cx))); + { + const char *cx_label = CxLABEL(cx); + if (!cx_label || strNE(label, cx_label) ) { + DEBUG_l(Perl_deb(aTHX_ "(poptolabel(): skipping label at cx=%ld %s)\n", + (long)i, cx_label)); continue; } - DEBUG_l( Perl_deb(aTHX_ "(Found label #%ld %s)\n", (long)i, label)); + DEBUG_l( Perl_deb(aTHX_ "(poptolabel(): found label at cx=%ld %s)\n", (long)i, label)); return i; + } } } return i; @@ -1365,7 +1415,7 @@ S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32 startingblock) case CXt_EVAL: case CXt_SUB: case CXt_FORMAT: - DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i)); + DEBUG_l( Perl_deb(aTHX_ "(dopoptosub_at(): found sub at cx=%ld)\n", (long)i)); return i; } } @@ -1383,7 +1433,7 @@ S_dopoptoeval(pTHX_ I32 startingblock) default: continue; case CXt_EVAL: - DEBUG_l( Perl_deb(aTHX_ "(Found eval #%ld)\n", (long)i)); + DEBUG_l( Perl_deb(aTHX_ "(dopoptoeval(): found eval at cx=%ld)\n", (long)i)); return i; } } @@ -1403,9 +1453,8 @@ S_dopoptoloop(pTHX_ I32 startingblock) case CXt_FORMAT: case CXt_EVAL: case CXt_NULL: - if (ckWARN(WARN_EXITING)) - Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s", - context_name[CxTYPE(cx)], OP_NAME(PL_op)); + Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s", + context_name[CxTYPE(cx)], OP_NAME(PL_op)); if ((CxTYPE(cx)) == CXt_NULL) return -1; break; @@ -1413,7 +1462,7 @@ S_dopoptoloop(pTHX_ I32 startingblock) case CXt_LOOP_LAZYSV: case CXt_LOOP_FOR: case CXt_LOOP_PLAIN: - DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i)); + DEBUG_l( Perl_deb(aTHX_ "(dopoptoloop(): found loop at cx=%ld)\n", (long)i)); return i; } } @@ -1431,7 +1480,7 @@ S_dopoptogiven(pTHX_ I32 startingblock) default: continue; case CXt_GIVEN: - DEBUG_l( Perl_deb(aTHX_ "(Found given #%ld)\n", (long)i)); + DEBUG_l( Perl_deb(aTHX_ "(dopoptogiven(): found given at cx=%ld)\n", (long)i)); return i; case CXt_LOOP_PLAIN: assert(!CxFOREACHDEF(cx)); @@ -1440,7 +1489,7 @@ S_dopoptogiven(pTHX_ I32 startingblock) case CXt_LOOP_LAZYSV: case CXt_LOOP_FOR: if (CxFOREACHDEF(cx)) { - DEBUG_l( Perl_deb(aTHX_ "(Found foreach #%ld)\n", (long)i)); + DEBUG_l( Perl_deb(aTHX_ "(dopoptogiven(): found foreach at cx=%ld)\n", (long)i)); return i; } } @@ -1459,7 +1508,7 @@ S_dopoptowhen(pTHX_ I32 startingblock) default: continue; case CXt_WHEN: - DEBUG_l( Perl_deb(aTHX_ "(Found when #%ld)\n", (long)i)); + DEBUG_l( Perl_deb(aTHX_ "(dopoptowhen(): found when at cx=%ld)\n", (long)i)); return i; } } @@ -1475,8 +1524,7 @@ Perl_dounwind(pTHX_ I32 cxix) while (cxstack_ix > cxix) { SV *sv; register PERL_CONTEXT *cx = &cxstack[cxstack_ix]; - DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n", - (long) cxstack_ix, PL_block_type[CxTYPE(cx)])); + DEBUG_CX("UNWIND"); \ /* Note: we don't need to restore the base context info till the end. */ switch (CxTYPE(cx)) { case CXt_SUBST: @@ -1523,44 +1571,18 @@ Perl_qerror(pTHX_ SV *err) ++PL_parser->error_count; } -OP * -Perl_die_where(pTHX_ const char *message, STRLEN msglen) +void +Perl_die_unwind(pTHX_ SV *msv) { dVAR; + SV *exceptsv = sv_mortalcopy(msv); + U8 in_eval = PL_in_eval; + PERL_ARGS_ASSERT_DIE_UNWIND; - if (PL_in_eval) { + if (in_eval) { I32 cxix; I32 gimme; - if (message) { - if (PL_in_eval & EVAL_KEEPERR) { - static const char prefix[] = "\t(in cleanup) "; - SV * const err = ERRSV; - const char *e = NULL; - if (!SvPOK(err)) - sv_setpvn(err,"",0); - else if (SvCUR(err) >= sizeof(prefix)+msglen-1) { - STRLEN len; - e = SvPV_const(err, len); - e += len - msglen; - if (*e != *message || strNE(e,message)) - e = NULL; - } - if (!e) { - SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen); - sv_catpvn(err, prefix, sizeof(prefix)-1); - sv_catpvn(err, message, msglen); - if (ckWARN(WARN_MISC)) { - const STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1; - Perl_warner(aTHX_ packWARN(WARN_MISC), SvPVX_const(err)+start); - } - } - } - else { - sv_setpvn(ERRSV, message, msglen); - } - } - while ((cxix = dopoptoeval(cxstack_ix)) < 0 && PL_curstackinfo->si_prev) { @@ -1570,6 +1592,7 @@ Perl_die_where(pTHX_ const char *message, STRLEN msglen) if (cxix >= 0) { I32 optype; + SV *namesv; register PERL_CONTEXT *cx; SV **newsp; @@ -1578,13 +1601,14 @@ Perl_die_where(pTHX_ const char *message, STRLEN msglen) POPBLOCK(cx,PL_curpm); if (CxTYPE(cx) != CXt_EVAL) { - if (!message) - message = SvPVx_const(ERRSV, msglen); + STRLEN msglen; + const char* message = SvPVx_const(exceptsv, msglen); PerlIO_write(Perl_error_log, (const char *)"panic: die ", 11); PerlIO_write(Perl_error_log, message, msglen); my_exit(1); } POPEVAL(cx); + namesv = cx->blk_eval.old_namesv; if (gimme == G_SCALAR) *++newsp = &PL_sv_undef; @@ -1599,24 +1623,35 @@ Perl_die_where(pTHX_ const char *message, STRLEN msglen) PL_curcop = cx->blk_oldcop; if (optype == OP_REQUIRE) { - const char* const msg = SvPVx_nolen_const(ERRSV); - SV * const nsv = cx->blk_eval.old_namesv; - (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), + const char* const msg = SvPVx_nolen_const(exceptsv); + (void)hv_store(GvHVn(PL_incgv), + SvPVX_const(namesv), SvCUR(namesv), &PL_sv_undef, 0); + /* note that unlike pp_entereval, pp_require isn't + * supposed to trap errors. So now that we've popped the + * EVAL that pp_require pushed, and processed the error + * message, rethrow the error */ DIE(aTHX_ "%sCompilation failed in require", *msg ? msg : "Unknown error\n"); } + if (in_eval & EVAL_KEEPERR) { + Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %s", + SvPV_nolen_const(exceptsv)); + } + else { + sv_setsv(ERRSV, exceptsv); + } assert(CxTYPE(cx) == CXt_EVAL); - return cx->blk_eval.retop; + PL_restartjmpenv = cx->blk_eval.cur_top_env; + PL_restartop = cx->blk_eval.retop; + JMPENV_JUMP(3); + /* NOTREACHED */ } } - if (!message) - message = SvPVx_const(ERRSV, msglen); - write_to_stderr(message, msglen); + write_to_stderr(exceptsv); my_failure_exit(); /* NOTREACHED */ - return 0; } PP(pp_xor) @@ -1750,9 +1785,8 @@ PP(pp_caller) const int off = AvARRAY(ary) - AvALLOC(ary); if (!PL_dbargs) { - GV* const tmpgv = gv_fetchpvs("DB::args", GV_ADD, SVt_PVAV); - PL_dbargs = GvAV(gv_AVadd(tmpgv)); - GvMULTI_on(tmpgv); + PL_dbargs = GvAV(gv_AVadd(gv_fetchpvs("DB::args", GV_ADDMULTI, + SVt_PVAV))); AvREAL_off(PL_dbargs); /* XXX should be REIFY (see av.h) */ } @@ -1777,7 +1811,7 @@ PP(pp_caller) /* Get the bit mask for $warnings::Bits{all}, because * it could have been extended by warnings::register */ SV **bits_all; - HV * const bits = get_hv("warnings::Bits", FALSE); + HV * const bits = get_hv("warnings::Bits", 0); if (bits && (bits_all=hv_fetchs(bits, "all", FALSE))) { mask = newSVsv(*bits_all); } @@ -1792,8 +1826,8 @@ PP(pp_caller) PUSHs(cx->blk_oldcop->cop_hints_hash ? sv_2mortal(newRV_noinc( - (SV*)Perl_refcounted_he_chain_2hv(aTHX_ - cx->blk_oldcop->cop_hints_hash))) + MUTABLE_SV(Perl_refcounted_he_chain_2hv(aTHX_ + cx->blk_oldcop->cop_hints_hash)))) : &PL_sv_undef); RETURN; } @@ -1818,6 +1852,8 @@ PP(pp_dbstate) PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp; FREETMPS; + PERL_ASYNC_CHECK(); + if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */ || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace)) { @@ -1878,7 +1914,7 @@ PP(pp_enteriter) PAD *iterdata; #endif - ENTER; + ENTER_with_name("loop1"); SAVETMPS; if (PL_op->op_targ) { @@ -1895,7 +1931,7 @@ PP(pp_enteriter) #endif } else { - GV * const gv = (GV*)POPs; + GV * const gv = MUTABLE_GV(POPs); svp = &GvSV(gv); /* symbol table variable */ SAVEGENERICSV(*svp); *svp = newSV(0); @@ -1907,7 +1943,7 @@ PP(pp_enteriter) if (PL_op->op_private & OPpITER_DEF) cxtype |= CXp_FOR_DEF; - ENTER; + ENTER_with_name("loop2"); PUSHBLOCK(cx, cxtype, SP); #ifdef USE_ITHREADS @@ -1977,7 +2013,7 @@ PP(pp_enteriter) } } else /* SvTYPE(maybe_ary) == SVt_PVAV */ { - cx->blk_loop.state_u.ary.ary = (AV*)maybe_ary; + cx->blk_loop.state_u.ary.ary = MUTABLE_AV(maybe_ary); SvREFCNT_inc(maybe_ary); cx->blk_loop.state_u.ary.ix = (PL_op->op_private & OPpITER_REVERSED) ? @@ -2004,9 +2040,9 @@ PP(pp_enterloop) register PERL_CONTEXT *cx; const I32 gimme = GIMME_V; - ENTER; + ENTER_with_name("loop1"); SAVETMPS; - ENTER; + ENTER_with_name("loop2"); PUSHBLOCK(cx, CXt_LOOP_PLAIN, SP); PUSHLOOP_PLAIN(cx, SP); @@ -2049,8 +2085,8 @@ PP(pp_leaveloop) POPLOOP(cx); /* Stack values are safe: release loop vars ... */ PL_curpm = newpm; /* ... and pop $1 et al */ - LEAVE; - LEAVE; + LEAVE_with_name("loop2"); + LEAVE_with_name("loop1"); return NORMAL; } @@ -2065,8 +2101,9 @@ PP(pp_return) SV **newsp; PMOP *newpm; I32 optype = 0; + SV *namesv; SV *sv; - OP *retop; + OP *retop = NULL; const I32 cxix = dopoptosub(cxstack_ix); @@ -2107,6 +2144,7 @@ PP(pp_return) if (!(PL_in_eval & EVAL_KEEPERR)) clear_errsv = TRUE; POPEVAL(cx); + namesv = cx->blk_eval.old_namesv; retop = cx->blk_eval.retop; if (CxTRYBLOCK(cx)) break; @@ -2115,9 +2153,10 @@ PP(pp_return) (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) ) { /* Unassume the success we assumed earlier. */ - SV * const nsv = cx->blk_eval.old_namesv; - (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD); - DIE(aTHX_ "%"SVf" did not return a true value", SVfARG(nsv)); + (void)hv_delete(GvHVn(PL_incgv), + SvPVX_const(namesv), SvCUR(namesv), + G_DISCARD); + DIE(aTHX_ "%"SVf" did not return a true value", SVfARG(namesv)); } break; case CXt_FORMAT: @@ -2188,7 +2227,7 @@ PP(pp_last) I32 pop2 = 0; I32 gimme; I32 optype; - OP *nextop; + OP *nextop = NULL; SV **newsp; PMOP *newpm; SV **mark; @@ -2370,9 +2409,11 @@ S_dofindlabel(pTHX_ OP *o, const char *label, OP **opstack, OP **oplimit) OP *kid; /* First try all the kids at this level, since that's likeliest. */ for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) { - if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) && - CopLABEL(kCOP) && strEQ(CopLABEL(kCOP), label)) - return kid; + if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) { + const char *kid_label = CopLABEL(kCOP); + if (kid_label && strEQ(kid_label, label)) + return kid; + } } for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) { if (kid == PL_lastgotoprobe) @@ -2413,7 +2454,7 @@ PP(pp_goto) if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) { I32 cxix; register PERL_CONTEXT *cx; - CV* cv = (CV*)SvRV(sv); + CV *cv = MUTABLE_CV(SvRV(sv)); SV** mark; I32 items = 0; I32 oldsave; @@ -2475,7 +2516,7 @@ PP(pp_goto) av = newAV(); av_extend(av, items-1); AvREIFY_only(av); - PAD_SVl(0) = (SV*)(cx->blk_sub.argarray = av); + PAD_SVl(0) = MUTABLE_SV(cx->blk_sub.argarray = av); } } else if (CvISXSUB(cv)) { /* put GvAV(defgv) back onto stack */ @@ -2536,10 +2577,10 @@ PP(pp_goto) PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv)); if (CxHASARGS(cx)) { - AV* const av = (AV*)PAD_SVl(0); + AV *const av = MUTABLE_AV(PAD_SVl(0)); cx->blk_sub.savearray = GvAV(PL_defgv); - GvAV(PL_defgv) = (AV*)SvREFCNT_inc_simple(av); + GvAV(PL_defgv) = MUTABLE_AV(SvREFCNT_inc_simple(av)); CX_CURPAD_SAVE(cx->blk_sub); cx->blk_sub.argarray = av; @@ -2574,10 +2615,10 @@ PP(pp_goto) if (PERLDB_SUB) { /* Checking curstash breaks DProf. */ Perl_get_db_sub(aTHX_ NULL, cv); if (PERLDB_GOTO) { - CV * const gotocv = get_cv("DB::goto", FALSE); + CV * const gotocv = get_cvs("DB::goto", 0); if (gotocv) { PUSHMARK( PL_stack_sp ); - call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG); + call_sv(MUTABLE_SV(gotocv), G_SCALAR | G_NODEBUG); PL_stack_sp--; } } @@ -2598,6 +2639,8 @@ PP(pp_goto) else label = cPVOP->op_pv; + PERL_ASYNC_CHECK(); + if (label && *label) { OP *gotoprobe = NULL; bool leaving_eval = FALSE; @@ -2625,6 +2668,8 @@ PP(pp_goto) case CXt_LOOP_LAZYSV: case CXt_LOOP_FOR: case CXt_LOOP_PLAIN: + case CXt_GIVEN: + case CXt_WHEN: gotoprobe = cx->blk_oldcop->op_sibling; break; case CXt_SUBST: @@ -2673,6 +2718,12 @@ PP(pp_goto) DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop"); } + if (*enterops && enterops[1]) { + I32 i = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1; + if (enterops[i]) + deprecate("\"goto\" to jump into a construct"); + } + /* pop unwanted frames */ if (ix < cxstack_ix) { @@ -2762,7 +2813,7 @@ S_save_lines(pTHX_ AV *array, SV *sv) const char *t; SV * const tmpstr = newSV_type(SVt_PVMG); - t = strchr(s, '\n'); + t = (const char *)memchr(s, '\n', send - s); if (t) t++; else @@ -2774,6 +2825,20 @@ S_save_lines(pTHX_ AV *array, SV *sv) } } +/* +=for apidoc docatch + +Check for the cases 0 or 3 of cur_env.je_ret, only used inside an eval context. + +0 is used as continue inside eval, + +3 is used for a die caught by an inner eval - continue inner loop + +See cop.h: je_mustcatch, when set at any runlevel to TRUE, means eval ops must +establish a local jmpenv to handle exception traps. + +=cut +*/ STATIC OP * S_docatch(pTHX_ OP *o) { @@ -2798,17 +2863,8 @@ S_docatch(pTHX_ OP *o) break; case 3: /* die caught by an inner eval - continue inner loop */ - - /* NB XXX we rely on the old popped CxEVAL still being at the top - * of the stack; the way die_where() currently works, this - * assumption is valid. In theory The cur_top_env value should be - * returned in another global, the way retop (aka PL_restartop) - * is. */ - assert(CxTYPE(&cxstack[cxstack_ix+1]) == CXt_EVAL); - - if (PL_restartop - && cxstack[cxstack_ix+1].blk_eval.cur_top_env == PL_top_env) - { + if (PL_restartop && PL_restartjmpenv == PL_top_env) { + PL_restartjmpenv = NULL; PL_op = PL_restartop; PL_restartop = 0; goto redo_body; @@ -2825,13 +2881,20 @@ S_docatch(pTHX_ OP *o) return NULL; } +/* James Bond: Do you expect me to talk? + Auric Goldfinger: No, Mr. Bond. I expect you to die. + + This code is an ugly hack, doesn't work with lexicals in subroutines that are + called more than once, and is only used by regcomp.c, for (?{}) blocks. + + Currently it is not used outside the core code. Best if it stays that way. +*/ OP * Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp) /* sv Text to convert to OP tree. */ /* startop op_free() this to undo. */ /* code Short string id of the caller. */ { - /* FIXME - how much of this code is common with pp_entereval? */ dVAR; dSP; /* Make POPBLOCK work. */ PERL_CONTEXT *cx; SV **newsp; @@ -2847,7 +2910,7 @@ Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp) PERL_ARGS_ASSERT_SV_COMPILE_2OP; - ENTER; + ENTER_with_name("eval"); lex_start(sv, NULL, FALSE); SAVETMPS; /* switch to eval mode */ @@ -2907,8 +2970,8 @@ Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp) (*startop)->op_ppaddr = PL_ppaddr[OP_NULL]; lex_end(); /* XXX DAPM do this properly one year */ - *padp = (AV*)SvREFCNT_inc_simple(PL_comppad); - LEAVE; + *padp = MUTABLE_AV(SvREFCNT_inc_simple(PL_comppad)); + LEAVE_with_name("eval"); if (IN_PERL_COMPILETIME) CopHINTS_set(&PL_compiling, PL_hints); #ifdef OP_IN_REGISTER @@ -2962,6 +3025,35 @@ Perl_find_runcv(pTHX_ U32 *db_seqp) } +/* Run yyparse() in a setjmp wrapper. Returns: + * 0: yyparse() successful + * 1: yyparse() failed + * 3: yyparse() died + */ +STATIC int +S_try_yyparse(pTHX) +{ + int ret; + dJMPENV; + + assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL); + JMPENV_PUSH(ret); + switch (ret) { + case 0: + ret = yyparse() ? 1 : 0; + break; + case 3: + break; + default: + JMPENV_POP; + JMPENV_JUMP(ret); + /* NOTREACHED */ + } + JMPENV_POP; + return ret; +} + + /* Compile a require/do, an eval '', or a /(?{...})/. * In the last case, startop is non-null, and contains the address of * a pointer that should be set to the just-compiled code. @@ -2976,21 +3068,23 @@ S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq) { dVAR; dSP; OP * const saveop = PL_op; + bool in_require = (saveop && saveop->op_type == OP_REQUIRE); + int yystatus; - PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE) + PL_in_eval = (in_require ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL)) : EVAL_INEVAL); PUSHMARK(SP); SAVESPTR(PL_compcv); - PL_compcv = (CV*)newSV_type(SVt_PVCV); + PL_compcv = MUTABLE_CV(newSV_type(SVt_PVCV)); CvEVAL_on(PL_compcv); assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL); cxstack[cxstack_ix].blk_eval.cv = PL_compcv; CvOUTSIDE_SEQ(PL_compcv) = seq; - CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc_simple(outside); + CvOUTSIDE(PL_compcv) = MUTABLE_CV(SvREFCNT_inc_simple(outside)); /* set up a scratch pad */ @@ -3029,36 +3123,61 @@ S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq) PL_in_eval |= EVAL_KEEPERR; else CLEAR_ERRSV(); - if (yyparse() || PL_parser->error_count || !PL_eval_root) { + + /* note that yyparse() may raise an exception, e.g. C, + * so honour CATCH_GET and trap it here if necessary */ + + yystatus = (!in_require && CATCH_GET) ? S_try_yyparse(aTHX) : yyparse(); + + if (yystatus || PL_parser->error_count || !PL_eval_root) { SV **newsp; /* Used by POPBLOCK. */ - PERL_CONTEXT *cx = &cxstack[cxstack_ix]; - I32 optype = 0; /* Might be reset by POPEVAL. */ + PERL_CONTEXT *cx = NULL; + I32 optype; /* Used by POPEVAL. */ + SV *namesv = NULL; const char *msg; + PERL_UNUSED_VAR(newsp); + PERL_UNUSED_VAR(optype); + + /* note that if yystatus == 3, then the EVAL CX block has already + * been popped, and various vars restored */ PL_op = saveop; - if (PL_eval_root) { - op_free(PL_eval_root); - PL_eval_root = NULL; - } - SP = PL_stack_base + POPMARK; /* pop original mark */ - if (!startop) { - POPBLOCK(cx,PL_curpm); - POPEVAL(cx); + if (yystatus != 3) { + if (PL_eval_root) { + op_free(PL_eval_root); + PL_eval_root = NULL; + } + SP = PL_stack_base + POPMARK; /* pop original mark */ + if (!startop) { + POPBLOCK(cx,PL_curpm); + POPEVAL(cx); + namesv = cx->blk_eval.old_namesv; + } } lex_end(); - LEAVE; + if (yystatus != 3) + LEAVE_with_name("eval"); /* pp_entereval knows about this LEAVE. */ msg = SvPVx_nolen_const(ERRSV); - if (optype == OP_REQUIRE) { - const SV * const nsv = cx->blk_eval.old_namesv; - (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), - &PL_sv_undef, 0); + if (in_require) { + if (!cx) { + /* If cx is still NULL, it means that we didn't go in the + * POPEVAL branch. */ + cx = &cxstack[cxstack_ix]; + assert(CxTYPE(cx) == CXt_EVAL); + namesv = cx->blk_eval.old_namesv; + } + (void)hv_store(GvHVn(PL_incgv), + SvPVX_const(namesv), SvCUR(namesv), + &PL_sv_undef, 0); Perl_croak(aTHX_ "%sCompilation failed in require", *msg ? msg : "Unknown error\n"); } else if (startop) { - POPBLOCK(cx,PL_curpm); - POPEVAL(cx); + if (yystatus != 3) { + POPBLOCK(cx,PL_curpm); + POPEVAL(cx); + } Perl_croak(aTHX_ "%sCompilation failed in regexp", (*msg ? msg : "Unknown error\n")); } @@ -3067,7 +3186,6 @@ S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq) sv_setpvs(ERRSV, "Compilation error"); } } - PERL_UNUSED_VAR(newsp); PUSHs(&PL_sv_undef); PUTBACK; return FALSE; @@ -3079,14 +3197,8 @@ S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq) SAVEFREEOP(PL_eval_root); /* Set the context for this new optree. - * If the last op is an OP_REQUIRE, force scalar context. - * Otherwise, propagate the context from the eval(). */ - if (PL_eval_root->op_type == OP_LEAVEEVAL - && cUNOPx(PL_eval_root)->op_first->op_type == OP_LINESEQ - && cLISTOPx(cUNOPx(PL_eval_root)->op_first)->op_last->op_type - == OP_REQUIRE) - scalar(PL_eval_root); - else if ((gimme & G_WANT) == G_VOID) + * Propagate the context from the eval(). */ + if ((gimme & G_WANT) == G_VOID) scalarvoid(PL_eval_root); else if ((gimme & G_WANT) == G_ARRAY) list(PL_eval_root); @@ -3097,13 +3209,13 @@ S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq) /* Register with debugger: */ if (PERLDB_INTER && saveop && saveop->op_type == OP_REQUIRE) { - CV * const cv = get_cv("DB::postponed", FALSE); + CV * const cv = get_cvs("DB::postponed", 0); if (cv) { dSP; PUSHMARK(SP); - XPUSHs((SV*)CopFILEGV(&PL_compiling)); + XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling))); PUTBACK; - call_sv((SV*)cv, G_DISCARD); + call_sv(MUTABLE_SV(cv), G_DISCARD); } } @@ -3209,14 +3321,14 @@ PP(pp_require) I32 first = 0; AV *lav; SV * const req = SvRV(sv); - SV * const pv = *hv_fetchs((HV*)req, "original", FALSE); + SV * const pv = *hv_fetchs(MUTABLE_HV(req), "original", FALSE); /* get the left hand term */ - lav = (AV *)SvRV(*hv_fetchs((HV*)req, "version", FALSE)); + lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(req), "version", FALSE))); first = SvIV(*av_fetch(lav,0,0)); if ( first > (int)PERL_REVISION /* probably 'use 6.0' */ - || hv_exists((HV*)req, "qv", 2 ) /* qv style */ + || hv_exists(MUTABLE_HV(req), "qv", 2 ) /* qv style */ || av_len(lav) > 1 /* FP with > 3 digits */ || strstr(SvPVX(pv),".0") /* FP with leading 0 */ ) { @@ -3225,21 +3337,21 @@ PP(pp_require) SVfARG(vnormal(PL_patchlevel))); } else { /* probably 'use 5.10' or 'use 5.8' */ - SV * hintsv = newSV(0); + SV *hintsv; I32 second = 0; if (av_len(lav)>=1) second = SvIV(*av_fetch(lav,1,0)); second /= second >= 600 ? 100 : 10; - hintsv = Perl_newSVpvf(aTHX_ "v%d.%d.%d", - (int)first, (int)second,0); + hintsv = Perl_newSVpvf(aTHX_ "v%d.%d.0", + (int)first, (int)second); upg_version(hintsv, TRUE); DIE(aTHX_ "Perl %"SVf" required (did you mean %"SVf"?)" "--this is only %"SVf", stopped", SVfARG(vnormal(req)), - SVfARG(vnormal(hintsv)), + SVfARG(vnormal(sv_2mortal(hintsv))), SVfARG(vnormal(PL_patchlevel))); } } @@ -3252,9 +3364,14 @@ PP(pp_require) vcmp(sv, sv_2mortal(upg_version(newSVnv(5.009005), FALSE))) >= 0) { SV *const importsv = vnormal(sv); *SvPVX_mutable(importsv) = ':'; - ENTER; + ENTER_with_name("load_feature"); Perl_load_module(aTHX_ 0, newSVpvs("feature"), NULL, importsv, NULL); - LEAVE; + LEAVE_with_name("load_feature"); + } + /* If a version >= 5.11.0 is requested, strictures are on by default! */ + if (PL_compcv && + vcmp(sv, sv_2mortal(upg_version(newSVnv(5.011000), FALSE))) >= 0) { + PL_hints |= (HINT_STRICT_REFS | HINT_STRICT_SUBS | HINT_STRICT_VARS); } RETPUSHYES; @@ -3303,17 +3420,6 @@ PP(pp_require) tryname = name; tryrsfp = doopen_pm(name, len); } -#ifdef MACOS_TRADITIONAL - if (!tryrsfp) { - char newname[256]; - - MacPerl_CanonDir(name, newname, 1); - if (path_is_absolute(newname)) { - tryname = newname; - tryrsfp = doopen_pm(newname, strlen(newname)); - } - } -#endif if (!tryrsfp) { AV * const ar = GvAVn(PL_incgv); I32 i; @@ -3325,7 +3431,7 @@ PP(pp_require) for (i = 0; i <= AvFILL(ar); i++) { SV * const dirsv = *av_fetch(ar, i, TRUE); - if (SvTIED_mg((SV*)ar, PERL_MAGIC_tied)) + if (SvTIED_mg((const SV *)ar, PERL_MAGIC_tied)) mg_get(dirsv); if (SvROK(dirsv)) { int count; @@ -3335,7 +3441,7 @@ PP(pp_require) if (SvTYPE(SvRV(loader)) == SVt_PVAV && !sv_isobject(loader)) { - loader = *av_fetch((AV *)SvRV(loader), 0, TRUE); + loader = *av_fetch(MUTABLE_AV(SvRV(loader)), 0, TRUE); } Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s", @@ -3343,7 +3449,7 @@ PP(pp_require) tryname = SvPVX_const(namesv); tryrsfp = NULL; - ENTER; + ENTER_with_name("call_INC"); SAVETMPS; EXTEND(SP, 2); @@ -3360,7 +3466,7 @@ PP(pp_require) /* Adjust file name if the hook has set an %INC entry */ svp = hv_fetch(GvHVn(PL_incgv), name, len, 0); if (svp) - tryname = SvPVX_const(*svp); + tryname = SvPV_nolen_const(*svp); if (count > 0) { int i = 0; @@ -3384,7 +3490,7 @@ PP(pp_require) } if (isGV_with_GP(arg)) { - IO * const io = GvIO((GV *)arg); + IO * const io = GvIO((const GV *)arg); ++filter_has_file; @@ -3421,7 +3527,7 @@ PP(pp_require) PUTBACK; FREETMPS; - LEAVE; + LEAVE_with_name("call_INC"); if (tryrsfp) { hook_sv = dirsv; @@ -3444,12 +3550,6 @@ PP(pp_require) } else { if (!path_is_absolute(name) -#ifdef MACOS_TRADITIONAL - /* We consider paths of the form :a:b ambiguous and interpret them first - as global then as local - */ - || (*name == ':' && name[1] != ':' && strchr(name+2, ':')) -#endif ) { const char *dir; STRLEN dirlen; @@ -3461,21 +3561,14 @@ PP(pp_require) dirlen = 0; } -#ifdef MACOS_TRADITIONAL - char buf1[256]; - char buf2[256]; - - MacPerl_CanonDir(name, buf2, 1); - Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf1, 0), buf2+(buf2[0] == ':')); -#else -# ifdef VMS +#ifdef VMS char *unixdir; if ((unixdir = tounixpath(dir, NULL)) == NULL) continue; sv_setpv(namesv, unixdir); sv_catpv(namesv, unixname); -# else -# ifdef __SYMBIAN32__ +#else +# ifdef __SYMBIAN32__ if (PL_origfilename[0] && PL_origfilename[1] == ':' && !(dir[0] && dir[1] == ':')) @@ -3487,7 +3580,7 @@ PP(pp_require) Perl_sv_setpvf(aTHX_ namesv, "%s\\%s", dir, name); -# else +# else /* The equivalent of Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name); but without the need to parse the format string, or @@ -3508,15 +3601,16 @@ PP(pp_require) /* Don't even actually have to turn SvPOK_on() as we access it directly with SvPVX() below. */ } -# endif # endif #endif TAINT_PROPER("require"); tryname = SvPVX_const(namesv); tryrsfp = doopen_pm(tryname, SvCUR(namesv)); if (tryrsfp) { - if (tryname[0] == '.' && tryname[1] == '/') - tryname += 2; + if (tryname[0] == '.' && tryname[1] == '/') { + ++tryname; + while (*++tryname == '/'); + } break; } else if (errno == EMFILE) @@ -3580,16 +3674,13 @@ PP(pp_require) unixname, unixlen, SvREFCNT_inc_simple(hook_sv), 0 ); } - ENTER; + ENTER_with_name("eval"); SAVETMPS; lex_start(NULL, tryrsfp, TRUE); SAVEHINTS(); PL_hints = 0; - if (PL_compiling.cop_hints_hash) { - Perl_refcounted_he_free(aTHX_ PL_compiling.cop_hints_hash); - PL_compiling.cop_hints_hash = NULL; - } + hv_clear(GvHV(PL_hintgv)); SAVECOMPILEWARNINGS(); if (PL_dowarn & G_WARN_ALL_ON) @@ -3600,11 +3691,14 @@ PP(pp_require) PL_compiling.cop_warnings = pWARN_STD ; if (filter_sub || filter_cache) { - SV * const datasv = filter_add(S_run_user_filter, NULL); + /* We can use the SvPV of the filter PVIO itself as our cache, rather + than hanging another SV from it. In turn, filter_add() optionally + takes the SV to use as the filter (or creates a new SV if passed + NULL), so simply pass in whatever value filter_cache has. */ + SV * const datasv = filter_add(S_run_user_filter, filter_cache); IoLINES(datasv) = filter_has_file; - IoTOP_GV(datasv) = (GV *)filter_state; - IoBOTTOM_GV(datasv) = (GV *)filter_sub; - IoFMT_GV(datasv) = (GV *)filter_cache; + IoTOP_GV(datasv) = MUTABLE_GV(filter_state); + IoBOTTOM_GV(datasv) = MUTABLE_GV(filter_sub); } /* switch to eval mode */ @@ -3640,7 +3734,7 @@ PP(pp_hintseval) { dVAR; dSP; - mXPUSHs((SV*)Perl_hv_copy_hints_hv(aTHX_ (HV*)cSVOP_sv)); + mXPUSHs(MUTABLE_SV(Perl_hv_copy_hints_hv(aTHX_ MUTABLE_HV(cSVOP_sv)))); RETURN; } @@ -3651,27 +3745,23 @@ PP(pp_entereval) register PERL_CONTEXT *cx; SV *sv; const I32 gimme = GIMME_V; - const I32 was = PL_sub_generation; + const U32 was = PL_breakable_sub_gen; char tbuf[TYPE_DIGITS(long) + 12]; char *tmpbuf = tbuf; - char *safestr; STRLEN len; - bool ok; CV* runcv; U32 seq; HV *saved_hh = NULL; - const char * const fakestr = "_<(eval )"; - const int fakelen = 9 + 1; - + if (PL_op->op_private & OPpEVAL_HAS_HH) { - saved_hh = (HV*) SvREFCNT_inc(POPs); + saved_hh = MUTABLE_HV(SvREFCNT_inc(POPs)); } sv = POPs; TAINT_IF(SvTAINTED(sv)); TAINT_PROPER("eval"); - ENTER; + ENTER_with_name("eval"); lex_start(sv, NULL, FALSE); SAVETMPS; @@ -3696,18 +3786,30 @@ PP(pp_entereval) (i.e. before run-time proper). To work around the coredump that ensues, we always turn GvMULTI_on for any globals that were introduced within evals. See force_ident(). GSAR 96-10-12 */ - safestr = savepvn(tmpbuf, len); - SAVEDELETE(PL_defstash, safestr, len); SAVEHINTS(); PL_hints = PL_op->op_targ; - if (saved_hh) + if (saved_hh) { + /* SAVEHINTS created a new HV in PL_hintgv, which we need to GC */ + SvREFCNT_dec(GvHV(PL_hintgv)); GvHV(PL_hintgv) = saved_hh; + } SAVECOMPILEWARNINGS(); PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings); if (PL_compiling.cop_hints_hash) { Perl_refcounted_he_free(aTHX_ PL_compiling.cop_hints_hash); } - PL_compiling.cop_hints_hash = PL_curcop->cop_hints_hash; + if (Perl_fetch_cop_label(aTHX_ PL_curcop->cop_hints_hash, NULL, NULL)) { + /* The label, if present, is the first entry on the chain. So rather + than writing a blank label in front of it (which involves an + allocation), just use the next entry in the chain. */ + PL_compiling.cop_hints_hash + = PL_curcop->cop_hints_hash->refcounted_he_next; + /* Check the assumption that this removed the label. */ + assert(Perl_fetch_cop_label(aTHX_ PL_compiling.cop_hints_hash, NULL, + NULL) == NULL); + } + else + PL_compiling.cop_hints_hash = PL_curcop->cop_hints_hash; if (PL_compiling.cop_hints_hash) { HINTS_REFCNT_LOCK; PL_compiling.cop_hints_hash->refcounted_he_refcnt++; @@ -3726,16 +3828,32 @@ PP(pp_entereval) /* prepare to compile string */ - if (PERLDB_LINE && PL_curstash != PL_debstash) + if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash) save_lines(CopFILEAV(&PL_compiling), PL_parser->linestr); PUTBACK; - ok = doeval(gimme, NULL, runcv, seq); - if (PERLDB_INTER && was != (I32)PL_sub_generation /* Some subs defined here. */ - && ok) { - /* Copy in anything fake and short. */ - my_strlcpy(safestr, fakestr, fakelen); + + if (doeval(gimme, NULL, runcv, seq)) { + if (was != PL_breakable_sub_gen /* Some subs defined here. */ + ? (PERLDB_LINE || PERLDB_SAVESRC) + : PERLDB_SAVESRC_NOSUBS) { + /* Retain the filegv we created. */ + } else { + char *const safestr = savepvn(tmpbuf, len); + SAVEDELETE(PL_defstash, safestr, len); + } + return DOCATCH(PL_eval_start); + } else { + /* We have already left the scope set up earler thanks to the LEAVE + in doeval(). */ + if (was != PL_breakable_sub_gen /* Some subs defined here. */ + ? (PERLDB_LINE || PERLDB_SAVESRC) + : PERLDB_SAVESRC_INVALID) { + /* Retain the filegv we created. */ + } else { + (void)hv_delete(PL_defstash, tmpbuf, len, G_DISCARD); + } + return PL_op->op_next; } - return ok ? DOCATCH(PL_eval_start) : PL_op->op_next; } PP(pp_leaveeval) @@ -3749,9 +3867,11 @@ PP(pp_leaveeval) OP *retop; const U8 save_flags = PL_op -> op_flags; I32 optype; + SV *namesv; POPBLOCK(cx,newpm); POPEVAL(cx); + namesv = cx->blk_eval.old_namesv; retop = cx->blk_eval.retop; TAINT_NOT; @@ -3792,13 +3912,15 @@ PP(pp_leaveeval) !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp)) { /* Unassume the success we assumed earlier. */ - SV * const nsv = cx->blk_eval.old_namesv; - (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD); - retop = Perl_die(aTHX_ "%"SVf" did not return a true value", SVfARG(nsv)); - /* die_where() did LEAVE, or we won't be here */ + (void)hv_delete(GvHVn(PL_incgv), + SvPVX_const(namesv), SvCUR(namesv), + G_DISCARD); + retop = Perl_die(aTHX_ "%"SVf" did not return a true value", + SVfARG(namesv)); + /* die_unwind() did LEAVE, or we won't be here */ } else { - LEAVE; + LEAVE_with_name("eval"); if (!(save_flags & OPf_SPECIAL)) { CLEAR_ERRSV(); } @@ -3821,7 +3943,7 @@ Perl_delete_eval_scope(pTHX) POPBLOCK(cx,newpm); POPEVAL(cx); PL_curpm = newpm; - LEAVE; + LEAVE_with_name("eval_scope"); PERL_UNUSED_VAR(newsp); PERL_UNUSED_VAR(gimme); PERL_UNUSED_VAR(optype); @@ -3835,7 +3957,7 @@ Perl_create_eval_scope(pTHX_ U32 flags) PERL_CONTEXT *cx; const I32 gimme = GIMME_V; - ENTER; + ENTER_with_name("eval_scope"); SAVETMPS; PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp); @@ -3903,7 +4025,7 @@ PP(pp_leavetry) } PL_curpm = newpm; /* Don't pop $1 et al till now */ - LEAVE; + LEAVE_with_name("eval_scope"); CLEAR_ERRSV(); RETURN; } @@ -3914,16 +4036,10 @@ PP(pp_entergiven) register PERL_CONTEXT *cx; const I32 gimme = GIMME_V; - ENTER; + ENTER_with_name("given"); SAVETMPS; - if (PL_op->op_targ == 0) { - SV ** const defsv_p = &GvSV(PL_defgv); - *defsv_p = newSVsv(POPs); - SAVECLEARSV(*defsv_p); - } - else - sv_setsv(PAD_SV(PL_op->op_targ), POPs); + sv_setsv(PAD_SV(PL_op->op_targ), POPs); PUSHBLOCK(cx, CXt_GIVEN, SP); PUSHGIVEN(cx); @@ -3948,7 +4064,7 @@ PP(pp_leavegiven) PL_curpm = newpm; /* pop $1 et al */ - LEAVE; + LEAVE_with_name("given"); return NORMAL; } @@ -3965,7 +4081,7 @@ S_make_matcher(pTHX_ REGEXP *re) PM_SETRE(matcher, ReREFCNT_inc(re)); SAVEFREEOP((OP *) matcher); - ENTER; SAVETMPS; + ENTER_with_name("matcher"); SAVETMPS; SAVEOP(); return matcher; } @@ -3995,12 +4111,13 @@ S_destroy_matcher(pTHX_ PMOP *matcher) PERL_UNUSED_ARG(matcher); FREETMPS; - LEAVE; + LEAVE_with_name("matcher"); } /* Do a smart match */ PP(pp_smartmatch) { + DEBUG_M(Perl_deb(aTHX_ "Starting smart match resolution\n")); return do_smartmatch(NULL, NULL); } @@ -4013,54 +4130,26 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other) dVAR; dSP; + bool object_on_left = FALSE; SV *e = TOPs; /* e is for 'expression' */ SV *d = TOPm1s; /* d is for 'default', as in PL_defgv */ - SV *This, *Other; /* 'This' (and Other to match) to play with C++ */ - REGEXP *this_regex, *other_regex; - -# define NOT_EMPTY_PROTO(cv) (!SvPOK(cv) || SvCUR(cv) == 0) - -# define SM_REF(type) ( \ - (SvROK(d) && (SvTYPE(This = SvRV(d)) == SVt_##type) && (Other = e)) \ - || (SvROK(e) && (SvTYPE(This = SvRV(e)) == SVt_##type) && (Other = d))) - -# define SM_CV_NEP /* Find a code ref without an empty prototype */ \ - ((SvROK(d) && (SvTYPE(This = SvRV(d)) == SVt_PVCV) \ - && NOT_EMPTY_PROTO(This) && (Other = e)) \ - || (SvROK(e) && (SvTYPE(This = SvRV(e)) == SVt_PVCV) \ - && NOT_EMPTY_PROTO(This) && (Other = d))) - -# define SM_REGEX ( \ - (SvROK(d) && (SvTYPE(This = SvRV(d)) == SVt_REGEXP) \ - && (this_regex = (REGEXP*) This) \ - && (Other = e)) \ - || \ - (SvROK(e) && (SvTYPE(This = SvRV(e)) == SVt_REGEXP) \ - && (this_regex = (REGEXP*) This) \ - && (Other = d)) ) - - -# define SM_OBJECT ( \ - (sv_isobject(d) && (SvTYPE(SvRV(d)) != SVt_REGEXP)) \ - || \ - (sv_isobject(e) && (SvTYPE(SvRV(e)) != SVt_REGEXP)) ) \ -# define SM_OTHER_REF(type) \ - (SvROK(Other) && SvTYPE(SvRV(Other)) == SVt_##type) + /* First of all, handle overload magic of the rightmost argument */ + if (SvAMAGIC(e)) { + SV * tmpsv; + DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Object\n")); + DEBUG_M(Perl_deb(aTHX_ " attempting overload\n")); -# define SM_OTHER_REGEX (SvROK(Other) \ - && (SvTYPE(SvRV(Other)) == SVt_REGEXP) \ - && (other_regex = (REGEXP*) SvRV(Other))) - - -# define SM_SEEN_THIS(sv) hv_exists_ent(seen_this, \ - sv_2mortal(newSViv(PTR2IV(sv))), 0) - -# define SM_SEEN_OTHER(sv) hv_exists_ent(seen_other, \ - sv_2mortal(newSViv(PTR2IV(sv))), 0) + tmpsv = amagic_call(d, e, smart_amg, 0); + if (tmpsv) { + SPAGAIN; + (void)POPs; + SETs(tmpsv); + RETURN; + } + DEBUG_M(Perl_deb(aTHX_ " failed to run overload method; continuing...\n")); + } - tryAMAGICbinSET(smart, 0); - SP -= 2; /* Pop the values */ /* Take care only to invoke mg_get() once for each argument. @@ -4076,72 +4165,156 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other) if (SvGMAGICAL(e)) e = sv_mortalcopy(e); - if (SM_OBJECT) + /* ~~ undef */ + if (!SvOK(e)) { + DEBUG_M(Perl_deb(aTHX_ " applying rule Any-undef\n")); + if (SvOK(d)) + RETPUSHNO; + else + RETPUSHYES; + } + + if (sv_isobject(e) && (SvTYPE(SvRV(e)) != SVt_REGEXP)) { + DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Object\n")); Perl_croak(aTHX_ "Smart matching a non-overloaded object breaks encapsulation"); + } + if (sv_isobject(d) && (SvTYPE(SvRV(d)) != SVt_REGEXP)) + object_on_left = TRUE; - if (SM_CV_NEP) { + /* ~~ sub */ + if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVCV) { I32 c; - - if ( SM_OTHER_REF(PVCV) && NOT_EMPTY_PROTO(SvRV(Other)) ) - { - if (This == SvRV(Other)) + if (object_on_left) { + goto sm_any_sub; /* Treat objects like scalars */ + } + else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) { + /* Test sub truth for each key */ + HE *he; + bool andedresults = TRUE; + HV *hv = (HV*) SvRV(d); + I32 numkeys = hv_iterinit(hv); + DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-CodeRef\n")); + if (numkeys == 0) + RETPUSHYES; + while ( (he = hv_iternext(hv)) ) { + DEBUG_M(Perl_deb(aTHX_ " testing hash key...\n")); + ENTER_with_name("smartmatch_hash_key_test"); + SAVETMPS; + PUSHMARK(SP); + PUSHs(hv_iterkeysv(he)); + PUTBACK; + c = call_sv(e, G_SCALAR); + SPAGAIN; + if (c == 0) + andedresults = FALSE; + else + andedresults = SvTRUEx(POPs) && andedresults; + FREETMPS; + LEAVE_with_name("smartmatch_hash_key_test"); + } + if (andedresults) RETPUSHYES; else RETPUSHNO; } - - ENTER; - SAVETMPS; - PUSHMARK(SP); - PUSHs(Other); - PUTBACK; - c = call_sv(This, G_SCALAR); - SPAGAIN; - if (c == 0) - PUSHs(&PL_sv_no); - else if (SvTEMP(TOPs)) - SvREFCNT_inc_void(TOPs); - FREETMPS; - LEAVE; - RETURN; + else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) { + /* Test sub truth for each element */ + I32 i; + bool andedresults = TRUE; + AV *av = (AV*) SvRV(d); + const I32 len = av_len(av); + DEBUG_M(Perl_deb(aTHX_ " applying rule Array-CodeRef\n")); + if (len == -1) + RETPUSHYES; + for (i = 0; i <= len; ++i) { + SV * const * const svp = av_fetch(av, i, FALSE); + DEBUG_M(Perl_deb(aTHX_ " testing array element...\n")); + ENTER_with_name("smartmatch_array_elem_test"); + SAVETMPS; + PUSHMARK(SP); + if (svp) + PUSHs(*svp); + PUTBACK; + c = call_sv(e, G_SCALAR); + SPAGAIN; + if (c == 0) + andedresults = FALSE; + else + andedresults = SvTRUEx(POPs) && andedresults; + FREETMPS; + LEAVE_with_name("smartmatch_array_elem_test"); + } + if (andedresults) + RETPUSHYES; + else + RETPUSHNO; + } + else { + sm_any_sub: + DEBUG_M(Perl_deb(aTHX_ " applying rule Any-CodeRef\n")); + ENTER_with_name("smartmatch_coderef"); + SAVETMPS; + PUSHMARK(SP); + PUSHs(d); + PUTBACK; + c = call_sv(e, G_SCALAR); + SPAGAIN; + if (c == 0) + PUSHs(&PL_sv_no); + else if (SvTEMP(TOPs)) + SvREFCNT_inc_void(TOPs); + FREETMPS; + LEAVE_with_name("smartmatch_coderef"); + RETURN; + } } - else if (SM_REF(PVHV)) { - if (SM_OTHER_REF(PVHV)) { + /* ~~ %hash */ + else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVHV) { + if (object_on_left) { + goto sm_any_hash; /* Treat objects like scalars */ + } + else if (!SvOK(d)) { + DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Hash ($a undef)\n")); + RETPUSHNO; + } + else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) { /* Check that the key-sets are identical */ HE *he; - HV *other_hv = (HV *) SvRV(Other); + HV *other_hv = MUTABLE_HV(SvRV(d)); bool tied = FALSE; bool other_tied = FALSE; U32 this_key_count = 0, other_key_count = 0; - + HV *hv = MUTABLE_HV(SvRV(e)); + + DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Hash\n")); /* Tied hashes don't know how many keys they have. */ - if (SvTIED_mg(This, PERL_MAGIC_tied)) { + if (SvTIED_mg((SV*)hv, PERL_MAGIC_tied)) { tied = TRUE; } - else if (SvTIED_mg((SV *) other_hv, PERL_MAGIC_tied)) { + else if (SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied)) { HV * const temp = other_hv; - other_hv = (HV *) This; - This = (SV *) temp; + other_hv = hv; + hv = temp; tied = TRUE; } - if (SvTIED_mg((SV *) other_hv, PERL_MAGIC_tied)) + if (SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied)) other_tied = TRUE; - if (!tied && HvUSEDKEYS((HV *) This) != HvUSEDKEYS(other_hv)) + if (!tied && HvUSEDKEYS((const HV *) hv) != HvUSEDKEYS(other_hv)) RETPUSHNO; /* The hashes have the same number of keys, so it suffices to check that one is a subset of the other. */ - (void) hv_iterinit((HV *) This); - while ( (he = hv_iternext((HV *) This)) ) { - I32 key_len; - char * const key = hv_iterkey(he, &key_len); - + (void) hv_iterinit(hv); + while ( (he = hv_iternext(hv)) ) { + SV *key = hv_iterkeysv(he); + + DEBUG_M(Perl_deb(aTHX_ " comparing hash key...\n")); ++ this_key_count; - if(!hv_exists(other_hv, key, key_len)) { - (void) hv_iterinit((HV *) This); /* reset iterator */ + if(!hv_exists_ent(other_hv, key, 0)) { + (void) hv_iterinit(hv); /* reset iterator */ RETPUSHNO; } } @@ -4159,50 +4332,79 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other) else RETPUSHYES; } - else if (SM_OTHER_REF(PVAV)) { - AV * const other_av = (AV *) SvRV(Other); + else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) { + AV * const other_av = MUTABLE_AV(SvRV(d)); const I32 other_len = av_len(other_av) + 1; I32 i; + HV *hv = MUTABLE_HV(SvRV(e)); + DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Hash\n")); for (i = 0; i < other_len; ++i) { SV ** const svp = av_fetch(other_av, i, FALSE); - char *key; - STRLEN key_len; - + DEBUG_M(Perl_deb(aTHX_ " checking for key existence...\n")); if (svp) { /* ??? When can this not happen? */ - key = SvPV(*svp, key_len); - if (hv_exists((HV *) This, key, key_len)) + if (hv_exists_ent(hv, *svp, 0)) RETPUSHYES; } } RETPUSHNO; } - else if (SM_OTHER_REGEX) { - PMOP * const matcher = make_matcher(other_regex); - HE *he; - - (void) hv_iterinit((HV *) This); - while ( (he = hv_iternext((HV *) This)) ) { - if (matcher_matches_sv(matcher, hv_iterkeysv(he))) { - (void) hv_iterinit((HV *) This); - destroy_matcher(matcher); - RETPUSHYES; + else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) { + DEBUG_M(Perl_deb(aTHX_ " applying rule Regex-Hash\n")); + sm_regex_hash: + { + PMOP * const matcher = make_matcher((REGEXP*) SvRV(d)); + HE *he; + HV *hv = MUTABLE_HV(SvRV(e)); + + (void) hv_iterinit(hv); + while ( (he = hv_iternext(hv)) ) { + DEBUG_M(Perl_deb(aTHX_ " testing key against pattern...\n")); + if (matcher_matches_sv(matcher, hv_iterkeysv(he))) { + (void) hv_iterinit(hv); + destroy_matcher(matcher); + RETPUSHYES; + } } + destroy_matcher(matcher); + RETPUSHNO; } - destroy_matcher(matcher); - RETPUSHNO; } else { - if (hv_exists_ent((HV *) This, Other, 0)) + sm_any_hash: + DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Hash\n")); + if (hv_exists_ent(MUTABLE_HV(SvRV(e)), d, 0)) RETPUSHYES; else RETPUSHNO; } } - else if (SM_REF(PVAV)) { - if (SM_OTHER_REF(PVAV)) { - AV *other_av = (AV *) SvRV(Other); - if (av_len((AV *) This) != av_len(other_av)) + /* ~~ @array */ + else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVAV) { + if (object_on_left) { + goto sm_any_array; /* Treat objects like scalars */ + } + else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) { + AV * const other_av = MUTABLE_AV(SvRV(e)); + const I32 other_len = av_len(other_av) + 1; + I32 i; + + DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Array\n")); + for (i = 0; i < other_len; ++i) { + SV ** const svp = av_fetch(other_av, i, FALSE); + + DEBUG_M(Perl_deb(aTHX_ " testing for key existence...\n")); + if (svp) { /* ??? When can this not happen? */ + if (hv_exists_ent(MUTABLE_HV(SvRV(d)), *svp, 0)) + RETPUSHYES; + } + } + RETPUSHNO; + } + if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) { + AV *other_av = MUTABLE_AV(SvRV(d)); + DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Array\n")); + if (av_len(MUTABLE_AV(SvRV(e))) != av_len(other_av)) RETPUSHNO; else { I32 i; @@ -4210,22 +4412,25 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other) if (NULL == seen_this) { seen_this = newHV(); - (void) sv_2mortal((SV *) seen_this); + (void) sv_2mortal(MUTABLE_SV(seen_this)); } if (NULL == seen_other) { - seen_this = newHV(); - (void) sv_2mortal((SV *) seen_other); + seen_other = newHV(); + (void) sv_2mortal(MUTABLE_SV(seen_other)); } for(i = 0; i <= other_len; ++i) { - SV * const * const this_elem = av_fetch((AV *)This, i, FALSE); + SV * const * const this_elem = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE); SV * const * const other_elem = av_fetch(other_av, i, FALSE); if (!this_elem || !other_elem) { - if (this_elem || other_elem) + if ((this_elem && SvOK(*this_elem)) + || (other_elem && SvOK(*other_elem))) RETPUSHNO; } - else if (SM_SEEN_THIS(*this_elem) - || SM_SEEN_OTHER(*other_elem)) + else if (hv_exists_ent(seen_this, + sv_2mortal(newSViv(PTR2IV(*this_elem))), 0) || + hv_exists_ent(seen_other, + sv_2mortal(newSViv(PTR2IV(*other_elem))), 0)) { if (*this_elem != *other_elem) RETPUSHNO; @@ -4237,12 +4442,14 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other) (void)hv_store_ent(seen_other, sv_2mortal(newSViv(PTR2IV(*other_elem))), &PL_sv_undef, 0); - PUSHs(*this_elem); PUSHs(*other_elem); + PUSHs(*this_elem); PUTBACK; + DEBUG_M(Perl_deb(aTHX_ " recursively comparing array element...\n")); (void) do_smartmatch(seen_this, seen_other); SPAGAIN; + DEBUG_M(Perl_deb(aTHX_ " recursion finished\n")); if (!SvTRUEx(POPs)) RETPUSHNO; @@ -4251,124 +4458,124 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other) RETPUSHYES; } } - else if (SM_OTHER_REGEX) { - PMOP * const matcher = make_matcher(other_regex); - const I32 this_len = av_len((AV *) This); - I32 i; - - for(i = 0; i <= this_len; ++i) { - SV * const * const svp = av_fetch((AV *)This, i, FALSE); - if (svp && matcher_matches_sv(matcher, *svp)) { - destroy_matcher(matcher); - RETPUSHYES; + else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) { + DEBUG_M(Perl_deb(aTHX_ " applying rule Regex-Array\n")); + sm_regex_array: + { + PMOP * const matcher = make_matcher((REGEXP*) SvRV(d)); + const I32 this_len = av_len(MUTABLE_AV(SvRV(e))); + I32 i; + + for(i = 0; i <= this_len; ++i) { + SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE); + DEBUG_M(Perl_deb(aTHX_ " testing element against pattern...\n")); + if (svp && matcher_matches_sv(matcher, *svp)) { + destroy_matcher(matcher); + RETPUSHYES; + } } + destroy_matcher(matcher); + RETPUSHNO; } - destroy_matcher(matcher); - RETPUSHNO; } - else if (SvIOK(Other) || SvNOK(Other)) { + else if (!SvOK(d)) { + /* undef ~~ array */ + const I32 this_len = av_len(MUTABLE_AV(SvRV(e))); I32 i; - for(i = 0; i <= AvFILL((AV *) This); ++i) { - SV * const * const svp = av_fetch((AV *)This, i, FALSE); - if (!svp) - continue; - - PUSHs(Other); - PUSHs(*svp); - PUTBACK; - if (CopHINTS_get(PL_curcop) & HINT_INTEGER) - (void) pp_i_eq(); - else - (void) pp_eq(); - SPAGAIN; - if (SvTRUEx(POPs)) + DEBUG_M(Perl_deb(aTHX_ " applying rule Undef-Array\n")); + for (i = 0; i <= this_len; ++i) { + SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE); + DEBUG_M(Perl_deb(aTHX_ " testing for undef element...\n")); + if (!svp || !SvOK(*svp)) RETPUSHYES; } RETPUSHNO; } - else if (SvPOK(Other)) { - const I32 this_len = av_len((AV *) This); - I32 i; + else { + sm_any_array: + { + I32 i; + const I32 this_len = av_len(MUTABLE_AV(SvRV(e))); - for(i = 0; i <= this_len; ++i) { - SV * const * const svp = av_fetch((AV *)This, i, FALSE); - if (!svp) - continue; - - PUSHs(Other); - PUSHs(*svp); - PUTBACK; - (void) pp_seq(); - SPAGAIN; - if (SvTRUEx(POPs)) - RETPUSHYES; + DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Array\n")); + for (i = 0; i <= this_len; ++i) { + SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE); + if (!svp) + continue; + + PUSHs(d); + PUSHs(*svp); + PUTBACK; + /* infinite recursion isn't supposed to happen here */ + DEBUG_M(Perl_deb(aTHX_ " recursively testing array element...\n")); + (void) do_smartmatch(NULL, NULL); + SPAGAIN; + DEBUG_M(Perl_deb(aTHX_ " recursion finished\n")); + if (SvTRUEx(POPs)) + RETPUSHYES; + } + RETPUSHNO; } - RETPUSHNO; } } - else if (!SvOK(d) || !SvOK(e)) { - if (!SvOK(d) && !SvOK(e)) - RETPUSHYES; - else - RETPUSHNO; - } - else if (SM_REGEX) { - PMOP * const matcher = make_matcher(this_regex); + /* ~~ qr// */ + else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_REGEXP) { + if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) { + SV *t = d; d = e; e = t; + DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Regex\n")); + goto sm_regex_hash; + } + else if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) { + SV *t = d; d = e; e = t; + DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Regex\n")); + goto sm_regex_array; + } + else { + PMOP * const matcher = make_matcher((REGEXP*) SvRV(e)); - PUTBACK; - PUSHs(matcher_matches_sv(matcher, Other) - ? &PL_sv_yes - : &PL_sv_no); - destroy_matcher(matcher); - RETURN; + DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Regex\n")); + PUTBACK; + PUSHs(matcher_matches_sv(matcher, d) + ? &PL_sv_yes + : &PL_sv_no); + destroy_matcher(matcher); + RETURN; + } } - else if (SM_REF(PVCV)) { - I32 c; - /* This must be a null-prototyped sub, because we - already checked for the other kind. */ - - ENTER; - SAVETMPS; - PUSHMARK(SP); + /* ~~ scalar */ + /* See if there is overload magic on left */ + else if (object_on_left && SvAMAGIC(d)) { + SV *tmpsv; + DEBUG_M(Perl_deb(aTHX_ " applying rule Object-Any\n")); + DEBUG_M(Perl_deb(aTHX_ " attempting overload\n")); + PUSHs(d); PUSHs(e); PUTBACK; - c = call_sv(This, G_SCALAR); - SPAGAIN; - if (c == 0) - PUSHs(&PL_sv_undef); - else if (SvTEMP(TOPs)) - SvREFCNT_inc_void(TOPs); - - if (SM_OTHER_REF(PVCV)) { - /* This one has to be null-proto'd too. - Call both of 'em, and compare the results */ - PUSHMARK(SP); - c = call_sv(SvRV(Other), G_SCALAR); + tmpsv = amagic_call(d, e, smart_amg, AMGf_noright); + if (tmpsv) { SPAGAIN; - if (c == 0) - PUSHs(&PL_sv_undef); - else if (SvTEMP(TOPs)) - SvREFCNT_inc_void(TOPs); - FREETMPS; - LEAVE; - PUTBACK; - return pp_eq(); + (void)POPs; + SETs(tmpsv); + RETURN; } - - FREETMPS; - LEAVE; - RETURN; + SP -= 2; + DEBUG_M(Perl_deb(aTHX_ " failed to run overload method; falling back...\n")); + goto sm_any_scalar; } - else if ( ((SvIOK(d) || SvNOK(d)) && (This = d) && (Other = e)) - || ((SvIOK(e) || SvNOK(e)) && (This = e) && (Other = d)) ) - { - if (SvPOK(Other) && !looks_like_number(Other)) { - /* String comparison */ - PUSHs(d); PUSHs(e); - PUTBACK; - return pp_seq(); - } - /* Otherwise, numeric comparison */ + else if (!SvOK(d)) { + /* undef ~~ scalar ; we already know that the scalar is SvOK */ + DEBUG_M(Perl_deb(aTHX_ " applying rule undef-Any\n")); + RETPUSHNO; + } + else + sm_any_scalar: + if (SvNIOK(e) || (SvPOK(e) && looks_like_number(e) && SvNIOK(d))) { + DEBUG_M(if (SvNIOK(e)) + Perl_deb(aTHX_ " applying rule Any-Num\n"); + else + Perl_deb(aTHX_ " applying rule Num-numish\n"); + ); + /* numeric comparison */ PUSHs(d); PUSHs(e); PUTBACK; if (CopHINTS_get(PL_curcop) & HINT_INTEGER) @@ -4383,6 +4590,7 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other) } /* As a last resort, use string comparison */ + DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Any\n")); PUSHs(d); PUSHs(e); PUTBACK; return pp_seq(); @@ -4402,7 +4610,7 @@ PP(pp_enterwhen) if ((0 == (PL_op->op_flags & OPf_SPECIAL)) && !SvTRUEx(POPs)) return cLOGOP->op_other->op_next; - ENTER; + ENTER_with_name("eval"); SAVETMPS; PUSHBLOCK(cx, CXt_WHEN, SP); @@ -4427,7 +4635,7 @@ PP(pp_leavewhen) PL_curpm = newpm; /* pop $1 et al */ - LEAVE; + LEAVE_with_name("eval"); return NORMAL; } @@ -4739,13 +4947,13 @@ S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen) dVAR; SV * const datasv = FILTER_DATA(idx); const int filter_has_file = IoLINES(datasv); - SV * const filter_state = (SV *)IoTOP_GV(datasv); - SV * const filter_sub = (SV *)IoBOTTOM_GV(datasv); + SV * const filter_state = MUTABLE_SV(IoTOP_GV(datasv)); + SV * const filter_sub = MUTABLE_SV(IoBOTTOM_GV(datasv)); int status = 0; SV *upstream; STRLEN got_len; - const char *got_p = NULL; - const char *prune_from = NULL; + char *got_p = NULL; + char *prune_from = NULL; bool read_from_cache = FALSE; STRLEN umaxlen; @@ -4759,8 +4967,8 @@ S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen) for PL_parser->error_count == 0.) Solaris doesn't segfault -- not sure where the trouble is yet. XXX */ - if (IoFMT_GV(datasv)) { - SV *const cache = (SV *)IoFMT_GV(datasv); + { + SV *const cache = datasv; if (SvOK(cache)) { STRLEN cache_len; const char *cache_p = SvPV(cache, cache_len); @@ -4814,12 +5022,12 @@ S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen) dSP; int count; - ENTER; + ENTER_with_name("call_filter_sub"); SAVE_DEFSV; SAVETMPS; EXTEND(SP, 2); - DEFSV = upstream; + DEFSV_set(upstream); PUSHMARK(SP); mPUSHi(0); if (filter_state) { @@ -4838,7 +5046,7 @@ S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen) PUTBACK; FREETMPS; - LEAVE; + LEAVE_with_name("call_filter_sub"); } if(SvOK(upstream)) { @@ -4848,8 +5056,7 @@ S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen) prune_from = got_p + umaxlen; } } else { - const char *const first_nl = - (const char *)memchr(got_p, '\n', got_len); + char *const first_nl = (char *)memchr(got_p, '\n', got_len); if (first_nl && first_nl + 1 < got_p + got_len) { /* There's a second line here... */ prune_from = first_nl + 1; @@ -4859,11 +5066,9 @@ S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen) if (prune_from) { /* Oh. Too long. Stuff some in our cache. */ STRLEN cached_len = got_p + got_len - prune_from; - SV *cache = (SV *)IoFMT_GV(datasv); + SV *const cache = datasv; - if (!cache) { - IoFMT_GV(datasv) = (GV*) (cache = newSV(got_len - umaxlen)); - } else if (SvOK(cache)) { + if (SvOK(cache)) { /* Cache should be empty. */ assert(!SvCUR(cache)); } @@ -4877,6 +5082,7 @@ S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen) SvUTF8_on(cache); } SvCUR_set(upstream, got_len - cached_len); + *prune_from = 0; /* Can't yet be EOF */ if (status == 0) status = 1; @@ -4892,7 +5098,6 @@ S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen) if (status <= 0) { IoLINES(datasv) = 0; - SvREFCNT_dec(IoFMT_GV(datasv)); if (filter_state) { SvREFCNT_dec(filter_state); IoTOP_GV(datasv) = NULL; @@ -4920,8 +5125,12 @@ S_path_is_absolute(const char *name) PERL_ARGS_ASSERT_PATH_IS_ABSOLUTE; if (PERL_FILE_IS_ABSOLUTE(name) -#ifdef MACOS_TRADITIONAL - || (*name == ':') +#ifdef WIN32 + || (*name == '.' && ((name[1] == '/' || + (name[1] == '.' && name[2] == '/')) + || (name[1] == '\\' || + ( name[1] == '.' && name[2] == '\\'))) + ) #else || (*name == '.' && (name[1] == '/' || (name[1] == '.' && name[2] == '/')))