eviscerate smartmatch
authorZefram <zefram@fysh.org>
Wed, 22 Nov 2017 17:23:57 +0000 (17:23 +0000)
committerZefram <zefram@fysh.org>
Wed, 22 Nov 2017 17:23:57 +0000 (17:23 +0000)
Regularise smartmatch's operand handling, by removing the implicit
enreferencement and just supplying scalar context.  Eviscerate its runtime
behaviour, by removing all the matching rules other than rhs overloading.
Overload smartmatching in the Regexp package to perform regexp matching.

There are consequential customisations to autodie, in two areas.  Firstly,
autodie::exception objects are matchers, but autodie has been advising
smartmatching with the exception on the lhs.  This has to change to the
rhs, in both documentation and tests.  Secondly, it uses smartmatching as
part of its hint mechanism.  Most of the hint examples, in documentation
and tests, have to change to subroutines, to be portable across Perl
versions.

27 files changed:
Porting/Maintainers.pl
cpan/autodie/lib/autodie/exception.pm
cpan/autodie/lib/autodie/hints.pm
cpan/autodie/t/exceptions.t
cpan/autodie/t/lib/Hints_pod_examples.pm
cpan/experimental/t/basic.t
embed.fnc
embed.h
ext/XS-APItest/t/fetch_pad_names.t
lib/overload.t
op.c
opcode.h
pod/perldiag.pod
pod/perlop.pod
pp_ctl.c
proto.h
regen/opcodes
t/lib/warnings/9uninit
t/lib/warnings/op
t/lib/warnings/utf8
t/op/smartmatch.t
t/op/switch.t
t/op/taint.t
t/op/tie_fetch_count.t
t/porting/customized.dat
t/run/switches.t
universal.c

index 116c12c..ee616af 100755 (executable)
@@ -156,8 +156,15 @@ use File::Glob qw(:case);
                 t/system.t
                 )
         ],
-        # CPAN RT 105344
-        'CUSTOMIZED'   => [ qw[ t/mkdir.t ] ],
+        'CUSTOMIZED'   => [
+           # CPAN RT 105344
+           't/mkdir.t',
+           # smartmatch changes
+           'lib/autodie/exception.pm',
+           'lib/autodie/hints.pm',
+           't/exceptions.t',
+           't/lib/Hints_pod_examples.pm',
+        ],
     },
 
     'AutoLoader' => {
@@ -409,6 +416,10 @@ use File::Glob qw(:case);
         'DISTRIBUTION' => 'LEONT/experimental-0.017.tar.gz',
         'FILES'        => q[cpan/experimental],
         'EXCLUDED'     => [qr{^xt/}],
+        'CUSTOMIZED'   => [
+           # smartmatch changes
+           't/basic.t',
+        ],
     },
 
     'Exporter' => {
index 7305808..b3fcff9 100644 (file)
@@ -4,7 +4,7 @@ use strict;
 use warnings;
 use Carp qw(croak);
 
-our $VERSION = '2.29'; # VERSION: Generated by DZP::OurPkg:Version
+our $VERSION = '2.29001';
 # ABSTRACT: Exceptions from autodying functions.
 
 our $DEBUG = 0;
@@ -195,12 +195,10 @@ sub eval_error { return $_[0]->{$PACKAGE}{eval_error}; }
 
     if ( $e->matches('open') ) { ... }
 
-    if ( $e ~~ 'open' ) { ... }
+    if ( 'open' ~~ $e ) { ... }
 
 C<matches> is used to determine whether a
-given exception matches a particular role.  On Perl 5.10,
-using smart-match (C<~~>) with an C<autodie::exception> object
-will use C<matches> underneath.
+given exception matches a particular role.
 
 An exception is considered to match a string if:
 
@@ -221,6 +219,17 @@ C<CORE::open> subroutine does C<:file>, C<:io> and C<:all>.
 
 See L<autodie/CATEGORIES> for further information.
 
+On Perl 5.10 and above, using smart-match (C<~~>) with an
+C<autodie::exception> object will use C<matches> underneath.  This module
+used to recommend using smart-match with the exception object on the left
+hand side, but in newer Perls that no longer works.  The smart-match
+facility of this class can now only be used with the exception object
+on the right hand side.  Having the exception object on the right also
+works on older Perls, back to 5.10.  Beware that this facility can only
+be relied upon when it is certain that the exception object actually is
+an C<autodie::exception> object; it is no more capable than an explicit
+call to the C<matches> method.
+
 =back
 
 =cut
index beaefcc..be9fbce 100644 (file)
@@ -5,7 +5,7 @@ use warnings;
 
 use constant PERL58 => ( $] < 5.009 );
 
-our $VERSION = '2.29'; # VERSION: Generated by DZP::OurPkg:Version
+our $VERSION = '2.29001';
 
 # ABSTRACT: Provide hints about user subroutines to autodie
 
@@ -115,8 +115,9 @@ has been checked.
 
 =head2 Example hints
 
-Hints may consist of scalars, array references, regular expressions and
-subroutine references.  You can specify different hints for how
+Hints may consist of subroutine references, objects overloading
+smart-match, regular expressions, and depending on Perl version possibly
+other things.  You can specify different hints for how
 failure should be identified in scalar and list contexts.
 
 These examples apply for use in the C<AUTODIE_HINTS> subroutine and when
@@ -125,16 +126,16 @@ calling C<autodie::hints->set_hints_for()>.
 The most common context-specific hints are:
 
         # Scalar failures always return undef:
-            {  scalar => undef  }
+            {  scalar => sub { !defined($_[0]) }  }
 
         # Scalar failures return any false value [default expectation]:
             {  scalar => sub { ! $_[0] }  }
 
         # Scalar failures always return zero explicitly:
-            {  scalar => '0'  }
+            {  scalar => sub { defined($_[0]) && $_[0] eq '0' }  }
 
         # List failures always return an empty list:
-            {  list => []  }
+            {  list => sub { !@_ }  }
 
         # List failures return () or (undef) [default expectation]:
             {  list => sub { ! @_ || @_ == 1 && !defined $_[0] }  }
@@ -151,7 +152,7 @@ The most common context-specific hints are:
             \&foo,
             {
                 scalar => qr/^ _? FAIL $/xms,
-                list   => [-1],
+                list   => sub { @_ == 1 && $_[0] eq -1 },
             }
         );
 
@@ -159,8 +160,8 @@ The most common context-specific hints are:
         autodie::hints->set_hints_for(
             \&foo,
             {
-                scalar => 0,
-                list   => [0],
+                scalar => sub { defined($_[0]) && $_[0] == 0 },
+                list   => sub { @_ == 1 && defined($_[0]) && $_[0] == 0 },
             }
         );
 
index 4e7545d..ab6f07d 100644 (file)
@@ -19,10 +19,10 @@ eval {
 };
 
 ok($@,                 "Exception thrown"                      );
