view release on metacpan or  search on metacpan

lib/Devel/Confess.pm  view on Meta::CPAN

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.009004';
$VERSION = eval $VERSION;

use Carp ();
use Symbol ();
use Devel::Confess::_Util qw(
  blessed
  refaddr
  weaken
  longmess
  _str_val
  _in_END
  _can_stringify
  _can
  _isa
);
use Config ();
BEGIN {
  *_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 };
  my $inf = 9**9**9;
  *_INF = sub () { $inf }
}

$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;

lib/Devel/Confess.pm  view on Meta::CPAN

}

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} == _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 _isa($ex, "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 {