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.

7 files changed, 102 insertions, 80 deletions

diff --git a/lib/B/Deparse-core.t b/lib/B/Deparse-core.t
index 4071e5e5f2..6ee935f5f7 100644
--- a/lib/B/Deparse-core.t
+++ b/lib/B/Deparse-core.t
@@ -36,7 +36,7 @@ BEGIN {
 
 use strict;
 use Test::More;
-plan tests => 3874;
+plan tests => 3886;
 
 use feature (sprintf(":%vd", $^V)); # to avoid relying on the feature
                                     # logic to add CORE::
@@ -381,8 +381,7 @@ my %not_tested = map { $_ => 1} qw(
     unless
     until
     use
-    whereis
-    whereso
+    when
     while
     y
 );
@@ -465,6 +464,7 @@ atan2            2     p
 bind             2     p
 binmode          12    p
 bless            1     p
+break            0     -
 caller           0     -
 chdir            01    -
 chmod            @     p1
diff --git a/lib/B/Deparse.pm b/lib/B/Deparse.pm
index d10e6a0868..86f262acf1 100644
--- a/lib/B/Deparse.pm
+++ b/lib/B/Deparse.pm
@@ -52,7 +52,7 @@ use B qw(class main_root main_start main_cv svref_2object opnumber perlstring
         MDEREF_SHIFT
     );
 
-$VERSION = '1.46';
+$VERSION = '1.47';
 use strict;
 our $AUTOLOAD;
 use warnings ();
@@ -2267,8 +2267,9 @@ my %feature_keywords = (
     state   => 'state',
     say     => 'say',
     given   => 'switch',
-    whereis => 'switch',
-    whereso => 'switch',
+    when    => 'switch',
+    default => 'switch',
+    break   => 'switch',
     evalbytes=>'evalbytes',
     __SUB__ => '__SUB__',
    fc       => 'fc',
@@ -2560,31 +2561,33 @@ sub pp_ggrgid { unop(@_, "getgrgid") }
 sub pp_lock { unop(@_, "lock") }
 
 sub pp_continue { unop(@_, "continue"); }
+sub pp_break { unop(@_, "break"); }
 
-sub _op_is_defsv {
-    my($self, $op) = @_;
-    $op->name eq "null" && !null($op->first) && null($op->first->sibling)
-	and $op = $op->first;
-    $op->name eq "gvsv" && $self->gv_name($self->gv_or_padgv($op)) eq "_";
-}
+sub givwhen {
+    my $self = shift;
+    my($op, $cx, $givwhen) = @_;
 
-sub pp_leavewhereso {
-    my($self, $op, $cx) = @_;
     my $enterop = $op->first;
-    my $cond = $enterop->first;
-    my $block = $cond->sibling;
-    my $keyword = "whereso";
-    if ($cond->name eq "smartmatch" && $self->{expand} < 2 &&
-		$self->_op_is_defsv($cond->first)) {
-	$cond = $cond->last;
-	$keyword = "whereis";
+    my ($head, $block);
+    if ($enterop->flags & OPf_SPECIAL) {
+	$head = $self->keyword("default");
+	$block = $self->deparse($enterop->first, 0);
     }
-    my $cond_str = $self->deparse($cond, 1);
-    $keyword = $self->keyword($keyword);
-    $block = $self->deparse($block, 0);
-    return "$keyword ($cond_str) {\n\t$block\n\b}\cK";
+    else {
+	my $cond = $enterop->first;
+	my $cond_str = $self->deparse($cond, 1);
+	$head = "$givwhen ($cond_str)";
+	$block = $self->deparse($cond->sibling, 0);
+    }
+
+    return "$head {\n".
+	"\t$block\n".
+	"\b}\cK";
 }
 
+sub pp_leavegiven { givwhen(@_, $_[0]->keyword("given")); }
+sub pp_leavewhen  { givwhen(@_, $_[0]->keyword("when")); }
+
 sub pp_exists {
     my $self = shift;
     my($op, $cx) = @_;
@@ -3019,7 +3022,6 @@ sub pp_i_ge { binop(@_, ">=", 15) }
 sub pp_i_le { binop(@_, "<=", 15) }
 sub pp_i_ncmp { maybe_targmy(@_, \&binop, "<=>", 14) }
 
-sub pp_smartmatch { binop(@_, "~~", 14) }
 sub pp_seq { binop(@_, "eq", 14) }
 sub pp_sne { binop(@_, "ne", 14) }
 sub pp_slt { binop(@_, "lt", 15) }
@@ -3031,6 +3033,16 @@ sub pp_scmp { maybe_targmy(@_, \&binop, "cmp", 14) }
 sub pp_sassign { binop(@_, "=", 7, SWAP_CHILDREN) }
 sub pp_aassign { binop(@_, "=", 7, SWAP_CHILDREN | LIST_CONTEXT) }
 
+sub pp_smartmatch {
+    my ($self, $op, $cx) = @_;
+    if (($op->flags & OPf_SPECIAL) && $self->{expand} < 2) {
+	return $self->deparse($op->last, $cx);
+    }
+    else {
+	binop(@_, "~~", 14);
+    }
+}
+
 # '.' is special because concats-of-concats are optimized to save copying
 # by making all but the first concat stacked. The effect is as if the
 # programmer had written '($a . $b) .= $c', except legal.
@@ -3834,13 +3846,6 @@ sub loop_common {
 	    $bare = 1;
 	}
 	$body = $kid;
-    } elsif ($enter->name eq "entergiven") { # given
-	my $given = $self->keyword("given");
-	my $enterop = $op->first;
-	my $topic = $enterop->first;
-	my $topic_str = $self->deparse($topic, 1);
-	my $block = $self->deparse($topic->sibling, 0);
-	return "$given ($topic_str) {\n\t$block\n\b}\cK";
     } elsif ($enter->name eq "enteriter") { # foreach
 	my $ary = $enter->first->sibling; # first was pushmark
 	my $var = $ary->sibling;
diff --git a/lib/B/Deparse.t b/lib/B/Deparse.t
index 576cd7456f..00fbb01cf8 100644
--- a/lib/B/Deparse.t
+++ b/lib/B/Deparse.t
@@ -1039,14 +1039,13 @@ my $b = \{};
 my $c = [];
 my $d = \[];
 ####
-# SKIP ?$] < 5.010 && "smartmatch and given/whereso not implemented on this Perl version"
+# SKIP ?$] < 5.010 && "smartmatch and given/when not implemented on this Perl version"
 # CONTEXT use feature ':5.10'; no warnings 'experimental::smartmatch';
-# implicit smartmatch in given/whereso
+# implicit smartmatch in given/when
 given ('foo') {
-    whereso ('bar') { continue; }
-    whereso ($_ == 3) { continue; }
-    whereis ('quux') { continue; }
-    0;
+    when ('bar') { continue; }
+    when ($_ ~~ 'quux') { continue; }
+    default { 0; }
 }
 ####
 # conditions in elsifs (regression in change #33710 which fixed bug #37302)
@@ -1528,13 +1527,12 @@ $a[0] = 1;
 CORE::state $x;
 CORE::say $x;
 CORE::given ($x) {
-    CORE::whereso (3) {
+    CORE::when (3) {
         continue;
     }
-    CORE::whereis (5) {
-        continue;
+    CORE::default {
+        CORE::break;
     }
-    next;
 }
 CORE::evalbytes '';
 () = CORE::__SUB__;
@@ -1547,13 +1545,12 @@ use 1;
 CORE::say $_;
 CORE::state $x;
 CORE::given ($x) {
-    CORE::whereso (3) {
+    CORE::when (3) {
         continue;
     }
-    CORE::whereis (5) {
-        continue;
+    CORE::default {
+        CORE::break;
     }
-    next;
 }
 CORE::evalbytes '';
 () = CORE::__SUB__;
@@ -1561,13 +1558,12 @@ CORE::evalbytes '';
 CORE::say $_;
 CORE::state $x;
 CORE::given ($x) {
-    CORE::whereso (3) {
+    CORE::when (3) {
         continue;
     }
-    CORE::whereis (5) {
-        continue;
+    CORE::default {
+        CORE::break;
     }
-    next;
 }
 CORE::evalbytes '';
 () = CORE::__SUB__;
@@ -1580,13 +1576,12 @@ use 1;
 CORE::say $_;
 CORE::state $x;
 CORE::given ($x) {
-    CORE::whereso (3) {
+    CORE::when (3) {
         continue;
     }
-    CORE::whereis (5) {
-        continue;
+    CORE::default {
+        CORE::break;
     }
-    next;
 }
 CORE::evalbytes '';
 () = CORE::__SUB__;
@@ -1596,13 +1591,12 @@ use feature ':default';
 CORE::say $_;
 CORE::state $x;
 CORE::given ($x) {
-    CORE::whereso (3) {
+    CORE::when (3) {
         continue;
     }
-    CORE::whereis (5) {
-        continue;
+    CORE::default {
+        CORE::break;
     }
-    next;
 }
 CORE::evalbytes '';
 () = CORE::__SUB__;
@@ -1610,6 +1604,7 @@ CORE::evalbytes '';
 # SKIP ?$] < 5.017004 && "lexical subs not implemented on this Perl version"
 # lexical subroutines and keywords of the same name
 # CONTEXT use feature 'lexical_subs', 'switch'; no warnings 'experimental';
+my sub default;
 my sub else;
 my sub elsif;
 my sub for;
@@ -1630,9 +1625,9 @@ my sub tr;
 my sub unless;
 my sub until;
 my sub use;
-my sub whereis;
-my sub whereso;
+my sub when;
 my sub while;
+CORE::default { die; }
 CORE::if ($1) { die; }
 CORE::if ($1) { die; }
 CORE::elsif ($1) { die; }
@@ -1654,8 +1649,7 @@ CORE::unless ($1) { die; }
 CORE::until ($1) { die; }
 die CORE::until $1;
 CORE::use strict;
-CORE::whereis (5) { die; }
-CORE::whereso ($1 ~~ $2) { die; }
+CORE::when ($1 ~~ $2) { die; }
 CORE::while ($1) { die; }
 die CORE::while $1;
 ####
diff --git a/lib/B/Op_private.pm b/lib/B/Op_private.pm
index 1bf9c57e27..25e9a8c6f2 100644
--- a/lib/B/Op_private.pm
+++ b/lib/B/Op_private.pm
@@ -304,9 +304,11 @@ $bits{dorassign}{0} = $bf[0];
 $bits{dump}{0} = $bf[0];
 $bits{each}{0} = $bf[0];
 @{$bits{entereval}}{5,4,3,2,1,0} = ('OPpEVAL_RE_REPARSING', 'OPpEVAL_COPHH', 'OPpEVAL_BYTES', 'OPpEVAL_UNICODE', 'OPpEVAL_HAS_HH', $bf[0]);
+$bits{entergiven}{0} = $bf[0];
+$bits{enteriter}{3} = 'OPpITER_DEF';
 @{$bits{entersub}}{5,4,0} = ($bf[8], $bf[8], 'OPpENTERSUB_INARGS');
 $bits{entertry}{0} = $bf[0];
-$bits{enterwhereso}{0} = $bf[0];
+$bits{enterwhen}{0} = $bf[0];
 @{$bits{enterwrite}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
 @{$bits{eof}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
 @{$bits{eq}}{1,0} = ($bf[1], $bf[1]);
@@ -405,10 +407,11 @@ $bits{lc}{0} = $bf[0];
 $bits{lcfirst}{0} = $bf[0];
 @{$bits{le}}{1,0} = ($bf[1], $bf[1]);
 $bits{leaveeval}{0} = $bf[0];
+$bits{leavegiven}{0} = $bf[0];
 @{$bits{leaveloop}}{1,0} = ($bf[1], $bf[1]);
 $bits{leavesub}{0} = $bf[0];
 $bits{leavesublv}{0} = $bf[0];
-$bits{leavewhereso}{0} = $bf[0];
+$bits{leavewhen}{0} = $bf[0];
 $bits{leavewrite}{0} = $bf[0];
 @{$bits{left_shift}}{1,0} = ($bf[1], $bf[1]);
 $bits{length}{0} = $bf[0];
@@ -632,6 +635,7 @@ our %defines = (
     OPpHINT_STRICT_REFS      =>   2,
     OPpHUSH_VMSISH           =>  32,
     OPpINDEX_BOOLNEG         =>  64,
+    OPpITER_DEF              =>   8,
     OPpITER_REVERSED         =>   2,
     OPpKVSLICE               =>  32,
     OPpLIST_GUESSED          =>  64,
@@ -737,6 +741,7 @@ our %labels = (
     OPpHINT_STRICT_REFS      => 'STRICT',
     OPpHUSH_VMSISH           => 'HUSH',
     OPpINDEX_BOOLNEG         => 'NEG',
+    OPpITER_DEF              => 'DEF',
     OPpITER_REVERSED         => 'REVERSED',
     OPpKVSLICE               => 'KVSLICE',
     OPpLIST_GUESSED          => 'GUESSED',
@@ -814,6 +819,7 @@ our %ops_using = (
     OPpHINT_STRICT_REFS      => [qw(entersub multideref rv2av rv2cv rv2gv rv2hv rv2sv)],
     OPpHUSH_VMSISH           => [qw(dbstate nextstate)],
     OPpINDEX_BOOLNEG         => [qw(index rindex)],
+    OPpITER_DEF              => [qw(enteriter)],
     OPpITER_REVERSED         => [qw(enteriter iter)],
     OPpKVSLICE               => [qw(delete)],
     OPpLIST_GUESSED          => [qw(list)],
diff --git a/lib/feature.pm b/lib/feature.pm
index e9cf2f77b9..70df619e49 100644
--- a/lib/feature.pm
+++ b/lib/feature.pm
@@ -5,7 +5,7 @@
 
 package feature;
 
-our $VERSION = '1.50';
+our $VERSION = '1.51';
 
 our %feature = (
     fc              => 'feature_fc',
@@ -151,7 +151,7 @@ explicitly disabled the warning:
 
     no warnings "experimental::smartmatch";
 
-C<use feature 'switch'> tells the compiler to enable the
+C<use feature 'switch'> tells the compiler to enable the Perl 6
 given/when construct.
 
 See L<perlsyn/"Switch Statements"> for details.
diff --git a/lib/overload.pm b/lib/overload.pm
index 45c48958e5..b19c5a53cb 100644
--- a/lib/overload.pm
+++ b/lib/overload.pm
@@ -1,6 +1,6 @@
 package overload;
 
-our $VERSION = '1.29';
+our $VERSION = '1.30';
 
 %ops = (
     with_assign         => "+ - * / % ** << >> x .",
@@ -522,8 +522,33 @@ This overload was introduced in Perl 5.12.
 =item * I<Matching>
 
 The key C<"~~"> allows you to override the smart matching logic used by
-the C<~~> operator.  See L<perlop/"Smartmatch Operator">.
-Unusually, the overloaded only takes effect for the right-hand operand.
+the C<~~> operator and the switch construct (C<given>/C<when>).  See
+L<perlsyn/Switch Statements> and L<feature>.
+
+Unusually, the overloaded implementation of the smart match operator
+does not get full control of the smart match behaviour.
+In particular, in the following code:
+
+    package Foo;
+    use overload '~~' => 'match';
+
+    my $obj =  Foo->new();
+    $obj ~~ [ 1,2,3 ];
+
+the smart match does I<not> invoke the method call like this:
+
+    $obj->match([1,2,3],0);
+
+rather, the smart match distributive rule takes precedence, so $obj is
+smart matched against each array element in turn until a match is found,
+so you may see between one and three of these calls instead:
+
+    $obj->match(1,0);
+    $obj->match(2,0);
+    $obj->match(3,0);
+
+Consult the match table in  L<perlop/"Smartmatch Operator"> for
+details of when overloading is invoked.
 
 =item * I<Dereferencing>
 
diff --git a/lib/overload.t b/lib/overload.t
index 99f5b64adb..2afa6cf437 100644
--- a/lib/overload.t
+++ b/lib/overload.t
@@ -48,7 +48,7 @@ package main;
 
 $| = 1;
 BEGIN { require './test.pl'; require './charset_tools.pl' }
-plan tests => 5392;
+plan tests => 5338;
 
 use Scalar::Util qw(tainted);
 
@@ -1622,11 +1622,6 @@ foreach my $op (qw(<=> == != < <= > >=)) {
     is($y, $o, "copy constructor falls back to assignment (preinc)");
 }
 
-{
-    package MatchAbc;
-    use overload '~~' => sub { $_[1] eq "abc" };
-}
-
 # only scalar 'x' should currently overload
 
 {
@@ -1840,10 +1835,7 @@ foreach my $op (qw(<=> == != < <= > >=)) {
 
 	$e = '"abc" ~~ (%s)';
 	$subs{'~~'} = $e;
-	push @tests, [ bless({}, "MatchAbc"), $e, '(~~)', '(NM:~~)',
-			[ 1, 1, 0 ], 0 ];
-	$e = '(%s) ~~ bless({}, "MatchAbc")';
-	push @tests, [ "xyz", $e, '(eq)', '(NM:eq)', [ 1, 1, 0 ], 0 ];
+	push @tests, [ "abc", $e, '(~~)', '(NM:~~)', [ 1, 1, 0 ], 0 ];
 
 	$subs{'-X'} = 'do { my $f = (%s);'
 		    . '$_[1] eq "r" ? (-r ($f)) :'