The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
# vim: set ft=perl ts=2 sts=2 sw=2 et sta:
use strict;
use warnings;

package # no_index
  AggTestTester;

use Test::Aggregate;
use File::Spec::Functions qw(catfile); # core
use Test::More;
use Exporter;
our @ISA = qw(Exporter);

our @EXPORT = qw(
  aggregate
  catfile
  only_with_nested
);

sub only_with_nested (&) {
  my $sub = shift;
  SKIP: {
    # We use done_testing so skip(1) is sufficient.
    skip 'Need Test::More::subtest() for nested tests', 1
        if !Test::More->can('subtest');

    require Test::Aggregate::Nested;
    $sub->();
  }
}

sub aggregate {
  AggTestTester->new(@_)->run;
}

sub new {
  my ($class, $mod, $tests, $exp, %extra) = @_;
  eval "require $mod" or die $@;
  bless {
    mod   => $mod,
    tests => $tests,
    exp   => $exp,
    diag  => delete($extra{diag}) || [],
    args  => { %extra },
  }, $class;
}

sub aggregator {
  my ($self) = shift;

  return $self->{mod}->new({
    tests   => $self->{tests},
    verbose => 2,
    %{ $self->{args} },
    @_,
  });
}

sub run {
  my $self = shift;
  my $mod = $self->{mod};
  my $is_nested = ($mod =~ /::Nested$/);
  my $tb = {};
  my @ran;

  # Break the reference.
  my @exp_results = @{ $self->{exp} };

  # Test::Tester didn't work well with Test::Aggregate
  # so just override the functions used in the tests
  {
    no strict 'refs';
    no warnings 'redefine';

    # Keep copies to the originals so we can call them.
    my $ok   = \&Test::Builder::ok;
    my $diag = \&Test::Builder::diag;

    # Intercept calls to ok():
    # Make it "ok" if it's the test we expected and "not ok" if it isn't.
    local *Test::Builder::ok = sub {
      my ($self, $val, $msg) = @_;
      my $agg_ok = 0;
      my $exp = $exp_results[0];

      if( $exp && $val == $exp->[0] && $msg =~ $exp->[1] ){
        $agg_ok = 1;
        $msg = $exp->[2];
        shift @exp_results;
      }

      # For debugging.
      if( !$agg_ok ){
        $self->$diag(       "Intercepted: ok($val, $msg);");
        $self->$diag($exp ? "Expected:    ok($exp->[0], $exp->[1]);" : "No more expected");
      }

      $self->$ok($agg_ok, "(Aggregated) $msg");
    };
    # Hide most diag output, but track it for later.
    local *Test::Builder::diag = sub {
      my ($self, $msg) = @_;
      push @{ $tb->{diag} }, $msg;
    };

    my $agg = $self->aggregator(
      setup => sub { push @ran, $_[0] },
    );

    # Nested sets a plan so it needs to run in a subtest.
    if( $is_nested ){
      # Therefore we'll need to expect another ok().
      push @exp_results, [1, qr/Nested/, 'Tester subtest'];
      Test::More::subtest(Nested => sub { $agg->run })
    }
    else {
      $agg->run;
    }
  }

  is scalar(@exp_results), 0, "$mod - All expected tests found";

  is_deeply(\@ran, $self->{tests}, "$mod - All expected test scripts run");

  # Check diag to see that we ran each script.
  # This is redundant with the setup block test but it makes me feel good.
  my @exp_diags = (
    (map { (
      (!$is_nested && $ENV{TEST_VERBOSE} ? qr/[*]{8} running tests for \Q$_\E [*]{8}/ : ()),
      qr/ \Q$_\E \(\d out of ${\scalar @{ $self->{tests} }}\)/,
    ) } @{ $self->{tests} }),
    @{ $self->{diag} },
  );
  my @diags = @{ $tb->{diag} };
  my @unmatched;

  is scalar(@exp_diags), scalar(@diags), 'expected number of diagnostics';

  DIAG: while( my $diag = shift @diags ){
    foreach my $exp_msg ( @exp_diags ){
      $diag =~ $exp_msg
        and next DIAG;
    }
    push @unmatched, $diag;
  }

  is scalar(@unmatched), 0, 'all diagnostics matched'
    or diag explain \@unmatched;
}

1;