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

use Scalar::Util qw/blessed weaken/;

use Test::Stream::Carp qw/confess/;

use Test::Stream::Threads;
use Test::Stream::Event();
use Test::Stream::Util qw/try translate_filename/;
use Test::Stream::Meta qw/init_tester is_tester/;

use Test::Stream::ArrayBase(
    accessors => [qw/frame stream encoding in_todo todo modern pid skip diag_todo provider monkeypatch_stash/],
);

use Test::Stream::Exporter qw/import export_to default_exports/;
default_exports qw/context/;
Test::Stream::Exporter->cleanup();

{
    no warnings 'once';
    $Test::Builder::Level ||= 1;
}

my $CURRENT;

sub init {
    $_[0]->[FRAME]    ||= _find_context(1);                # +1 for call to init
    $_[0]->[STREAM]   ||= Test::Stream->shared;
    $_[0]->[ENCODING] ||= 'legacy';
    $_[0]->[PID]      ||= $$;
}

sub peek  { $CURRENT }
sub clear { $CURRENT = undef }

sub set {
    $CURRENT = pop;
    weaken($CURRENT);
}

my $WARNED;
sub context {
    my ($level, $stream) = @_;
    # If the context has already been initialized we simply return it, we
    # ignore any additional parameters as they no longer matter. The first
    # thing to ask for a context wins, anything context aware that is called
    # later MUST expect that it can get a context found by something down the
    # stack.
    if ($CURRENT) {
        return $CURRENT unless $stream;
        return $CURRENT if $stream == $CURRENT->[STREAM];
    }

    my $call = _find_context($level);
    $call = _find_context_harder() unless $call;
    my $pkg  = $call->[0];

    my $meta = is_tester($pkg) || _find_tester();

    # Check if $TODO is set in the package, if not check if Test::Builder is
    # loaded, and if so if it has Todo set. We check the element directly for
    # performance.
    my ($todo, $in_todo);
    {
        my $todo_pkg = $meta->[Test::Stream::Meta::PACKAGE];
        no strict 'refs';
        no warnings 'once';
        if ($todo = $meta->[Test::Stream::Meta::TODO]) {
            $in_todo = 1;
        }
        elsif ($todo = ${"$pkg\::TODO"}) {
            $in_todo = 1;
        }
        elsif ($todo = ${"$todo_pkg\::TODO"}) {
            $in_todo = 1;
        }
        elsif ($Test::Builder::Test && defined $Test::Builder::Test->{Todo}) {
            $todo    = $Test::Builder::Test->{Todo};
            $in_todo = 1;
        }
        else {
            $in_todo = 0;
        }
    };

    my ($ppkg, $pname);
    if(my @provider = caller(1)) {
        ($ppkg, $pname) = ($provider[3] =~ m/^(.*)::([^:]+)$/);
    }

    # Uh-Oh! someone has replaced the singleton, that means they probably want
    # everything to go through them... We can't do a whole lot about that, but
    # we will use the singletons stream which should catch most use-cases.
    if ($Test::Builder::_ORIG_Test && $Test::Builder::_ORIG_Test != $Test::Builder::Test) {
        $stream ||= $Test::Builder::Test->{stream};

        my $warn = $meta->[Test::Stream::Meta::MODERN]
                && !$WARNED++;

        warn <<"        EOT" if $warn;

    *******************************************************************************
    Something replaced the singleton \$Test::Builder::Test.

    The Test::Builder singleton is no longer the central place for all test
    events. Please look at Test::Stream, and Test::Stream->intercept() to
    accomplish the type of thing that was once done with the singleton.

    All attempts have been made to preserve compatability with older modules,
    but if you experience broken behavior you may need to update your code. If
    updating your code is not an option you will need to downgrade to a
    Test::More prior to version 1.301001. Patches that restore compatability
    without breaking necessary Test::Stream functionality will be gladly
    accepted.
    *******************************************************************************
        EOT
    }

    $stream ||= $meta->[Test::Stream::Meta::STREAM] || Test::Stream->shared || confess "No Stream!?";
    if ((USE_THREADS || $stream->_use_fork) && ($stream->pid == $$ && $stream->tid == get_tid())) {
        $stream->fork_cull();
    }

    my $encoding = $meta->[Test::Stream::Meta::ENCODING] || 'legacy';
    $call->[1] = translate_filename($encoding => $call->[1]) if $encoding ne 'legacy';

    my $ctx = bless(
        [
            $call,
            $stream,
            $encoding,
            $in_todo,
            $todo,
            $meta->[Test::Stream::Meta::MODERN]   || 0,
            $$,
            undef,
            $in_todo,
            [$ppkg, $pname]
        ],
        __PACKAGE__
    );

    weaken($ctx->[STREAM]);

    return $ctx if $CURRENT;

    $CURRENT = $ctx;
    weaken($CURRENT);
    return $ctx;
}

