X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pp_ctl.c;h=7d7ad1f6e9cf9e2a4cfd1dcd17c2bf8c9ecfe300;hb=28c5b5bcd7f52e6b2219508a1066cd0ccc8dd19a;hp=5adfc686b9a55dd860e102ec6f03f7d035fe9df7;hpb=2c9d2554ad3b3d37d1c8b83cf0f3c4b4b99fde8b;p=p5sagit%2Fp5-mst-13.2.git diff --git a/pp_ctl.c b/pp_ctl.c index 5adfc68..7d7ad1f 100644 --- a/pp_ctl.c +++ b/pp_ctl.c @@ -122,7 +122,7 @@ PP(pp_regcomp) re = (REGEXP*) sv; } if (re) { - re = reg_temp_copy(re); + re = reg_temp_copy(NULL, re); ReREFCNT_dec(PM_GETRE(pm)); PM_SETRE(pm, re); } @@ -233,13 +233,16 @@ PP(pp_substcont) if (!(cx->sb_rxtainted & 2) && SvTAINTED(TOPs)) cx->sb_rxtainted |= 2; sv_catsv(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; @@ -532,8 +535,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; @@ -901,11 +903,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; @@ -1280,9 +1277,8 @@ S_dopoptolabel(pTHX_ const char *label) 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; @@ -1401,9 +1397,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; @@ -1545,14 +1540,13 @@ Perl_die_where(pTHX_ const char *message, STRLEN msglen) e = NULL; } if (!e) { + STRLEN start; 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), "%s", - SvPVX_const(err)+start); - } + start = SvCUR(err)-msglen-sizeof(prefix)+1; + Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "%s", + SvPVX_const(err)+start); } } else { @@ -1749,9 +1743,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) */ } @@ -2624,6 +2617,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: @@ -3255,6 +3250,11 @@ PP(pp_require) Perl_load_module(aTHX_ 0, newSVpvs("feature"), NULL, importsv, NULL); LEAVE; } + /* 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; } @@ -3348,7 +3348,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; @@ -3489,8 +3489,10 @@ PP(pp_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) @@ -3560,10 +3562,7 @@ PP(pp_require) 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) @@ -3574,11 +3573,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) = MUTABLE_GV(filter_state); IoBOTTOM_GV(datasv) = MUTABLE_GV(filter_sub); - IoFMT_GV(datasv) = MUTABLE_GV(filter_cache); } /* switch to eval mode */ @@ -3668,8 +3670,11 @@ PP(pp_entereval) introduced within evals. See force_ident(). GSAR 96-10-12 */ 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) { @@ -3901,13 +3906,7 @@ PP(pp_entergiven) ENTER; 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); @@ -3985,6 +3984,7 @@ S_destroy_matcher(pTHX_ PMOP *matcher) /* Do a smart match */ PP(pp_smartmatch) { + DEBUG_M(Perl_deb(aTHX_ "Starting smart match resolution\n")); return do_smartmatch(NULL, NULL); } @@ -4003,13 +4003,18 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other) /* First of all, handle overload magic of the rightmost argument */ if (SvAMAGIC(e)) { - SV * const tmpsv = amagic_call(d, e, smart_amg, 0); + SV * tmpsv; + DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Object\n")); + DEBUG_M(Perl_deb(aTHX_ " attempting overload\n")); + + 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")); } SP -= 2; /* Pop the values */ @@ -4029,14 +4034,17 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other) /* ~~ 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)) + 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; @@ -4052,9 +4060,11 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other) 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; SAVETMPS; PUSHMARK(SP); @@ -4080,10 +4090,12 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other) 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; SAVETMPS; PUSHMARK(SP); @@ -4106,6 +4118,7 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other) } else { sm_any_sub: + DEBUG_M(Perl_deb(aTHX_ " applying rule Any-CodeRef\n")); ENTER; SAVETMPS; PUSHMARK(SP); @@ -4128,6 +4141,7 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other) 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) { @@ -4139,7 +4153,8 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other) 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((SV*)hv, PERL_MAGIC_tied)) { tied = TRUE; @@ -4161,7 +4176,8 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other) (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_ent(other_hv, key, 0)) { @@ -4189,8 +4205,10 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other) 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); + DEBUG_M(Perl_deb(aTHX_ " checking for key existence...\n")); if (svp) { /* ??? When can this not happen? */ if (hv_exists_ent(hv, *svp, 0)) RETPUSHYES; @@ -4199,6 +4217,7 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other) RETPUSHNO; } 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)); @@ -4207,6 +4226,7 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other) (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); @@ -4219,6 +4239,7 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other) } else { 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 @@ -4235,8 +4256,11 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other) 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; @@ -4246,6 +4270,7 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other) } 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 { @@ -4287,8 +4312,10 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other) 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; @@ -4298,6 +4325,7 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other) } } 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)); @@ -4306,6 +4334,7 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other) 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; @@ -4320,8 +4349,10 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other) const I32 this_len = av_len(MUTABLE_AV(SvRV(e))); I32 i; + 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; } @@ -4333,6 +4364,7 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other) I32 i; const I32 this_len = av_len(MUTABLE_AV(SvRV(e))); + 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) @@ -4342,8 +4374,10 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other) 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; } @@ -4355,15 +4389,18 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other) 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)); + DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Regex\n")); PUTBACK; PUSHs(matcher_matches_sv(matcher, d) ? &PL_sv_yes @@ -4376,6 +4413,8 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other) /* 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; tmpsv = amagic_call(d, e, smart_amg, AMGf_noright); @@ -4386,11 +4425,22 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other) RETURN; } SP -= 2; + DEBUG_M(Perl_deb(aTHX_ " failed to run overload method; falling back...\n")); goto sm_any_scalar; } + 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; @@ -4406,6 +4456,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(); @@ -4782,8 +4833,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 = MUTABLE_SV(IoFMT_GV(datasv)); + { + SV *const cache = datasv; if (SvOK(cache)) { STRLEN cache_len; const char *cache_p = SvPV(cache, cache_len); @@ -4882,11 +4933,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 = MUTABLE_SV(IoFMT_GV(datasv)); + SV *const cache = datasv; - if (!cache) { - IoFMT_GV(datasv) = MUTABLE_GV((cache = newSV(got_len - umaxlen))); - } else if (SvOK(cache)) { + if (SvOK(cache)) { /* Cache should be empty. */ assert(!SvCUR(cache)); } @@ -4915,7 +4964,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;