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