sub _find_context {
    my ($add) = @_;

    $add ||= 0;
    my $tb = $Test::Builder::Level - 1;

    # 0 - call to find_context
    # 1 - call to context/new
    # 2 - call to tool
    my $level = 2 + $add + $tb;
    my ($package, $file, $line, $subname) = caller($level);

    return unless $package;

    while ($package eq 'Test::Builder') {
        ($package, $file, $line, $subname) = caller(++$level);
    }

    return unless $package;

    return [$package, $file, $line, $subname];
}

sub _find_context_harder {
    my $level = 0;
    my $fallback;
    while(1) {
        my ($pkg, $file, $line, $subname) = caller($level++);
        $fallback ||= [$pkg, $file, $line, $subname] if $subname =~ m/::END$/;
        next if $pkg =~ m/^Test::(Stream|Builder|More|Simple)(::.*)?$/;
        return [$pkg, $file, $line, $subname];
    }

    return $fallback if $fallback;
    return [ '<UNKNOWN>', '<UNKNOWN>', 0, '<UNKNOWN>' ];
}

sub _find_tester {
    my $level = 2;
    while(1) {
        my $pkg = caller($level++);
        last unless $pkg;
        my $meta = is_tester($pkg) || next;
        return $meta;
    }

    # find a .t file!
    $level = 0;
    while(1) {
        my ($pkg, $file) = caller($level++);
        last unless $pkg;
        if ($file eq $0 && $file =~ m/\.t$/) {
            return init_tester($pkg);
        }
    }

    return init_tester('main');
}

sub alert {
    my $self = shift;
    my ($msg) = @_;

    my @call = $self->call;

    warn "$msg at $call[1] line $call[2].\n";
}

sub throw {
    my $self = shift;
    my ($msg) = @_;

    my @call = $self->call;

    $CURRENT = undef if $CURRENT = $self;

    die "$msg at $call[1] line $call[2].\n";
}

sub call { @{$_[0]->[FRAME]} }

sub package { $_[0]->[FRAME]->[0] }
sub file    { $_[0]->[FRAME]->[1] }
sub line    { $_[0]->[FRAME]->[2] }
sub subname { $_[0]->[FRAME]->[3] }

sub snapshot {
    return bless [@{$_[0]}], blessed($_[0]);
}

sub send {
    my $self = shift;
    $self->[STREAM]->send(@_);
}

# Uhg.. support legacy monkeypatching
# If this is still here in 2020 I will be a sad panda.
{
    sub ok {
        return _ok(@_) unless $INC{'Test/Builder.pm'} && $Test::Builder::ORIG{ok} != \&Test::Builder::ok;
        my $self = shift;
        local $Test::Builder::CTX = $self;
        my ($bool, $name, @stash) = @_;
        push @{$self->[MONKEYPATCH_STASH]} => \@stash;
        my $out = Test::Builder->new->ok($bool, $name);
        return $out;
    }

    sub _unwind_ok {
        my $self = shift;
        my ($bool, $name) = @_;
        my $stash = pop @{$self->[MONKEYPATCH_STASH]};
        return $self->_ok($bool, $name, @$stash);
    }

    sub note {
        return _note(@_) unless $INC{'Test/Builder.pm'} && $Test::Builder::ORIG{note} != \&Test::Builder::note;
        local $Test::Builder::CTX = shift;
        my $out = Test::Builder->new->note(@_);
        return $out;
    }

    sub diag {
        return _diag(@_) unless $INC{'Test/Builder.pm'} && $Test::Builder::ORIG{diag} != \&Test::Builder::diag;
        local $Test::Builder::CTX = shift;
        my $out = Test::Builder->new->diag(@_);
        return $out;
    }

    sub plan {
        return _plan(@_) unless $INC{'Test/Builder.pm'} && $Test::Builder::ORIG{plan} != \&Test::Builder::plan;
        local $Test::Builder::CTX = shift;
        my ($num, $dir, $arg) = @_;
        $dir ||= 'tests';
        $dir = 'skip_all' if $dir eq 'SKIP';
        $dir = 'no_plan'  if $dir eq 'NO PLAN';
        my $out = Test::Builder->new->plan($dir, $num || $arg || ());
        return $out;
    }

    sub done_testing {
        return $_[0]->stream->done_testing(@_)
            unless $INC{'Test/Builder.pm'} && $Test::Builder::ORIG{done_testing} != \&Test::Builder::done_testing;

        local $Test::Builder::CTX = shift;
        my $out = Test::Builder->new->done_testing(@_);
        return $out;
    }
}

