#!/usr/bin/perl
# =============================================================================
#  Mediabot v3 - Framework de test des commandes IRC
#  Usage : perl t/test_commands.pl [--verbose] [--filter <pattern>]
#           [--nick <nick>] [--host <host>] [--channel <chan>]
#           [--botnick <botnick>] [--cmdchar <char>]
# =============================================================================

BEGIN {
    require FindBin;
    unshift @INC, "$FindBin::Bin/lib";  # t/lib/
    unshift @INC, "$FindBin::Bin/..";   # racine projet
}

use strict;
use warnings;
use MockBot;
use MockIRC;
use MockMessage;
use MockUser;
use Getopt::Long;
use File::Basename;
use Cwd qw(getcwd);
use POSIX qw(strftime);
use TAP::Parser;

binmode(STDOUT, ':encoding(UTF-8)');
binmode(STDERR, ':encoding(UTF-8)');

# Mediabot.pm charge "use diagnostics" qui formate les warnings longuement.
# On le desactive juste avant chaque execution de closure (apres chargement).


# ---- Options CLI ------------------------------------------------------------
my $opt_verbose = 0;
my $opt_filter  = '';
my $opt_nick    = 'testuser';
my $opt_host    = 'test.host';
my $opt_channel = '#test';
my $opt_botnick = 'mediabot';
my $opt_cmdchar = '!';
GetOptions(
    'verbose|v'   => \$opt_verbose,
    'filter|f=s'  => \$opt_filter,
    'nick|n=s'    => \$opt_nick,
    'host=s'      => \$opt_host,
    'channel|c=s' => \$opt_channel,
    'botnick|b=s' => \$opt_botnick,
    'cmdchar=s'   => \$opt_cmdchar,
) or die <<USAGE;
Usage: $0 [options]
  --verbose, -v          Afficher chaque test [OK]/[FAIL]
  --filter,  -f <pat>    Lancer uniquement les fichiers matching <pat>
  --nick,    -n <nick>   Pseudo par defaut (defaut: testuser)
  --host        <host>   Hostname par defaut (defaut: test.host)
  --channel, -c <chan>   Canal par defaut   (defaut: #test)
  --botnick, -b <name>   Pseudo du bot      (defaut: mediabot)
  --cmdchar     <char>   Caractere de commande (defaut: !)
USAGE

# ---- Classe d'assertion -----------------------------------------------------
package Assert;

# Legacy MB12x-MB20x case files receive an assertion callback and invoke it as
# $assert->($condition, $description), while newer cases use the Assert object
# methods directly. Make the same object callable so the static runner supports
# both test styles.
use overload
    '&{}' => sub {
        my ($self) = @_;
        return sub {
            my (@args) = @_;

            # A failed regex evaluated in list context contributes an empty
            # list, leaving only the description. Treat that shape as failure
            # instead of accepting a truthy description as an unnamed pass.
            if (@args == 1 && defined $args[0] && $args[0] !~ /\A(?:0|1)\z/) {
                $self->fail($args[0]);
                return;
            }

            $self->ok($args[0], $args[1]);
        };
    },
    fallback => 1;

sub new {
    my ($class, %args) = @_;
    return bless { verbose => $args{verbose} // 0, pass => 0, fail => 0 }, $class;
}

sub _result {
    my ($self, $ok, $desc, $extra) = @_;
    if ($ok) {
        $self->{pass}++;
        print "  [OK] $desc\n" if $self->{verbose};
    } else {
        $self->{fail}++;
        my $info = $extra ? " ($extra)" : '';
        print "  [FAIL] $desc$info\n";
    }

    # MB301: assertion methods must behave like Test::More predicates so
    # constructs such as ok(...) or diag(...) work predictably.
    return $ok ? 1 : 0;
}

sub ok {
    my ($self, $val, $desc) = @_;
    $self->_result($val ? 1 : 0, $desc // '(unnamed)',
        $val ? '' : 'got: ' . (defined $val ? "'$val'" : 'undef'));
}

sub is {
    my ($self, $got, $expected, $desc) = @_;
    my $ok = defined $got && defined $expected && $got eq $expected;
    $self->_result($ok, $desc // '(unnamed)',
        $ok ? '' : 'got: ' . (defined $got ? "'$got'" : 'undef') . " expected: '$expected'");
}

sub isnt {
    my ($self, $got, $unexpected, $desc) = @_;
    my $ok = !defined $got || $got ne $unexpected;
    $self->_result($ok, $desc // '(unnamed)',
        $ok ? '' : "got unexpected: '$got'");
}

sub like {
    my ($self, $got, $pattern, $desc) = @_;
    my $ok = defined $got && $got =~ /$pattern/;
    $self->_result($ok, $desc // '(unnamed)',
        $ok ? '' : 'got: ' . (defined $got ? "'$got'" : 'undef') . " pattern: $pattern");
}

sub unlike {
    my ($self, $got, $pattern, $desc) = @_;
    my $ok = !defined $got || $got !~ /$pattern/;
    $self->_result($ok, $desc // '(unnamed)',
        $ok ? '' : "unexpectedly matched '$pattern'");
}

sub pass { $_[0]->_result(1, $_[1] // '(pass)') }
sub fail { $_[0]->_result(0, $_[1] // '(fail)') }

sub diag {
    my ($self, @parts) = @_;
    my $text = join('', map { defined($_) ? $_ : 'undef' } @parts);
    $text =~ s/\r\n?/\n/g;
    $text =~ s/\n\z//;
    $text =~ s/^/# /mg;
    print "$text\n" if length $text;
    return 0;
}

sub total  { $_[0]->{pass} + $_[0]->{fail} }
sub passed { $_[0]->{pass} }
sub failed { $_[0]->{fail} }

# ---- Runner -----------------------------------------------------------------
package main;

sub make_bot {
    my (%args) = @_;
    my $default_nick = $opt_nick;
    my $user = $args{user} // MockUser->new(nick => $default_nick, level => 'Owner', auth => 1);
    return MockBot->new(
        mock_user   => $user,
        debug_level => $args{debug_level} // -1,
        botnick     => $args{botnick}     // $opt_botnick,
        cmd_char    => $args{cmd_char}    // $opt_cmdchar,
    );
}

sub make_msg_chan {
    my (%args) = @_;
    return MockMessage->from_channel(
        prefix  => $args{prefix}  // "$opt_nick!$opt_nick\@$opt_host",
        channel => $args{channel} // $opt_channel,
        text    => $args{text}    // '',
    );
}

sub make_msg_priv {
    my (%args) = @_;
    return MockMessage->from_private(
        prefix => $args{prefix} // "$opt_nick!$opt_nick\@$opt_host",
        text   => $args{text}   // '',
    );
}

# mb333-B1: Some historical case files are standalone TAP programs. They call exit()
# directly instead of returning a closure when loaded through do(). Loading one
# of those files in the runner process terminates the whole suite immediately,
# skips every later case, and can return success before the runner prints its
# final summary. MB333 isolates such cases in a subprocess and merges their TAP
# counts into the normal Assert totals.
sub _case_requires_isolation {
    my ($file) = @_;

    open my $fh, '<:encoding(UTF-8)', $file
        or return (1, "cannot inspect $file: $!");
    local $/;
    my $src = <$fh>;
    close $fh;

    return (1, 'empty or unreadable test source')
        unless defined $src && length $src;

    # MB335: classify by the file contract, not by words that may appear in
    # quoted probe programs. Native runner cases return a closure directly.
    return (0, 'runner closure')
        if $src =~ /^\s*return\s+sub\s*\{/m;

    # Hybrid cases expose a closure when loaded by this runner and execute a
    # standalone TAP footer only when called directly.
    return (0, 'caller-guarded runner closure')
        if $src =~ /^\s*my\s+\$[A-Za-z_]\w*\s*=\s*sub\s*\{/m
        && $src =~ /\b(?:if|unless)\s*\(\s*caller(?:\s*\(\s*\))?\s*\)/;

    # Test::More/Test2 and historical TAP scripts must run in their own Perl
    # process so their plan/done_testing/exit state cannot contaminate the
    # custom Assert runner or any later case.
    return (1, 'standalone TAP contract');
}

sub _run_isolated_tap_case {
    my ($file, $name, $assert) = @_;

    my $project_root = "$FindBin::Bin/..";

    my $pid = open(my $child, '-|');
    unless (defined $pid) {
        $assert->fail("$name: isolated launch - cannot fork: $!");
        return;
    }

    if ($pid == 0) {
        open STDERR, '>&', STDOUT
            or POSIX::_exit(254);
        chdir $project_root
            or do {
                print "Bail out! cannot chdir to $project_root: $!\n";
                POSIX::_exit(254);
            };
        no warnings 'exec';
        exec(
            $^X,
            "-I$FindBin::Bin/lib",
            "-I$project_root",
            $file,
        );
        print "Bail out! cannot exec $file: $!\n";
        POSIX::_exit(254);
    }

    local $/;
    my $output = <$child> // '';
    my $closed = close $child;
    my $status = $?;

    print $output;

    my $parser = TAP::Parser->new({ source => \$output });
    my ($tap_pass, $tap_fail, $tap_tests) = (0, 0, 0);

    while (my $result = $parser->next) {
        next unless $result->is_test;
        $tap_tests++;
        if ($result->is_ok) {
            $tap_pass++;
        }
        else {
            $tap_fail++;
        }
    }

    $assert->{pass} += $tap_pass;
    $assert->{fail} += $tap_fail;

    my @parse_errors = $parser->parse_errors;

    # Several historical standalone scripts emit valid ok/not-ok lines but no
    # explicit plan. Preserve that legacy contract when assertions were seen;
    # every other TAP parse error remains fatal.
    my @fatal_parse_errors = grep {
        !($tap_tests > 0 && /No plan found in TAP output/)
    } @parse_errors;

    if (@fatal_parse_errors) {
        my $detail = join('; ', @fatal_parse_errors);
        $assert->fail("$name: isolated TAP parse", $detail);
    }
    elsif ($tap_tests == 0) {
        $assert->fail("$name: isolated TAP", 'no TAP assertions found');
    }

    my $signal = $status & 127;
    my $exit   = $status >> 8;

    if ($signal) {
        $assert->fail("$name: isolated process - terminated by signal $signal");
    }
    elsif (!$closed || $exit != 0) {
        # A normal failing TAP case already contributes its not-ok assertions.
        # Add a process-level failure only when TAP did not explain the exit.
        if ($tap_fail == 0 && !@fatal_parse_errors) {
            $assert->fail("$name: isolated process - exit status $exit");
        }
    }

    return 1;
}

# ---- Chargement des cas de test ---------------------------------------------

my $assert   = Assert->new(verbose => $opt_verbose);
my $ts_start = time();

# Chemin absolu vers t/cases/ — indépendant du CWD
my $cases_dir  = "$FindBin::Bin/cases";
my @test_files = sort glob("$cases_dir/*.t");

if ($opt_filter) {
    my $filter_re = eval { qr/$opt_filter/i };
    if (!$filter_re) {
        my $err = $@ || 'unknown regex error';
        $err =~ s/\s+\z//;
        die "Invalid --filter regex '$opt_filter': $err\n";
    }
    @test_files = grep { basename($_) =~ $filter_re } @test_files;
}

if (!@test_files) {
    print "Aucun fichier de test trouve dans $cases_dir\n";
    exit 1;
}

for my $file (@test_files) {
    my $name = basename($file);
    print "\n[ $name ]\n";

    my ($isolate, $isolate_reason) = _case_requires_isolation($file);
    if ($isolate) {
        print "  (isolated standalone TAP case: $isolate_reason)\n" if $opt_verbose;
        _run_isolated_tap_case($file, $name, $assert);
        next;
    }

    # FindBin was initialized for this runner. Legacy loaded cases expect $Bin
    # to be their own t/cases directory, so localize it around do().
    local $FindBin::Bin = dirname($file);
    local $FindBin::RealBin = $FindBin::Bin;
    my $code = do $file;
    if ($@) {
        print "  ERREUR de chargement : $@\n";
        $assert->fail("$name: chargement");
        next;
    }
    if (ref $code eq 'CODE') {
        eval { diagnostics->disable } if $diagnostics::VERSION;
        local $SIG{__WARN__} = sub {
            my $w = shift;
            return if $w =~ /uninitialized|redefine|prototype|only once/i;
            warn $w;
        };
        # MB301: a broken case must fail that case, not abort the whole runner.
        my $executed = eval {
            $code->($assert, \&make_bot, \&make_msg_chan, \&make_msg_priv);
            1;
        };

        if (!$executed) {
            my $err = $@ || 'unknown test execution error';
            $err =~ s/\r\n?/\n/g;
            $err =~ s/\s+\z//;
            $err =~ s/\n/\n  /g;
            print "  ERREUR d'execution : $err\n";
            $assert->fail("$name: execution");
        }
    } else {
        print "  (pas de sous-routine retournee, skip)\n";
    }
}

# ---- Resume -----------------------------------------------------------------

my $elapsed = time() - $ts_start;
my $total   = $assert->total;
my $passed  = $assert->passed;
my $failed  = $assert->failed;

print "\n" . "=" x 60 . "\n";
if ($failed == 0) {
    printf "PASSED : %d/%d  (%ds)\n", $passed, $total, $elapsed;
} else {
    printf "FAILED : %d/%d  (%d passed)  (%ds)\n", $failed, $total, $passed, $elapsed;
}
print "=" x 60 . "\n";

exit($failed > 0 ? 1 : 0);