summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorZefram <zefram@fysh.org>2017-11-22 17:23:57 +0000
committerZefram <zefram@fysh.org>2017-11-22 17:23:57 +0000
commit5f3202fa3e77c4a20de590df045af4683aaedffa (patch)
tree5572a671df6c4586c7d77cf8f98787eb0f457f07
parent5e1cca32ac612f0b59508a99fbff671a693f39b9 (diff)
downloadperl-5f3202fa3e77c4a20de590df045af4683aaedffa.tar.gz
eviscerate smartmatch
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.
-rwxr-xr-xPorting/Maintainers.pl15
-rw-r--r--cpan/autodie/lib/autodie/exception.pm19
-rw-r--r--cpan/autodie/lib/autodie/hints.pm19
-rw-r--r--cpan/autodie/t/exceptions.t16
-rw-r--r--cpan/autodie/t/lib/Hints_pod_examples.pm16
-rw-r--r--cpan/experimental/t/basic.t4
-rw-r--r--embed.fnc6
-rw-r--r--embed.h6
-rw-r--r--ext/XS-APItest/t/fetch_pad_names.t5
-rw-r--r--lib/overload.t12
-rw-r--r--op.c66
-rw-r--r--opcode.h4
-rw-r--r--pod/perldiag.pod17
-rw-r--r--pod/perlop.pod293
-rw-r--r--pp_ctl.c537
-rw-r--r--proto.h20
-rw-r--r--regen/opcodes2
-rw-r--r--t/lib/warnings/9uninit7
-rw-r--r--t/lib/warnings/op2
-rw-r--r--t/lib/warnings/utf85
-rw-r--r--t/op/smartmatch.t631
-rw-r--r--t/op/switch.t9
-rw-r--r--t/op/taint.t10
-rw-r--r--t/op/tie_fetch_count.t6
-rw-r--r--t/porting/customized.dat5
-rw-r--r--t/run/switches.t7
-rw-r--r--universal.c34
27 files changed, 208 insertions, 1565 deletions
diff --git a/Porting/Maintainers.pl b/Porting/Maintainers.pl
index 116c12c64c..ee616af8d8 100755
--- a/Porting/Maintainers.pl
+++ b/Porting/Maintainers.pl
@@ -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' => {
diff --git a/cpan/autodie/lib/autodie/exception.pm b/cpan/autodie/lib/autodie/exception.pm
index 73058085e0..b3fcff9bb4 100644
--- a/cpan/autodie/lib/autodie/exception.pm
+++ b/cpan/autodie/lib/autodie/exception.pm
@@ -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
diff --git a/cpan/autodie/lib/autodie/hints.pm b/cpan/autodie/lib/autodie/hints.pm
index beaefcc28a..be9fbceb47 100644
--- a/cpan/autodie/lib/autodie/hints.pm
+++ b/cpan/autodie/lib/autodie/hints.pm
@@ -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 },
}
);
diff --git a/cpan/autodie/t/exceptions.t b/cpan/autodie/t/exceptions.t
index 4e7545d1ee..ab6f07de44 100644
--- a/cpan/autodie/t/exceptions.t
+++ b/cpan/autodie/t/exceptions.t
@@ -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)" );
diff --git a/cpan/autodie/t/lib/Hints_pod_examples.pm b/cpan/autodie/t/lib/Hints_pod_examples.pm
index 05db908e18..72a58a5ce5 100644
--- a/cpan/autodie/t/lib/Hints_pod_examples.pm
+++ b/cpan/autodie/t/lib/Hints_pod_examples.pm
@@ -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 },
}
);
diff --git a/cpan/experimental/t/basic.t b/cpan/experimental/t/basic.t
index a270fdfd91..95f60db347 100644
--- a/cpan/experimental/t/basic.t
+++ b/cpan/experimental/t/basic.t
@@ -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
}
diff --git a/embed.fnc b/embed.fnc
index 496a2ebb79..b39a5a7229 100644
--- 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 edadfc0611..f726f97980 100644
--- a/embed.h
+++ b/embed.h
@@ -1195,7 +1195,6 @@
#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)
@@ -1665,7 +1664,6 @@
#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)
@@ -1715,8 +1713,6 @@
# 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)
@@ -1727,8 +1723,6 @@
#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)
diff --git a/ext/XS-APItest/t/fetch_pad_names.t b/ext/XS-APItest/t/fetch_pad_names.t
index bdff1a8fe6..7670e9b3af 100644
--- a/ext/XS-APItest/t/fetch_pad_names.t
+++ b/ext/XS-APItest/t/fetch_pad_names.t
@@ -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};
}
}
diff --git a/lib/overload.t b/lib/overload.t
index 46b193be21..077a796ce8 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 => 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 73b5bb8721..6318f42e69 100644
--- 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)
{
diff --git a/opcode.h b/opcode.h
index b5ed37ff35..e1ba36bb52 100644
--- 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 */
diff --git a/pod/perldiag.pod b/pod/perldiag.pod
index 2565ee6a62..efc1c3f54d 100644
--- a/pod/perldiag.pod
+++ b/pod/perldiag.pod
@@ -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
diff --git a/pod/perlop.pod b/pod/perlop.pod
index b060839fef..17e6060f47 100644
--- a/pod/perlop.pod
+++ b/pod/perlop.pod
@@ -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<&>
diff --git a/pp_ctl.c b/pp_ctl.c
index 4026d4d579..e4a9ad9f11 100644
--- 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 c3ed9dddbd..bd9e2d8217 100644
--- 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__;
diff --git a/regen/opcodes b/regen/opcodes
index 5aa8a94fa5..18dc4fcbfa 100644
--- a/regen/opcodes
+++ b/regen/opcodes
@@ -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.
diff --git a/t/lib/warnings/9uninit b/t/lib/warnings/9uninit
index 774c6ee432..3963d66e39 100644
--- a/t/lib/warnings/9uninit
+++ b/t/lib/warnings/9uninit
@@ -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 = "";
diff --git a/t/lib/warnings/op b/t/lib/warnings/op
index bb684022dc..30931b68a4 100644
--- a/t/lib/warnings/op
+++ b/t/lib/warnings/op
@@ -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";
diff --git a/t/lib/warnings/utf8 b/t/lib/warnings/utf8
index a9a6388d31..2ac8ac97f6 100644
--- a/t/lib/warnings/utf8
+++ b/t/lib/warnings/utf8
@@ -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.
diff --git a/t/op/smartmatch.t b/t/op/smartmatch.t
index 10d35390d7..40867e3649 100644
--- a/t/op/smartmatch.t
+++ b/t/op/smartmatch.t
@@ -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;
diff --git a/t/op/switch.t b/t/op/switch.t
index 700ae35021..fda7bdf0d8 100644
--- a/t/op/switch.t
+++ b/t/op/switch.t
@@ -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
{
diff --git a/t/op/taint.t b/t/op/taint.t
index 8701e70285..d91ec8b175 100644
--- a/t/op/taint.t
+++ b/t/op/taint.t
@@ -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");
diff --git a/t/op/tie_fetch_count.t b/t/op/tie_fetch_count.t
index d8b906d7ab..2b79f34e5e 100644
--- a/t/op/tie_fetch_count.t
+++ b/t/op/tie_fetch_count.t
@@ -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///';
diff --git a/t/porting/customized.dat b/t/porting/customized.dat
index 3787dfa19b..d1779cf54b 100644
--- a/t/porting/customized.dat
+++ b/t/porting/customized.dat
@@ -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
diff --git a/t/run/switches.t b/t/run/switches.t
index c293c6488e..d831b8b8c9 100644
--- a/t/run/switches.t
+++ b/t/run/switches.t
@@ -12,7 +12,7 @@ BEGIN {
BEGIN { require "./test.pl"; require "./loc_tools.pl"; }
-plan(tests => 137);
+plan(tests => 136);
use Config;
@@ -648,11 +648,6 @@ 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!)"}}']
);
is( $r, "Hello, world!\n", "-E given" );
diff --git a/universal.c b/universal.c
index 2262939b8d..30b70ac2f6 100644
--- a/universal.c
+++ b/universal.c
@@ -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);
}
/*