my %EVENTS;
sub events { \%EVENTS }

sub register_event {
    my $class = shift;
    my ($pkg, $name) = @_;

    my $real_name = lc($pkg);
    $real_name =~ s/^.*:://g;

    $name ||= $real_name;

    confess "Method '$name' is already defined, event '$pkg' cannot get a context method!"
        if $class->can($name);

    $EVENTS{$real_name} = $pkg;

    # Use a string eval so that we get a names sub instead of __ANON__
    local ($@, $!);
    eval qq|
        sub $name {
            my \$self = shift;
            my \@call = caller(0);
            my \$encoding = \$self->[ENCODING];
            \$call[1] = translate_filename(\$encoding => \$call[1]) if \$encoding ne 'legacy';
            my \$e = '$pkg'->new(\$self->snapshot, [\@call[0 .. 4]], 0, \@_);
            return \$self->stream->send(\$e);
        };
        1;
    | || die $@;
}

sub meta { is_tester($_[0]->[FRAME]->[0]) }

sub hide_todo {
    my $self = shift;
    no strict 'refs';
    no warnings 'once';

    my $pkg = $self->[FRAME]->[0];
    my $meta = is_tester($pkg);

    my $found = {
        TB   => $Test::Builder::Test ? $Test::Builder::Test->{Todo} : undef,
        META => $meta->[Test::Stream::Meta::TODO],
        PKG  => ${"$pkg\::TODO"},
    };

    $Test::Builder::Test->{Todo} = undef;
    $meta->[Test::Stream::Meta::TODO] = undef;
    ${"$pkg\::TODO"} = undef;

    return $found;
}

sub restore_todo {
    my $self = shift;
    my ($found) = @_;
    no strict 'refs';
    no warnings 'once';

    my $pkg = $self->[FRAME]->[0];
    my $meta = is_tester($pkg);

    $Test::Builder::Test->{Todo} = $found->{TB};
    $meta->[Test::Stream::Meta::TODO] = $found->{META};
    ${"$pkg\::TODO"} = $found->{PKG};

    my $found2 = {
        TB   => $Test::Builder::Test ? $Test::Builder::Test->{Todo} : undef,
        META => $meta->[Test::Stream::Meta::TODO] || undef,
        PKG  => ${"$pkg\::TODO"} || undef,
    };

    for my $k (qw/TB META PKG/) {
        no warnings 'uninitialized';
        next if "$found->{$k}" eq "$found2->{$k}";
        die "Mismatch! $k:\t$found->{$k}\n\t$found2->{$k}\n"
    }

    return;
}

sub DESTROY { 1 }

