xref: /openbsd/gnu/usr.bin/perl/cpan/Test-Simple/t/Test2/modules/API.t (revision de8cc8ed)

use strict;
use warnings;

BEGIN { no warnings 'once'; $main::cleanup1 = bless {}, 'My::Cleanup' }

use Test2::API qw/context/;

my ($LOADED, $INIT);
BEGIN {
    $INIT   = Test2::API::test2_init_done;
    $LOADED = Test2::API::test2_load_done;
};

use Test2::IPC;
use Test2::Tools::Tiny;
use Test2::Util qw/get_tid/;
my $CLASS = 'Test2::API';

# Ensure we do not break backcompat later by removing anything
ok(Test2::API->can($_), "$_ method is present") for qw{
    context_do
    no_context

    test2_init_done
    test2_load_done

    test2_pid
    test2_tid
    test2_stack
    test2_no_wait
    test2_is_testing_done

    test2_add_callback_context_init
    test2_add_callback_context_release
    test2_add_callback_exit
    test2_add_callback_post_load
    test2_list_context_init_callbacks
    test2_list_context_release_callbacks
    test2_list_exit_callbacks
    test2_list_post_load_callbacks

    test2_ipc
    test2_ipc_disable
    test2_ipc_disabled
    test2_ipc_drivers
    test2_ipc_add_driver
    test2_ipc_polling
    test2_ipc_disable_polling
    test2_ipc_enable_polling

    test2_formatter
    test2_formatters
    test2_formatter_add
    test2_formatter_set
};

ok(!$LOADED, "Was not load_done right away");
ok(!$INIT, "Init was not done right away");
ok(Test2::API::test2_load_done, "We loaded it");

# Note: This is a check that stuff happens in an END block.
{
    {
        package FOLLOW;

        sub DESTROY {
            return if $_[0]->{fixed};
            print "not ok - Did not run end ($_[0]->{name})!";
            $? = 255;
            exit 255;
        }
    }

    our $kill1 = bless {fixed => 0, name => "Custom Hook"}, 'FOLLOW';
    Test2::API::test2_add_callback_exit(
        sub {
            print "# Running END hook\n";
            $kill1->{fixed} = 1;
        }
    );

    our $kill2 = bless {fixed => 0, name => "set exit"}, 'FOLLOW';
    my $old = Test2::API::Instance->can('set_exit');
    no warnings 'redefine';
    *Test2::API::Instance::set_exit = sub {
        $kill2->{fixed} = 1;
        print "# Running set_exit\n";
        $old->(@_);
    };
}

ok($CLASS->can('test2_init_done')->(), "init is done.");
ok($CLASS->can('test2_load_done')->(), "Test2 is finished loading");

is($CLASS->can('test2_pid')->(), $$, "got pid");
is($CLASS->can('test2_tid')->(), get_tid(), "got tid");

ok($CLASS->can('test2_stack')->(), 'got stack');
is($CLASS->can('test2_stack')->(), $CLASS->can('test2_stack')->(), "always get the same stack");

ok($CLASS->can('test2_ipc')->(), 'got ipc');
is($CLASS->can('test2_ipc')->(), $CLASS->can('test2_ipc')->(), "always get the same IPC");

is_deeply([$CLASS->can('test2_ipc_drivers')->()], [qw/Test2::IPC::Driver::Files/], "Got driver list");

# Verify it reports to the correct file/line, there was some trouble with this...
my $file = __FILE__;
my $line = __LINE__ + 1;
my $warnings = warnings { $CLASS->can('test2_ipc_add_driver')->('fake') };
my $sub1 = sub {
like(
    $warnings->[0],
    qr{^IPC driver fake loaded too late to be used as the global ipc driver at \Q$file\E line $line},
    "got warning about adding driver too late"
);
};
if ($] le "5.006002") {
    todo("TODO known to fail on $]", $sub1);
} else {
    $sub1->();
}

is_deeply([$CLASS->can('test2_ipc_drivers')->()], [qw/fake Test2::IPC::Driver::Files/], "Got updated list");

ok($CLASS->can('test2_ipc_polling')->(), "Polling is on");
$CLASS->can('test2_ipc_disable_polling')->();
ok(!$CLASS->can('test2_ipc_polling')->(), "Polling is off");
$CLASS->can('test2_ipc_enable_polling')->();
ok($CLASS->can('test2_ipc_polling')->(), "Polling is on");

ok($CLASS->can('test2_formatter')->(), "Got a formatter");
is($CLASS->can('test2_formatter')->(), $CLASS->can('test2_formatter')->(), "always get the same Formatter (class name)");

my $ran = 0;
$CLASS->can('test2_add_callback_post_load')->(sub { $ran++ });
is($ran, 1, "ran the post-load");

like(
    exception { $CLASS->can('test2_formatter_set')->() },
    qr/No formatter specified/,
    "formatter_set requires an argument"
);

like(
    exception { $CLASS->can('test2_formatter_set')->('fake') },
    qr/Global Formatter already set/,
    "formatter_set doesn't work after initialization",
);

ok(!$CLASS->can('test2_no_wait')->(), "no_wait is not set");
$CLASS->can('test2_no_wait')->(1);
ok($CLASS->can('test2_no_wait')->(), "no_wait is set");
$CLASS->can('test2_no_wait')->(undef);
ok(!$CLASS->can('test2_no_wait')->(), "no_wait is not set");

