mirror/perl
1
0
Fork 0
mirror of https://github.com/Perl/perl5.git synced 2026-01-26 00:27:57 +00:00
Code Issues Packages Projects Releases Wiki Activity

Revert "switch removal: remove smartmatch"

Browse Source 
This reverts commit cb2167d3785e61e23819ca2c58ac1e89d5e4bf3b.
This commit is contained in:
Tony Cook 2024-11-18 14:47:33 +11:00 committed by Aristotle Pagaltzis
parent 9a10079617
commit a215a77dd9
32 changed files with 1994 additions and 338 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
MANIFEST
View File

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

10
embed.fnc
View File

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

6
embed.h
View File

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

2
ext/Opcode/Opcode.pm
View File

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

12
lib/B/Deparse.pm
View File

@ -3169,6 +3169,16 @@ sub pp_padsv_store {
return $self->maybe_parens("$var = $val", $cx, 7);
}
sub pp_smartmatch {
my ($self, $op, $cx) = @_;
if (($op->flags & OPf_SPECIAL) && $self->{expand} < 2) {
return $self->deparse($op->last, $cx);
}
else {
binop(@_, "~~", 14);
}
}
# '.' is special because concats-of-concats are optimized to save copying
# by making all but the first concat stacked. The effect is as if the
# programmer had written '($a . $b) .= $c', except legal.
@ -5194,7 +5204,7 @@ sub retscalar {
|i_subtract|concat|multiconcat|stringify|left_shift|right_shift|lt
|i_lt|gt|i_gt|le|i_le|ge|i_ge|eq|i_eq|ne|i_ne|ncmp|i_ncmp
|slt|sgt|sle|sge|seq|sne|scmp|[sn]?bit_(?:and|x?or)|negate
|i_negate|not|[sn]?complement|atan2|sin|cos
|i_negate|not|[sn]?complement|smartmatch|atan2|sin|cos
|rand|srand|exp|log|sqrt|int|hex|oct|abs|length|substr
|vec|index|rindex|sprintf|formline|ord|chr|crypt|ucfirst
|lcfirst|uc|lc|quotemeta|aelemfast|aelem|exists|helem

1
lib/B/Op_private.pm generated
View File

@ -566,6 +566,7 @@ $bits{sin}{0} = $bf[0];
@{$bits{sle}}{1,0} = ($bf[1], $bf[1]);
@{$bits{sleep}}{3,2,1,0} = ($bf[5], $bf[5], $bf[5], $bf[5]);
@{$bits{slt}}{1,0} = ($bf[1], $bf[1]);
@{$bits{smartmatch}}{1,0} = ($bf[1], $bf[1]);
@{$bits{sne}}{1,0} = ($bf[1], $bf[1]);
$bits{snetent}{0} = $bf[0];
@{$bits{socket}}{3,2,1,0} = ($bf[5], $bf[5], $bf[5], $bf[5]);

38
lib/overload.pm
View File

@ -3,7 +3,7 @@ package overload;
use strict;
no strict 'refs';
our $VERSION = '1.39';
our $VERSION = '1.40';
our %ops = (
with_assign => "+ - * / % ** << >> x .",
@ -376,6 +376,7 @@ hash C<%overload::ops>:
iterators => '<>',
filetest => '-X',
dereferencing => '${} @{} %{} &{} *{}',
matching => '~~',
special => 'nomethod fallback =',
Most of the overloadable operators map one-to-one to these keys.
@ -519,6 +520,37 @@ result of the last C<stat>, C<lstat> or unoverloaded filetest.
This overload was introduced in Perl 5.12.
=item * I<Matching>
The key C<"~~"> allows you to override the smart matching logic used by
the C<~~> operator and the switch construct (C<given>/C<when>). See
L<perlsyn/Switch Statements> and L<feature>.
Unusually, the overloaded implementation of the smart match operator
does not get full control of the smart match behaviour.
In particular, in the following code:
package Foo;
use overload '~~' => 'match';
my $obj = Foo->new();
$obj ~~ [ 1,2,3 ];
the smart match does I<not> invoke the method call like this:
$obj->match([1,2,3],0);
rather, the smart match distributive rule takes precedence, so $obj is
smart matched against each array element in turn until a match is found,
so you may see between one and three of these calls instead:
$obj->match(1,0);
$obj->match(2,0);
$obj->match(3,0);
Consult the match table in L<perlop/"Smartmatch Operator"> for
details of when overloading is invoked.
=item * I<Dereferencing>
${} @{} %{} &{} *{}
@ -647,6 +679,7 @@ expects. The minimal set is:
& | ^ ~ &. |. ^. ~.
atan2 cos sin exp log sqrt int
"" 0+ bool
~~
Of the conversions, only one of string, boolean or numeric is
needed because each can be generated from either of the other two.
@ -849,7 +882,8 @@ skipped.
There are exceptions to the above rules for dereference operations
(which, if Step 1 fails, always fall back to the normal, built-in
implementations - see Dereferencing) under L</Overloadable Operations>
implementations - see Dereferencing), and for C<~~> (which has its
own set of rules - see C<Matching> under L</Overloadable Operations>
above).
Note on Step 7: some operators have a different semantic depending

31
lib/overload.t
View File

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

2
lib/overload/numbers.pm
View File

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

65
op.c
View File

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

9
opcode.h generated
View File

@ -256,6 +256,7 @@ EXTCONST char* const PL_op_name[] INIT({
"complement",
"ncomplement",
"scomplement",
"smartmatch",
"atan2",
"sin",
"cos",
@ -679,6 +680,7 @@ EXTCONST char* const PL_op_desc[] INIT({
"1's complement (~)",
"numeric 1's complement (~)",
"string 1's complement (~)",
"smart match",
"atan2",
"sin",
"cos",
@ -1107,6 +1109,7 @@ INIT({
Perl_pp_complement,
Perl_pp_ncomplement,
Perl_pp_scomplement,
Perl_pp_smartmatch,
Perl_pp_atan2,
Perl_pp_sin,
Perl_pp_cos, /* implemented by Perl_pp_sin */
@ -1530,6 +1533,7 @@ INIT({
Perl_ck_bitop, /* complement */
Perl_ck_bitop, /* ncomplement */
Perl_ck_null, /* scomplement */
Perl_ck_smartmatch, /* smartmatch */
Perl_ck_fun, /* atan2 */
Perl_ck_fun, /* sin */
Perl_ck_fun, /* cos */
@ -1952,6 +1956,7 @@ EXTCONST U32 PL_opargs[] INIT({
0x0000110e, /* complement */
0x0000111e, /* ncomplement */
0x0000111e, /* scomplement */
0x00000204, /* smartmatch */
0x0001141e, /* atan2 */
0x00009b9e, /* sin */
0x00009b9e, /* cos */
@ -2676,6 +2681,7 @@ EXTCONST I16 PL_op_private_bitdef_ix[] = {
105, /* complement */
103, /* ncomplement */
78, /* scomplement */
13, /* smartmatch */
101, /* atan2 */
78, /* sin */
78, /* cos */
@ -3011,7 +3017,7 @@ EXTCONST U16 PL_op_private_bitdefs[] = {
0x077e, 0x0554, 0x1b70, 0x542c, 0x4fc8, 0x4225, /* const */
0x3cfc, 0x47f9, /* gvsv */
0x19d5, /* gv */
0x0067, /* gelem, lt, i_lt, gt, i_gt, le, i_le, ge, i_ge, eq, i_eq, ne, i_ne, ncmp, i_ncmp, slt, sgt, sle, sge, seq, sne, scmp, lslice, xor, isa */
0x0067, /* gelem, lt, i_lt, gt, i_gt, le, i_le, ge, i_ge, eq, i_eq, ne, i_ne, ncmp, i_ncmp, slt, sgt, sle, sge, seq, sne, scmp, smartmatch, lslice, xor, isa */
0x3cfc, 0x5378, 0x04f7, /* padsv */
0x3cfc, 0x5378, 0x0003, /* padsv_store, lvavref */
0x3cfc, 0x5378, 0x06d4, 0x3dec, 0x5149, /* padav */
@ -3204,6 +3210,7 @@ EXTCONST U8 PL_op_private_valid[] = {
/* COMPLEMENT */ (OPpUSEINT),
/* NCOMPLEMENT */ (OPpUSEINT|OPpTARGET_MY),
/* SCOMPLEMENT */ (OPpARG1_MASK|OPpTARGET_MY),
/* SMARTMATCH */ (OPpARG2_MASK),
/* ATAN2 */ (OPpARG4_MASK|OPpTARGET_MY),
/* SIN */ (OPpARG1_MASK|OPpTARGET_MY),
/* COS */ (OPpARG1_MASK|OPpTARGET_MY),

625
opnames.h generated
View File

@ -122,317 +122,318 @@ typedef enum opcode {
OP_COMPLEMENT = 105,
OP_NCOMPLEMENT = 106,
OP_SCOMPLEMENT = 107,
OP_ATAN2 = 108,
OP_SIN = 109,
OP_COS = 110,
OP_RAND = 111,
OP_SRAND = 112,
OP_EXP = 113,
OP_LOG = 114,
OP_SQRT = 115,
OP_INT = 116,
OP_HEX = 117,
OP_OCT = 118,
OP_ABS = 119,
OP_LENGTH = 120,
OP_SUBSTR = 121,
OP_SUBSTR_LEFT = 122,
OP_VEC = 123,
OP_INDEX = 124,
OP_RINDEX = 125,
OP_SPRINTF = 126,
OP_FORMLINE = 127,
OP_ORD = 128,
OP_CHR = 129,
OP_CRYPT = 130,
OP_UCFIRST = 131,
OP_LCFIRST = 132,
OP_UC = 133,
OP_LC = 134,
OP_QUOTEMETA = 135,
OP_RV2AV = 136,
OP_AELEMFAST = 137,
OP_AELEMFAST_LEX = 138,
OP_AELEMFASTLEX_STORE = 139,
OP_AELEM = 140,
OP_ASLICE = 141,
OP_KVASLICE = 142,
OP_AEACH = 143,
OP_AVALUES = 144,
OP_AKEYS = 145,
OP_EACH = 146,
OP_VALUES = 147,
OP_KEYS = 148,
OP_DELETE = 149,
OP_EXISTS = 150,
OP_RV2HV = 151,
OP_HELEM = 152,
OP_HSLICE = 153,
OP_KVHSLICE = 154,
OP_MULTIDEREF = 155,
OP_UNPACK = 156,
OP_PACK = 157,
OP_SPLIT = 158,
OP_JOIN = 159,
OP_LIST = 160,
OP_LSLICE = 161,
OP_ANONLIST = 162,
OP_ANONHASH = 163,
OP_EMPTYAVHV = 164,
OP_SPLICE = 165,
OP_PUSH = 166,
OP_POP = 167,
OP_SHIFT = 168,
OP_UNSHIFT = 169,
OP_SORT = 170,
OP_REVERSE = 171,
OP_GREPSTART = 172,
OP_GREPWHILE = 173,
OP_ANYSTART = 174,
OP_ALLSTART = 175,
OP_ANYWHILE = 176,
OP_MAPSTART = 177,
OP_MAPWHILE = 178,
OP_RANGE = 179,
OP_FLIP = 180,
OP_FLOP = 181,
OP_AND = 182,
OP_OR = 183,
OP_XOR = 184,
OP_DOR = 185,
OP_COND_EXPR = 186,
OP_ANDASSIGN = 187,
OP_ORASSIGN = 188,
OP_DORASSIGN = 189,
OP_ENTERSUB = 190,
OP_LEAVESUB = 191,
OP_LEAVESUBLV = 192,
OP_ARGCHECK = 193,
OP_ARGELEM = 194,
OP_ARGDEFELEM = 195,
OP_CALLER = 196,
OP_WARN = 197,
OP_DIE = 198,
OP_RESET = 199,
OP_LINESEQ = 200,
OP_NEXTSTATE = 201,
OP_DBSTATE = 202,
OP_UNSTACK = 203,
OP_ENTER = 204,
OP_LEAVE = 205,
OP_SCOPE = 206,
OP_ENTERITER = 207,
OP_ITER = 208,
OP_ENTERLOOP = 209,
OP_LEAVELOOP = 210,
OP_RETURN = 211,
OP_LAST = 212,
OP_NEXT = 213,
OP_REDO = 214,
OP_DUMP = 215,
OP_GOTO = 216,
OP_EXIT = 217,
OP_METHOD = 218,
OP_METHOD_NAMED = 219,
OP_METHOD_SUPER = 220,
OP_METHOD_REDIR = 221,
OP_METHOD_REDIR_SUPER = 222,
OP_OPEN = 223,
OP_CLOSE = 224,
OP_PIPE_OP = 225,
OP_FILENO = 226,
OP_UMASK = 227,
OP_BINMODE = 228,
OP_TIE = 229,
OP_UNTIE = 230,
OP_TIED = 231,
OP_DBMOPEN = 232,
OP_DBMCLOSE = 233,
OP_SSELECT = 234,
OP_SELECT = 235,
OP_GETC = 236,
OP_READ = 237,
OP_ENTERWRITE = 238,
OP_LEAVEWRITE = 239,
OP_PRTF = 240,
OP_PRINT = 241,
OP_SAY = 242,
OP_SYSOPEN = 243,
OP_SYSSEEK = 244,
OP_SYSREAD = 245,
OP_SYSWRITE = 246,
OP_EOF = 247,
OP_TELL = 248,
OP_SEEK = 249,
OP_TRUNCATE = 250,
OP_FCNTL = 251,
OP_IOCTL = 252,
OP_FLOCK = 253,
OP_SEND = 254,
OP_RECV = 255,
OP_SOCKET = 256,
OP_SOCKPAIR = 257,
OP_BIND = 258,
OP_CONNECT = 259,
OP_LISTEN = 260,
OP_ACCEPT = 261,
OP_SHUTDOWN = 262,
OP_GSOCKOPT = 263,
OP_SSOCKOPT = 264,
OP_GETSOCKNAME = 265,
OP_GETPEERNAME = 266,
OP_LSTAT = 267,
OP_STAT = 268,
OP_FTRREAD = 269,
OP_FTRWRITE = 270,
OP_FTREXEC = 271,
OP_FTEREAD = 272,
OP_FTEWRITE = 273,
OP_FTEEXEC = 274,
OP_FTIS = 275,
OP_FTSIZE = 276,
OP_FTMTIME = 277,
OP_FTATIME = 278,
OP_FTCTIME = 279,
OP_FTROWNED = 280,
OP_FTEOWNED = 281,
OP_FTZERO = 282,
OP_FTSOCK = 283,
OP_FTCHR = 284,
OP_FTBLK = 285,
OP_FTFILE = 286,
OP_FTDIR = 287,
OP_FTPIPE = 288,
OP_FTSUID = 289,
OP_FTSGID = 290,
OP_FTSVTX = 291,
OP_FTLINK = 292,
OP_FTTTY = 293,
OP_FTTEXT = 294,
OP_FTBINARY = 295,
OP_CHDIR = 296,
OP_CHOWN = 297,
OP_CHROOT = 298,
OP_UNLINK = 299,
OP_CHMOD = 300,
OP_UTIME = 301,
OP_RENAME = 302,
OP_LINK = 303,
OP_SYMLINK = 304,
OP_READLINK = 305,
OP_MKDIR = 306,
OP_RMDIR = 307,
OP_OPEN_DIR = 308,
OP_READDIR = 309,
OP_TELLDIR = 310,
OP_SEEKDIR = 311,
OP_REWINDDIR = 312,
OP_CLOSEDIR = 313,
OP_FORK = 314,
OP_WAIT = 315,
OP_WAITPID = 316,
OP_SYSTEM = 317,
OP_EXEC = 318,
OP_KILL = 319,
OP_GETPPID = 320,
OP_GETPGRP = 321,
OP_SETPGRP = 322,
OP_GETPRIORITY = 323,
OP_SETPRIORITY = 324,
OP_TIME = 325,
OP_TMS = 326,
OP_LOCALTIME = 327,
OP_GMTIME = 328,
OP_ALARM = 329,
OP_SLEEP = 330,
OP_SHMGET = 331,
OP_SHMCTL = 332,
OP_SHMREAD = 333,
OP_SHMWRITE = 334,
OP_MSGGET = 335,
OP_MSGCTL = 336,
OP_MSGSND = 337,
OP_MSGRCV = 338,
OP_SEMOP = 339,
OP_SEMGET = 340,
OP_SEMCTL = 341,
OP_REQUIRE = 342,
OP_DOFILE = 343,
OP_HINTSEVAL = 344,
OP_ENTEREVAL = 345,
OP_LEAVEEVAL = 346,
OP_ENTERTRY = 347,
OP_LEAVETRY = 348,
OP_GHBYNAME = 349,
OP_GHBYADDR = 350,
OP_GHOSTENT = 351,
OP_GNBYNAME = 352,
OP_GNBYADDR = 353,
OP_GNETENT = 354,
OP_GPBYNAME = 355,
OP_GPBYNUMBER = 356,
OP_GPROTOENT = 357,
OP_GSBYNAME = 358,
OP_GSBYPORT = 359,
OP_GSERVENT = 360,
OP_SHOSTENT = 361,
OP_SNETENT = 362,
OP_SPROTOENT = 363,
OP_SSERVENT = 364,
OP_EHOSTENT = 365,
OP_ENETENT = 366,
OP_EPROTOENT = 367,
OP_ESERVENT = 368,
OP_GPWNAM = 369,
OP_GPWUID = 370,
OP_GPWENT = 371,
OP_SPWENT = 372,
OP_EPWENT = 373,
OP_GGRNAM = 374,
OP_GGRGID = 375,
OP_GGRENT = 376,
OP_SGRENT = 377,
OP_EGRENT = 378,
OP_GETLOGIN = 379,
OP_SYSCALL = 380,
OP_LOCK = 381,
OP_ONCE = 382,
OP_CUSTOM = 383,
OP_COREARGS = 384,
OP_AVHVSWITCH = 385,
OP_RUNCV = 386,
OP_FC = 387,
OP_PADCV = 388,
OP_INTROCV = 389,
OP_CLONECV = 390,
OP_PADRANGE = 391,
OP_REFASSIGN = 392,
OP_LVREF = 393,
OP_LVREFSLICE = 394,
OP_LVAVREF = 395,
OP_ANONCONST = 396,
OP_ISA = 397,
OP_CMPCHAIN_AND = 398,
OP_CMPCHAIN_DUP = 399,
OP_ENTERTRYCATCH = 400,
OP_LEAVETRYCATCH = 401,
OP_POPTRY = 402,
OP_CATCH = 403,
OP_PUSHDEFER = 404,
OP_IS_BOOL = 405,
OP_IS_WEAK = 406,
OP_WEAKEN = 407,
OP_UNWEAKEN = 408,
OP_BLESSED = 409,
OP_REFADDR = 410,
OP_REFTYPE = 411,
OP_CEIL = 412,
OP_FLOOR = 413,
OP_IS_TAINTED = 414,
OP_HELEMEXISTSOR = 415,
OP_METHSTART = 416,
OP_INITFIELD = 417,
OP_CLASSNAME = 418,
OP_SMARTMATCH = 108,
OP_ATAN2 = 109,
OP_SIN = 110,
OP_COS = 111,
OP_RAND = 112,
OP_SRAND = 113,
OP_EXP = 114,
OP_LOG = 115,
OP_SQRT = 116,
OP_INT = 117,
OP_HEX = 118,
OP_OCT = 119,
OP_ABS = 120,
OP_LENGTH = 121,
OP_SUBSTR = 122,
OP_SUBSTR_LEFT = 123,
OP_VEC = 124,
OP_INDEX = 125,
OP_RINDEX = 126,
OP_SPRINTF = 127,
OP_FORMLINE = 128,
OP_ORD = 129,
OP_CHR = 130,
OP_CRYPT = 131,
OP_UCFIRST = 132,
OP_LCFIRST = 133,
OP_UC = 134,
OP_LC = 135,
OP_QUOTEMETA = 136,
OP_RV2AV = 137,
OP_AELEMFAST = 138,
OP_AELEMFAST_LEX = 139,
OP_AELEMFASTLEX_STORE = 140,
OP_AELEM = 141,
OP_ASLICE = 142,
OP_KVASLICE = 143,
OP_AEACH = 144,
OP_AVALUES = 145,
OP_AKEYS = 146,
OP_EACH = 147,
OP_VALUES = 148,
OP_KEYS = 149,
OP_DELETE = 150,
OP_EXISTS = 151,
OP_RV2HV = 152,
OP_HELEM = 153,
OP_HSLICE = 154,
OP_KVHSLICE = 155,
OP_MULTIDEREF = 156,
OP_UNPACK = 157,
OP_PACK = 158,
OP_SPLIT = 159,
OP_JOIN = 160,
OP_LIST = 161,
OP_LSLICE = 162,
OP_ANONLIST = 163,
OP_ANONHASH = 164,
OP_EMPTYAVHV = 165,
OP_SPLICE = 166,
OP_PUSH = 167,
OP_POP = 168,
OP_SHIFT = 169,
OP_UNSHIFT = 170,
OP_SORT = 171,
OP_REVERSE = 172,
OP_GREPSTART = 173,
OP_GREPWHILE = 174,
OP_ANYSTART = 175,
OP_ALLSTART = 176,
OP_ANYWHILE = 177,
OP_MAPSTART = 178,
OP_MAPWHILE = 179,
OP_RANGE = 180,
OP_FLIP = 181,
OP_FLOP = 182,
OP_AND = 183,
OP_OR = 184,
OP_XOR = 185,
OP_DOR = 186,
OP_COND_EXPR = 187,
OP_ANDASSIGN = 188,
OP_ORASSIGN = 189,
OP_DORASSIGN = 190,
OP_ENTERSUB = 191,
OP_LEAVESUB = 192,
OP_LEAVESUBLV = 193,
OP_ARGCHECK = 194,
OP_ARGELEM = 195,
OP_ARGDEFELEM = 196,
OP_CALLER = 197,
OP_WARN = 198,
OP_DIE = 199,
OP_RESET = 200,
OP_LINESEQ = 201,
OP_NEXTSTATE = 202,
OP_DBSTATE = 203,
OP_UNSTACK = 204,
OP_ENTER = 205,
OP_LEAVE = 206,
OP_SCOPE = 207,
OP_ENTERITER = 208,
OP_ITER = 209,
OP_ENTERLOOP = 210,
OP_LEAVELOOP = 211,
OP_RETURN = 212,
OP_LAST = 213,
OP_NEXT = 214,
OP_REDO = 215,
OP_DUMP = 216,
OP_GOTO = 217,
OP_EXIT = 218,
OP_METHOD = 219,
OP_METHOD_NAMED = 220,
OP_METHOD_SUPER = 221,
OP_METHOD_REDIR = 222,
OP_METHOD_REDIR_SUPER = 223,
OP_OPEN = 224,
OP_CLOSE = 225,
OP_PIPE_OP = 226,
OP_FILENO = 227,
OP_UMASK = 228,
OP_BINMODE = 229,
OP_TIE = 230,
OP_UNTIE = 231,
OP_TIED = 232,
OP_DBMOPEN = 233,
OP_DBMCLOSE = 234,
OP_SSELECT = 235,
OP_SELECT = 236,
OP_GETC = 237,
OP_READ = 238,
OP_ENTERWRITE = 239,
OP_LEAVEWRITE = 240,
OP_PRTF = 241,
OP_PRINT = 242,
OP_SAY = 243,
OP_SYSOPEN = 244,
OP_SYSSEEK = 245,
OP_SYSREAD = 246,
OP_SYSWRITE = 247,
OP_EOF = 248,
OP_TELL = 249,
OP_SEEK = 250,
OP_TRUNCATE = 251,
OP_FCNTL = 252,
OP_IOCTL = 253,
OP_FLOCK = 254,
OP_SEND = 255,
OP_RECV = 256,
OP_SOCKET = 257,
OP_SOCKPAIR = 258,
OP_BIND = 259,
OP_CONNECT = 260,
OP_LISTEN = 261,
OP_ACCEPT = 262,
OP_SHUTDOWN = 263,
OP_GSOCKOPT = 264,
OP_SSOCKOPT = 265,
OP_GETSOCKNAME = 266,
OP_GETPEERNAME = 267,
OP_LSTAT = 268,
OP_STAT = 269,
OP_FTRREAD = 270,
OP_FTRWRITE = 271,
OP_FTREXEC = 272,
OP_FTEREAD = 273,
OP_FTEWRITE = 274,
OP_FTEEXEC = 275,
OP_FTIS = 276,
OP_FTSIZE = 277,
OP_FTMTIME = 278,
OP_FTATIME = 279,
OP_FTCTIME = 280,
OP_FTROWNED = 281,
OP_FTEOWNED = 282,
OP_FTZERO = 283,
OP_FTSOCK = 284,
OP_FTCHR = 285,
OP_FTBLK = 286,
OP_FTFILE = 287,
OP_FTDIR = 288,
OP_FTPIPE = 289,
OP_FTSUID = 290,
OP_FTSGID = 291,
OP_FTSVTX = 292,
OP_FTLINK = 293,
OP_FTTTY = 294,
OP_FTTEXT = 295,
OP_FTBINARY = 296,
OP_CHDIR = 297,
OP_CHOWN = 298,
OP_CHROOT = 299,
OP_UNLINK = 300,
OP_CHMOD = 301,
OP_UTIME = 302,
OP_RENAME = 303,
OP_LINK = 304,
OP_SYMLINK = 305,
OP_READLINK = 306,
OP_MKDIR = 307,
OP_RMDIR = 308,
OP_OPEN_DIR = 309,
OP_READDIR = 310,
OP_TELLDIR = 311,
OP_SEEKDIR = 312,
OP_REWINDDIR = 313,
OP_CLOSEDIR = 314,
OP_FORK = 315,
OP_WAIT = 316,
OP_WAITPID = 317,
OP_SYSTEM = 318,
OP_EXEC = 319,
OP_KILL = 320,
OP_GETPPID = 321,
OP_GETPGRP = 322,
OP_SETPGRP = 323,
OP_GETPRIORITY = 324,
OP_SETPRIORITY = 325,
OP_TIME = 326,
OP_TMS = 327,
OP_LOCALTIME = 328,
OP_GMTIME = 329,
OP_ALARM = 330,
OP_SLEEP = 331,
OP_SHMGET = 332,
OP_SHMCTL = 333,
OP_SHMREAD = 334,
OP_SHMWRITE = 335,
OP_MSGGET = 336,
OP_MSGCTL = 337,
OP_MSGSND = 338,
OP_MSGRCV = 339,
OP_SEMOP = 340,
OP_SEMGET = 341,
OP_SEMCTL = 342,
OP_REQUIRE = 343,
OP_DOFILE = 344,
OP_HINTSEVAL = 345,
OP_ENTEREVAL = 346,
OP_LEAVEEVAL = 347,
OP_ENTERTRY = 348,
OP_LEAVETRY = 349,
OP_GHBYNAME = 350,
OP_GHBYADDR = 351,
OP_GHOSTENT = 352,
OP_GNBYNAME = 353,
OP_GNBYADDR = 354,
OP_GNETENT = 355,
OP_GPBYNAME = 356,
OP_GPBYNUMBER = 357,
OP_GPROTOENT = 358,
OP_GSBYNAME = 359,
OP_GSBYPORT = 360,
OP_GSERVENT = 361,
OP_SHOSTENT = 362,
OP_SNETENT = 363,
OP_SPROTOENT = 364,
OP_SSERVENT = 365,
OP_EHOSTENT = 366,
OP_ENETENT = 367,
OP_EPROTOENT = 368,
OP_ESERVENT = 369,
OP_GPWNAM = 370,
OP_GPWUID = 371,
OP_GPWENT = 372,
OP_SPWENT = 373,
OP_EPWENT = 374,
OP_GGRNAM = 375,
OP_GGRGID = 376,
OP_GGRENT = 377,
OP_SGRENT = 378,
OP_EGRENT = 379,
OP_GETLOGIN = 380,
OP_SYSCALL = 381,
OP_LOCK = 382,
OP_ONCE = 383,
OP_CUSTOM = 384,
OP_COREARGS = 385,
OP_AVHVSWITCH = 386,
OP_RUNCV = 387,
OP_FC = 388,
OP_PADCV = 389,
OP_INTROCV = 390,
OP_CLONECV = 391,
OP_PADRANGE = 392,
OP_REFASSIGN = 393,
OP_LVREF = 394,
OP_LVREFSLICE = 395,
OP_LVAVREF = 396,
OP_ANONCONST = 397,
OP_ISA = 398,
OP_CMPCHAIN_AND = 399,
OP_CMPCHAIN_DUP = 400,
OP_ENTERTRYCATCH = 401,
OP_LEAVETRYCATCH = 402,
OP_POPTRY = 403,
OP_CATCH = 404,
OP_PUSHDEFER = 405,
OP_IS_BOOL = 406,
OP_IS_WEAK = 407,
OP_WEAKEN = 408,
OP_UNWEAKEN = 409,
OP_BLESSED = 410,
OP_REFADDR = 411,
OP_REFTYPE = 412,
OP_CEIL = 413,
OP_FLOOR = 414,
OP_IS_TAINTED = 415,
OP_HELEMEXISTSOR = 416,
OP_METHSTART = 417,
OP_INITFIELD = 418,
OP_CLASSNAME = 419,
OP_max
} opcode;
@ -443,7 +444,7 @@ An enum of all the legal Perl opcodes, defined in F<opnames.h>
=cut
*/
#define MAXO 419
#define MAXO 420
#define OP_FREED MAXO
/* the OP_IS_* macros are optimized to a simple range check because

5
overload.h
View File

@ -86,8 +86,9 @@ enum {
repeat_ass_amg, /* 0x45 x= */
concat_amg, /* 0x46 . */
concat_ass_amg, /* 0x47 .= */
ftest_amg, /* 0x48 -X */
regexp_amg, /* 0x49 qr */
smart_amg, /* 0x48 ~~ */
ftest_amg, /* 0x49 -X */
regexp_amg, /* 0x4a qr */
max_amg_code
/* Do not leave a trailing comma here. C9X allows it, C89 doesn't. */
};

2
overload.inc
View File

@ -90,6 +90,7 @@ static const U8 PL_AMG_namelens[NofAMmeth] = {
2,
3,
3,
3,
3
};
@ -171,6 +172,7 @@ static const char * const PL_AMG_names[NofAMmeth] = {
"(x=", /* repeat_ass */
"(.", /* concat */
"(.=", /* concat_ass */
"(~~", /* smart */
"(-X", /* ftest */
"(qr"
};

4
pod/perlcheat.pod
View File

@ -28,14 +28,14 @@ already be overwhelming.
-> while (e) { } until (e) { }
++ -- if (e) { } elsif (e) { } else { }
** unless (e) { } elsif (e) { } else { }
! ~ \ u+ u-
! ~ \ u+ u- given (e) { when (e) {} default {} }
=~ !~
* / % x NUMBERS vs STRINGS FALSE vs TRUE
+ - . = = undef, "", 0, "0"
<< >> + . anything else
named uops == != eq ne
< > <= >= lt gt le ge < > <= >= lt gt le ge
== != <=> eq ne cmp <=> cmp
== != <=> eq ne cmp ~~ <=> cmp
&
| ^ REGEX MODIFIERS REGEX METACHARS
&& /i case insensitive ^ string begin

14
pod/perldiag.pod
View File

@ -6174,6 +6174,20 @@ 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 deprecated
(D deprecated::smartmatch) This warning is emitted if you
use the smartmatch (C<~~>) operator. This is a deprecated
feature. Particularly, its behavior is noticed for being
unnecessarily complex and unintuitive, and it will be removed
in Perl 5.42.
=item Sorry, hash keys must be smaller than 2**31 bytes
(F) You tried to create a hash containing a very large key, where "very

295
pod/perlop.pod
View File

@ -138,7 +138,7 @@ values only, not array values.
nonassoc named unary operators
nonassoc isa
chained < > <= >= lt gt le ge
chain/na == != eq ne <=> cmp
chain/na == != eq ne <=> cmp ~~
left & &.
left | |. ^ ^.
left &&
@ -639,9 +639,13 @@ Here we can see the difference between <=> and cmp,
(likewise between gt and >, lt and <, etc.)
X<cmp>
The two-sided ordering operators C<"E<lt>=E<gt>"> and C<"cmp"> are
non-associative with respect to each other and with respect to the
equality operators of the same precedence.
Binary C<"~~"> does a smartmatch between its arguments. Smart matching
is described in the next section.
X<~~>
The two-sided ordering operators C<"E<lt>=E<gt>"> and C<"cmp">, and the
smartmatch operator C<"~~">, are non-associative with respect to each
other and with respect to the equality operators of the same precedence.
C<"lt">, C<"le">, C<"ge">, C<"gt"> and C<"cmp"> use the collation (sort)
order specified by the current C<LC_COLLATE> locale if a S<C<use
@ -678,7 +682,288 @@ C<use v5.36> (or higher) declaration in the current scope.
=head2 Smartmatch Operator
The smartmatch operator C<~~> was removed in Perl 5.42.
First available in Perl 5.10.1 (the 5.10.0 version behaved differently),
binary C<~~> does a "smartmatch" between its arguments. This is mostly
used implicitly in the C<when> construct described in L<perlsyn>, although
not all C<when> clauses call the smartmatch operator. Unique among all of
Perl's operators, the smartmatch operator can recurse. 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 cannot 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.
The smartmatch operator is most often used as the implicit operator of a
C<when> clause. See the section on "Switch Statements" in L<perlsyn>.
=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.
=head2 Bitwise And
X<operator, bitwise, and> X<bitwise and> X<&>

514
pp_ctl.c
View File

@ -5720,6 +5720,520 @@ PP(pp_leavetry)
return retop;
}
/* Helper routines used by pp_smartmatch */
STATIC PMOP *
S_make_matcher(pTHX_ REGEXP *re)
{
PMOP *matcher = cPMOPx(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)
{
bool result;
PERL_ARGS_ASSERT_MATCHER_MATCHES_SV;
PL_op = (OP *) matcher;
rpp_xpush_1(sv);
(void) Perl_pp_match(aTHX);
result = SvTRUEx(*PL_stack_sp);
rpp_popfree_1_NN();
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)
{
bool object_on_left = FALSE;
SV *e = PL_stack_sp[0]; /* e is for 'expression' */
SV *d = PL_stack_sp[-1]; /* 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) {
rpp_replace_2_1_NN(tmpsv);
return NORMAL;
}
DEBUG_M(Perl_deb(aTHX_ " failed to run overload method; continuing...\n"));
}
/* ~~ undef */
if (!SvOK(e)) {
DEBUG_M(Perl_deb(aTHX_ " applying rule Any-undef\n"));
if (SvOK(d))
goto ret_no;
else
goto ret_yes;
}
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) {
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)
goto ret_yes;
while ( (he = hv_iternext(hv)) ) {
DEBUG_M(Perl_deb(aTHX_ " testing hash key...\n"));
ENTER_with_name("smartmatch_hash_key_test");
SAVETMPS;
PUSHMARK(PL_stack_sp);
rpp_xpush_1(hv_iterkeysv(he));
(void)call_sv(e, G_SCALAR);
andedresults = SvTRUEx(PL_stack_sp[0]) && andedresults;
rpp_popfree_1_NN();
FREETMPS;
LEAVE_with_name("smartmatch_hash_key_test");
}
if (andedresults)
goto ret_yes;
else
goto ret_no;
}
else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
/* Test sub truth for each element */
Size_t i;
bool andedresults = TRUE;
AV *av = (AV*) SvRV(d);
const Size_t len = av_count(av);
DEBUG_M(Perl_deb(aTHX_ " applying rule Array-CodeRef\n"));
if (len == 0)
goto ret_yes;
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(PL_stack_sp);
if (svp)
rpp_xpush_1(*svp);
(void)call_sv(e, G_SCALAR);
andedresults = SvTRUEx(PL_stack_sp[0]) && andedresults;
rpp_popfree_1_NN();
FREETMPS;
LEAVE_with_name("smartmatch_array_elem_test");
}
if (andedresults)
goto ret_yes;
else
goto ret_no;
}
else {
sm_any_sub:
DEBUG_M(Perl_deb(aTHX_ " applying rule Any-CodeRef\n"));
ENTER_with_name("smartmatch_coderef");
PUSHMARK(PL_stack_sp);
rpp_xpush_1(d);
(void)call_sv(e, G_SCALAR);
LEAVE_with_name("smartmatch_coderef");
SV *retsv = *PL_stack_sp--;
rpp_replace_2_1(retsv);
#ifdef PERL_RC_STACK
SvREFCNT_dec(retsv);
#endif
return NORMAL;
}
}
/* ~~ %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"));
goto ret_no;
}
else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
/* Check that the key-sets are identical */
HE *he;
HV *other_hv = HV_FROM_REF(d);
bool tied;
bool other_tied;
U32 this_key_count = 0,
other_key_count = 0;
HV *hv = HV_FROM_REF(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))
goto ret_no;
}
/* 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 */
goto ret_no;
}
}
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)
goto ret_no;
else
goto ret_yes;
}
else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
AV * const other_av = AV_FROM_REF(d);
const Size_t other_len = av_count(other_av);
Size_t i;
HV *hv = HV_FROM_REF(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))
goto ret_yes;
}
}
goto ret_no;
}
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 = HV_FROM_REF(e);
(void) hv_iterinit(hv);
while ( (he = hv_iternext(hv)) ) {
DEBUG_M(Perl_deb(aTHX_ " testing key against pattern...\n"));
if (matcher_matches_sv(matcher, hv_iterkeysv(he))) {
(void) hv_iterinit(hv);
destroy_matcher(matcher);
goto ret_yes;
}
}
destroy_matcher(matcher);
goto ret_no;
}
}
else {
sm_any_hash:
DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Hash\n"));
if (hv_exists_ent(HV_FROM_REF(e), d, 0))
goto ret_yes;
else
goto ret_no;
}
}
/* ~~ @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 = AV_FROM_REF(e);
const Size_t other_len = av_count(other_av);
Size_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(HV_FROM_REF(d), *svp, 0))
goto ret_yes;
}
}
goto ret_no;
}
if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
AV *other_av = AV_FROM_REF(d);
DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Array\n"));
if (av_count(AV_FROM_REF(e)) != av_count(other_av))
goto ret_no;
else {
Size_t i;
const Size_t other_len = av_count(other_av);
if (NULL == seen_this) {
seen_this = (HV*)newSV_type_mortal(SVt_PVHV);
}
if (NULL == seen_other) {
seen_other = (HV*)newSV_type_mortal(SVt_PVHV);
}
for(i = 0; i < other_len; ++i) {
SV * const * const this_elem = av_fetch(AV_FROM_REF(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)))
goto ret_no;
}
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)
goto ret_no;
}
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);
rpp_xpush_2(*other_elem, *this_elem);
DEBUG_M(Perl_deb(aTHX_ " recursively comparing array element...\n"));
(void) do_smartmatch(seen_this, seen_other, 0);
DEBUG_M(Perl_deb(aTHX_ " recursion finished\n"));
bool ok = SvTRUEx(PL_stack_sp[0]);
rpp_popfree_1_NN();
if (!ok)
goto ret_no;
}
}
goto ret_yes;
}
}
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 Size_t this_len = av_count(AV_FROM_REF(e));
Size_t i;
for(i = 0; i < this_len; ++i) {
SV * const * const svp = av_fetch(AV_FROM_REF(e), i, FALSE);
DEBUG_M(Perl_deb(aTHX_ " testing element against pattern...\n"));
if (svp && matcher_matches_sv(matcher, *svp)) {
destroy_matcher(matcher);
goto ret_yes;
}
}
destroy_matcher(matcher);
goto ret_no;
}
}
else if (!SvOK(d)) {
/* undef ~~ array */
const Size_t this_len = av_count(AV_FROM_REF(e));
Size_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(AV_FROM_REF(e), i, FALSE);
DEBUG_M(Perl_deb(aTHX_ " testing for undef element...\n"));
if (!svp || !SvOK(*svp))
goto ret_yes;
}
goto ret_no;
}
else {
sm_any_array:
{
Size_t i;
const Size_t this_len = av_count(AV_FROM_REF(e));
DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Array\n"));
for (i = 0; i < this_len; ++i) {
SV * const * const svp = av_fetch(AV_FROM_REF(e), i, FALSE);
if (!svp)
continue;
rpp_xpush_2(d, *svp);
/* infinite recursion isn't supposed to happen here */
DEBUG_M(Perl_deb(aTHX_ " recursively testing array element...\n"));
(void) do_smartmatch(NULL, NULL, 1);
DEBUG_M(Perl_deb(aTHX_ " recursion finished\n"));
bool ok = SvTRUEx(PL_stack_sp[0]);
rpp_popfree_1_NN();
if (ok)
goto ret_yes;
}
goto ret_no;
}
}
}
/* ~~ 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"));
result = matcher_matches_sv(matcher, d);
destroy_matcher(matcher);
if (result)
goto ret_yes;
else
goto ret_no;
}
}
/* ~~ 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"));
tmpsv = amagic_call(d, e, smart_amg, AMGf_noright);
if (tmpsv) {
rpp_replace_2_1_NN(tmpsv);
return NORMAL;
}
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"));
goto ret_no;
}
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 */
rpp_xpush_2(d, e);
if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
(void) Perl_pp_i_eq(aTHX);
else
(void) Perl_pp_eq(aTHX);
bool ok = SvTRUEx(PL_stack_sp[0]);
rpp_popfree_1_NN();
if (ok)
goto ret_yes;
else
goto ret_no;
}
/* As a last resort, use string comparison */
DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Any\n"));
rpp_xpush_2(d, e);
Perl_pp_seq(aTHX);
{
bool ok = SvTRUEx(PL_stack_sp[0]);
rpp_popfree_1_NN();
if (ok)
goto ret_yes;
else
goto ret_no;
}
ret_no:
rpp_replace_2_IMM_NN(&PL_sv_no);
return NORMAL;
ret_yes:
rpp_replace_2_IMM_NN(&PL_sv_yes);
return NORMAL;
}
static void
_invoke_defer_block(pTHX_ U8 type, void *_arg)
{

1
pp_proto.h generated
View File

@ -265,6 +265,7 @@ PERL_CALLCONV PP(pp_shutdown) __attribute__visibility__("hidden");
PERL_CALLCONV PP(pp_sin) __attribute__visibility__("hidden");
PERL_CALLCONV PP(pp_sle) __attribute__visibility__("hidden");
PERL_CALLCONV PP(pp_sleep) __attribute__visibility__("hidden");
PERL_CALLCONV PP(pp_smartmatch) __attribute__visibility__("hidden");
PERL_CALLCONV PP(pp_sne) __attribute__visibility__("hidden");
PERL_CALLCONV PP(pp_socket) __attribute__visibility__("hidden");
PERL_CALLCONV PP(pp_sockpair) __attribute__visibility__("hidden");

32
proto.h generated
View File

@ -6458,6 +6458,13 @@ 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__
__attribute__visibility__("hidden");
# define PERL_ARGS_ASSERT_CK_SMARTMATCH \
assert(o)
PERL_CALLCONV OP *
Perl_ck_sort(pTHX_ OP *o)
__attribute__warn_unused_result__
@ -7413,6 +7420,10 @@ S_process_special_blocks(pTHX_ I32 floor, const char * const fullname, GV * cons
assert(fullname); assert(gv); assert(cv); \
assert(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM)
STATIC OP *
S_ref_array_or_hash(pTHX_ OP *cond);
# define PERL_ARGS_ASSERT_REF_ARRAY_OR_HASH
STATIC OP *
S_refkids(pTHX_ OP *o, I32 type);
# define PERL_ARGS_ASSERT_REFKIDS
@ -7735,6 +7746,15 @@ 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);
# define PERL_ARGS_ASSERT_DO_SMARTMATCH
STATIC OP *
S_docatch(pTHX_ Perl_ppaddr_t firstpp)
__attribute__warn_unused_result__;
@ -7777,6 +7797,18 @@ S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32 startingblock)
# define PERL_ARGS_ASSERT_DOPOPTOSUB_AT \
assert(cxstk)
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__;

