File Coverage

blib/lib/Devel/Confess.pm

Criterion	Covered	Total	%
statement	215	278	77.3
branch	98	156	62.8
condition	35	76	46.0
subroutine	32	37	86.4
pod			n/a
total	380	547	69.4

package Devel::Confess;
BEGIN {
  my $can_use_informative_names = $] >= 5.008;
  # detect -d:Confess.  disable debugger features for now.  we'll
  # enable them when we need them.
  if (!defined &DB::DB && $^P & 0x02) {
    $can_use_informative_names = 1;
    $^P = 0;
  }
  *_CAN_USE_INFORMATIVE_NAMES
    = $can_use_informative_names ? sub () { 1 } : sub () { 0 };
}

use 5.006;
use strict;
use warnings;
no warnings 'once';

our $VERSION = '0.009002';
$VERSION = eval $VERSION;

use Carp ();
use Symbol ();
use Devel::Confess::_Util qw(blessed refaddr weaken longmess _str_val _in_END _can_stringify);
use Config ();
BEGIN {
  *_can = \&UNIVERSAL::can;

  *_BROKEN_CLONED_DESTROY_REBLESS
    = ($] >= 5.008009 && $] < 5.010000) ? sub () { 1 } : sub () { 0 };
  *_BROKEN_CLONED_GLOB_UNDEF
    = ($] > 5.008009 && $] <= 5.010000) ? sub () { 1 } : sub () { 0 };
  *_BROKEN_SIG_DELETE
    = ($] < 5.008008) ? sub () { 1 } : sub () { 0 };
  *_DEBUGGING
    = (
      defined &Config::non_bincompat_options
        ? (grep $_ eq 'DEBUGGING', Config::non_bincompat_options())
        : ($Config::Config{ccflags} =~ /-DDEBUGGING\b/)
    ) ? sub () { 1 } : sub () { 0 };
}

$Carp::Internal{+__PACKAGE__}++;

our %NoTrace;
$NoTrace{'Throwable::Error'}++;
$NoTrace{'Moose::Error::Default'}++;

our %OPTIONS = (
  objects   => !!1,
  builtin   => undef,
  dump      => !!0,
  color     => !!0,
  source    => 0,
  evalsource => 0,
  errors    => !!1,
  warnings  => !!1,
  better_names => !!1,
);
our %ENABLEOPTS = (
  dump => 3,
  source => 3,
  evalsource => 3,
);
our %NUMOPTS = (
  dump => 1,
  source => 1,
  evalsource => 1,
);

our @options = sort keys %OPTIONS;
our ($opt_match) =
  map qr/^-?(?:(no[_-]?)(?:$_)|(?:$_)(?:(\d+)|=(.*)|))$/,
  join '|',
  map {
    my $o = $_;
    $o =~ s/_/[-_]?/g;
    '('.$o.')';
  }
  @options;

sub _parse_options {
  my %opts;
  my @bad;
  while (@_) {
    my $arg = shift;
    my @match = defined $arg ? $arg =~ $opt_match : ();
    if (@match) {
      my $no = shift @match;
      my $equal = pop @match;
      my $num = pop @match;
      my ($opt) =
        map $options[$_ % @options],
        grep defined $match[$_],
        0 .. $#match;
      my $value
        = defined $no       ? !!0
        : defined $equal    ? $equal
        : defined $num      ? $num
        : @_ && (!defined $_[0] || $_[0] =~ /^\d+$/) ? shift
        : defined $ENABLEOPTS{$opt} ? $ENABLEOPTS{$opt}
        : !!1;

      if ($NUMOPTS{$opt}) {
        $value
          = !defined $value ? 0
          : !$value ? 1e10000
          : 0+$value;
      }
      $opts{$opt} = $value;
    }
    else {
      push @bad, $arg;
    }
  }
  if (@bad) {
    local $SIG{__DIE__};
    Carp::croak("invalid options: " . join(', ', map { defined $_ ? $_ : '[undef]' } @bad));
  }
  \%opts;
}

if (my $env = $ENV{DEVEL_CONFESS_OPTIONS}) {
  local $@;
  eval {
    my $options = _parse_options(grep length, split /[\s,]+/, $env);
    @OPTIONS{keys %$options} = values %$options;
    1;
  } or warn "DEVEL_CONFESS_OPTIONS: $@";
}

