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