PageRenderTime 92ms CodeModel.GetById 49ms app.highlight 37ms RepoModel.GetById 0ms app.codeStats 1ms

/perl/private-Error.pm

https://bitbucket.org/nbargnesi/git
Perl | 827 lines | 554 code | 214 blank | 59 comment | 52 complexity | e2953bb957eae5331824539e82a1a6b2 MD5 | raw file
  1# Error.pm
  2#
  3# Copyright (c) 1997-8 Graham Barr <gbarr@ti.com>. 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# <peter@weblogic.com> and adapted by Jesse Glick <jglick@sig.bsh.com>.
  9#
 10# but modified ***significantly***
 11
 12package Error;
 13
 14use strict;
 15use vars qw($VERSION);
 16use 5.004;
 17
 18$VERSION = "0.15009";
 19
 20use overload (
 21	'""'	   =>	'stringify',
 22	'0+'	   =>	'value',
 23	'bool'     =>	sub { return 1; },
 24	'fallback' =>	1
 25);
 26
 27$Error::Depth = 0;	# Depth to pass to caller()
 28$Error::Debug = 0;	# Generate verbose stack traces
 29@Error::STACK = ();	# Clause stack for try
 30$Error::THROWN = undef;	# last error thrown, a workaround until die $ref works
 31
 32my $LAST;		# Last error created
 33my %ERROR;		# Last error associated with package
 34
 35sub throw_Error_Simple
 36{
 37    my $args = shift;
 38    return Error::Simple->new($args->{'text'});
 39}
 40
 41$Error::ObjectifyCallback = \&throw_Error_Simple;
 42
 43
 44# Exported subs are defined in Error::subs
 45
 46sub import {
 47    shift;
 48    local $Exporter::ExportLevel = $Exporter::ExportLevel + 1;
 49    Error::subs->import(@_);
 50}
 51
 52# I really want to use last for the name of this method, but it is a keyword
 53# which prevent the syntax  last Error
 54
 55sub prior {
 56    shift; # ignore
 57
 58    return $LAST unless @_;
 59
 60    my $pkg = shift;
 61    return exists $ERROR{$pkg} ? $ERROR{$pkg} : undef
 62	unless ref($pkg);
 63
 64    my $obj = $pkg;
 65    my $err = undef;
 66    if($obj->isa('HASH')) {
 67	$err = $obj->{'__Error__'}
 68	    if exists $obj->{'__Error__'};
 69    }
 70    elsif($obj->isa('GLOB')) {
 71	$err = ${*$obj}{'__Error__'}
 72	    if exists ${*$obj}{'__Error__'};
 73    }
 74
 75    $err;
 76}
 77
 78sub flush {
 79    shift; #ignore
 80
 81    unless (@_) {
 82       $LAST = undef;
 83       return;
 84    }
 85
 86    my $pkg = shift;
 87    return unless ref($pkg);
 88
 89    undef $ERROR{$pkg} if defined $ERROR{$pkg};
 90}
 91
 92# Return as much information as possible about where the error
 93# happened. The -stacktrace element only exists if $Error::DEBUG
 94# was set when the error was created
 95
 96sub stacktrace {
 97    my $self = shift;
 98
 99    return $self->{'-stacktrace'}
100	if exists $self->{'-stacktrace'};
101
102    my $text = exists $self->{'-text'} ? $self->{'-text'} : "Died";
103
104    $text .= sprintf(" at %s line %d.\n", $self->file, $self->line)
105	unless($text =~ /\n$/s);
106
107    $text;
108}
109
110# Allow error propagation, ie
111#
112# $ber->encode(...) or
113#    return Error->prior($ber)->associate($ldap);
114
115sub associate {
116    my $err = shift;
117    my $obj = shift;
118
119    return unless ref($obj);
120
121    if($obj->isa('HASH')) {
122	$obj->{'__Error__'} = $err;
123    }
124    elsif($obj->isa('GLOB')) {
125	${*$obj}{'__Error__'} = $err;
126    }
127    $obj = ref($obj);
128    $ERROR{ ref($obj) } = $err;
129
130    return;
131}
132
133sub new {
134    my $self = shift;
135    my($pkg,$file,$line) = caller($Error::Depth);
136
137    my $err = bless {
138	'-package' => $pkg,
139	'-file'    => $file,
140	'-line'    => $line,
141	@_
142    }, $self;
143
144    $err->associate($err->{'-object'})
145	if(exists $err->{'-object'});
146
147    # To always create a stacktrace would be very inefficient, so
148    # we only do it if $Error::Debug is set
149
150    if($Error::Debug) {
151	require Carp;
152	local $Carp::CarpLevel = $Error::Depth;
153	my $text = defined($err->{'-text'}) ? $err->{'-text'} : "Error";
154	my $trace = Carp::longmess($text);
155	# Remove try calls from the trace
156	$trace =~ s/(\n\s+\S+__ANON__[^\n]+)?\n\s+eval[^\n]+\n\s+Error::subs::try[^\n]+(?=\n)//sog;
157	$trace =~ 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;
158	$err->{'-stacktrace'} = $trace
159    }
160
161    $@ = $LAST = $ERROR{$pkg} = $err;
162}
163
164# Throw an error. this contains some very gory code.
165
166sub throw {
167    my $self = shift;
168    local $Error::Depth = $Error::Depth + 1;
169
170    # if we are not rethrow-ing then create the object to throw
171    $self = $self->new(@_) unless ref($self);
172
173    die $Error::THROWN = $self;
174}
175
176# syntactic sugar for
177#
178#    die with Error( ... );
179
180sub with {
181    my $self = shift;
182    local $Error::Depth = $Error::Depth + 1;
183
184    $self->new(@_);
185}
186
187# syntactic sugar for
188#
189#    record Error( ... ) and return;
190
191sub record {
192    my $self = shift;
193    local $Error::Depth = $Error::Depth + 1;
194
195    $self->new(@_);
196}
197
198# catch clause for
199#
200# try { ... } catch CLASS with { ... }
201
202sub catch {
203    my $pkg = shift;
204    my $code = shift;
205    my $clauses = shift || {};
206    my $catch = $clauses->{'catch'} ||= [];
207
208    unshift @$catch,  $pkg, $code;
209
210    $clauses;
211}
212
213# Object query methods
214
215sub object {
216    my $self = shift;
217    exists $self->{'-object'} ? $self->{'-object'} : undef;
218}
219
220sub file {
221    my $self = shift;
222    exists $self->{'-file'} ? $self->{'-file'} : undef;
223}
224
225sub line {
226    my $self = shift;
227    exists $self->{'-line'} ? $self->{'-line'} : undef;
228}
229
230sub text {
231    my $self = shift;
232    exists $self->{'-text'} ? $self->{'-text'} : undef;
233}
234
235# overload methods
236
237sub stringify {
238    my $self = shift;
239    defined $self->{'-text'} ? $self->{'-text'} : "Died";
240}
241
242sub value {
243    my $self = shift;
244    exists $self->{'-value'} ? $self->{'-value'} : undef;
245}
246
247package Error::Simple;
248
249@Error::Simple::ISA = qw(Error);
250
251sub new {
252    my $self  = shift;
253    my $text  = "" . shift;
254    my $value = shift;
255    my(@args) = ();
256
257    local $Error::Depth = $Error::Depth + 1;
258
259    @args = ( -file => $1, -line => $2)
260	if($text =~ s/\s+at\s+(\S+)\s+line\s+(\d+)(?:,\s*<[^>]*>\s+line\s+\d+)?\.?\n?$//s);
261    push(@args, '-value', 0 + $value)
262	if defined($value);
263
264    $self->SUPER::new(-text => $text, @args);
265}
266
267sub stringify {
268    my $self = shift;
269    my $text = $self->SUPER::stringify;
270    $text .= sprintf(" at %s line %d.\n", $self->file, $self->line)
271	unless($text =~ /\n$/s);
272    $text;
273}
274
275##########################################################################
276##########################################################################
277
278# Inspired by code from Jesse Glick <jglick@sig.bsh.com> and
279# Peter Seibel <peter@weblogic.com>
280
281package Error::subs;
282
283use Exporter ();
284use vars qw(@EXPORT_OK @ISA %EXPORT_TAGS);
285
286@EXPORT_OK   = qw(try with finally except otherwise);
287%EXPORT_TAGS = (try => \@EXPORT_OK);
288
289@ISA = qw(Exporter);
290
291
292sub blessed {
293	my $item = shift;
294	local $@; # don't kill an outer $@
295	ref $item and eval { $item->can('can') };
296}
297
298
299sub run_clauses ($$$\@) {
300    my($clauses,$err,$wantarray,$result) = @_;
301    my $code = undef;
302
303    $err = $Error::ObjectifyCallback->({'text' =>$err}) unless ref($err);
304
305    CATCH: {
306
307	# catch
308	my $catch;
309	if(defined($catch = $clauses->{'catch'})) {
310	    my $i = 0;
311
312	    CATCHLOOP:
313	    for( ; $i < @$catch ; $i += 2) {
314		my $pkg = $catch->[$i];
315		unless(defined $pkg) {
316		    #except
317		    splice(@$catch,$i,2,$catch->[$i+1]->());
318		    $i -= 2;
319		    next CATCHLOOP;
320		}
321		elsif(blessed($err) && $err->isa($pkg)) {
322		    $code = $catch->[$i+1];
323		    while(1) {
324			my $more = 0;
325			local($Error::THROWN);
326			my $ok = eval {
327			    if($wantarray) {
328				@{$result} = $code->($err,\$more);
329			    }
330			    elsif(defined($wantarray)) {
331			        @{$result} = ();
332				$result->[0] = $code->($err,\$more);
333			    }
334			    else {
335				$code->($err,\$more);
336			    }
337			    1;
338			};
339			if( $ok ) {
340			    next CATCHLOOP if $more;
341			    undef $err;
342			}
343			else {
344			    $err = defined($Error::THROWN)
345				    ? $Error::THROWN : $@;
346                $err = $Error::ObjectifyCallback->({'text' =>$err})
347                    unless ref($err);
348			}
349			last CATCH;
350		    };
351		}
352	    }
353	}
354
355	# otherwise
356	my $owise;
357	if(defined($owise = $clauses->{'otherwise'})) {
358	    my $code = $clauses->{'otherwise'};
359	    my $more = 0;
360	    my $ok = eval {
361		if($wantarray) {
362		    @{$result} = $code->($err,\$more);
363		}
364		elsif(defined($wantarray)) {
365		    @{$result} = ();
366		    $result->[0] = $code->($err,\$more);
367		}
368		else {
369		    $code->($err,\$more);
370		}
371		1;
372	    };
373	    if( $ok ) {
374		undef $err;
375	    }
376	    else {
377		$err = defined($Error::THROWN)
378			? $Error::THROWN : $@;
379
380        $err = $Error::ObjectifyCallback->({'text' =>$err})
381            unless ref($err);
382	    }
383	}
384    }
385    $err;
386}
387
388sub try (&;$) {
389    my $try = shift;
390    my $clauses = @_ ? shift : {};
391    my $ok = 0;
392    my $err = undef;
393    my @result = ();
394
395    unshift @Error::STACK, $clauses;
396
397    my $wantarray = wantarray();
398
399    do {
400	local $Error::THROWN = undef;
401    local $@ = undef;
402
403	$ok = eval {
404	    if($wantarray) {
405		@result = $try->();
406	    }
407	    elsif(defined $wantarray) {
408		$result[0] = $try->();
409	    }
410	    else {
411		$try->();
412	    }
413	    1;
414	};
415
416	$err = defined($Error::THROWN) ? $Error::THROWN : $@
417	    unless $ok;
418    };
419
420    shift @Error::STACK;
421
422    $err = run_clauses($clauses,$err,wantarray,@result)
423	unless($ok);
424
425    $clauses->{'finally'}->()
426	if(defined($clauses->{'finally'}));
427
428    if (defined($err))
429    {
430        if (blessed($err) && $err->can('throw'))
431        {
432            throw $err;
433        }
434        else
435        {
436            die $err;
437        }
438    }
439
440    wantarray ? @result : $result[0];
441}
442
443# Each clause adds a sub to the list of clauses. The finally clause is
444# always the last, and the otherwise clause is always added just before
445# the finally clause.
446#
447# All clauses, except the finally clause, add a sub which takes one argument
448# this argument will be the error being thrown. The sub will return a code ref
449# if that clause can handle that error, otherwise undef is returned.
450#
451# The otherwise clause adds a sub which unconditionally returns the users
452# code reference, this is why it is forced to be last.
453#
454# The catch clause is defined in Error.pm, as the syntax causes it to
455# be called as a method
456
457sub with (&;$) {
458    @_
459}
460
461sub finally (&) {
462    my $code = shift;
463    my $clauses = { 'finally' => $code };
464    $clauses;
465}
466
467# The except clause is a block which returns a hashref or a list of
468# key-value pairs, where the keys are the classes and the values are subs.
469
470sub except (&;$) {
471    my $code = shift;
472    my $clauses = shift || {};
473    my $catch = $clauses->{'catch'} ||= [];
474
475    my $sub = sub {
476	my $ref;
477	my(@array) = $code->($_[0]);
478	if(@array == 1 && ref($array[0])) {
479	    $ref = $array[0];
480	    $ref = [ %$ref ]
481		if(UNIVERSAL::isa($ref,'HASH'));
482	}
483	else {
484	    $ref = \@array;
485	}
486	@$ref
487    };
488
489    unshift @{$catch}, undef, $sub;
490
491    $clauses;
492}
493
494sub otherwise (&;$) {
495    my $code = shift;
496    my $clauses = shift || {};
497
498    if(exists $clauses->{'otherwise'}) {
499	require Carp;
500	Carp::croak("Multiple otherwise clauses");
501    }
502
503    $clauses->{'otherwise'} = $code;
504
505    $clauses;
506}
507
5081;
509__END__
510
511=head1 NAME
512
513Error - Error/exception handling in an OO-ish way
514
515=head1 SYNOPSIS
516
517    use Error qw(:try);
518
519    throw Error::Simple( "A simple error");
520
521    sub xyz {
522        ...
523	record Error::Simple("A simple error")
524	    and return;
525    }
526
527    unlink($file) or throw Error::Simple("$file: $!",$!);
528
529    try {
530	do_some_stuff();
531	die "error!" if $condition;
532	throw Error::Simple -text => "Oops!" if $other_condition;
533    }
534    catch Error::IO with {
535	my $E = shift;
536	print STDERR "File ", $E->{'-file'}, " had a problem\n";
537    }
538    except {
539	my $E = shift;
540	my $general_handler=sub {send_message $E->{-description}};
541	return {
542	    UserException1 => $general_handler,
543	    UserException2 => $general_handler
544	};
545    }
546    otherwise {
547	print STDERR "Well I don't know what to say\n";
548    }
549    finally {
550	close_the_garage_door_already(); # Should be reliable
551    }; # Don't forget the trailing ; or you might be surprised
552
553=head1 DESCRIPTION
554
555The C<Error> package provides two interfaces. Firstly C<Error> provides
556a procedural interface to exception handling. Secondly C<Error> is a
557base class for errors/exceptions that can either be thrown, for
558subsequent catch, or can simply be recorded.
559
560Errors in the class C<Error> should not be thrown directly, but the
561user should throw errors from a sub-class of C<Error>.
562
563=head1 PROCEDURAL INTERFACE
564
565C<Error> exports subroutines to perform exception handling. These will
566be exported if the C<:try> tag is used in the C<use> line.
567
568=over 4
569
570=item try BLOCK CLAUSES
571
572C<try> is the main subroutine called by the user. All other subroutines
573exported are clauses to the try subroutine.
574
575The BLOCK will be evaluated and, if no error is throw, try will return
576the result of the block.
577
578C<CLAUSES> are the subroutines below, which describe what to do in the
579event of an error being thrown within BLOCK.
580
581=item catch CLASS with BLOCK
582
583This clauses will cause all errors that satisfy C<$err-E<gt>isa(CLASS)>
584to be caught and handled by evaluating C<BLOCK>.
585
586C<BLOCK> will be passed two arguments. The first will be the error
587being thrown. The second is a reference to a scalar variable. If this
588variable is set by the catch block then, on return from the catch
589block, try will continue processing as if the catch block was never
590found.
591
592To propagate the error the catch block may call C<$err-E<gt>throw>
593
594If the scalar reference by the second argument is not set, and the
595error is not thrown. Then the current try block will return with the
596result from the catch block.
597
598=item except BLOCK
599
600When C<try> is looking for a handler, if an except clause is found
601C<BLOCK> is evaluated. The return value from this block should be a
602HASHREF or a list of key-value pairs, where the keys are class names
603and the values are CODE references for the handler of errors of that
604type.
605
606=item otherwise BLOCK
607
608Catch any error by executing the code in C<BLOCK>
609
610When evaluated C<BLOCK> will be passed one argument, which will be the
611error being processed.
612
613Only one otherwise block may be specified per try block
614
615=item finally BLOCK
616
617Execute the code in C<BLOCK> either after the code in the try block has
618successfully completed, or if the try block throws an error then
619C<BLOCK> will be executed after the handler has completed.
620
621If the handler throws an error then the error will be caught, the
622finally block will be executed and the error will be re-thrown.
623
624Only one finally block may be specified per try block
625
626=back
627
628=head1 CLASS INTERFACE
629
630=head2 CONSTRUCTORS
631
632The C<Error> object is implemented as a HASH. This HASH is initialized
633with the arguments that are passed to its constructor. The elements
634that are used by, or are retrievable by the C<Error> class are listed
635below, other classes may add to these.
636
637	-file
638	-line
639	-text
640	-value
641	-object
642
643If C<-file> or C<-line> are not specified in the constructor arguments
644then these will be initialized with the file name and line number where
645the constructor was called from.
646
647If the error is associated with an object then the object should be
648passed as the C<-object> argument. This will allow the C<Error> package
649to associate the error with the object.
650
651The C<Error> package remembers the last error created, and also the
652last error associated with a package. This could either be the last
653error created by a sub in that package, or the last error which passed
654an object blessed into that package as the C<-object> argument.
655
656=over 4
657
658=item throw ( [ ARGS ] )
659
660Create a new C<Error> object and throw an error, which will be caught
661by a surrounding C<try> block, if there is one. Otherwise it will cause
662the program to exit.
663
664C<throw> may also be called on an existing error to re-throw it.
665
666=item with ( [ ARGS ] )
667
668Create a new C<Error> object and returns it. This is defined for
669syntactic sugar, eg
670
671    die with Some::Error ( ... );
672
673=item record ( [ ARGS ] )
674
675Create a new C<Error> object and returns it. This is defined for
676syntactic sugar, eg
677
678    record Some::Error ( ... )
679	and return;
680
681=back
682
683=head2 STATIC METHODS
684
685=over 4
686
687=item prior ( [ PACKAGE ] )
688
689Return the last error created, or the last error associated with
690C<PACKAGE>
691
692=item flush ( [ PACKAGE ] )
693
694Flush the last error created, or the last error associated with
695C<PACKAGE>.It is necessary to clear the error stack before exiting the
696package or uncaught errors generated using C<record> will be reported.
697
698     $Error->flush;
699
700=cut
701
702=back
703
704=head2 OBJECT METHODS
705
706=over 4
707
708=item stacktrace
709
710If the variable C<$Error::Debug> was non-zero when the error was
711created, then C<stacktrace> returns a string created by calling
712C<Carp::longmess>. If the variable was zero the C<stacktrace> returns
713the text of the error appended with the filename and line number of
714where the error was created, providing the text does not end with a
715newline.
716
717=item object
718
719The object this error was associated with
720
721=item file
722
723The file where the constructor of this error was called from
724
725=item line
726
727The line where the constructor of this error was called from
728
729=item text
730
731The text of the error
732
733=back
734
735=head2 OVERLOAD METHODS
736
737=over 4
738
739=item stringify
740
741A method that converts the object into a string. This method may simply
742return the same as the C<text> method, or it may append more
743information. For example the file name and line number.
744
745By default this method returns the C<-text> argument that was passed to
746the constructor, or the string C<"Died"> if none was given.
747
748=item value
749
750A method that will return a value that can be associated with the
751error. For example if an error was created due to the failure of a
752system call, then this may return the numeric value of C<$!> at the
753time.
754
755By default this method returns the C<-value> argument that was passed
756to the constructor.
757
758=back
759
760=head1 PRE-DEFINED ERROR CLASSES
761
762=over 4
763
764=item Error::Simple
765
766This class can be used to hold simple error strings and values. Its
767constructor takes two arguments. The first is a text value, the second
768is a numeric value. These values are what will be returned by the
769overload methods.
770
771If the text value ends with C<at file line 1> as $@ strings do, then
772this information will be used to set the C<-file> and C<-line> arguments
773of the error object.
774
775This class is used internally if an eval'd block die's with an error
776that is a plain string. (Unless C<$Error::ObjectifyCallback> is modified)
777
778=back
779
780=head1 $Error::ObjectifyCallback
781
782This variable holds a reference to a subroutine that converts errors that
783are plain strings to objects. It is used by Error.pm to convert textual
784errors to objects, and can be overridden by the user.
785
786It accepts a single argument which is a hash reference to named parameters.
787Currently the only named parameter passed is C<'text'> which is the text
788of the error, but others may be available in the future.
789
790For example the following code will cause Error.pm to throw objects of the
791class MyError::Bar by default:
792
793    sub throw_MyError_Bar
794    {
795        my $args = shift;
796        my $err = MyError::Bar->new();
797        $err->{'MyBarText'} = $args->{'text'};
798        return $err;
799    }
800
801    {
802        local $Error::ObjectifyCallback = \&throw_MyError_Bar;
803
804        # Error handling here.
805    }
806
807=head1 KNOWN BUGS
808
809None, but that does not mean there are not any.
810
811=head1 AUTHORS
812
813Graham Barr <gbarr@pobox.com>
814
815The code that inspired me to write this was originally written by
816Peter Seibel <peter@weblogic.com> and adapted by Jesse Glick
817<jglick@sig.bsh.com>.
818
819=head1 MAINTAINER
820
821Shlomi Fish <shlomif@iglu.org.il>
822
823=head1 PAST MAINTAINERS
824
825Arun Kumar U <u_arunkumar@yahoo.com>
826
827=cut