File Coverage

blib/lib/Test/Expr.pm

Criterion	Covered	Total	%
statement	70	108	64.8
branch	9	24	37.5
condition	5	14	35.7
subroutine	13	13	100.0
pod			n/a
total	97	159	61.0

package Test::Expr;
our $VERSION = '0.000006';

use 5.012; use warnings;
use Keyword::Declare;
use Data::Dump;
use List::Util 'max';
use Test::More;
use parent 'Exporter';
our @EXPORT = @Test::More::EXPORT;

sub _trim {
    my $str = shift;
    $str =~ s{\A\s*|\s*\Z}{}g;
    return $str;
}

my $PERL_VAR = qr{ ((?&PerlVariable)) $PPR::GRAMMAR }xms;
my $PERL_LITERAL = qr{^ (?> (?&PerlString)
                          | (?&PerlQuotelikeQR)
                          | (?&PerlQuotelikeQW)
                          | (?&PerlNumber)        ) $ $PPR::GRAMMAR }xms;

sub import {
    my ($package) = @_;
    $package->export_to_level(1, @_);

    keyword ok (Expr $test) {{{
        ok do{«$test»}, q{«$test»};
    }}}

    keyword ok (ListElem $test, Comma, ListElem $desc) {
        # Work out what values to report if there's a problem...
        (my $test_code = $test) =~ s/^\s*do\s*\{(.*)\}\s*$/$1/;
        my ($lhs, $op, $rhs)
            = $test_code =~ m{(.*?)
                              (<|(?!<-)>|<=|>=|==|!=|<=>|~~|\b(?:lt|gt|le|ge|eq|ne|cmp)\b)
                              (.*)
                              }xms;
        my $test_setup;
        my $test_expr;

        if ($op) {
            $test_setup = qq{my \$lhs = $lhs; my \$rhs = $rhs;};
            $test_expr  = '$lhs '.$op.' $rhs';
        }
        else {
            $lhs = $test_code;
            $rhs = "";
            $test_setup = qq{my \$lhs = $lhs;};
            $test_expr = q{$lhs};
        }

        my @vars = grep {defined} $test =~ m{$PERL_VAR}g;
        ($lhs, $rhs, @vars) = map {_trim $_} $lhs, $rhs, @vars;
        my $var_len = max map {length} $lhs, $rhs, @vars;
        my %seen = ( $rhs => 1, $lhs => 1 );
        my @diagnostics = (
              ( $lhs !~ $PERL_LITERAL
                  ? qq{diag sprintf(q{    %${var_len}s --> }, '$lhs'), Data::Dump::dump(\$lhs);}
                  : ()
              ),
              ( $rhs && $rhs !~ $PERL_LITERAL
                  ? qq{diag sprintf(q{    %${var_len}s --> }, '$rhs'), Data::Dump::dump(\$rhs);}
                  : ()
              ),
              map {qq{diag sprintf(q{    %${var_len}s --> }, q{$_}), Data::Dump::dump($_);}}
                  grep { !$seen{$_}++ }
                       @vars
        );

        unshift @diagnostics, qq{diag q{  because:};}
            if @diagnostics;
        unshift @diagnostics, qq{diag q{}; diag q{  ($test_code) was false};}
            if (eval($desc)//'') ne qq{$test_code};

        # Build the test code...
        qq{
            {
                $test_setup
                if ($test_expr) {
                    Test::More::ok(1, $desc);
                }
                else {
                    fail($desc); @diagnostics diag q{};
                }
            }
        };
    }
}

1; # Magic true value required at end of module
__END__