summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-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);
}
/*
View Lorry Controller Status