(perl #130705) don't convert match with argument to qr
[perl.git] / t / op / smartmatch.t
1 #!./perl
2
3 BEGIN {
4     chdir 't' if -d 't';
5     require './test.pl';
6     set_up_inc('../lib');
7 }
8 use strict;
9 use warnings;
10 no warnings 'uninitialized';
11 no warnings 'experimental::smartmatch';
12
13 ++$|;
14
15 use Tie::Array;
16 use Tie::Hash;
17
18 # Predeclare vars used in the tests:
19 my @empty;
20 my %empty;
21 my @sparse; $sparse[2] = 2;
22
23 my $deep1 = []; push @$deep1, $deep1;
24 my $deep2 = []; push @$deep2, $deep2;
25
26 my @nums = (1..10);
27 tie my @tied_nums, 'Tie::StdArray';
28 @tied_nums =  (1..10);
29
30 my %hash = (foo => 17, bar => 23);
31 tie my %tied_hash, 'Tie::StdHash';
32 %tied_hash = %hash;
33
34 {
35     package Test::Object::NoOverload;
36     sub new { bless { key => 1 } }
37 }
38
39 {
40     package Test::Object::StringOverload;
41     use overload '""' => sub { "object" }, fallback => 1;
42     sub new { bless { key => 1 } }
43 }
44
45 {
46     package Test::Object::WithOverload;
47     sub new { bless { key => ($_[1] // 'magic') } }
48     use overload '~~' => sub {
49         my %hash = %{ $_[0] };
50         if ($_[2]) { # arguments reversed ?
51             return $_[1] eq reverse $hash{key};
52         }
53         else {
54             return $_[1] eq $hash{key};
55         }
56     };
57     use overload '""' => sub { "stringified" };
58     use overload 'eq' => sub {"$_[0]" eq "$_[1]"};
59 }
60
61 our $ov_obj = Test::Object::WithOverload->new;
62 our $ov_obj_2 = Test::Object::WithOverload->new("object");
63 our $obj = Test::Object::NoOverload->new;
64 our $str_obj = Test::Object::StringOverload->new;
65
66 my %refh;
67 unless (is_miniperl()) {
68     require Tie::RefHash;
69     tie %refh, 'Tie::RefHash';
70     $refh{$ov_obj} = 1;
71 }
72
73 my @keyandmore = qw(key and more);
74 my @fooormore = qw(foo or more);
75 my %keyandmore = map { $_ => 0 } @keyandmore;
76 my %fooormore = map { $_ => 0 } @fooormore;
77
78 # Load and run the tests
79 plan tests => 349+4;
80
81 while (<DATA>) {
82   SKIP: {
83     next if /^#/ || !/\S/;
84     chomp;
85     my ($yn, $left, $right, $note) = split /\t+/;
86
87     local $::TODO = $note =~ /TODO/;
88
89     die "Bad test spec: ($yn, $left, $right)" if $yn =~ /[^!@=]/;
90
91     my $tstr = "$left ~~ $right";
92
93     test_again:
94     my $res;
95     if ($note =~ /NOWARNINGS/) {
96         $res = eval "no warnings; $tstr";
97     }
98     else {
99         skip_if_miniperl("Doesn't work with miniperl", $yn =~ /=/ ? 2 : 1)
100             if $note =~ /MINISKIP/;
101         $res = eval $tstr;
102     }
103
104     chomp $@;
105
106     if ( $yn =~ /@/ ) {
107         ok( $@ ne '', "$tstr dies" )
108             and print "# \$\@ was: $@\n";
109     } else {
110         my $test_name = $tstr . ($yn =~ /!/ ? " does not match" : " matches");
111         if ( $@ ne '' ) {
112             fail($test_name);
113             print "# \$\@ was: $@\n";
114         } else {
115             ok( ($yn =~ /!/ xor $res), $test_name );
116         }
117     }
118
119     if ( $yn =~ s/=// ) {
120         $tstr = "$right ~~ $left";
121         goto test_again;
122     }
123   }
124 }
125
126 sub foo {}
127 sub bar {42}
128 sub gorch {42}
129 sub fatal {die "fatal sub\n"}
130
131 # to test constant folding
132 sub FALSE() { 0 }
133 sub TRUE() { 1 }
134 sub NOT_DEF() { undef }
135
136 {
137   # [perl #123860]
138   # this can but might not crash
139   # This can but might not crash
140   #
141   # The second smartmatch would leave a &PL_sv_no on the stack for
142   # each key it checked in %!, this could then cause various types of
143   # crash or assertion failure.
144   #
145   # This isn't guaranteed to crash, but if the stack issue is
146   # re-introduced it will probably crash in one of the many smoke
147   # builds.
148   fresh_perl_is('print (q(x) ~~ q(x)) | (/x/ ~~ %!)', "1",
149                 { switches => [ "-MErrno", "-M-warnings=experimental::smartmatch" ] },
150                  "don't fill the stack with rubbish");
151 }
152
153 {
154     # [perl #123860] continued;
155     # smartmatch was failing to SPAGAIN after pushing an SV and calling
156     # pp_match, which may have resulted in the stack being realloced
157     # in the meantime. Test this by filling the stack with pregressively
158     # larger amounts of data. At some point the stack will get realloced.
159     my @a = qw(x);
160     my %h = qw(x 1);
161     my @args;
162     my $x = 1;
163     my $bad = -1;
164     for (1..1000)  {
165         push @args, $_;
166         my $exp_n  = join '-',  (@args, $x == 0);
167         my $exp_y  = join '-',  (@args, $x == 1);
168
169         my $got_an = join '-',  (@args, (/X/ ~~ @a));
170         my $got_ay = join '-',  (@args, (/x/ ~~ @a));
171         my $got_hn = join '-',  (@args, (/X/ ~~ %h));
172         my $got_hy = join '-',  (@args, (/x/ ~~ %h));
173
174         if (   $exp_n ne $got_an || $exp_n ne $got_hn
175             || $exp_y ne $got_ay || $exp_y ne $got_hy
176         ) {
177             $bad = $_;
178             last;
179         }
180     }
181     is($bad, -1, "RT 123860: stack realloc");
182 }
183
184
185 {
186     # [perl #130705]
187     # Perl_ck_smartmatch would turn the match in:
188     # 0 =~ qr/1/ ~~ 0  # parsed as (0 =~ qr/1/) ~~ 0
189     # into a qr, leaving the initial 0 on the stack after execution
190     #
191     # Similarly for: 0 ~~ (0 =~ qr/1/)
192     #
193     # Either caused an assertion failure in the context of warn (or print)
194     # if there was some other operator's arguments left on the stack, as with
195     # the test cases.
196     fresh_perl_is('print(0->[0 =~ qr/1/ ~~ 0])', '',
197                   { switches => [ "-M-warnings=experimental::smartmatch" ] },
198                   "don't qr-ify left-side match against a stacked argument");
199     fresh_perl_is('print(0->[0 ~~ (0 =~ qr/1/)])', '',
200                   { switches => [ "-M-warnings=experimental::smartmatch" ] },
201                   "don't qr-ify right-side match against a stacked argument");
202 }
203
204 # Prefix character :
205 #   - expected to match
206 # ! - expected to not match
207 # @ - expected to be a compilation failure
208 # = - expected to match symmetrically (runs test twice)
209 # Data types to test :
210 #   undef
211 #   Object-overloaded
212 #   Object
213 #   Coderef
214 #   Hash
215 #   Hashref
216 #   Array
217 #   Arrayref
218 #   Tied arrays and hashes
219 #   Arrays that reference themselves
220 #   Regex (// and qr//)
221 #   Range
222 #   Num
223 #   Str
224 # Other syntactic items of interest:
225 #   Constants
226 #   Values returned by a sub call
227 __DATA__
228 # Any ~~ undef
229 !       $ov_obj         undef
230 !       $obj            undef
231 !       sub {}          undef
232 !       %hash           undef
233 !       \%hash          undef
234 !       {}              undef
235 !       @nums           undef
236 !       \@nums          undef
237 !       []              undef
238 !       %tied_hash      undef
239 !       @tied_nums      undef
240 !       $deep1          undef
241 !       /foo/           undef
242 !       qr/foo/         undef
243 !       21..30          undef
244 !       189             undef
245 !       "foo"           undef
246 !       ""              undef
247 !       !1              undef
248         undef           undef
249         (my $u)         undef
250         NOT_DEF         undef
251         &NOT_DEF        undef
252
253 # Any ~~ object overloaded
254 !       \&fatal         $ov_obj
255         'cigam'         $ov_obj
256 !       'cigam on'      $ov_obj
257 !       ['cigam']       $ov_obj
258 !       ['stringified'] $ov_obj
259 !       { cigam => 1 }  $ov_obj
260 !       { stringified => 1 }    $ov_obj
261 !       $obj            $ov_obj
262 !       undef           $ov_obj
263
264 # regular object
265 @       $obj            $obj
266 @       $ov_obj         $obj
267 =@      \&fatal         $obj
268 @       \&FALSE         $obj
269 @       \&foo           $obj
270 @       sub { 1 }       $obj
271 @       sub { 0 }       $obj
272 @       %keyandmore     $obj
273 @       {"key" => 1}    $obj
274 @       @fooormore      $obj
275 @       ["key" => 1]    $obj
276 @       /key/           $obj
277 @       qr/key/         $obj
278 @       "key"           $obj
279 @       FALSE           $obj
280
281 # regular object with "" overload
282 @       $obj            $str_obj
283 =@      \&fatal         $str_obj
284 @       \&FALSE         $str_obj
285 @       \&foo           $str_obj
286 @       sub { 1 }       $str_obj
287 @       sub { 0 }       $str_obj
288 @       %keyandmore     $str_obj
289 @       {"object" => 1} $str_obj
290 @       @fooormore      $str_obj
291 @       ["object" => 1] $str_obj
292 @       /object/        $str_obj
293 @       qr/object/      $str_obj
294 @       "object"        $str_obj
295 @       FALSE           $str_obj
296 # Those will treat the $str_obj as a string because of fallback:
297
298 # object (overloaded or not) ~~ Any
299         $obj            qr/NoOverload/
300         $ov_obj         qr/^stringified$/
301 =       "$ov_obj"       "stringified"
302 =       "$str_obj"      "object"
303 !=      $ov_obj         "stringified"
304         $str_obj        "object"
305         $ov_obj         'magic'
306 !       $ov_obj         'not magic'
307
308 # ~~ Coderef
309         sub{0}          sub { ref $_[0] eq "CODE" }
310         %fooormore      sub { $_[0] =~ /^(foo|or|more)$/ }
311 !       %fooormore      sub { $_[0] =~ /^(foo|or|less)$/ }
312         \%fooormore     sub { $_[0] =~ /^(foo|or|more)$/ }
313 !       \%fooormore     sub { $_[0] =~ /^(foo|or|less)$/ }
314         +{%fooormore}   sub { $_[0] =~ /^(foo|or|more)$/ }
315 !       +{%fooormore}   sub { $_[0] =~ /^(foo|or|less)$/ }
316         @fooormore      sub { $_[0] =~ /^(foo|or|more)$/ }
317 !       @fooormore      sub { $_[0] =~ /^(foo|or|less)$/ }
318         \@fooormore     sub { $_[0] =~ /^(foo|or|more)$/ }
319 !       \@fooormore     sub { $_[0] =~ /^(foo|or|less)$/ }
320         [@fooormore]    sub { $_[0] =~ /^(foo|or|more)$/ }
321 !       [@fooormore]    sub { $_[0] =~ /^(foo|or|less)$/ }
322         %fooormore      sub{@_==1}
323         @fooormore      sub{@_==1}
324         "foo"           sub { $_[0] =~ /^(foo|or|more)$/ }
325 !       "more"          sub { $_[0] =~ /^(foo|or|less)$/ }
326         /fooormore/     sub{ref $_[0] eq 'Regexp'}
327         qr/fooormore/   sub{ref $_[0] eq 'Regexp'}
328         1               sub{shift}
329 !       0               sub{shift}
330 !       undef           sub{shift}
331         undef           sub{not shift}
332         NOT_DEF         sub{not shift}
333         &NOT_DEF        sub{not shift}
334         FALSE           sub{not shift}
335         [1]             \&bar
336         {a=>1}          \&bar
337         qr//            \&bar
338 !       [1]             \&foo
339 !       {a=>1}          \&foo
340         $obj            sub { ref($_[0]) =~ /NoOverload/ }
341         $ov_obj         sub { ref($_[0]) =~ /WithOverload/ }
342 # empty stuff matches, because the sub is never called:
343         []              \&foo
344         {}              \&foo
345         @empty          \&foo
346         %empty          \&foo
347 !       qr//            \&foo
348 !       undef           \&foo
349         undef           \&bar
350 @       undef           \&fatal
351 @       1               \&fatal
352 @       [1]             \&fatal
353 @       {a=>1}          \&fatal
354 @       "foo"           \&fatal
355 @       qr//            \&fatal
356 # sub is not called on empty hashes / arrays
357         []              \&fatal
358         +{}             \&fatal
359         @empty          \&fatal
360         %empty          \&fatal
361 # sub is not special on the left
362         sub {0}         qr/^CODE/
363         sub {0}         sub { ref shift eq "CODE" }
364
365 # HASH ref against:
366 #   - another hash ref
367         {}              {}
368 =!      {}              {1 => 2}
369         {1 => 2}        {1 => 2}
370         {1 => 2}        {1 => 3}
371 =!      {1 => 2}        {2 => 3}
372 =       \%main::        {map {$_ => 'x'} keys %main::}
373
374 #  - tied hash ref
375 =       \%hash          \%tied_hash
376         \%tied_hash     \%tied_hash
377 !=      {"a"=>"b"}      \%tied_hash
378 =       %hash           %tied_hash
379         %tied_hash      %tied_hash
380 !=      {"a"=>"b"}      %tied_hash
381         $ov_obj         %refh           MINISKIP
382 !       "$ov_obj"       %refh           MINISKIP
383         [$ov_obj]       %refh           MINISKIP
384 !       ["$ov_obj"]     %refh           MINISKIP
385         %refh           %refh           MINISKIP
386
387 #  - an array ref
388 #  (since this is symmetrical, tests as well hash~~array)
389 =       [keys %main::]  \%::
390 =       [qw[STDIN STDOUT]]      \%::
391 =!      []              \%::
392 =!      [""]            {}
393 =!      []              {}
394 =!      @empty          {}
395 =       [undef]         {"" => 1}
396 =       [""]            {"" => 1}
397 =       ["foo"]         { foo => 1 }
398 =       ["foo", "bar"]  { foo => 1 }
399 =       ["foo", "bar"]  \%hash
400 =       ["foo"]         \%hash
401 =!      ["quux"]        \%hash
402 =       [qw(foo quux)]  \%hash
403 =       @fooormore      { foo => 1, or => 2, more => 3 }
404 =       @fooormore      %fooormore
405 =       @fooormore      \%fooormore
406 =       \@fooormore     %fooormore
407
408 #  - a regex
409 =       qr/^(fo[ox])$/          {foo => 1}
410 =       /^(fo[ox])$/            %fooormore
411 =!      qr/[13579]$/            +{0..99}
412 =!      qr/a*/                  {}
413 =       qr/a*/                  {b=>2}
414 =       qr/B/i                  {b=>2}
415 =       /B/i                    {b=>2}
416 =!      qr/a+/                  {b=>2}
417 =       qr/^à/                 {"à"=>2}
418
419 #  - a scalar
420         "foo"           +{foo => 1, bar => 2}
421         "foo"           %fooormore
422 !       "baz"           +{foo => 1, bar => 2}
423 !       "boz"           %fooormore
424 !       1               +{foo => 1, bar => 2}
425 !       1               %fooormore
426         1               { 1 => 3 }
427         1.0             { 1 => 3 }
428 !       "1.0"           { 1 => 3 }
429 !       "1.0"           { 1.0 => 3 }
430         "1.0"           { "1.0" => 3 }
431         "à"            { "à" => "À" }
432
433 #  - undef
434 !       undef           { hop => 'zouu' }
435 !       undef           %hash
436 !       undef           +{"" => "empty key"}
437 !       undef           {}
438
439 # ARRAY ref against:
440 #  - another array ref
441         []                      []
442 =!      []                      [1]
443         [["foo"], ["bar"]]      [qr/o/, qr/a/]
444 !       [["foo"], ["bar"]]      [qr/ARRAY/, qr/ARRAY/]
445         ["foo", "bar"]          [qr/o/, qr/a/]
446 !       [qr/o/, qr/a/]          ["foo", "bar"]
447         ["foo", "bar"]          [["foo"], ["bar"]]
448 !       ["foo", "bar"]          [qr/o/, "foo"]
449         ["foo", undef, "bar"]   [qr/o/, undef, "bar"]
450 !       ["foo", undef, "bar"]   [qr/o/, "",    "bar"]
451 !       ["foo", "", "bar"]      [qr/o/, undef, "bar"]
452         $deep1                  $deep1
453         @$deep1                 @$deep1
454 !       $deep1                  $deep2
455
456 =       \@nums                  \@tied_nums
457 =       @nums                   \@tied_nums
458 =       \@nums                  @tied_nums
459 =       @nums                   @tied_nums
460
461 #  - an object
462 !       $obj            @fooormore
463         $obj            [sub{ref shift}]
464
465 #  - a regex
466 =       qr/x/           [qw(foo bar baz quux)]
467 =!      qr/y/           [qw(foo bar baz quux)]
468 =       /x/             [qw(foo bar baz quux)]
469 =!      /y/             [qw(foo bar baz quux)]
470 =       /FOO/i          @fooormore
471 =!      /bar/           @fooormore
472
473 # - a number
474         2               [qw(1.00 2.00)]
475         2               [qw(foo 2)]
476         2.0_0e+0        [qw(foo 2)]
477 !       2               [qw(1foo bar2)]
478
479 # - a string
480 !       "2"             [qw(1foo 2bar)]
481         "2bar"          [qw(1foo 2bar)]
482
483 # - undef
484         undef           [1, 2, undef, 4]
485 !       undef           [1, 2, [undef], 4]
486 !       undef           @fooormore
487         undef           @sparse
488         undef           [undef]
489 !       0               [undef]
490 !       ""              [undef]
491 !       undef           [0]
492 !       undef           [""]
493
494 # - nested arrays and ~~ distributivity
495         11              [[11]]
496 !       11              [[12]]
497         "foo"           [{foo => "bar"}]
498 !       "bar"           [{foo => "bar"}]
499
500 # Number against number
501         2               2
502         20              2_0
503 !       2               3
504         0               FALSE
505         3-2             TRUE
506 !       undef           0
507 !       (my $u)         0
508
509 # Number against string
510 =       2               "2"
511 =       2               "2.0"
512 !       2               "2bananas"
513 !=      2_3             "2_3"           NOWARNINGS
514         FALSE           "0"
515 !       undef           "0"
516 !       undef           ""
517
518 # Regex against string
519         "x"             qr/x/
520 !       "x"             qr/y/
521
522 # Regex against number
523         12345           qr/3/
524 !       12345           qr/7/
525
526 # array/hash against string
527         @fooormore      "".\@fooormore
528 !       @keyandmore     "".\@fooormore
529         %fooormore      "".\%fooormore
530 !       %keyandmore     "".\%fooormore
531
532 # Test the implicit referencing
533         7               @nums
534         @nums           \@nums
535 !       @nums           \\@nums
536         @nums           [1..10]
537 !       @nums           [0..9]
538
539         "foo"           %hash
540         /bar/           %hash
541         [qw(bar)]       %hash
542 !       [qw(a b c)]     %hash
543         %hash           %hash
544         %hash           +{%hash}
545         %hash           \%hash
546         %hash           %tied_hash
547         %tied_hash      %tied_hash
548         %hash           { foo => 5, bar => 10 }
549 !       %hash           { foo => 5, bar => 10, quux => 15 }
550
551         @nums           {  1, '',  2, '' }
552         @nums           {  1, '', 12, '' }
553 !       @nums           { 11, '', 12, '' }
554
555 # array slices
556         @nums[0..-1]    []
557         @nums[0..0]     [1]
558 !       @nums[0..1]     [0..2]
559         @nums[0..4]     [1..5]
560
561 !       undef           @nums[0..-1]
562         1               @nums[0..0]
563         2               @nums[0..1]
564 !       @nums[0..1]     2
565
566         @nums[0..1]     @nums[0..1]
567
568 # hash slices
569         @keyandmore{qw(not)}            [undef]
570         @keyandmore{qw(key)}            [0]
571
572         undef                           @keyandmore{qw(not)}
573         0                               @keyandmore{qw(key and more)}
574 !       2                               @keyandmore{qw(key and)}
575
576         @fooormore{qw(foo)}             @keyandmore{qw(key)}
577         @fooormore{qw(foo or more)}     @keyandmore{qw(key and more)}
578
579 # UNDEF
580 !       3               undef
581 !       1               undef
582 !       []              undef
583 !       {}              undef
584 !       \%::main        undef
585 !       [1,2]           undef
586 !       %hash           undef
587 !       @nums           undef
588 !       "foo"           undef
589 !       ""              undef
590 !       !1              undef
591 !       \&foo           undef
592 !       sub { }         undef