File Coverage

blib/lib/Error.pm
Criterion Covered Total %
statement 201 249 80.7
branch 63 112 56.2
condition 16 28 57.1
subroutine 33 38 86.8
pod 17 17 100.0
total 330 444 74.3


line stmt bran cond sub pod time code
1             # Error.pm
2             #
3             # Copyright (c) 1997-8 Graham Barr . All rights reserved.
4             # This program is free software; you can redistribute it and/or
5             # modify it under the same terms as Perl itself.
6             #
7             # Based on my original Error.pm, and Exceptions.pm by Peter Seibel
8             # and adapted by Jesse Glick .
9             #
10             # but modified ***significantly***
11              
12             package Error;
13             $Error::VERSION = '0.17029';
14 24     24   967870 use strict;
  24         211  
  24         677  
15 24     24   110 use warnings;
  24         44  
  24         549  
16              
17 24     24   476 use 5.004;
  24         74  
18              
19             use overload (
20             '""' => 'stringify',
21             '0+' => 'value',
22 34     34   90 'bool' => sub { return 1; },
23 24         190 'fallback' => 1
24 24     24   26149 );
  24         21869  
25              
26             $Error::Depth = 0; # Depth to pass to caller()
27             $Error::Debug = 0; # Generate verbose stack traces
28             @Error::STACK = (); # Clause stack for try
29             $Error::THROWN = undef; # last error thrown, a workaround until die $ref works
30              
31             my $LAST; # Last error created
32             my %ERROR; # Last error associated with package
33              
34             sub _throw_Error_Simple
35             {
36 12     12   20 my $args = shift;
37 12         36 return Error::Simple->new( $args->{'text'} );
38             }
39              
40             $Error::ObjectifyCallback = \&_throw_Error_Simple;
41              
42             # Exported subs are defined in Error::subs
43              
44 24     24   4344 use Scalar::Util ();
  24         48  
  24         31257  
