Merge branch 'dp/autoconf-curl-ssl' into maint
[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 its 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. Its
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 information 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