Assorted typo fixes
[git/git.git] / perl / private-Error.pm
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
12 package Error;
13
14 use strict;
15 use vars qw($VERSION);
16 use 5.004;
17
18 $VERSION = "0.15009";
19
20 use 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
32 my $LAST; # Last error created
33 my %ERROR; # Last error associated with package
34
35 sub 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
46 sub 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
55 sub 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
78 sub 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
96 sub 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
115 sub 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
133 sub 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
166 sub 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
180 sub 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
191 sub 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
202 sub 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
215 sub object {
216 my $self = shift;
217 exists $self->{'-object'} ? $self->{'-object'} : undef;
218 }
219
220 sub file {
221 my $self = shift;
222 exists $self->{'-file'} ? $self->{'-file'} : undef;
223 }
224
225 sub line {
226 my $self = shift;
227 exists $self->{'-line'} ? $self->{'-line'} : undef;
228 }
229
230 sub text {
231 my $self = shift;
232 exists $self->{'-text'} ? $self->{'-text'} : undef;
233 }
234
235 # overload methods
236
237 sub stringify {
238 my $self = shift;
239 defined $self->{'-text'} ? $self->{'-text'} : "Died";
240 }
241
242 sub value {
243 my $self = shift;
244 exists $self->{'-value'} ? $self->{'-value'} : undef;
245 }
246
247 package Error::Simple;
248
249 @Error::Simple::ISA = qw(Error);
250
251 sub 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
267 sub 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
281 package Error::subs;
282
283 use Exporter ();
284 use 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
292 sub blessed {
293 my $item = shift;
294 local $@; # don't kill an outer $@
295 ref $item and eval { $item->can('can') };
296 }
297
298
299 sub 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
388 sub 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
457 sub with (&;$) {
458 @_
459 }
460
461 sub 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
470 sub 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
494 sub 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
508 1;
509 __END__
510
511 =head1 NAME
512
513 Error - 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
555 The C<Error> package provides two interfaces. Firstly C<Error> provides
556 a procedural interface to exception handling. Secondly C<Error> is a
557 base class for errors/exceptions that can either be thrown, for
558 subsequent catch, or can simply be recorded.
559
560 Errors in the class C<Error> should not be thrown directly, but the
561 user should throw errors from a sub-class of C<Error>.
562
563 =head1 PROCEDURAL INTERFACE
564
565 C<Error> exports subroutines to perform exception handling. These will
566 be exported if the C<:try> tag is used in the C<use> line.
567
568 =over 4
569
570 =item try BLOCK CLAUSES
571
572 C<try> is the main subroutine called by the user. All other subroutines
573 exported are clauses to the try subroutine.
574
575 The BLOCK will be evaluated and, if no error is throw, try will return
576 the result of the block.
577
578 C<CLAUSES> are the subroutines below, which describe what to do in the
579 event of an error being thrown within BLOCK.
580
581 =item catch CLASS with BLOCK
582
583 This clauses will cause all errors that satisfy C<$err-E<gt>isa(CLASS)>
584 to be caught and handled by evaluating C<BLOCK>.
585
586 C<BLOCK> will be passed two arguments. The first will be the error
587 being thrown. The second is a reference to a scalar variable. If this
588 variable is set by the catch block then, on return from the catch
589 block, try will continue processing as if the catch block was never
590 found.
591
592 To propagate the error the catch block may call C<$err-E<gt>throw>
593
594 If the scalar reference by the second argument is not set, and the
595 error is not thrown. Then the current try block will return with the
596 result from the catch block.
597
598 =item except BLOCK
599
600 When C<try> is looking for a handler, if an except clause is found
601 C<BLOCK> is evaluated. The return value from this block should be a
602 HASHREF or a list of key-value pairs, where the keys are class names
603 and the values are CODE references for the handler of errors of that
604 type.
605
606 =item otherwise BLOCK
607
608 Catch any error by executing the code in C<BLOCK>
609
610 When evaluated C<BLOCK> will be passed one argument, which will be the
611 error being processed.
612
613 Only one otherwise block may be specified per try block
614
615 =item finally BLOCK
616
617 Execute the code in C<BLOCK> either after the code in the try block has
618 successfully completed, or if the try block throws an error then
619 C<BLOCK> will be executed after the handler has completed.
620
621 If the handler throws an error then the error will be caught, the
622 finally block will be executed and the error will be re-thrown.
623
624 Only one finally block may be specified per try block
625
626 =back
627
628 =head1 CLASS INTERFACE
629
630 =head2 CONSTRUCTORS
631
632 The C<Error> object is implemented as a HASH. This HASH is initialized
633 with the arguments that are passed to it's constructor. The elements
634 that are used by, or are retrievable by the C<Error> class are listed
635 below, other classes may add to these.
636
637 -file
638 -line
639 -text
640 -value
641 -object
642
643 If C<-file> or C<-line> are not specified in the constructor arguments
644 then these will be initialized with the file name and line number where
645 the constructor was called from.
646
647 If the error is associated with an object then the object should be
648 passed as the C<-object> argument. This will allow the C<Error> package
649 to associate the error with the object.
650
651 The C<Error> package remembers the last error created, and also the
652 last error associated with a package. This could either be the last
653 error created by a sub in that package, or the last error which passed
654 an object blessed into that package as the C<-object> argument.
655
656 =over 4
657
658 =item throw ( [ ARGS ] )
659
660 Create a new C<Error> object and throw an error, which will be caught
661 by a surrounding C<try> block, if there is one. Otherwise it will cause
662 the program to exit.
663
664 C<throw> may also be called on an existing error to re-throw it.
665
666 =item with ( [ ARGS ] )
667
668 Create a new C<Error> object and returns it. This is defined for
669 syntactic sugar, eg
670
671 die with Some::Error ( ... );
672
673 =item record ( [ ARGS ] )
674
675 Create a new C<Error> object and returns it. This is defined for
676 syntactic 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
689 Return the last error created, or the last error associated with
690 C<PACKAGE>
691
692 =item flush ( [ PACKAGE ] )
693
694 Flush the last error created, or the last error associated with
695 C<PACKAGE>.It is necessary to clear the error stack before exiting the
696 package 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
710 If the variable C<$Error::Debug> was non-zero when the error was
711 created, then C<stacktrace> returns a string created by calling
712 C<Carp::longmess>. If the variable was zero the C<stacktrace> returns
713 the text of the error appended with the filename and line number of
714 where the error was created, providing the text does not end with a
715 newline.
716
717 =item object
718
719 The object this error was associated with
720
721 =item file
722
723 The file where the constructor of this error was called from
724
725 =item line
726
727 The line where the constructor of this error was called from
728
729 =item text
730
731 The text of the error
732
733 =back
734
735 =head2 OVERLOAD METHODS
736
737 =over 4
738
739 =item stringify
740
741 A method that converts the object into a string. This method may simply
742 return the same as the C<text> method, or it may append more
743 information. For example the file name and line number.
744
745 By default this method returns the C<-text> argument that was passed to
746 the constructor, or the string C<"Died"> if none was given.
747
748 =item value
749
750 A method that will return a value that can be associated with the
751 error. For example if an error was created due to the failure of a
752 system call, then this may return the numeric value of C<$!> at the
753 time.
754
755 By default this method returns the C<-value> argument that was passed
756 to the constructor.
757
758 =back
759
760 =head1 PRE-DEFINED ERROR CLASSES
761
762 =over 4
763
764 =item Error::Simple
765
766 This class can be used to hold simple error strings and values. It's
767 constructor takes two arguments. The first is a text value, the second
768 is a numeric value. These values are what will be returned by the
769 overload methods.
770
771 If the text value ends with C<at file line 1> as $@ strings do, then
772 this infomation will be used to set the C<-file> and C<-line> arguments
773 of the error object.
774
775 This class is used internally if an eval'd block die's with an error
776 that is a plain string. (Unless C<$Error::ObjectifyCallback> is modified)
777
778 =back
779
780 =head1 $Error::ObjectifyCallback
781
782 This variable holds a reference to a subroutine that converts errors that
783 are plain strings to objects. It is used by Error.pm to convert textual
784 errors to objects, and can be overridden by the user.
785
786 It accepts a single argument which is a hash reference to named parameters.
787 Currently the only named parameter passed is C<'text'> which is the text
788 of the error, but others may be available in the future.
789
790 For example the following code will cause Error.pm to throw objects of the
791 class 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
809 None, but that does not mean there are not any.
810
811 =head1 AUTHORS
812
813 Graham Barr <gbarr@pobox.com>
814
815 The code that inspired me to write this was originally written by
816 Peter Seibel <peter@weblogic.com> and adapted by Jesse Glick
817 <jglick@sig.bsh.com>.
818
819 =head1 MAINTAINER
820
821 Shlomi Fish <shlomif@iglu.org.il>
822
823 =head1 PAST MAINTAINERS
824
825 Arun Kumar U <u_arunkumar@yahoo.com>
826
827 =cut