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