our %OLD_SIG;

sub import {
  my $class = shift;

  my $options = _parse_options(@_);
  @OPTIONS{keys %$options} = values %$options;

  if (defined $OPTIONS{builtin}) {
    require Devel::Confess::Builtin;
    my $do = $OPTIONS{builtin} ? 'import' : 'unimport';
    Devel::Confess::Builtin->$do;
  }
  if ($OPTIONS{source} || $OPTIONS{evalsource}) {
    require Devel::Confess::Source;
    Devel::Confess::Source->import;
  }
  if ($OPTIONS{color} && $^O eq 'MSWin32') {
    if (eval { require Win32::Console::ANSI }) {
      Win32::Console::ANSI->import;
    }
    else {
      local $SIG{__WARN__};
      Carp::carp
        "Devel::Confess color option requires Win32::Console::ANSI on Windows";
      $OPTIONS{color} = 0;
    }
  }

  if ($OPTIONS{errors} && !$OLD_SIG{__DIE__}) {
    $OLD_SIG{__DIE__} = $SIG{__DIE__}
      if $SIG{__DIE__} && $SIG{__DIE__} ne \&_die;
    $SIG{__DIE__} = \&_die;
  }
  if ($OPTIONS{warnings} && !$OLD_SIG{__WARN__}) {
    $OLD_SIG{__WARN__} = $SIG{__WARN__}
      if $SIG{__WARN__} && $SIG{__WARN__} ne \&_warn;
    $SIG{__WARN__} = \&_warn;
  }

  # enable better names for evals and anon subs
  $^P |= 0x100 | 0x200
    if _CAN_USE_INFORMATIVE_NAMES && $OPTIONS{better_names};
}

sub unimport {
  for my $sig (
    [ __DIE__ => \&_die ],
    [ __WARN__ => \&_warn ],
  ) {
    my ($name, $sub) = @$sig;
    my $now = $SIG{$name} or next;
    my $old = $OLD_SIG{$name};
    if ($now ne $sub && $old) {
      local $SIG{__WARN__};
      warn "Can't restore $name handler!\n";
      delete $SIG{$sig};
    }
    elsif ($old) {
      $SIG{$name} = $old;
      delete $OLD_SIG{$name};
    }
    else {
      no warnings 'uninitialized'; # bogus warnings on perl < 5.8.8
      undef $SIG{$name}
        if _BROKEN_SIG_DELETE;
      delete $SIG{$name};
    }
  }
}

sub _find_sig {
  my $sig = $_[0];
  return undef
    if !defined $sig;
  return $sig
    if ref $sig;
  return undef
    if $sig eq 'DEFAULT' || $sig eq 'IGNORE';
  # this isn't really needed because %SIG entries are always fully qualified
  package #hide
    main;
  no strict 'refs';
  defined &{$sig} ? \&{$sig} : undef;
}

sub _warn {
  local $SIG{__WARN__};
  my @convert = _convert(@_);
  if (my $sig = _find_sig($OLD_SIG{__WARN__})) {
    (\&$sig)->(ref $convert[0] ? $convert[0] : join('', @convert));
  }
  else {
    @convert = _ex_as_strings(@convert);
    @convert = _colorize(33, @convert) if $OPTIONS{color};
    warn @convert;
  }
}
sub _die {
  local $SIG{__DIE__};
  my @convert = _convert(@_);
  if (my $sig = _find_sig($OLD_SIG{__DIE__})) {
    (\&$sig)->(ref $convert[0] ? $convert[0] : join('', @convert));
  }
  @convert = _ex_as_strings(@convert) if _can_stringify;
  @convert = _colorize(31, @convert) if $OPTIONS{color} && _can_stringify;
  if (_DEBUGGING && _in_END) {
    local $SIG{__WARN__};
    warn @convert;
    $! ||= 1;
    return;
  }
  die @convert unless ref $convert[0];
}

sub _colorize {
  my ($color, @convert) = @_;
  if ($OPTIONS{color} eq 'force' || -t *STDERR) {
    if (@convert == 1) {
      $convert[0] = s/(.*)//;
      unshift @convert, $1;
    }
    $convert[0] = "\e[${color}m$convert[0]\e[m";
  }
  return @convert;
}

