File Coverage

blib/lib/Throw.pm
Criterion Covered Total %
statement 63 96 65.6
branch 35 80 43.7
condition 23 61 37.7
subroutine 10 15 66.6
pod 9 9 100.0
total 140 261 53.6


line stmt bran cond sub pod time code
1             package Throw;
2 3     3   24368 use strict;
  3         3  
  3         79  
3 3     3   14 use warnings;
  3         4  
  3         152  
4             require 5.8.8;
5 3     3   3391 use overload '""' => \&_str, fallback => 1;
  3         2346  
  3         27  
6              
7             =head1 NAME
8              
9             Throw - Simple exceptions that do the right things in multiple contexts
10              
11             =cut
12              
13             our (@EXPORT, $trace, $level, $pretty, $js, $jp) = ('throw');
14             our $VERSION = '0.13'; #VERSION
15              
16             sub import {
17 3     3   384 no strict 'refs'; ## no critic
  3         6  
  3         5377  
18 3 100   3   27 my ($me, $you, $f, $l) = (shift, caller); @_ = @{"$me\::EXPORT"} if !@_;
  3         15  
  2         9  
19 3 50       9 defined &{"$me\::$_"} ? *{"$you\::$_"} = \&{"$me\::$_"} : die "Cannot export $_ from $me to $you at $f line $l.\n" for @_;
  6         29  
  6         1892  
  6         18  
20             }
21              
22             sub throw {
23 6 100   6 1 3310 my $args = ref($_[0]) ? shift() : {%{$_[1]||{}}, error => $_[0]};
  6 50       39  
24 6 100 50     55 $args->{'trace'} = caller_trace($trace || $args->{'trace'} || 1, $_[2]) if $trace || $args->{'trace'} || @_>2;
      33        
      66        
25 6         32 die bless $args, __PACKAGE__;
26             }
27              
28             sub new {
29 0     0 1 0 my $class = shift;
30 0 0       0 my $args = ref($_[0]) ? shift() : {%{$_[1]||{}}, error => $_[0]};
  0 0       0  
31 0 0 0     0 $args->{'trace'} = caller_trace($trace || $args->{'trace'} || 1, $_[2]) if $trace || $args->{'trace'} || @_>2;
      0        
      0        
32 0         0 return bless $args, $class;
33             }
34              
35 1 50 50 1 1 7 sub croak { my $a = {%{$_[1]||{}}, error => $_[0]}; $a->{'trace'} = caller_trace(1, ($_[2]||0)+1); die bless $a, __PACKAGE__ }
  1         12  
  1         11  
  1         9  
36 0 0 0 0 1 0 sub carp { my $a = {%{$_[1]||{}}, error => $_[0]}; $a->{'trace'} = caller_trace(1, ($_[2]||0)+1); warn bless $a, __PACKAGE__ }
  0         0  
  0         0  
  0         0  
37 1 50   1 1 2 sub confess { my $a = {%{$_[1]||{}}, error => $_[0]}; $a->{'trace'} = caller_trace(2, $_[2]); die bless $a, __PACKAGE__ }
  1         8  
  1         5  
  1         6  
38 0 0   0 1 0 sub cluck { my $a = {%{$_[1]||{}}, error => $_[0]}; $a->{'trace'} = caller_trace(2, $_[2]); warn bless $a, __PACKAGE__ }
  0         0  
  0         0  
  0         0  
