The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
use strict;
use warnings;
use Test::More tests => 14;
use Devel::Confess ();
use Scalar::Util qw(blessed);

sub DEFAULT { die "DEFAULT\n" }
sub IGNORE  { die "IGNORE\n" }
sub string  { die "string\n" }
sub stub;
sub Namespaced::string { die "Namespaced::string\n" }
{
  no strict 'refs';
  *{"main::0"} = sub { die "zero\n" };
}
my $coderef = sub { die "coderef\n" };

{
  package CodeOverload;
  use overload '&{}' => sub { sub { die "CodeOverload\n" } };
  sub new { bless {} }
}

{
  package StringOverload;
  use overload '""' => sub { "StringOverload::named" };
  sub named { die "StringOverload::named\n" }
  sub new { bless {} }
}

{
  package FalseOverload;
  use overload
    'bool' => sub { 0 },
    '&{}'  => sub { sub { die "FalseOverload\n" } },
  ;
  sub new { bless {} }
}

sub _ex (&) {
  my $sub = $_[0];
  local $@;
  eval { $sub->(); 1 } and return undef;
  my $e = $@;
  $e =~ s/(?: at .*? line [0-9]+\.)?\n//;
  return $e;
}

sub check_find {
  my $sub = do {
    no warnings 'uninitialized';
    local $SIG{__DIE__} = $_[0];
    Devel::Confess::_find_sig($SIG{__DIE__});
  };
  return "none"
    if !defined $sub;
  _ex {
    (\&$sub)->("welp");
  };
}

sub check_sig {
  no warnings 'uninitialized';
  local $SIG{__DIE__} = $_[0];
  _ex {
    die "none\n";
  };
}

for my $sig (
  undef,
  0,
  {},
  '',
  $coderef,
  'DEFAULT',
  'IGNORE',
  'string',
  'stub',
  'Namespaced::string',
  'nonexistant',
  CodeOverload->new,
  StringOverload->new,
  FalseOverload->new,
) {
  my $name
    = blessed $sig ? (blessed($sig) . " instance")
    : ref $sig ? (ref($sig) . " ref")
    : defined $sig ? qq{"$sig"}
    : 'undef';
  is(check_find($sig), check_sig($sig),
    "correct signal handler for $name"
  );
}