ok($CLASS->can('test2_ipc_wait_enabled')->(), "IPC waiting enabled");
$CLASS->can('test2_ipc_wait_disable')->();
ok(!$CLASS->can('test2_ipc_wait_enabled')->(), "IPC waiting disabled");
$CLASS->can('test2_ipc_wait_enable')->();
ok($CLASS->can('test2_ipc_wait_enabled')->(), "IPC waiting enabled");

my $pctx;
sub tool_a($;$) {
    Test2::API::context_do {
        my $ctx = shift;
        my ($bool, $name) = @_;
        $pctx = wantarray;
        die "xyz" unless $bool;
        $ctx->ok($bool, $name);
        return unless defined $pctx;
        return (1, 2) if $pctx;
        return 'a';
    } @_;
}

$pctx = 'x';
tool_a(1, "void context test");
ok(!defined($pctx), "void context");

my $x = tool_a(1, "scalar context test");
ok(defined($pctx) && $pctx == 0, "scalar context");
is($x, 'a', "got scalar return");

my @x = tool_a(1, "array context test");
ok($pctx, "array context");
is_deeply(\@x, [1, 2], "Got array return");

like(
    exception { tool_a(0) },
    qr/^xyz/,
    "got exception"
);

sub {
    my $outer = context();
    sub {
        my $middle = context();
        is($outer->trace, $middle->trace, "got the same context before calling no_context");

        Test2::API::no_context {
            my $inner = context();
            ok($inner->trace != $outer->trace, "Got a different context inside of no_context()");
            $inner->release;
        };

        $middle->release;
    }->();

    $outer->release;
}->();

sub {
    my $outer = context();
    sub {
        my $middle = context();
        is($outer->trace, $middle->trace, "got the same context before calling no_context");

        Test2::API::no_context {
            my $inner = context();
            ok($inner->trace != $outer->trace, "Got a different context inside of no_context({}, hid)");
            $inner->release;
        } $outer->hub->hid;

        $middle->release;
    }->();

    $outer->release;
}->();

sub {
    my @warnings;
    my $outer = context();
    sub {
        my $middle = context();
        is($outer->trace, $middle->trace, "got the same context before calling no_context");

        local $SIG{__WARN__} = sub { push @warnings => @_ };
        Test2::API::no_context {
            my $inner = context();
            ok($inner->trace != $outer->trace, "Got a different context inside of no_context({}, hid)");
        } $outer->hub->hid;

        $middle->release;
    }->();

    $outer->release;

    is(@warnings, 1, "1 warning");
    like(
        $warnings[0],
        qr/A context appears to have been destroyed without first calling release/,
        "Got warning about unreleased context"
    );
}->();


sub {
    my $hub = Test2::Hub->new();
    my $ctx = context(hub => $hub);
    is($ctx->hub,$hub, 'got the hub of context() argument');
    $ctx->release;
}->();


my $sub = sub { };

Test2::API::test2_add_callback_context_acquire($sub);
Test2::API::test2_add_callback_context_init($sub);
Test2::API::test2_add_callback_context_release($sub);
Test2::API::test2_add_callback_exit($sub);
Test2::API::test2_add_callback_post_load($sub);

is((grep { $_ == $sub } Test2::API::test2_list_context_acquire_callbacks()), 1, "got the one instance of the hook");
is((grep { $_ == $sub } Test2::API::test2_list_context_init_callbacks()),    1, "got the one instance of the hook");
is((grep { $_ == $sub } Test2::API::test2_list_context_release_callbacks()), 1, "got the one instance of the hook");
is((grep { $_ == $sub } Test2::API::test2_list_exit_callbacks()),            1, "got the one instance of the hook");
is((grep { $_ == $sub } Test2::API::test2_list_post_load_callbacks()),       1, "got the one instance of the hook");

Test2::API::test2_add_callback_context_acquire($sub);
Test2::API::test2_add_callback_context_init($sub);
Test2::API::test2_add_callback_context_release($sub);
Test2::API::test2_add_callback_exit($sub);
Test2::API::test2_add_callback_post_load($sub);

is((grep { $_ == $sub } Test2::API::test2_list_context_acquire_callbacks()), 2, "got the two instances of the hook");
is((grep { $_ == $sub } Test2::API::test2_list_context_init_callbacks()),    2, "got the two instances of the hook");
is((grep { $_ == $sub } Test2::API::test2_list_context_release_callbacks()), 2, "got the two instances of the hook");
is((grep { $_ == $sub } Test2::API::test2_list_exit_callbacks()),            2, "got the two instances of the hook");
is((grep { $_ == $sub } Test2::API::test2_list_post_load_callbacks()),       2, "got the two instances of the hook");

ok(!Test2::API::test2_is_testing_done(), "Testing is not done");

done_testing;

die "Testing should be done, but it is not!" unless Test2::API::test2_is_testing_done();

{
    package My::Cleanup;

    sub DESTROY {
        return if Test2::API::test2_is_testing_done();
        print "not ok - Testing should be done, but it is not!\n";
        warn "Testing should be done, but it is not!";
        eval "END { $? = 255 }; 1" or die $@;
        exit 255;
    }
}

# This should destroy the thing
END { no warnings 'once'; $main::cleanup2 = bless {}, 'My::Cleanup' }