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 # empty stuff matches, because the sub is never called:
 204         []              \&foo
 205         {}              \&foo
 206         @empty          \&foo
 207         %empty          \&foo
 208 !       qr//            \&foo
 209 !       undef           \&foo
 210         undef           \&bar
 211 @       undef           \&fatal
 212 @       1               \&fatal
 213 @       [1]             \&fatal
 214 @       {a=>1}          \&fatal
 215 @       "foo"           \&fatal
 216 @       qr//            \&fatal
 217 # sub is not called on empty hashes / arrays
 218         []              \&fatal
 219         +{}             \&fatal
 220         @empty          \&fatal
 221         %empty          \&fatal
 222
 223 # HASH ref against:
 224 #   - another hash ref
 225         {}              {}
 226 =!      {}              {1 => 2}
 227         {1 => 2}        {1 => 2}
 228         {1 => 2}        {1 => 3}
 229 =!      {1 => 2}        {2 => 3}
 230 =       \%main::        {map {$_ => 'x'} keys %main::}
 231
 232 #  - tied hash ref
 233 =       \%hash          \%tied_hash
 234         \%tied_hash     \%tied_hash
 235 !=      {"a"=>"b"}      \%tied_hash
 236 =       %hash           %tied_hash
 237         %tied_hash      %tied_hash
 238 !=      {"a"=>"b"}      %tied_hash
 239
 240 #  - an array ref
 241 #  (since this is symmetrical, tests as well hash~~array)
 242 =       [keys %main::]  \%::
 243 =       [qw[STDIN STDOUT]]      \%::
 244 =!      []              \%::
 245 =!      [""]            {}
 246 =!      []              {}
 247 =!      @empty          {}
 248 =       [undef]         {"" => 1}
 249 =       [""]            {"" => 1}
 250 =       ["foo"]         { foo => 1 }
 251 =       ["foo", "bar"]  { foo => 1 }
 252 =       ["foo", "bar"]  \%hash
 253 =       ["foo"]         \%hash
 254 =!      ["quux"]        \%hash
 255 =       [qw(foo quux)]  \%hash
 256 =       @fooormore      { foo => 1, or => 2, more => 3 }
 257 =       @fooormore      %fooormore
 258 =       @fooormore      \%fooormore
 259 =       \@fooormore     %fooormore
 260
 261 #  - a regex
 262 # TODO those should be symmetrical
 263         qr/^(fo[ox])$/          {foo => 1}
 264         /^(fo[ox])$/            %fooormore
 265 =!      qr/[13579]$/            +{0..99}
 266 !       qr/a*/                  {}
 267 =       qr/a*/                  {b=>2}
 268         qr/B/i                  {b=>2}
 269         /B/i                    {b=>2}
 270 !       qr/a+/                  {b=>2}
 271         qr/^à/                 {"à"=>2}
 272
 273 #  - a scalar
 274         "foo"           +{foo => 1, bar => 2}
 275         "foo"           %fooormore
 276 !       "baz"           +{foo => 1, bar => 2}
 277 !       "boz"           %fooormore
 278 !       1               +{foo => 1, bar => 2}
 279 !       1               %fooormore
 280         1               { 1 => 3 }
 281         1.0             { 1 => 3 }
 282 !       "1.0"           { 1 => 3 }
 283 !       "1.0"           { 1.0 => 3 }
 284         "1.0"           { "1.0" => 3 }
 285         "à"            { "à" => "À" }
 286
 287 #  - undef
 288 !       undef           { hop => 'zouu' }
 289 !       undef           %hash
 290 !       undef           +{"" => "empty key"}
 291 !       undef           {}
 292
 293 # ARRAY ref against:
 294 #  - another array ref
 295         []                      []
 296 =!      []                      [1]
 297 !       [["foo"], ["bar"]]      [qr/o/, qr/a/]
 298         [["foo"], ["bar"]]      [qr/ARRAY/, qr/ARRAY/]
 299         ["foo", "bar"]          [qr/o/, qr/a/]
 300 !       [qr/o/, qr/a/]          ["foo", "bar"]
 301         ["foo", "bar"]          [["foo"], ["bar"]]
 302 !       ["foo", "bar"]          [qr/o/, "foo"]
 303         ["foo", undef, "bar"]   [qr/o/, undef, "bar"]
 304         ["foo", undef, "bar"]   [qr/o/, "",    "bar"]
 305 !       ["foo", "", "bar"]      [qr/o/, undef, "bar"]
 306         $deep1                  $deep1
 307         @$deep1                 @$deep1
 308 !       $deep1                  $deep2
 309
 310 =       \@nums                  \@tied_nums
 311 =       @nums                   \@tied_nums
 312 =       \@nums                  @tied_nums
 313 =       @nums                   @tied_nums
 314
 315 #  - works with lists instead of arrays
 316         "foo"                   qw(foo bar)     TODO
 317         "foo"                   ('foo','bar')   TODO
 318
 319 #  - a regex
 320         qr/x/           [qw(foo bar baz quux)]
 321 !       qr/y/           [qw(foo bar baz quux)]
 322         /x/             [qw(foo bar baz quux)]
 323 !       /y/             [qw(foo bar baz quux)]
 324         /FOO/i          @fooormore
 325 !       /bar/           @fooormore
 326
 327 # - a number
 328         2               [qw(1foo 2bar)]
 329         2               [qw(foo 2)]
 330         2.0_0e+0        [qw(foo 2)]
 331 !       2               [qw(1foo bar2)]
 332
 333 # - a string
 334 !       "2"             [qw(1foo 2bar)]
 335         "2bar"          [qw(1foo 2bar)]
 336
 337 # Number against number
 338         2               2
 339         20              2_0
 340 !       2               3
 341         0               FALSE
 342         3-2             TRUE
 343         undef           0
 344
 345 # Number against string
 346 =       2               "2"
 347 =       2               "2.0"
 348 !       2               "2bananas"
 349 !=      2_3             "2_3"
 350         FALSE           "0"
 351
 352 # Regex against string
 353         "x"             qr/x/
 354 !       "x"             qr/y/
 355
 356 # Regex against number
 357         12345           qr/3/
 358 !       12345           qr/7/
 359
 360 # TODO ranges
 361
 362 # array/hash against string
 363         @fooormore      "".\@fooormore
 364 !       @keyandmore     "".\@fooormore
 365         %fooormore      "".\%fooormore
 366 !       %keyandmore     "".\%fooormore
 367
 368 # Test the implicit referencing
 369         7               @nums
 370         @nums           \@nums
 371 !       @nums           \\@nums
 372         @nums           [1..10]
 373 !       @nums           [0..9]
 374
 375         "foo"           %hash
 376         /bar/           %hash
 377         [qw(bar)]       %hash
 378 !       [qw(a b c)]     %hash
 379         %hash           %hash
 380         %hash           +{%hash}
 381         %hash           \%hash
 382         %hash           %tied_hash
 383         %tied_hash      %tied_hash
 384         %hash           { foo => 5, bar => 10 }
 385 !       %hash           { foo => 5, bar => 10, quux => 15 }
 386
 387         @nums           {  1, '',  2, '' }
 388         @nums           {  1, '', 12, '' }
 389 !       @nums           { 11, '', 12, '' }