ACIL FM

Pilih semua

Nama	Ukuran	Aksi
InterceptResult	-	Open
Breakage.t	3.04 MB	View DL Edit
Context.t	14.06 MB	View DL Edit
Instance.t	14.52 MB	View DL Edit
InterceptResult.t	8.48 MB	View DL Edit
Stack.t	1.81 MB	View DL Edit

Edit file: /usr/share/doc/perl-Test-Simple/t/Test2/modules/API/Context.t

use strict;
use warnings;

BEGIN { $Test2::API::DO_DEPTH_CHECK = 1 }
use Test2::Tools::Tiny;

use Test2::API qw{
    context intercept
    test2_stack
    test2_add_callback_context_acquire
    test2_add_callback_context_init
    test2_add_callback_context_release
};

my $error = exception { context(); 1 };
my $exception = "context() called, but return value is ignored at " . __FILE__ . ' line ' . (__LINE__ - 1);
like($error, qr/^\Q$exception\E/, "Got the exception" );

my $ref;
my $frame;
sub wrap(&) {
    my $ctx = context();
    my ($pkg, $file, $line, $sub) = caller(0);
    $frame = [$pkg, $file, $line, $sub];

$_[0]->($ctx);

$ref = "$ctx";

$ctx->release;
}

wrap {
    my $ctx = shift;
    ok($ctx->hub, "got hub");
    delete $ctx->trace->frame->[4];
    is_deeply($ctx->trace->frame, $frame, "Found place to report errors");
};

wrap {
    my $ctx = shift;
    ok("$ctx" ne "$ref", "Got a new context");
    my $new = context();
    my @caller = caller(0);
    is_deeply(
        $new,
        {%$ctx, _is_canon => undef, _is_spawn => [@caller[0,1,2,3]]},
        "Additional call to context gets spawn"
    );
    delete $ctx->trace->frame->[4];
    is_deeply($ctx->trace->frame, $frame, "Found place to report errors");
    $new->release;
};

wrap {
    my $ctx = shift;
    my $snap = $ctx->snapshot;

is_deeply(
        $snap,
        {%$ctx, _is_canon => undef, _is_spawn => undef, _aborted => undef},
        "snapshot is identical except for canon/spawn/aborted"
    );
    ok($ctx != $snap, "snapshot is a new instance");
};

my $end_ctx;
{ # Simulate an END block...
    local *END = sub { local *__ANON__ = 'END'; context() };
    my $ctx = END();
    $frame = [ __PACKAGE__, __FILE__, __LINE__ - 1, 'main::END' ];
    # "__LINE__ - 1" on the preceding line forces the value to be an IV
    # (even though __LINE__ on its own is a PV), just as (caller)[2] is.
    $end_ctx = $ctx->snapshot;
    $ctx->release;
}
delete $end_ctx->trace->frame->[4];
is_deeply( $end_ctx->trace->frame, $frame, 'context is ok in an end block');

# Test event generation
{
    package My::Formatter;

sub write {
        my $self = shift;
        my ($e) = @_;
        push @$self => $e;
    }
}
my $events = bless [], 'My::Formatter';
my $hub = Test2::Hub->new(
    formatter => $events,
);
my $trace = Test2::EventFacet::Trace->new(
    frame => [ 'Foo::Bar', 'foo_bar.t', 42, 'Foo::Bar::baz' ],
);
my $ctx = Test2::API::Context->new(
    trace => $trace,
    hub   => $hub,
);

my $e = $ctx->build_event('Ok', pass => 1, name => 'foo');
is($e->pass, 1, "Pass");
is($e->name, 'foo', "got name");
is_deeply($e->trace, $trace, "Got the trace info");
ok(!@$events, "No events yet");

$e = $ctx->send_event('Ok', pass => 1, name => 'foo');
is($e->pass, 1, "Pass");
is($e->name, 'foo', "got name");
is_deeply($e->trace, $trace, "Got the trace info");
is(@$events, 1, "1 event");
is_deeply($events, [$e], "Hub saw the event");
pop @$events;

$e = $ctx->ok(1, 'foo');
is($e->pass, 1, "Pass");
is($e->name, 'foo', "got name");
is_deeply($e->trace, $trace, "Got the trace info");
is(@$events, 1, "1 event");
is_deeply($events, [$e], "Hub saw the event");
pop @$events;

