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 => 1 } }
  33     use overload '~~' => sub { my %hash = %{ $_[0] }; %hash ~~ $_[1] };
  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
  83
  84 sub foo {}
  85 sub bar {42}
  86 sub gorch {42}
  87 sub fatal {die "fatal sub\n"}
  88
  89 sub FALSE() { 0 }
  90 sub TRUE() { 1 }
  91 sub TWO() { 1 }
  92
  93 # Prefix character :
  94 #   - expected to match
  95 # ! - expected to not match
  96 # @ - expected to be a compilation failure
  97 # = - expected to match symmetrically (runs test twice)
  98 # Data types to test :
  99 #   undef
 100 #   Object-overloaded
 101 #   Object
 102 #   Coderef
 103 #   Hash
 104 #   Hashref
 105 #   Array
 106 #   Arrayref
 107 #   Tied arrays and hashes
 108 #   Arrays that reference themselves
 109 #   Regex (// and qr//)
 110 #   Range
 111 #   Num
 112 #   Str
 113 # Other syntactic items of interest:
 114 #   Constants
 115 #   Values returned by a sub call
 116 __DATA__
 117 # Any ~~ undef
 118 !       $ov_obj         undef
 119 !       $obj            undef
 120 !       sub {}          undef
 121 !       %hash           undef
 122 !       \%hash          undef
 123 !       {}              undef
 124 !       @nums           undef
 125 !       \@nums          undef
 126 !       []              undef
 127 !       %tied_hash      undef
 128 !       @tied_nums      undef
 129 !       $deep1          undef
 130 !       /foo/           undef
 131 !       qr/foo/         undef
 132 !       21..30          undef
 133 !       189             undef
 134 !       "foo"           undef
 135 !       ""              undef
 136 !       !1              undef
 137         undef           undef
 138         (my $u)         undef
 139
 140 # Any ~~ object overloaded
 141 # object overloaded ~~ Any
 142         $ov_obj         $ov_obj
 143 =@      $ov_obj         \&fatal
 144 =!      $ov_obj         \&FALSE
 145 =!      $ov_obj         \&foo
 146 =       $ov_obj         \&bar
 147 =       $ov_obj         sub { shift ~~ "key" }
 148 =!      $ov_obj         sub { shift eq "key" }
 149 =!      $ov_obj         sub { shift ~~ "foo" }
 150 =       $ov_obj         %keyandmore                     TODO
 151 =!      $ov_obj         %fooormore
 152 =       $ov_obj         {"key" => 1}
 153 =       $ov_obj         {"key" => 1, bar => 2}          TODO
 154 =!      $ov_obj         {"foo" => 1}
 155 =       $ov_obj         @keyandmore
 156 =!      $ov_obj         @fooormore
 157 =       $ov_obj         ["key" => 1]
 158 =!      $ov_obj         ["foo" => 1]
 159 =       $ov_obj         /key/
 160 =!      $ov_obj         /foo/
 161 =       $ov_obj         qr/Key/i
 162 =!      $ov_obj         qr/foo/
 163 =       $ov_obj         "key"
 164 =!      $ov_obj         "foo"
 165 =!      $ov_obj         FALSE
 166
 167 # regular object
 168 =@      $obj    $ov_obj
 169 =@      $obj    $obj
 170 =@      $obj    \&fatal
 171 =@      $obj    \&FALSE
 172 =@      $obj    \&foo
 173 =@      $obj    sub { 1 }
 174 =@      $obj    sub { 0 }
 175 =@      $obj    %keyandmore
 176 =@      $obj    {"key" => 1}
 177 =@      $obj    @fooormore
 178 =@      $obj    ["key" => 1]
 179 =@      $obj    /key/
 180 =@      $obj    qr/key/
 181 =@      $obj    "key"
 182 =@      $obj    FALSE
 183
 184 # CODE ref against argument
 185 #  - arg is code ref
 186 !       \&foo           sub {}
 187
 188 # - arg is not code ref
 189         1       sub{shift}
 190 !       0       sub{shift}
 191 !       undef   sub{shift}
 192         undef   sub{not shift}
 193         FALSE   sub{not shift}
 194         1       sub{scalar @_}
 195         []      \&bar
 196         {}      \&bar
 197         qr//    \&bar
 198 !       []      \&foo
 199 !       {}      \&foo
 200 !       qr//    \&foo
 201 !       undef   \&foo
 202         undef   \&bar
 203 @       undef   \&fatal
 204 @       1       \&fatal
 205 @       []      \&fatal
 206 @       "foo"   \&fatal
 207 @       qr//    \&fatal
 208 # pass argument by reference
 209         @fooormore      sub{scalar @_ == 1}
 210         @fooormore      sub{"@_" =~ /ARRAY/}
 211         %fooormore      sub{"@_" =~ /HASH/}
 212         /fooormore/     sub{ref $_[0] eq 'Regexp'}
 213
 214 # - null-prototyped subs
 215 !       undef           \&FALSE
 216         undef           \&TRUE
 217 !       0               \&FALSE
 218         0               \&TRUE
 219 !       1               \&FALSE
 220         1               \&TRUE
 221 !       \&FALSE         \&foo
 222
 223 # - non-null-prototyped subs
 224         bar             gorch
 225 @       fatal           bar
 226
 227 # HASH ref against:
 228 #   - another hash ref
 229         {}              {}
 230 !       {}              {1 => 2}
 231         {1 => 2}        {1 => 2}
 232         {1 => 2}        {1 => 3}
 233 !       {1 => 2}        {2 => 3}
 234         \%main::        {map {$_ => 'x'} keys %main::}
 235
 236 #  - tied hash ref
 237         \%hash          \%tied_hash
 238         \%tied_hash     \%tied_hash
 239
 240 #  - an array ref
 241         \%::            [keys %main::]
 242 !       \%::            []
 243         {"" => 1}       [undef]
 244         { foo => 1 }    ["foo"]
 245         { foo => 1 }    ["foo", "bar"]
 246         \%hash          ["foo", "bar"]
 247         \%hash          ["foo"]
 248 !       \%hash          ["quux"]
 249         \%hash          [qw(foo quux)]
 250
 251 #  - a regex
 252         {foo => 1}      qr/^(fo[ox])$/
 253 !       +{0..99}        qr/[13579]$/
 254
 255 #  - a string
 256         +{foo => 1, bar => 2}   "foo"
 257 !       +{foo => 1, bar => 2}   "baz"
 258
 259
 260 # ARRAY ref against:
 261 #  - another array ref
 262         []                      []
 263 !       []                      [1]
 264         [["foo"], ["bar"]]      [qr/o/, qr/a/]
 265         ["foo", "bar"]          [qr/o/, qr/a/]
 266 !       ["foo", "bar"]          [qr/o/, "foo"]
 267         $deep1                  $deep1
 268 !       $deep1                  $deep2
 269
 270         \@nums                  \@tied_nums
 271
 272 #  - a regex
 273         [qw(foo bar baz quux)]  qr/x/
 274 !       [qw(foo bar baz quux)]  qr/y/
 275
 276 # - a number
 277         [qw(1foo 2bar)]         2
 278         [qw(foo 2)]             2
 279         [qw(foo 2)]             2.0_0e+0
 280 !       [qw(1foo bar2)]         2
 281
 282 # - a string
 283 !       [qw(1foo 2bar)]         "2"
 284         [qw(1foo 2bar)]         "2bar"
 285
 286 # Number against number
 287         2               2
 288 !       2               3
 289         0               FALSE
 290         3-2             TRUE
 291
 292 # Number against string
 293         2               "2"
 294         2               "2.0"
 295 !       2               "2bananas"
 296 !       2_3             "2_3"
 297         FALSE           "0"
 298
 299 # Regex against string
 300         qr/x/           "x"
 301 !       qr/y/           "x"
 302
 303 # Regex against number
 304         12345           qr/3/
 305
 306
 307 # Test the implicit referencing
 308         @nums           7
 309         @nums           \@nums
 310 !       @nums           \\@nums
 311         @nums           [1..10]
 312 !       @nums           [0..9]
 313
 314         %hash           "foo"
 315         %hash           /bar/
 316         %hash           [qw(bar)]
 317 !       %hash           [qw(a b c)]
 318         %hash           %hash
 319         %hash           +{%hash}
 320         %hash           \%hash
 321         %hash           %tied_hash
 322         %tied_hash      %tied_hash
 323         %hash           { foo => 5, bar => 10 }
 324 !       %hash           { foo => 5, bar => 10, quux => 15 }
 325
 326         @nums           {  1, '',  2, '' }
 327         @nums           {  1, '', 12, '' }
 328 !       @nums           { 11, '', 12, '' }