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