$e = $ctx->note('foo');
is($e->message, 'foo', "got message");
is_deeply($e->trace, $trace, "Got the trace info");
is(@$events, 1, "1 event");
is_deeply($events, [$e], "Hub saw the event");
pop @$events;

$e = $ctx->diag('foo');
is($e->message, 'foo', "got message");
is_deeply($e->trace, $trace, "Got the trace info");
is(@$events, 1, "1 event");
is_deeply($events, [$e], "Hub saw the event");
pop @$events;

$e = $ctx->plan(100);
is($e->max, 100, "got max");
is_deeply($e->trace, $trace, "Got the trace info");
is(@$events, 1, "1 event");
is_deeply($events, [$e], "Hub saw the event");
pop @$events;

$e = $ctx->skip('foo', 'because');
is($e->name, 'foo', "got name");
is($e->reason, 'because', "got reason");
ok($e->pass, "skip events pass by default");
is_deeply($e->trace, $trace, "Got the trace info");
is(@$events, 1, "1 event");
is_deeply($events, [$e], "Hub saw the event");
pop @$events;

$e = $ctx->skip('foo', 'because', pass => 0);
ok(!$e->pass, "can override skip params");
pop @$events;

# Test hooks

my @hooks;
$hub =  test2_stack()->top;
my $ref1 = $hub->add_context_init(sub {    die "Bad Arg" unless ref($_[0]) eq 'Test2::API::Context'; push @hooks => 'hub_init'       });
my $ref2 = $hub->add_context_release(sub { die "Bad Arg" unless ref($_[0]) eq 'Test2::API::Context'; push @hooks => 'hub_release'    });
test2_add_callback_context_init(sub {      die "Bad Arg" unless ref($_[0]) eq 'Test2::API::Context'; push @hooks => 'global_init'    });
test2_add_callback_context_release(sub {   die "Bad Arg" unless ref($_[0]) eq 'Test2::API::Context'; push @hooks => 'global_release' });

my $ref3 = $hub->add_context_acquire(sub { die "Bad Arg" unless ref($_[0]) eq 'HASH'; push @hooks => 'hub_acquire'     });
test2_add_callback_context_acquire(sub {   die "Bad Arg" unless ref($_[0]) eq 'HASH'; push @hooks => 'global_acquire'  });

sub {
    push @hooks => 'start';
    my $ctx = context(on_init => sub { push @hooks => 'ctx_init' }, on_release => sub { push @hooks => 'ctx_release' });
    push @hooks => 'deep';
    my $ctx2 = sub {
        context(on_init => sub { push @hooks => 'ctx_init_deep' }, on_release => sub { push @hooks => 'ctx_release_deep' });
    }->();
    push @hooks => 'release_deep';
    $ctx2->release;
    push @hooks => 'release_parent';
    $ctx->release;
    push @hooks => 'released_all';

push @hooks => 'new';
    $ctx = context(on_init => sub { push @hooks => 'ctx_init2' }, on_release => sub { push @hooks => 'ctx_release2' });
    push @hooks => 'release_new';
    $ctx->release;
    push @hooks => 'done';
}->();

$hub->remove_context_init($ref1);
$hub->remove_context_release($ref2);
$hub->remove_context_acquire($ref3);
@{Test2::API::_context_init_callbacks_ref()} = ();
@{Test2::API::_context_release_callbacks_ref()} = ();
@{Test2::API::_context_acquire_callbacks_ref()} = ();

is_deeply(
    \@hooks,
    [qw{
        start
        global_acquire
        hub_acquire
        global_init
        hub_init
        ctx_init
        deep
        global_acquire
        hub_acquire
        release_deep
        release_parent
        ctx_release_deep
        ctx_release
        hub_release
        global_release
        released_all
        new
        global_acquire
        hub_acquire
        global_init
        hub_init
        ctx_init2
        release_new
        ctx_release2
        hub_release
        global_release
        done
    }],
    "Got all hook in correct order"
);

