add eval and error support to the t/op/smartmatch.t test

[p5sagit/p5-mst-13.2.git] / t / op / smartmatch.t

#!./perl

BEGIN {
    chdir 't';
    @INC = '../lib';
    require './test.pl';
}
use strict;

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;

{my $const = "a constant"; sub a_const () {$const}}

my @nums = (1..10);
tie my @tied_nums, 'Tie::StdArray';
@tied_nums =  (1..10);

my %hash = (foo => 17, bar => 23);
tie my %tied_hash, 'Tie::StdHash';
%tied_hash = %hash;

# Load and run the tests
my @tests = map [chomp and split /\t+/, $_, 3], grep !/^#/ && /\S/, <DATA>;
plan tests => 2 * @tests;

for my $test (@tests) {
    my ($yn, $left, $right) = @$test;

    match_test($yn, $left, $right);
    match_test($yn, $right, $left);
}

sub match_test {
    my ($yn, $left, $right) = @_;

    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

    chomp $@;

    if ( $yn eq '@' ) {
	ok( $@ ne '', sprintf "%s%s: %s", $tstr, $@ ? ( ', $@', $@ ) : ( '', $res ) );
    } else {
	if ( $@ ne '' ) {
	    fail("$tstr, \$\@: $@");
	} else {
	    ok( ($yn eq '!' xor $res), "$tstr: $res");
	}
    }
}



sub foo {}
sub bar {2}
sub fatal {die}

sub a_const() {die if @_; "a constant"}
sub b_const() {die if @_; "a constant"}

__DATA__
# CODE ref against argument
#  - arg is code ref
	\&foo		\&foo
!	\&foo		sub {}
!	\&foo		\&bar

# - arg is not code ref
	1		sub{shift}
!	0		sub{shift}
	1		sub{scalar @_}
	[]		\&bar
	{}		\&bar
	qr//		\&bar

# - null-prototyped subs
	a_const		"a constant"
	a_const		a_const
	a_const		b_const

# HASH ref against:
#   - another hash ref
	{}		{}
!	{}		{1 => 2}
	{1 => 2}	{1 => 2}
	{1 => 2}	{1 => 3}
!	{1 => 2}	{2 => 3}
	\%main::	{map {$_ => 'x'} keys %main::}

#  - tied hash ref
	\%hash		\%tied_hash
	\%tied_hash	\%tied_hash

#  - an array ref
	\%::		[keys %main::]
!	\%::		[]
	{"" => 1}	[undef]
	{ foo => 1 }	["foo"]
	{ foo => 1 }	["foo", "bar"]
	\%hash		["foo", "bar"]
	\%hash		["foo"]
!	\%hash		["quux"]
	\%hash		[qw(foo quux)]

#  - a regex
	{foo => 1}	qr/^(fo[ox])$/
!	+{0..100}	qr/[13579]$/

#  - a string
	+{foo => 1, bar => 2}	"foo"
!	+{foo => 1, bar => 2}	"baz"


# ARRAY ref against:
#  - another array ref
	[]		[]
!	[]		[1]
	[["foo"], ["bar"]]	[qr/o/, qr/a/]
	["foo", "bar"]		[qr/o/, qr/a/]
!	["foo", "bar"]		[qr/o/, "foo"]
	$deep1		$deep1
!	$deep1		$deep2

	\@nums		\@tied_nums

#  - a regex
	[qw(foo bar baz quux)]	qr/x/
!	[qw(foo bar baz quux)]	qr/y/

# - a number
	[qw(1foo 2bar)]		2

# - a string
!	[qw(1foo 2bar)]		"2"

# Number against number
	2		2
!	2		3

# Number against string
	2		"2"
	2		"2.0"
!	2		"2bananas"
!	2_3		"2_3"

# Regex against string
	qr/x/		"x"
!	qr/y/		"x"

# Regex against number
	12345		qr/3/


# Test the implicit referencing
	@nums		7
	@nums		\@nums
!	@nums		\\@nums
	@nums		[1..10]
!	@nums		[0..9]

	%hash		"foo"
	%hash		/bar/
	%hash		[qw(bar)]
!	%hash		[qw(a b c)]
	%hash		%hash
	%hash		{%hash}
	%hash		%tied_hash
	%tied_hash	%tied_hash
	%hash		{ foo => 5, bar => 10 }
!	%hash		{ foo => 5, bar => 10, quux => 15 }

	@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