File Coverage

blib/lib/Test/Stream/Context.pm

Criterion	Covered	Total	%
statement	188	189	99.4
branch	66	68	97.0
condition	37	51	72.5
subroutine	33	33	100.0
pod	15	16	93.7
total	339	357	94.9

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

use Scalar::Util qw/weaken/;
use Carp qw/confess croak longmess/;
use Test::Stream::Util qw/get_tid try pkg_to_file/;

use Test::Stream::Sync();
use Test::Stream::DebugInfo();

# Preload some key event types
my %LOADED = (
    map {
        require "Test/Stream/Event/$_.pm";
        my $pkg = "Test::Stream::Event::$_";
        ( $pkg => $pkg, $_ => $pkg )
    } qw/Ok Diag Note Plan Bail Exception Waiting/
);

# Stack is ok to cache.
our $STACK = Test::Stream::Sync->stack;
our @ON_INIT;
our @ON_RELEASE;
our %CONTEXTS;

sub ON_INIT    { shift; push @ON_INIT => @_ }
sub ON_RELEASE { shift; push @ON_RELEASE => @_ }

END { _do_end() }

sub _do_end {
    my $real = $?;
    my $new  = $real;

    my @unreleased = grep { $_ && $_->debug->pid == $$ } values %CONTEXTS;
    if (@unreleased) {
        $new = 255;

        $_->debug->alert("context object was never released! This means a testing tool is behaving very badly")
            for @unreleased;
    }

    $? = $new;
}

use Test::Stream::Exporter qw/import exports export/;
exports qw/context/;
export release => sub($;@) {
    $_[0]->release;
    shift; # Remove undef that used to be our $self reference.
    return @_ > 1 ? @_ : $_[0];
};
no Test::Stream::Exporter;

use Test::Stream::HashBase(
    accessors => [qw/stack hub debug _on_release _depth _err _no_destroy_warning/],
);

sub init {
    confess "The 'debug' attribute is required"
        unless $_[0]->{+DEBUG};

    confess "The 'hub' attribute is required"
        unless $_[0]->{+HUB};

    $_[0]->{+_DEPTH} = 0 unless defined $_[0]->{+_DEPTH};

    $_[0]->{+_ERR} = $@;
}

sub snapshot { bless {%{$_[0]}}, __PACKAGE__ }

sub release {
    my ($self) = @_;
    return $_[0] = undef if Internals::SvREFCNT(%$self) != 2;

    my $hub = $self->{+HUB};
    my $hid = $hub->{hid};

    if (!$CONTEXTS{$hid} || $self != $CONTEXTS{$hid}) {
        $_[0] = undef;
        croak "release() should not be called on a non-canonical context.";
    }

    # Remove the weak reference, this will also prevent the destructor from
    # having an issue.
    # Remove the key itself to avoid a slow memory leak
    delete $CONTEXTS{$hid};

    if (my $cbk = $self->{+_ON_RELEASE}) {
        $_->($self) for reverse @$cbk;
    }
    if (my $hcbk = $hub->{_context_release}) {
        $_->($self) for reverse @$hcbk;
    }
    $_->($self) for reverse @ON_RELEASE;

    return;
}

sub DESTROY {
    my ($self) = @_;

    return unless $self->{+HUB};
    my $hid = $self->{+HUB}->hid;

    return unless $CONTEXTS{$hid} && $CONTEXTS{$hid} == $self;
    return unless "$@" eq "" . $self->{+_ERR};

    my $debug = $self->{+DEBUG} || return;
    my $frame = $debug->frame;

    my $mess = longmess;

    warn <<"    EOT" unless $self->{+_NO_DESTROY_WARNING} || $self->{+DEBUG}->pid != $$ || $self->{+DEBUG}->tid != get_tid;
Context was not released! Releasing at destruction.
Context creation details:
  Package: $frame->[0]
     File: $frame->[1]
     Line: $frame->[2]
     Tool: $frame->[3]

Trace: $mess
    EOT

    # Remove the key itself to avoid a slow memory leak
    delete $CONTEXTS{$hid};
    if(my $cbk = $self->{+_ON_RELEASE}) {
        $_->($self) for reverse @$cbk;
    }
    if (my $hcbk = $self->{+HUB}->{_context_release}) {
        $_->($self) for reverse @$hcbk;
    }
    $_->($self) for reverse @ON_RELEASE;
    return;
}

sub do_in_context {
    my $self = shift;
    my ($sub, @args) = @_;

    my $hub = $self->{+HUB};
    my $hid = $hub->hid;

    my $old = $CONTEXTS{$hid};

    weaken($CONTEXTS{$hid} = $self);
    my ($ok, $err) = &try($sub, @args);
    if ($old) {
        weaken($CONTEXTS{$hid} = $old);
        $old = undef;
    }
    else {
        delete $CONTEXTS{$hid};
    }
    die $err unless $ok;
}

