X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/869b8c119a7436d3373e1325925a8b753d0e7805..1df96a41bcf7102f099be953187c66b6f66f5bc9:/pp_ctl.c diff --git a/pp_ctl.c b/pp_ctl.c index a3ece51..40e9ae7 100644 --- a/pp_ctl.c +++ b/pp_ctl.c @@ -33,10 +33,16 @@ #include "EXTERN.h" #define PERL_IN_PP_CTL_C #include "perl.h" +#include "feature.h" #define RUN_PP_CATCHABLY(thispp) \ STMT_START { if (CATCH_GET) return docatch(thispp); } STMT_END +#define dopopto_cursub() \ + (PL_curstackinfo->si_cxsubix >= 0 \ + ? PL_curstackinfo->si_cxsubix \ + : dopoptosub_at(cxstack, cxstack_ix)) + #define dopoptosub(plop) dopoptosub_at(cxstack, (plop)) PP(pp_wantarray) @@ -50,7 +56,7 @@ PP(pp_wantarray) if (!(cx = caller_cx(1,NULL))) RETPUSHUNDEF; } else { - cxix = dopoptosub(cxstack_ix); + cxix = dopopto_cursub(); if (cxix < 0) RETPUSHUNDEF; cx = &cxstack[cxix]; @@ -256,7 +262,7 @@ PP(pp_substcont) (void)SvPOK_only_UTF8(targ); } - /* update the taint state of various various variables in + /* update the taint state of various variables in * preparation for final exit. * See "how taint works" above pp_subst() */ if (TAINTING_get) { @@ -275,6 +281,24 @@ PP(pp_substcont) cBOOL(cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL)) ); + + /* sv_magic(), when adding magic (e.g.taint magic), also + * recalculates any pos() magic, converting any byte offset + * to utf8 offset. Make sure pos() is reset before this + * happens rather than using the now invalid value (since + * we've just replaced targ's pvx buffer with the + * potentially shorter dstr buffer). Normally (i.e. in + * non-taint cases), pos() gets removed a few lines later + * with the SvSETMAGIC(). + */ + { + MAGIC *mg; + mg = mg_find_mglob(targ); + if (mg) { + MgBYTEPOS_set(mg, targ, SvPVX(targ), -1); + } + } + SvTAINT(TARG); } /* PL_tainted must be correctly set for this mg_set */ @@ -325,7 +349,7 @@ PP(pp_substcont) } if (old != rx) (void)ReREFCNT_inc(rx); - /* update the taint state of various various variables in preparation + /* update the taint state of various variables in preparation * for calling the code block. * See "how taint works" above pp_subst() */ if (TAINTING_get) { @@ -781,7 +805,8 @@ PP(pp_formline) * for safety */ grow = linemax; while (linemark--) - s += UTF8SKIP(s); + s += UTF8_SAFE_SKIP(s, + (U8 *) SvEND(PL_formtarget)); linemark = s - (U8*)SvPVX(PL_formtarget); } /* Easy. They agree. */ @@ -856,21 +881,18 @@ PP(pp_formline) arg &= ~(FORM_NUM_POINT|FORM_NUM_BLANK); #ifdef USE_QUADMATH { - const char* qfmt = quadmath_format_single(fmt); int len; - if (!qfmt) + if (!quadmath_format_valid(fmt)) Perl_croak_nocontext("panic: quadmath invalid format \"%s\"", fmt); - len = quadmath_snprintf(t, max, qfmt, (int) fieldsize, (int) arg, value); + len = quadmath_snprintf(t, max, fmt, (int) fieldsize, (int) arg, value); if (len == -1) - Perl_croak_nocontext("panic: quadmath_snprintf failed, format \"%s\"", qfmt); - if (qfmt != fmt) - Safefree(fmt); + Perl_croak_nocontext("panic: quadmath_snprintf failed, format \"%s\"", fmt); } #else /* we generate fmt ourselves so it is safe */ - GCC_DIAG_IGNORE(-Wformat-nonliteral); + GCC_DIAG_IGNORE_STMT(-Wformat-nonliteral); len = my_snprintf(t, max, fmt, (int) fieldsize, (int) arg, value); - GCC_DIAG_RESTORE; + GCC_DIAG_RESTORE_STMT; #endif PERL_MY_SNPRINTF_POST_GUARD(len, max); RESTORE_LC_NUMERIC(); @@ -1177,14 +1199,18 @@ PP(pp_flip) } /* This code tries to decide if "$left .. $right" should use the - magical string increment, or if the range is numeric (we make - an exception for .."0" [#18165]). AMS 20021031. */ + magical string increment, or if the range is numeric. Initially, + an exception was made for *any* string beginning with "0" (see + [#18165], AMS 20021031), but now that is only applied when the + string's length is also >1 - see the rules now documented in + perlop [#133695] */ #define RANGE_IS_NUMERIC(left,right) ( \ SvNIOKp(left) || (SvOK(left) && !SvPOKp(left)) || \ SvNIOKp(right) || (SvOK(right) && !SvPOKp(right)) || \ (((!SvOK(left) && SvOK(right)) || ((!SvOK(left) || \ - looks_like_number(left)) && SvPOKp(left) && *SvPVX_const(left) != '0')) \ + looks_like_number(left)) && SvPOKp(left) \ + && !(*SvPVX_const(left) == '0' && SvCUR(left)>1 ) )) \ && (!SvOK(right) || looks_like_number(right)))) PP(pp_flop) @@ -1361,10 +1387,12 @@ Perl_dowantarray(pTHX) return (gimme == G_VOID) ? G_SCALAR : gimme; } +/* note that this function has mostly been superseded by Perl_gimme_V */ + U8 Perl_block_gimme(pTHX) { - const I32 cxix = dopoptosub(cxstack_ix); + const I32 cxix = dopopto_cursub(); U8 gimme; if (cxix < 0) return G_VOID; @@ -1379,7 +1407,7 @@ Perl_block_gimme(pTHX) I32 Perl_is_lvalue_sub(pTHX) { - const I32 cxix = dopoptosub(cxstack_ix); + const I32 cxix = dopopto_cursub(); assert(cxix >= 0); /* We should only be called from inside subs */ if (CxLVAL(cxstack + cxix) && CvLVALUE(cxstack[cxix].blk_sub.cv)) @@ -1719,9 +1747,13 @@ Perl_die_unwind(pTHX_ SV *msv) * perls 5.13.{1..7} which had late setting of $@ without this * early-setting hack. */ - if (!(in_eval & EVAL_KEEPERR)) + if (!(in_eval & EVAL_KEEPERR)) { + /* remove any read-only/magic from the SV, so we don't + get infinite recursion when setting ERRSV */ + SANE_ERRSV(); sv_setsv_flags(ERRSV, exceptsv, (SV_GMAGIC|SV_DO_COW_SVSETSV|SV_NOSTEAL)); + } if (in_eval & EVAL_KEEPERR) { Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %" SVf, @@ -1783,8 +1815,10 @@ Perl_die_unwind(pTHX_ SV *msv) */ S_pop_eval_context_maybe_croak(aTHX_ cx, exceptsv, 2); - if (!(in_eval & EVAL_KEEPERR)) + if (!(in_eval & EVAL_KEEPERR)) { + SANE_ERRSV(); sv_setsv(ERRSV, exceptsv); + } PL_restartjmpenv = restartjmpenv; PL_restartop = restartop; JMPENV_JUMP(3); @@ -1831,7 +1865,7 @@ frame for the sub call itself. const PERL_CONTEXT * Perl_caller_cx(pTHX_ I32 count, const PERL_CONTEXT **dbcxp) { - I32 cxix = dopoptosub(cxstack_ix); + I32 cxix = dopopto_cursub(); const PERL_CONTEXT *cx; const PERL_CONTEXT *ccstack = cxstack; const PERL_SI *top_si = PL_curstackinfo; @@ -2433,7 +2467,7 @@ PP(pp_return) { dSP; dMARK; PERL_CONTEXT *cx; - const I32 cxix = dopoptosub(cxstack_ix); + const I32 cxix = dopopto_cursub(); assert(cxstack_ix >= 0); if (cxix < cxstack_ix) { @@ -2644,6 +2678,9 @@ PP(pp_redo) return redo_op; } +#define UNENTERABLE (OP *)1 +#define GOTO_DEPTH 64 + STATIC OP * S_dofindlabel(pTHX_ OP *o, const char *label, STRLEN len, U32 flags, OP **opstack, OP **oplimit) { @@ -2658,15 +2695,34 @@ S_dofindlabel(pTHX_ OP *o, const char *label, STRLEN len, U32 flags, OP **opstac o->op_type == OP_SCOPE || o->op_type == OP_LEAVELOOP || o->op_type == OP_LEAVESUB || - o->op_type == OP_LEAVETRY) + o->op_type == OP_LEAVETRY || + o->op_type == OP_LEAVEGIVEN) { *ops++ = cUNOPo->op_first; - if (ops >= oplimit) - Perl_croak(aTHX_ "%s", too_deep); } + else if (oplimit - opstack < GOTO_DEPTH) { + if (o->op_flags & OPf_KIDS + && cUNOPo->op_first->op_type == OP_PUSHMARK) { + *ops++ = UNENTERABLE; + } + else if (o->op_flags & OPf_KIDS && PL_opargs[o->op_type] + && OP_CLASS(o) != OA_LOGOP + && o->op_type != OP_LINESEQ + && o->op_type != OP_SREFGEN + && o->op_type != OP_ENTEREVAL + && o->op_type != OP_GLOB + && o->op_type != OP_RV2CV) { + OP * const kid = cUNOPo->op_first; + if (OP_GIMME(kid, 0) != G_SCALAR || OpHAS_SIBLING(kid)) + *ops++ = UNENTERABLE; + } + } + if (ops >= oplimit) + Perl_croak(aTHX_ "%s", too_deep); *ops = 0; if (o->op_flags & OPf_KIDS) { OP *kid; + OP * const kid1 = cUNOPo->op_first; /* First try all the kids at this level, since that's likeliest. */ for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) { if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) { @@ -2689,19 +2745,27 @@ S_dofindlabel(pTHX_ OP *o, const char *label, STRLEN len, U32 flags, OP **opstac } } for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) { + bool first_kid_of_binary = FALSE; if (kid == PL_lastgotoprobe) continue; if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) { if (ops == opstack) *ops++ = kid; - else if (ops[-1]->op_type == OP_NEXTSTATE || - ops[-1]->op_type == OP_DBSTATE) + else if (ops[-1] != UNENTERABLE + && (ops[-1]->op_type == OP_NEXTSTATE || + ops[-1]->op_type == OP_DBSTATE)) ops[-1] = kid; else *ops++ = kid; } + if (kid == kid1 && ops != opstack && ops[-1] == UNENTERABLE) { + first_kid_of_binary = TRUE; + ops--; + } if ((o = dofindlabel(kid, label, len, flags, ops, oplimit))) return o; + if (first_kid_of_binary) + *ops++ = UNENTERABLE; } } *ops = 0; @@ -2709,15 +2773,31 @@ S_dofindlabel(pTHX_ OP *o, const char *label, STRLEN len, U32 flags, OP **opstac } +static void +S_check_op_type(pTHX_ OP * const o) +{ + /* Eventually we may want to stack the needed arguments + * for each op. For now, we punt on the hard ones. */ + /* XXX This comment seems to me like wishful thinking. --sprout */ + if (o == UNENTERABLE) + Perl_croak(aTHX_ + "Can't \"goto\" into a binary or list expression"); + if (o->op_type == OP_ENTERITER) + Perl_croak(aTHX_ + "Can't \"goto\" into the middle of a foreach loop"); + if (o->op_type == OP_ENTERGIVEN) + Perl_croak(aTHX_ + "Can't \"goto\" into a \"given\" block"); +} + /* also used for: pp_dump() */ PP(pp_goto) { - dVAR; dSP; + dSP; OP *retop = NULL; I32 ix; PERL_CONTEXT *cx; -#define GOTO_DEPTH 64 OP *enterops[GOTO_DEPTH]; const char *label = NULL; STRLEN label_len = 0; @@ -2758,7 +2838,7 @@ PP(pp_goto) DIE(aTHX_ "Goto undefined subroutine"); } - cxix = dopoptosub(cxstack_ix); + cxix = dopopto_cursub(); if (cxix < 0) { DIE(aTHX_ "Can't goto subroutine outside a subroutine"); } @@ -2880,6 +2960,9 @@ PP(pp_goto) * this is a cx_popblock(), less all the stuff we already did * for cx_topblock() earlier */ PL_curcop = cx->blk_oldcop; + /* this is cx_popsub, less all the stuff we already did */ + PL_curstackinfo->si_cxsubix = cx->blk_sub.old_cxsubix; + CX_POP(cx); /* Push a mark for the start of arglist */ @@ -3050,12 +3133,14 @@ PP(pp_goto) if (leaving_eval && *enterops && enterops[1]) { I32 i; for (i = 1; enterops[i]; i++) - if (enterops[i]->op_type == OP_ENTERITER) - DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop"); + S_check_op_type(aTHX_ enterops[i]); } if (*enterops && enterops[1]) { - I32 i = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1; + I32 i = enterops[1] != UNENTERABLE + && enterops[1]->op_type == OP_ENTER && in_block + ? 2 + : 1; if (enterops[i]) deprecate("\"goto\" to jump into a construct"); } @@ -3074,13 +3159,15 @@ PP(pp_goto) if (*enterops && enterops[1]) { OP * const oldop = PL_op; - ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1; + ix = enterops[1] != UNENTERABLE + && enterops[1]->op_type == OP_ENTER && in_block + ? 2 + : 1; for (; enterops[ix]; ix++) { PL_op = enterops[ix]; - /* Eventually we may want to stack the needed arguments - * for each op. For now, we punt on the hard ones. */ - if (PL_op->op_type == OP_ENTERITER) - DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop"); + S_check_op_type(aTHX_ PL_op); + DEBUG_l( Perl_deb(aTHX_ "pp_goto: Entering %s\n", + OP_NAME(PL_op))); PL_op->op_ppaddr(aTHX); } PL_op = oldop; @@ -3396,6 +3483,7 @@ S_doeval_compile(pTHX_ U8 gimme, CV* outside, U32 seq, HV *hh) if (clear_hints) { PL_hints = 0; hv_clear(GvHV(PL_hintgv)); + CLEARFEATUREBITS(); } else { PL_hints = saveop->op_private & OPpEVAL_COPHH @@ -3413,6 +3501,7 @@ S_doeval_compile(pTHX_ U8 gimme, CV* outside, U32 seq, HV *hh) /* SAVEHINTS created a new HV in PL_hintgv, which we need to GC */ SvREFCNT_dec(GvHV(PL_hintgv)); GvHV(PL_hintgv) = hh; + FETCHFEATUREBITSHH(hh); } } SAVECOMPILEWARNINGS(); @@ -3663,7 +3752,7 @@ S_path_is_searchable(const char *name) static OP * S_require_version(pTHX_ SV *sv) { - dVAR; dSP; + dSP; sv = sv_2mortal(new_version(sv)); if (!Perl_sv_derived_from_pvn(aTHX_ PL_patchlevel, STR_WITH_LEN("version"), 0)) @@ -3729,7 +3818,7 @@ S_require_version(pTHX_ SV *sv) static OP * S_require_file(pTHX_ SV *sv) { - dVAR; dSP; + dSP; PERL_CONTEXT *cx; const char *name; @@ -3772,7 +3861,7 @@ S_require_file(pTHX_ SV *sv) if (op_is_require) { /* can optimize to only perform one single lookup */ svp_cached = hv_fetch(GvHVn(PL_incgv), (char*) name, len, 0); - if ( svp_cached && *svp_cached != &PL_sv_undef ) RETPUSHYES; + if ( svp_cached && (SvGETMAGIC(*svp_cached), SvOK(*svp_cached)) ) RETPUSHYES; } #endif @@ -3817,7 +3906,10 @@ S_require_file(pTHX_ SV *sv) /* reuse the previous hv_fetch result if possible */ SV * const * const svp = svp_cached ? svp_cached : hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0); if ( svp ) { - if (*svp != &PL_sv_undef) + /* we already did a get magic if this was cached */ + if (!svp_cached) + SvGETMAGIC(*svp); + if (SvOK(*svp)) RETPUSHYES; else DIE(aTHX_ "Attempt to reload %s aborted.\n" @@ -3884,7 +3976,7 @@ S_require_file(pTHX_ SV *sv) } /* ... but if we fail, still search @INC for code references; - * these are applied even on on-searchable paths (except + * these are applied even on non-searchable paths (except * if we got EACESS). * * For searchable paths, just search @INC normally @@ -4053,18 +4145,6 @@ S_require_file(pTHX_ SV *sv) continue; sv_setpv(namesv, unixdir); sv_catpv(namesv, unixname); -#elif defined(__SYMBIAN32__) - if (PL_origfilename[0] && - PL_origfilename[1] == ':' && - !(dir[0] && dir[1] == ':')) - Perl_sv_setpvf(aTHX_ namesv, - "%c:%s\\%s", - PL_origfilename[0], - dir, name); - else - Perl_sv_setpvf(aTHX_ namesv, - "%s\\%s", - dir, name); #else /* The equivalent of Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name); @@ -4168,7 +4248,7 @@ S_require_file(pTHX_ SV *sv) } if (c == e && isIDFIRST_lazy_if_safe(name, e, utf8)) { - sv_catpv(msg, " (you may need to install the "); + sv_catpvs(msg, " (you may need to install the "); for (c = name; c < e; c++) { if (*c == '/') { sv_catpvs(msg, "::"); @@ -4177,14 +4257,14 @@ S_require_file(pTHX_ SV *sv) sv_catpvn(msg, c, 1); } } - sv_catpv(msg, " module)"); + sv_catpvs(msg, " module)"); } } else if (memENDs(name, len, ".h")) { - sv_catpv(msg, " (change .h to .ph maybe?) (did you run h2ph?)"); + sv_catpvs(msg, " (change .h to .ph maybe?) (did you run h2ph?)"); } else if (memENDs(name, len, ".ph")) { - sv_catpv(msg, " (did you run h2ph?)"); + sv_catpvs(msg, " (did you run h2ph?)"); } /* diag_listed_as: Can't locate %s */ @@ -4630,25 +4710,538 @@ PP(pp_leavegiven) return NORMAL; } +/* Helper routines used by pp_smartmatch */ +STATIC PMOP * +S_make_matcher(pTHX_ REGEXP *re) +{ + PMOP *matcher = (PMOP *) newPMOP(OP_MATCH, OPf_WANT_SCALAR | OPf_STACKED); + + PERL_ARGS_ASSERT_MAKE_MATCHER; + + PM_SETRE(matcher, ReREFCNT_inc(re)); + + SAVEFREEOP((OP *) matcher); + ENTER_with_name("matcher"); SAVETMPS; + SAVEOP(); + return matcher; +} + +STATIC bool +S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv) +{ + dSP; + bool result; + + PERL_ARGS_ASSERT_MATCHER_MATCHES_SV; + + PL_op = (OP *) matcher; + XPUSHs(sv); + PUTBACK; + (void) Perl_pp_match(aTHX); + SPAGAIN; + result = SvTRUEx(POPs); + PUTBACK; + + return result; +} + +STATIC void +S_destroy_matcher(pTHX_ PMOP *matcher) +{ + PERL_ARGS_ASSERT_DESTROY_MATCHER; + PERL_UNUSED_ARG(matcher); + + FREETMPS; + 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, 0); +} + +/* This version of do_smartmatch() implements the + * table of smart matches that is found in perlsyn. + */ +STATIC OP * +S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other, const bool copied) +{ dSP; - SV *right = POPs; - SV *left = TOPs; - SV *result; + + bool object_on_left = FALSE; + SV *e = TOPs; /* e is for 'expression' */ + SV *d = TOPm1s; /* d is for 'default', as in PL_defgv */ + /* Take care only to invoke mg_get() once for each argument. + * Currently we do this by copying the SV if it's magical. */ + if (d) { + if (!copied && SvGMAGICAL(d)) + d = sv_mortalcopy(d); + } + else + d = &PL_sv_undef; + + assert(e); + if (SvGMAGICAL(e)) + e = sv_mortalcopy(e); + + /* 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")); + + tmpsv = amagic_call(d, e, smart_amg, AMGf_noleft); + 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 */ PUTBACK; - if (SvGMAGICAL(left)) - left = sv_mortalcopy(left); - if (SvGMAGICAL(right)) - right = sv_mortalcopy(right); - if (SvAMAGIC(right) && - (result = amagic_call(left, right, smart_amg, AMGf_noleft))) { + + /* ~~ undef */ + if (!SvOK(e)) { + DEBUG_M(Perl_deb(aTHX_ " applying rule Any-undef\n")); + if (SvOK(d)) + RETPUSHNO; + else + RETPUSHYES; + } + + if (SvROK(e) && SvOBJECT(SvRV(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 (SvROK(d) && SvOBJECT(SvRV(d)) && (SvTYPE(SvRV(d)) != SVt_REGEXP)) + object_on_left = TRUE; + + /* ~~ sub */ + if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVCV) { + I32 c; + 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; + } + else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) { + /* Test sub truth for each element */ + SSize_t i; + bool andedresults = TRUE; + AV *av = (AV*) SvRV(d); + const I32 len = av_tindex(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; + } + } + /* ~~ %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 = MUTABLE_HV(SvRV(d)); + bool tied; + bool other_tied; + 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. */ + tied = cBOOL(SvTIED_mg((SV*)hv, PERL_MAGIC_tied)); + other_tied = cBOOL(SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied)); + if (!tied ) { + if(other_tied) { + /* swap HV sides */ + HV * const temp = other_hv; + other_hv = hv; + hv = temp; + tied = TRUE; + other_tied = FALSE; + } + else if(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); + 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)) { + (void) hv_iterinit(hv); /* reset iterator */ + RETPUSHNO; + } + } + + if (other_tied) { + (void) hv_iterinit(other_hv); + while ( hv_iternext(other_hv) ) + ++other_key_count; + } + else + other_key_count = HvUSEDKEYS(other_hv); + + if (this_key_count != other_key_count) + RETPUSHNO; + else + RETPUSHYES; + } + else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) { + AV * const other_av = MUTABLE_AV(SvRV(d)); + const SSize_t other_len = av_tindex(other_av) + 1; + SSize_t 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; + } + } + 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)); + 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")); + PUTBACK; + if (matcher_matches_sv(matcher, hv_iterkeysv(he))) { + SPAGAIN; + (void) hv_iterinit(hv); + destroy_matcher(matcher); + RETPUSHYES; + } + SPAGAIN; + } + destroy_matcher(matcher); + RETPUSHNO; + } + } + 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 + RETPUSHNO; + } + } + /* ~~ @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 SSize_t other_len = av_tindex(other_av) + 1; + SSize_t 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_tindex(MUTABLE_AV(SvRV(e))) != av_tindex(other_av)) + RETPUSHNO; + else { + SSize_t i; + const SSize_t other_len = av_tindex(other_av); + + if (NULL == seen_this) { + seen_this = newHV(); + (void) sv_2mortal(MUTABLE_SV(seen_this)); + } + if (NULL == 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(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 && SvOK(*this_elem)) + || (other_elem && SvOK(*other_elem))) + RETPUSHNO; + } + 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; + } + else { + (void)hv_store_ent(seen_this, + sv_2mortal(newSViv(PTR2IV(*this_elem))), + &PL_sv_undef, 0); + (void)hv_store_ent(seen_other, + sv_2mortal(newSViv(PTR2IV(*other_elem))), + &PL_sv_undef, 0); + PUSHs(*other_elem); + PUSHs(*this_elem); + + PUTBACK; + DEBUG_M(Perl_deb(aTHX_ " recursively comparing array element...\n")); + (void) do_smartmatch(seen_this, seen_other, 0); + SPAGAIN; + DEBUG_M(Perl_deb(aTHX_ " recursion finished\n")); + + if (!SvTRUEx(POPs)) + RETPUSHNO; + } + } + 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 SSize_t this_len = av_tindex(MUTABLE_AV(SvRV(e))); + SSize_t 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")); + PUTBACK; + if (svp && matcher_matches_sv(matcher, *svp)) { + SPAGAIN; + destroy_matcher(matcher); + RETPUSHYES; + } + SPAGAIN; + } + destroy_matcher(matcher); + RETPUSHNO; + } + } + else if (!SvOK(d)) { + /* undef ~~ array */ + const SSize_t this_len = av_tindex(MUTABLE_AV(SvRV(e))); + SSize_t 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; + } + RETPUSHNO; + } + else { + sm_any_array: + { + SSize_t i; + const SSize_t this_len = av_tindex(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) + 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, 1); + SPAGAIN; + DEBUG_M(Perl_deb(aTHX_ " recursion finished\n")); + if (SvTRUEx(POPs)) + RETPUSHYES; + } + RETPUSHNO; + } + } + } + /* ~~ 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)); + bool result; + + DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Regex\n")); + PUTBACK; + result = matcher_matches_sv(matcher, d); + SPAGAIN; + PUSHs(result ? &PL_sv_yes : &PL_sv_no); + destroy_matcher(matcher); + RETURN; + } + } + /* ~~ 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; + tmpsv = amagic_call(d, e, smart_amg, AMGf_noright); + if (tmpsv) { + SPAGAIN; + (void)POPs; + SETs(tmpsv); + 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; + if (CopHINTS_get(PL_curcop) & HINT_INTEGER) + (void) Perl_pp_i_eq(aTHX); + else + (void) Perl_pp_eq(aTHX); SPAGAIN; - SETs(boolSV(SvTRUE_NN(result))); - return NORMAL; + if (SvTRUEx(POPs)) + RETPUSHYES; + else + RETPUSHNO; } - Perl_croak(aTHX_ "Cannot smart match without a matcher object"); + + /* As a last resort, use string comparison */ + DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Any\n")); + PUSHs(d); PUSHs(e); + PUTBACK; + return Perl_pp_seq(aTHX); } PP(pp_enterwhen) @@ -4663,8 +5256,11 @@ PP(pp_enterwhen) to the op that follows the leavewhen. RETURNOP calls PUTBACK which restores the stack pointer after the POPs. */ - if (!SvTRUEx(POPs)) + if (!(PL_op->op_flags & OPf_SPECIAL) && !SvTRUEx(POPs)) { + if (gimme == G_SCALAR) + PUSHs(&PL_sv_undef); RETURNOP(cLOGOP->op_other->op_next); + } cx = cx_pushblock(CXt_WHEN, gimme, SP, PL_savestack_ix); cx_pushwhen(cx); @@ -4685,7 +5281,9 @@ PP(pp_leavewhen) cxix = dopoptogivenfor(cxstack_ix); if (cxix < 0) - DIE(aTHX_ "Can't \"when\" outside a topicalizer"); + /* diag_listed_as: Can't "when" outside a topicalizer */ + DIE(aTHX_ "Can't \"%s\" outside a topicalizer", + PL_op->op_flags & OPf_SPECIAL ? "default" : "when"); oldsp = PL_stack_base + cx->blk_oldsp; if (gimme == G_VOID)