{
    my $ctx = context(level => -1);

my $one = Test2::API::Context->new(
        trace => Test2::EventFacet::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__, 'blah']),
        hub => test2_stack()->top,
    );
    is($one->_depth, 0, "default depth");

my $ran = 0;
    my $doit = sub {
        is_deeply(\@_, [qw/foo bar/], "got args");
        $ran++;
        die "Make sure old context is restored";
    };

eval { $one->do_in_context($doit, 'foo', 'bar') };

my $spawn = context(level => -1, wrapped => -2);
    is($spawn->trace, $ctx->trace, "Old context restored");
    $spawn->release;
    $ctx->release;

ok(!exception { $one->do_in_context(sub {1}) }, "do_in_context works without an original")
}

{
    like(exception { Test2::API::Context->new() }, qr/The 'trace' attribute is required/, "need to have trace");

my $trace = Test2::EventFacet::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__, 'foo']);
    like(exception { Test2::API::Context->new(trace => $trace) }, qr/The 'hub' attribute is required/, "need to have hub");

my $hub = test2_stack()->top;
    my $ctx = Test2::API::Context->new(trace => $trace, hub => $hub);
    is($ctx->{_depth}, 0, "depth set to 0 when not defined.");

$ctx = Test2::API::Context->new(trace => $trace, hub => $hub, _depth => 1);
    is($ctx->{_depth}, 1, "Do not reset depth");

like(
        exception { $ctx->release },
        qr/release should not be called on context that is neither canon nor a child/,
        "Non canonical context, do not release"
    );
}

sub {
    like(
        exception { my $ctx = context(level => 20) },
        qr/Could not find context at depth 21/,
        "Level sanity"
    );

ok(
        !exception {
            my $ctx = context(level => 20, fudge => 1);
            $ctx->release;
        },
        "Was able to get context when fudging level"
    );
}->();

sub {
    my ($ctx1, $ctx2);
    sub { $ctx1 = context() }->();

my @warnings;
    {
        local $SIG{__WARN__} = sub { push @warnings => @_ };
        $ctx2 = context();
        $ctx1 = undef;
    }

$ctx2->release;

is(@warnings, 1, "1 warning");
    like(
        $warnings[0],
        qr/^context was called to retrieve an existing context, however the existing/,
        "Got expected warning"
    );
}->();

sub {
    my $ctx = context();
    my $e = exception { $ctx->throw('xxx') };
    like($e, qr/xxx/, "got exception");

$ctx = context();
    my $warnings = warnings { $ctx->alert('xxx') };
    like($warnings->[0], qr/xxx/, "got warning");
    $ctx->release;
}->();

sub {
    my $ctx = context;

is($ctx->_parse_event('Ok'), 'Test2::Event::Ok', "Got the Ok event class");
    is($ctx->_parse_event('+Test2::Event::Ok'), 'Test2::Event::Ok', "Got the +Ok event class");

like(
        exception { $ctx->_parse_event('+DFASGFSDFGSDGSD') },
        qr/Could not load event module 'DFASGFSDFGSDGSD': Can't locate DFASGFSDFGSDGSD\.pm/,
        "Bad event type"
    );
}->();

{
    my ($e1, $e2);
    my $events = intercept {
        my $ctx = context();
        $e1 = $ctx->ok(0, 'foo', ['xxx']);
        $e2 = $ctx->ok(0, 'foo');
        $ctx->release;
    };

ok($e1->isa('Test2::Event::Ok'), "returned ok event");
    ok($e2->isa('Test2::Event::Ok'), "returned ok event");

is($events->[0], $e1, "got ok event 1");
    is($events->[3], $e2, "got ok event 2");

is($events->[2]->message, 'xxx', "event 1 diag 2");
    ok($events->[2]->isa('Test2::Event::Diag'), "event 1 diag 2 is diag");

is($events->[3], $e2, "got ok event 2");
}

