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