File Coverage

blib/lib/Test/Workflow.pm

Criterion	Covered	Total	%
statement	145	148	97.9
branch	33	42	78.5
condition	10	19	52.6
subroutine	32	32	100.0
pod	13	17	76.4
total	233	258	90.3

package Test::Workflow;
use strict;
use warnings;

use Exporter::Declare;
use Test::Workflow::Meta;
use Test::Workflow::Test;
use Test::Workflow::Layer;
use List::Util qw/shuffle/;
use Carp qw/croak/;
use Scalar::Util qw/blessed/;

our @CARP_NOT = qw/ Test::Workflow Test::Workflow::Test /;

default_exports qw/
    tests       run_tests
    describe    it
    cases       case
    before_case after_case
    before_each after_each around_each
    before_all  after_all  around_all
    with_tests
    test_sort
    /;

gen_default_export TEST_WORKFLOW => sub {
    my ( $class, $importer ) = @_;
    my $meta = Test::Workflow::Meta->new($importer);
    return sub { $meta };
};

{ no warnings 'once'; @DB::CARP_NOT = qw/ DB Test::Workflow / }

sub _get_layer {
    my ( $offset, $sub, $caller ) = @_;

    my $meta = $caller->[0]->TEST_WORKFLOW;
    croak "$sub() can only be used within a describe or case block, or at the package level."
        if $meta->build_complete;

    my $layer = $meta->peek_layer;

    if ( blessed($layer) && blessed($layer)->isa('Test::Workflow::Layer') ) {
        croak "Layer has already been finalized!"
            if $layer->finalized;
        return $layer;
    }

    return $meta->root_layer;
}

sub with_tests {
    my @caller = caller;
    my $layer = _get_layer( 0, 'with_tests', \@caller );
    $layer->merge_in( \@caller, @_ );
}

{
    no warnings 'once';
    *it = \&tests;
}

sub tests {
    my $name   = shift;
    my @caller = caller;
    my $layer  = _get_layer( 0, 'tests', \@caller );
    $layer->add_test(
        \@caller,
        $name,
        verbose => 1,
        @_
    );
}

sub describe { _add_child( 'describe', @_ ) }
sub cases    { _add_child( 'case',     @_ ) }

sub _add_child {
    my $type   = shift;
    my @caller = caller(1);
    my $layer  = _get_layer( 1, $type, \@caller );
    $layer->add_child( \@caller, @_ );
}

sub case        { _add_type( 'case',        @_ ) }
sub before_case { _add_type( 'before_case', @_ ) }
sub before_each { _add_type( 'before_each', @_ ) }
sub before_all  { _add_type( 'before_all',  @_ ) }
sub after_each  { _add_type( 'after_each',  @_ ) }
sub after_all   { _add_type( 'after_all',   @_ ) }
sub after_case  { _add_type( 'before_each', @_ ) }
sub around_each { _add_type( 'around_each', @_ ) }
sub around_all  { _add_type( 'around_all',  @_ ) }

sub _add_type {
    my $type = shift;
    my $meth = "add_$type";

    my @caller = caller(1);
    my $layer = _get_layer( 1, $type, \@caller );
    $layer->$meth( \@caller, @_ );
}

sub test_sort { caller->TEST_WORKFLOW->test_sort(@_) }

sub run_tests {
    my ($instance) = @_;
    unless ($instance) {
        my $caller = caller;
        $instance = $caller->new() if $caller->can('new');
        $instance ||= bless( {}, $caller );
    }
    my $layer = $instance->TEST_WORKFLOW->root_layer;
    my @tests = get_tests( $instance, $layer, 'PACKAGE LEVEL', [], [], [], [], [] );
    $instance->TEST_WORKFLOW->build_complete(1);
    my $sort = $instance->TEST_WORKFLOW->test_sort || 'rand';
    @tests = order_tests( $sort, @tests );
    $_->run($instance) for @tests;
}

