<html><head><meta name="color-scheme" content="light dark"></head><body><pre style="word-wrap: break-word; white-space: pre-wrap;">package Test2::Workflow::Runner;
use strict;
use warnings;

our $VERSION = '0.000162';

use Test2::API();
use Test2::Todo();
use Test2::AsyncSubtest();

use Test2::Util qw/get_tid CAN_REALLY_FORK/;

use Scalar::Util qw/blessed/;
use Time::HiRes qw/sleep/;
use List::Util qw/shuffle min/;
use Carp qw/confess/;

use Test2::Util::HashBase qw{
    stack no_fork no_threads max slots pid tid rand subtests filter
};

use overload(
    'fallback' =&gt; 1,
    '&amp;{}' =&gt; sub {
        my $self = shift;

        sub {
            @_ = ($self);
            goto &amp;run;
        }
    },
);

sub init {
    my $self = shift;

    $self-&gt;{+STACK}    = [];
    $self-&gt;{+SUBTESTS} = [];

    $self-&gt;{+PID} = $$;
    $self-&gt;{+TID} = get_tid();

    $self-&gt;{+NO_FORK} ||= $ENV{T2_WORKFLOW_NO_FORK} || !CAN_REALLY_FORK();

    my $can_thread = Test2::AsyncSubtest-&gt;CAN_REALLY_THREAD();
    my $should_thread = ($ENV{T2_WORKFLOW_USE_THREADS} || $ENV{T2_DO_THREAD_TESTS}) &amp;&amp; !$ENV{T2_WORKFLOW_NO_THREADS};
    $self-&gt;{+NO_THREADS} ||= !($can_thread &amp;&amp; $should_thread);

    $self-&gt;{+RAND} = 1 unless defined $self-&gt;{+RAND};

    my @max = grep {defined $_} $self-&gt;{+MAX}, $ENV{T2_WORKFLOW_ASYNC};
    my $max = @max ? min(@max) : 3;
    $self-&gt;{+MAX} = $max;
    $self-&gt;{+SLOTS} = [] if $max;

    unless(defined($self-&gt;{+FILTER})) {
        if (my $raw = $ENV{T2_WORKFLOW}) {
            my ($file, $line, $name);
            if ($raw =~ m/^(.*)\s+(\d+)$/) {
                ($file, $line) = ($1, $2);
            }
            elsif($raw =~ m/^(\d+)$/) {
                $line = $1;
            }
            else {
                $name = $raw;
            }

            $self-&gt;{+FILTER} = {
                file =&gt; $file,
                line =&gt; $line,
                name =&gt; $name,
            };
        }
    }

    if (my $task = delete $self-&gt;{task}) {
        $self-&gt;push_task($task);
    }
}

sub is_local {
    my $self = shift;
    return 0 unless $self-&gt;{+PID} == $$;
    return 0 unless $self-&gt;{+TID} == get_tid();
    return 1;
}

sub send_event {
    my $self = shift;
    my ($type, %params) = @_;

    my $class;
    if ($type =~ m/\+(.*)$/) {
        $class = $1;
    }
    else {
        $class = "Test2::Event::$type";
    }

    my $hub = Test2::API::test2_stack()-&gt;top();

    my $e = $class-&gt;new(
        trace =&gt; Test2::Util::Trace-&gt;new(
            frame =&gt; [caller(0)],
            buffered =&gt; $hub-&gt;buffered,
            nested   =&gt; $hub-&gt;nested,
            hid      =&gt; $hub-&gt;hid,
            huuid    =&gt; $hub-&gt;uuid,
            #cid      =&gt; $self-&gt;{+CID},
            #uuid     =&gt; $self-&gt;{+UUID},
        ),

        %params,
    );

    $hub-&gt;send($e);
}

sub current_subtest {
    my $self = shift;
    my $stack = $self-&gt;{+STACK} or return undef;

    for my $state (reverse @$stack) {
        next unless $state-&gt;{subtest};
        return $state-&gt;{subtest};
    }

    return undef;
}