45              
46             sub import
47             {
48 28     28   7081130 shift;
49 28         99 my @tags = @_;
50 28         83 local $Exporter::ExportLevel = $Exporter::ExportLevel + 1;
51              
52             @tags = grep {
53 28 100       67 if ( $_ eq ':warndie' )
  26         87  
54             {
55 14         93 Error::WarnDie->import();
56 14         42 0;
57             }
58             else
59             {
60 12         32 1;
61             }
62             } @tags;
63              
64 28         37281 Error::subs->import(@tags);
65             }
66              
67             # I really want to use last for the name of this method, but it is a keyword
68             # which prevent the syntax last Error
69              
70             sub prior
71             {
72 1     1 1 2 shift; # ignore
73              
74 1 50       5 return $LAST unless @_;
75              
76 0         0 my $pkg = shift;
77 0 0       0 return exists $ERROR{$pkg} ? $ERROR{$pkg} : undef
    0          
78             unless ref($pkg);
79              
80 0         0 my $obj = $pkg;
81 0         0 my $err = undef;
82 0 0       0 if ( $obj->isa('HASH') )
    0          
83             {
84             $err = $obj->{'__Error__'}
85 0 0       0 if exists $obj->{'__Error__'};
86             }
87             elsif ( $obj->isa('GLOB') )
88             {
89 0         0 $err = ${*$obj}{'__Error__'}
90 0 0       0 if exists ${*$obj}{'__Error__'};
  0         0  
91             }
92              
93 0         0 $err;
94             }
95              
96             sub flush
97             {
98 0     0 1 0 shift; #ignore
99              
100 0 0       0 unless (@_)
101             {
102 0         0 $LAST = undef;
103 0         0 return;
104             }
105              
106 0         0 my $pkg = shift;
107 0 0       0 return unless ref($pkg);
108              
109 0 0       0 undef $ERROR{$pkg} if defined $ERROR{$pkg};
110             }
111              
112             # Return as much information as possible about where the error
113             # happened. The -stacktrace element only exists if $Error::DEBUG
114             # was set when the error was created
115              
116             sub stacktrace
117             {
118 1     1 1 3 my $self = shift;
119              
120             return $self->{'-stacktrace'}
121 1 50       27 if exists $self->{'-stacktrace'};
122              
123 0 0       0 my $text = exists $self->{'-text'} ? $self->{'-text'} : "Died";
124              
125 0 0       0 $text .= sprintf( " at %s line %d.\n", $self->file, $self->line )
126             unless ( $text =~ /\n$/s );
127              
128 0         0 $text;
129             }
130              
131             sub associate
132             {
133 0     0 1 0 my $err = shift;
134 0         0 my $obj = shift;
135              
136 0 0       0 return unless ref($obj);
137              
138 0 0       0 if ( $obj->isa('HASH') )
    0          
139             {
140 0         0 $obj->{'__Error__'} = $err;
141             }
142             elsif ( $obj->isa('GLOB') )
143             {
144 0         0 ${*$obj}{'__Error__'} = $err;
  0         0  
145             }
146 0         0 $obj = ref($obj);
147 0         0 $ERROR{ ref($obj) } = $err;
148              
149 0         0 return;
150             }
151              
152             sub new
153             {
154 25     25 1 62 my $self = shift;
155 25         191 my ( $pkg, $file, $line ) = caller($Error::Depth);
156              
157 25         160 my $err = bless {
158             '-package' => $pkg,
159             '-file' => $file,
160             '-line' => $line,
161             @_
162             }, $self;
163              
164             $err->associate( $err->{'-object'} )
165 25 50       495 if ( exists $err->{'-object'} );
166              
167             # To always create a stacktrace would be very inefficient, so
168             # we only do it if $Error::Debug is set
169              
170 25 100       88 if ($Error::Debug)
171             {
172 1         41 require Carp;
173 1         14 local $Carp::CarpLevel = $Error::Depth;
174 1 50       22 my $text = defined( $err->{'-text'} ) ? $err->{'-text'} : "Error";
175 1         756 my $trace = Carp::longmess($text);
176              
177             # Remove try calls from the trace
178 1         58 $trace =~
179             s/(\n\s+\S+__ANON__[^\n]+)?\n\s+eval[^\n]+\n\s+Error::subs::try[^\n]+(?=\n)//sog;
180 1         4 $trace =~
181             s/(\n\s+\S+__ANON__[^\n]+)?\n\s+eval[^\n]+\n\s+Error::subs::run_clauses[^\n]+\n\s+Error::subs::try[^\n]+(?=\n)//sog;
182 1         15 $err->{'-stacktrace'} = $trace;
183             }
184              
185 25         110 $@ = $LAST = $ERROR{$pkg} = $err;
186             }
187              
188             # Throw an error. this contains some very gory code.
189              
190             sub throw
191             {
192 23     23 1 1438115 my $self = shift;
193 23         64 local $Error::Depth = $Error::Depth + 1;
194              
195             # if we are not rethrow-ing then create the object to throw
196 23 100       137 $self = $self->new(@_) unless ref($self);
197              
198 23         112 die $Error::THROWN = $self;
199             }
200              
201             # syntactic sugar for
202             #
203             # die with Error( ... );
204              
205             sub with
206             {
207 0     0 1 0 my $self = shift;
208 0         0 local $Error::Depth = $Error::Depth + 1;
209              
210 0         0 $self->new(@_);
211             }
212              
213             # syntactic sugar for
214             #
215             # record Error( ... ) and return;
216              
217             sub record
218             {
219 0     0 1 0 my $self = shift;
220 0         0 local $Error::Depth = $Error::Depth + 1;
221              
222 0         0 $self->new(@_);
223             }
224              
225             # catch clause for
226             #
227             # try { ... } catch CLASS with { ... }
228              
229             sub catch
230             {
231 16     16 1 35 my $pkg = shift;
232 16         23 my $code = shift;
233 16   100     61 my $clauses = shift || {};
234 16   100     66 my $catch = $clauses->{'catch'} ||= [];
235              
236 16         41 unshift @$catch, $pkg, $code;
237              
238 16         57 $clauses;
239             }
240              
241             # Object query methods
242              
243             sub object
244             {
245 0     0 1 0 my $self = shift;
246 0 0       0 exists $self->{'-object'} ? $self->{'-object'} : undef;
247             }
248              
249             sub file
250             {
251 11     11 1 15 my $self = shift;
252 11 50       52 exists $self->{'-file'} ? $self->{'-file'} : undef;
253             }
254              
255             sub line
256             {
257 11     11 1 15 my $self = shift;
258 11 50       58 exists $self->{'-line'} ? $self->{'-line'} : undef;
259             }
260              
261             sub text
262             {
263 1     1 1 3 my $self = shift;
264 1 50       11 exists $self->{'-text'} ? $self->{'-text'} : undef;
265             }
266              
267             # overload methods
268              
269             sub stringify
270             {
271 12     12 1 18 my $self = shift;
272 12 50       34 defined $self->{'-text'} ? $self->{'-text'} : "Died";
273             }
274              
275             sub value
276             {
277 3     3 1 17 my $self = shift;
278 3 50       13 exists $self->{'-value'} ? $self->{'-value'} : undef;
279             }
280              
281             package Error::Simple;
282             $Error::Simple::VERSION = '0.17029';
283             @Error::Simple::ISA = qw(Error);
284              
285             sub new
286             {
287 22     22 1 38 my $self = shift;
288 22         50 my $text = "" . shift;
289 22         28 my $value = shift;
290 22         34 my (@args) = ();
291              
292 22         32 local $Error::Depth = $Error::Depth + 1;
293              
294 22 100       191 @args = ( -file => $1, -line => $2 )
295             if ( $text =~
296             s/\s+at\s+(\S+)\s+line\s+(\d+)(?:,\s*<[^>]*>\s+line\s+\d+)?\.?\n?$//s );
297 22 100       55 push( @args, '-value', 0 + $value )
298             if defined($value);
299              
300 22         85 $self->SUPER::new( -text => $text, @args );
301             }
302              
303             sub stringify
304             {
305 12     12 1 59 my $self = shift;
306 12         35 my $text = $self->SUPER::stringify;
307 12 100       51 $text .= sprintf( " at %s line %d.\n", $self->file, $self->line )
308             unless ( $text =~ /\n$/s );
309 12         72 $text;
310             }
311              
312             ##########################################################################
313             ##########################################################################
314              
315             # Inspired by code from Jesse Glick and
316             # Peter Seibel
317              
318             package Error::subs;
319             $Error::subs::VERSION = '0.17029';
320 24     24   214 use Exporter ();
  24         57  
  24         752  
321 24     24   146 use vars qw(@EXPORT_OK @ISA %EXPORT_TAGS);
  24         32  
  24         41282  
322              
323             @EXPORT_OK = qw(try with finally except otherwise);
324             %EXPORT_TAGS = ( try => \@EXPORT_OK );
325              
326             @ISA = qw(Exporter);
327              
328             sub run_clauses ($$$\@)
329             {
330 23     23   55 my ( $clauses, $err, $wantarray, $result ) = @_;
331 23         31 my $code = undef;
332              
333 23 100       70 $err = $Error::ObjectifyCallback->( { 'text' => $err } ) unless ref($err);
334              
335             CATCH:
336             {
337              
338             # catch
339 23         39 my $catch;
  23         28  
340 23 100       70 if ( defined( $catch = $clauses->{'catch'} ) )
341             {
342 14         23 my $i = 0;
343              
344             CATCHLOOP:
345 14         39 for ( ; $i < @$catch ; $i += 2 )
346             {
347 16         36 my $pkg = $catch->[$i];
348 16 100 66     183 unless ( defined $pkg )
349             {
350             #except
351 1         3 splice( @$catch, $i, 2, $catch->[ $i + 1 ]->($err) );
352 1         6 $i -= 2;
353 1         3 next CATCHLOOP;
354             }
355             elsif ( Scalar::Util::blessed($err) && $err->isa($pkg) )
356             {
357             $code = $catch->[ $i + 1 ];
358             while (1)
359             {
360             my $more = 0;
361             local ( $Error::THROWN, $@ );
362             my $ok = eval {
363             $@ = $err;
364             if ($wantarray)
365             {
366             @{$result} = $code->( $err, \$more );
367             }
368             elsif ( defined($wantarray) )
369             {
370             @{$result} = ();
371             $result->[0] = $code->( $err, \$more );
372             }
373             else
374             {
375             $code->( $err, \$more );
376             }
377             1;
378             };
379             if ($ok)
380             {
381             next CATCHLOOP if $more;
382             undef $err;
383             }
384             else
385             {
386             $err = $@ || $Error::THROWN;
387             $err = $Error::ObjectifyCallback->(
388             { 'text' => $err } )
389             unless ref($err);
390             }
391             last CATCH;
392             }
393             }
394             }
395             }
396              
397             # otherwise
398 13         21 my $owise;
399 13 100       40 if ( defined( $owise = $clauses->{'otherwise'} ) )
400             {
401 8         11 my $code = $clauses->{'otherwise'};
402 8         13 my $more = 0;
403 8         12 local ( $Error::THROWN, $@ );
404 8         11 my $ok = eval {
405 8         11 $@ = $err;
406 8 50       21 if ($wantarray)
    50          
407             {
408 0         0 @{$result} = $code->( $err, \$more );
  0         0  
409             }
410             elsif ( defined($wantarray) )
411             {
412 0         0 @{$result} = ();
  0         0  
413 0         0 $result->[0] = $code->( $err, \$more );
414             }
415             else
416             {
417 8         19 $code->( $err, \$more );
418             }
419 6         1957 1;
420             };
421 8 100       28 if ($ok)
422             {
423 6         13 undef $err;
424             }
425             else
426             {
427 2   33     8 $err = $@ || $Error::THROWN;
428              
429 2 50       8 $err = $Error::ObjectifyCallback->( { 'text' => $err } )
430             unless ref($err);
431             }
432             }
433             }
434 23         48 $err;
435             }
436              
437             sub try (&;$)
438             {
439 25     25   53 my $try = shift;
440 25 100       60 my $clauses = @_ ? shift : {};
441 25         36 my $ok = 0;
442 25         32 my $err = undef;
443 25         38 my @result = ();
444              
445 25         58 unshift @Error::STACK, $clauses;
446              
447 25         37 my $wantarray = wantarray();
448              
449             do
450 25         32 {
451 25         36 local $Error::THROWN = undef;
452 25         31 local $@ = undef;
453              
454 25         39 $ok = eval {
455 25 50       69 if ($wantarray)
    100          
456             {
457 0         0 @result = $try->();
458             }
459             elsif ( defined $wantarray )
460             {
461 3         6 $result[0] = $try->();
462             }
463             else
464             {
465 22         54 $try->();
466             }
467 2         7 1;
468             };
469              
470 25 100 33     243 $err = $@ || $Error::THROWN
471             unless $ok;
472             };
473              
474 25         41 shift @Error::STACK;
475              
476 25 100       85 $err = run_clauses( $clauses, $err, wantarray, @result )
477             unless ($ok);
478              
479             $clauses->{'finally'}->()
480 25 100       71 if ( defined( $clauses->{'finally'} ) );
481              
482 25 100       60 if ( defined($err) )
483             {
484 12 100 66     87 if ( Scalar::Util::blessed($err) && $err->can('throw') )
485             {
486 11         21 throw $err;
487             }
488             else
489             {
490 1         4 die $err;
491             }
492             }
493              
494 13 50       149 wantarray ? @result : $result[0];
495             }
496              
497             # Each clause adds a sub to the list of clauses. The finally clause is
498             # always the last, and the otherwise clause is always added just before
499             # the finally clause.
500             #
501             # All clauses, except the finally clause, add a sub which takes one argument
502             # this argument will be the error being thrown. The sub will return a code ref
503             # if that clause can handle that error, otherwise undef is returned.
504             #
505             # The otherwise clause adds a sub which unconditionally returns the users
506             # code reference, this is why it is forced to be last.
507             #
508             # The catch clause is defined in Error.pm, as the syntax causes it to
509             # be called as a method
510              
511             sub with (&;$)
512             {
513 16     16   1095 @_;
514             }
515              
516             sub finally (&)
517             {
518 3     3   31 my $code = shift;
519 3         7 my $clauses = { 'finally' => $code };
520 3         10 $clauses;
521             }
522              
523             # The except clause is a block which returns a hashref or a list of
524             # key-value pairs, where the keys are the classes and the values are subs.
525              
526             sub except (&;$)
527             {
528 1     1   81 my $code = shift;
529 1   50     6 my $clauses = shift || {};
530 1   50     6 my $catch = $clauses->{'catch'} ||= [];
531              
532             my $sub = sub {
533 1     1   1 my $ref;
534 1         4 my (@array) = $code->( $_[0] );
535 1 50 33     11 if ( @array == 1 && ref( $array[0] ) )
536             {
537 1         2 $ref = $array[0];
538 1 50       6 $ref = [%$ref]
539             if ( UNIVERSAL::isa( $ref, 'HASH' ) );
540             }
541             else
542             {
543 0         0 $ref = \@array;
544             }
545 1         4 @$ref;
546 1         4 };
547              
548 1         3 unshift @{$catch}, undef, $sub;
  1         2  
549              
550 1         3 $clauses;
551             }
552              
553             sub otherwise (&;$)
554             {
555 10     10   276 my $code = shift;
556 10   50     43 my $clauses = shift || {};
557              
558 10 50       25 if ( exists $clauses->{'otherwise'} )
559             {
560 0         0 require Carp;
561 0         0 Carp::croak("Multiple otherwise clauses");
562             }
563              
564 10         18 $clauses->{'otherwise'} = $code;
565              
566 10         31 $clauses;
567             }
568              
569             1;
570              
571             package Error::WarnDie;
572             $Error::WarnDie::VERSION = '0.17029';
573             sub gen_callstack($)
574             {
575 6     6   77 my ($start) = @_;
576              
577 6         316 require Carp;
578 6         135 local $Carp::CarpLevel = $start;
579 6         5135 my $trace = Carp::longmess("");
580              
581             # Remove try calls from the trace
582 6         290 $trace =~
583             s/(\n\s+\S+__ANON__[^\n]+)?\n\s+eval[^\n]+\n\s+Error::subs::try[^\n]+(?=\n)//sog;
584 6         53 $trace =~
585             s/(\n\s+\S+__ANON__[^\n]+)?\n\s+eval[^\n]+\n\s+Error::subs::run_clauses[^\n]+\n\s+Error::subs::try[^\n]+(?=\n)//sog;
586 6         55 my @callstack = split( m/\n/, $trace );
587 6         23 return @callstack;
588             }
589              
590             my $old_DIE;
591             my $old_WARN;
592              
593             sub DEATH
594             {
595 4     4   2301351 my ($e) = @_;
596              
597 4 100       151 local $SIG{__DIE__} = $old_DIE if ( defined $old_DIE );
598              
599 4 50       92 die @_ if $^S;
600              
601 4         51 my ( $etype, $message, $location, @callstack );
602 4 100 66     155 if ( ref($e) && $e->isa("Error") )
603             {
604 1         4 $etype = "exception of type " . ref($e);
605 1         15 $message = $e->text;
606 1         5 $location = $e->file . ":" . $e->line;
607 1         10 @callstack = split( m/\n/, $e->stacktrace );
608             }
609             else
610             {
611             # Don't apply subsequent layer of message formatting
612 3 50       78 die $e if ( $e =~ m/^\nUnhandled perl error caught at toplevel:\n\n/ );
613 3         52 $etype = "perl error";
614 3         11 my $stackdepth = 0;
615 3         106 while ( caller($stackdepth) =~ m/^Error(?:$|::)/ )
616             {
617 0         0 ++$stackdepth;
618             }
619              
620 3         61 @callstack = gen_callstack( $stackdepth + 1 );
621              
622 3         6 $message = "$e";
623 3         10 chomp $message;
624              
625 3 100       41 if ( $message =~ s/ at (.*?) line (\d+)\.$// )
626             {
627 2         9 $location = $1 . ":" . $2;
628             }
629             else
630             {
631 1         8 my @caller = caller($stackdepth);
632 1         14 $location = $caller[1] . ":" . $caller[2];
633             }
634             }
635              
636 4         12 shift @callstack;
637              
638             # Do it this way in case there are no elements; we don't print a spurious \n
639 4         18 my $callstack = join( "", map { "$_\n" } @callstack );
  8         41  
640              
641 4         1160 die
642             "\nUnhandled $etype caught at toplevel:\n\n $message\n\nThrown from: $location\n\nFull stack trace:\n\n$callstack\n";
643             }
644              
645             sub TAXES
646             {
647 3     3   866920 my ($message) = @_;
648              
649 3 100       119 local $SIG{__WARN__} = $old_WARN if ( defined $old_WARN );
650              
651 3         88 $message =~ s/ at .*? line \d+\.$//;
652 3         43 chomp $message;
653              
654 3         101 my @callstack = gen_callstack(1);
655 3         26 my $location = shift @callstack;
656              
657             # $location already starts in a leading space
658 3         40 $message .= $location;
659              
660             # Do it this way in case there are no elements; we don't print a spurious \n
661 3         10 my $callstack = join( "", map { "$_\n" } @callstack );
  6         34  
662              
663 3         120 warn "$message:\n$callstack";
664             }
665              
666             sub import
667             {
668 14     14   48 $old_DIE = $SIG{__DIE__};
669 14         31 $old_WARN = $SIG{__WARN__};
670              
671 14         56 $SIG{__DIE__} = \&DEATH;
672 14         89 $SIG{__WARN__} = \&TAXES;
673             }
674              
675             1;
676              
677             __END__