39              
40             sub _str {
41 4     4   916 my $self = shift;
42 4   50     17 my $err = $self->{'error'} || "Something happened";
43 4 50       11 my $p = defined($pretty) ? $pretty : $self->{'_pretty'};
44 4         13 local @$self{'error','_pretty'}; delete @$self{'error','_pretty'};
  4         12  
45 4 100       20 return "$err\n" if !scalar keys %$self;
46 2         10 require JSON;
47 2 50 0     38 my $j = $p ? $jp ||= JSON->new->allow_unknown->allow_blessed->utf8->convert_blessed->canonical->pretty
      66        
48             : $js ||= JSON->new->allow_unknown->allow_blessed->utf8->convert_blessed->canonical;
49 2 50       43 return "$err: ".$j->encode({%$self}).($p ? '' : "\n");
50             }
51              
52             sub caller_trace {
53 5 50 33 5 1 54 my $args = ref($_[0]) ? $_[0] : (!$_[0] || $_[0] !~ /^[123]$/) ? return $_[0]: {verbose => $_[0], level => $_[1]};
    50          
54 5   50     41 my $i = ($level || $_[1] || $args->{'level'} || 0) + 1;
55 5 100 100     47 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';
  4   66     10  
  4         20  
56 3 50 50     6 my ($m1, $m2, $m3, $nv, @trace) = (0, 0, 0, eval {require 5.014} ? ($args->{'verbose'} || '') ne '3' : 1);
  3         71  
57 3         8 while (1) {
58             my ($pkg, $file, $line, $sub, $sargs) = $nv ? ((caller $i++)[0..3], [])
59 9 100 50     38 : do { package DB; local $DB::args[0] = \$nv; ((caller $i++)[0..3], ($DB::args[0]||'') ne \$nv ? [@DB::args] : []) };
  3 100       6  
  3         0  
60 9 100       26 last if ! $sargs;
61 6         20 $sub =~ s/.*://; $file =~ s|^(?:.+/)?lib/||;
  6         9  
62 6 50 33     54 next if ($file eq __FILE__) || $args->{'skip'}->{$file} || $args->{'skip'}->{$pkg} || $args->{'skip'}->{$sub};
      33        
      33        
63 6 50 100     30 splice @$sargs, $args->{'max_args'}, -1, '...' if @$sargs > ($args->{'max_args'} ||= 5);
64             my $args = (!@$sargs || $i==2 && $sub eq 'throw') ? ''
65             : ' ('.join(', ',map{
66 6 0 66     30 my$d=!defined($_)?'undef':ref($_)||!/\D/?$_:do{(my$c=$_)=~s|([\'/])|\\$1|g;"'$c'"};
  0 0 0     0  
  0 50       0  
  0         0  
67 0   0     0 substr($d,0,$args->{'max_arg_len'}||20)
68             } @$sargs).')';
69 6 100       15 $m1 = length $sub if length($sub) > $m1;
70 6 100       15 $m2 = length $file if length($file) > $m2;
71 6 100       15 $m3 = length $line if length($line) > $m3;
72 6         22 push @trace, [$sub, $file, $line, $args];
73             }
74 3         19 return join "\n", map {sprintf "%-${m1}s at %-${m2}s line %${m3}s%s", @$_} @trace;
  6         44  
75             }
76              
77 0     0 1   sub TO_JSON { return {%{$_[0]}} }
  0            
78              
79             sub classify {
80 0     0 1   my ($err, $ref) = @_;
81 0 0         $ref = {$ref => 1} if ! ref $ref;
82 0 0         my $type = !ref($err) ? 'undef.flat' : defined($err->{'type'}) ? $err->{'type'} : 'undef.none';
    0          
83 0           my @keys = grep {$_ ne 'default'} keys %$ref;
  0            
84 0 0         @keys = sort {length($b) <=> length($a) || $a cmp $b} @keys if @keys > 1;
  0 0          
85 0           foreach my $key (@keys) {
86 0 0         next if $type !~ /^\Q$key\E\b(?:$|\.)/;
87 0           my $val = $ref->{$key};
88 0 0         return ref($val) ? $val->($err, $key) : $val;
89             }
90 0 0         return if ! exists $ref->{'default'};
91 0           my $val = $ref->{'default'};
92 0 0         return ref($val) ? $val->($err, 'default') : $val;
93             }
94              
95             1;
96              
97             __END__