File Coverage

blib/lib/Data/Handle/Exception.pm

Criterion	Covered	Total	%
statement	74	76	97.3
branch	10	16	62.5
condition			n/a
subroutine	13	13	100.0
pod	3	3	100.0
total	100	108	92.5

use strict;
use warnings;

package Data::Handle::Exception;
BEGIN {
  $Data::Handle::Exception::AUTHORITY = 'cpan:KENTNL';
}
{
  $Data::Handle::Exception::VERSION = '0.02001003';
}

# ABSTRACT: Super-light Weight Dependency Free Exception base.



use overload '""' => \&stringify;
use Scalar::Util qw( blessed );
use Carp 1.22;
use Term::ANSIColor qw( :constants );

if ( not defined &Carp::caller_info ) {
  Carp::croak(q{Cannot load Data::Handle::Exception as your version of Carp does not have ::caller_info which we use for backtraces, Carp Version: } .
    $Carp::VERSION );
}



sub new {
  my ($class) = @_;
  my $self = {};
  bless $self, $class;
  return $self;
}



sub throw {
  my $self = shift;

  if ( not blessed $self ) {
    $self = $self->new();
  }
  my $message = shift;

  my @stack      = ();
  my @stacklines = ();

  # This is mostly because want to benefit from all new fixes in carp.
  my $callerinfo = \&Carp::caller_info;
  {    # stolen parts  from Carp::ret_backtrace
    my ($i) = 0;

    my $tid_msg = q{};
    if ( defined &threads::tid ) {
      my $tid = threads->tid;
      $tid_msg = " thread $tid" if $tid;
    }

    my %i = $callerinfo->($i);

    push @stack, \%i;
    push @stacklines, sprintf q{Exception '%s' thrown at %s line %s%s}, blessed($self), $i{file}, $i{line}, $tid_msg;

    while ( my %j = $callerinfo->( ++$i ) ) {
      push @stack, \%j;
      push @stacklines, sprintf q{%s called at %s line %s%s}, $j{sub_name}, $j{file}, $j{line}, $tid_msg;
    }
  }
  $self->{message}    = $message;
  $self->{stacklines} = \@stacklines;
  $self->{stack}      = \@stack;
  Carp::confess($self);
}

{
  ## no critic ( RequireInterpolationOfMetachars )
  my $s = q{(\x2F|\x5c)};
  my $d = q{\x2E};
  ## use critic
  my $yellow = qr{
      ${s}Try${s}Tiny${d}pm
      |
      ${s}Test${s}Fatal${d}pm
  }x;
  my $green = qr{
    ${s}Data${s}Handle${d}pm
    |
    ${s}Data${s}Handle${s}
  }x;

  sub _color_for_line {
    my $line = shift;
    return YELLOW if ( $line =~ $yellow );
    return GREEN  if ( $line =~ $green );
    return q{};
  }
}


sub stringify {
  ## no critic ( ProhibitPunctuationVars )
  local $@ = undef;  # Term::ANSIColour clobbers $@
  my $self       = shift;
  my $message    = $self->{message};
  my @stacklines = @{ $self->{stacklines} };

  my $out       = $message . "\n\n";
  my $throwline = shift @stacklines;
  $out .= _color_for_line($throwline) . $throwline . RESET;
  my $i = 2;
  for (@stacklines) {
    $out .= "\n " . _color_for_line($_) . "$i.  " . $_ . RESET;
    $i++;
  }
  return $out . "\n\n";
}
my $dynaexceptions = { 'Data::Handle::Exception' => 1 };

sub _gen {
  my ( $self, $fullclass, $parent ) = @_;
  ## no critic ( RequireInterpolationOfMetachars )
  my $code = sprintf q{package %s; our @ISA=("%s"); 1;}, $fullclass, $parent;

  ## no critic ( ProhibitStringyEval RequireCarping ProhibitPunctuationVars )
  eval $code or throw(qq{ Exception generating exception :[ $@ });
  $dynaexceptions->{$fullclass} = 1;
  return 1;
}

sub _gen_tree {
  my ( $self, $class ) = @_;
  my $parent = $class;

  $parent =~ s{
     ::[^:]+$
    }{}x;
  if ( !exists $dynaexceptions->{$parent} ) {
    $self->_gen_tree($parent);
  }
  if ( !exists $dynaexceptions->{$class} ) {
    $self->_gen( $class, $parent );
  }
  return $class;
}

for (qw( API::Invalid API::Invalid::Whence API::Invalid::Params API::NotImplemented Internal::BadGet NoSymbol BadFilePos )) {
  __PACKAGE__->_gen_tree("Data::Handle::Exception::$_");
}

1;

__END__