1#!./perl 2 3BEGIN { 4 chdir 't'; 5 @INC = '../lib'; 6 require './test.pl'; 7} 8use strict; 9use warnings; 10no warnings 'uninitialized'; 11no warnings 'experimental::smartmatch'; 12 13use Tie::Array; 14use Tie::Hash; 15 16# Predeclare vars used in the tests: 17my @empty; 18my %empty; 19my @sparse; $sparse[2] = 2; 20 21my $deep1 = []; push @$deep1, $deep1; 22my $deep2 = []; push @$deep2, $deep2; 23 24my @nums = (1..10); 25tie my @tied_nums, 'Tie::StdArray'; 26@tied_nums = (1..10); 27 28my %hash = (foo => 17, bar => 23); 29tie my %tied_hash, 'Tie::StdHash'; 30%tied_hash = %hash; 31 32{ 33 package Test::Object::NoOverload; 34 sub new { bless { key => 1 } } 35} 36 37{ 38 package Test::Object::StringOverload; 39 use overload '""' => sub { "object" }, fallback => 1; 40 sub new { bless { key => 1 } } 41} 42 43{ 44 package Test::Object::WithOverload; 45 sub new { bless { key => ($_[1] // 'magic') } } 46 use overload '~~' => sub { 47 my %hash = %{ $_[0] }; 48 if ($_[2]) { # arguments reversed ? 49 return $_[1] eq reverse $hash{key}; 50 } 51 else { 52 return $_[1] eq $hash{key}; 53 } 54 }; 55 use overload '""' => sub { "stringified" }; 56 use overload 'eq' => sub {"$_[0]" eq "$_[1]"}; 57} 58 59our $ov_obj = Test::Object::WithOverload->new; 60our $ov_obj_2 = Test::Object::WithOverload->new("object"); 61our $obj = Test::Object::NoOverload->new; 62our $str_obj = Test::Object::StringOverload->new; 63 64my %refh; 65unless (is_miniperl()) { 66 require Tie::RefHash; 67 tie %refh, 'Tie::RefHash'; 68 $refh{$ov_obj} = 1; 69} 70 71my @keyandmore = qw(key and more); 72my @fooormore = qw(foo or more); 73my %keyandmore = map { $_ => 0 } @keyandmore; 74my %fooormore = map { $_ => 0 } @fooormore; 75 76# Load and run the tests 77plan tests => 349; 78 79while (<DATA>) { 80 SKIP: { 81 next if /^#/ || !/\S/; 82 chomp; 83 my ($yn, $left, $right, $note) = split /\t+/; 84 85 local $::TODO = $note =~ /TODO/; 86 87 die "Bad test spec: ($yn, $left, $right)" if $yn =~ /[^!@=]/; 88 89 my $tstr = "$left ~~ $right"; 90 91 test_again: 92 my $res; 93 if ($note =~ /NOWARNINGS/) { 94 $res = eval "no warnings; $tstr"; 95 } 96 else { 97 skip_if_miniperl("Doesn't work with miniperl", $yn =~ /=/ ? 2 : 1) 98 if $note =~ /MINISKIP/; 99 $res = eval $tstr; 100 } 101 102 chomp $@; 103 104 if ( $yn =~ /@/ ) { 105 ok( $@ ne '', "$tstr dies" ) 106 and print "# \$\@ was: $@\n"; 107 } else { 108 my $test_name = $tstr . ($yn =~ /!/ ? " does not match" : " matches"); 109 if ( $@ ne '' ) { 110 fail($test_name); 111 print "# \$\@ was: $@\n"; 112 } else { 113 ok( ($yn =~ /!/ xor $res), $test_name ); 114 } 115 } 116 117 if ( $yn =~ s/=// ) { 118 $tstr = "$right ~~ $left"; 119 goto test_again; 120 } 121 } 122} 123 124sub foo {} 125sub bar {42} 126sub gorch {42} 127sub fatal {die "fatal sub\n"} 128 129# to test constant folding 130sub FALSE() { 0 } 131sub TRUE() { 1 } 132sub NOT_DEF() { undef } 133 134# Prefix character : 135# - expected to match 136# ! - expected to not match 137# @ - expected to be a compilation failure 138# = - expected to match symmetrically (runs test twice) 139# Data types to test : 140# undef 141# Object-overloaded 142# Object 143# Coderef 144# Hash 145# Hashref 146# Array 147# Arrayref 148# Tied arrays and hashes 149# Arrays that reference themselves 150# Regex (// and qr//) 151# Range 152# Num 153# Str 154# Other syntactic items of interest: 155# Constants 156# Values returned by a sub call 157__DATA__ 158# Any ~~ undef 159! $ov_obj undef 160! $obj undef 161! sub {} undef 162! %hash undef 163! \%hash undef 164! {} undef 165! @nums undef 166! \@nums undef 167! [] undef 168! %tied_hash undef 169! @tied_nums undef 170! $deep1 undef 171! /foo/ undef 172! qr/foo/ undef 173! 21..30 undef 174! 189 undef 175! "foo" undef 176! "" undef 177! !1 undef 178 undef undef 179 (my $u) undef 180 NOT_DEF undef 181 &NOT_DEF undef 182 183# Any ~~ object overloaded 184! \&fatal $ov_obj 185 'cigam' $ov_obj 186! 'cigam on' $ov_obj 187! ['cigam'] $ov_obj 188! ['stringified'] $ov_obj 189! { cigam => 1 } $ov_obj 190! { stringified => 1 } $ov_obj 191! $obj $ov_obj 192! undef $ov_obj 193 194# regular object 195@ $obj $obj 196@ $ov_obj $obj 197=@ \&fatal $obj 198@ \&FALSE $obj 199@ \&foo $obj 200@ sub { 1 } $obj 201@ sub { 0 } $obj 202@ %keyandmore $obj 203@ {"key" => 1} $obj 204@ @fooormore $obj 205@ ["key" => 1] $obj 206@ /key/ $obj 207@ qr/key/ $obj 208@ "key" $obj 209@ FALSE $obj 210 211# regular object with "" overload 212@ $obj $str_obj 213=@ \&fatal $str_obj 214@ \&FALSE $str_obj 215@ \&foo $str_obj 216@ sub { 1 } $str_obj 217@ sub { 0 } $str_obj 218@ %keyandmore $str_obj 219@ {"object" => 1} $str_obj 220@ @fooormore $str_obj 221@ ["object" => 1] $str_obj 222@ /object/ $str_obj 223@ qr/object/ $str_obj 224@ "object" $str_obj 225@ FALSE $str_obj 226# Those will treat the $str_obj as a string because of fallback: 227 228# object (overloaded or not) ~~ Any 229 $obj qr/NoOverload/ 230 $ov_obj qr/^stringified$/ 231= "$ov_obj" "stringified" 232= "$str_obj" "object" 233!= $ov_obj "stringified" 234 $str_obj "object" 235 $ov_obj 'magic' 236! $ov_obj 'not magic' 237 238# ~~ Coderef 239 sub{0} sub { ref $_[0] eq "CODE" } 240 %fooormore sub { $_[0] =~ /^(foo|or|more)$/ } 241! %fooormore sub { $_[0] =~ /^(foo|or|less)$/ } 242 \%fooormore sub { $_[0] =~ /^(foo|or|more)$/ } 243! \%fooormore sub { $_[0] =~ /^(foo|or|less)$/ } 244 +{%fooormore} sub { $_[0] =~ /^(foo|or|more)$/ } 245! +{%fooormore} sub { $_[0] =~ /^(foo|or|less)$/ } 246 @fooormore sub { $_[0] =~ /^(foo|or|more)$/ } 247! @fooormore sub { $_[0] =~ /^(foo|or|less)$/ } 248 \@fooormore sub { $_[0] =~ /^(foo|or|more)$/ } 249! \@fooormore sub { $_[0] =~ /^(foo|or|less)$/ } 250 [@fooormore] sub { $_[0] =~ /^(foo|or|more)$/ } 251! [@fooormore] sub { $_[0] =~ /^(foo|or|less)$/ } 252 %fooormore sub{@_==1} 253 @fooormore sub{@_==1} 254 "foo" sub { $_[0] =~ /^(foo|or|more)$/ } 255! "more" sub { $_[0] =~ /^(foo|or|less)$/ } 256 /fooormore/ sub{ref $_[0] eq 'Regexp'} 257 qr/fooormore/ sub{ref $_[0] eq 'Regexp'} 258 1 sub{shift} 259! 0 sub{shift} 260! undef sub{shift} 261 undef sub{not shift} 262 NOT_DEF sub{not shift} 263 &NOT_DEF sub{not shift} 264 FALSE sub{not shift} 265 [1] \&bar 266 {a=>1} \&bar 267 qr// \&bar 268! [1] \&foo 269! {a=>1} \&foo 270 $obj sub { ref($_[0]) =~ /NoOverload/ } 271 $ov_obj sub { ref($_[0]) =~ /WithOverload/ } 272# empty stuff matches, because the sub is never called: 273 [] \&foo 274 {} \&foo 275 @empty \&foo 276 %empty \&foo 277! qr// \&foo 278! undef \&foo 279 undef \&bar 280@ undef \&fatal 281@ 1 \&fatal 282@ [1] \&fatal 283@ {a=>1} \&fatal 284@ "foo" \&fatal 285@ qr// \&fatal 286# sub is not called on empty hashes / arrays 287 [] \&fatal 288 +{} \&fatal 289 @empty \&fatal 290 %empty \&fatal 291# sub is not special on the left 292 sub {0} qr/^CODE/ 293 sub {0} sub { ref shift eq "CODE" } 294 295# HASH ref against: 296# - another hash ref 297 {} {} 298=! {} {1 => 2} 299 {1 => 2} {1 => 2} 300 {1 => 2} {1 => 3} 301=! {1 => 2} {2 => 3} 302= \%main:: {map {$_ => 'x'} keys %main::} 303 304# - tied hash ref 305= \%hash \%tied_hash 306 \%tied_hash \%tied_hash 307!= {"a"=>"b"} \%tied_hash 308= %hash %tied_hash 309 %tied_hash %tied_hash 310!= {"a"=>"b"} %tied_hash 311 $ov_obj %refh MINISKIP 312! "$ov_obj" %refh MINISKIP 313 [$ov_obj] %refh MINISKIP 314! ["$ov_obj"] %refh MINISKIP 315 %refh %refh MINISKIP 316 317# - an array ref 318# (since this is symmetrical, tests as well hash~~array) 319= [keys %main::] \%:: 320= [qw[STDIN STDOUT]] \%:: 321=! [] \%:: 322=! [""] {} 323=! [] {} 324=! @empty {} 325= [undef] {"" => 1} 326= [""] {"" => 1} 327= ["foo"] { foo => 1 } 328= ["foo", "bar"] { foo => 1 } 329= ["foo", "bar"] \%hash 330= ["foo"] \%hash 331=! ["quux"] \%hash 332= [qw(foo quux)] \%hash 333= @fooormore { foo => 1, or => 2, more => 3 } 334= @fooormore %fooormore 335= @fooormore \%fooormore 336= \@fooormore %fooormore 337 338# - a regex 339= qr/^(fo[ox])$/ {foo => 1} 340= /^(fo[ox])$/ %fooormore 341=! qr/[13579]$/ +{0..99} 342=! qr/a*/ {} 343= qr/a*/ {b=>2} 344= qr/B/i {b=>2} 345= /B/i {b=>2} 346=! qr/a+/ {b=>2} 347= qr/^à/ {"à"=>2} 348 349# - a scalar 350 "foo" +{foo => 1, bar => 2} 351 "foo" %fooormore 352! "baz" +{foo => 1, bar => 2} 353! "boz" %fooormore 354! 1 +{foo => 1, bar => 2} 355! 1 %fooormore 356 1 { 1 => 3 } 357 1.0 { 1 => 3 } 358! "1.0" { 1 => 3 } 359! "1.0" { 1.0 => 3 } 360 "1.0" { "1.0" => 3 } 361 "à" { "à" => "À" } 362 363# - undef 364! undef { hop => 'zouu' } 365! undef %hash 366! undef +{"" => "empty key"} 367! undef {} 368 369# ARRAY ref against: 370# - another array ref 371 [] [] 372=! [] [1] 373 [["foo"], ["bar"]] [qr/o/, qr/a/] 374! [["foo"], ["bar"]] [qr/ARRAY/, qr/ARRAY/] 375 ["foo", "bar"] [qr/o/, qr/a/] 376! [qr/o/, qr/a/] ["foo", "bar"] 377 ["foo", "bar"] [["foo"], ["bar"]] 378! ["foo", "bar"] [qr/o/, "foo"] 379 ["foo", undef, "bar"] [qr/o/, undef, "bar"] 380! ["foo", undef, "bar"] [qr/o/, "", "bar"] 381! ["foo", "", "bar"] [qr/o/, undef, "bar"] 382 $deep1 $deep1 383 @$deep1 @$deep1 384! $deep1 $deep2 385 386= \@nums \@tied_nums 387= @nums \@tied_nums 388= \@nums @tied_nums 389= @nums @tied_nums 390 391# - an object 392! $obj @fooormore 393 $obj [sub{ref shift}] 394 395# - a regex 396= qr/x/ [qw(foo bar baz quux)] 397=! qr/y/ [qw(foo bar baz quux)] 398= /x/ [qw(foo bar baz quux)] 399=! /y/ [qw(foo bar baz quux)] 400= /FOO/i @fooormore 401=! /bar/ @fooormore 402 403# - a number 404 2 [qw(1.00 2.00)] 405 2 [qw(foo 2)] 406 2.0_0e+0 [qw(foo 2)] 407! 2 [qw(1foo bar2)] 408 409# - a string 410! "2" [qw(1foo 2bar)] 411 "2bar" [qw(1foo 2bar)] 412 413# - undef 414 undef [1, 2, undef, 4] 415! undef [1, 2, [undef], 4] 416! undef @fooormore 417 undef @sparse 418 undef [undef] 419! 0 [undef] 420! "" [undef] 421! undef [0] 422! undef [""] 423 424# - nested arrays and ~~ distributivity 425 11 [[11]] 426! 11 [[12]] 427 "foo" [{foo => "bar"}] 428! "bar" [{foo => "bar"}] 429 430# Number against number 431 2 2 432 20 2_0 433! 2 3 434 0 FALSE 435 3-2 TRUE 436! undef 0 437! (my $u) 0 438 439# Number against string 440= 2 "2" 441= 2 "2.0" 442! 2 "2bananas" 443!= 2_3 "2_3" NOWARNINGS 444 FALSE "0" 445! undef "0" 446! undef "" 447 448# Regex against string 449 "x" qr/x/ 450! "x" qr/y/ 451 452# Regex against number 453 12345 qr/3/ 454! 12345 qr/7/ 455 456# array/hash against string 457 @fooormore "".\@fooormore 458! @keyandmore "".\@fooormore 459 %fooormore "".\%fooormore 460! %keyandmore "".\%fooormore 461 462# Test the implicit referencing 463 7 @nums 464 @nums \@nums 465! @nums \\@nums 466 @nums [1..10] 467! @nums [0..9] 468 469 "foo" %hash 470 /bar/ %hash 471 [qw(bar)] %hash 472! [qw(a b c)] %hash 473 %hash %hash 474 %hash +{%hash} 475 %hash \%hash 476 %hash %tied_hash 477 %tied_hash %tied_hash 478 %hash { foo => 5, bar => 10 } 479! %hash { foo => 5, bar => 10, quux => 15 } 480 481 @nums { 1, '', 2, '' } 482 @nums { 1, '', 12, '' } 483! @nums { 11, '', 12, '' } 484 485# array slices 486 @nums[0..-1] [] 487 @nums[0..0] [1] 488! @nums[0..1] [0..2] 489 @nums[0..4] [1..5] 490 491! undef @nums[0..-1] 492 1 @nums[0..0] 493 2 @nums[0..1] 494! @nums[0..1] 2 495 496 @nums[0..1] @nums[0..1] 497 498# hash slices 499 @keyandmore{qw(not)} [undef] 500 @keyandmore{qw(key)} [0] 501 502 undef @keyandmore{qw(not)} 503 0 @keyandmore{qw(key and more)} 504! 2 @keyandmore{qw(key and)} 505 506 @fooormore{qw(foo)} @keyandmore{qw(key)} 507 @fooormore{qw(foo or more)} @keyandmore{qw(key and more)} 508 509# UNDEF 510! 3 undef 511! 1 undef 512! [] undef 513! {} undef 514! \%::main undef 515! [1,2] undef 516! %hash undef 517! @nums undef 518! "foo" undef 519! "" undef 520! !1 undef 521! \&foo undef 522! sub { } undef 523