File Coverage

blib/lib/Test/Kantan.pm

Criterion	Covered	Total	%
statement	68	102	66.6
branch	6	16	37.5
condition	0	11	0.0
subroutine	22	36	61.1
pod	8	19	42.1
total	104	184	56.5

package Test::Kantan;
use 5.010_001;
use strict;
use warnings;

our $VERSION = "0.40";

use parent qw(Exporter);

use Try::Tiny;

use Test::Kantan::State;
use Test::Kantan::Builder;
use Test::Kantan::Caller;
use Test::Kantan::Suite;
use Test::Kantan::Expect;

use Test::Deep::NoTest qw(ignore);
use Module::Spy 0.03 qw(spy_on);

our @EXPORT = (
    qw(Feature Scenario Given When Then),
    qw(subtest done_testing setup teardown),
    qw(describe context it),
    qw(before_each after_each),
    qw(expect ok diag ignore spy_on),
    qw(skip_all),
);

my $HAS_DEVEL_CODEOBSERVER = !$ENV{KANTAN_NOOBSERVER} && eval "use Devel::CodeObserver 0.11; 1;";

our $Level = 0;

if (Test::Builder->can('new')) {
    # Replace some Test::Builder methods with mine.

    no warnings 'redefine';

    *Test::Builder::ok = sub {
        my ($self, $ok, $msg) = @_;
        Test::Kantan->builder->ok(
            value => $ok,
            message => $msg,
            caller => Test::Kantan::Caller->new(
                $Test::Builder::Level
            ),
        );
    };

    *Test::Builder::subtest = sub {
        my $self = shift;
        goto \&Test::Kantan::subtest;
    };

    *Test::Builder::diag = sub {
        my ($self, $message) = @_;

        Test::Kantan->builder->diag(
            message => $message,
            cutoff  => 1024,
            caller  => Test::Kantan::Caller->new($Test::Builder::Level),
        );
    };

    *Test::Builder::note = sub {
        my ($self, $message) = @_;

        Test::Kantan->builder->diag(
            message => $message,
            cutoff  => 1024,
            caller  => Test::Kantan::Caller->new($Test::Builder::Level),
        );
    };

    *Test::Builder::done_testing = sub {
        my ($self, $message) = @_;

        Test::Kantan->builder->done_testing()
    };
}

our $BUILDER = Test::Kantan::Builder->new();
sub builder { $BUILDER }

# -------------------------------------------------------------------------
# DSL functions

our $CURRENT = our $ROOT = Test::Kantan::Suite->new(root => 1, title => 'Root');
our $FINISHED;
our $RAN_TEST;

sub skip_all {
    my ($reason) = @_;
    $reason //= '';
    print "1..0 # SKIP ${reason}\n";
    exit 0;
}

sub setup(&) {
    my ($code) = @_;
    $CURRENT->add_trigger('setup' => $code);
}
sub before_each { goto \&setup }

sub teardown(&) {
    my ($code) = @_;
    $CURRENT->add_trigger('teardown' => $code);
}
sub after_each { goto \&teardown }

sub _step {
    my ($tag, $title) = @_;
    @_==2 or Carp::confess "Invalid arguments";

    my $last_state = $CURRENT->{last_state};
    $CURRENT->{last_state} = $tag;
    if ($last_state && $last_state eq $tag) {
        $tag = 'And';
    }
    builder->reporter->step(sprintf("%5s %s", $tag, $title));
}

sub Given { _step('Given', @_) }
sub When  { _step('When', @_) }
sub Then  { _step('Then', @_) }

sub _suite {
    my ($env_key, $tag, $title, $code) = @_;

    if (defined($env_key)) {
        my $filter = $ENV{$env_key};
        if (defined($filter) && length($filter) > 0 && $title !~ /$filter/) {
            builder->reporter->step("SKIP: ${title}");
            return;
        }
    }

    my $suite = Test::Kantan::Suite->new(
        title   => $title,
        parent  => $CURRENT,
    );
    {
        local $CURRENT = $suite;
        builder->subtest(
            title => defined($tag) ? "${tag} ${title}" : $title,
            code  => $code,
            suite => $suite,
        );
    }
    $RAN_TEST++;
}

sub Feature  { _suite('KANTAN_FILTER_FEATURE',  'Feature', @_) }
sub Scenario { _suite('KANTAN_FILTER_SCENARIO', 'Scenario', @_) }

# Test::More compat
sub subtest  { _suite('KANTAN_FILTER_SUBTEST', undef, @_) }

# BDD compat
sub describe { _suite(     undef, undef, @_) }
sub context  { _suite(     undef, undef, @_) }
sub it       { _suite(     undef, undef, @_) }

sub expect {
    my $stuff = shift;
    Test::Kantan::Expect->new(
        stuff   => $stuff,
        builder => Test::Kantan->builder
    );
}

sub ok(&) {
    my $code = shift;

    if ($HAS_DEVEL_CODEOBSERVER) {
        state $observer = Devel::CodeObserver->new();
        my ($retval, $result) = $observer->call($code);

        my $builder = Test::Kantan->builder;
        $builder->ok(
            value       => $retval,
            caller      => Test::Kantan::Caller->new(
                $Test::Kantan::Level
            ),
        );
        for my $pair (@{$result->dump_pairs}) {
            my ($code, $dump) = @$pair;

            $builder->diag(
                message => sprintf("%s => %s", $code, $dump),
                caller  => Test::Kantan::Caller->new(
                    $Test::Kantan::Level
                ),
                cutoff  => $builder->reporter->cutoff,
            );
        }
        return !!$retval;
    } else {
        my $retval = $code->();
        my $builder = Test::Kantan->builder;
        $builder->ok(
            value       => $retval,
            caller      => Test::Kantan::Caller->new(
                $Test::Kantan::Level
            ),
        );
    }
}

sub diag {
    my ($msg, $cutoff) = @_;

    Test::Kantan->builder->diag(
        message => $msg,
        cutoff  => $cutoff,
        caller  => Test::Kantan::Caller->new(
            $Test::Kantan::Level
        ),
    );
}

sub done_testing {
    builder->done_testing
}

END {
    if ($RAN_TEST) {
        unless (builder->finished) {
            die "You need to call `done_testing` before exit";
        }
    }
}


1;
__END__