File Coverage

blib/lib/Test/Lazy/Tester.pm

Criterion	Covered	Total	%
statement	90	100	90.0
branch	25	40	62.5
condition	5	15	33.3
subroutine	15	15	100.0
pod	6	6	100.0
total	141	176	80.1

package Test::Lazy::Tester;

use warnings;
use strict;

=head1 NAME

Test::Lazy::Tester

=head1 SYNOPSIS

	use Test::Lazy::Tester;

    $tester = Test::Lazy::Tester->new;

    # Will evaluate the code and check it:
	$tester->try('qw/a/' => eq => 'a');
	$tester->try('qw/a/' => ne => 'b');
	$tester->try('qw/a/' => is => ['a']);

    # Don't evaluate, but still compare:
	$tester->check(1 => is => 1);
	$tester->check(0 => isnt => 1);
	$tester->check(a => like => qr/[a-zA-Z]/);
	$tester->check(0 => unlike => qr/a-zA-Z]/);
	$tester->check(1 => '>' => 0);
	$tester->check(0 => '<' => 1);

    # A failure example:

	$tester->check([qw/a b/] => is => [qw/a b c/]);

    # Failed test '['a','b'] is ['a','b','c']'
    # Compared array length of $data
    #    got : array with 2 element(s)
    # expect : array with 3 element(s)


    # Custom test explanation:

	$tester->try('2 + 2' => '==' => 5, "Math is hard: %?");

    # Failed test 'Math is hard: 2 + 2 == 5'
    #      got: 4
    # expected: 5

=head1 DESCRIPTION

See L for more information.

=head1 METHODS

=head2 Test::Lazy::Tester->new( cmp_scalar => ?, cmp_structure => ?, render => ? )

Create a new Test::Lazy::Tester object, optionally amending the scalar comparison, structure comparison, and render subroutines
using the supplied hashes.

For now, more information on customization can be gotten by:

    perldoc -m Test::Lazy::Tester

=head2 $tester->check( , , , [  ] )

See L for details.

=head2 $tester->try( , , , [  ] )

See L for details.

=head2 $tester->template()

Creates a C using $tester as the basis.

See L for more details.

Returns a new L object.

=head2 $tester->render_value(  )

Render a gotten or expected value to a form suitable for the test notice/explanation.

This method will consult the $tester->render hash to see what if should do based on 'ref '.
By default, ARRAY and HASH are handled by Data::Dumper using the following:

        local $Data::Dumper::Indent = 0;
        local $Data::Dumper::Varname = 0;
        local $Data::Dumper::Terse = 1;

An undef value is a special case, handled by the $tester->render->{undef} subroutine.
By default, the subroutine returns the string "undef"

=head2 $tester->render_notice( , , ,  )

Render the text explantaion message. You don't need to mess with this.

=cut

use base qw/Class::Accessor::Fast/;

__PACKAGE__->mk_accessors(qw/render cmp_scalar cmp_structure/);

use Data::Dumper qw/Dumper/;
use Carp;
use Test::Deep;
use Test::Builder();

my $deparser;
eval {
    require B::Deparse;
    $deparser = B::Deparse->new;
    $deparser->ambient_pragmas(strict => 'all', warnings => 'all');
};
undef $deparser if $@;

my %base_cmp_scalar = (
	ok => sub {
        Test::More::ok($_[0], $_[2])
    },

	not_ok => sub {
        Test::More::ok(! $_[0], $_[2])
    },

	(map { my $mtd = $_; $_ => sub {
        Test::More::cmp_ok($_[0] => $mtd => $_[1], $_[2])
    } }
	qw/< > <= >= lt gt le ge == != eq ne/),

	(map { my $method = $_; $_ => sub {
        no strict 'refs';
       "Test::More::$method"->($_[0], $_[1], $_[2])
    } }
	qw/is isnt like unlike/),
);

my %base_cmp_structure = (
	ok => sub {
        Test::More::ok($_[0], $_[2])
    },

	not_ok => sub {
        Test::More::ok(! $_[0], $_[2])
    },

    (map { $_ => sub {
        Test::Deep::cmp_bag($_[0], $_[1], $_[2]);
    } }
    qw/bag same_bag samebag/),

    (map { $_ => sub {
        Test::Deep::cmp_set($_[0], $_[1], $_[2]);
    } }
    qw/set same_set sameset/),

    (map { $_ => sub {
        Test::Deep::cmp_deeply($_[0], $_[1], $_[2]);
    } }
    qw/same is like eq ==/),

	(map { $_ => sub {
        Test::More::ok(!Test::Deep::eq_deeply($_[0], $_[1]), $_[2]);
    } }
    qw/isnt unlink ne !=/),
);