our $AUTOLOAD;
sub AUTOLOAD {
    my $class = blessed($_[0]) || $_[0] || confess $AUTOLOAD;

    my $name = $AUTOLOAD;
    $name =~ s/^.*:://g;

    my $module = 'Test/Stream/Event/' . ucfirst(lc($name)) . '.pm';
    try { require $module };

    my $sub = $class->can($name);
    goto &$sub if $sub;

    my ($pkg, $file, $line) = caller;

    die qq{Can't locate object method "$name" via package "$class" at $file line $line.\n};
}

1;

__END__

=head1 NAME

Test::Stream::Context - Object to represent a testing context.

=head1 DESCRIPTION

In testing it is important to have context. It is not helpful to simply say a
test failed, you want to know where it failed. This object is responsible for
tracking the context of each test that is run. It makes it possible to get the
file and line number where the failure occured .This object is also responsible
for generating almost all the events you will encounter.

=head1 SYNOPSYS

    use Test::Stream::Context qw/context/;

    sub my_tool {
        my $ctx = context();

        # Generate an event.
        $ctx->ok(1, "Pass!");
    }

    1;

=head1 EXPORTS

=over 4

=item $ctx = context()

This function is used to obtain a context. If there is already a context object
in scope this will return it, otherwise it will return a new one.

It is important that you never store a context object in a variable from a
higher scope, a package variable, or an object attribute. The scope of a
context matters a lot.

If you want to store a context for later reference use the C<snapshot()> method
to get a clone of it that is safe to store anywhere.

=back

=head1 METHODS

=over 4

=item $ctx->alert($MESSAGE)

This issues a warning at the calling context (filename and line number where
errors should be reported).

=item $ctx->throw($MESSAGE)

This throws an exception at the calling context (filename and line number where
errors should be reported).

=item ($package, $file, $line, $subname) = $ctx->call()

Get the caller details for the context. This is where errors should be
reported.

=item $pkg = $ctx->package

Get the context package.

=item $file = $ctx->file

Get the context filename.

=item $line = $ctx->line

Get the context line number.

=item $subname = $ctx->subname

Get the context subroutine name.

=item $ctx_copy = $ctx->snapshot

Get a copy of the context object that is safe to store for later reference.

=item $ctx->send($event)

Send an event to the correct L<Test::Stream> object.

=item $ctx = $class->peek

Get the current context object, if there is one.

=back

=head2 DANGEROUS ONES

=over 4

=item $ctx->set

=item $cclass->set($ctx)

Set the context object as the current one, replacing any that might already be
current.

=item $class->clear

Unset the current context.

=item $ctx->register_event($package)

=item $ctx->register_event($package, $name)

Register a new event type, creating the shortcut method to generate it. If
C<$name> is not provided it will be taken from the end of the package name, and
will be lowercased.

=item $hr = $ctx->events

Get the hashref that holds C<< (name => $package) >> pairs. This is the actual
ref used by the package, so please do not alter it.

=item $stash = $ctx->hide_todo

=item $ctx->restore_todo($stash)

These are used to temporarily hide the TODO value in ALL places where it might
be found. The returned C<$stash> must be used to restore it later.

=back

=encoding utf8

=head1 SOURCE

The source code repository for Test::More can be found at
F<http://github.com/Test-More/test-more/>.

=head1 MAINTAINER

=over 4

=item Chad Granum E<lt>exodist@cpan.orgE<gt>

=back

=head1 AUTHORS

The following people have all contributed to the Test-More dist (sorted using
VIM's sort function).

=over 4

=item Chad Granum E<lt>exodist@cpan.orgE<gt>

=item Fergal Daly E<lt>fergal@esatclear.ie>E<gt>

=item Mark Fowler E<lt>mark@twoshortplanks.comE<gt>

=item Michael G Schwern E<lt>schwern@pobox.comE<gt>

=item 唐鳳

=back

=head1 COPYRIGHT

There has been a lot of code migration between modules,
here are all the original copyrights together:

=over 4

=item Test::Stream

=item Test::Stream::Tester

Copyright 2014 Chad Granum E<lt>exodist7@gmail.comE<gt>.

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

See F<http://www.perl.com/perl/misc/Artistic.html>

=item Test::Simple

=item Test::More

=item Test::Builder

Originally authored by Michael G Schwern E<lt>schwern@pobox.comE<gt> with much
inspiration from Joshua Pritikin's Test module and lots of help from Barrie
Slaymaker, Tony Bowden, blackstar.co.uk, chromatic, Fergal Daly and the perl-qa
gang.

Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern
E<lt>schwern@pobox.comE<gt>, wardrobe by Calvin Klein.

Copyright 2001-2008 by Michael G Schwern E<lt>schwern@pobox.comE<gt>.

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

See F<http://www.perl.com/perl/misc/Artistic.html>

=item Test::use::ok

To the extent possible under law, 唐鳳 has waived all copyright and related
or neighboring rights to L<Test-use-ok>.

This work is published from Taiwan.

L<http://creativecommons.org/publicdomain/zero/1.0>

=item Test::Tester

This module is copyright 2005 Fergal Daly <fergal@esatclear.ie>, some parts
are based on other people's work.

Under the same license as Perl itself

See http://www.perl.com/perl/misc/Artistic.html

=item Test::Builder::Tester

Copyright Mark Fowler E<lt>mark@twoshortplanks.comE<gt> 2002, 2004.

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

=back