sub order_tests {
    my ( $sort, @tests ) = @_;

    if ( "$sort" =~ /^sort/ ) {
        @tests = sort { $a->name cmp $b->name } @tests;
    }
    elsif ( "$sort" =~ /^rand/ ) {
        @tests = shuffle @tests;
    }
    elsif ( ref $sort eq 'CODE' ) {
        @tests = $sort->(@tests);
    }
    elsif ( $sort !~ /^ord/ ) {
        croak "'$sort' is not a recognized option to test_sort";
    }

    return sort {
        return 0 if $a->is_wrap == $b->is_wrap;
        return 1 if $a->is_wrap;
        return 0;
    } @tests;
}

#<<< no-tidy
sub get_tests {
    my ( $instance, $layer, $name, $before_case, $before_each, $after_each, $around_each, $control, $todo ) = @_;

    # get before_each and after_each
    push    @$before_case => @{ $layer->before_case };
    push    @$before_each => @{ $layer->before_each };
    push    @$around_each => @{ $layer->around_each };
    push    @$control     => @{ $layer->control     };
    unshift @$after_each  => @{ $layer->after_each  };

    my @tests = @{ $layer->test };

    if ($todo) {
        $_->todo( $todo ) for @tests
    }

    if ( my $specific = $ENV{FENNEC_TEST}) {
        @tests = grep {
            my $out = 0;
            if ( $specific =~ m/^\d+$/ ) {
                $out = 1 if $_->start_line <= $specific && $_->end_line >= $specific;
            }
            else {
                $out = 1 if $_->name eq $specific;
            }
            $out;
        } @tests;
    }

    my @cases = @{ $layer->case };
    if ( @cases ) {
        my @new_tests;
        for my $test ( @tests ) {
            for my $case ( @cases ) {
                push @new_tests => Test::Workflow::Test->new(
                    setup => [ @$before_case, $case, @$before_each ],
                    tests => [
                        $test->clone_with(
                            name => "'" . $case->name . "' x '" . $test->name . "'"
                        )
                    ],
                    teardown   => [ @$after_each  ],
                    around     => [ @$around_each ],
                    control    => [ @$control     ],
                    block_name => $name,
                );
            }
        }
        @tests = @new_tests;
    }
    else {
        @tests = map { Test::Workflow::Test->new(
            setup      => [ @$before_each ],
            tests      => [ $_            ],
            teardown   => [ @$after_each  ],
            around     => [ @$around_each ],
            control    => [ @$control     ],
            block_name => $name,
        )} @tests;
    }

    push @tests => map {
        my $layer = Test::Workflow::Layer->new;

        $instance->TEST_WORKFLOW->push_layer( $layer );
        $_->todo( $todo ) if $todo;
        $_->run( $instance, $layer );

        my @tests = get_tests(
            $instance,
            $layer,
            $_->name,
            [@$before_case],
            [@$before_each],
            [@$after_each],
            [@$around_each],
            [@$control],
            $_->todo,
        );

        $instance->TEST_WORKFLOW->pop_layer( $layer );

        unless (@tests) {
            my $name  = $_->name;
            my $start = $_->start_line;
            my $end   = $_->end_line;
            warn "No tests in block '$name' approx lines $start -> $end\n"
                unless $ENV{FENNEC_TEST};
        }

        @tests;
    } @{ $layer->child };

    my @before_all = @{ $layer->before_all };
    my @after_all  = @{ $layer->after_all  };
    my @around_all = @{ $layer->around_all };
    my @control    = @{ $layer->control    };
    return Test::Workflow::Test->new(
        setup      => [ @before_all ],
        tests      => [ @tests      ],
        teardown   => [ @after_all  ],
        around     => [ @around_all ],
        control    => [ @control    ],
        block_name => $name,
        is_wrap    => 1,
    ) if @before_all || @after_all || @around_all || @control;

    return @tests;
}
#>>>

1;

__END__