t/op/smartmatch.t

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