POE::Test::Helpers - Testing framework for POE

    use Test::More tests => 1;
    use POE;
    use POE::Test::Helpers;

    # defining a callback to create a session
    my $run = sub {
        return POE::Session->create(
            inline_states => {
                '_start' => sub {
                    print "Start says hi!\n";
                    $_[KERNEL]->yield('next');
                },
                'next' => sub { print "Next says hi!\n" },
            }
        );
    };

    # here we define the tests
    # and tell POE::Test::Helpers to run your session
    POE::Test::Helpers->spawn(
        run   => $run,
        tests => {
            # _start is actually 0
            # next will run right after _start
            next => { order => 1 },
        },
    );

    POE::Kernel->run;

    use POE::Test::Helpers;

    # we want to test Our::Module
    POE::Test::Helpers->spawn(
        run => sub { Our::Module->spawn( ... ) },
        ...
    );

    # or, if we want to set up the session ourselves in more intricate ways
    my $object = Our::Module->new( ... );
    my $code   = sub { $object->create_session };

    POE::Test::Helpers->spawn(
        run => $code,
        ...
    );

    POE::Kernel->run;

    use POE::Test::Helpers;

    sub start {
        # POE code
        $_[KERNEL]->yield('next');
    }

    sub next {
        # POE code
    }

    # now provide POE::Test::Helpers with a coderef that creates a POE::Session
    POE::Test::Helpers->spawn(
        run => sub {
            POE::Session->create(
                inline_states => [ qw/ _start next / ],
            );
        },
    );

    POE::Kernel->run;

    POE::Test::Helpers->spawn(
        run   => $run_method,
        tests => {
            # testing that "next" was run once
            next => { count => 1 },

            # testing that "more" wasn't run at all
            more => { count => 0 },

            # testing that "again" was run 3 times
            # and that "next" was run beforehand
            again => {
                count => 3,
                deps  => ['next'],
            },

            # testing that "last" was run 4th
            # and what were the subroutine parameters each time
            last => {
                order  => 3, # 0 is first, 1 is second...
                params => [ [ 'first', 'params' ], ['second'] ],
            },
        },
    );

    POE::Kernel->run;

    use POE::Test::Helpers;

    POE::Test::Helpers->spawn(
        run          => $run_method,
        event_params => 'unordered',
        tests        => {
            checks => {
                # either called with "now" or "then" parameters
                # doesn't matter the order
                params => [ ['now'], ['then'] ],
            },
        },
    );

    POE::Kernel->run;

    perldoc POE::Test::Helpers

  Sawyer X <xsawyerx@cpan.org>

use strictures 1;
package POE::Test::Helpers;
BEGIN {
  $POE::Test::Helpers::VERSION = '1.11';
}
# ABSTRACT: Testing framework for POE

use Carp;
use parent 'Test::Builder::Module';
use POE::Session;
use Data::Validate    'is_integer';
use List::AllUtils     qw( first none );
use Test::Deep::NoTest qw( bag eq_deeply );
use namespace::autoclean;

my $CLASS = __PACKAGE__;

sub new {
    my ( $class, %opts ) = @_;

    # must have tests
    my $tests = $opts{'tests'};
    defined $tests       or croak 'Missing tests data in new';
    ref $tests eq 'HASH' or croak 'Tests data should be a hashref in new';

    # must have run method
    exists $opts{'run'}        or croak 'Missing run method in new';
    ref $opts{'run'} eq 'CODE' or croak 'Run method should be a coderef in new';

    foreach my $name ( keys %{$tests} ) {
        my $test_data = $tests->{$name};

        my ( $count, $order, $params, $deps ) =
            @{$test_data}{ qw/ count order params deps / };

        # currently we still allow to register tests without requiring
        # at least a count or params

        # check the count
        if ( defined $count ) {
            # count is only tested in the last run so we just check the param
            defined is_integer($count) or croak 'Bad event count in new';
        }

        # check the order
        if ( defined $order ) {
            defined is_integer($order) or croak 'Bad event order in new';
        }

        # check deps
        if ( defined $deps ) {
            ref $deps eq 'ARRAY' or croak 'Bad event deps in new';
        }

        # check the params
        if ( defined $params ) {
            ref $params eq 'ARRAY' or croak 'Bad event params in new';
        }
    }

    my $self = bless {
        tests       => $tests,
        run         => $opts{'run'},
        params_type => $opts{'params_type'} || 'ordered',
    }, $class;

    return $self;
}

sub spawn {
    my ( $class, %opts ) = @_;

    my $self = $class->new(%opts);

    $self->{'session_id'} = POE::Session->create(
        object_states => [
            $self => [ '_start', '_child' ],
        ],
    )->ID;

    return $self;
}

