package Test2::Formatter::Stream;
use strict;
use warnings;

our $VERSION = '1.000169';

use Carp qw/croak confess/;
use Time::HiRes qw/time/;
use IO::Handle;
use File::Spec();
use List::Util qw/first/;

use Test2::Harness::Util::UUID qw/gen_uuid/;
use Test2::Harness::Util::JSON qw/JSON JSON_IS_XS/;
use Test2::Harness::Util qw/hub_truth apply_encoding/;

use Test2::Util qw/get_tid ipc_separator/;

use parent qw/Test2::Formatter/;
use Test2::Util::HashBase qw/-io _encoding _no_header _no_numbers _no_diag -stream_id -tb -tb_handles -dir -_pid -_tid -_fh <job_id -ugids/;

BEGIN {
    my $J = JSON->new;
    $J->indent(0);
    $J->convert_blessed(1);
    $J->allow_blessed(1);
    $J->utf8(1);

    require constant;
    constant->import(ENCODER => $J);

    if (JSON_IS_XS) {
        require JSON::PP;
        my $JPP = JSON::PP->new;
        $JPP->indent(0);
        $JPP->convert_blessed(1);
        $JPP->allow_blessed(1);
        $JPP->utf8(1);

        constant->import(ENCODER_PP => $JPP);
    }
}

my ($ROOT_TID, $ROOT_PID, $ROOT_DIR, $ROOT_JOB_ID, $ROOT_UGIDS);
sub import {
    my $class = shift;
    my %params = @_;

    confess "$class no longer accept the 'file' argument, it now takes a 'dir' argument"
        if exists $params{file};

    $class->SUPER::import();

    $ROOT_PID  = $$;
    $ROOT_TID  = get_tid();
    $ROOT_DIR = $params{dir} if $params{dir};
    $ROOT_JOB_ID = $params{job_id} if $params{job_id};
    $ROOT_UGIDS = [$<, $>, $(, $)];

    if ($ROOT_DIR && ! -d $ROOT_DIR) {
        mkdir($ROOT_DIR) or die "Could not make root dir: $!";
    }
}

sub hide_buffered { 0 }

sub fh {
    my $self = shift;

    my $dir = $self->{+DIR} or return undef;

    my $pid = $self->{+_PID};
    my $tid = $self->{+_TID};

    if ($pid && $pid != $$) {
        delete $self->{+_PID};
        delete $self->{+_FH};
    }

    if ($tid && $tid != get_tid()) {
        delete $self->{+_TID};
        delete $self->{+_FH};
    }

    return $self->{+_FH} if $self->{+_FH};

    $self->{+STREAM_ID} = 1;

    $pid = $self->{+_PID} = $$;
    $tid = $self->{+_TID} = get_tid();

    my $file = File::Spec->catfile($dir, join(ipc_separator() => 'events', $pid, $tid) . ".jsonl");

    my @now = ($<, $>, $(, $));
    local ($<, $>, $(, $)) = @{$self->{+UGIDS}} if $self->{+UGIDS} && first { $self->{+UGIDS}->[$_] ne $now[$_] } 0 .. $#now;

    mkdir($dir) or die "Could not make dir '$dir': $!" unless -d $dir;
    confess "File '$file' already exists!" if -f $file;
    open(my $fh, '>', $file) or die "Could not open file: $file";
    $fh->autoflush(1);

    # Do not apply encoding to the UTF8 output, we let the utf8 formatter
    # handle that. This means do not apply encoding to $self->{+_FH}.

    return $self->{+_FH} = $fh;
}

sub init {
    my $self = shift;

    $self->{+STREAM_ID} = 1;
    $self->{+UGIDS} //= [$<, $>, $(, $)];

    # To create necessary directories as soon as possible
    $self->fh();

    for (@{$self->{+IO}}) {
        $_->autoflush(1);
    }

    STDOUT->autoflush(1);
    STDERR->autoflush(1);

    if ($INC{'Test2/API.pm'}) {
        Test2::API::test2_stdout()->autoflush(1);
        Test2::API::test2_stderr()->autoflush(1);
    }

    if ($self->{check_tb}) {
        require Test::Builder::Formatter;
        $self->{+TB} = Test::Builder::Formatter->new();
        $self->{+TB_HANDLES} = [@{$self->{+TB}->handles}];
    }
}