sub _ref_formatter {
  require Data::Dumper;
  local $SIG{__WARN__} = sub {};
  local $SIG{__DIE__} = sub {};
  no warnings 'once';
  local $Data::Dumper::Indent = 0;
  local $Data::Dumper::Purity = 0;
  local $Data::Dumper::Terse = 1;
  local $Data::Dumper::Useqq = 1;
  local $Data::Dumper::Maxdepth = $OPTIONS{dump} eq 'inf' ? 0 : $OPTIONS{dump};
  Data::Dumper::Dumper($_[0]);
}

sub _stack_trace {
  no warnings 'once';
  local $Carp::RefArgFormatter
    = $OPTIONS{dump} ? \&_ref_formatter : \&_str_val;
  my $message = &longmess;
  $message =~ s/\.?$/./m;
  if ($OPTIONS{source} || $OPTIONS{evalsource}) {
    $message .= Devel::Confess::Source::source_trace(1,
      $OPTIONS{evalsource} ? ($OPTIONS{evalsource}, 1) : $OPTIONS{source});
  }
  $message;
}

# these are package varibles to control their lifetime.  they should not be
# used externally.
our $PACK_SUFFIX = 'A000';

our %EXCEPTIONS;
our %PACKAGES;
our %MESSAGES;
our %CLONED;

sub CLONE {
  my %id_map = map {
    my $ex = $EXCEPTIONS{$_};
    defined $ex ? ($_ => refaddr($ex)) : ();
  } keys %EXCEPTIONS;

  %EXCEPTIONS = map {; $id_map{$_} => $EXCEPTIONS{$_}} keys %id_map;
  %PACKAGES = map {; $id_map{$_} => $PACKAGES{$_}} keys %id_map;
  %MESSAGES = map {; $id_map{$_} => $MESSAGES{$_}} keys %id_map;
  %CLONED = map {; $_ => 1 } values %id_map
    if _BROKEN_CLONED_DESTROY_REBLESS || _BROKEN_CLONED_GLOB_UNDEF;
  weaken($_)
    for values %EXCEPTIONS;
}

sub _update_ex_refs {
  for my $id ( keys %EXCEPTIONS ) {
    next
      if defined $EXCEPTIONS{$id};
    delete $EXCEPTIONS{$id};
    delete $PACKAGES{$id};
    delete $MESSAGES{$id};
    delete $CLONED{$id}
      if _BROKEN_CLONED_DESTROY_REBLESS || _BROKEN_CLONED_GLOB_UNDEF;
  }
}

sub _convert {
  _update_ex_refs;
  if (my $class = blessed(my $ex = $_[0])) {
    return @_
      unless $OPTIONS{objects};
    return @_
      if ! do {no strict 'refs'; defined &{"Devel::Confess::_Attached::DESTROY"} };
    my $message;
    my $id = refaddr($ex);
    if (defined $EXCEPTIONS{$id}) {
      return @_
        if $ex->isa("Devel::Confess::_Attached");

      # something is going very wrong.  possibly from a Safe compartment.
      # we probably broke something, but do the best we can.
      if ((ref $ex) =~ /^Devel::Confess::__ANON_/) {
        my $oldclass = $PACKAGES{$id};
        $message = $MESSAGES{$id};
        bless $ex, $oldclass;
      }
      else {
        # give up
        return @_;
      }
    }

    my $does = _can($ex, 'can') && ($ex->can('does') || $ex->can('DOES')) || sub () { 0 };
    if (
      grep {
        $NoTrace{$_}
        && _can($ex, 'isa')
        && $ex->isa($_)
        || $ex->$does($_)
      } keys %NoTrace
    ) {
      return @_;
    }

    $message ||= _stack_trace();

    weaken($EXCEPTIONS{$id} = $ex);
    $PACKAGES{$id} = $class;
    $MESSAGES{$id} = $message;

    my $newclass = __PACKAGE__ . '::__ANON_' . $PACK_SUFFIX++ . '__';

    {
      no strict 'refs';
      @{$newclass . '::ISA'} = ('Devel::Confess::_Attached', $class);
    }

    bless $ex, $newclass;
    return $ex;
  }
  elsif (ref($ex = $_[0])) {
    my $id = refaddr($ex);

    my $message = _stack_trace;

    weaken($EXCEPTIONS{$id} = $ex);
    $PACKAGES{$id} = undef;
    $MESSAGES{$id} ||= $message;

    return $ex;
  }

  my $out = join('', @_);

  if (caller(1) eq 'Carp') {
    my $long = longmess();
    my $long_trail = $long;
    $long_trail =~ s/.*?\n//;
    $out =~ s/\Q$long\E\z|\Q$long_trail\E\z//
      or $out =~ s/(.*) at .*? line .*?\n\z/$1/;
  }

  my $source_trace;
  $out =~ s/^(={75}\ncontext for .*^={75}\n\z)//ms
    and $source_trace = $1
    if $OPTIONS{source} || $OPTIONS{evalsource};
  my $trace = _stack_trace();
  $trace =~ s/^(.*\n?)//;
  my $where = $1;
  my $new_source_trace;
  $trace =~ s/^(={75}\ncontext for .*^={75}\n\z)//ms
    and $new_source_trace = $1
    if $OPTIONS{source} || $OPTIONS{evalsource};
  my $find = $where;
  $find =~ s/(\.?\n?)\z//;
  my $trace_re = length $trace ? "(?:\Q$trace\E)?" : '';
  $out =~ s/(\Q$find\E(?: during global destruction)?(\.?\n?))$trace_re\z//
    and $where = $1;
  if (defined $source_trace) {
    if (defined $new_source_trace) {
      $new_source_trace =~ s/^={75}\n//;
      $source_trace =~ s/^(([-=])\2{74}\n)(?:\Q$new_source_trace\E)?\z/$1/ms;
    }
    $trace .= $source_trace;
  }
  if (defined $new_source_trace) {
    $trace .= $new_source_trace;
  }
  return ($out, $where . $trace);
}

