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