sub context {
    my %params = (level => 0, wrapped => 0, @_);

    croak "context() called, but return value is ignored"
        unless defined wantarray;

    my $stack = $params{stack} || $STACK;
    my $hub = $params{hub} || @$stack ? $stack->[-1] : $stack->top;
    my $hid = $hub->{hid};
    my $current = $CONTEXTS{$hid};

    my $level = 1 + $params{level};
    my ($pkg, $file, $line, $sub) = caller($level);
    unless ($pkg) {
        confess "Could not find context at depth $level" unless $params{fudge};
        ($pkg, $file, $line, $sub) = caller(--$level) while ($level >= 0 && !$pkg);
    }

    my $depth = $level;
    $depth++ while caller($depth + 1) && (!$current || $depth <= $current->{+_DEPTH} + $params{wrapped});
    $depth -= $params{wrapped};

    if ($current && $params{on_release} && $current->{+_DEPTH} < $depth) {
        $current->{+_ON_RELEASE} ||= [];
        push @{$current->{+_ON_RELEASE}} => $params{on_release};
    }

    return $current if $current && $current->{+_DEPTH} < $depth;

    # Handle error condition of bad level
    $current->_depth_error([$pkg, $file, $line, $sub, $depth])
        if $current;

    my $dbg = bless(
        {
            frame => [$pkg, $file, $line, $sub],
            pid   => $$,
            tid   => get_tid(),
            $hub->debug_todo,
        },
        'Test::Stream::DebugInfo'
    );

    $current = bless(
        {
            STACK()  => $stack,
            HUB()    => $hub,
            DEBUG()  => $dbg,
            _DEPTH() => $depth,
            _ERR()   => $@,
            $params{on_release} ? (_ON_RELEASE() => [$params{on_release}]) : (),
        },
        __PACKAGE__
    );

    weaken($CONTEXTS{$hid} = $current);

    $_->($current) for @ON_INIT;

    if (my $hcbk = $hub->{_context_init}) {
        $_->($current) for @$hcbk;
    }

    $params{on_init}->($current) if $params{on_init};

    return $current;
}

sub _depth_error {
    my $self = shift;
    my ($details) = @_;
    my ($pkg, $file, $line, $sub, $depth) = @$details;

    my $oldframe = $self->{+DEBUG}->frame;
    my $olddepth = $self->{+_DEPTH};

    my $mess = longmess();

    warn <<"    EOT";
context() was called to retrieve an existing context, however the existing
context was created in a stack frame at the same, or deeper level. This usually
means that a tool failed to release the context when it was finished.

Old context details:
   File: $oldframe->[1]
   Line: $oldframe->[2]
   Tool: $oldframe->[3]
  Depth: $olddepth

New context details:
   File: $file
   Line: $line
   Tool: $sub
  Depth: $depth

Trace: $mess

Removing the old context and creating a new one...
    EOT

    my $hid = $self->{+HUB}->hid;
    delete $CONTEXTS{$hid};
    $self->release;
}

sub throw {
    my ($self, $msg) = @_;
    $_[0]->release; # We have to act on $_[0] because it is aliased
    $self->debug->throw($msg);
}

sub alert {
    my ($self, $msg) = @_;
    $self->debug->alert($msg);
}

sub send_event {
    my $self  = shift;
    my $event = shift;
    my %args  = @_;

    my $pkg = $LOADED{$event} || $self->_parse_event($event);

    $self->{+HUB}->send(
        $pkg->new(
            debug => $self->{+DEBUG}->snapshot,
            %args,
        )
    );
}

sub build_event {
    my $self  = shift;
    my $event = shift;
    my %args  = @_;

    my $pkg = $LOADED{$event} || $self->_parse_event($event);

    $pkg->new(
        debug => $self->{+DEBUG}->snapshot,
        %args,
    );
}

sub ok {
    my $self = shift;
    my ($pass, $name, $diag) = @_;

    my $e = bless {
        debug => bless( {%{$self->{+DEBUG}}}, 'Test::Stream::DebugInfo'),
        pass  => $pass,
        name  => $name,
    }, 'Test::Stream::Event::Ok';
    $e->init;

    return $self->{+HUB}->send($e) if $pass;

    $diag ||= [];
    unshift @$diag => $e->default_diag;

    $e->set_diag($diag);

    $self->{+HUB}->send($e);
}

sub note {
    my $self = shift;
    my ($message) = @_;
    $self->send_event('Note', message => $message);
}

sub diag {
    my $self = shift;
    my ($message) = @_;
    $self->send_event('Diag', message => $message);
}

sub plan {
    my ($self, $max, $directive, $reason) = @_;
    if ($directive && $directive =~ m/skip/i) {
        $self->{+_NO_DESTROY_WARNING} = 1;
        $self = $self->snapshot;
        $_[0]->release;
    }

    $self->send_event('Plan', max => $max, directive => $directive, reason => $reason);
}

sub bail {
    my ($self, $reason) = @_;
    $self->{+_NO_DESTROY_WARNING} = 1;
    $self = $self->snapshot;
    $_[0]->release;
    $self->send_event('Bail', reason => $reason);
}

sub _parse_event {
    my $self = shift;
    my $event = shift;

    my $pkg;
    if ($event =~ m/^\+(.*)/) {
        $pkg = $1;
    }
    else {
        $pkg = "Test::Stream::Event::$event";
    }

    unless ($LOADED{$pkg}) {
        my $file = pkg_to_file($pkg);
        my ($ok, $err) = try { require $file };
        $self->throw("Could not load event module '$pkg': $err")
            unless $ok;

        $LOADED{$pkg} = $pkg;
    }

    confess "'$pkg' is not a subclass of 'Test::Stream::Event'"
        unless $pkg->isa('Test::Stream::Event');

    $LOADED{$event} = $pkg;

    return $pkg;
}

1;

__END__