The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
#!perl -T
# -*- mode: cperl ; compile-command: "cd .. ; ./Build ; prove -vb t/10-*.t" -*-

BEGIN { $_ = defined && /(.*)/ && $1 for @ENV{qw/ TMPDIR TEMP TMP /} } # taint vs tempfile
use Test::Tester;
use Test::More tests => 2 + 3 + 7*15 + 5*3;
use strict;
use warnings;

use Test::Trap qw( trap $T );
use Test::Trap qw( diag_all $T :on_fail(diag_all) );
use Test::Trap qw( diag_all_once $T :on_fail(diag_all_once) );

# Trap with warning and return
my ($prem, @t) = run_tests
  ( sub {
      my $t = trap { warn "A warning"; 5 };
      $T->return_is_deeply( [5], '5 was returned' );
      $T->warn_like( 0, qr/^A warning\b/, 'A warning was given' );
    },
  );
is( $prem, '' );
is( $#t, 1 );
is( $t[0]{ok}, 1, '->return_is_deeply [5]');
is( $t[0]{actual_ok}, 1 );
is( $t[0]{name}, '5 was returned' );
is( $t[0]{diag}, '' );
is( $t[0]{depth}, 1 );
is( $t[1]{ok}, 1, '->warn_like');
is( $t[1]{actual_ok}, 1 );
is( $t[1]{name}, 'A warning was given' );
is( $t[1]{diag}, '' );
is( $t[1]{depth}, 1 );

# Trap with silent exit
($prem, @t) = run_tests
  ( sub {
      my $t = trap { exit };
      $T->return_is_deeply( [5], '5 was returned' );
    },
  );
is( $prem, '' );
is( $#t, 0 );
is( $t[0]{ok}, 0, '->return_is_deeply [5]');
is( $t[0]{actual_ok}, 0 );
is( $t[0]{name}, '5 was returned' );
is( $t[0]{diag}, <<'EOE' );
    Expecting to return(), but instead exit()ed with 0
EOE
is( $t[0]{depth}, 1 );

# Trap with exception and diag_all
($prem, @t) = run_tests
  ( sub {
      my $t = diag_all { die "Argh\n" };
      $T->return_nok(0, 'Return with (first) false value');
      $T->exit_nok(q/Exit with (Perl's idea of a) false value/);
    },
  );
is( $prem, '' );
is( $#t, 1 );
is( $t[0]{ok}, 0, '->return_nok');
is( $t[0]{actual_ok}, 0 );
is( $t[0]{name}, 'Return with (first) false value' );
is( $t[0]{diag}, sprintf <<'EOE', Data::Dump::dump($T) );
    Expecting to return(), but instead die()ed with "Argh\n"
%s
EOE
is( $t[0]{depth}, 1 );
is( $t[1]{ok}, 0, '->exit_nok');
is( $t[1]{actual_ok}, 0 );
is( $t[1]{name}, q/Exit with (Perl's idea of a) false value/ );
is( $t[1]{diag}, sprintf <<'EOE', Data::Dump::dump($T) );
    Expecting to exit(), but instead die()ed with "Argh\n"
%s
EOE
is( $t[1]{depth}, 1 );

# Trap with print, exit, and diag_all
($prem, @t) = run_tests
  ( sub {
      my $t = diag_all { print "Hello world"; exit };
      $T->exit_nok('Exit with false value');
    },
  );
is( $prem, '' );
is( $#t, 0 );
is( $t[0]{ok}, 1, '->exit_nok');
is( $t[0]{actual_ok}, 1 );
is( $t[0]{name}, 'Exit with false value' );
is( $t[0]{diag}, '' );
is( $t[0]{depth}, 1 );

# Capture some TB version dependent stuff:
($prem, @t) = run_tests sub { isnt 5, 5 };
my $diag5isnt5 = $t[0]{diag};

# Trap with print, and exit 5, and diag_all_once
($prem, @t) = run_tests
  ( sub {
      my $t = diag_all_once { print "Hello world"; exit 5 };
      $T->exit_nok('Exit with false value');
      $T->exit_isnt(5, 'Exit with non-5 value');
    },
  );
is( $prem, '' );
is( $#t, 1 );
is( $t[0]{ok}, 0, '->exit_nok');
is( $t[0]{actual_ok}, 0 );
is( $t[0]{name}, 'Exit with false value' );
is( $t[0]{diag}, sprintf <<'EOE', Data::Dump::dump($T) );
    Expecting false value in exit(), but got 5 instead
%s
EOE
is( $t[0]{depth}, 1 );
is( $t[1]{ok}, 0, '->exit_isnt');
is( $t[1]{actual_ok}, 0 );
is( $t[1]{name}, 'Exit with non-5 value' );
is( $t[1]{diag}, "$diag5isnt5(as above)\n" );
is( $t[1]{depth}, 1 );

# Trap with multiple return values and diag_all_once
($prem, @t) = run_tests
  ( sub {
      my ($t) = diag_all_once { return 3..7 };
      $T->return_like( 1, qr/4/, 'return[1] matches /4/' );
    },
  );
is( $prem, '' );
is( $#t, 0 );
is( $t[0]{ok}, 1, '->return_like');
is( $t[0]{actual_ok}, 1 );
is( $t[0]{name}, 'return[1] matches /4/' );
is( $t[0]{diag}, '' );
is( $t[0]{depth}, 1 );

# Quiet trap, with no on-test-failure callback
($prem, @t) = run_tests
  ( sub {
      my ($t) = trap { return 3..7 };
      $T->quiet;
    },
  );
is( $prem, '' );
is( $#t, 0 );
is( $t[0]{ok}, 1, '->quiet');
is( $t[0]{actual_ok}, 1 );
is( $t[0]{name}, '' );
is( $t[0]{diag}, '' );
is( $t[0]{depth}, 1 );

# Warning trap with diag_all_once
($prem, @t) = run_tests
  ( sub {
      my ($t) = diag_all_once { warn "Hello!\n" };
      $T->quiet('In denial about STDERR');
    },
  );
is( $prem, '' );
is( $#t, 0 );
is( $t[0]{ok}, 0, '->quiet');
is( $t[0]{actual_ok}, 0 );
is( $t[0]{name}, 'In denial about STDERR' );
is( $t[0]{diag}, sprintf <<'EOE', Data::Dump::dump($T) );
Expecting no STDERR, but got "Hello!\n"
%s
EOE
is( $t[0]{depth}, 1 );

# Printing trap with no on-test-failure callback
($prem, @t) = run_tests
  ( sub {
      my ($t) = trap { print "Hello!\n" };
      $T->quiet('In denial about STDOUT');
    },
  );
is( $prem, '' );
is( $#t, 0 );
is( $t[0]{ok}, 0, '->quiet');
is( $t[0]{actual_ok}, 0 );
is( $t[0]{name}, 'In denial about STDOUT' );
is( $t[0]{diag}, <<'EOE' );
Expecting no STDOUT, but got "Hello!\n"
EOE
is( $t[0]{depth}, 1 );

# Noisy trap
($prem, @t) = run_tests
  ( sub {
      my ($t) = trap { warn "world!\n"; print "Hello!\n" };
      $T->quiet('In denial about noise!');
    },
  );
is( $prem, '' );
is( $#t, 0 );
is( $t[0]{ok}, 0, '->quiet');
is( $t[0]{actual_ok}, 0 );
is( $t[0]{name}, 'In denial about noise!' );
is( $t[0]{diag}, <<'EOE' );
Expecting no STDOUT, but got "Hello!\n"
Expecting no STDERR, but got "world!\n"
EOE
is( $t[0]{depth}, 1 );

# Noisy trap
($prem, @t) = run_tests
  ( sub {
      my ($t) = trap { warn "world!\n"; print "Hello!\n" };
      $T->did_return('Should return');
    },
  );
is( $prem, '' );
is( $#t, 0 );
is( $t[0]{ok}, 1, '->did_return');
is( $t[0]{actual_ok}, 1 );
is( $t[0]{name}, 'Should return' );
is( $t[0]{diag}, '' );
is( $t[0]{depth}, 1 );

# Exiting trap
($prem, @t) = run_tests
  ( sub {
      my ($t) = trap { exit };
      $T->did_exit('Should exit');
    },
  );
is( $prem, '' );
is( $#t, 0 );
is( $t[0]{ok}, 1, '->did_exit');
is( $t[0]{actual_ok}, 1 );
is( $t[0]{name}, 'Should exit' );
is( $t[0]{diag}, '' );
is( $t[0]{depth}, 1 );

# Exiting trap
($prem, @t) = run_tests
  ( sub {
      my ($t) = trap { exit };
      $T->did_die('In denial about death');
    },
  );
is( $prem, '' );
is( $#t, 0 );
is( $t[0]{ok}, 0, '->did_die');
is( $t[0]{actual_ok}, 0 );
is( $t[0]{name}, 'In denial about death' );
is( $t[0]{diag}, <<'EOE' );
    Expecting to die(), but instead exit()ed with 0
EOE
is( $t[0]{depth}, 1 );

# Exiting TODO trap
($prem, @t) = run_tests
  ( sub {
    TODO: {
	local $TODO = 'Testing TODOs';
	my ($t) = trap { exit };
	$T->did_die('In denial about death');
      }
    },
  );
is( $prem, '' );
is( $#t, 0 );
is( $t[0]{ok}, 1, '->did_die, TODO');
is( $t[0]{actual_ok}, 0 );
is( $t[0]{name}, 'In denial about death' );
is( $t[0]{diag}, <<'EOE' );
    Expecting to die(), but instead exit()ed with 0
EOE
is( $t[0]{depth}, 1 );
# extra 2:
is( $t[0]{type}, 'todo', 'type = todo' );
is( $t[0]{reason}, 'Testing TODOs', 'reason' );

my $really_skipped = 1;
# Exiting SKIPPED trap
($prem, @t) = run_tests
  ( sub {
    SKIP: {
	skip 'Testing SKIP', 1;
	undef $really_skipped;
	my ($t) = trap { exit };
	$T->did_die('In denial about death');
      }
    },
  );
is( $prem, '' );
is( $#t, 0 );
is( $t[0]{ok}, 1, '->did_die, SKIPPED');
is( $t[0]{actual_ok}, 1 );
is( $t[0]{name}, '' );
is( $t[0]{diag}, '' );
is( $t[0]{depth}, 1 );
# extra 3:
is( $t[0]{type}, 'skip', 'type = skip' );
is( $t[0]{reason}, 'Testing SKIP', 'reason' );
is( $really_skipped, 1, 'Asserting that SKIPPED code has not been run');