File Coverage

blib/lib/Throw.pm

Criterion	Covered	Total	%
statement	63	96	65.6
branch	35	80	43.7
condition	25	61	40.9
subroutine	10	15	66.6
pod	9	9	100.0
total	142	261	54.4

package Throw;
use strict;
use warnings;
require 5.8.8;
use overload '""' => \&_str, fallback => 1;

=head1 NAME

Throw - Simple exceptions that do the right things in multiple contexts

=cut

our (@EXPORT, $trace, $level, $pretty, $js, $jp) = ('throw');
our $VERSION = '0.12'; #VERSION

sub import {
    no strict 'refs'; ## no critic
    my ($me, $you, $f, $l) = (shift, caller); @_ = @{"$me\::EXPORT"} if !@_;
    defined &{"$me\::$_"} ? *{"$you\::$_"} = \&{"$me\::$_"} : die "Cannot export $_ from $me to $you at $f line $l.\n" for @_;
}

sub throw {
    my $args = ref($_[0]) ? shift() : {%{$_[1]||{}}, error => $_[0]};
    $args->{'trace'} = caller_trace($trace || $args->{'trace'} || 1, $_[2]) if $trace || $args->{'trace'} || @_>2;
    die bless $args, __PACKAGE__;
}

sub new {
    my $class = shift;
    my $args = ref($_[0]) ? shift() : {%{$_[1]||{}}, error => $_[0]};
    $args->{'trace'} = caller_trace($trace || $args->{'trace'} || 1, $_[2]) if $trace || $args->{'trace'} || @_>2;
    return bless $args, $class;
}

sub croak   { my $a = {%{$_[1]||{}}, error => $_[0]};  $a->{'trace'} = caller_trace(1, ($_[2]||0)+1);  die bless $a, __PACKAGE__ }
sub carp    { my $a = {%{$_[1]||{}}, error => $_[0]};  $a->{'trace'} = caller_trace(1, ($_[2]||0)+1); warn bless $a, __PACKAGE__ }
sub confess { my $a = {%{$_[1]||{}}, error => $_[0]};  $a->{'trace'} = caller_trace(2, $_[2]);  die bless $a, __PACKAGE__ }
sub cluck   { my $a = {%{$_[1]||{}}, error => $_[0]};  $a->{'trace'} = caller_trace(2, $_[2]); warn bless $a, __PACKAGE__ }

sub _str {
    my $self = shift;
    my $err  = $self->{'error'} || "Something happened";
    my $p    = defined($pretty) ? $pretty : $self->{'_pretty'};
    local @$self{'error','_pretty'};  delete @$self{'error','_pretty'};
    return "$err\n" if !scalar keys %$self;
    require JSON;
    my $j = $p ? $jp ||= JSON->new->allow_unknown->allow_blessed->utf8->convert_blessed->canonical->pretty
               : $js ||= JSON->new->allow_unknown->allow_blessed->utf8->convert_blessed->canonical;
    return "$err: ".$j->encode({%$self}).($p ? '' : "\n");
}

sub caller_trace {
    my $args = ref($_[0]) ? $_[0] : (!$_[0] || $_[0] !~ /^[123]$/) ? return $_[0]: {verbose => $_[0], level => $_[1]};
    my $i = ($level || $_[1] || $args->{'level'} || 0) + 1;
    return sprintf "Called from %s at %s line %s", (caller $i+1)[3]||'main', map{(my$s=$_)=~s|^(?:.+/)?lib/||;$s} (caller $i)[1,2] if $args->{'verbose'} && $args->{'verbose'} eq '1';
    my ($m1, $m2, $m3, $nv, @trace) = (0, 0, 0, eval {require 5.014} ? ($args->{'verbose'} || '') ne '3' : 1);
    while (1) {
        my ($pkg, $file, $line, $sub, $sargs) = $nv ? ((caller $i++)[0..3], [])
            : do { package DB;  local $DB::args[0] = \$nv; ((caller $i++)[0..3], ($DB::args[0]||'') ne \$nv ? [@DB::args] : []) };
        last if ! $sargs;
        $sub =~ s/.*://; $file =~ s|^(?:.+/)?lib/||;
        next if ($file eq __FILE__) || $args->{'skip'}->{$file} || $args->{'skip'}->{$pkg} || $args->{'skip'}->{$sub};
        splice @$sargs, $args->{'max_args'}, -1, '...' if @$sargs > ($args->{'max_args'} ||= 5);
        my $args = (!@$sargs || $i==2 && $sub eq 'throw') ? ''
            : ' ('.join(', ',map{
                my$d=!defined($_)?'undef':ref($_)||!/\D/?$_:do{(my$c=$_)=~s|([\'/])|\\$1|g;"'$c'"};
                substr($d,0,$args->{'max_arg_len'}||20)
            } @$sargs).')';
        $m1 = length $sub  if length($sub)  > $m1;
        $m2 = length $file if length($file) > $m2;
        $m3 = length $line if length($line) > $m3;
        push @trace, [$sub, $file, $line, $args];
    }
    return join "\n", map {sprintf "%-${m1}s at %-${m2}s line %${m3}s%s", @$_} @trace;
}

sub TO_JSON { return {%{$_[0]}} }

sub classify {
    my ($err, $ref) = @_;
    $ref = {$ref => 1} if ! ref $ref;
    my $type = !ref($err) ? 'undef.flat' : defined($err->{'type'}) ? $err->{'type'} : 'undef.none';
    my @keys = grep {$_ ne 'default'} keys %$ref;
    @keys = sort {length($b) <=> length($a) || $a cmp $b} @keys if @keys > 1;
    foreach my $key (@keys) {
        next if $type !~ /^\Q$key\E\b(?:$|\.)/;
        my $val = $ref->{$key};
        return ref($val) ? $val->($err, $key) : $val;
    }
    return if ! exists $ref->{'default'};
    my $val = $ref->{'default'};
    return ref($val) ? $val->($err, 'default') : $val;
}

1;

__END__