t/op/smartmatch.t

   1 #!./perl
   2
   3 BEGIN {
   4     chdir 't';
   5     @INC = '../lib';
   6     require './test.pl';
   7 }
   8 use strict;
   9 use warnings;
  10 no warnings 'uninitialized';
  11
  12 use Tie::Array;
  13 use Tie::Hash;
  14 use Tie::RefHash;
  15
  16 # Predeclare vars used in the tests:
  17 my @empty;
  18 my %empty;
  19 my @sparse; $sparse[2] = 2;
  20
  21 my $deep1 = []; push @$deep1, \$deep1;
  22 my $deep2 = []; push @$deep2, \$deep2;
  23
  24 my @nums = (1..10);
  25 tie my @tied_nums, 'Tie::StdArray';
  26 @tied_nums =  (1..10);
  27
  28 my %hash = (foo => 17, bar => 23);
  29 tie my %tied_hash, 'Tie::StdHash';
  30 %tied_hash = %hash;
  31
  32 {
  33     package Test::Object::NoOverload;
  34     sub new { bless { key => 1 } }
  35 }
  36
  37 {
  38     package Test::Object::StringOverload;
  39     use overload '""' => sub { "object" }, fallback => 1;
  40     sub new { bless { key => 1 } }
  41 }
  42
  43 {
  44     package Test::Object::WithOverload;
  45     sub new { bless { key => ($_[1] // 'magic') } }
  46     use overload '~~' => sub {
  47         my %hash = %{ $_[0] };
  48         if ($_[2]) { # arguments reversed ?
  49             return $_[1] eq reverse $hash{key};
  50         }
  51         else {
  52             return $_[1] eq $hash{key};
  53         }
  54     };
  55     use overload '""' => sub { "stringified" };
  56     use overload 'eq' => sub {"$_[0]" eq "$_[1]"};
  57 }
  58
  59 our $ov_obj = Test::Object::WithOverload->new;
  60 our $ov_obj_2 = Test::Object::WithOverload->new("object");
  61 our $obj = Test::Object::NoOverload->new;
  62 our $str_obj = Test::Object::StringOverload->new;
  63
  64 tie my %refh, 'Tie::RefHash';
  65 $refh{$ov_obj} = 1;
  66
  67 my @keyandmore = qw(key and more);
  68 my @fooormore = qw(foo or more);
  69 my %keyandmore = map { $_ => 0 } @keyandmore;
  70 my %fooormore = map { $_ => 0 } @fooormore;
  71
  72 # Load and run the tests
  73 plan tests => 314;
  74
  75 while (<DATA>) {
  76     next if /^#/ || !/\S/;
  77     chomp;
  78     my ($yn, $left, $right, $note) = split /\t+/;
  79
  80     local $::TODO = $note =~ /TODO/;
  81
  82     die "Bad test spec: ($yn, $left, $right)" if $yn =~ /[^!@=]/;
  83
  84     my $tstr = "$left ~~ $right";
  85
  86     test_again:
  87     my $res;
  88     if ($note =~ /NOWARNINGS/) {
  89         $res = eval "no warnings; $tstr";
  90     }
  91     else {
  92         $res = eval $tstr;
  93     }
  94
  95     chomp $@;
  96
  97     if ( $yn =~ /@/ ) {
  98         ok( $@ ne '', "$tstr dies" )
  99             and print "# \$\@ was: $@\n";
 100     } else {
 101         my $test_name = $tstr . ($yn =~ /!/ ? " does not match" : " matches");
 102         if ( $@ ne '' ) {
 103             fail($test_name);
 104             print "# \$\@ was: $@\n";
 105         } else {
 106             ok( ($yn =~ /!/ xor $res), $test_name );
 107         }
 108     }
 109
 110     if ( $yn =~ s/=// ) {
 111         $tstr = "$right ~~ $left";
 112         goto test_again;
 113     }
 114 }
 115
 116 sub foo {}
 117 sub bar {42}
 118 sub gorch {42}
 119 sub fatal {die "fatal sub\n"}
 120
 121 # to test constant folding
 122 sub FALSE() { 0 }
 123 sub TRUE() { 1 }
 124 sub NOT_DEF() { undef }
 125
 126 # Prefix character :
 127 #   - expected to match
 128 # ! - expected to not match
 129 # @ - expected to be a compilation failure
 130 # = - expected to match symmetrically (runs test twice)
 131 # Data types to test :
 132 #   undef
 133 #   Object-overloaded
 134 #   Object
 135 #   Coderef
 136 #   Hash
 137 #   Hashref
 138 #   Array
 139 #   Arrayref
 140 #   Tied arrays and hashes
 141 #   Arrays that reference themselves
 142 #   Regex (// and qr//)
 143 #   Range
 144 #   Num
 145 #   Str
 146 # Other syntactic items of interest:
 147 #   Constants
 148 #   Values returned by a sub call
 149 __DATA__
 150 # Any ~~ undef
 151 !       $ov_obj         undef
 152 !       $obj            undef
 153 !       sub {}          undef
 154 !       %hash           undef
 155 !       \%hash          undef
 156 !       {}              undef
 157 !       @nums           undef
 158 !       \@nums          undef
 159 !       []              undef
 160 !       %tied_hash      undef
 161 !       @tied_nums      undef
 162 !       $deep1          undef
 163 !       /foo/           undef
 164 !       qr/foo/         undef
 165 !       21..30          undef
 166 !       189             undef
 167 !       "foo"           undef
 168 !       ""              undef
 169 !       !1              undef
 170         undef           undef
 171         (my $u)         undef
 172         NOT_DEF         undef
 173         &NOT_DEF        undef
 174
 175 # Any ~~ object overloaded
 176 !       \&fatal         $ov_obj
 177         'cigam'         $ov_obj
 178 !       'cigam on'      $ov_obj
 179 !       ['cigam']       $ov_obj
 180 !       ['stringified'] $ov_obj
 181 !       { cigam => 1 }  $ov_obj
 182 !       { stringified => 1 }    $ov_obj
 183 !       $obj            $ov_obj
 184 !       undef           $ov_obj
 185
 186 # regular object
 187 @       $obj            $obj
 188 @       $ov_obj         $obj
 189 =@      \&fatal         $obj
 190 @       \&FALSE         $obj
 191 @       \&foo           $obj
 192 @       sub { 1 }       $obj
 193 @       sub { 0 }       $obj
 194 @       %keyandmore     $obj
 195 @       {"key" => 1}    $obj
 196 @       @fooormore      $obj
 197 @       ["key" => 1]    $obj
 198 @       /key/           $obj
 199 @       qr/key/         $obj
 200 @       "key"           $obj
 201 @       FALSE           $obj
 202
 203 # regular object with "" overload
 204 @       $obj            $str_obj
 205 =@      \&fatal         $str_obj
 206 @       \&FALSE         $str_obj
 207 @       \&foo           $str_obj
 208 @       sub { 1 }       $str_obj
 209 @       sub { 0 }       $str_obj
 210 @       %keyandmore     $str_obj
 211 @       {"object" => 1} $str_obj
 212 @       @fooormore      $str_obj
 213 @       ["object" => 1] $str_obj
 214 @       /object/        $str_obj
 215 @       qr/object/      $str_obj
 216 @       "object"        $str_obj
 217 @       FALSE           $str_obj
 218 # Those will treat the $str_obj as a string because of fallback:
 219 !       $ov_obj         $str_obj
 220         $ov_obj_2       $str_obj
 221
 222 # object (overloaded or not) ~~ Any
 223         $obj            qr/NoOverload/
 224         $ov_obj         qr/^stringified$/
 225 =       "$ov_obj"       "stringified"
 226 =       "$str_obj"      "object"
 227 !=      $ov_obj         "stringified"
 228         $str_obj        "object"
 229         $ov_obj         'magic'
 230 !       $ov_obj         'not magic'
 231
 232 # ~~ Coderef
 233         sub{0}          sub { ref $_[0] eq "CODE" }
 234         %fooormore      sub { $_[0] =~ /^(foo|or|more)$/ }
 235 !       %fooormore      sub { $_[0] =~ /^(foo|or|less)$/ }
 236         \%fooormore     sub { $_[0] =~ /^(foo|or|more)$/ }
 237 !       \%fooormore     sub { $_[0] =~ /^(foo|or|less)$/ }
 238         +{%fooormore}   sub { $_[0] =~ /^(foo|or|more)$/ }
 239 !       +{%fooormore}   sub { $_[0] =~ /^(foo|or|less)$/ }
 240         @fooormore      sub { $_[0] =~ /^(foo|or|more)$/ }
 241 !       @fooormore      sub { $_[0] =~ /^(foo|or|less)$/ }
 242         \@fooormore     sub { $_[0] =~ /^(foo|or|more)$/ }
 243 !       \@fooormore     sub { $_[0] =~ /^(foo|or|less)$/ }
 244         [@fooormore]    sub { $_[0] =~ /^(foo|or|more)$/ }
 245 !       [@fooormore]    sub { $_[0] =~ /^(foo|or|less)$/ }
 246         %fooormore      sub{@_==1}
 247         @fooormore      sub{@_==1}
 248         "foo"           sub { $_[0] =~ /^(foo|or|more)$/ }
 249 !       "more"          sub { $_[0] =~ /^(foo|or|less)$/ }
 250         /fooormore/     sub{ref $_[0] eq 'Regexp'}
 251         qr/fooormore/   sub{ref $_[0] eq 'Regexp'}
 252         1               sub{shift}
 253 !       0               sub{shift}
 254 !       undef           sub{shift}
 255         undef           sub{not shift}
 256         NOT_DEF         sub{not shift}
 257         &NOT_DEF        sub{not shift}
 258         FALSE           sub{not shift}
 259         [1]             \&bar
 260         {a=>1}          \&bar
 261         qr//            \&bar
 262 !       [1]             \&foo
 263 !       {a=>1}          \&foo
 264         $obj            sub { ref($_[0]) =~ /NoOverload/ }
 265         $ov_obj         sub { ref($_[0]) =~ /WithOverload/ }
 266 # empty stuff matches, because the sub is never called:
 267         []              \&foo
 268         {}              \&foo
 269         @empty          \&foo
 270         %empty          \&foo
 271 !       qr//            \&foo
 272 !       undef           \&foo
 273         undef           \&bar
 274 @       undef           \&fatal
 275 @       1               \&fatal
 276 @       [1]             \&fatal
 277 @       {a=>1}          \&fatal
 278 @       "foo"           \&fatal
 279 @       qr//            \&fatal
 280 # sub is not called on empty hashes / arrays
 281         []              \&fatal
 282         +{}             \&fatal
 283         @empty          \&fatal
 284         %empty          \&fatal
 285 # sub is not special on the left
 286         sub {0}         qr/^CODE/
 287         sub {0}         sub { ref shift eq "CODE" }
 288
 289 # HASH ref against:
 290 #   - another hash ref
 291         {}              {}
 292 =!      {}              {1 => 2}
 293         {1 => 2}        {1 => 2}
 294         {1 => 2}        {1 => 3}
 295 =!      {1 => 2}        {2 => 3}
 296 =       \%main::        {map {$_ => 'x'} keys %main::}
 297
 298 #  - tied hash ref
 299 =       \%hash          \%tied_hash
 300         \%tied_hash     \%tied_hash
 301 !=      {"a"=>"b"}      \%tied_hash
 302 =       %hash           %tied_hash
 303         %tied_hash      %tied_hash
 304 !=      {"a"=>"b"}      %tied_hash
 305         $ov_obj         %refh
 306 !       "$ov_obj"       %refh
 307         [$ov_obj]       %refh
 308 !       ["$ov_obj"]     %refh
 309         %refh           %refh
 310
 311 #  - an array ref
 312 #  (since this is symmetrical, tests as well hash~~array)
 313 =       [keys %main::]  \%::
 314 =       [qw[STDIN STDOUT]]      \%::
 315 =!      []              \%::
 316 =!      [""]            {}
 317 =!      []              {}
 318 =!      @empty          {}
 319 =       [undef]         {"" => 1}
 320 =       [""]            {"" => 1}
 321 =       ["foo"]         { foo => 1 }
 322 =       ["foo", "bar"]  { foo => 1 }
 323 =       ["foo", "bar"]  \%hash
 324 =       ["foo"]         \%hash
 325 =!      ["quux"]        \%hash
 326 =       [qw(foo quux)]  \%hash
 327 =       @fooormore      { foo => 1, or => 2, more => 3 }
 328 =       @fooormore      %fooormore
 329 =       @fooormore      \%fooormore
 330 =       \@fooormore     %fooormore
 331
 332 #  - a regex
 333 =       qr/^(fo[ox])$/          {foo => 1}
 334 =       /^(fo[ox])$/            %fooormore
 335 =!      qr/[13579]$/            +{0..99}
 336 =!      qr/a*/                  {}
 337 =       qr/a*/                  {b=>2}
 338 =       qr/B/i                  {b=>2}
 339 =       /B/i                    {b=>2}
 340 =!      qr/a+/                  {b=>2}
 341 =       qr/^à/                 {"à"=>2}
 342
 343 #  - a scalar
 344         "foo"           +{foo => 1, bar => 2}
 345         "foo"           %fooormore
 346 !       "baz"           +{foo => 1, bar => 2}
 347 !       "boz"           %fooormore
 348 !       1               +{foo => 1, bar => 2}
 349 !       1               %fooormore
 350         1               { 1 => 3 }
 351         1.0             { 1 => 3 }
 352 !       "1.0"           { 1 => 3 }
 353 !       "1.0"           { 1.0 => 3 }
 354         "1.0"           { "1.0" => 3 }
 355         "à"            { "à" => "À" }
 356
 357 #  - undef
 358 !       undef           { hop => 'zouu' }
 359 !       undef           %hash
 360 !       undef           +{"" => "empty key"}
 361 !       undef           {}
 362
 363 # ARRAY ref against:
 364 #  - another array ref
 365         []                      []
 366 =!      []                      [1]
 367         [["foo"], ["bar"]]      [qr/o/, qr/a/]
 368 !       [["foo"], ["bar"]]      [qr/ARRAY/, qr/ARRAY/]
 369         ["foo", "bar"]          [qr/o/, qr/a/]
 370 !       [qr/o/, qr/a/]          ["foo", "bar"]
 371         ["foo", "bar"]          [["foo"], ["bar"]]
 372 !       ["foo", "bar"]          [qr/o/, "foo"]
 373         ["foo", undef, "bar"]   [qr/o/, undef, "bar"]
 374         ["foo", undef, "bar"]   [qr/o/, "",    "bar"]
 375 !       ["foo", "", "bar"]      [qr/o/, undef, "bar"]
 376         $deep1                  $deep1
 377         @$deep1                 @$deep1
 378 !       $deep1                  $deep2
 379
 380 =       \@nums                  \@tied_nums
 381 =       @nums                   \@tied_nums
 382 =       \@nums                  @tied_nums
 383 =       @nums                   @tied_nums
 384
 385 #  - an object
 386 !       $obj            @fooormore
 387         $obj            [sub{ref shift}]
 388
 389 #  - a regex
 390 =       qr/x/           [qw(foo bar baz quux)]
 391 =!      qr/y/           [qw(foo bar baz quux)]
 392 =       /x/             [qw(foo bar baz quux)]
 393 =!      /y/             [qw(foo bar baz quux)]
 394 =       /FOO/i          @fooormore
 395 =!      /bar/           @fooormore
 396
 397 # - a number
 398         2               [qw(1.00 2.00)]
 399         2               [qw(foo 2)]
 400         2.0_0e+0        [qw(foo 2)]
 401 !       2               [qw(1foo bar2)]
 402
 403 # - a string
 404 !       "2"             [qw(1foo 2bar)]
 405         "2bar"          [qw(1foo 2bar)]
 406
 407 # - undef
 408         undef           [1, 2, undef, 4]
 409 !       undef           [1, 2, [undef], 4]
 410 !       undef           @fooormore
 411         undef           @sparse
 412
 413 # - nested arrays and ~~ distributivity
 414         11              [[11]]
 415 !       11              [[12]]
 416         "foo"           [{foo => "bar"}]
 417 !       "bar"           [{foo => "bar"}]
 418
 419 # Number against number
 420         2               2
 421         20              2_0
 422 !       2               3
 423         0               FALSE
 424         3-2             TRUE
 425         undef           0
 426
 427 # Number against string
 428 =       2               "2"
 429 =       2               "2.0"
 430 !       2               "2bananas"
 431 !=      2_3             "2_3"           NOWARNINGS
 432         FALSE           "0"
 433
 434 # Regex against string
 435         "x"             qr/x/
 436 !       "x"             qr/y/
 437
 438 # Regex against number
 439         12345           qr/3/
 440 !       12345           qr/7/
 441
 442 # array/hash against string
 443         @fooormore      "".\@fooormore
 444 !       @keyandmore     "".\@fooormore
 445         %fooormore      "".\%fooormore
 446 !       %keyandmore     "".\%fooormore
 447
 448 # Test the implicit referencing
 449         7               @nums
 450         @nums           \@nums
 451 !       @nums           \\@nums
 452         @nums           [1..10]
 453 !       @nums           [0..9]
 454
 455         "foo"           %hash
 456         /bar/           %hash
 457         [qw(bar)]       %hash
 458 !       [qw(a b c)]     %hash
 459         %hash           %hash
 460         %hash           +{%hash}
 461         %hash           \%hash
 462         %hash           %tied_hash
 463         %tied_hash      %tied_hash
 464         %hash           { foo => 5, bar => 10 }
 465 !       %hash           { foo => 5, bar => 10, quux => 15 }
 466
 467         @nums           {  1, '',  2, '' }
 468         @nums           {  1, '', 12, '' }
 469 !       @nums           { 11, '', 12, '' }