sub {
    local $! = 100;
    local $@ = 'foobarbaz';
    local $? = 123;

my $ctx = context();

is($ctx->errno,       100,         "saved errno");
    is($ctx->eval_error,  'foobarbaz', "saved eval error");
    is($ctx->child_error, 123,         "saved child exit");

$! = 22;
    $@ = 'xyz';
    $? = 33;

is(0 + $!, 22,    "altered \$! in tool");
    is($@,     'xyz', "altered \$@ in tool");
    is($?,     33,    "altered \$? in tool");

sub {
        my $ctx2 = context();

$! = 42;
        $@ = 'app';
        $? = 43;

is(0 + $!, 42,    "altered \$! in tool (nested)");
        is($@,     'app', "altered \$@ in tool (nested)");
        is($?,     43,    "altered \$? in tool (nested)");

$ctx2->release;

is(0 + $!, 22,    "restored the nested \$! in tool");
        is($@,     'xyz', "restored the nested \$@ in tool");
        is($?,     33,    "restored the nested \$? in tool");
    }->();

sub {
        my $ctx2 = context();

$! = 42;
        $@ = 'app';
        $? = 43;

is(0 + $!, 42,    "altered \$! in tool (nested)");
        is($@,     'app', "altered \$@ in tool (nested)");
        is($?,     43,    "altered \$? in tool (nested)");

# Will not warn since $@ is changed
        $ctx2 = undef;

is(0 + $!, 42,    'Destroy does not reset $!');
        is($@,     'app', 'Destroy does not reset $@');
        is($?,     43,    'Destroy does not reset $?');
    }->();

$ctx->release;

is($ctx->errno,       100,         "restored errno");
    is($ctx->eval_error,  'foobarbaz', "restored eval error");
    is($ctx->child_error, 123,         "restored child exit");
}->();

sub {
    local $! = 100;
    local $@ = 'foobarbaz';
    local $? = 123;

my $ctx = context();

is($ctx->errno,       100,         "saved errno");
    is($ctx->eval_error,  'foobarbaz', "saved eval error");
    is($ctx->child_error, 123,         "saved child exit");

$! = 22;
    $@ = 'xyz';
    $? = 33;

is(0 + $!, 22,    "altered \$! in tool");
    is($@,     'xyz', "altered \$@ in tool");
    is($?,     33,    "altered \$? in tool");

# Will not warn since $@ is changed
    $ctx = undef;

is(0 + $!, 22,    "Destroy does not restore \$!");
    is($@,     'xyz', "Destroy does not restore \$@");
    is($?,     33,    "Destroy does not restore \$?");
}->();

sub {
    require Test2::EventFacet::Info::Table;

my $events = intercept {
        my $ctx = context();

$ctx->fail('foo', 'bar', Test2::EventFacet::Info::Table->new(rows => [['a', 'b']]));
        $ctx->fail_and_release('foo', 'bar', Test2::EventFacet::Info::Table->new(rows => [['a', 'b']], as_string => 'a, b'));
    };

is(@$events, 2, "got 2 events");

is($events->[0]->{info}->[0]->{details}, 'bar', "got first diag");
    is($events->[0]->{info}->[1]->{details}, '<TABLE NOT DISPLAYED>', "second diag has default details");
    is_deeply(
        $events->[0]->{info}->[1]->{table},
        {rows => [['a', 'b']]},
        "Got the table rows"
    );

is($events->[1]->{info}->[0]->{details}, 'bar', "got first diag");
    is($events->[1]->{info}->[1]->{details}, 'a, b', "second diag has custom details");
    is_deeply(
        $events->[1]->{info}->[1]->{table},
        {rows => [['a', 'b']]},
        "Got the table rows"
    );

}->();

sub ctx_destroy_test {
    my (undef, undef, $line1) = caller();
    my (@warn, $line2);
    local $SIG{__WARN__} = sub { push @warn => $_[0] };

{ my $ctx = context(); $ctx = undef } $line2 = __LINE__;

use Data::Dumper;
#    print Dumper(@warn);

like($warn[0], qr/context appears to have been destroyed without first calling release/, "Is normal context warning");
    like($warn[0], qr{\QContext destroyed at ${ \__FILE__ } line $line2\E}, "Reported context destruction trace");

my $created = <<"    EOT";
Here are the context creation details, just in case a tool forgot to call
release():
  File: ${ \__FILE__ }
  Line: $line1
  Tool: main::ctx_destroy_test
    EOT

like($warn[0], qr{\Q$created\E}, "Reported context creation details");
};

ctx_destroy_test();

done_testing;

Batal

Isi Zip:

Create