The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
use Test2::V0 -no_srand => 1;
use Test::Script;
use File::Spec;
use File::Temp qw( tempdir );
use Data::Dumper qw( Dumper );
  

# the first subtest replaces t/02_compiles_good.t

subtest 'good' => sub {

  subtest 'default name' => sub {

    my $events;
    my $rv;
    is(
      $events = intercept { $rv = script_compiles 't/bin/good.pl' },
      array {
        event Ok => sub {
          call pass => T();
          call name => 'Script t/bin/good.pl compiles';
        };
        end;
      },
      'script_compiles t/bin/good.pl',
    );
    
    diag Dumper($events) unless $rv;

    is $rv, T(), 'script_compiles_ok returns true as convenience';
  };

  subtest 'with different name' => sub {
  
    my $events;
    my $rv;

    is(
      $events = intercept { $rv = script_compiles 't/bin/good.pl', 'It worked' },
      array {
        event Ok => sub {
          call pass => T();
          call name => 'It worked';
        };
        end;
      },
      'script_compiles t/bin/good.pl It worked',
    );

    diag Dumper($events) unless $rv;

    is $rv, T(), 'script_compiles_ok returns true as convenience';
  };

};

# second subtest replaces t/03_compiles_bad.t

subtest 'bad' => sub {

  my $bad = File::Spec->catfile(qw( t bin bad.pl ));
  ok -f $bad, 'found bad script';

  subtest 'default name' => sub {

    my $rv;
    my $events;

    my $rv2 = is(
      $events = intercept { $rv = script_compiles 't/bin/bad.pl' },
      array {
        event Ok => sub {
          call pass => F();
          call name => 'Script t/bin/bad.pl compiles';
        };
        event Diag => sub {
          # generated by TB / T2
        };
        event Diag => sub {
          call message => match qr{\d+ - (?:Using.*\n# )?Bad at \Q$bad\E line 4\.\n};
          call message => match qr{BEGIN failed--compilation aborted at \Q$bad\E line 5.};
        };
        end;
      },
      'script_compiles t/bin/bad.pl',
    );

    diag Dumper($events) unless $rv2;

    is $rv, F(), 'script_compiles_ok returns false as convenience';
    
  };

  subtest 'custom name' => sub {
  
    my $rv;
    my $events;
    
    my $rv2 = is(
      $events = intercept { $rv = script_compiles 't/bin/bad.pl', 'It worked' },
      array {
        event Ok => sub {
          call pass => F();
          call name => 'It worked';
        };
        event Diag => sub {
          # generated by TB / T2
        };
        event Diag => sub {
          call message => match qr{\d+ - (?:Using.*\n# )?Bad at \Q$bad\E line 4\.\n};
          call message => match qr{BEGIN failed--compilation aborted at \Q$bad\E line 5\.};
        };
        end;
      },
      'script_compiles t/bin/bad.pl It worked',
    );

    diag Dumper($events) unless $rv2;

    is $rv, F(), 'script_compiles_ok returns false as convenience';
    
  };

};

subtest 'unreasonable number of libs' => sub {

  skip_all 'developer only test' unless $ENV{TEST_SCRIPT_DEV_TEST};

  local @INC = @INC;

  my $dir = tempdir( CLEANUP => 1 );

  for(map { File::Spec->catfile($dir, $_) } 1..1000000)
  {
    #mkdir;
    push @INC, $_;
  }

  script_compiles 't/bin/good.pl';

};

subtest exception => sub {

  my $events;
  
  is(
    $events = intercept { script_compiles( 't/bin/missing.pl' ) },
    array {
      event Ok => sub {
        call pass => F();
        call name => 'Script t/bin/missing.pl compiles';
      };
      event Diag => sub {};
      event Diag => sub { call message => match(qr{^2 - }) };
      end;
    },
  );

  note "diagnostic = @{[ $events->[-1]->message ]}";

};

subtest 'signal' => sub {

  skip_all 'not on windows' if $^O eq 'MSWin32';

  is(
    intercept { script_compiles( 't/bin/signal.pl' ) },
    array {
      event Ok => sub {
        call pass => F();
      };
      event Diag => sub {};
      event Diag => sub { call message => '0 - ' };
      event Diag => sub { call message => 'signal: 9' };
      end;
    },
  );

};

script_compiles 't/bin/taint.pl';

done_testing;