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