revert smartmatch to 5.27.6 behaviour

The pumpking has determined that the CPAN breakage caused by changing
smartmatch [perl #132594] is too great for the smartmatch changes to
stay in for 5.28.

This reverts most of the merge in commit
da4e040f42421764ef069371d77c008e6b801f45.  All core behaviour and
documentation is reverted.  The removal of use of smartmatch from a couple
of tests (that aren't testing smartmatch) remains.  Customisation of
a couple of CPAN modules to make them portable across smartmatch types
remains.  A small bugfix in scope.c also remains.

1 files changed, 643 insertions, 46 deletions

diff --git a/pp_ctl.c b/pp_ctl.c
index a97761d999..e6d39f289e 100644
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -1285,9 +1285,9 @@ PP(pp_flop)
 
 static const char * const context_name[] = {
     "pseudo-block",
-    NULL, /* CXt_WHERESO never actually needs "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" */
@@ -1320,7 +1320,6 @@ S_dopoptolabel(pTHX_ const char *label, STRLEN len, U32 flags)
 	    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:
@@ -1469,7 +1468,6 @@ S_dopoptoloop(pTHX_ I32 startingblock)
 	    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:
@@ -1482,8 +1480,38 @@ S_dopoptoloop(pTHX_ I32 startingblock)
     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_dopoptowhereso(pTHX_ I32 startingblock)
+S_dopoptowhen(pTHX_ I32 startingblock)
 {
     I32 i;
     for (i = startingblock; i >= 0; i--) {
@@ -1491,8 +1519,8 @@ S_dopoptowhereso(pTHX_ I32 startingblock)
 	switch (CxTYPE(cx)) {
 	default:
 	    continue;
-	case CXt_WHERESO:
-	    DEBUG_l( Perl_deb(aTHX_ "(dopoptowhereso(): found whereso at cx=%ld)\n", (long)i));
+	case CXt_WHEN:
+	    DEBUG_l( Perl_deb(aTHX_ "(dopoptowhen(): found when at cx=%ld)\n", (long)i));
 	    return i;
 	}
     }
@@ -1536,7 +1564,6 @@ Perl_dounwind(pTHX_ I32 cxix)
 	case CXt_EVAL:
 	    cx_popeval(cx);
 	    break;
-	case CXt_LOOP_GIVEN:
 	case CXt_LOOP_PLAIN:
 	case CXt_LOOP_LAZYIV:
 	case CXt_LOOP_LAZYSV:
@@ -1544,8 +1571,11 @@ Perl_dounwind(pTHX_ I32 cxix)
 	case CXt_LOOP_ARY:
 	    cx_poploop(cx);
 	    break;
-	case CXt_WHERESO:
-	    cx_popwhereso(cx);
+	case CXt_WHEN:
+	    cx_popwhen(cx);
+	    break;
+	case CXt_GIVEN:
+	    cx_popgiven(cx);
 	    break;
 	case CXt_BLOCK:
 	case CXt_NULL:
@@ -2160,6 +2190,8 @@ PP(pp_enteriter)
             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);
@@ -2169,6 +2201,8 @@ PP(pp_enteriter)
             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,
@@ -2624,7 +2658,8 @@ 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)
@@ -2970,8 +3005,8 @@ PP(pp_goto)
             case CXt_LOOP_LAZYSV:
             case CXt_LOOP_LIST:
             case CXt_LOOP_ARY:
-	    case CXt_LOOP_GIVEN:
-	    case CXt_WHERESO:
+	    case CXt_GIVEN:
+	    case CXt_WHEN:
 		gotoprobe = OpSIBLING(cx->blk_oldcop);
 		break;
 	    case CXt_SUBST:
@@ -4577,34 +4612,572 @@ PP(pp_entergiven)
     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;
 }
 
+PP(pp_leavegiven)
+{
+    PERL_CONTEXT *cx;
+    U8 gimme;
+    SV **oldsp;
+    PERL_UNUSED_CONTEXT;
+
+    cx = CX_CUR();
+    assert(CxTYPE(cx) == CXt_GIVEN);
+    oldsp = PL_stack_base + cx->blk_oldsp;
+    gimme = cx->blk_gimme;
+
+    if (gimme == G_VOID)
+        PL_stack_sp = oldsp;
+    else
+        leave_adjust_stacks(oldsp, oldsp, gimme, 1);
+
+    CX_LEAVE_SCOPE(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_enterwhereso)
+PP(pp_enterwhen)
 {
     dSP;
     PERL_CONTEXT *cx;
@@ -4613,22 +5186,22 @@ PP(pp_enterwhereso)
     /* This is essentially an optimization: if the match
        fails, we don't want to push a context and then
        pop it again right away, so we skip straight
-       to the op that follows the leavewhereso.
+       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_WHERESO, gimme, SP, PL_savestack_ix);
-    cx_pushwhereso(cx);
+    cx = cx_pushblock(CXt_WHEN, gimme, SP, PL_savestack_ix);
+    cx_pushwhen(cx);
 
     RETURN;
 }
 
-PP(pp_leavewhereso)
+PP(pp_leavewhen)
 {
     I32 cxix;
     PERL_CONTEXT *cx;
@@ -4636,12 +5209,14 @@ PP(pp_leavewhereso)
     SV **oldsp;
 
     cx = CX_CUR();
-    assert(CxTYPE(cx) == CXt_WHERESO);
+    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 \"whereso\" 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)
@@ -4649,25 +5224,24 @@ PP(pp_leavewhereso)
     else
         leave_adjust_stacks(oldsp, oldsp, gimme, 1);
 
-    /* pop the WHERESO, 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_LEAVELOOP);
-	return cx->blk_loop.my_op->op_nextop;
+        assert(cx->blk_givwhen.leave_op->op_type == OP_LEAVEGIVEN);
+	return cx->blk_givwhen.leave_op;
     }
 }
 
@@ -4677,25 +5251,48 @@ PP(pp_continue)
     PERL_CONTEXT *cx;
     OP *nextop;
     
-    cxix = dopoptowhereso(cxstack_ix); 
+    cxix = dopoptowhen(cxstack_ix); 
     if (cxix < 0)   
-	DIE(aTHX_ "Can't \"continue\" outside a whereso block");
+	DIE(aTHX_ "Can't \"continue\" outside a when block");
 
     if (cxix < cxstack_ix)
         dounwind(cxix);
     
     cx = CX_CUR();
-    assert(CxTYPE(cx) == CXt_WHERESO);
+    assert(CxTYPE(cx) == CXt_WHEN);
     PL_stack_sp = PL_stack_base + cx->blk_oldsp;
     CX_LEAVE_SCOPE(cx);
-    cx_popwhereso(cx);
+    cx_popwhen(cx);
     cx_popblock(cx);
-    nextop = cx->blk_whereso.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)
 {