sub _ex_as_strings {
  my $ex = $_[0];
  return @_
    unless ref $ex;
  my $id = refaddr($ex);
  my $class = $PACKAGES{$id};
  my $message = $MESSAGES{$id};
  my $out;
  if (blessed $ex) {
    my $newclass = ref $ex;
    bless $ex, $class if $class;
    if ($OPTIONS{dump} && !overload::OverloadedStringify($ex)) {
      $out = _ref_formatter($ex);
    }
    else {
      $out = "$ex";
    }
    bless $ex, $newclass if $class;
  }
  elsif ($OPTIONS{dump}) {
    $out = _ref_formatter($ex);
  }
  else {
    $out = "$ex";
  }
  return ($out, $message);
}

{
  package #hide
    Devel::Confess::_Attached;
  use overload
    fallback => 1,
    'bool' => sub {
      my $ex = $_[0];
      my $class = $PACKAGES{Devel::Confess::refaddr($ex)};
      my $newclass = ref $ex;
      bless $ex, $class;
      my $out = !!$ex;
      bless $ex, $newclass;
      return $out;
    },
    '0+' => sub {
      my $ex = $_[0];
      my $class = $PACKAGES{Devel::Confess::refaddr($ex)};
      my $newclass = ref $ex;
      bless $ex, $class;
      my $out = 0+sprintf '%f', $ex;
      bless $ex, $newclass;
      return $out;
    },
    '""' => sub {
      return join('', Devel::Confess::_ex_as_strings(@_));
    },
  ;

  sub DESTROY {
    my $ex = $_[0];
    my $id = Devel::Confess::refaddr($ex);
    my $class = delete $PACKAGES{$id} or return;
    delete $MESSAGES{$id};
    delete $EXCEPTIONS{$id};

    my $newclass = ref $ex;

    my $cloned;
    # delete_package is more complete, but can explode on some perls
    if (Devel::Confess::_BROKEN_CLONED_GLOB_UNDEF && delete $Devel::Confess::CLONED{$id}) {
      $cloned = 1;
      no strict 'refs';
      @{"${newclass}::ISA"} = ();
      my $stash = \%{"${newclass}::"};
      delete @{$stash}{keys %$stash};
    }
    else {
      Symbol::delete_package($newclass);
    }

    if (Devel::Confess::_BROKEN_CLONED_DESTROY_REBLESS && $cloned || delete $Devel::Confess::CLONED{$id}) {
      my $destroy = $class->can('DESTROY') || return;
      goto $destroy;
    }

    bless $ex, $class;

    # after reblessing, perl will re-dispatch to the class's own DESTROY.
    ();
  }
}

1;
__END__