sub reached_event {
    my ( $self, %opts ) = @_;
    # we don't have to get params,
    # but we do have to get the name and order

    my $name = $opts{'name'};
    # must have name
    defined $name && $name ne ''
        or croak 'Missing event name in reached_event';

    my ( $event_order, $event_params, $event_deps ) =
        @opts{ qw/ order params deps / };

    defined $event_order
        or croak 'Missing event order in reached_event';
    defined is_integer($event_order)
        or croak 'Event order must be integer in reached_event';

    if ( defined $event_params ) {
        ref $event_params eq 'ARRAY'
            or croak 'Event params must be arrayref in reached_event';
    }

    if ( defined $event_deps ) {
        ref $event_deps eq 'ARRAY'
            or croak 'Event deps must be arrayref in reached_event';
    }

    my $test_data = $self->{'tests'}{$name};

    my ( $test_count, $test_order, $test_params, $test_deps ) =
        @{$test_data}{ qw/ count order params deps / };

    # currently we still allow to register events without requiring
    # at least a count or params

    # add the event to the list of events
    push @{ $self->{'events_order'} }, $name;

    # check the order
    if ( defined $test_order ) {
        $self->check_order( $name, $event_order );
    }

    # check deps
    if ( defined $test_deps ) {
        $self->check_deps( $name, $event_deps );
    }

    # check the params
    if ( defined $test_params ) {
        $self->check_params( $name, $event_params );
    }

    return 1;
}

sub check_count {
    my ( $self, $event, $count ) = @_;
    my $tb = $CLASS->builder;

    my $count_from_event = grep /^$event$/, @{ $self->{'events_order'} };
    $tb->is_num( $count_from_event, $count, "$event ran $count times" );

    return 1;
}

sub check_order {
    my ( $self, $event, $event_order ) = @_;
    my $tb = $CLASS->builder;

    my $event_from_order = $self->{'events_order'}[$event_order];

    $tb->is_eq( $event, $event_from_order, "($event_order) $event" );

    return 1;
}

sub check_deps {
    my ( $self, $event, $deps ) = @_;
    my $tb = $CLASS->builder;

    # get the event's tested dependencies and all events run so far
    my @deps_from_event = @{ $self->{'tests'}{$event}{'deps'} };
    my @all_events      = @{ $self->{'events_order'} };

    # check for problematic dependencies
    my @problems = ();
    foreach my $dep_event (@deps_from_event) {
        if ( ! grep /^$dep_event$/, @all_events ) {
            push @problems, $dep_event;
        }
    }

    # serialize possible errors
    my $missing = join ', ', @problems;
    my $extra   = @problems ? "[$missing missing]" : q{};

    $tb->ok( ( @problems == 0 ), "Correct sub deps for ${event}${extra}" );
}

sub check_params {
    my ( $self, $event, $current_params ) = @_;
    my $tb = $CLASS->builder;

    my $test_params = $self->{'tests'}{$event}{'params'};

    if ( $self->{'params_type'} eq 'ordered' ) {
        # remove the fetched
        my $expected_params = shift @{$test_params} || [];

        $tb->ok(
            eq_deeply(
                $current_params,
                $expected_params,
            ),
            "($event) Correct params",
        );
    } else {
        # don't remove, just match
        my $okay = 0;

        foreach my $expected_params ( @{$test_params} ) {
            if ( eq_deeply(
                    $current_params,
                    bag(@{$expected_params}) ) ) {
                $okay++;
            }
        }

        $tb->ok( $okay, "($event) Correct [unordered] params" );
    }
}

sub _child {
    # this says that _start on our spawned session started
    # we should mark _start on our superhash
    my $self    = $_[OBJECT];
    my $change  = $_[ARG0];
    my $session = $_[ARG1];

    my $internals = $session->[KERNEL];

    if ( $change eq 'create' ) {
        $self->reached_event(
            name  => '_start',
            order => 0,
        );
    } elsif ( $change eq 'lose' ) {
        # get the last events_order
        my $order = $self->{'events_order'}             ?
                    scalar @{ $self->{'events_order'} } :
                    0;

        $self->reached_event(
            name  => '_stop',
            order => $order,
        );

        # checking the count
        $self->check_all_counts;
    }
}

sub check_all_counts {
    my $self = shift;
    foreach my $test ( keys %{ $self->{'tests'} } ) {
        my $test_data = $self->{'tests'}{$test};

        if ( exists $test_data->{'count'} ) {
            $self->check_count( $test, $test_data->{'count'} );
        }
    }
}

sub _start {
    my ( $self, $kernel ) = @_[ OBJECT, KERNEL ];

    # collect the keys of everyone
    # if exists key in test, add a test for it for them
    $self->{'session_id'} = $_[SESSION]->ID();

    my @subs_to_override = keys %{ $self->{'tests'} };

    my $callback        = $self->{'run'};
    my $session_to_test = $callback->();
    my $internal_data   = $session_to_test->[KERNEL];

    # 0 is done by _start in _child event, so we start from 1
    my $count = 1;

    foreach my $sub_to_override (@subs_to_override) {
        # use _child event to handle these
        $sub_to_override eq '_start' || $sub_to_override eq '_stop' and next;

        # override the subroutine
        my $old_sub = $internal_data->{$sub_to_override};
        my $new_sub = sub {
            $self->reached_event(
                name   => $sub_to_override,
                order  => $count++,
                params => [ @_[ ARG0 .. $#_ ] ],
            );

            goto &$old_sub;
        };

        $internal_data->{$sub_to_override} = $new_sub;
    }
}

1;

__END__