* 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. */
}
#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();
}
/* 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)
"pseudo-block",
NULL, /* CXt_WHEN never actually needs "block" */
NULL, /* CXt_BLOCK never actually needs "block" */
- NULL, /* CXt_LOOP_GIVEN never actually needs "block" */
+ NULL, /* CXt_GIVEN never actually needs "block" */
NULL, /* CXt_LOOP_PLAIN never actually needs "loop" */
NULL, /* CXt_LOOP_LAZYIV never actually needs "loop" */
NULL, /* CXt_LOOP_LAZYSV never actually needs "loop" */
if (CxTYPE(cx) == CXt_NULL) /* sort BLOCK */
return -1;
break;
- case CXt_LOOP_GIVEN:
case CXt_LOOP_PLAIN:
case CXt_LOOP_LAZYIV:
case CXt_LOOP_LAZYSV:
if ((CxTYPE(cx)) == CXt_NULL) /* sort BLOCK */
return -1;
break;
- case CXt_LOOP_GIVEN:
case CXt_LOOP_PLAIN:
case CXt_LOOP_LAZYIV:
case CXt_LOOP_LAZYSV:
return i;
}
+/* find the next GIVEN or FOR (with implicit $_) loop context block */
+
+STATIC I32
+S_dopoptogivenfor(pTHX_ I32 startingblock)
+{
+ I32 i;
+ for (i = startingblock; i >= 0; i--) {
+ const PERL_CONTEXT *cx = &cxstack[i];
+ switch (CxTYPE(cx)) {
+ default:
+ continue;
+ case CXt_GIVEN:
+ DEBUG_l( Perl_deb(aTHX_ "(dopoptogivenfor(): found given at cx=%ld)\n", (long)i));
+ return i;
+ case CXt_LOOP_PLAIN:
+ assert(!(cx->cx_type & CXp_FOR_DEF));
+ break;
+ case CXt_LOOP_LAZYIV:
+ case CXt_LOOP_LAZYSV:
+ case CXt_LOOP_LIST:
+ case CXt_LOOP_ARY:
+ if (cx->cx_type & CXp_FOR_DEF) {
+ DEBUG_l( Perl_deb(aTHX_ "(dopoptogivenfor(): found foreach at cx=%ld)\n", (long)i));
+ return i;
+ }
+ }
+ }
+ return i;
+}
+
STATIC I32
S_dopoptowhen(pTHX_ I32 startingblock)
{
case CXt_EVAL:
cx_popeval(cx);
break;
- case CXt_LOOP_GIVEN:
case CXt_LOOP_PLAIN:
case CXt_LOOP_LAZYIV:
case CXt_LOOP_LAZYSV:
case CXt_WHEN:
cx_popwhen(cx);
break;
+ case CXt_GIVEN:
+ cx_popgiven(cx);
+ break;
case CXt_BLOCK:
case CXt_NULL:
/* these two don't have a POPFOO() */
* 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,
*/
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);
itersave = GvSV(sv);
SvREFCNT_inc_simple_void(itersave);
cxflags = CXp_FOR_GV;
+ if (PL_op->op_private & OPpITER_DEF)
+ cxflags |= CXp_FOR_DEF;
}
else { /* LV ref: for \$foo (...) */
assert(SvTYPE(sv) == SVt_PVMG);
cxflags = CXp_FOR_LVREF;
}
}
+ /* OPpITER_DEF (implicit $_) should only occur with a GV iter var */
+ assert((cxflags & CXp_FOR_GV) || !(PL_op->op_private & OPpITER_DEF));
/* Note that this context is initially set as CXt_NULL. Further on
* down it's changed to one of the CXt_LOOP_*. Before it's changed,
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)
{
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) {
}
}
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;
}
+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)
OP *retop = NULL;
I32 ix;
PERL_CONTEXT *cx;
-#define GOTO_DEPTH 64
OP *enterops[GOTO_DEPTH];
const char *label = NULL;
STRLEN label_len = 0;
case CXt_LOOP_LAZYSV:
case CXt_LOOP_LIST:
case CXt_LOOP_ARY:
- case CXt_LOOP_GIVEN:
+ case CXt_GIVEN:
case CXt_WHEN:
gotoprobe = OpSIBLING(cx->blk_oldcop);
break;
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");
}
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;
}
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, "::");
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 */
assert(!PL_op->op_targ); /* used to be set for lexical $_ */
GvSV(PL_defgv) = SvREFCNT_inc(newsv);
- cx = cx_pushblock(CXt_LOOP_GIVEN|CXp_FOR_GV, gimme, SP, PL_savestack_ix);
- cx_pushloop_given(cx, origsv);
+ cx = cx_pushblock(CXt_GIVEN, gimme, SP, PL_savestack_ix);
+ cx_pushgiven(cx, origsv);
RETURN;
}
PERL_UNUSED_CONTEXT;
cx = CX_CUR();
- assert(CxTYPE(cx) == CXt_LOOP_GIVEN);
+ assert(CxTYPE(cx) == CXt_GIVEN);
oldsp = PL_stack_base + cx->blk_oldsp;
gimme = cx->blk_gimme;
leave_adjust_stacks(oldsp, oldsp, gimme, 1);
CX_LEAVE_SCOPE(cx);
- cx_poploop(cx);
+ cx_popgiven(cx);
cx_popblock(cx);
CX_POP(cx);
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)
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);
assert(CxTYPE(cx) == CXt_WHEN);
gimme = cx->blk_gimme;
- cxix = dopoptoloop(cxstack_ix);
+ cxix = dopoptogivenfor(cxstack_ix);
if (cxix < 0)
- DIE(aTHX_ "Can't leave \"when\" outside a loop block");
+ /* 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)
else
leave_adjust_stacks(oldsp, oldsp, gimme, 1);
- /* pop the WHEN, BLOCK and anything else before the loop */
+ /* pop the WHEN, BLOCK and anything else before the GIVEN/FOR */
assert(cxix < cxstack_ix);
dounwind(cxix);
cx = &cxstack[cxix];
- if (CxTYPE(cx) != CXt_LOOP_GIVEN) {
+ if (CxFOREACH(cx)) {
/* emulate pp_next. Note that any stack(s) cleanup will be
* done by the pp_unstack which op_nextop should point to */
cx = CX_CUR();
cx_topblock(cx);
PL_curcop = cx->blk_oldcop;
- PERL_ASYNC_CHECK();
return cx->blk_loop.my_op->op_nextop;
}
else {
PERL_ASYNC_CHECK();
- assert(cx->blk_loop.my_op->op_nextop->op_type == OP_LEAVEGIVEN);
- return cx->blk_loop.my_op->op_nextop;
+ assert(cx->blk_givwhen.leave_op->op_type == OP_LEAVEGIVEN);
+ return cx->blk_givwhen.leave_op;
}
}
CX_LEAVE_SCOPE(cx);
cx_popwhen(cx);
cx_popblock(cx);
- nextop = cx->blk_when.leave_op->op_next;
+ nextop = cx->blk_givwhen.leave_op->op_next;
CX_POP(cx);
return nextop;
}
+PP(pp_break)
+{
+ I32 cxix;
+ PERL_CONTEXT *cx;
+
+ cxix = dopoptogivenfor(cxstack_ix);
+ if (cxix < 0)
+ DIE(aTHX_ "Can't \"break\" outside a given block");
+
+ cx = &cxstack[cxix];
+ if (CxFOREACH(cx))
+ DIE(aTHX_ "Can't \"break\" in a loop topicalizer");
+
+ if (cxix < cxstack_ix)
+ dounwind(cxix);
+
+ /* Restore the sp at the time we entered the given block */
+ cx = CX_CUR();
+ PL_stack_sp = PL_stack_base + cx->blk_oldsp;
+
+ return cx->blk_givwhen.leave_op;
+}
+
static MAGIC *
S_doparseform(pTHX_ SV *sv)
{
https://perl5.git.perl.org / perl5.git / blobdiff