File Coverage

blib/lib/Exception/Sink.pm
Criterion Covered Total %
statement 9 68 13.2
branch 0 42 0.0
condition 0 3 0.0
subroutine 3 9 33.3
pod 6 6 100.0
total 18 128 14.0


line stmt bran cond sub pod time code
1             ##############################################################################
2             #
3             # Exception::Sink
4             # (c) Vladi Belperchinov-Shabanski "Cade" 2006-2013
5             #
6             # http://cade.datamax.bg
7             #
8             ##############################################################################
9             #
10             # compact general purpose exception handling
11             #
12             ##############################################################################
13             package Exception::Sink;
14 1     1   23314 use Exporter;
  1         2  
  1         93  
15             our @ISA = qw( Exporter );
16             our @EXPORT = qw(
17             sink
18             dive
19             surface
20             surface2
21             boom
22             );
23              
24             our @EXPORT_OK = qw(
25             $DEBUG_SINK
26             get_stack_trace
27             );
28            
29             our %EXPORT_TAGS = ( 'none' => [ ] );
30             our $VERSION = '3.07';
31 1     1   306 use Exception::Sink::Class;
  1         2  
  1         18  
32 1     1   3 use strict;
  1         1  
  1         786  
33              
34             our $DEBUG_SINK = 0;
35              
36             sub sink($);
37             sub dive();
38             sub surface(@);
39              
40             sub boom($);
41              
42             ##############################################################################
43             #
44             # sink( "CLASS: ID: message..." )
45             # sinks the ship of class and id with reason message
46             #
47              
48             sub sink($)
49             {
50 0     0 1   my $msg = shift;
51              
52 0           my $org = $msg;
53              
54 0           my $class = 'UNKNOWN';
55 0           my $id = 'UNKNOWN';
56              
57 0 0 0       $class = $1 || $2 if $msg =~ s/^([a-z0-9_]+)\s*:\s*|^([a-z0-9_]+)$//i;
58 0 0         $id = $1 if $msg =~ s/^([a-z0-9_]+)\s*:\s*|^([a-z0-9_]+)$//i;
59              
60 0           $msg =~ s/\s+at\s+\/\S+.+$//;
61 0           chomp( $msg );
62              
63 0           my ( $p, $f, $l ) = caller();
64 0           $f =~ s/^(.*\/)([^\/]+)$/$2/;
65              
66 0           $class = uc $class;
67              
68 0 0         print STDERR "sink: $class ($f:$l)\n" if $DEBUG_SINK;
69              
70 0           die Exception::Sink::Class->new(
71             'CLASS' => $class,
72             'ID' => $id,
73             'MSG' => $msg,
74             'PACKAGE' => $p,
75             'FILE' => $f,
76             'LINE' => $l,
77             'ORG' => $org,
78             );
79             }
80              
81             ##############################################################################
82             #
83             # dive()
84             # continue sinking...
85             #
86              
87             sub dive()
88             {
89 0 0   0 1   print STDERR "dive: pre: $@\n" if $DEBUG_SINK;
90 0 0         return 0 unless $@;
91 0 0         if( !ref($@) )
92             {
93 0 0         print STDERR "dive: non-ship, resink: $@\n" if $DEBUG_SINK;
94             # re-sink, non-ship
95 0           my $AT=$@;
96 0           eval { sink "SINK: $AT"; }
  0            
97             };
98              
99 0 0         print STDERR "dive: $@->{CLASS}\n" if $DEBUG_SINK;
100              
101 0           die; # propagate
102             }
103              
104             ##############################################################################
105             #
106             # surface( class list )
107             # stops sinking of specific classes...
108             #
109              
110             sub surface(@)
111             {
112 0 0   0 1   print STDERR "surface: enter: $@ -> @_\n" if $DEBUG_SINK;
113 0 0         return 0 unless $@;
114 0 0         return 1 unless @_; # catch all
115 0 0         if( !ref($@) )
116             {
117 0 0         print STDERR "surface: non-ship, resink: $@\n" if $DEBUG_SINK;
118             # re-sink, non-ship
119 0           my $AT=$@;
120 0 0         if( $AT =~ /^[A-Z0-9_]+\:/ )
121             {
122 0           eval { sink $AT; }
  0            
123             }
124             else
125             {
126 0           eval { sink "SINK: $AT"; }
  0            
127             }
128             };
129              
130 0 0         print STDERR "surface: $@->{CLASS} -> @_?\n" if $DEBUG_SINK;
131              
132 0           for my $class ( @_ )
133             {
134 0 0         return 1 if $class eq '*';
135 0 0         return 1 if uc $class eq $@->{ 'CLASS' };
136             }
137 0 0         print STDERR "surface: $@->{CLASS} -> continuing...\n" if $DEBUG_SINK;
138 0           return 0;
139             }
140              
141             sub surface2(@)
142             {
143 0 0   0 1   return 1 if surface(@_);
144 0           dive();
145 0           return 0;
146             }
147              
148             ##############################################################################
149             #
150             # boom()
151             # sink with stack trace
152             #
153              
154             sub boom($)
155             {
156 0     0 1   my $msg = shift;
157 0           chomp( $msg );
158 0           $msg = "BOOM: [$$] $msg\n";
159 0           sink( join '', ( $msg, get_stack_trace() ) );
160             }
161              
162             sub get_stack_trace
163             {
164 0     0 1   my @st;
165             my $i;
166 0           my $ml;
167            
168 0           $i = 1; # skip get_stack_trace
169 0           while ( my ( $pack, $file, $line, $subname ) = caller($i++) )
170             {
171 0           my $l = length( "$pack::$subname" );
172 0 0         $ml = $l if $l > $ml;
173             }
174            
175 0           $i = 1; # skip get_stack_trace
176 0           while ( my ( $pack, $file, $line, $subname ) = caller($i++) )
177             {
178 0           my $ii = $i - 1;
179 0           my $l = length( "$pack::$subname" );
180 0           my $pad = ' ' x ( $ml - $l );
181 0           push @st, " [$$] $ii: $pack::$subname $pad $file line $line\n";
182             }
183            
184             #die( @st );
185 0 0         return wantarray ? @st : join( '', @st );
186             }
187              
188             ##############################################################################
189             1;
190             ##############################################################################
191              
192             __END__