sub run {
    my $self = shift;

    my $stack = $self-&gt;stack;

    my $c = 0;
    while (@$stack) {
        $self-&gt;cull;

        my $state  = $stack-&gt;[-1];
        my $task   = $state-&gt;{task};

        unless($state-&gt;{started}++) {
            my $skip = $task-&gt;skip;

            my $filter;
            if (my $f = $self-&gt;{+FILTER}) {
                my $in_var = grep { $_-&gt;{filter_satisfied} } @$stack;

                $filter = $task-&gt;filter($f) unless $in_var;
                $state-&gt;{filter_satisfied} = 1 if $filter-&gt;{satisfied};
            }

            $skip ||= $filter-&gt;{skip} if $filter;

            if ($skip) {
                $state-&gt;{ended}++;
                $self-&gt;send_event(
                    'Skip',
                    reason         =&gt; $skip || $filter,
                    name           =&gt; $task-&gt;name,
                    pass           =&gt; 1,
                    effective_pass =&gt; 1,
                );
                pop @$stack;
                next;
            }

            if ($task-&gt;flat) {
                my $st = $self-&gt;current_subtest;
                my $hub = $st ? $st-&gt;hub : Test2::API::test2_stack-&gt;top;

                $state-&gt;{todo} = Test2::Todo-&gt;new(reason =&gt; $task-&gt;todo, hub =&gt; $hub)
                    if $task-&gt;todo;

                $hub-&gt;send($_) for @{$task-&gt;events};
            }
            else {
                my $st = Test2::AsyncSubtest-&gt;new(
                    name  =&gt; $task-&gt;name,
                    frame =&gt; $task-&gt;frame,
                );
                $state-&gt;{subtest} = $st;

                $state-&gt;{todo} = Test2::Todo-&gt;new(reason =&gt; $task-&gt;todo, hub =&gt; $st-&gt;hub)
                    if $task-&gt;todo;

                for my $e (@{$task-&gt;events}) {
                    my $hub = $st-&gt;hub;

                    $e-&gt;trace-&gt;{buffered} = $hub-&gt;buffered;
                    $e-&gt;trace-&gt;{nested}   = $hub-&gt;nested;
                    $e-&gt;trace-&gt;{hid}      = $hub-&gt;hid;
                    $e-&gt;trace-&gt;{huuid}    = $hub-&gt;uuid;

                    $hub-&gt;send($e);
                }

                my $slot = $self-&gt;isolate($state);

                # if we forked/threaded then this state has ended here.
                if (defined($slot)) {
                    push @{$self-&gt;{+SUBTESTS}} =&gt; [$st, $task] unless $st-&gt;finished;
                    $state-&gt;{subtest} = undef;
                    $state-&gt;{ended} = 1;
                }
            }
        }

        if ($state-&gt;{ended}) {
            $state-&gt;{todo}-&gt;end() if $state-&gt;{todo};
            $state-&gt;{subtest}-&gt;stop() if $state-&gt;{subtest};

            return if $state-&gt;{in_thread};
            if(my $guard = delete $state-&gt;{in_fork}) {
                $state-&gt;{subtest}-&gt;detach;
                $guard-&gt;dismiss;
                exit 0;
            }

            pop @$stack;
            next;
        }

        if($state-&gt;{subtest} &amp;&amp; !$state-&gt;{subtest_started}++) {
            push @{$self-&gt;{+SUBTESTS}} =&gt; [$state-&gt;{subtest}, $task];
            $state-&gt;{subtest}-&gt;start();
        }

        if ($task-&gt;isa('Test2::Workflow::Task::Action')) {
            $state-&gt;{PID} = $$;
            my $ok = eval { $task-&gt;code-&gt;($self); 1 };

            unless ($state-&gt;{PID} == $$) {
                print STDERR "Task '" . $task-&gt;name . "' started in pid $state-&gt;{PID}, but ended in pid $$, did you forget to exit after forking?\n";
                exit 255;
            }

            $task-&gt;exception($@) unless $ok;
            $state-&gt;{ended} = 1;

            next;
        }

        if (!$state-&gt;{stage} || $state-&gt;{stage} eq 'BEFORE') {
            $state-&gt;{before}  = (defined $state-&gt;{before}) ? $state-&gt;{before} : 0;

            if (my $add = $task-&gt;before-&gt;[$state-&gt;{before}++]) {
                if ($add-&gt;around) {
                    $state-&gt;{PID} = $$;
                    my $ok = eval { $add-&gt;code-&gt;($self); 1 };
                    my $err = $@;
                    my $complete = $state-&gt;{stage} &amp;&amp; $state-&gt;{stage} eq 'AFTER';

                    unless ($state-&gt;{PID} == $$) {
                        print STDERR "Task '" . $task-&gt;name . "' started in pid $state-&gt;{PID}, but ended in pid $$, did you forget to exit after forking?\n";
                        exit 255;
                    }

                    unless($ok &amp;&amp; $complete) {
                        $state-&gt;{ended} = 1;
                        $state-&gt;{stage} = 'AFTER';
                        $task-&gt;exception($ok ? "'around' task failed to continue into the workflow chain.\n" : $err);
                    }
                }
                else {
                    $self-&gt;push_task($add);
                }
            }
            else {
                $state-&gt;{stage} = 'VARIANT';
            }
        }
        elsif ($state-&gt;{stage} eq 'VARIANT') {
            if (my $v = $task-&gt;variant) {
                $self-&gt;push_task($v);
            }
            $state-&gt;{stage} = 'PRIMARY';
        }
        elsif ($state-&gt;{stage} eq 'PRIMARY') {
            unless (defined $state-&gt;{order}) {
                my $rand = defined($task-&gt;rand) ? $task-&gt;rand : $self-&gt;rand;
                $state-&gt;{order} = [0 .. scalar(@{$task-&gt;primary}) - 1];
                @{$state-&gt;{order}} = shuffle(@{$state-&gt;{order}})
                    if $rand;
            }
            my $num = shift @{$state-&gt;{order}};
            if (defined $num) {
                $self-&gt;push_task($task-&gt;primary-&gt;[$num]);
            }
            else {
                $state-&gt;{stage} = 'AFTER';
            }
        }
        elsif ($state-&gt;{stage} eq 'AFTER') {
            $state-&gt;{after}  = (defined $state-&gt;{after}) ? $state-&gt;{after} : 0;
            if (my $add = $task-&gt;after-&gt;[$state-&gt;{after}++]) {
                return if $add-&gt;around;
                $self-&gt;push_task($add);
            }
            else {
                $state-&gt;{ended} = 1;
            }
        }
    }

    $self-&gt;finish;
}