sub new_root {
    my $class = shift;
    my %params = @_;

    $ROOT_PID = $$ unless defined $ROOT_PID;
    $ROOT_TID = get_tid() unless defined $ROOT_TID;

    confess "new_root called from child process!"
        if $ROOT_PID != $$;

    confess "new_root called from child thread!"
        if $ROOT_TID != get_tid();

    require Test2::API;
    my $io = $params{+IO} = [Test2::API::test2_stdout(), Test2::API::test2_stderr()];
    $_->autoflush(1) for @$io;

    confess "T2_STREAM_FILE is no longer used, see T2_STREAM_DIR"
        if exists $ENV{T2_STREAM_FILE};

    $params{+DIR} ||= $ENV{T2_STREAM_DIR} || $ROOT_DIR;
    $params{+JOB_ID} ||= $ENV{T2_STREAM_JOB_ID} || $ROOT_JOB_ID || 1;

    # DO NOT REOPEN THEM!
    delete $ENV{T2_FORMATTER} if $ENV{T2_FORMATTER} && $ENV{T2_FORMATTER} eq 'Stream';
    delete $ENV{T2_STREAM_DIR};
    delete $ENV{T2_STREAM_JOB_ID};
    $ROOT_DIR = undef;

    $params{check_tb} = 1 if $INC{'Test/Builder.pm'};

    $params{+UGIDS} = $ROOT_UGIDS if $ROOT_UGIDS;

    return $class->new(%params);
}

sub record {
    my $self = shift;
    my ($facets, $num) = @_;

    my $stamp = time;
    my $times = [times];

    my @sync = @{$self->{+IO}};
    my $leader = 0;

    my $fh = $self->fh;
    unless($fh) {
        $leader = 1;
        $fh = shift @sync;
    }

    if ($facets->{control}->{halt}) {
        my $reason = $facets->{control}->{details} || "";

        if ($leader) {
            print $fh "\nBail out!  $reason\n";
        }
        else {
            open(my $bh, '>', File::Spec->catfile($self->{+DIR}, 'bail')) or die "Could not create bail file: $!";
            print $bh $reason;
            close($bh);
        }
    }

    my $tid = get_tid();
    my $id = $self->{+STREAM_ID}++;

    my $json;
    {
        no warnings 'once';
        local *UNIVERSAL::TO_JSON = sub { "$_[0]" };

        my $event_id = $facets->{about}->{uuid} ||= gen_uuid();

        if (JSON_IS_XS) {
            for my $encoder (ENCODER, ENCODER_PP) {
                local $@;
                my $ok = eval {
                    $json = $encoder->encode(
                        {
                            stamp        => $stamp,
                            times        => $times,
                            stream_id    => $id,
                            tid          => $tid,
                            pid          => $$,
                            event_id     => $event_id,
                            facet_data   => $facets,
                            assert_count => $self->{+_NO_NUMBERS} ? undef : $num,
                        }
                    );
                    1;
                };
                my $err = $@;
                last if $ok;

                # Intercept bug in JSON::XS so we can fall back to JSON::PP
                next if $encoder eq ENCODER && $err =~ m/Modification of a read-only value attempted/;

                # Different error, time to die.
                die $err;
            }
        }
        else {
            $json = ENCODER->encode(
                {
                    stamp        => $stamp,
                    times        => $times,
                    stream_id    => $id,
                    tid          => $tid,
                    pid          => $$,
                    event_id     => $event_id,
                    facet_data   => $facets,
                    assert_count => $self->{+_NO_NUMBERS} ? undef : $num,
                }
            );
        }
    }

    # Local is expensive! Only do it if we really need to.
    local($\, $,) = (undef, '') if $\ || $,;

    my $job_id = $self->{+JOB_ID};

    print $fh $leader ? ("T2-HARNESS-$job_id-EVENT: ", $json, "\n") : ($json, "\n");

    print $_ "T2-HARNESS-$job_id-ESYNC: ", join(ipc_separator() => $$, $tid, $id) . "\n" for @sync;
}

sub encoding {
    my $self = shift;

    if (@_) {
        my ($enc) = @_;
        $self->record({control => {encoding => $enc}});
        $self->_set_encoding($enc);
        $self->{+TB}->encoding($enc) if $self->{+TB};
    }

    return $self->{+_ENCODING};
}

sub _set_encoding {
    my $self = shift;

    if (@_) {
        my ($enc) = @_;

        # Do not apply encoding to the UTF8 output, we let the utf8 formatter
        # handle that. This means do not apply encoding to $self->{+_FH}.

        apply_encoding(\*STDOUT, $enc);
        apply_encoding(\*STDERR, $enc);

        my $job_id = $self->{+JOB_ID};
        for my $fh (@{$self->{+IO}}) {
            print $fh "T2-HARNESS-$job_id-ENCODING: $enc\n";
            apply_encoding($fh, $enc);
        }
    }

    return $self->{+_ENCODING};
}

