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 # The feature mechanism is tested in t/lib/feature/smartmatch:
  14 # This file tests the semantics of the operator, without worrying
  15 # about feature issues such as scoping etc.
  16
  17 # Predeclare vars used in the tests:
  18 my $deep1 = []; push @$deep1, \$deep1;
  19 my $deep2 = []; push @$deep2, \$deep2;
  20
  21 {my $const = "a constant"; sub a_const () {$const}}
  22
  23 my @nums = (1..10);
  24 tie my @tied_nums, 'Tie::StdArray';
  25 @tied_nums =  (1..10);
  26
  27 my %hash = (foo => 17, bar => 23);
  28 tie my %tied_hash, 'Tie::StdHash';
  29 %tied_hash = %hash;
  30
  31 {
  32     package Test::Object::NoOverload;
  33     sub new { bless { key => 1 } }
  34 }
  35
  36 {
  37     package Test::Object::CopyOverload;
  38     sub new { bless { key => 1 } }
  39     use overload '~~' => sub { my %hash = %{ $_[0] }; %hash ~~ $_[1] };
  40 }
  41
  42 {
  43     package Test::Object::OverloadCodeRef;
  44     sub new { bless $_[1] }
  45     use overload '~~' => sub { shift->($_[1]) };
  46 }
  47
  48 our $ov_obj = Test::Object::CopyOverload->new;
  49 our $obj = Test::Object::NoOverload->new;
  50 our $false_obj = Test::Object::OverloadCodeRef->new(sub { 0 });
  51 our $true_obj = Test::Object::OverloadCodeRef->new(sub { 1 });
  52
  53
  54 # Load and run the tests
  55 my @tests = map [chomp and split /\t+/, $_, 3], grep !/^#/ && /\S/, <DATA>;
  56 plan tests => 2 * @tests;
  57
  58 for my $test (@tests) {
  59     my ($yn, $left, $right) = @$test;
  60
  61     match_test($yn, $left, $right);
  62     match_test($yn, $right, $left);
  63 }
  64
  65 sub match_test {
  66     my ($yn, $left, $right) = @_;
  67
  68     die "Bad test spec: ($yn, $left, $right)"
  69         unless $yn eq "" || $yn eq "!" || $yn eq '@';
  70
  71     my $tstr = "$left ~~ $right";
  72
  73     my $res;
  74     $res = eval $tstr // "";    #/ <- fix syntax colouring
  75
  76     chomp $@;
  77
  78     if ( $yn eq '@' ) {
  79         ok( $@ ne '', sprintf "%s%s: %s", $tstr, $@ ? ( ', $@', $@ ) : ( '', $res ) );
  80     } else {
  81         if ( $@ ne '' ) {
  82             fail("$tstr, \$\@: $@");
  83         } else {
  84             ok( ($yn eq '!' xor $res), "$tstr: $res");
  85         }
  86     }
  87 }
  88
  89
  90
  91 sub foo {}
  92 sub bar {2}
  93 sub gorch {2}
  94 sub fatal {die "fatal sub\n"}
  95
  96 sub a_const() {die "const\n" if @_; "a constant"}
  97 sub b_const() {die "const\n" if @_; "a constant"}
  98
  99 __DATA__
 100 # OBJECT
 101 # - overloaded
 102         $ov_obj         "key"
 103         $ov_obj         {"key" => 1}
 104 !       $ov_obj         "foo"
 105 !       $ov_obj         \&foo
 106 @       $ov_obj         \&fatal
 107
 108 # regular object
 109 @       $obj    "key"
 110 @       $obj    {"key" => 1}
 111 @       $obj    "foo"
 112 @       $obj    $obj
 113 @       $obj    sub { 1 }
 114 @       $obj    sub { 0 }
 115 @       $obj    \&foo
 116 @       $obj    \&fatal
 117
 118 # CODE ref against argument
 119 #  - arg is code ref
 120         \&foo           \&foo
 121 !       \&foo           sub {}
 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         1       sub{scalar @_}
 132         []      \&bar
 133         {}      \&bar
 134         qr//    \&bar
 135 !       []      \&foo
 136 !       {}      \&foo
 137 !       qr//    \&foo
 138 !       undef   \&foo
 139         undef   \&bar
 140 @       undef   \&fatal
 141 @       1       \&fatal
 142 @       []      \&fatal
 143 @       "foo"   \&fatal
 144 @       qr//    \&fatal
 145 @       $obj    \&bar
 146         $ov_obj \&bar
 147
 148 # - null-prototyped subs
 149         a_const         "a constant"
 150         a_const         a_const
 151         a_const         b_const
 152         \&a_const       \&a_const
 153 !       \&a_const       \&b_const
 154
 155 # - non-null-prototyped subs
 156 !       \&bar           \&gorch
 157         bar             gorch
 158 @       fatal           bar
 159
 160 # HASH ref against:
 161 #   - another hash ref
 162         {}              {}
 163 !       {}              {1 => 2}
 164         {1 => 2}        {1 => 2}
 165         {1 => 2}        {1 => 3}
 166 !       {1 => 2}        {2 => 3}
 167         \%main::        {map {$_ => 'x'} keys %main::}
 168
 169 #  - tied hash ref
 170         \%hash          \%tied_hash
 171         \%tied_hash     \%tied_hash
 172
 173 #  - an array ref
 174         \%::            [keys %main::]
 175 !       \%::            []
 176         {"" => 1}       [undef]
 177         { foo => 1 }    ["foo"]
 178         { foo => 1 }    ["foo", "bar"]
 179         \%hash          ["foo", "bar"]
 180         \%hash          ["foo"]
 181 !       \%hash          ["quux"]
 182         \%hash          [qw(foo quux)]
 183
 184 #  - a regex
 185         {foo => 1}      qr/^(fo[ox])$/
 186 !       +{0..100}       qr/[13579]$/
 187
 188 #  - a string
 189         +{foo => 1, bar => 2}   "foo"
 190 !       +{foo => 1, bar => 2}   "baz"
 191
 192
 193 # ARRAY ref against:
 194 #  - another array ref
 195         []                      []
 196 !       []                      [1]
 197         [["foo"], ["bar"]]      [qr/o/, qr/a/]
 198         ["foo", "bar"]          [qr/o/, qr/a/]
 199 !       ["foo", "bar"]          [qr/o/, "foo"]
 200         $deep1                  $deep1
 201 !       $deep1                  $deep2
 202
 203         \@nums                  \@tied_nums
 204
 205 #  - a regex
 206         [qw(foo bar baz quux)]  qr/x/
 207 !       [qw(foo bar baz quux)]  qr/y/
 208
 209 # - a number
 210         [qw(1foo 2bar)]         2
 211
 212 # - a string
 213 !       [qw(1foo 2bar)]         "2"
 214
 215 # Number against number
 216         2               2
 217 !       2               3
 218
 219 # Number against string
 220         2               "2"
 221         2               "2.0"
 222 !       2               "2bananas"
 223 !       2_3             "2_3"
 224
 225 # Regex against string
 226         qr/x/           "x"
 227 !       qr/y/           "x"
 228
 229 # Regex against number
 230         12345           qr/3/
 231
 232
 233 # Test the implicit referencing
 234         @nums           7
 235         @nums           \@nums
 236 !       @nums           \\@nums
 237         @nums           [1..10]
 238 !       @nums           [0..9]
 239
 240         %hash           "foo"
 241         %hash           /bar/
 242         %hash           [qw(bar)]
 243 !       %hash           [qw(a b c)]
 244         %hash           %hash
 245         %hash           {%hash}
 246         %hash           %tied_hash
 247         %tied_hash      %tied_hash
 248         %hash           { foo => 5, bar => 10 }
 249 !       %hash           { foo => 5, bar => 10, quux => 15 }
 250
 251         @nums           {  1, '',  2, '' }
 252         @nums           {  1, '', 12, '' }
 253 !       @nums           { 11, '', 12, '' }
 254
 255 # UNDEF
 256 !       3               undef
 257 !       1               undef
 258 !       []              undef
 259 !       {}              undef
 260 !       \%::main        undef
 261 !       [1,2]           undef
 262 !       %hash           undef
 263 !       @nums           undef
 264 !       "foo"           undef
 265 !       ""              undef
 266 !       !1              undef
 267 !       \&foo           undef
 268 !       sub { }         undef