Code

avoid NULL dereference on failed malloc
[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***
12 package Error;
14 use strict;
15 use vars qw($VERSION);
16 use 5.004;
18 $VERSION = "0.15009";
20 use overload (
21         '""'       =>   'stringify',
22         '0+'       =>   'value',
23         'bool'     =>   sub { return 1; },
24         'fallback' =>   1
25 );
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
32 my $LAST;               # Last error created
33 my %ERROR;              # Last error associated with package
35 sub throw_Error_Simple
36 {
37     my $args = shift;
38     return Error::Simple->new($args->{'text'});
39 }
41 $Error::ObjectifyCallback = \&throw_Error_Simple;
44 # Exported subs are defined in Error::subs
46 sub import {
47     shift;
48     local $Exporter::ExportLevel = $Exporter::ExportLevel + 1;
49     Error::subs->import(@_);
50 }
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
55 sub prior {
56     shift; # ignore
58     return $LAST unless @_;
60     my $pkg = shift;
61     return exists $ERROR{$pkg} ? $ERROR{$pkg} : undef
62         unless ref($pkg);
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     }
75     $err;
76 }
78 sub flush {
79     shift; #ignore
81     unless (@_) {
82        $LAST = undef;
83        return;
84     }
86     my $pkg = shift;
87     return unless ref($pkg);
89     undef $ERROR{$pkg} if defined $ERROR{$pkg};
90 }
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
96 sub stacktrace {
97     my $self = shift;
99     return $self->{'-stacktrace'}
100         if exists $self->{'-stacktrace'};
102     my $text = exists $self->{'-text'} ? $self->{'-text'} : "Died";
104     $text .= sprintf(" at %s line %d.\n", $self->file, $self->line)
105         unless($text =~ /\n$/s);
107     $text;
110 # Allow error propagation, ie
112 # $ber->encode(...) or
113 #    return Error->prior($ber)->associate($ldap);
115 sub associate {
116     my $err = shift;
117     my $obj = shift;
119     return unless ref($obj);
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;
130     return;
133 sub new {
134     my $self = shift;
135     my($pkg,$file,$line) = caller($Error::Depth);
137     my $err = bless {
138         '-package' => $pkg,
139         '-file'    => $file,
140         '-line'    => $line,
141         @_
142     }, $self;
144     $err->associate($err->{'-object'})
145         if(exists $err->{'-object'});
147     # To always create a stacktrace would be very inefficient, so
148     # we only do it if $Error::Debug is set
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     }
161     $@ = $LAST = $ERROR{$pkg} = $err;
164 # Throw an error. this contains some very gory code.
166 sub throw {
167     my $self = shift;
168     local $Error::Depth = $Error::Depth + 1;
170     # if we are not rethrow-ing then create the object to throw
171     $self = $self->new(@_) unless ref($self);
173     die $Error::THROWN = $self;
176 # syntactic sugar for
178 #    die with Error( ... );
180 sub with {
181     my $self = shift;
182     local $Error::Depth = $Error::Depth + 1;
184     $self->new(@_);
187 # syntactic sugar for
189 #    record Error( ... ) and return;
191 sub record {
192     my $self = shift;
193     local $Error::Depth = $Error::Depth + 1;
195     $self->new(@_);
198 # catch clause for
200 # try { ... } catch CLASS with { ... }
202 sub catch {
203     my $pkg = shift;
204     my $code = shift;
205     my $clauses = shift || {};
206     my $catch = $clauses->{'catch'} ||= [];
208     unshift @$catch,  $pkg, $code;
210     $clauses;
213 # Object query methods
215 sub object {
216     my $self = shift;
217     exists $self->{'-object'} ? $self->{'-object'} : undef;
220 sub file {
221     my $self = shift;
222     exists $self->{'-file'} ? $self->{'-file'} : undef;
225 sub line {
226     my $self = shift;
227     exists $self->{'-line'} ? $self->{'-line'} : undef;
230 sub text {
231     my $self = shift;
232     exists $self->{'-text'} ? $self->{'-text'} : undef;
235 # overload methods
237 sub stringify {
238     my $self = shift;
239     defined $self->{'-text'} ? $self->{'-text'} : "Died";
242 sub value {
243     my $self = shift;
244     exists $self->{'-value'} ? $self->{'-value'} : undef;
247 package Error::Simple;
249 @Error::Simple::ISA = qw(Error);
251 sub new {
252     my $self  = shift;
253     my $text  = "" . shift;
254     my $value = shift;
255     my(@args) = ();
257     local $Error::Depth = $Error::Depth + 1;
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);
264     $self->SUPER::new(-text => $text, @args);
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;
275 ##########################################################################
276 ##########################################################################
278 # Inspired by code from Jesse Glick <jglick@sig.bsh.com> and
279 # Peter Seibel <peter@weblogic.com>
281 package Error::subs;
283 use Exporter ();
284 use vars qw(@EXPORT_OK @ISA %EXPORT_TAGS);
286 @EXPORT_OK   = qw(try with finally except otherwise);
287 %EXPORT_TAGS = (try => \@EXPORT_OK);
289 @ISA = qw(Exporter);
292 sub blessed {
293         my $item = shift;
294         local $@; # don't kill an outer $@
295         ref $item and eval { $item->can('can') };
299 sub run_clauses ($$$\@) {
300     my($clauses,$err,$wantarray,$result) = @_;
301     my $code = undef;
303     $err = $Error::ObjectifyCallback->({'text' =>$err}) unless ref($err);
305     CATCH: {
307         # catch
308         my $catch;
309         if(defined($catch = $clauses->{'catch'})) {
310             my $i = 0;
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         }
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 : $@;
380         $err = $Error::ObjectifyCallback->({'text' =>$err})
381             unless ref($err);
382             }
383         }
384     }
385     $err;
388 sub try (&;$) {
389     my $try = shift;
390     my $clauses = @_ ? shift : {};
391     my $ok = 0;
392     my $err = undef;
393     my @result = ();
395     unshift @Error::STACK, $clauses;
397     my $wantarray = wantarray();
399     do {
400         local $Error::THROWN = undef;
401     local $@ = undef;
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         };
416         $err = defined($Error::THROWN) ? $Error::THROWN : $@
417             unless $ok;
418     };
420     shift @Error::STACK;
422     $err = run_clauses($clauses,$err,wantarray,@result)
423         unless($ok);
425     $clauses->{'finally'}->()
426         if(defined($clauses->{'finally'}));
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     }
440     wantarray ? @result : $result[0];
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.
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.
451 # The otherwise clause adds a sub which unconditionally returns the users
452 # code reference, this is why it is forced to be last.
454 # The catch clause is defined in Error.pm, as the syntax causes it to
455 # be called as a method
457 sub with (&;$) {
458     @_
461 sub finally (&) {
462     my $code = shift;
463     my $clauses = { 'finally' => $code };
464     $clauses;
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.
470 sub except (&;$) {
471     my $code = shift;
472     my $clauses = shift || {};
473     my $catch = $clauses->{'catch'} ||= [];
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     };
489     unshift @{$catch}, undef, $sub;
491     $clauses;
494 sub otherwise (&;$) {
495     my $code = shift;
496     my $clauses = shift || {};
498     if(exists $clauses->{'otherwise'}) {
499         require Carp;
500         Carp::croak("Multiple otherwise clauses");
501     }
503     $clauses->{'otherwise'} = $code;
505     $clauses;
508 1;
509 __END__
511 =head1 NAME
513 Error - Error/exception handling in an OO-ish way
515 =head1 SYNOPSIS
517     use Error qw(:try);
519     throw Error::Simple( "A simple error");
521     sub xyz {
522         ...
523         record Error::Simple("A simple error")
524             and return;
525     }
527     unlink($file) or throw Error::Simple("$file: $!",$!);
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
553 =head1 DESCRIPTION
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.
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>.
563 =head1 PROCEDURAL INTERFACE
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.
568 =over 4
570 =item try BLOCK CLAUSES
572 C<try> is the main subroutine called by the user. All other subroutines
573 exported are clauses to the try subroutine.
575 The BLOCK will be evaluated and, if no error is throw, try will return
576 the result of the block.
578 C<CLAUSES> are the subroutines below, which describe what to do in the
579 event of an error being thrown within BLOCK.
581 =item catch CLASS with BLOCK
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>.
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.
592 To propagate the error the catch block may call C<$err-E<gt>throw>
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.
598 =item except BLOCK
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.
606 =item otherwise BLOCK
608 Catch any error by executing the code in C<BLOCK>
610 When evaluated C<BLOCK> will be passed one argument, which will be the
611 error being processed.
613 Only one otherwise block may be specified per try block
615 =item finally BLOCK
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.
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.
624 Only one finally block may be specified per try block
626 =back
628 =head1 CLASS INTERFACE
630 =head2 CONSTRUCTORS
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.
637         -file
638         -line
639         -text
640         -value
641         -object
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.
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.
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.
656 =over 4
658 =item throw ( [ ARGS ] )
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.
664 C<throw> may also be called on an existing error to re-throw it.
666 =item with ( [ ARGS ] )
668 Create a new C<Error> object and returns it. This is defined for
669 syntactic sugar, eg
671     die with Some::Error ( ... );
673 =item record ( [ ARGS ] )
675 Create a new C<Error> object and returns it. This is defined for
676 syntactic sugar, eg
678     record Some::Error ( ... )
679         and return;
681 =back
683 =head2 STATIC METHODS
685 =over 4
687 =item prior ( [ PACKAGE ] )
689 Return the last error created, or the last error associated with
690 C<PACKAGE>
692 =item flush ( [ PACKAGE ] )
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.
698      $Error->flush;
700 =cut
702 =back
704 =head2 OBJECT METHODS
706 =over 4
708 =item stacktrace
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.
717 =item object
719 The object this error was associated with
721 =item file
723 The file where the constructor of this error was called from
725 =item line
727 The line where the constructor of this error was called from
729 =item text
731 The text of the error
733 =back
735 =head2 OVERLOAD METHODS
737 =over 4
739 =item stringify
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.
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.
748 =item value
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.
755 By default this method returns the C<-value> argument that was passed
756 to the constructor.
758 =back
760 =head1 PRE-DEFINED ERROR CLASSES
762 =over 4
764 =item Error::Simple
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.
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.
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)
778 =back
780 =head1 $Error::ObjectifyCallback
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.
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.
790 For example the following code will cause Error.pm to throw objects of the
791 class MyError::Bar by default:
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     }
801     {
802         local $Error::ObjectifyCallback = \&throw_MyError_Bar;
804         # Error handling here.
805     }
807 =head1 KNOWN BUGS
809 None, but that does not mean there are not any.
811 =head1 AUTHORS
813 Graham Barr <gbarr@pobox.com>
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>.
819 =head1 MAINTAINER
821 Shlomi Fish <shlomif@iglu.org.il>
823 =head1 PAST MAINTAINERS
825 Arun Kumar U <u_arunkumar@yahoo.com>
827 =cut