sub push_task {
    my $self = shift;
    my ($task) = @_;

    confess "No Task!" unless $task;
    confess "Bad Task ($task)!" unless blessed($task) &amp;&amp; $task-&gt;isa('Test2::Workflow::Task');

    if ($task-&gt;isa('Test2::Workflow::Build')) {
        confess "Can only push a Build instance when initializing the stack"
            if @{$self-&gt;{+STACK}};
        $task = $task-&gt;compile();
    }

    push @{$self-&gt;{+STACK}} =&gt; {
        task =&gt; $task,
        name =&gt; $task-&gt;name,
    };
}

sub add_mock {
    my $self = shift;
    my ($mock) = @_;
    my $stack = $self-&gt;{+STACK};

    confess "Nothing on the stack!"
        unless $stack &amp;&amp; @$stack;

    my ($state) = grep { !$_-&gt;{task}-&gt;scaffold} reverse @$stack;
    push @{$state-&gt;{mocks}} =&gt; $mock;
}

sub isolate {
    my $self = shift;
    my ($state) = @_;

    return if $state-&gt;{task}-&gt;skip;

    my $iso   = $state-&gt;{task}-&gt;iso;
    my $async = $state-&gt;{task}-&gt;async;

    # No need to isolate
    return undef unless $iso || $async;

    # Cannot isolate
    unless($self-&gt;{+MAX} &amp;&amp; $self-&gt;is_local) {
        # async does not NEED to be isolated
        return undef unless $iso;
    }

    # Wait for a slot, if max is set to 0 then we will not find a slot, instead
    # we use '0'.  We need to return a defined value to let the stack know that
    # the task has ended.
    my $slot = 0;
    while($self-&gt;{+MAX} &amp;&amp; $self-&gt;is_local) {
        $self-&gt;cull;
        for my $s (1 .. $self-&gt;{+MAX}) {
            my $st = $self-&gt;{+SLOTS}-&gt;[$s];
            next if $st &amp;&amp; !$st-&gt;finished;
            $self-&gt;{+SLOTS}-&gt;[$s] = undef;
            $slot = $s;
            last;
        }
        last if $slot;
        sleep(0.02);
    }

    my $st = $state-&gt;{subtest}
        or confess "Cannot isolate a task without a subtest";

    if (!$self-&gt;no_fork) {
        my $out = $st-&gt;fork;
        if (blessed($out)) {
            $state-&gt;{in_fork} = $out;

            # drop back out to complete the task.
            return undef;
        }
        else {
            $self-&gt;send_event(
                'Note',
                message =&gt; "Forked PID $out to run: " . $state-&gt;{task}-&gt;name,
            );
            $state-&gt;{pid} = $out;
        }
    }
    elsif (!$self-&gt;no_threads) {
        $state-&gt;{in_thread} = 1;
        my $thr = $st-&gt;run_thread(\&amp;run, $self);
        $state-&gt;{thread} = $thr;
        delete $state-&gt;{in_thread};
        $self-&gt;send_event(
            'Note',
            message =&gt; "Started Thread-ID " . $thr-&gt;tid . " to run: " . $state-&gt;{task}-&gt;name,
        );
    }
    else {
        $st-&gt;finish(skip =&gt; "No isolation method available");
        return 0;
    }

    if($slot) {
        $self-&gt;{+SLOTS}-&gt;[$slot] = $st;
    }
    else {
        $st-&gt;finish;
    }

    return $slot;
}

