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 # Load and run the tests
  40 plan "no_plan";
  41
  42 while (<DATA>) {
  43     next if /^#/ || !/\S/;
  44     chomp;
  45     my ($yn, $left, $right) = split /\t+/;
  46
  47     match_test($yn, $left, $right);
  48     match_test($yn, $right, $left);
  49 }
  50
  51 sub match_test {
  52     my ($yn, $left, $right) = @_;
  53
  54     die "Bad test spec: ($yn, $left, $right)"
  55         unless $yn eq "" || $yn eq "!" || $yn eq '@';
  56
  57     my $tstr = "$left ~~ $right";
  58
  59     my $res = eval $tstr;
  60
  61     chomp $@;
  62
  63     if ( $yn eq '@' ) {
  64         ok( $@ ne '', "$tstr dies" )
  65             and print "# \$\@ was: $@\n";
  66     } else {
  67         my $test_name = $tstr . ($yn eq '!' ? " does not match" : " matches");
  68         if ( $@ ne '' ) {
  69             fail($test_name);
  70             print "# \$\@ was: $@\n";
  71         } else {
  72             ok( ($yn eq '!' xor $res), $test_name );
  73         }
  74     }
  75 }
  76
  77
  78
  79 sub foo {}
  80 sub bar {2}
  81 sub gorch {2}
  82 sub fatal {die "fatal sub\n"}
  83
  84 sub a_const() {die "const\n" if @_; "a constant"}
  85 sub b_const() {die "const\n" if @_; "a constant"}
  86 sub FALSE() { 0 }
  87 sub TRUE() { 1 }
  88 sub TWO() { 1 }
  89
  90 # Prefix character :
  91 #   - expected to match
  92 # ! - expected to not match
  93 # @ - expected to be a compilation failure
  94 __DATA__
  95 # OBJECT
  96 # - overloaded
  97         $ov_obj         "key"
  98 !       $ov_obj         "foo"
  99         $ov_obj         {"key" => 1}
 100 !       $ov_obj         {"foo" => 1}
 101         $ov_obj         ["key" => 1]
 102 !       $ov_obj         ["foo" => 1]
 103         $ov_obj         sub { shift ~~ "key" }
 104 !       $ov_obj         sub { shift ~~ "foo" }
 105 !       $ov_obj         \&foo
 106         $ov_obj         \&bar
 107 @       $ov_obj         \&fatal
 108 !       $ov_obj         FALSE
 109 !       $ov_obj         \&FALSE
 110 !       $ov_obj         undef
 111         $ov_obj         $ov_obj
 112
 113 # regular object
 114 @       $obj    "key"
 115 @       $obj    {"key" => 1}
 116 @       $obj    ["key" => 1]
 117 @       $obj    sub { 1 }
 118 @       $obj    sub { 0 }
 119 @       $obj    \&foo
 120 @       $obj    \&fatal
 121 @       $obj    FALSE
 122 @       $obj    \&FALSE
 123 !       $obj    undef
 124 @       $obj    $obj
 125
 126 # CODE ref against argument
 127 #  - arg is code ref
 128         \&foo           \&foo
 129 !       \&foo           sub {}
 130 !       \&foo           sub { "$_[0]" =~ /^CODE/ }
 131 !       \&foo           \&bar
 132         \&fatal         \&fatal
 133 !       \&foo           \&fatal
 134
 135 # - arg is not code ref
 136         1       sub{shift}
 137 !       0       sub{shift}
 138 !       undef   sub{shift}
 139         undef   sub{not shift}
 140         FALSE   sub{not shift}
 141         1       sub{scalar @_}
 142         []      \&bar
 143         {}      \&bar
 144         qr//    \&bar
 145 !       []      \&foo
 146 !       {}      \&foo
 147 !       qr//    \&foo
 148 !       undef   \&foo
 149         undef   \&bar
 150 @       undef   \&fatal
 151 @       1       \&fatal
 152 @       []      \&fatal
 153 @       "foo"   \&fatal
 154 @       qr//    \&fatal
 155
 156 # - null-prototyped subs
 157         a_const         "a constant"
 158         a_const         a_const
 159         a_const         b_const
 160         \&a_const       \&a_const
 161 !       \&a_const       \&b_const
 162 !       undef           \&FALSE
 163         undef           \&TRUE
 164 !       0               \&FALSE
 165         0               \&TRUE
 166 !       1               \&FALSE
 167         1               \&TRUE
 168         \&FALSE         \&FALSE
 169 !       \&FALSE         \&foo
 170 !       \&FALSE         \&bar
 171 !       \&TRUE          \&foo
 172 !       \&TRUE          \&bar
 173 !       \&TWO           \&foo
 174 !       \&TWO           \&bar
 175         \&FALSE         \&FALSE
 176
 177 # - non-null-prototyped subs
 178 !       \&bar           \&gorch
 179         bar             gorch
 180 @       fatal           bar
 181
 182 # HASH ref against:
 183 #   - another hash ref
 184         {}              {}
 185 !       {}              {1 => 2}
 186         {1 => 2}        {1 => 2}
 187         {1 => 2}        {1 => 3}
 188 !       {1 => 2}        {2 => 3}
 189         \%main::        {map {$_ => 'x'} keys %main::}
 190
 191 #  - tied hash ref
 192         \%hash          \%tied_hash
 193         \%tied_hash     \%tied_hash
 194
 195 #  - an array ref
 196         \%::            [keys %main::]
 197 !       \%::            []
 198         {"" => 1}       [undef]
 199         { foo => 1 }    ["foo"]
 200         { foo => 1 }    ["foo", "bar"]
 201         \%hash          ["foo", "bar"]
 202         \%hash          ["foo"]
 203 !       \%hash          ["quux"]
 204         \%hash          [qw(foo quux)]
 205
 206 #  - a regex
 207         {foo => 1}      qr/^(fo[ox])$/
 208 !       +{0..99}        qr/[13579]$/
 209
 210 #  - a string
 211         +{foo => 1, bar => 2}   "foo"
 212 !       +{foo => 1, bar => 2}   "baz"
 213
 214
 215 # ARRAY ref against:
 216 #  - another array ref
 217         []                      []
 218 !       []                      [1]
 219         [["foo"], ["bar"]]      [qr/o/, qr/a/]
 220         ["foo", "bar"]          [qr/o/, qr/a/]
 221 !       ["foo", "bar"]          [qr/o/, "foo"]
 222         $deep1                  $deep1
 223 !       $deep1                  $deep2
 224
 225         \@nums                  \@tied_nums
 226
 227 #  - a regex
 228         [qw(foo bar baz quux)]  qr/x/
 229 !       [qw(foo bar baz quux)]  qr/y/
 230
 231 # - a number
 232         [qw(1foo 2bar)]         2
 233         [qw(foo 2)]             2
 234         [qw(foo 2)]             2.0_0e+0
 235 !       [qw(1foo bar2)]         2
 236
 237 # - a string
 238 !       [qw(1foo 2bar)]         "2"
 239         [qw(1foo 2bar)]         "2bar"
 240
 241 # Number against number
 242         2               2
 243 !       2               3
 244         0               FALSE
 245         3-2             TRUE
 246
 247 # Number against string
 248         2               "2"
 249         2               "2.0"
 250 !       2               "2bananas"
 251 !       2_3             "2_3"
 252         FALSE           "0"
 253
 254 # Regex against string
 255         qr/x/           "x"
 256 !       qr/y/           "x"
 257
 258 # Regex against number
 259         12345           qr/3/
 260
 261
 262 # Test the implicit referencing
 263         @nums           7
 264         @nums           \@nums
 265 !       @nums           \\@nums
 266         @nums           [1..10]
 267 !       @nums           [0..9]
 268
 269         %hash           "foo"
 270         %hash           /bar/
 271         %hash           [qw(bar)]
 272 !       %hash           [qw(a b c)]
 273         %hash           %hash
 274         %hash           +{%hash}
 275         %hash           %tied_hash
 276         %tied_hash      %tied_hash
 277         %hash           { foo => 5, bar => 10 }
 278 !       %hash           { foo => 5, bar => 10, quux => 15 }
 279
 280         @nums           {  1, '',  2, '' }
 281         @nums           {  1, '', 12, '' }
 282 !       @nums           { 11, '', 12, '' }
 283
 284 # UNDEF
 285 !       3               undef
 286 !       1               undef
 287 !       []              undef
 288 !       {}              undef
 289 !       \%::main        undef
 290 !       [1,2]           undef
 291 !       %hash           undef
 292 !       @nums           undef
 293 !       "foo"           undef
 294 !       ""              undef
 295 !       !1              undef
 296 !       \&foo           undef
 297 !       sub { }         undef
 298         undef           undef
 299         $::undef        undef