my %base_render = (
    ARRAY => sub {
        local $Data::Dumper::Indent = 0;
        local $Data::Dumper::Varname = 0;
        local $Data::Dumper::Terse = 1;
        my $self = shift;
        my $value = shift;
        return Dumper($value);
    },

    HASH => sub {
        local $Data::Dumper::Indent = 0;
        local $Data::Dumper::Varname = 0;
        local $Data::Dumper::Terse = 1;
        my $self = shift;
        my $value = shift;
        return Dumper($value);
    },

    undef => sub {
        return "undef";
    },
);

sub new {
    my $self = bless {}, shift;
    local %_ = @_;
    $self->{cmp_scalar} = { %base_cmp_scalar, %{ $_{cmp_scalar} || {} } };
    $self->{cmp_structure} = { %base_cmp_structure, %{ $_{cmp_structure} || {} } };
    $self->{render} = { %base_render, %{ $_{base_render} || {} } };
    return $self;
}

sub render_notice {
    my $self = shift;
    my ($left, $compare, $right, $notice, $length) = @_;

	# my $_notice = $length == 4 ? "$left $compare $right" : "$left $compare";
	my $_notice = "$left $compare $right";
	if (defined $notice) {
        if ($notice =~ m/%\?/) {
		    $notice =~ s/%\?/$_notice/g;
        }
        else { # Old version, deprecated.
		    $notice =~ s/%(?!%)/%?/g;
		    $notice =~ s/%%/%/g;
		    $notice =~ s/%\?/$_notice/g;
        }
	}
	else {
		$notice = $_notice;
	}

    return $notice;
}

sub render_value {
    my $self = shift;
	my $value = shift;

    my $type = ref $value;
    $type = "undef" unless defined $value;

    return $value unless $type;
    return $value unless my $renderer = $self->render->{$type};
    return $renderer->($self, $value);
}

sub _test {
    my $self = shift;
	my ($compare, $got, $expect, $notice) = @_;

    local $Test::Builder::Level = $Test::Builder::Level + 1;

    my $cmp = $compare;
	if (ref $cmp eq "CODE") {
		Test::More::ok($cmp->($got, $expect), $notice);
	}
	else {
        my $structure = ref $expect eq "ARRAY" || ref $expect eq "HASH";
        my $scalar = ! $structure;

        my $cmp_source = $scalar ? $self->cmp_scalar : $self->cmp_structure;

		die "Don't know how to compare via ($compare)" unless $cmp = $cmp_source->{$cmp};
        local $Test::Builder::Level = $Test::Builder::Level + 1;
		$cmp->($got, $expect, $notice);
	}
}

sub check {
    my $self = shift;
	my ($got, $compare, $expect, $notice) = @_;
    my $length = @_;

	my $left = $self->render_value($got);
	my $right = $self->render_value($expect);
    $notice = $self->render_notice($left, $compare, $right, $notice, $length);

    local $Test::Builder::Level = $Test::Builder::Level + 1;

	return $self->_test($compare, $got, $expect, $notice);
}

sub try {
    my $self = shift;
	my ($statement, $compare, $expect, $notice) = @_;
    my $length = @_;

	my @got = ref $statement eq "CODE" ? $statement->() : eval $statement;
	die "$statement: $@" if $@;
	my $got;
	if (@got > 1) {
		if (ref $expect eq "ARRAY") {
			$got = \@got;
		}
		elsif (ref $expect eq "HASH") {
			$got = { @got };
		}
		else {
			$got = scalar @got;
		}
	}
	else {
		if (ref $expect eq "ARRAY" && (! @got || ref $got[0] ne "ARRAY")) {
			$got = \@got;
		}
		elsif (ref $expect eq "HASH" && ! @got) {
			$got = { };
		}
		else {
			$got = $got[0];
		}
	}

    my $left;
	if (ref $statement eq "CODE" && $deparser) {
		my $deparse = $deparser->coderef2text($statement);
		my @deparse = split m/\n\s*/, $deparse;
		$deparse = join ' ', "sub", @deparse if 3 == @deparse;
		$left = $deparse;
	}
	else {
		$left = $statement;
	}
	my $right = $self->render_value($expect);
    $notice = $self->render_notice($left, $compare, $right, $notice, $length);

    local $Test::Builder::Level = $Test::Builder::Level + 1;

	return $self->_test($compare, $got, $expect, $notice);
}

sub template {
    my $self = shift;
    require Test::Lazy::Template;
	return Test::Lazy::Template->new($self, @_);
}

1;