File Coverage

blib/lib/Test/Stream/Workflow.pm

Criterion	Covered	Total	%
statement	166	166	100.0
branch	78	80	97.5
condition	39	47	82.9
subroutine	38	38	100.0
pod	15	16	93.7
total	336	347	96.8

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

use Scalar::Util qw/reftype blessed/;
use Carp qw/confess croak/;

use Test::Stream::Sync();

use Test::Stream::Workflow::Meta();
use Test::Stream::Workflow::Unit();

use Test::Stream::Context qw/context/;
use Test::Stream::Util qw/try set_sub_name CAN_SET_SUB_NAME sub_info update_mask/;

use Test::Stream::Exporter qw/exports export import/;
exports qw{
    workflow_build
    workflow_current
    workflow_meta
    workflow_runner
    workflow_runner_args
    workflow_var
    workflow_run
    new_proto_unit
    group_builder
    gen_unit_builder
    push_workflow_build
    pop_workflow_build
    push_workflow_vars
    pop_workflow_vars
    has_workflow_vars
};

export import => sub {
    my $class = shift;
    my ($pkg, $file, $line) = caller;

    Test::Stream::Exporter::export_from($class, $pkg, \@_);

    # This is a no-op if it has already been done.
    Test::Stream::Workflow::Meta->build($pkg, $file, $line, 'EOF');
};

export unimport => sub {
    my $caller = caller;
    my $meta = Test::Stream::Workflow::Meta->get($caller);
    $meta->set_autorun(0);
};
no Test::Stream::Exporter;

my $PKG = __PACKAGE__;
my %ALLOWED_STASHES = map {$_ => 1} qw{
    primary
    modify
    buildup
    teardown
    buildup+teardown
};

my @BUILD;
my @VARS;

sub workflow_current     { _current(caller) }
sub workflow_meta        { Test::Stream::Workflow::Meta->get(scalar caller) }
sub workflow_run         { Test::Stream::Workflow::Meta->get(scalar caller)->run(@_) }
sub workflow_runner      { Test::Stream::Workflow::Meta->get(scalar caller)->set_runner(@_) }
sub workflow_runner_args { Test::Stream::Workflow::Meta->get(scalar caller)->set_runner_args(@_) }

sub workflow_build { @BUILD ? $BUILD[-1] : undef }
sub push_workflow_build { push @BUILD => $_[0] || die "Nothing to push"; $_[0] }

sub pop_workflow_build {
    my ($should_be) = @_;

    croak "Build stack mismatch"
        unless @BUILD && $should_be && $BUILD[-1] == $should_be;

    pop @BUILD;
}

sub has_workflow_vars { scalar @VARS }
sub push_workflow_vars {
    my $vars = shift || {};
    push @VARS => $vars;
    $vars;
}

sub pop_workflow_vars {
    my ($should_be) = @_;

    croak "Vars stack mismatch!"
        unless @VARS && $should_be && $VARS[-1] == $should_be;

    my $it = pop @VARS;
    %$it = ();
    return;
}

sub workflow_var {
    confess "No VARS! workflow_var() should only be called inside a unit sub"
        unless @VARS;

    my $vars = $VARS[-1];

    my $name = shift;
    if (@_) {
        if (ref $_[0] && reftype($_[0]) eq 'CODE') {
            $vars->{$name} = $_[0]->()
                unless defined $vars->{$name};
        }
        else {
            ($vars->{$name}) = @_;
        }
    }
    return $vars->{$name};
};

sub _current {
    my ($caller) = @_;

    return $BUILD[-1] if @BUILD;
    my $spec_meta = Test::Stream::Workflow::Meta->get($caller) || return;
    return $spec_meta->unit;
}

sub die_at_caller {
    my ($caller, $msg) = @_;
    die "$msg at $caller->[1] line $caller->[2].\n";
}

sub new_proto_unit {
    my %params = @_;
    $params{level} = 1 unless defined $params{level};
    my $caller = $params{caller} || [caller($params{level})];
    my $args = $params{args};
    my $subname = $params{subname};

    unless ($subname) {
        $subname = $caller->[3];
        $subname =~ s/^.*:://g;
    }

    my ($name, $code, $meta, @lines);
    for my $item (@$args) {
        if (my $type = reftype($item)) {
            if ($type eq 'CODE') {
                die_at_caller $caller => "$subname() only accepts 1 coderef argument per call"
                    if $code;

                $code = $item;
            }
            elsif ($type eq 'HASH') {
                die_at_caller $caller => "$subname() only accepts 1 meta-hash argument per call"
                    if $meta;

                $meta = $item;
            }
            else {
                die_at_caller $caller => "Unknown argument to $subname: $item";
            }
        }
        elsif ($item =~ m/^\d+$/) {
            die_at_caller $caller => "$subname() only accepts 2 line number arguments per call (got: " . join(', ', @lines, $item) . ")"
                if @lines >= 2;

            push @lines => $item;
        }
        else {
            die_at_caller $caller => "$subname() only accepts 1 name argument per call (got: '$name', '$item')"
                if $name;

            $name = $item;
        }
    }

    die_at_caller $caller => "$subname() requires a name argument (non-numeric string)"
        unless $name;
    die_at_caller $caller => "$subname() requires a code reference"
        unless $code;

    my $info = sub_info($code, @lines);
    set_sub_name("$caller->[0]\::$name", $code) if CAN_SET_SUB_NAME && $info->{name} =~ m/__ANON__$/;

    my $unit = Test::Stream::Workflow::Unit->new(
        name       => $name,
        meta       => $meta,
        package    => $caller->[0],
        file       => $info->{file},
        start_line => $info->{start_line} || $caller->[2],
        end_line   => $info->{end_line}   || $caller->[2],

        $params{set_primary} ? (primary => $code) : (),

        $params{unit} ? (%{$params{unit}}) : (),
    );

    return ($unit, $code, $caller);
}


