File Coverage

blib/lib/Test/Expr.pm

Criterion	Covered	Total	%
statement	86	131	65.6
branch	16	32	50.0
condition	15	32	46.8
subroutine	14	14	100.0
pod			n/a
total	131	209	62.6

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

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_MATCHABLE = qr{ ^ (?&PerlOWS)
                           (?>
                               (?&PerlMatch)
                             | (?&PerlSubstitution)
                             | (?&PerlTransliteration)
                           )
                           $PPR::GRAMMAR
                       }xms;

use re 'eval';
my $PERL_FIND_VARS = qr{
    ^ (?&PerlExpression)

    (?(DEFINE)
        (?
            (
                (?= [\$\@%] )
                (?>
                    (?&PerlScalarAccess)
                |   (?&PerlHashAccess)
                |   (?&PerlArrayAccess)
                )
            )
            (?{ $Test::Expr::vars{$^N} = 1 })
        )

        (?
            (
                (?>(?&PerlVariableScalarNoSpace))
                (?:
                    (?:
                        (?:
                            ->
                            (?&PerlParenthesesList)
                        |
                            (?: -> )?+
                            (?> \$\* | (?&PerlArrayIndexer) | (?&PerlHashIndexer) )
                        )
                        (?:
                            (?: -> )?+
                            (?> \$\* | (?&PerlArrayIndexer) | (?&PerlHashIndexer) | (?&PerlParenthesesList) )
                        )*+
                    )?+
                    (?:
                        ->
                        [\@%]
                        (?> \* | (?&PerlArrayIndexer) | (?&PerlHashIndexer) )
                    )?+
                )?+
            )
            (?{ $Test::Expr::vars{$^N} = 1 })
        ) # End of rule


        (?
            (
                (?>(?&PerlVariableArrayNoSpace))
                (?:
                    (?: -> )?+
                    (?> \$\* | (?&PerlArrayIndexer) | (?&PerlHashIndexer) | (?&PerlParenthesesList)  )
                )*+
                (?:
                    ->
                    [\@%]
                    (?> \* | (?&PerlArrayIndexer) | (?&PerlHashIndexer) )
                )?+
            )
            (?{ $Test::Expr::vars{$^N} = 1 })
        ) # End of rule
    )

    $PPR::GRAMMAR
}xms;

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

my $PERL_EXPR = qr{
    ^ (?>(?&PerlOWS))  (? (?>(?&PerlHighBinaryExpression)) )
      (?>(?&PerlOWS))  (?  (?> [<>]=?|[=!]=|<=>|[~=!]~|\b(?:[lg]t|[lgn]e|eq|cmp)\b))
      (?>(?&PerlOWS))  (? .*)

    (?(DEFINE)

        (?
                                (?>(?&PerlPrefixPostfixTerm))
            (?: (?>(?&PerlOWS)) (?>(?&PerlInfixHighBinaryOperator))
                (?>(?&PerlOWS))    (?&PerlPrefixPostfixTerm) )*+
        )

        (?
            (?>  [+]             (?! [+=] )
            |     -              (?! [-=] )
            |    [.]{2,3}+
            |    [.%x]           (?! [=]  )
            |    [&|^][.]        (?! [=]  )
            |    [*&|/]{1,2}+    (?! [=]  )
            |    [<>]{2}         (?! [=]  )
            |    \^              (?! [=]  )
            )
        ) # End of rule
    )

    $PPR::GRAMMAR

}mxs;

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/;

        # Handle low-precedence prefix not...
        (my $pos_test_code = $test_code) =~ s/^\s*(not)\b//;
        my $negative = $pos_test_code eq $test_code ? q{} : 'not';

        # Extract components of test, if possible...
        $pos_test_code =~ $PERL_EXPR;
        my ($lhs, $op, $rhs) = @+{qw};

        # These hold rearranged code to capture and test component values (if possible)...
        my $test_setup;
        my $test_expr;

        # Don't try to capture explicit regex matches on the rhs...
        if ($op && $op =~ /[=!~]~/ && $rhs =~ $PERL_MATCHABLE) {
            $test_setup = qq{ my \$_____l_h_s_____ = $lhs; };
            $test_expr  = qq{ $negative \$_____l_h_s_____ $op $rhs };
            $rhs = "";
        }

        # Catch lhs and rhs values for other comparison operators...
        elsif ($op) {
            $test_setup = qq{ my \$_____l_h_s_____ = $lhs; my \$_____r_h_s_____ = $rhs; };
            $test_expr  = qq{ $negative \$_____l_h_s_____ $op \$_____r_h_s_____ };
        }

        # Otherwise just execute the text verbatim...
        else {
            $lhs = "";
            $rhs = "";
            $test_setup = qq{my \$_____l_h_s_____ = $test_code;};
            $test_expr  = q{$_____l_h_s_____};
        }

        # Extract and tidy all variables in the test expression...
        %Test::Expr::vars = ();
        $test_code =~ $PERL_FIND_VARS;
        my @vars = grep {defined} keys %Test::Expr::vars;
        ($lhs, $rhs, @vars) = map {_trim $_} $lhs, $rhs, @vars;

        # Find maximum width of any reported value, so we can align them...
        my $var_len = max map {length} $lhs, $rhs, @vars;

        # Generate diagnostics (reporting each distinct value only once)...
        my %seen = ( $rhs => 1, $lhs => 1 );
        my @diagnostics = (
              ( $lhs && $lhs !~ $PERL_LITERAL
                  ? qq{diag sprintf(q{    %${var_len}s --> }, q{$lhs}),
                      Data::Dump::dump(\$_____l_h_s_____);}
                  : ()
              ),
              ( $rhs && $rhs !~ $PERL_LITERAL
                  ? qq{diag sprintf(q{    %${var_len}s --> }, q{$rhs}),
                      Data::Dump::dump(\$_____r_h_s_____);}
                  : ()
              ),
              map {qq{diag sprintf(q{    %${var_len}s --> }, q{$_}), Data::Dump::dump($_);}}
                  grep { !$seen{$_}++ }
                       @vars
        );

        # Build the diagnostic code...
        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...
        my $new_test_code = qq{
            {
                $test_setup
                if ($test_expr) {
                    Test::More::ok(1, $desc);
                }
                else {
                    fail($desc); @diagnostics diag q{};
                }
            }
        };
        $new_test_code =~ tr/\n/ /;
        return $new_test_code;
    }
}

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