view release on metacpan or  search on metacpan

lib/Test/Kantan.pm  view on Meta::CPAN

    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";
        }
    }
}