#!perl

BEGIN {
  unless ($ENV{AUTHOR_TESTING}) {
    require Test::More;
    Test::More::plan(skip_all => 'these tests are for testing by the author');
  }
}


use 5.010;
use strict;
use warnings;

my %OLD_SIG;
BEGIN {
    @OLD_SIG{qw/__DIE__ __WARN__/} = @SIG{qw/__DIE__ __WARN__/};
    my $longmess = sub {
        my $mess = '';
        my $i = 2;
        {
            package DB;
            while (my @caller = caller($i)) {
                if ($i == 2) { $mess .= $_[0] }
                $mess .= "\t";
                if ($caller[3]) { # subroutine
                    $mess .= "$caller[3](";
                    if ($caller[4]) { # has_args
                        my $j = 0;
                        for my $arg0 (@DB::args) {
                            my $arg = $arg0; # copy
                            if ($j++) { $mess .= ", " }
                            if (!defined($arg)) { $arg = "undef" }
                            elsif (ref($arg)) { }
                            else { $arg =~ s/([\\'])/\\$1/g; $arg = "'$arg'" }
                            $mess .= $arg;
                        }
                    }
                    $mess .= ") called ";
                }
                $mess .= "at $caller[1] line $caller[2]\n";
                $i++;
            }
        }
        $mess;
    };
    $SIG{__DIE__}  = sub { die &$longmess };
    $SIG{__WARN__} = sub { warn &$longmess };
}
END {
    @SIG{qw/__DIE__ __WARN__/} = @OLD_SIG{qw/__DIE__ __WARN__/};
}

use Capture::Tiny qw(capture);
use Test::More 0.98;

my $stderr;

(undef, undef, undef) = capture { eval { die }; $stderr = $@ };
like($stderr, qr/ called at .+ called at /s) or diag $stderr;

(undef, $stderr, undef) = capture { warn };
like($stderr, qr/ called at .+ called at /s) or diag $stderr;

done_testing;
