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 # Load and run the tests
  32 my @tests = map [chomp and split /\t+/, $_, 3], grep !/^#/ && /\S/, <DATA>;
  33 plan tests => 2 * @tests;
  34
  35 for my $test (@tests) {
  36     my ($yn, $left, $right) = @$test;
  37
  38     match_test($yn, $left, $right);
  39     match_test($yn, $right, $left);
  40 }
  41
  42 sub match_test {
  43     my ($yn, $left, $right) = @_;
  44
  45     die "Bad test spec: ($yn, $left, $right)"
  46         unless $yn eq "" || $yn eq "!" || $yn eq '@';
  47
  48     my $tstr = "$left ~~ $right";
  49
  50     my $res;
  51     $res = eval $tstr // "";    #/ <- fix syntax colouring
  52
  53     chomp $@;
  54
  55     if ( $yn eq '@' ) {
  56         ok( $@ ne '', sprintf "%s%s: %s", $tstr, $@ ? ( ', $@', $@ ) : ( '', $res ) );
  57     } else {
  58         if ( $@ ne '' ) {
  59             fail("$tstr, \$\@: $@");
  60         } else {
  61             ok( ($yn eq '!' xor $res), "$tstr: $res");
  62         }
  63     }
  64 }
  65
  66
  67
  68 sub foo {}
  69 sub bar {2}
  70 sub fatal {die}
  71
  72 sub a_const() {die if @_; "a constant"}
  73 sub b_const() {die if @_; "a constant"}
  74
  75 __DATA__
  76 # CODE ref against argument
  77 #  - arg is code ref
  78         \&foo           \&foo
  79 !       \&foo           sub {}
  80 !       \&foo           \&bar
  81
  82 # - arg is not code ref
  83         1               sub{shift}
  84 !       0               sub{shift}
  85         1               sub{scalar @_}
  86         []              \&bar
  87         {}              \&bar
  88         qr//            \&bar
  89
  90 # - null-prototyped subs
  91         a_const         "a constant"
  92         a_const         a_const
  93         a_const         b_const
  94
  95 # HASH ref against:
  96 #   - another hash ref
  97         {}              {}
  98 !       {}              {1 => 2}
  99         {1 => 2}        {1 => 2}
 100         {1 => 2}        {1 => 3}
 101 !       {1 => 2}        {2 => 3}
 102         \%main::        {map {$_ => 'x'} keys %main::}
 103
 104 #  - tied hash ref
 105         \%hash          \%tied_hash
 106         \%tied_hash     \%tied_hash
 107
 108 #  - an array ref
 109         \%::            [keys %main::]
 110 !       \%::            []
 111         {"" => 1}       [undef]
 112         { foo => 1 }    ["foo"]
 113         { foo => 1 }    ["foo", "bar"]
 114         \%hash          ["foo", "bar"]
 115         \%hash          ["foo"]
 116 !       \%hash          ["quux"]
 117         \%hash          [qw(foo quux)]
 118
 119 #  - a regex
 120         {foo => 1}      qr/^(fo[ox])$/
 121 !       +{0..100}       qr/[13579]$/
 122
 123 #  - a string
 124         +{foo => 1, bar => 2}   "foo"
 125 !       +{foo => 1, bar => 2}   "baz"
 126
 127
 128 # ARRAY ref against:
 129 #  - another array ref
 130         []              []
 131 !       []              [1]
 132         [["foo"], ["bar"]]      [qr/o/, qr/a/]
 133         ["foo", "bar"]          [qr/o/, qr/a/]
 134 !       ["foo", "bar"]          [qr/o/, "foo"]
 135         $deep1          $deep1
 136 !       $deep1          $deep2
 137
 138         \@nums          \@tied_nums
 139
 140 #  - a regex
 141         [qw(foo bar baz quux)]  qr/x/
 142 !       [qw(foo bar baz quux)]  qr/y/
 143
 144 # - a number
 145         [qw(1foo 2bar)]         2
 146
 147 # - a string
 148 !       [qw(1foo 2bar)]         "2"
 149
 150 # Number against number
 151         2               2
 152 !       2               3
 153
 154 # Number against string
 155         2               "2"
 156         2               "2.0"
 157 !       2               "2bananas"
 158 !       2_3             "2_3"
 159
 160 # Regex against string
 161         qr/x/           "x"
 162 !       qr/y/           "x"
 163
 164 # Regex against number
 165         12345           qr/3/
 166
 167
 168 # Test the implicit referencing
 169         @nums           7
 170         @nums           \@nums
 171 !       @nums           \\@nums
 172         @nums           [1..10]
 173 !       @nums           [0..9]
 174
 175         %hash           "foo"
 176         %hash           /bar/
 177         %hash           [qw(bar)]
 178 !       %hash           [qw(a b c)]
 179         %hash           %hash
 180         %hash           {%hash}
 181         %hash           %tied_hash
 182         %tied_hash      %tied_hash
 183         %hash           { foo => 5, bar => 10 }
 184 !       %hash           { foo => 5, bar => 10, quux => 15 }
 185
 186         @nums           {  1, '',  2, '' }
 187         @nums           {  1, '', 12, '' }
 188 !       @nums           { 11, '', 12, '' }
 189
 190 # UNDEF
 191 !       3               undef
 192 !       1               undef
 193 !       []              undef
 194 !       {}              undef
 195 !       \%::main        undef
 196 !       [1,2]           undef
 197 !       %hash           undef
 198 !       @nums           undef
 199 !       "foo"           undef
 200 !       ""              undef
 201 !       !1              undef
 202 !       \&foo           undef
 203 !       sub { }         undef