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