-ok($@ ~~ 'open',       "Exception from open"                   );
-ok($@ ~~ ':file',      "Exception from open / class :file"     );
-ok($@ ~~ ':io',                "Exception from open / class :io"       );
-ok($@ ~~ ':all',       "Exception from open / class :all"      );
+ok('open' ~~ $@,       "Exception from open"                   );
+ok(':file' ~~ $@,      "Exception from open / class :file"     );
+ok(':io' ~~ $@,                "Exception from open / class :io"       );
+ok(':all' ~~ $@,       "Exception from open / class :all"      );
 
 eval {
     no warnings 'once';    # To prevent the following close from complaining.
@@ -39,10 +39,10 @@ eval {
 like($@, qr{Can't close filehandle 'THIS_FILEHANDLE_AINT_OPEN'},"Nice msg from close");
 
 ok($@,                 "Exception thrown"                      );
-ok($@ ~~ 'close',      "Exception from close"                  );
-ok($@ ~~ ':file',      "Exception from close / class :file"    );
-ok($@ ~~ ':io',                "Exception from close / class :io"      );
-ok($@ ~~ ':all',       "Exception from close / class :all"     );
+ok('close' ~~ $@,      "Exception from close"                  );
+ok(':file' ~~ $@,      "Exception from close / class :file"    );
+ok(':io' ~~ $@,                "Exception from close / class :io"      );
+ok(':all' ~~ $@,       "Exception from close / class :all"     );
 
 ok $@ eq $@.'',                 "string overloading is complete (eq)";
 ok( ($@ cmp $@.'') == 0,        "string overloading is complete (cmp)" );
index 05db908..72a58a5 100644 (file)
@@ -17,17 +17,17 @@ use autodie::hints;
 sub AUTODIE_HINTS {
     return {
         # Scalar failures always return undef:
-        undef_scalar =>    {  fail => undef  },
+        undef_scalar =>    {  fail => sub { !defined($_[0]) }  },
 
         # Scalar failures return any false value [default behaviour]:
         false_scalar =>    {  fail => sub { return ! $_[0] }  },
 
         # Scalar failures always return zero explicitly:
-        zero_scalar =>     {  fail => '0'  },
+        zero_scalar =>     {  fail => sub { defined($_[0]) && $_[0] eq '0' }  },
 
         # List failures always return empty list:
         # We never want these called in a scalar context
-        empty_list  =>     {  scalar => sub { 1 }, list => []  },
+        empty_list  =>     {  scalar => sub { 1 }, list => sub { !@_ }  },
 
         # List failures return C<()> or C<(undef)> [default expectation]:
         default_list => {  fail => sub { ! @_ || @_ == 1 && !defined $_[0] }  },
@@ -54,8 +54,8 @@ sub undef_n_error_list { return wantarray ? @_  : $_[0] }
 autodie::hints->set_hints_for(
     \&foo,
     {
-       scalar => 0,
-       list   => [0],
+       scalar => sub { defined($_[0]) && $_[0] == 0 },
+       list   => sub { @_ == 1 && defined($_[0]) && $_[0] == 0 },
     }
 );
 
@@ -67,7 +67,7 @@ autodie::hints->set_hints_for(
     \&re_fail,
     {
        scalar => qr/^ _? FAIL $/xms,
-       list   => [-1],
+       list   => sub { @_ == 1 && $_[0] eq -1 },
     }
 );
 
@@ -77,8 +77,8 @@ sub re_fail { return wantarray ? @_ : $_[0] }
 autodie::hints->set_hints_for(
     \&bar,
     {
-       scalar => 0,
-       list   => [0],
+       scalar => sub { defined($_[0]) && $_[0] == 0 },
+       list   => sub { @_ == 1 && defined($_[0]) && $_[0] == 0 },
     }
 );
 
index a270fdf..95f60db 100644 (file)
@@ -35,8 +35,8 @@ END
 if ($] >= 5.010001) {
        is (eval <<'END', 1, 'smartmatch compiles') or diag $@;
        use experimental 'smartmatch';
-       sub bar { 1 };
-       is(1 ~~ \&bar, 1, "is 1");
+       { package Bar; use overload "~~" => sub { 1 }; }
+       is(1 ~~ bless({}, "Bar"), 1, "is 1");
        1;
 END
 }
index 496a2eb..b39a5a7 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -2142,7 +2142,6 @@ sR        |OP*    |too_few_arguments_pv|NN OP *o|NN const char* name|U32 flags
 s      |OP*    |too_many_arguments_pv|NN OP *o|NN const char* name|U32 flags
 s      |OP*    |newGIVWHENOP   |NULLOK OP* cond|NN OP *block \
                                |I32 enter_opcode|I32 leave_opcode
-s      |OP*    |ref_array_or_hash|NULLOK OP* cond
 s      |bool   |process_special_blocks |I32 floor \
                                        |NN const char *const fullname\
                                        |NN GV *const gv|NN CV *const cv
@@ -2244,11 +2243,6 @@ sR       |PerlIO *|doopen_pm     |NN SV *name
 #endif
 iRn    |bool   |path_is_searchable|NN const char *name
 sR     |I32    |run_user_filter|int idx|NN SV *buf_sv|int maxlen
-sR     |PMOP*  |make_matcher   |NN REGEXP* re
-sR     |bool   |matcher_matches_sv|NN PMOP* matcher|NN SV* sv
-s      |void   |destroy_matcher|NN PMOP* matcher
-s      |OP*    |do_smartmatch  |NULLOK HV* seen_this \
-                               |NULLOK HV* seen_other|const bool copied
 #endif
 
 #if defined(PERL_IN_PP_HOT_C)
diff --git a/embed.h b/embed.h
index edadfc0..f726f97 100644 (file)
--- a/embed.h
+++ b/embed.h
 #define ck_sassign(a)          Perl_ck_sassign(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)
 #define optimize_op(a)         S_optimize_op(aTHX_ a)
 #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)
 #  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)
 #define dopoptoloop(a)         S_dopoptoloop(aTHX_ a)
 #define dopoptosub_at(a,b)     S_dopoptosub_at(aTHX_ a,b)
 #define dopoptowhen(a)         S_dopoptowhen(aTHX_ a)
-#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)
index bdff1a8..7670e9b 100644 (file)
@@ -321,11 +321,10 @@ sub general_tests {
        $tests->{pad_size}{invariant}{msg};
 
     for my $var (@{$tests->{vars}}) {
-        no warnings 'experimental::smartmatch';
         if ($var->{type} eq 'ok') {
-            ok $var->{name} ~~ $names_av, $var->{msg};
+            ok +(grep { $_ eq $var->{name} } @$names_av), $var->{msg};
         } else {
-            ok !($var->{name} ~~ $names_av), $var->{msg};
+            ok !(grep { $_ eq $var->{name} } @$names_av), $var->{msg};
         }
     }
 
index 46b193b..077a796 100644 (file)
@@ -48,7 +48,7 @@ package main;
 
 $| = 1;
 BEGIN { require './test.pl'; require './charset_tools.pl' }
-plan tests => 5331;
+plan tests => 5385;
 
 use Scalar::Util qw(tainted);
 
@@ -1622,6 +1622,11 @@ 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
 
 {
@@ -1835,7 +1840,10 @@ foreach my $op (qw(<=> == != < <= > >=)) {
 
        $e = '"abc" ~~ (%s)';
        $subs{'~~'} = $e;
-       push @tests, [ "abc", $e, '(~~)', '(NM:~~)', [ 1, 1, 0 ], 0 ];
+       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 ];
 
        $subs{'-X'} = 'do { my $f = (%s);'
                    . '$_[1] eq "r" ? (-r ($f)) :'
diff --git a/op.c b/op.c
index 73b5bb8..6318f42 100644 (file)
--- a/op.c
+++ b/op.c
@@ -8766,38 +8766,6 @@ 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;
-}
-
 /* These construct the optree fragments representing given()
    and when() blocks.
 
@@ -11588,40 +11556,6 @@ Perl_ck_listiob(pTHX_ OP *o)
     return listkids(o);
 }
 
-OP *
-Perl_ck_smartmatch(pTHX_ OP *o)
-{
-    dVAR;
-    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)
 {
index b5ed37f..e1ba36b 100644 (file)
--- a/opcode.h
+++ b/opcode.h
@@ -1488,7 +1488,7 @@ EXT Perl_check_t PL_check[] /* or perlvars.h */
        Perl_ck_bitop,          /* complement */
        Perl_ck_bitop,          /* ncomplement */
        Perl_ck_bitop,          /* scomplement */
-       Perl_ck_smartmatch,     /* smartmatch */
+       Perl_ck_null,           /* smartmatch */
        Perl_ck_fun,            /* atan2 */
        Perl_ck_fun,            /* sin */
        Perl_ck_fun,            /* cos */
@@ -1897,7 +1897,7 @@ EXTCONST U32 PL_opargs[] = {
        0x0000110e,     /* complement */
        0x0000111e,     /* ncomplement */
        0x0000111e,     /* scomplement */
-       0x00000204,     /* smartmatch */
+       0x00011206,     /* smartmatch */
        0x0001141e,     /* atan2 */
        0x00009b9e,     /* sin */
        0x00009b9e,     /* cos */
index 2565ee6..efc1c3f 100644 (file)
@@ -726,6 +726,13 @@ which makes no sense.  Maybe you meant '%s', or just stringifying it?
 (F) C<caller> tried to set C<@DB::args>, but found it tied.  Tying C<@DB::args>
 is not supported.  (Before this error was added, it used to crash.)
 
+=item Cannot smart match without a matcher object
+
+(F) You tried to perform a smart match (C<~~>), but the right hand operand
+was not an object overloading the smart match operation.  Such a matcher
+object is required, in order to determine what kind of matching operation
+to apply to the left hand operand.
+
 =item Cannot tie unreifiable array
 
 (P) You somehow managed to call C<tie> on an array that does not
@@ -5665,20 +5672,12 @@ requested.
 hash) parameter.  The slurpy parameter takes all the available arguments,
 so there can't be any left to fill later parameters.
 
-=item Smart matching a non-overloaded object breaks encapsulation
-
-(F) You should not use the C<~~> operator on an object that does not
-overload it: Perl refuses to use the object's underlying structure
-for the smart match.
-
 =item Smartmatch is experimental
 
 (S experimental::smartmatch) This warning is emitted if you
 use the smartmatch (C<~~>) operator.  This is currently an experimental
 feature, and its details are subject to change in future releases of
-Perl.  Particularly, its current behavior is noticed for being
-unnecessarily complex and unintuitive, and is very likely to be
-overhauled.
+Perl.
 
 =item Sorry, hash keys must be smaller than 2**31 bytes
 
index b060839..17e6060 100644 (file)
@@ -551,283 +551,24 @@ function, available in Perl v5.16 or later:
 
 =head2 Smartmatch Operator
 
-First available in Perl 5.10.1 (the 5.10.0 version behaved differently),
-binary C<~~> does a "smartmatch" between its arguments.  Unique among all of
-Perl's operators, the smartmatch operator can recurse.  The smartmatch
+Binary C<~~> does a "smartmatch" between its arguments.  The smartmatch
 operator is L<experimental|perlpolicy/experimental> and its behavior is
-subject to change.
-
-It is also unique in that all other Perl operators impose a context
-(usually string or numeric context) on their operands, autoconverting
-those operands to those imposed contexts.  In contrast, smartmatch
-I<infers> contexts from the actual types of its operands and uses that
-type information to select a suitable comparison mechanism.
-
-The C<~~> operator compares its operands "polymorphically", determining how
-to compare them according to their actual types (numeric, string, array,
-hash, etc.)  Like the equality operators with which it shares the same
-precedence, C<~~> returns 1 for true and C<""> for false.  It is often best
-read aloud as "in", "inside of", or "is contained in", because the left
-operand is often looked for I<inside> the right operand.  That makes the
-order of the operands to the smartmatch operand often opposite that of
-the regular match operator.  In other words, the "smaller" thing is usually
-placed in the left operand and the larger one in the right.
-
-The behavior of a smartmatch depends on what type of things its arguments
-are, as determined by the following table.  The first row of the table
-whose types apply determines the smartmatch behavior.  Because what
-actually happens is mostly determined by the type of the second operand,
-the table is sorted on the right operand instead of on the left.
-
- Left      Right      Description and pseudocode
- ===============================================================
- Any       undef      check whether Any is undefined
-                like: !defined Any
-
- Any       Object     invoke ~~ overloading on Object, or die
-
- Right operand is an ARRAY:
-
- Left      Right      Description and pseudocode
- ===============================================================
- ARRAY1    ARRAY2     recurse on paired elements of ARRAY1 and ARRAY2[2]
-                like: (ARRAY1[0] ~~ ARRAY2[0])
-                        && (ARRAY1[1] ~~ ARRAY2[1]) && ...
- HASH      ARRAY      any ARRAY elements exist as HASH keys
-                like: grep { exists HASH->{$_} } ARRAY
- Regexp    ARRAY      any ARRAY elements pattern match Regexp
-                like: grep { /Regexp/ } ARRAY
- undef     ARRAY      undef in ARRAY
-                like: grep { !defined } ARRAY
- Any       ARRAY      smartmatch each ARRAY element[3]
-                like: grep { Any ~~ $_ } ARRAY
-
- Right operand is a HASH:
-
- Left      Right      Description and pseudocode
- ===============================================================
- HASH1     HASH2      all same keys in both HASHes
-                like: keys HASH1 ==
-                         grep { exists HASH2->{$_} } keys HASH1
- ARRAY     HASH       any ARRAY elements exist as HASH keys
-                like: grep { exists HASH->{$_} } ARRAY
- Regexp    HASH       any HASH keys pattern match Regexp
-                like: grep { /Regexp/ } keys HASH
- undef     HASH       always false (undef can't be a key)
-                like: 0 == 1
- Any       HASH       HASH key existence
-                like: exists HASH->{Any}
-
- Right operand is CODE:
-
- Left      Right      Description and pseudocode
- ===============================================================
- ARRAY     CODE       sub returns true on all ARRAY elements[1]
-                like: !grep { !CODE->($_) } ARRAY
- HASH      CODE       sub returns true on all HASH keys[1]
-                like: !grep { !CODE->($_) } keys HASH
- Any       CODE       sub passed Any returns true
-                like: CODE->(Any)
-
-Right operand is a Regexp:
-
- Left      Right      Description and pseudocode
- ===============================================================
- ARRAY     Regexp     any ARRAY elements match Regexp
-                like: grep { /Regexp/ } ARRAY
- HASH      Regexp     any HASH keys match Regexp
-                like: grep { /Regexp/ } keys HASH
- Any       Regexp     pattern match
-                like: Any =~ /Regexp/
-
- Other:
-
- Left      Right      Description and pseudocode
- ===============================================================
- Object    Any        invoke ~~ overloading on Object,
-                      or fall back to...
-
- Any       Num        numeric equality
-                 like: Any == Num
- Num       nummy[4]    numeric equality
-                 like: Num == nummy
- undef     Any        check whether undefined
-                 like: !defined(Any)
- Any       Any        string equality
-                 like: Any eq Any
-
-
-Notes:
-
-=over
-
-=item 1.
-Empty hashes or arrays match.
-
-=item 2.
-That is, each element smartmatches the element of the same index in the other array.[3]
-
-=item 3.
-If a circular reference is found, fall back to referential equality.
-
-=item 4.
-Either an actual number, or a string that looks like one.
-
-=back
-
-The smartmatch implicitly dereferences any non-blessed hash or array
-reference, so the C<I<HASH>> and C<I<ARRAY>> entries apply in those cases.
-For blessed references, the C<I<Object>> entries apply.  Smartmatches
-involving hashes only consider hash keys, never hash values.
-
-The "like" code entry is not always an exact rendition.  For example, the
-smartmatch operator short-circuits whenever possible, but C<grep> does
-not.  Also, C<grep> in scalar context returns the number of matches, but
-C<~~> returns only true or false.
-
-Unlike most operators, the smartmatch operator knows to treat C<undef>
-specially:
-
-    use v5.10.1;
-    @array = (1, 2, 3, undef, 4, 5);
-    say "some elements undefined" if undef ~~ @array;
-
-Each operand is considered in a modified scalar context, the modification
-being that array and hash variables are passed by reference to the
-operator, which implicitly dereferences them.  Both elements
-of each pair are the same:
-
-    use v5.10.1;
-
-    my %hash = (red    => 1, blue   => 2, green  => 3,
-                orange => 4, yellow => 5, purple => 6,
-                black  => 7, grey   => 8, white  => 9);
-
-    my @array = qw(red blue green);
-
-    say "some array elements in hash keys" if  @array ~~  %hash;
-    say "some array elements in hash keys" if \@array ~~ \%hash;
-
-    say "red in array" if "red" ~~  @array;
-    say "red in array" if "red" ~~ \@array;
-
-    say "some keys end in e" if /e$/ ~~  %hash;
-    say "some keys end in e" if /e$/ ~~ \%hash;
-
-Two arrays smartmatch if each element in the first array smartmatches
-(that is, is "in") the corresponding element in the second array,
-recursively.
-
-    use v5.10.1;
-    my @little = qw(red blue green);
-    my @bigger = ("red", "blue", [ "orange", "green" ] );
-    if (@little ~~ @bigger) {  # true!
-        say "little is contained in bigger";
-    }
-
-Because the smartmatch operator recurses on nested arrays, this
-will still report that "red" is in the array.
-
-    use v5.10.1;
-    my @array = qw(red blue green);
-    my $nested_array = [[[[[[[ @array ]]]]]]];
-    say "red in array" if "red" ~~ $nested_array;
-
-If two arrays smartmatch each other, then they are deep
-copies of each others' values, as this example reports:
-
-    use v5.12.0;
-    my @a = (0, 1, 2, [3, [4, 5], 6], 7);
-    my @b = (0, 1, 2, [3, [4, 5], 6], 7);
-
-    if (@a ~~ @b && @b ~~ @a) {
-        say "a and b are deep copies of each other";
-    }
-    elsif (@a ~~ @b) {
-        say "a smartmatches in b";
-    }
-    elsif (@b ~~ @a) {
-        say "b smartmatches in a";
-    }
-    else {
-        say "a and b don't smartmatch each other at all";
-    }
-
-
-If you were to set S<C<$b[3] = 4>>, then instead of reporting that "a and b
-are deep copies of each other", it now reports that C<"b smartmatches in a">.
-That's because the corresponding position in C<@a> contains an array that
-(eventually) has a 4 in it.
-
-Smartmatching one hash against another reports whether both contain the
-same keys, no more and no less.  This could be used to see whether two
-records have the same field names, without caring what values those fields
-might have.  For example:
-
-    use v5.10.1;
-    sub make_dogtag {
-        state $REQUIRED_FIELDS = { name=>1, rank=>1, serial_num=>1 };
-
-        my ($class, $init_fields) = @_;
-
-        die "Must supply (only) name, rank, and serial number"
-            unless $init_fields ~~ $REQUIRED_FIELDS;
-
-        ...
-    }
-
-However, this only does what you mean if C<$init_fields> is indeed a hash
-reference. The condition C<$init_fields ~~ $REQUIRED_FIELDS> also allows the
-strings C<"name">, C<"rank">, C<"serial_num"> as well as any array reference
-that contains C<"name"> or C<"rank"> or C<"serial_num"> anywhere to pass
-through.
-
-=head3 Smartmatching of Objects
-
-To avoid relying on an object's underlying representation, if the
-smartmatch's right operand is an object that doesn't overload C<~~>,
-it raises the exception "C<Smartmatching a non-overloaded object
-breaks encapsulation>".  That's because one has no business digging
-around to see whether something is "in" an object.  These are all
-illegal on objects without a C<~~> overload:
-
-    %hash ~~ $object
-       42 ~~ $object
-   "fred" ~~ $object
-
-However, you can change the way an object is smartmatched by overloading
-the C<~~> operator.  This is allowed to
-extend the usual smartmatch semantics.
-For objects that do have an C<~~> overload, see L<overload>.
-
-Using an object as the left operand is allowed, although not very useful.
-Smartmatching rules take precedence over overloading, so even if the
-object in the left operand has smartmatch overloading, this will be
-ignored.  A left operand that is a non-overloaded object falls back on a
-string or numeric comparison of whatever the C<ref> operator returns.  That
-means that
-
-    $object ~~ X
-
-does I<not> invoke the overload method with C<I<X>> as an argument.
-Instead the above table is consulted as normal, and based on the type of
-C<I<X>>, overloading may or may not be invoked.  For simple strings or
-numbers, "in" becomes equivalent to this:
-
-    $object ~~ $number          ref($object) == $number
-    $object ~~ $string          ref($object) eq $string
-
-For example, this reports that the handle smells IOish
-(but please don't really do this!):
-
-    use IO::Handle;
-    my $fh = IO::Handle->new();
-    if ($fh ~~ /\bIO\b/) {
-        say "handle smells IOish";
-    }
-
-That's because it treats C<$fh> as a string like
-C<"IO::Handle=GLOB(0x8039e0)">, then pattern matches against that.
+subject to change.  It first became available in Perl 5.10, but prior
+to Perl 5.28 its behaviour was quite different from its present behaviour.
+
+The C<~~> operator applies some kind of matching criterion to its
+left-hand operand, and returns a truth value result.  The criterion to
+apply is determined by the right-hand operand, which must be a reference
+to an object blessed into a class that overloads the C<~~> operator for
+this purpose.  The class into which compiled regexp objects are blessed
+by the C<qr//> operator has such an overloading, which checks whether
+the left-hand operand matches the regexp.  If the right-hand operand is
+not a reference to such a matcher object, an exception is raised.
+
+Overloading of C<~~> only applies when the object reference is the
+right-hand operand.  An object reference as the left-hand operand is
+subjected to whatever criterion is specified by the right-hand operand,
+regardless of its own overloading.
 
 =head2 Bitwise And
 X<operator, bitwise, and> X<bitwise and> X<&>
index 4026d4d..e4a9ad9 100644 (file)
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -4630,538 +4630,25 @@ 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;
-    
-    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"));
-    }
+    SV *right = POPs;
+    SV *left = TOPs;
+    SV *result;
 
-    SP -= 2;   /* Pop the values */
     PUTBACK;
-
-    /* ~~ 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);
+    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))) {
        SPAGAIN;
-       if (SvTRUEx(POPs))
-           RETPUSHYES;
-       else
-           RETPUSHNO;
+       SETs(result);
+       return NORMAL;
     }
-    
-    /* 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);
+    Perl_croak(aTHX_ "Cannot smart match without a matcher object");
 }
 
 PP(pp_enterwhen)
diff --git a/proto.h b/proto.h
index c3ed9dd..bd9e2d8 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -498,11 +498,6 @@ PERL_CALLCONV OP * Perl_ck_shift(pTHX_ OP *o)
 #define PERL_ARGS_ASSERT_CK_SHIFT      \
        assert(o)
 
-PERL_CALLCONV OP *     Perl_ck_smartmatch(pTHX_ OP *o)
-                       __attribute__warn_unused_result__;
-#define PERL_ARGS_ASSERT_CK_SMARTMATCH \
-       assert(o)
-
 PERL_CALLCONV OP *     Perl_ck_sort(pTHX_ OP *o)
                        __attribute__warn_unused_result__;
 #define PERL_ARGS_ASSERT_CK_SORT       \
@@ -4782,7 +4777,6 @@ STATIC OP*        S_pmtrans(pTHX_ OP* o, OP* expr, OP* repl);
 STATIC bool    S_process_special_blocks(pTHX_ I32 floor, const char *const fullname, GV *const gv, CV *const cv);
 #define PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS        \
        assert(fullname); assert(gv); assert(cv)
-STATIC OP*     S_ref_array_or_hash(pTHX_ OP* cond);
 STATIC OP*     S_refkids(pTHX_ OP* o, I32 type);
 STATIC bool    S_scalar_mod_type(const OP *o, I32 type)
                        __attribute__warn_unused_result__;
@@ -4897,10 +4891,6 @@ STATIC PerlIO *  S_check_type_and_open(pTHX_ SV *name)
 #define PERL_ARGS_ASSERT_CHECK_TYPE_AND_OPEN   \
        assert(name)
 
-STATIC void    S_destroy_matcher(pTHX_ PMOP* matcher);
-#define PERL_ARGS_ASSERT_DESTROY_MATCHER       \
-       assert(matcher)
-STATIC OP*     S_do_smartmatch(pTHX_ HV* seen_this, HV* seen_other, const bool copied);
 STATIC OP*     S_docatch(pTHX_ Perl_ppaddr_t firstpp)
                        __attribute__warn_unused_result__;
 
@@ -4935,16 +4925,6 @@ STATIC I32       S_dopoptosub_at(pTHX_ const PERL_CONTEXT* cxstk, I32 startingblock)
 STATIC I32     S_dopoptowhen(pTHX_ I32 startingblock)
                        __attribute__warn_unused_result__;
 
-STATIC PMOP*   S_make_matcher(pTHX_ REGEXP* re)
-                       __attribute__warn_unused_result__;
-#define PERL_ARGS_ASSERT_MAKE_MATCHER  \
-       assert(re)
-
-STATIC bool    S_matcher_matches_sv(pTHX_ PMOP* matcher, SV* sv)
-                       __attribute__warn_unused_result__;
-#define PERL_ARGS_ASSERT_MATCHER_MATCHES_SV    \
-       assert(matcher); assert(sv)
-
 STATIC bool    S_num_overflow(NV value, I32 fldsize, I32 frcsize)
                        __attribute__warn_unused_result__;
 
index 5aa8a94..18dc4fc 100644 (file)
@@ -179,7 +179,7 @@ ncomplement numeric 1's complement (~)      ck_bitop        fsT1    S
 # warning is gone, this can change to ck_null.
 scomplement    string 1's complement (~)       ck_bitop        fsT1    S
 
-smartmatch     smart match             ck_smartmatch   s2
+smartmatch     smart match             ck_null         ifs2    S S
 
 # High falutin' math.
 
index 774c6ee..3963d66 100644 (file)
@@ -1943,13 +1943,6 @@ $v = 1 + prototype $fn;
 EXPECT
 Use of uninitialized value in addition (+) at - line 4.
 ########
-use warnings 'uninitialized'; no warnings 'experimental::smartmatch';
-my $v;
-my $fn = sub {};
-$v = 1 + (1 ~~ $fn);
-EXPECT
-Use of uninitialized value in addition (+) at - line 4.
-########
 use warnings 'uninitialized';
 my $v;
 my $f = "";
index bb68402..30931b6 100644 (file)
@@ -414,7 +414,7 @@ eval { getgrgid 1 };        # OP_GGRGID
 eval { getpwnam 1 };   # OP_GPWNAM
 eval { getpwuid 1 };   # OP_GPWUID
 prototype "foo";       # OP_PROTOTYPE
-$a ~~ $b;              # OP_SMARTMATCH
+$a ~~ $b if rand(1)>2; # OP_SMARTMATCH
 $a <=> $b;             # OP_NCMP
 "dsatrewq";
 "diatrewq";
index a9a6388..2ac8ac9 100644 (file)
@@ -779,7 +779,6 @@ BEGIN{
 }
 no warnings;
 use warnings 'utf8';
-for(uc 0..t){0~~pack"UXc",exp}
+pack("UXc",168) eq "\xaa";
 EXPECT
-OPTIONS regex
-Malformed UTF-8 character: \\x([[:xdigit:]]{2})\\x([[:xdigit:]]{2}) \(unexpected non-continuation byte 0x\2, immediately after start byte 0x\1; need 2 bytes, got 1\)  in smart match at - line 9.
+Malformed UTF-8 character: \xc2\x00 (unexpected non-continuation byte 0x00, immediately after start byte 0xc2; need 2 bytes, got 1)  in string eq at - line 9.
index 10d3539..40867e3 100644 (file)
@@ -7,586 +7,65 @@ BEGIN {
 }
 use strict;
 use warnings;
-no warnings 'uninitialized';
-no warnings 'experimental::smartmatch';
-
-++$|;
-
-use Tie::Array;
-use Tie::Hash;
-
-# Predeclare vars used in the tests:
-my @empty;
-my %empty;
-my @sparse; $sparse[2] = 2;
-
-my $deep1 = []; push @$deep1, $deep1;
-my $deep2 = []; push @$deep2, $deep2;
-
-my @nums = (1..10);
-tie my @tied_nums, 'Tie::StdArray';
-@tied_nums =  (1..10);
-
-my %hash = (foo => 17, bar => 23);
-tie my %tied_hash, 'Tie::StdHash';
-%tied_hash = %hash;
-
-{
-    package Test::Object::NoOverload;
-    sub new { bless { key => 1 } }
-}
-
-{
-    package Test::Object::StringOverload;
-    use overload '""' => sub { "object" }, fallback => 1;
-    sub new { bless { key => 1 } }
-}
-
-{
-    package Test::Object::WithOverload;
-    sub new { bless { key => ($_[1] // 'magic') } }
-    use overload '~~' => sub {
-       my %hash = %{ $_[0] };
-       if ($_[2]) { # arguments reversed ?
-           return $_[1] eq reverse $hash{key};
-       }
-       else {
-           return $_[1] eq $hash{key};
-       }
-    };
-    use overload '""' => sub { "stringified" };
-    use overload 'eq' => sub {"$_[0]" eq "$_[1]"};
-}
-
-our $ov_obj = Test::Object::WithOverload->new;
-our $ov_obj_2 = Test::Object::WithOverload->new("object");
-our $obj = Test::Object::NoOverload->new;
-our $str_obj = Test::Object::StringOverload->new;
-
-my %refh;
-unless (is_miniperl()) {
-    require Tie::RefHash;
-    tie %refh, 'Tie::RefHash';
-    $refh{$ov_obj} = 1;
-}
-
-my @keyandmore = qw(key and more);
-my @fooormore = qw(foo or more);
-my %keyandmore = map { $_ => 0 } @keyandmore;
-my %fooormore = map { $_ => 0 } @fooormore;
-
-# Load and run the tests
-plan tests => 349+4;
-
-while (<DATA>) {
-  SKIP: {
-    next if /^#/ || !/\S/;
-    chomp;
-    my ($yn, $left, $right, $note) = split /\t+/;
-
-    local $::TODO = $note =~ /TODO/;
-
-    die "Bad test spec: ($yn, $left, $right)" if $yn =~ /[^!@=]/;
-
-    my $tstr = "$left ~~ $right";
-
-    test_again:
-    my $res;
-    if ($note =~ /NOWARNINGS/) {
-       $res = eval "no warnings; $tstr";
-    }
-    else {
-       skip_if_miniperl("Doesn't work with miniperl", $yn =~ /=/ ? 2 : 1)
-           if $note =~ /MINISKIP/;
-       $res = eval $tstr;
-    }
-
-    chomp $@;
-
-    if ( $yn =~ /@/ ) {
-       ok( $@ ne '', "$tstr dies" )
-           and print "# \$\@ was: $@\n";
-    } else {
-       my $test_name = $tstr . ($yn =~ /!/ ? " does not match" : " matches");
-       if ( $@ ne '' ) {
-           fail($test_name);
-           print "# \$\@ was: $@\n";
-       } else {
-           ok( ($yn =~ /!/ xor $res), $test_name );
-       }
-    }
-
-    if ( $yn =~ s/=// ) {
-       $tstr = "$right ~~ $left";
-       goto test_again;
-    }
-  }
-}
-
-sub foo {}
-sub bar {42}
-sub gorch {42}
-sub fatal {die "fatal sub\n"}
-
-# to test constant folding
-sub FALSE() { 0 }
-sub TRUE() { 1 }
-sub NOT_DEF() { undef }
-
-{
-  # [perl #123860]
-  # this can but might not crash
-  # This can but might not crash
-  #
-  # The second smartmatch would leave a &PL_sv_no on the stack for
-  # each key it checked in %!, this could then cause various types of
-  # crash or assertion failure.
-  #
-  # This isn't guaranteed to crash, but if the stack issue is
-  # re-introduced it will probably crash in one of the many smoke
-  # builds.
-  fresh_perl_is('print (q(x) ~~ q(x)) | (/x/ ~~ %!)', "1",
-               { switches => [ "-MErrno", "-M-warnings=experimental::smartmatch" ] },
-                "don't fill the stack with rubbish");
-}
-
-{
-    # [perl #123860] continued;
-    # smartmatch was failing to SPAGAIN after pushing an SV and calling
-    # pp_match, which may have resulted in the stack being realloced
-    # in the meantime. Test this by filling the stack with pregressively
-    # larger amounts of data. At some point the stack will get realloced.
-    my @a = qw(x);
-    my %h = qw(x 1);
-    my @args;
-    my $x = 1;
-    my $bad = -1;
-    for (1..1000)  {
-        push @args, $_;
-        my $exp_n  = join '-',  (@args, $x == 0);
-        my $exp_y  = join '-',  (@args, $x == 1);
-
-        my $got_an = join '-',  (@args, (/X/ ~~ @a));
-        my $got_ay = join '-',  (@args, (/x/ ~~ @a));
-        my $got_hn = join '-',  (@args, (/X/ ~~ %h));
-        my $got_hy = join '-',  (@args, (/x/ ~~ %h));
-
-        if (   $exp_n ne $got_an || $exp_n ne $got_hn
-            || $exp_y ne $got_ay || $exp_y ne $got_hy
-        ) {
-            $bad = $_;
-            last;
-        }
+no warnings qw(uninitialized experimental::smartmatch);
+
+my @notov = (
+    undef,
+    0,
+    1,
+    "",
+    "abc",
+    *foo,
+    ${qr/./},
+    \undef,
+    \0,
+    \1,
+    \"",
+    \"abc",
+    \*foo,
+    [],
+    {},
+    sub { 1 },
+    \*STDIN,
+    bless({}, "NotOverloaded"),
+);
+
+package MatchAbc { use overload "~~" => sub { $_[1] eq "abc" }, fallback => 1; }
+my $matchabc = bless({}, "MatchAbc");
+my $regexpabc = qr/\Aabc\z/;
+
+plan tests => (2+@notov)*@notov + 4*(2+@notov) + 7;
+
+foreach my $matcher (@notov) {
+    foreach my $matchee ($matchabc, $regexpabc, @notov) {
+       my $res = eval { $matchee ~~ $matcher };
+       like $@, qr/\ACannot smart match without a matcher object /;
     }
-    is($bad, -1, "RT 123860: stack realloc");
 }
-
-
-{
-    # [perl #130705]
-    # Perl_ck_smartmatch would turn the match in:
-    # 0 =~ qr/1/ ~~ 0  # parsed as (0 =~ qr/1/) ~~ 0
-    # into a qr, leaving the initial 0 on the stack after execution
-    #
-    # Similarly for: 0 ~~ (0 =~ qr/1/)
-    #
-    # Either caused an assertion failure in the context of warn (or print)
-    # if there was some other operator's arguments left on the stack, as with
-    # the test cases.
-    fresh_perl_is('print(0->[0 =~ qr/1/ ~~ 0])', '',
-                  { switches => [ "-M-warnings=experimental::smartmatch" ] },
-                  "don't qr-ify left-side match against a stacked argument");
-    fresh_perl_is('print(0->[0 ~~ (0 =~ qr/1/)])', '',
-                  { switches => [ "-M-warnings=experimental::smartmatch" ] },
-                  "don't qr-ify right-side match against a stacked argument");
+foreach my $matchee ($matchabc, $regexpabc, @notov) {
+    my $res = eval { $matchee ~~ $matchabc };
+    is $@, "";
+    is $res, $matchee eq "abc";
+    $res = eval { $matchee ~~ $regexpabc };
+    is $@, "";
+    is $res, $matchee eq "abc";
 }
 
-# Prefix character :
-#   - expected to match
-# ! - expected to not match
-# @ - expected to be a compilation failure
-# = - expected to match symmetrically (runs test twice)
-# Data types to test :
-#   undef
-#   Object-overloaded
-#   Object
-#   Coderef
-#   Hash
-#   Hashref
-#   Array
-#   Arrayref
-#   Tied arrays and hashes
-#   Arrays that reference themselves
-#   Regex (// and qr//)
-#   Range
-#   Num
-#   Str
-# Other syntactic items of interest:
-#   Constants
-#   Values returned by a sub call
-__DATA__
-# Any ~~ undef
-!      $ov_obj         undef
-!      $obj            undef
-!      sub {}          undef
-!      %hash           undef
-!      \%hash          undef
-!      {}              undef
-!      @nums           undef
-!      \@nums          undef
-!      []              undef
-!      %tied_hash      undef
-!      @tied_nums      undef
-!      $deep1          undef
-!      /foo/           undef
-!      qr/foo/         undef
-!      21..30          undef
-!      189             undef
-!      "foo"           undef
-!      ""              undef
-!      !1              undef
-       undef           undef
-       (my $u)         undef
-       NOT_DEF         undef
-       &NOT_DEF        undef
-
-# Any ~~ object overloaded
-!      \&fatal         $ov_obj
-       'cigam'         $ov_obj
-!      'cigam on'      $ov_obj
-!      ['cigam']       $ov_obj
-!      ['stringified'] $ov_obj
-!      { cigam => 1 }  $ov_obj
-!      { stringified => 1 }    $ov_obj
-!      $obj            $ov_obj
-!      undef           $ov_obj
-
-# regular object
-@      $obj            $obj
-@      $ov_obj         $obj
-=@     \&fatal         $obj
-@      \&FALSE         $obj
-@      \&foo           $obj
-@      sub { 1 }       $obj
-@      sub { 0 }       $obj
-@      %keyandmore     $obj
-@      {"key" => 1}    $obj
-@      @fooormore      $obj
-@      ["key" => 1]    $obj
-@      /key/           $obj
-@      qr/key/         $obj
-@      "key"           $obj
-@      FALSE           $obj
-
-# regular object with "" overload
-@      $obj            $str_obj
-=@     \&fatal         $str_obj
-@      \&FALSE         $str_obj
-@      \&foo           $str_obj
-@      sub { 1 }       $str_obj
-@      sub { 0 }       $str_obj
-@      %keyandmore     $str_obj
-@      {"object" => 1} $str_obj
-@      @fooormore      $str_obj
-@      ["object" => 1] $str_obj
-@      /object/        $str_obj
-@      qr/object/      $str_obj
-@      "object"        $str_obj
-@      FALSE           $str_obj
-# Those will treat the $str_obj as a string because of fallback:
-
-# object (overloaded or not) ~~ Any
-       $obj            qr/NoOverload/
-       $ov_obj         qr/^stringified$/
-=      "$ov_obj"       "stringified"
-=      "$str_obj"      "object"
-!=     $ov_obj         "stringified"
-       $str_obj        "object"
-       $ov_obj         'magic'
-!      $ov_obj         'not magic'
-
-# ~~ Coderef
-       sub{0}          sub { ref $_[0] eq "CODE" }
-       %fooormore      sub { $_[0] =~ /^(foo|or|more)$/ }
-!      %fooormore      sub { $_[0] =~ /^(foo|or|less)$/ }
-       \%fooormore     sub { $_[0] =~ /^(foo|or|more)$/ }
-!      \%fooormore     sub { $_[0] =~ /^(foo|or|less)$/ }
-       +{%fooormore}   sub { $_[0] =~ /^(foo|or|more)$/ }
-!      +{%fooormore}   sub { $_[0] =~ /^(foo|or|less)$/ }
-       @fooormore      sub { $_[0] =~ /^(foo|or|more)$/ }
-!      @fooormore      sub { $_[0] =~ /^(foo|or|less)$/ }
-       \@fooormore     sub { $_[0] =~ /^(foo|or|more)$/ }
-!      \@fooormore     sub { $_[0] =~ /^(foo|or|less)$/ }
-       [@fooormore]    sub { $_[0] =~ /^(foo|or|more)$/ }
-!      [@fooormore]    sub { $_[0] =~ /^(foo|or|less)$/ }
-       %fooormore      sub{@_==1}
-       @fooormore      sub{@_==1}
-       "foo"           sub { $_[0] =~ /^(foo|or|more)$/ }
-!      "more"          sub { $_[0] =~ /^(foo|or|less)$/ }
-       /fooormore/     sub{ref $_[0] eq 'Regexp'}
-       qr/fooormore/   sub{ref $_[0] eq 'Regexp'}
-       1               sub{shift}
-!      0               sub{shift}
-!      undef           sub{shift}
-       undef           sub{not shift}
-       NOT_DEF         sub{not shift}
-       &NOT_DEF        sub{not shift}
-       FALSE           sub{not shift}
-       [1]             \&bar
-       {a=>1}          \&bar
-       qr//            \&bar
-!      [1]             \&foo
-!      {a=>1}          \&foo
-       $obj            sub { ref($_[0]) =~ /NoOverload/ }
-       $ov_obj         sub { ref($_[0]) =~ /WithOverload/ }
-# empty stuff matches, because the sub is never called:
-       []              \&foo
-       {}              \&foo
-       @empty          \&foo
-       %empty          \&foo
-!      qr//            \&foo
-!      undef           \&foo
-       undef           \&bar
-@      undef           \&fatal
-@      1               \&fatal
-@      [1]             \&fatal
-@      {a=>1}          \&fatal
-@      "foo"           \&fatal
-@      qr//            \&fatal
-# sub is not called on empty hashes / arrays
-       []              \&fatal
-       +{}             \&fatal
-       @empty          \&fatal
-       %empty          \&fatal
-# sub is not special on the left
-       sub {0}         qr/^CODE/
-       sub {0}         sub { ref shift eq "CODE" }
-
-# HASH ref against:
-#   - another hash ref
-       {}              {}
-=!     {}              {1 => 2}
-       {1 => 2}        {1 => 2}
-       {1 => 2}        {1 => 3}
-=!     {1 => 2}        {2 => 3}
-=      \%main::        {map {$_ => 'x'} keys %main::}
-
-#  - tied hash ref
-=      \%hash          \%tied_hash
-       \%tied_hash     \%tied_hash
-!=     {"a"=>"b"}      \%tied_hash
-=      %hash           %tied_hash
-       %tied_hash      %tied_hash
-!=     {"a"=>"b"}      %tied_hash
-       $ov_obj         %refh           MINISKIP
-!      "$ov_obj"       %refh           MINISKIP
-       [$ov_obj]       %refh           MINISKIP
-!      ["$ov_obj"]     %refh           MINISKIP
-       %refh           %refh           MINISKIP
-
-#  - an array ref
-#  (since this is symmetrical, tests as well hash~~array)
-=      [keys %main::]  \%::
-=      [qw[STDIN STDOUT]]      \%::
-=!     []              \%::
-=!     [""]            {}
-=!     []              {}
-=!     @empty          {}
-=      [undef]         {"" => 1}
-=      [""]            {"" => 1}
-=      ["foo"]         { foo => 1 }
-=      ["foo", "bar"]  { foo => 1 }
-=      ["foo", "bar"]  \%hash
-=      ["foo"]         \%hash
-=!     ["quux"]        \%hash
-=      [qw(foo quux)]  \%hash
-=      @fooormore      { foo => 1, or => 2, more => 3 }
-=      @fooormore      %fooormore
-=      @fooormore      \%fooormore
-=      \@fooormore     %fooormore
-
-#  - a regex
-=      qr/^(fo[ox])$/          {foo => 1}
-=      /^(fo[ox])$/            %fooormore
-=!     qr/[13579]$/            +{0..99}
-=!     qr/a*/                  {}
-=      qr/a*/                  {b=>2}
-=      qr/B/i                  {b=>2}
-=      /B/i                    {b=>2}
-=!     qr/a+/                  {b=>2}
-=      qr/^à/                 {"à"=>2}
-
-#  - a scalar
-       "foo"           +{foo => 1, bar => 2}
-       "foo"           %fooormore
-!      "baz"           +{foo => 1, bar => 2}
-!      "boz"           %fooormore
-!      1               +{foo => 1, bar => 2}
-!      1               %fooormore
-       1               { 1 => 3 }
-       1.0             { 1 => 3 }
-!      "1.0"           { 1 => 3 }
-!      "1.0"           { 1.0 => 3 }
-       "1.0"           { "1.0" => 3 }
-       "à"            { "à" => "À" }
-
-#  - undef
-!      undef           { hop => 'zouu' }
-!      undef           %hash
-!      undef           +{"" => "empty key"}
-!      undef           {}
-
-# ARRAY ref against:
-#  - another array ref
-       []                      []
-=!     []                      [1]
-       [["foo"], ["bar"]]      [qr/o/, qr/a/]
-!      [["foo"], ["bar"]]      [qr/ARRAY/, qr/ARRAY/]
-       ["foo", "bar"]          [qr/o/, qr/a/]
-!      [qr/o/, qr/a/]          ["foo", "bar"]
-       ["foo", "bar"]          [["foo"], ["bar"]]
-!      ["foo", "bar"]          [qr/o/, "foo"]
-       ["foo", undef, "bar"]   [qr/o/, undef, "bar"]
-!      ["foo", undef, "bar"]   [qr/o/, "",    "bar"]
-!      ["foo", "", "bar"]      [qr/o/, undef, "bar"]
-       $deep1                  $deep1
-       @$deep1                 @$deep1
-!      $deep1                  $deep2
-
-=      \@nums                  \@tied_nums
-=      @nums                   \@tied_nums
-=      \@nums                  @tied_nums
-=      @nums                   @tied_nums
-
-#  - an object
-!      $obj            @fooormore
-       $obj            [sub{ref shift}]
-
-#  - a regex
-=      qr/x/           [qw(foo bar baz quux)]
-=!     qr/y/           [qw(foo bar baz quux)]
-=      /x/             [qw(foo bar baz quux)]
-=!     /y/             [qw(foo bar baz quux)]
-=      /FOO/i          @fooormore
-=!     /bar/           @fooormore
-
-# - a number
-       2               [qw(1.00 2.00)]
-       2               [qw(foo 2)]
-       2.0_0e+0        [qw(foo 2)]
-!      2               [qw(1foo bar2)]
-
-# - a string
-!      "2"             [qw(1foo 2bar)]
-       "2bar"          [qw(1foo 2bar)]
-
-# - undef
-       undef           [1, 2, undef, 4]
-!      undef           [1, 2, [undef], 4]
-!      undef           @fooormore
-       undef           @sparse
-       undef           [undef]
-!      0               [undef]
-!      ""              [undef]
-!      undef           [0]
-!      undef           [""]
-
-# - nested arrays and ~~ distributivity
-       11              [[11]]
-!      11              [[12]]
-       "foo"           [{foo => "bar"}]
-!      "bar"           [{foo => "bar"}]
-
-# Number against number
-       2               2
-       20              2_0
-!      2               3
-       0               FALSE
-       3-2             TRUE
-!      undef           0
-!      (my $u)         0
-
-# Number against string
-=      2               "2"
-=      2               "2.0"
-!      2               "2bananas"
-!=     2_3             "2_3"           NOWARNINGS
-       FALSE           "0"
-!      undef           "0"
-!      undef           ""
-
-# Regex against string
-       "x"             qr/x/
-!      "x"             qr/y/
-
-# Regex against number
-       12345           qr/3/
-!      12345           qr/7/
-
-# array/hash against string
-       @fooormore      "".\@fooormore
-!      @keyandmore     "".\@fooormore
-       %fooormore      "".\%fooormore
-!      %keyandmore     "".\%fooormore
-
-# Test the implicit referencing
-       7               @nums
-       @nums           \@nums
-!      @nums           \\@nums
-       @nums           [1..10]
-!      @nums           [0..9]
-
-       "foo"           %hash
-       /bar/           %hash
-       [qw(bar)]       %hash
-!      [qw(a b c)]     %hash
-       %hash           %hash
-       %hash           +{%hash}
-       %hash           \%hash
-       %hash           %tied_hash
-       %tied_hash      %tied_hash
-       %hash           { foo => 5, bar => 10 }
-!      %hash           { foo => 5, bar => 10, quux => 15 }
-
-       @nums           {  1, '',  2, '' }
-       @nums           {  1, '', 12, '' }
-!      @nums           { 11, '', 12, '' }
-
-# array slices
-       @nums[0..-1]    []
-       @nums[0..0]     [1]
-!      @nums[0..1]     [0..2]
-       @nums[0..4]     [1..5]
-
-!      undef           @nums[0..-1]
-       1               @nums[0..0]
-       2               @nums[0..1]
-!      @nums[0..1]     2
-
-       @nums[0..1]     @nums[0..1]
-
-# hash slices
-       @keyandmore{qw(not)}            [undef]
-       @keyandmore{qw(key)}            [0]
+ok "abc" ~~ qr/\Aabc/;
+ok "abcd" ~~ qr/\Aabc/;
+ok !("xabc" ~~ qr/\Aabc/);
 
-       undef                           @keyandmore{qw(not)}
-       0                               @keyandmore{qw(key and more)}
-!      2                               @keyandmore{qw(key and)}
+package MatchRef { use overload "~~" => sub { ref($_[1]) }; }
+my $matchref = bless({}, "MatchRef");
+package MatchThree { use overload "~~" => sub { !ref($_[1]) && $_[1] == 3 }; }
+my $matchthree = bless({}, "MatchThree");
 
-       @fooormore{qw(foo)}             @keyandmore{qw(key)}
-       @fooormore{qw(foo or more)}     @keyandmore{qw(key and more)}
+my @a = qw(x y z);
+ok @a ~~ $matchthree;
+ok !(@a ~~ $matchref);
+my %h = qw(a b c d);
+ok !(%h ~~ $matchref);
+my $res = eval { "abc" ~~ %$matchabc };
+like $@, qr/\ACannot smart match without a matcher object /;
 
-# UNDEF
-!      3               undef
-!      1               undef
-!      []              undef
-!      {}              undef
-!      \%::main        undef
-!      [1,2]           undef
-!      %hash           undef
-!      @nums           undef
-!      "foo"           undef
-!      ""              undef
-!      !1              undef
-!      \&foo           undef
-!      sub { }         undef
+1;
index 700ae35..fda7bdf 100644 (file)
@@ -10,7 +10,7 @@ use strict;
 use warnings;
 no warnings 'experimental::smartmatch';
 
-plan tests => 170;
+plan tests => 166;
 
 # The behaviour of the feature pragma should be tested by lib/feature.t
 # using the tests in t/lib/feature/*. This file tests the behaviour of
@@ -826,13 +826,6 @@ GIVEN5:
     is($flag, 1, "goto inside given and when to the given stmt");
 }
 
-# test with unreified @_ in smart match [perl #71078]
-sub unreified_check { ok([@_] ~~ \@_) } # should always match
-unreified_check(1,2,"lala");
-unreified_check(1,2,undef);
-unreified_check(undef);
-unreified_check(undef,"");
-
 # Test do { given } as a rvalue
 
 {
index 8701e70..d91ec8b 100644 (file)
@@ -17,7 +17,7 @@ BEGIN {
 use strict;
 use Config;
 
-plan tests => 1040;
+plan tests => 1038;
 
 $| = 1;
 
@@ -2432,14 +2432,6 @@ end
     ok(!tainted "", "tainting still works after index() of the constant");
 }
 
-# Tainted values with smartmatch
-# [perl #93590] S_do_smartmatch stealing its own string buffers
-{
-no warnings 'experimental::smartmatch';
-ok "M$TAINT" ~~ ['m', 'M'], '$tainted ~~ ["whatever", "match"]';
-ok !("M$TAINT" ~~ ['m', undef]), '$tainted ~~ ["whatever", undef]';
-}
-
 # Tainted values and ref()
 for(1,2) {
   my $x = bless \"M$TAINT", ref(bless[], "main");
index d8b906d..2b79f34 100644 (file)
@@ -9,7 +9,7 @@ BEGIN {
     set_up_inc('../lib');
 }
 
-plan (tests => 343);
+plan (tests => 342);
 
 use strict;
 use warnings;
@@ -164,10 +164,6 @@ $dummy  = -e -e -e $var ; check_count '-e -e';
 $_ = "foo";
 $dummy  =  $var =~ m/ / ; check_count 'm//';
 $dummy  =  $var =~ s/ //; check_count 's///';
-{
-    no warnings 'experimental::smartmatch';
-    $dummy  =  $var ~~    1 ; check_count '~~';
-}
 $dummy  =  $var =~ y/ //; check_count 'y///';
            $var = \1;
 $dummy  =  $var =~y/ /-/; check_count '$ref =~ y///';
index 3787dfa..d1779cf 100644 (file)
@@ -20,7 +20,12 @@ Pod::Checker cpan/Pod-Checker/t/pod/testpchk.pl b2072c7f4379fd050e15424175d7cac5
 Pod::Perldoc cpan/Pod-Perldoc/lib/Pod/Perldoc.pm 582be34c077c9ff44d99914724a0cc2140bcd48c
 Socket cpan/Socket/Socket.pm ee83312b6e3e0185af8d41a18635913d84b1b651
 Socket cpan/Socket/Socket.xs edd4fed212785f11c5c2095a75941dad27d586d9
+autodie cpan/autodie/lib/autodie/exception.pm 69eb9198238b0cd013fcb774df11ee939f667beb
+autodie cpan/autodie/lib/autodie/hints.pm e1998fec61fb4e82fe46585bd82c73200be6f262
+autodie cpan/autodie/t/exceptions.t ad315a208f875e06b0964012ce8d65daa438c036
+autodie cpan/autodie/t/lib/Hints_pod_examples.pm 6944c218e9754b3613c8d0c90a5ae8aceccb5c99
 autodie cpan/autodie/t/mkdir.t 9e70d2282a3cc7d76a78bf8144fccba20fb37dac
+experimental cpan/experimental/t/basic.t d971ca6e0b5b4d160a5429575675129dcea6b07c
 perlfaq cpan/perlfaq/lib/perlfaq5.pod bcc1b6af3b6dff3973643acf8d5e741463374123
 perlfaq cpan/perlfaq/lib/perlfaq8.pod bffbc0c8fa828aead24e0891a5e789369a8e0743
 podlators pod/perlpodstyle.pod c6500c9950b46e8228d4adbc09a3ee2ef23de2d0
index c293c64..d831b8b 100644 (file)
@@ -12,7 +12,7 @@ BEGIN {
 
 BEGIN { require "./test.pl";  require "./loc_tools.pl"; }
 
-plan(tests => 137);
+plan(tests => 136);
 
 use Config;
 
@@ -647,11 +647,6 @@ $r = runperl(
 is( $r, "Hello, world!\n", "-E say" );
 
 
-$r = runperl(
-    switches   => [ '-E', '"no warnings q{experimental::smartmatch}; undef ~~ undef and say q(Hello, world!)"']
-);
-is( $r, "Hello, world!\n", "-E ~~" );
-
 $r = runperl(
     switches   => [ '-E', '"no warnings q{experimental::smartmatch}; given(undef) {when(!defined) { say q(Hello, world!)"}}']
 );
index 2262939..30b70ac 100644 (file)
@@ -986,6 +986,34 @@ XS(XS_re_regexp_pattern)
     NOT_REACHED; /* NOTREACHED */
 }
 
+XS(XS_Regexp_smartmatch); /* prototype to pass -Wmissing-prototypes */
+XS(XS_Regexp_smartmatch)
+{
+    dXSARGS;
+    SV *regexp_sv, *matchee_sv;
+    REGEXP *rx;
+    regexp *prog;
+    const char *strstart, *strend;
+    STRLEN len;
+
+    if (items != 3)
+       croak_xs_usage(cv, "regexp, matchee, swap");
+    matchee_sv = SP[-1];
+    regexp_sv = SP[-2];
+    SP -= 2;
+    PUTBACK;
+    assert(SvROK(regexp_sv));
+    rx = (REGEXP*)SvRV(regexp_sv);
+    assert(SvTYPE((SV*)rx) == SVt_REGEXP);
+    prog = ReANY(rx);
+    strstart = SvPV_const(matchee_sv, len);
+    assert(strstart);
+    strend = strstart + len;
+    TOPs = boolSV((RXp_MINLEN(prog) < 0 || len >= (STRLEN)RXp_MINLEN(prog)) &&
+               CALLREGEXEC(rx, (char*)strstart, (char *)strend,
+                   (char*)strstart, 0, matchee_sv, NULL, 0));
+}
+
 #include "vutil.h"
 #include "vxs.inc"
 
@@ -1020,6 +1048,9 @@ static const struct xsub_details details[] = {
     {"re::regnames", XS_re_regnames, ";$"},
     {"re::regnames_count", XS_re_regnames_count, ""},
     {"re::regexp_pattern", XS_re_regexp_pattern, "$"},
+    {"Regexp::((", XS_Regexp_smartmatch, NULL},
+    {"Regexp::()", XS_Regexp_smartmatch, NULL},
+    {"Regexp::(~~", XS_Regexp_smartmatch, NULL},
 };
 
 STATIC OP*
@@ -1108,6 +1139,9 @@ Perl_boot_core_UNIVERSAL(pTHX)
        *cvfile = (char *)file;
        Safefree(oldfile);
     }
+
+    /* overload fallback flag for Regexp */
+    sv_setiv(get_sv("Regexp::()", GV_ADD), 1);
 }
 
 /*