From a215a77dd95c2472a6395310fd80580c750260c2 Mon Sep 17 00:00:00 2001 From: Tony Cook Date: Mon, 18 Nov 2024 14:47:33 +1100 Subject: [PATCH] Revert "switch removal: remove smartmatch" This reverts commit cb2167d3785e61e23819ca2c58ac1e89d5e4bf3b. --- MANIFEST | 1 + embed.fnc | 10 + embed.h | 6 + ext/Opcode/Opcode.pm | 2 + lib/B/Deparse.pm | 12 +- lib/B/Op_private.pm | 1 + lib/overload.pm | 38 ++- lib/overload.t | 31 +- lib/overload/numbers.pm | 2 + op.c | 65 +++++ opcode.h | 9 +- opnames.h | 625 ++++++++++++++++++++-------------------- overload.h | 5 +- overload.inc | 2 + pod/perlcheat.pod | 4 +- pod/perldiag.pod | 14 + pod/perlop.pod | 295 ++++++++++++++++++- pp_ctl.c | 514 +++++++++++++++++++++++++++++++++ pp_proto.h | 1 + proto.h | 32 ++ regen/opcodes | 2 + regen/overload.pl | 1 + sv.c | 1 + t/comp/parser.t | 6 + t/lib/warnings/9uninit | 7 + t/lib/warnings/op | 18 +- t/lib/warnings/utf8 | 2 +- t/op/smartmatch.t | 592 +++++++++++++++++++++++++++++++++++++ t/op/svleak.t | 9 +- t/op/taint.t | 10 +- t/op/tie_fetch_count.t | 6 +- toke.c | 9 + 32 files changed, 1994 insertions(+), 338 deletions(-) create mode 100644 t/op/smartmatch.t diff --git a/MANIFEST b/MANIFEST index 0f031d70c4..a8e85831de 100644 --- a/MANIFEST +++ b/MANIFEST @@ -6432,6 +6432,7 @@ t/op/signatures.t See if sub signatures work t/op/sigsystem.t See if system and SIGCHLD handlers play together nicely t/op/sleep.t See if sleep works t/op/smartkve.t See if smart deref for keys/values/each works +t/op/smartmatch.t See if the ~~ operator works t/op/sort.t See if sort works t/op/splice.t See if splice works t/op/split.t See if split works diff --git a/embed.fnc b/embed.fnc index fad30e306e..e243842764 100644 --- a/embed.fnc +++ b/embed.fnc @@ -4893,6 +4893,8 @@ S |bool |process_special_blocks \ |NN const char * const fullname \ |NN GV * const gv \ |NN CV * const cv +S |OP * |ref_array_or_hash \ + |NULLOK OP *cond S |OP * |refkids |NULLOK OP *o \ |I32 type S |OP * |scalarboolean |NN OP *o @@ -5071,6 +5073,7 @@ p |UV |_to_upper_title_latin1 \ #if defined(PERL_IN_PP_CTL_C) RS |PerlIO *|check_type_and_open \ |NN SV *name +S |void |destroy_matcher|NN PMOP *matcher RSd |OP * |docatch |Perl_ppaddr_t firstpp S |bool |doeval_compile |U8 gimme \ |NULLOK CV *outside \ @@ -5090,6 +5093,13 @@ RS |I32 |dopoptolabel |NN const char *label \ RS |I32 |dopoptoloop |I32 startingblock RS |I32 |dopoptosub_at |NN const PERL_CONTEXT *cxstk \ |I32 startingblock +S |OP * |do_smartmatch |NULLOK HV *seen_this \ + |NULLOK HV *seen_other \ + |const bool copied +RS |PMOP * |make_matcher |NN REGEXP *re +RS |bool |matcher_matches_sv \ + |NN PMOP *matcher \ + |NN SV *sv RST |bool |num_overflow |NV value \ |I32 fldsize \ |I32 frcsize diff --git a/embed.h b/embed.h index 68e5673273..b71a118136 100644 --- a/embed.h +++ b/embed.h @@ -1351,6 +1351,7 @@ # define ck_scmp(a) Perl_ck_scmp(aTHX_ a) # define ck_select(a) Perl_ck_select(aTHX_ a) # define ck_shift(a) Perl_ck_shift(aTHX_ a) +# define ck_smartmatch(a) Perl_ck_smartmatch(aTHX_ a) # define ck_sort(a) Perl_ck_sort(aTHX_ a) # define ck_spair(a) Perl_ck_spair(aTHX_ a) # define ck_split(a) Perl_ck_split(aTHX_ a) @@ -1556,6 +1557,7 @@ # define opslab_slot_offset S_opslab_slot_offset # define pmtrans(a,b,c) S_pmtrans(aTHX_ a,b,c) # define process_special_blocks(a,b,c,d) S_process_special_blocks(aTHX_ a,b,c,d) +# define ref_array_or_hash(a) S_ref_array_or_hash(aTHX_ a) # define refkids(a,b) S_refkids(aTHX_ a,b) # define scalar_mod_type S_scalar_mod_type # define scalarboolean(a) S_scalarboolean(aTHX_ a) @@ -1631,6 +1633,8 @@ # endif # if defined(PERL_IN_PP_CTL_C) # define check_type_and_open(a) S_check_type_and_open(aTHX_ a) +# define destroy_matcher(a) S_destroy_matcher(aTHX_ a) +# define do_smartmatch(a,b,c) S_do_smartmatch(aTHX_ a,b,c) # define docatch(a) S_docatch(aTHX_ a) # define doeval_compile(a,b,c,d) S_doeval_compile(aTHX_ a,b,c,d) # define dofindlabel(a,b,c,d,e,f) S_dofindlabel(aTHX_ a,b,c,d,e,f) @@ -1639,6 +1643,8 @@ # define dopoptolabel(a,b,c) S_dopoptolabel(aTHX_ a,b,c) # define dopoptoloop(a) S_dopoptoloop(aTHX_ a) # define dopoptosub_at(a,b) S_dopoptosub_at(aTHX_ a,b) +# define make_matcher(a) S_make_matcher(aTHX_ a) +# define matcher_matches_sv(a,b) S_matcher_matches_sv(aTHX_ a,b) # define num_overflow S_num_overflow # define path_is_searchable S_path_is_searchable # define run_user_filter(a,b,c) S_run_user_filter(aTHX_ a,b,c) diff --git a/ext/Opcode/Opcode.pm b/ext/Opcode/Opcode.pm index 11b116c8c5..7ad39a89f5 100644 --- a/ext/Opcode/Opcode.pm +++ b/ext/Opcode/Opcode.pm @@ -436,6 +436,8 @@ These are a hotchpotch of opcodes still waiting to be considered entertry leavetry -- can be used to 'hide' fatal errors entertrycatch poptry catch leavetrycatch -- similar + smartmatch + pushdefer custom -- where should this go diff --git a/lib/B/Deparse.pm b/lib/B/Deparse.pm index f7ebf6cea1..3a24fda168 100644 --- a/lib/B/Deparse.pm +++ b/lib/B/Deparse.pm @@ -3169,6 +3169,16 @@ sub pp_padsv_store { return $self->maybe_parens("$var = $val", $cx, 7); } +sub pp_smartmatch { + my ($self, $op, $cx) = @_; + if (($op->flags & OPf_SPECIAL) && $self->{expand} < 2) { + return $self->deparse($op->last, $cx); + } + else { + binop(@_, "~~", 14); + } +} + # '.' is special because concats-of-concats are optimized to save copying # by making all but the first concat stacked. The effect is as if the # programmer had written '($a . $b) .= $c', except legal. @@ -5194,7 +5204,7 @@ sub retscalar { |i_subtract|concat|multiconcat|stringify|left_shift|right_shift|lt |i_lt|gt|i_gt|le|i_le|ge|i_ge|eq|i_eq|ne|i_ne|ncmp|i_ncmp |slt|sgt|sle|sge|seq|sne|scmp|[sn]?bit_(?:and|x?or)|negate - |i_negate|not|[sn]?complement|atan2|sin|cos + |i_negate|not|[sn]?complement|smartmatch|atan2|sin|cos |rand|srand|exp|log|sqrt|int|hex|oct|abs|length|substr |vec|index|rindex|sprintf|formline|ord|chr|crypt|ucfirst |lcfirst|uc|lc|quotemeta|aelemfast|aelem|exists|helem diff --git a/lib/B/Op_private.pm b/lib/B/Op_private.pm index d4a4869d38..79f246d61b 100644 --- a/lib/B/Op_private.pm +++ b/lib/B/Op_private.pm @@ -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]); diff --git a/lib/overload.pm b/lib/overload.pm index cb699a16d4..03ad240a9c 100644 --- a/lib/overload.pm +++ b/lib/overload.pm @@ -3,7 +3,7 @@ package overload; use strict; no strict 'refs'; -our $VERSION = '1.39'; +our $VERSION = '1.40'; our %ops = ( with_assign => "+ - * / % ** << >> x .", @@ -376,6 +376,7 @@ hash C<%overload::ops>: iterators => '<>', filetest => '-X', dereferencing => '${} @{} %{} &{} *{}', + matching => '~~', special => 'nomethod fallback =', Most of the overloadable operators map one-to-one to these keys. @@ -519,6 +520,37 @@ result of the last C, C or unoverloaded filetest. This overload was introduced in Perl 5.12. +=item * I + +The key C<"~~"> allows you to override the smart matching logic used by +the C<~~> operator and the switch construct (C/C). See +L and L. + +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 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 for +details of when overloading is invoked. + =item * I ${} @{} %{} &{} *{} @@ -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 +implementations - see Dereferencing), and for C<~~> (which has its +own set of rules - see C under L above). Note on Step 7: some operators have a different semantic depending diff --git a/lib/overload.t b/lib/overload.t index afe76d707c..7f8cb48a7d 100644 --- a/lib/overload.t +++ b/lib/overload.t @@ -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"); +} diff --git a/lib/overload/numbers.pm b/lib/overload/numbers.pm index bc1ffb4251..9a6f457e52 100644 --- a/lib/overload/numbers.pm +++ b/lib/overload/numbers.pm @@ -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 #; diff --git a/op.c b/op.c index 33b98cc957..0716e9d0f8 100644 --- a/op.c +++ b/op.c @@ -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) diff --git a/opcode.h b/opcode.h index c292061121..6aa0c4a6e9 100644 --- a/opcode.h +++ b/opcode.h @@ -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), diff --git a/opnames.h b/opnames.h index b12553c8ff..eaf342c0e4 100644 --- a/opnames.h +++ b/opnames.h @@ -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 =cut */ -#define MAXO 419 +#define MAXO 420 #define OP_FREED MAXO /* the OP_IS_* macros are optimized to a simple range check because diff --git a/overload.h b/overload.h index a9d6bfbe7f..cb2e9f1d02 100644 --- a/overload.h +++ b/overload.h @@ -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. */ }; diff --git a/overload.inc b/overload.inc index 64d8022bae..34c3fc0010 100644 --- a/overload.inc +++ b/overload.inc @@ -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" }; diff --git a/pod/perlcheat.pod b/pod/perlcheat.pod index b7e0f903ea..797e333b62 100644 --- a/pod/perlcheat.pod +++ b/pod/perlcheat.pod @@ -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 diff --git a/pod/perldiag.pod b/pod/perldiag.pod index e3746d9f52..3d4162f637 100644 --- a/pod/perldiag.pod +++ b/pod/perldiag.pod @@ -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 diff --git a/pod/perlop.pod b/pod/perlop.pod index 925f2824b6..aa73309509 100644 --- a/pod/perlop.pod +++ b/pod/perlop.pod @@ -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 -The two-sided ordering operators C<"E=E"> 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=E"> 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 locale if a S (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 construct described in L, although +not all C clauses call the smartmatch operator. Unique among all of +Perl's operators, the smartmatch operator can recurse. The smartmatch +operator is L 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 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 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> and C> entries apply in those cases. +For blessed references, the C> 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 does +not. Also, C 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 +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>, 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 clause. See the section on "Switch Statements" in L. + +=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". 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. + +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 operator returns. That +means that + + $object ~~ X + +does I invoke the overload method with C> as an argument. +Instead the above table is consulted as normal, and based on the type of +C>, 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 X X<&> diff --git a/pp_ctl.c b/pp_ctl.c index 0e39d16209..c949a52962 100644 --- a/pp_ctl.c +++ b/pp_ctl.c @@ -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) { diff --git a/pp_proto.h b/pp_proto.h index 574632667e..31b9242cdc 100644 --- a/pp_proto.h +++ b/pp_proto.h @@ -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"); diff --git a/proto.h b/proto.h index 3c4249bd54..46a9ae7e1b 100644 --- a/proto.h +++ b/proto.h @@ -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__; diff --git a/regen/opcodes b/regen/opcodes index d3b7573642..a2676d8aa8 100644 --- a/regen/opcodes +++ b/regen/opcodes @@ -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 diff --git a/regen/overload.pl b/regen/overload.pl index 9496b7d369..cbd01b5d1b 100644 --- a/regen/overload.pl +++ b/regen/overload.pl @@ -202,5 +202,6 @@ repeat (x repeat_ass (x= concat (. concat_ass (.= +smart (~~ ftest (-X regexp (qr diff --git a/sv.c b/sv.c index 3299315a63..89ef063c05 100644 --- a/sv.c +++ b/sv.c @@ -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: diff --git a/t/comp/parser.t b/t/comp/parser.t index 20ecc7ac11..dbd5ecc842 100644 --- a/t/comp/parser.t +++ b/t/comp/parser.t @@ -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'; diff --git a/t/lib/warnings/9uninit b/t/lib/warnings/9uninit index 53e05e8a50..949e0b755a 100644 --- a/t/lib/warnings/9uninit +++ b/t/lib/warnings/9uninit @@ -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 = ""; diff --git a/t/lib/warnings/op b/t/lib/warnings/op index 336890bd5c..8a03e440a5 100644 --- a/t/lib/warnings/op +++ b/t/lib/warnings/op @@ -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 ; diff --git a/t/lib/warnings/utf8 b/t/lib/warnings/utf8 index 67d36ada6f..49fa4e404f 100644 --- a/t/lib/warnings/utf8 +++ b/t/lib/warnings/utf8 @@ -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. diff --git a/t/op/smartmatch.t b/t/op/smartmatch.t new file mode 100644 index 0000000000..ca85d15785 --- /dev/null +++ b/t/op/smartmatch.t @@ -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 () { + 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 diff --git a/t/op/svleak.t b/t/op/svleak.t index 8b2a35c085..da7bd6e2b0 100644 --- a/t/op/svleak.t +++ b/t/op/svleak.t @@ -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/; diff --git a/t/op/taint.t b/t/op/taint.t index 1e7a3e47de..a884a3e477 100644 --- a/t/op/taint.t +++ b/t/op/taint.t @@ -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"); diff --git a/t/op/tie_fetch_count.t b/t/op/tie_fetch_count.t index 2b79f34e5e..86505f6eba 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 => 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///'; diff --git a/toke.c b/toke.c index 0d45a3b017..0dd398356e 100644 --- a/toke.c +++ b/toke.c @@ -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++;