Revert "switch removal: remove smartmatch"

This reverts commit cb2167d.

Author: tonycoz

MANIFEST

@@ -6432,6 +6432,7 @@ t/op/signatures.t			See if sub signatures work
 t/op/sigsystem.t			See if system and SIGCHLD handlers play together nicely
 t/op/sleep.t				See if sleep works
 t/op/smartkve.t				See if smart deref for keys/values/each works
+t/op/smartmatch.t			See if the ~~ operator works
 t/op/sort.t				See if sort works
 t/op/splice.t				See if splice works
 t/op/split.t				See if split works

embed.fnc

@@ -4893,6 +4893,8 @@ S	|bool	|process_special_blocks 				\
 				|NN const char * const fullname 	\
 				|NN GV * const gv			\
 				|NN CV * const cv
+S	|OP *	|ref_array_or_hash					\
+				|NULLOK OP *cond
 S	|OP *	|refkids	|NULLOK OP *o				\
 				|I32 type
 S	|OP *	|scalarboolean	|NN OP *o
@@ -5071,6 +5073,7 @@ p	|UV	|_to_upper_title_latin1 				\
 #if defined(PERL_IN_PP_CTL_C)
 RS	|PerlIO *|check_type_and_open					\
 				|NN SV *name
+S	|void	|destroy_matcher|NN PMOP *matcher
 RSd	|OP *	|docatch	|Perl_ppaddr_t firstpp
 S	|bool	|doeval_compile |U8 gimme				\
 				|NULLOK CV *outside			\
@@ -5090,6 +5093,13 @@ RS	|I32	|dopoptolabel	|NN const char *label			\
 RS	|I32	|dopoptoloop	|I32 startingblock
 RS	|I32	|dopoptosub_at	|NN const PERL_CONTEXT *cxstk		\
 				|I32 startingblock
+S	|OP *	|do_smartmatch	|NULLOK HV *seen_this			\
+				|NULLOK HV *seen_other			\
+				|const bool copied
+RS	|PMOP * |make_matcher	|NN REGEXP *re
+RS	|bool	|matcher_matches_sv					\
+				|NN PMOP *matcher			\
+				|NN SV *sv
 RST	|bool	|num_overflow	|NV value				\
 				|I32 fldsize				\
 				|I32 frcsize

embed.h

@@ -1351,6 +1351,7 @@
 #     define ck_scmp(a)                         Perl_ck_scmp(aTHX_ a)
 #     define ck_select(a)                       Perl_ck_select(aTHX_ a)
 #     define ck_shift(a)                        Perl_ck_shift(aTHX_ a)
+#     define ck_smartmatch(a)                   Perl_ck_smartmatch(aTHX_ a)
 #     define ck_sort(a)                         Perl_ck_sort(aTHX_ a)
 #     define ck_spair(a)                        Perl_ck_spair(aTHX_ a)
 #     define ck_split(a)                        Perl_ck_split(aTHX_ a)
@@ -1556,6 +1557,7 @@
 #     define opslab_slot_offset                 S_opslab_slot_offset
 #     define pmtrans(a,b,c)                     S_pmtrans(aTHX_ a,b,c)
 #     define process_special_blocks(a,b,c,d)    S_process_special_blocks(aTHX_ a,b,c,d)
+#     define ref_array_or_hash(a)               S_ref_array_or_hash(aTHX_ a)
 #     define refkids(a,b)                       S_refkids(aTHX_ a,b)
 #     define scalar_mod_type                    S_scalar_mod_type
 #     define scalarboolean(a)                   S_scalarboolean(aTHX_ a)
@@ -1631,6 +1633,8 @@
 #   endif
 #   if defined(PERL_IN_PP_CTL_C)
 #     define check_type_and_open(a)             S_check_type_and_open(aTHX_ a)
+#     define destroy_matcher(a)                 S_destroy_matcher(aTHX_ a)
+#     define do_smartmatch(a,b,c)               S_do_smartmatch(aTHX_ a,b,c)
 #     define docatch(a)                         S_docatch(aTHX_ a)
 #     define doeval_compile(a,b,c,d)            S_doeval_compile(aTHX_ a,b,c,d)
 #     define dofindlabel(a,b,c,d,e,f)           S_dofindlabel(aTHX_ a,b,c,d,e,f)
@@ -1639,6 +1643,8 @@
 #     define dopoptolabel(a,b,c)                S_dopoptolabel(aTHX_ a,b,c)
 #     define dopoptoloop(a)                     S_dopoptoloop(aTHX_ a)
 #     define dopoptosub_at(a,b)                 S_dopoptosub_at(aTHX_ a,b)
