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