package App::ForkProve::SourceHandler;
use strict;
use parent qw(TAP::Parser::SourceHandler);

use App::ForkProve::PipeIterator;
use Scalar::Util 'openhandle';
use TAP::Parser::IteratorFactory;
TAP::Parser::IteratorFactory->register_handler(__PACKAGE__);

use TAP::Parser::SourceHandler::Perl;

sub can_handle {
    my($class, $src) = @_;

    # I think there's a TAP::Parser bug thinking the first line of .t
    # file as a shebang even if it doesn't begin with '#!'
    local $src->meta->{file}{shebang} = undef
      if $src->meta->{file}{shebang} !~ /^#!/;

    my $is_perl = TAP::Parser::SourceHandler::Perl->can_handle($src);
    return 1 if $is_perl > 0.5 && !$class->ignore($src->meta->{file});
    return 0;
}

sub ignore {
    my($class, $file) = @_;
    $ENV{PERL_FORKPROVE_IGNORE} && ($file->{dir} . $file->{basename}) =~ /$ENV{PERL_FORKPROVE_IGNORE}/;
}

sub make_iterator {
    my($class, $src) = @_;

    my $path = $src->meta->{file}{dir} . $src->meta->{file}{basename};
    my @inc = map { s/^-I//; $_ } grep { /^-I/ } @{ $src->switches };

    $class->_autoflush(\*STDOUT);
    $class->_autoflush(\*STDERR);

    pipe my $reader, my $writer;
    my $pid = fork;
    if ($pid) {
        close $writer;
        return App::ForkProve::PipeIterator->new($reader, $pid);
    } else {
        close $reader;
        open STDOUT, ">&", $writer;
        open STDERR, ">&", $writer if $src->merge;
        _run($path, \@inc);
        exit;
    }
}

sub _run {
    my ($t, $inc) = @_;

    # Many tests especially Exception tests rely on test file name being
    # passed as t/foo.t without a leading path
    local $0 = $t;
    local @INC = (@$inc, @INC);

    # if FindBin is preloaded, reset it with the new $0
    if (defined &FindBin::init) {
        FindBin::init()
    }

    # open DATA from test script
    {
        close ::DATA;
        if (open my $fh, $t) {
            my $code = do { local $/; <$fh> };
            if(my($data) = $code =~ /^__(?:END|DATA)__$(.*)/ms){
                open ::DATA, '<', \$data
                  or die "Can't open string as DATA. $!";
            }
        }
    }

    # restore DATA for all preloaded modules
    my $data = \%App::ForkProve::Data;
    for my $mod (keys %$data) {
        my ($was_open, $prev_file, $prev_pos) = @{ $data->{$mod} };

        my $fh = do {
            no strict 'refs';
            *{ $mod . '::DATA' }
        };

        # note that we need to ensure that each forked copy is using a
        # different file handle, or else concurrent processes will interfere
        # with each other

        close $fh if openhandle($fh);

        if ($was_open) {
            if (open $fh, '<', $prev_file) {
                seek($fh, $prev_pos, 0);
            }
            else {
                warn "Couldn't reopen DATA for $mod: $!";
            }
        }
    }

    # restore defaults
    Getopt::Long::ConfigDefaults();

    # reset the state of empty pattern matches, so that they have the same
    # behavior as running in a clean process.
    # see "The empty pattern //" in perlop.
    # note that this has to be dynamically scoped and can't go to other subs
    "" =~ /^/;

    # Test::Builder is loaded? Reset the $Test object to make it unaware
    # that it's a forked off proecess so that subtests won't run
    if (defined $Test::Builder::Test) {
        $Test::Builder::Test->reset;
    }

    # avoid child processes sharing the same seed value as the parent
    srand();

    # clear @ARGV it's localized in App::ForkProve
    local @ARGV = ();

    # do() can't tell if a test can't be read or a .t's last statement
    # returned undef with $! set somewhere. Fortunately in case of
    # prove, non-readable .t will fail earlier in prove itself.
    eval q{ package main; do $t; die $@ if $@; 1 } or die $@;
}

sub _autoflush {
    my ( $class, $flushed ) = @_;
    my $old_fh = select $flushed;
    $| = 1;
    select $old_fh;
}

1;