if ($^C) {
    no warnings 'redefine';
    *write = sub { };
}

sub write {
    my ($self, $e, $num, $f) = @_;
    $f ||= $e->facet_data;

    $self->_set_encoding($f->{control}->{encoding}) if $f->{control}->{encoding};

    # Hide these if we must, but do not remove them for good.
    local $f->{info} if $self->{+_NO_DIAG};
    local $f->{plan} if $self->{+_NO_HEADER};

    my $tb_only = 0;
    if ($self->{+TB}) {
        $tb_only ||= $self->{+TB_HANDLES}->[0] != $self->{+TB}->{handles}->[0];
        $tb_only ||= $self->{+TB_HANDLES}->[1] != $self->{+TB}->{handles}->[1];

        my $todo_match = $self->{+TB_HANDLES}->[0] == $self->{+TB}->{handles}->[2]
            || $self->{+TB_HANDLES}->[1] == $self->{+TB}->{handles}->[2];

        $tb_only ||= !$todo_match;

        if ($tb_only) {
            my $buffered = hub_truth($f)->{buffered};
            $self->{+TB}->write($e, $num, $f) if $self->{+TB} && !$buffered;
            return;
        }
    }

    $self->record($f, $num);
}

sub no_header  { $_[0]->{+_NO_HEADER} }
sub no_diag    { $_[0]->{+_NO_DIAG} }
sub no_numbers { $_[0]->{+_NO_NUMBERS} }

sub handles {
    my $self = shift;

    return $self->{+TB}->handles if $self->{+TB};
    return;
}

sub set_no_header {
    my $self = shift;
    ($self->{+_NO_HEADER}) = @_;
    $self->{+TB}->set_no_header(@_) if $self->{+TB};
    $self->{+_NO_HEADER};
}

sub set_no_diag {
    my $self = shift;
    ($self->{+_NO_DIAG}) = @_;
    $self->{+TB}->set_no_diag(@_) if $self->{+TB};
    $self->{+_NO_DIAG};
}

sub set_no_numbers {
    my $self = shift;
    ($self->{+_NO_NUMBERS}) = @_;
    $self->{+TB}->set_no_numbers(@_) if $self->{+TB};
    $self->{+_NO_NUMBERS};
}

sub set_handles {
    my $self = shift;
    return $self->{+TB}->set_handles(@_) if $self->{+TB};
    return;
}

sub terminate {
    my $self = shift;
    return $self->SUPER::terminate(@_) unless $self->{+TB};
    return $self->{+TB}->terminate(@_);
}

sub finalize {
    my $self = shift;
    return $self->SUPER::finalize(@_) unless $self->{+TB};
    return $self->{+TB}->finalize(@_);
}

sub DESTROY {}

our $AUTOLOAD;

sub AUTOLOAD {
    my $this = shift;

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

    my $type = ref($this);

    return $this->{+TB}->$meth(@_)
        if $type && $this->{+TB} && $this->{+TB}->can($meth);

    $type ||= $this;
    croak qq{Can't locate object method "$meth" via package "$type"};
}

sub isa {
    my $in = shift;
    return $in->SUPER::isa(@_) unless ref($in) && $in->{+TB};
    return $in->SUPER::isa(@_) || $in->{+TB}->isa(@_);
}

sub can {
    my $in = shift;
    return $in->SUPER::can(@_) unless ref($in) && $in->{+TB};
    return $in->SUPER::can(@_) || $in->{+TB}->can(@_);
}

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Test2::Formatter::Stream - Test2 Formatter that directly writes events.

=head1 DESCRIPTION

This formatter writes all test2 events to event files (one per process/thread)
instead of writing them to STDERR/STDOUT. It will output synchronization
messages to STDERR/STDOUT every time an event is written. From this data the
test output can be properly reconstructed in order with STDERR/STDOUT and
events mostly synced so that they appear in the correct order.

This formatter is not usually useful to humans. This formatter is used by
L<Test2::Harness> when possible to prevent the loss of data that normally
occurs when TAP is used.

=head1 SYNOPSIS

If you really want your test to output this:

    use Test2::Formatter::Stream;
    use Test2::V0;
    ...

Otherwise just use L<App::Yath> without the C<--no-stream> argument and this
formatter will be used when possible.

=head1 SOURCE

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

=head1 MAINTAINERS

=over 4

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

=back

=head1 AUTHORS

=over 4

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

=back

=head1 COPYRIGHT

Copyright 2020 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://dev.perl.org/licenses/>

=cut
