use Tie::Array;
use Tie::Hash;
-# The feature mechanism is tested in t/lib/feature/smartmatch:
-# This file tests the semantics of the operator, without worrying
-# about feature issues such as scoping etc.
-
# Predeclare vars used in the tests:
my $deep1 = []; push @$deep1, \$deep1;
my $deep2 = []; push @$deep2, \$deep2;
use overload '~~' => sub { my %hash = %{ $_[0] }; %hash ~~ $_[1] };
}
-{
- package Test::Object::OverloadCodeRef;
- sub new { bless $_[1] }
- use overload '~~' => sub { shift->($_[1]) };
-}
-
our $ov_obj = Test::Object::CopyOverload->new;
our $obj = Test::Object::NoOverload->new;
-our $false_obj = Test::Object::OverloadCodeRef->new(sub { 0 });
-our $true_obj = Test::Object::OverloadCodeRef->new(sub { 1 });
+my @keyandmore = qw(key and more);
+my @fooormore = qw(foo or more);
+my %keyandmore = map { $_ => 0 } @keyandmore;
+my %fooormore = map { $_ => 0 } @fooormore;
# Load and run the tests
-my @tests = map [chomp and split /\t+/, $_, 3], grep !/^#/ && /\S/, <DATA>;
-plan tests => 2 * @tests;
+plan "no_plan";
-for my $test (@tests) {
- my ($yn, $left, $right) = @$test;
+while (<DATA>) {
+ next if /^#/ || !/\S/;
+ chomp;
+ my ($yn, $left, $right, $note) = split /\t+/;
- match_test($yn, $left, $right);
- match_test($yn, $right, $left);
-}
+ local $::TODO = $note =~ /TODO/;
-sub match_test {
- my ($yn, $left, $right) = @_;
+ die "Bad test spec: ($yn, $left, $right)" if $yn =~ /[^!@=]/;
- die "Bad test spec: ($yn, $left, $right)"
- unless $yn eq "" || $yn eq "!" || $yn eq '@';
-
my $tstr = "$left ~~ $right";
-
- my $res;
- $res = eval $tstr // ""; #/ <- fix syntax colouring
+
+ test_again:
+ my $res = eval $tstr;
chomp $@;
- if ( $yn eq '@' ) {
- ok( $@ ne '', sprintf "%s%s: %s", $tstr, $@ ? ( ', $@', $@ ) : ( '', $res ) );
+ if ( $yn =~ /@/ ) {
+ ok( $@ ne '', "$tstr dies" )
+ and print "# \$\@ was: $@\n";
} else {
+ my $test_name = $tstr . ($yn =~ /!/ ? " does not match" : " matches");
if ( $@ ne '' ) {
- fail("$tstr, \$\@: $@");
+ fail($test_name);
+ print "# \$\@ was: $@\n";
} else {
- ok( ($yn eq '!' xor $res), "$tstr: $res");
+ ok( ($yn =~ /!/ xor $res), $test_name );
}
}
+
+ if ( $yn =~ s/=// ) {
+ $tstr = "$right ~~ $left";
+ goto test_again;
+ }
}
sub foo {}
-sub bar {2}
-sub gorch {2}
+sub bar {42}
+sub gorch {42}
sub fatal {die "fatal sub\n"}
-sub a_const() {die "const\n" if @_; "a constant"}
-sub b_const() {die "const\n" if @_; "a constant"}
-
+sub FALSE() { 0 }
+sub TRUE() { 1 }
+sub TWO() { 1 }
+
+# Prefix character :
+# - expected to match
+# ! - expected to not match
+# @ - expected to be a compilation failure
+# = - expected to match symmetrically (runs test twice)
+# Data types to test :
+# undef
+# Object-overloaded
+# Object
+# Coderef
+# Hash
+# Hashref
+# Array
+# Arrayref
+# Tied arrays and hashes
+# Arrays that reference themselves
+# Regex (// and qr//)
+# Range
+# Num
+# Str
+# Other syntactic items of interest:
+# Constants
+# Values returned by a sub call
__DATA__
-# OBJECT
-# - overloaded
- $ov_obj "key"
- $ov_obj {"key" => 1}
-! $ov_obj "foo"
-! $ov_obj \&foo
-@ $ov_obj \&fatal
+# Any ~~ undef
+! $ov_obj undef
+! $obj undef
+! sub {} undef
+! %hash undef
+! \%hash undef
+! {} undef
+! @nums undef
+! \@nums undef
+! [] undef
+! %tied_hash undef
+! @tied_nums undef
+! $deep1 undef
+! /foo/ undef
+! qr/foo/ undef
+! 21..30 undef
+! 189 undef
+! "foo" undef
+! "" undef
+! !1 undef
+ undef undef
+
+# Any ~~ object overloaded
+# object overloaded ~~ Any
+ $ov_obj $ov_obj
+=@ $ov_obj \&fatal
+=! $ov_obj \&FALSE
+=! $ov_obj \&foo
+= $ov_obj \&bar
+= $ov_obj sub { shift ~~ "key" }
+=! $ov_obj sub { shift eq "key" }
+=! $ov_obj sub { shift ~~ "foo" }
+= $ov_obj %keyandmore TODO
+=! $ov_obj %fooormore
+= $ov_obj {"key" => 1}
+= $ov_obj {"key" => 1, bar => 2} TODO
+=! $ov_obj {"foo" => 1}
+= $ov_obj @keyandmore
+=! $ov_obj @fooormore
+= $ov_obj ["key" => 1]
+=! $ov_obj ["foo" => 1]
+= $ov_obj /key/
+=! $ov_obj /foo/
+= $ov_obj qr/Key/i
+=! $ov_obj qr/foo/
+= $ov_obj "key"
+=! $ov_obj "foo"
+=! $ov_obj FALSE
# regular object
-@ $obj "key"
-@ $obj {"key" => 1}
-@ $obj "foo"
-@ $obj $obj
-@ $obj sub { 1 }
-@ $obj sub { 0 }
-@ $obj \&foo
-@ $obj \&fatal
+=@ $obj $ov_obj
+=@ $obj $obj
+=@ $obj \&fatal
+=@ $obj \&FALSE
+=@ $obj \&foo
+=@ $obj sub { 1 }
+=@ $obj sub { 0 }
+=@ $obj %keyandmore
+=@ $obj {"key" => 1}
+=@ $obj @fooormore
+=@ $obj ["key" => 1]
+=@ $obj /key/
+=@ $obj qr/key/
+=@ $obj "key"
+=@ $obj FALSE
# CODE ref against argument
# - arg is code ref
- \&foo \&foo
! \&foo sub {}
-! \&foo \&bar
- \&fatal \&fatal
-! \&foo \&fatal
# - arg is not code ref
1 sub{shift}
! 0 sub{shift}
! undef sub{shift}
undef sub{not shift}
+ FALSE sub{not shift}
1 sub{scalar @_}
[] \&bar
{} \&bar
@ [] \&fatal
@ "foo" \&fatal
@ qr// \&fatal
-@ $obj \&bar
- $ov_obj \&bar
+# pass argument by reference
+ @fooormore sub{scalar @_ == 1}
+ @fooormore sub{"@_" =~ /ARRAY/}
+ %fooormore sub{"@_" =~ /HASH/}
+ /fooormore/ sub{ref $_[0] eq 'Regexp'}
# - null-prototyped subs
- a_const "a constant"
- a_const a_const
- a_const b_const
- \&a_const \&a_const
-! \&a_const \&b_const
+! undef \&FALSE
+ undef \&TRUE
+! 0 \&FALSE
+ 0 \&TRUE
+! 1 \&FALSE
+ 1 \&TRUE
+! \&FALSE \&foo
# - non-null-prototyped subs
-! \&bar \&gorch
bar gorch
@ fatal bar
# - a regex
{foo => 1} qr/^(fo[ox])$/
-! +{0..100} qr/[13579]$/
+! +{0..99} qr/[13579]$/
# - a string
+{foo => 1, bar => 2} "foo"
# Number against number
2 2
! 2 3
+ 0 FALSE
+ 3-2 TRUE
# Number against string
2 "2"
2 "2.0"
! 2 "2bananas"
! 2_3 "2_3"
+ FALSE "0"
# Regex against string
qr/x/ "x"
%hash [qw(bar)]
! %hash [qw(a b c)]
%hash %hash
- %hash {%hash}
+ %hash +{%hash}
+ %hash \%hash
%hash %tied_hash
%tied_hash %tied_hash
%hash { foo => 5, bar => 10 }
@nums { 1, '', 2, '' }
@nums { 1, '', 12, '' }
! @nums { 11, '', 12, '' }
-
-# UNDEF
-! 3 undef
-! 1 undef
-! [] undef
-! {} undef
-! \%::main undef
-! [1,2] undef
-! %hash undef
-! @nums undef
-! "foo" undef
-! "" undef
-! !1 undef
-! \&foo undef
-! sub { } undef
projects / p5sagit/p5-mst-13.2.git / blobdiff