sub cull {
    my $self = shift;

    my $subtests = delete $self-&gt;{+SUBTESTS} || return;
    my @new;

    # Cull subtests in reverse order, Nested subtests end before their parents.
    for my $set (reverse @$subtests) {
        my ($st, $task) = @$set;
        next if $st-&gt;finished;
        if (!$st-&gt;active &amp;&amp; $st-&gt;ready) {
            $st-&gt;finish();
            next;
        }

        # Use unshift to preserve order.
        unshift @new =&gt; $set;
    }

    $self-&gt;{+SUBTESTS} = \@new;

    return;
}

sub finish {
    my $self = shift;
    while(@{$self-&gt;{+SUBTESTS}}) {
        $self-&gt;cull;
        sleep(0.02) if @{$self-&gt;{+SUBTESTS}};
    }
}

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Test2::Workflow::Runner - Runs the workflows.

=head1 SOURCE

The source code repository for Test2-Workflow can be found at
F&lt;https://github.com/Test-More/Test2-Suite/&gt;.

=head1 MAINTAINERS

=over 4

=item Chad Granum E&lt;lt&gt;exodist@cpan.orgE&lt;gt&gt;

=back

=head1 AUTHORS

=over 4

=item Chad Granum E&lt;lt&gt;exodist@cpan.orgE&lt;gt&gt;

=back

=head1 COPYRIGHT

Copyright 2018 Chad Granum E&lt;lt&gt;exodist7@gmail.comE&lt;gt&gt;.

This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.

See F&lt;http://dev.perl.org/licenses/&gt;

=cut

</pre></body></html>