BEGIN { update_mask('*', '*', __PACKAGE__ . '::group_builder', {hide => 1}) }
sub group_builder {
    my ($unit, $code, $caller) = new_proto_unit(
        args => \@_,
        unit => { type => 'group' },
    );

    push_workflow_build($unit);
    my ($ok, $err) = try {
        BEGIN { update_mask(__FILE__, __LINE__ + 1, '*', {hide => 1}) }
        $code->($unit);
        1; # To force the previous statement to be in void context
    };
    pop_workflow_build($unit);
    die $err unless $ok;

    $unit->do_post;
    $unit->adjust_lines();

    return $unit if defined wantarray;

    my $current = _current($caller->[0])
        or confess "Could not find the current build!";

    $current->add_primary($unit);
}

sub _unit_builder_callback_simple {
    my ($current, $unit, @stashes) = @_;
    $current->$_($unit) for map {"add_$_"} @stashes;
}

sub _unit_builder_callback_modifiers {
    my ($current, $unit, @stashes) = @_;
    $current->add_post(sub {
        my $modify = $current->modify || return;
        for my $mod (@$modify) {
            $mod->$_($unit) for map {"add_$_"} @stashes;
        }
    });
}

sub _unit_builder_callback_primaries {
    my ($current, $unit, @stashes) = @_;

    # Get the stash, we will be using it just like any plugin might
    my $stash = $current->stash;

    # If we do not have data in the stash yet then we need to do some preliminary setup
    unless($stash->{$PKG}) {
        # Add our hash to the stash
        $stash->{$PKG} = {};

        # Add the post-callback, do it once here, we don't want to add
        # duplicate callbacks
        $current->add_post(sub {
            my $stuff = delete $stash->{$PKG};

            my $modify   = $stuff->{modify};
            my $buildup  = $stuff->{buildup};
            my $primary  = $stuff->{primary};
            my $teardown = $stuff->{teardown};

            my @search = ($current);
            while (my $it = shift @search) {
                if ($it->type && $it->type eq 'group') {
                    my $prim = $it->primary or next;
                    push @search => @$prim;
                    next;
                }

                unshift @{$it->{modify}}   => @$modify   if $modify;
                unshift @{$it->{buildup}}  => @$buildup  if $buildup;
                push    @{$it->{primary}}  => @$primary  if $primary;
                push    @{$it->{teardown}} => @$teardown if $teardown;
            }
        });
    }

    # Add the unit to the plugin stash for each unit stash (these names are not
    # ideal...) The data will be used by the post-callback that has already been added
    push @{$stash->{$PKG}->{$_}} => $unit for @stashes;
}

sub gen_unit_builder {
    my %params = @_;
    my $name = $params{name};
    my $callback = $params{callback} || croak "'callback' is a required argument";
    my $stashes = $params{stashes} || croak "'stashes' is a required argument";

    my $reftype = reftype($callback) || "";
    my $cb_sub = $reftype eq 'CODE' ? $callback : $PKG->can("_unit_builder_callback_$callback");
    croak "'$callback' is not a valid callback"
        unless $cb_sub;

    $reftype = reftype($stashes) || "";
    croak "'stashes' must be an array reference (got: $stashes)"
        unless $reftype eq 'ARRAY';

    my $wrap = @$stashes > 1 ? 1 : 0;
    my $check = join '+', sort @$stashes;
    croak "'$check' is not a valid stash"
        unless $ALLOWED_STASHES{$check};

    return sub {
        my ($unit, $code, $caller) = new_proto_unit(
            set_primary => 1,
            args        => [@_],
            unit        => {type => 'single', wrap => $wrap},
            name        => $name,
        );

        my $subname = $name || $caller->[3];

        confess "$subname must only be called in a void context"
            if defined wantarray;

        my $current = _current($caller->[0])
            or confess "Could not find the current build!";

        $cb_sub->($current, $unit, @$stashes);
    }
}

1;

__END__