+#     define make_matcher(a)                    S_make_matcher(aTHX_ a)
+#     define matcher_matches_sv(a,b)            S_matcher_matches_sv(aTHX_ a,b)
 #     define num_overflow                       S_num_overflow
 #     define path_is_searchable                 S_path_is_searchable
 #     define run_user_filter(a,b,c)             S_run_user_filter(aTHX_ a,b,c)

ext/Opcode/Opcode.pm

@@ -436,6 +436,8 @@ These are a hotchpotch of opcodes still waiting to be considered
     entertry leavetry -- can be used to 'hide' fatal errors
     entertrycatch poptry catch leavetrycatch -- similar
 
+    smartmatch
+
     pushdefer
 
     custom -- where should this go

lib/B/Deparse.pm

@@ -3169,6 +3169,16 @@ sub pp_padsv_store {
     return $self->maybe_parens("$var = $val", $cx, 7);
 }
 
+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.
@@ -5194,7 +5204,7 @@ sub retscalar {
                  |i_subtract|concat|multiconcat|stringify|left_shift|right_shift|lt
                  |i_lt|gt|i_gt|le|i_le|ge|i_ge|eq|i_eq|ne|i_ne|ncmp|i_ncmp
                  |slt|sgt|sle|sge|seq|sne|scmp|[sn]?bit_(?:and|x?or)|negate
-                 |i_negate|not|[sn]?complement|atan2|sin|cos
+                 |i_negate|not|[sn]?complement|smartmatch|atan2|sin|cos
                  |rand|srand|exp|log|sqrt|int|hex|oct|abs|length|substr
                  |vec|index|rindex|sprintf|formline|ord|chr|crypt|ucfirst
                  |lcfirst|uc|lc|quotemeta|aelemfast|aelem|exists|helem

lib/B/Op_private.pm

@@ -3,7 +3,7 @@ package overload;
 use strict;
 no strict 'refs';
 
-our $VERSION = '1.39';
+our $VERSION = '1.40';
 
 our %ops = (
     with_assign         => "+ - * / % ** << >> x .",
@@ -376,6 +376,7 @@ hash C<%overload::ops>:
     iterators           => '<>',
     filetest            => '-X',
     dereferencing       => '${} @{} %{} &{} *{}',
+    matching            => '~~',
     special             => 'nomethod fallback =',
 
 Most of the overloadable operators map one-to-one to these keys.
@@ -519,6 +520,37 @@ result of the last C<stat>, C<lstat> or unoverloaded filetest.
 
 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 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>
 
     ${}  @{}  %{}  &{}  *{}
@@ -647,6 +679,7 @@ expects.  The minimal set is:
     & | ^ ~ &. |. ^. ~.
     atan2 cos sin exp log sqrt int
     "" 0+ bool
+    ~~
 
 Of the conversions, only one of string, boolean or numeric is
 needed because each can be generated from either of the other two.
@@ -849,7 +882,8 @@ skipped.
 
 There are exceptions to the above rules for dereference operations
 (which, if Step 1 fails, always fall back to the normal, built-in
-implementations - see Dereferencing) under L</Overloadable Operations>
+implementations - see Dereferencing), and for C<~~> (which has its
+own set of rules - see C<Matching> under L</Overloadable Operations>
 above).
 
 Note on Step 7: some operators have a different semantic depending

lib/overload.pm

@@ -71,7 +71,7 @@ package main;
 
 $| = 1;
 BEGIN { require './test.pl'; require './charset_tools.pl' }
-plan tests => 5309;
+plan tests => 5367;
 
 use Scalar::Util qw(tainted);
 
@@ -1857,6 +1857,10 @@ foreach my $op (qw(<=> == != < <= > >=)) {
 	push @tests, [ chr 256, 'chr(256) =~ (%s)', '(qr)', '("")',
 	                                                  [ 1, 2, 0 ], 0 ];
 
+	$e = '"abc" ~~ (%s)';
+	$subs{'~~'} = $e;
+	push @tests, [ "abc", $e, '(~~)', '(NM:~~)', [ 1, 1, 0 ], 0 ];
+
 	$subs{'-X'} = 'do { my $f = (%s);'
 		    . '$_[1] eq "r" ? (-r ($f)) :'
 		    . '$_[1] eq "e" ? (-e ($f)) :'
@@ -3225,3 +3229,28 @@ package RT33789 {
     ::is($destroy, 1, "RT #133789: delayed destroy");
 }
 
+# GH #21477: with an overloaded object $obj, ($obj ~~ $scalar) wasn't
+# popping the original args off the stack. So in list context, rather than
+# returning (Y/N), it was returning ($obj, $scalar, Y/N)
+
+
+package GH21477 {
+    use overload
+        '""'  => sub { $_[0][0]; },
+        '~~'  => sub { $_[0][0] eq $_[1] },
+        'eq'  => sub { $_[0][0] eq $_[1] },
+    ;
+
+    my $o = bless ['cat'];
+
+    # smartmatch is deprecated and will be removed in 5.042
+    no warnings 'deprecated';
+
+    my @result = ($o ~~ 'cat');
+    ::is(scalar(@result), 1, "GH #21477: return one result");
+    ::is($result[0], 1, "GH #21477: return true");
+
+    @result = ($o ~~ 'dog');
+    ::is(scalar(@result), 1, "GH #21477: return one result - part 2");
+    ::is($result[0], "", "GH #21477: return false");
+}

lib/overload.t

@@ -86,6 +86,7 @@ our @names = qw#
     (x=
     (.
     (.=
+    (~~
     (-X
     (qr
 #;
@@ -163,6 +164,7 @@ our @enums = qw#
     repeat_ass
     concat
     concat_ass
+    smart
     ftest
     regexp
 #;

lib/overload/numbers.pm

@@ -2174,6 +2174,7 @@ Perl_scalarvoid(pTHX_ OP *arg)
             /* FALLTHROUGH */
         case OP_WANTARRAY:
         case OP_GV:
+        case OP_SMARTMATCH:
         case OP_AV2ARYLEN:
         case OP_REF:
         case OP_REFGEN:
@@ -10009,6 +10010,38 @@ Perl_newLOOPEX(pTHX_ I32 type, OP *label)
     return o;
 }
 
+/* if the condition is a literal array or hash
+   (or @{ ... } etc), make a reference to it.
+ */
+STATIC OP *
+S_ref_array_or_hash(pTHX_ OP *cond)
+{
+    if (cond
+    && (cond->op_type == OP_RV2AV
+    ||  cond->op_type == OP_PADAV
+    ||  cond->op_type == OP_RV2HV
+    ||  cond->op_type == OP_PADHV))
+
+        return newUNOP(OP_REFGEN, 0, op_lvalue(cond, OP_REFGEN));
+
+    else if(cond
+    && (cond->op_type == OP_ASLICE
+    ||  cond->op_type == OP_KVASLICE
+    ||  cond->op_type == OP_HSLICE
+    ||  cond->op_type == OP_KVHSLICE)) {
+
+        /* anonlist now needs a list from this op, was previously used in
+         * scalar context */
+        cond->op_flags &= ~(OPf_WANT_SCALAR | OPf_REF);
+        cond->op_flags |= OPf_WANT_LIST;
+
+        return newANONLIST(op_lvalue(cond, OP_ANONLIST));
+    }
+
+    else
+        return cond;
+}
+
 
 /*
 =for apidoc newDEFEROP
@@ -13418,6 +13451,38 @@ Perl_ck_listiob(pTHX_ OP *o)
     return listkids(o);
 }
 
+OP *
+Perl_ck_smartmatch(pTHX_ OP *o)
+{
+    PERL_ARGS_ASSERT_CK_SMARTMATCH;
+    if (0 == (o->op_flags & OPf_SPECIAL)) {
+        OP *first  = cBINOPo->op_first;
+        OP *second = OpSIBLING(first);
+
+        /* Implicitly take a reference to an array or hash */
+
+        /* remove the original two siblings, then add back the
+         * (possibly different) first and second sibs.
+         */
+        op_sibling_splice(o, NULL, 1, NULL);
+        op_sibling_splice(o, NULL, 1, NULL);
+        first  = ref_array_or_hash(first);
+        second = ref_array_or_hash(second);
+        op_sibling_splice(o, NULL, 0, second);
+        op_sibling_splice(o, NULL, 0, first);
+
+        /* Implicitly take a reference to a regular expression */
+        if (first->op_type == OP_MATCH && !(first->op_flags & OPf_STACKED)) {
+            OpTYPE_set(first, OP_QR);
+        }
+        if (second->op_type == OP_MATCH && !(second->op_flags & OPf_STACKED)) {
+            OpTYPE_set(second, OP_QR);
+        }
+    }
+
+    return o;
+}
+
 
 static OP *
 S_maybe_targlex(pTHX_ OP *o)