The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
use strict;
use warnings;
BEGIN {
  $ENV{DEVEL_CONFESS_OPTIONS} = '';
}
use Test::More tests => 12;
use t::lib::capture;

# preload to make sure we only test the effect of our own import
use base ();
use Exporter ();
use Carp ();
use Carp::Heavy ();
use Symbol ();

my $pre_die;
BEGIN { $pre_die = $SIG{__DIE__} }

use Devel::Confess ();

is $SIG{__DIE__}, $pre_die, 'not activated without import';
my $called;
sub CALLED { $called++ };
$SIG{__DIE__} = \&CALLED;
Devel::Confess->import;
isnt $SIG{__DIE__}, \&CALLED, 'import overwrites existing __DIE__ handler';
$called = 0;
eval { die };
is 0+$called, 1, 'calls outer __DIE__ handler';
Devel::Confess->unimport;
is $SIG{__DIE__}, \&CALLED, 'unimport restores __DIE__ handler';

$SIG{__DIE__} = '';
Devel::Confess->import;
Devel::Confess->unimport;
ok !$SIG{__DIE__}, 'unimport restores nonexistent __DIE__ handler';

sub IGNORE { $called++ }
sub DEFAULT { $called++ }
sub other::sub { $called++ }

$SIG{__DIE__} = 'IGNORE';
Devel::Confess->import;
$called = 0;
eval { die };
is 0+$called, 0, 'no dispatching to IGNORE';
Devel::Confess->unimport;

$SIG{__DIE__} = 'DEFAULT';
Devel::Confess->import;
$called = 0;
eval { die };
is 0+$called, 0, 'no dispatching to DEFAULT';
Devel::Confess->unimport;

$SIG{__DIE__} = 'CALLED';
Devel::Confess->import;
$called = 0;
eval { die };
is 0+$called, 1, 'dispatches by name';
Devel::Confess->unimport;

$SIG{__DIE__} = 'other::sub';
Devel::Confess->import;
$called = 0;
eval { die };
is 0+$called, 1, 'dispatches by name to package sub';
Devel::Confess->unimport;

is capture <<'END_CODE', <<'END_OUTPUT', 'trace still added when outer __DIE__ exists';
BEGIN { $SIG{__DIE__} = sub { 1 } }
use Devel::Confess;
package A;

sub f {
#line 1 test-block.pl
    die "Beware!";
}

sub g {
#line 2 test-block.pl
    f();
}

package main;

#line 3 test-block.pl
A::g();
END_CODE
Beware! at test-block.pl line 1.
	A::f() called at test-block.pl line 2
	A::g() called at test-block.pl line 3
END_OUTPUT

is capture <<'END_CODE', '', 'outer __WARN__ can silence warnings';
BEGIN { $SIG{__WARN__} = sub { } }
use Devel::Confess;
package A;

sub f {
#line 1 test-block.pl
    warn "Beware!";
}

sub g {
#line 2 test-block.pl
    f();
}

package main;

#line 3 test-block.pl
A::g();
END_CODE

is capture <<'END_CODE', <<'END_OUTPUT', 'outer __WARN__ gets full location';
BEGIN { $SIG{__WARN__} = sub { warn $_[0] } }
use Devel::Confess;
package A;

sub f {
#line 1 test-block.pl
    warn "Beware!";
}

sub g {
#line 2 test-block.pl
    f();
}

package main;

#line 3 test-block.pl
A::g();
END_CODE
Beware! at test-block.pl line 1.
	A::f() called at test-block.pl line 2
	A::g() called at test-block.pl line 3
END_OUTPUT