2
regen/opcodes
View File

@ -178,6 +178,8 @@ complement 1's complement (~) ck_bitop fst1 S
ncomplement numeric 1's complement (~) ck_bitop fsT1 S
scomplement string 1's complement (~) ck_null fsT1 S
smartmatch smart match ck_smartmatch s2
# High falutin' math.
atan2 atan2 ck_fun fsT@ S S

1
regen/overload.pl
View File

@ -202,5 +202,6 @@ repeat (x
repeat_ass (x=
concat (.
concat_ass (.=
smart (~~
ftest (-X
regexp (qr

1
sv.c
View File

@ -17555,6 +17555,7 @@ S_find_uninit_var(pTHX_ const OP *const obase, const SV *const uninit_sv,
case OP_DOFILE:
case OP_PROTOTYPE:
case OP_NCMP:
case OP_SMARTMATCH:
case OP_UNPACK:
case OP_SYSOPEN:
case OP_SYSSEEK:

6
t/comp/parser.t
View File

@ -558,6 +558,12 @@ eval{$1=eval{a:}};
eval "map+map";
eval "grep+grep";
# ALso failed an assertion [perl #123848]
{
local $SIG{__WARN__} = sub{};
eval 'my $_; m// ~~ 0';
}
# Used to crash [perl #125679]
eval 'BEGIN {$^H=-1} \eval=time';

7
t/lib/warnings/9uninit
View File

@ -1950,6 +1950,13 @@ $v = 1 + prototype $fn;
EXPECT
Use of uninitialized value in addition (+) at - line 4.
########
use warnings 'uninitialized'; no warnings 'deprecated';
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 = "";

18
t/lib/warnings/op
View File

@ -418,6 +418,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; # OP_NCMP
"dsatrewq";
"diatrewq";
@ -468,14 +469,15 @@ Useless use of getgrgid in void context at - line 51.
Useless use of getpwnam in void context at - line 52.
Useless use of getpwuid in void context at - line 53.
Useless use of subroutine prototype in void context at - line 54.
Useless use of numeric comparison (<=>) in void context at - line 55.
Useless use of a constant ("dsatrewq") in void context at - line 56.
Useless use of a constant ("diatrewq") in void context at - line 57.
Useless use of a constant ("igatrewq") in void context at - line 58.
Useless use of numeric le (<=) in void context at - line 59.
Useless use of __SUB__ in void context at - line 61.
Useless use of anonymous array ([]) in void context at - line 62.
Useless use of comparison chaining in void context at - line 64.
Useless use of smart match in void context at - line 55.
Useless use of numeric comparison (<=>) in void context at - line 56.
Useless use of a constant ("dsatrewq") in void context at - line 57.
Useless use of a constant ("diatrewq") in void context at - line 58.
Useless use of a constant ("igatrewq") in void context at - line 59.
Useless use of numeric le (<=) in void context at - line 60.
Useless use of __SUB__ in void context at - line 62.
Useless use of anonymous array ([]) in void context at - line 63.
Useless use of comparison chaining in void context at - line 65.
########
# op.c
use warnings 'scalar' ; close STDIN ;

2
t/lib/warnings/utf8
View File

@ -779,7 +779,7 @@ BEGIN{
}
no warnings;
use warnings 'utf8';
for(uc 0..t){pack("UXc",exp) == 0}
for(uc 0..t){0~~pack"UXc",exp}
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 pack at - line 9.

592
t/op/smartmatch.t Normal file
View File

@ -0,0 +1,592 @@
#!./perl
BEGIN {
chdir 't' if -d 't';
require './test.pl';
set_up_inc('../lib');
}
use strict;
use warnings;
no warnings 'uninitialized';
no warnings 'deprecated'; # smartmatch is deprecated and will be removed in 5.042
++$|;
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=deprecated" ] },
"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;
}
}
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=deprecated" ] },
"don't qr-ify left-side match against a stacked argument");
fresh_perl_is('print(0->[0 ~~ (0 =~ qr/1/)])', '',
{ switches => [ "-M-warnings=deprecated" ] },
"don't qr-ify right-side match against a stacked argument");
}
# 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]
undef @keyandmore{qw(not)}
0 @keyandmore{qw(key and more)}
! 2 @keyandmore{qw(key and)}
@fooormore{qw(foo)} @keyandmore{qw(key)}
@fooormore{qw(foo or more)} @keyandmore{qw(key and more)}
# 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

9
t/op/svleak.t
View File

@ -15,7 +15,7 @@ BEGIN {
use Config;
plan tests => 156;
plan tests => 157;
# run some code N times. If the number of SVs at the end of loop N is
# greater than (N-1)*delta at the end of loop 1, we've got a leak
@ -646,6 +646,13 @@ my $refcount;
PERL
}
{
# smartmatch is deprecated and will be removed in 5.042
no warnings 'deprecated';
my $one = 1;
leak 2, 0, sub { 1 ~~ sub { 1 + $one } }, 'Smartmatch doesn\'t leak';
}
# the initial implementation of the require hook had some leaks
sub hook::before { $_[0] = "NoSuchFile2" if $_[0] =~/ NoSuch/;

10
t/op/taint.t
View File

@ -25,7 +25,7 @@ if ($NoTaintSupport) {
exit 0;
}
plan tests => 1057;
plan tests => 1059;
$| = 1;
@ -2454,6 +2454,14 @@ EOF
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 'deprecated';
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");

6
t/op/tie_fetch_count.t
View File

@ -9,7 +9,7 @@ BEGIN {
set_up_inc('../lib');
}
plan (tests => 342);
plan (tests => 343);
use strict;
use warnings;
@ -164,6 +164,10 @@ $dummy = -e -e -e $var ; check_count '-e -e';
$_ = "foo";
$dummy = $var =~ m/ / ; check_count 'm//';
$dummy = $var =~ s/ //; check_count 's///';
{
no warnings 'deprecated';
$dummy = $var ~~ 1 ; check_count '~~';
}
$dummy = $var =~ y/ //; check_count 'y///';
$var = \1;
$dummy = $var =~y/ /-/; check_count '$ref =~ y///';

9
toke.c
View File

@ -6772,6 +6772,15 @@ static int
yyl_tilde(pTHX_ char *s)
{
bool bof;
if (s[1] == '~' && (PL_expect == XOPERATOR || PL_expect == XTERMORDORDOR)) {
if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
TOKEN(0);
s += 2;
Perl_ck_warner_d(aTHX_
packWARN(WARN_DEPRECATED__SMARTMATCH),
"Smartmatch is deprecated");
NCEop(OP_SMARTMATCH);
}
s++;
if ((bof = FEATURE_BITWISE_IS_ENABLED) && *s == '.') {
s++;