perl/FromCPAN/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 warnings $ENV{GIT_PERL_FATAL_WARNINGS} ? qw(FATAL all) : ();
  16
  17 use vars qw($VERSION);
  18 use 5.004;
  19
  20 $VERSION = "0.17025";
  21
  22 use overload (
  23         '""'       =>   'stringify',
  24         '0+'       =>   'value',
  25         'bool'     =>   sub { return 1; },
  26         'fallback' =>   1
  27 );
  28
  29 $Error::Depth = 0;      # Depth to pass to caller()
  30 $Error::Debug = 0;      # Generate verbose stack traces
  31 @Error::STACK = ();     # Clause stack for try
  32 $Error::THROWN = undef; # last error thrown, a workaround until die $ref works
  33
  34 my $LAST;               # Last error created
  35 my %ERROR;              # Last error associated with package
  36
  37 sub _throw_Error_Simple
  38 {
  39     my $args = shift;
  40     return Error::Simple->new($args->{'text'});
  41 }
  42
  43 $Error::ObjectifyCallback = \&_throw_Error_Simple;
  44
  45
  46 # Exported subs are defined in Error::subs
  47
  48 use Scalar::Util ();
  49
  50 sub import {
  51     shift;
  52     my @tags = @_;
  53     local $Exporter::ExportLevel = $Exporter::ExportLevel + 1;
  54
  55     @tags = grep {
  56        if( $_ eq ':warndie' ) {
  57           Error::WarnDie->import();
  58           0;
  59        }
  60        else {
  61           1;
  62        }
  63     } @tags;
  64
  65     Error::subs->import(@tags);
  66 }
  67
  68 # I really want to use last for the name of this method, but it is a keyword
  69 # which prevent the syntax  last Error
  70
  71 sub prior {
  72     shift; # ignore
  73
  74     return $LAST unless @_;
  75
  76     my $pkg = shift;
  77     return exists $ERROR{$pkg} ? $ERROR{$pkg} : undef
  78         unless ref($pkg);
  79
  80     my $obj = $pkg;
  81     my $err = undef;
  82     if($obj->isa('HASH')) {
  83         $err = $obj->{'__Error__'}
  84             if exists $obj->{'__Error__'};
  85     }
  86     elsif($obj->isa('GLOB')) {
  87         $err = ${*$obj}{'__Error__'}
  88             if exists ${*$obj}{'__Error__'};
  89     }
  90
  91     $err;
  92 }
  93
  94 sub flush {
  95     shift; #ignore
  96
  97     unless (@_) {
  98        $LAST = undef;
  99        return;
 100     }
 101
 102     my $pkg = shift;
 103     return unless ref($pkg);
 104
 105     undef $ERROR{$pkg} if defined $ERROR{$pkg};
 106 }
 107
 108 # Return as much information as possible about where the error
 109 # happened. The -stacktrace element only exists if $Error::DEBUG
 110 # was set when the error was created
 111
 112 sub stacktrace {
 113     my $self = shift;
 114
 115     return $self->{'-stacktrace'}
 116         if exists $self->{'-stacktrace'};
 117
 118     my $text = exists $self->{'-text'} ? $self->{'-text'} : "Died";
 119
 120     $text .= sprintf(" at %s line %d.\n", $self->file, $self->line)
 121         unless($text =~ /\n$/s);
 122
 123     $text;
 124 }
 125
 126
 127 sub associate {
 128     my $err = shift;
 129     my $obj = shift;
 130
 131     return unless ref($obj);
 132
 133     if($obj->isa('HASH')) {
 134         $obj->{'__Error__'} = $err;
 135     }
 136     elsif($obj->isa('GLOB')) {
 137         ${*$obj}{'__Error__'} = $err;
 138     }
 139     $obj = ref($obj);
 140     $ERROR{ ref($obj) } = $err;
 141
 142     return;
 143 }
 144
 145
 146 sub new {
 147     my $self = shift;
 148     my($pkg,$file,$line) = caller($Error::Depth);
 149
 150     my $err = bless {
 151         '-package' => $pkg,
 152         '-file'    => $file,
 153         '-line'    => $line,
 154         @_
 155     }, $self;
 156
 157     $err->associate($err->{'-object'})
 158         if(exists $err->{'-object'});
 159
 160     # To always create a stacktrace would be very inefficient, so
 161     # we only do it if $Error::Debug is set
 162
 163     if($Error::Debug) {
 164         require Carp;
 165         local $Carp::CarpLevel = $Error::Depth;
 166         my $text = defined($err->{'-text'}) ? $err->{'-text'} : "Error";
 167         my $trace = Carp::longmess($text);
 168         # Remove try calls from the trace
 169         $trace =~ s/(\n\s+\S+__ANON__[^\n]+)?\n\s+eval[^\n]+\n\s+Error::subs::try[^\n]+(?=\n)//sog;
 170         $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;
 171         $err->{'-stacktrace'} = $trace
 172     }
 173
 174     $@ = $LAST = $ERROR{$pkg} = $err;
 175 }
 176
 177 # Throw an error. this contains some very gory code.
 178
 179 sub throw {
 180     my $self = shift;
 181     local $Error::Depth = $Error::Depth + 1;
 182
 183     # if we are not rethrow-ing then create the object to throw
 184     $self = $self->new(@_) unless ref($self);
 185
 186     die $Error::THROWN = $self;
 187 }
 188
 189 # syntactic sugar for
 190 #
 191 #    die with Error( ... );
 192
 193 sub with {
 194     my $self = shift;
 195     local $Error::Depth = $Error::Depth + 1;
 196
 197     $self->new(@_);
 198 }
 199
 200 # syntactic sugar for
 201 #
 202 #    record Error( ... ) and return;
 203
 204 sub record {
 205     my $self = shift;
 206     local $Error::Depth = $Error::Depth + 1;
 207
 208     $self->new(@_);
 209 }
 210
 211 # catch clause for
 212 #
 213 # try { ... } catch CLASS with { ... }
 214
 215 sub catch {
 216     my $pkg = shift;
 217     my $code = shift;
 218     my $clauses = shift || {};
 219     my $catch = $clauses->{'catch'} ||= [];
 220
 221     unshift @$catch,  $pkg, $code;
 222
 223     $clauses;
 224 }
 225
 226 # Object query methods
 227
 228 sub object {
 229     my $self = shift;
 230     exists $self->{'-object'} ? $self->{'-object'} : undef;
 231 }
 232
 233 sub file {
 234     my $self = shift;
 235     exists $self->{'-file'} ? $self->{'-file'} : undef;
 236 }
 237
 238 sub line {
 239     my $self = shift;
 240     exists $self->{'-line'} ? $self->{'-line'} : undef;
 241 }
 242
 243 sub text {
 244     my $self = shift;
 245     exists $self->{'-text'} ? $self->{'-text'} : undef;
 246 }
 247
 248 # overload methods
 249
 250 sub stringify {
 251     my $self = shift;
 252     defined $self->{'-text'} ? $self->{'-text'} : "Died";
 253 }
 254
 255 sub value {
 256     my $self = shift;
 257     exists $self->{'-value'} ? $self->{'-value'} : undef;
 258 }
 259
 260 package Error::Simple;
 261
 262 use vars qw($VERSION);
 263
 264 $VERSION = "0.17025";
 265
 266 @Error::Simple::ISA = qw(Error);
 267
 268 sub new {
 269     my $self  = shift;
 270     my $text  = "" . shift;
 271     my $value = shift;
 272     my(@args) = ();
 273
 274     local $Error::Depth = $Error::Depth + 1;
 275
 276     @args = ( -file => $1, -line => $2)
 277         if($text =~ s/\s+at\s+(\S+)\s+line\s+(\d+)(?:,\s*<[^>]*>\s+line\s+\d+)?\.?\n?$//s);
 278     push(@args, '-value', 0 + $value)
 279         if defined($value);
 280
 281     $self->SUPER::new(-text => $text, @args);
 282 }
 283
 284 sub stringify {
 285     my $self = shift;
 286     my $text = $self->SUPER::stringify;
 287     $text .= sprintf(" at %s line %d.\n", $self->file, $self->line)
 288         unless($text =~ /\n$/s);
 289     $text;
 290 }
 291
 292 ##########################################################################
 293 ##########################################################################
 294
 295 # Inspired by code from Jesse Glick <jglick@sig.bsh.com> and
 296 # Peter Seibel <peter@weblogic.com>
 297
 298 package Error::subs;
 299
 300 use Exporter ();
 301 use vars qw(@EXPORT_OK @ISA %EXPORT_TAGS);
 302
 303 @EXPORT_OK   = qw(try with finally except otherwise);
 304 %EXPORT_TAGS = (try => \@EXPORT_OK);
 305
 306 @ISA = qw(Exporter);
 307
 308 sub run_clauses ($$$\@) {
 309     my($clauses,$err,$wantarray,$result) = @_;
 310     my $code = undef;
 311
 312     $err = $Error::ObjectifyCallback->({'text' =>$err}) unless ref($err);
 313
 314     CATCH: {
 315
 316         # catch
 317         my $catch;
 318         if(defined($catch = $clauses->{'catch'})) {
 319             my $i = 0;
 320
 321             CATCHLOOP:
 322             for( ; $i < @$catch ; $i += 2) {
 323                 my $pkg = $catch->[$i];
 324                 unless(defined $pkg) {
 325                     #except
 326                     splice(@$catch,$i,2,$catch->[$i+1]->($err));
 327                     $i -= 2;
 328                     next CATCHLOOP;
 329                 }
 330                 elsif(Scalar::Util::blessed($err) && $err->isa($pkg)) {
 331                     $code = $catch->[$i+1];
 332                     while(1) {
 333                         my $more = 0;
 334                         local($Error::THROWN, $@);
 335                         my $ok = eval {
 336                             $@ = $err;
 337                             if($wantarray) {
 338                                 @{$result} = $code->($err,\$more);
 339                             }
 340                             elsif(defined($wantarray)) {
 341                                 @{$result} = ();
 342                                 $result->[0] = $code->($err,\$more);
 343                             }
 344                             else {
 345                                 $code->($err,\$more);
 346                             }
 347                             1;
 348                         };
 349                         if( $ok ) {
 350                             next CATCHLOOP if $more;
 351                             undef $err;
 352                         }
 353                         else {
 354                             $err = $@ || $Error::THROWN;
 355                                 $err = $Error::ObjectifyCallback->({'text' =>$err})
 356                                         unless ref($err);
 357                         }
 358                         last CATCH;
 359                     };
 360                 }
 361             }
 362         }
 363
 364         # otherwise
 365         my $owise;
 366         if(defined($owise = $clauses->{'otherwise'})) {
 367             my $code = $clauses->{'otherwise'};
 368             my $more = 0;
 369         local($Error::THROWN, $@);
 370             my $ok = eval {
 371                 $@ = $err;
 372                 if($wantarray) {
 373                     @{$result} = $code->($err,\$more);
 374                 }
 375                 elsif(defined($wantarray)) {
 376                     @{$result} = ();
 377                     $result->[0] = $code->($err,\$more);
 378                 }
 379                 else {
 380                     $code->($err,\$more);
 381                 }
 382                 1;
 383             };
 384             if( $ok ) {
 385                 undef $err;
 386             }
 387             else {
 388                 $err = $@ || $Error::THROWN;
 389
 390                 $err = $Error::ObjectifyCallback->({'text' =>$err})
 391                         unless ref($err);
 392             }
 393         }
 394     }
 395     $err;
 396 }
 397
 398 sub try (&;$) {
 399     my $try = shift;
 400     my $clauses = @_ ? shift : {};
 401     my $ok = 0;
 402     my $err = undef;
 403     my @result = ();
 404
 405     unshift @Error::STACK, $clauses;
 406
 407     my $wantarray = wantarray();
 408
 409     do {
 410         local $Error::THROWN = undef;
 411         local $@ = undef;
 412
 413         $ok = eval {
 414             if($wantarray) {
 415                 @result = $try->();
 416             }
 417             elsif(defined $wantarray) {
 418                 $result[0] = $try->();
 419             }
 420             else {
 421                 $try->();
 422             }
 423             1;
 424         };
 425
 426         $err = $@ || $Error::THROWN
 427             unless $ok;
 428     };
 429
 430     shift @Error::STACK;
 431
 432     $err = run_clauses($clauses,$err,wantarray,@result)
 433     unless($ok);
 434
 435     $clauses->{'finally'}->()
 436         if(defined($clauses->{'finally'}));
 437
 438     if (defined($err))
 439     {
 440         if (Scalar::Util::blessed($err) && $err->can('throw'))
 441         {
 442             throw $err;
 443         }
 444         else
 445         {
 446             die $err;
 447         }
 448     }
 449
 450     wantarray ? @result : $result[0];
 451 }
 452
 453 # Each clause adds a sub to the list of clauses. The finally clause is
 454 # always the last, and the otherwise clause is always added just before
 455 # the finally clause.
 456 #
 457 # All clauses, except the finally clause, add a sub which takes one argument
 458 # this argument will be the error being thrown. The sub will return a code ref
 459 # if that clause can handle that error, otherwise undef is returned.
 460 #
 461 # The otherwise clause adds a sub which unconditionally returns the users
 462 # code reference, this is why it is forced to be last.
 463 #
 464 # The catch clause is defined in Error.pm, as the syntax causes it to
 465 # be called as a method
 466
 467 sub with (&;$) {
 468     @_
 469 }
 470
 471 sub finally (&) {
 472     my $code = shift;
 473     my $clauses = { 'finally' => $code };
 474     $clauses;
 475 }
 476
 477 # The except clause is a block which returns a hashref or a list of
 478 # key-value pairs, where the keys are the classes and the values are subs.
 479
 480 sub except (&;$) {
 481     my $code = shift;
 482     my $clauses = shift || {};
 483     my $catch = $clauses->{'catch'} ||= [];
 484
 485     my $sub = sub {
 486         my $ref;
 487         my(@array) = $code->($_[0]);
 488         if(@array == 1 && ref($array[0])) {
 489             $ref = $array[0];
 490             $ref = [ %$ref ]
 491                 if(UNIVERSAL::isa($ref,'HASH'));
 492         }
 493         else {
 494             $ref = \@array;
 495         }
 496         @$ref
 497     };
 498
 499     unshift @{$catch}, undef, $sub;
 500
 501     $clauses;
 502 }
 503
 504 sub otherwise (&;$) {
 505     my $code = shift;
 506     my $clauses = shift || {};
 507
 508     if(exists $clauses->{'otherwise'}) {
 509         require Carp;
 510         Carp::croak("Multiple otherwise clauses");
 511     }
 512
 513     $clauses->{'otherwise'} = $code;
 514
 515     $clauses;
 516 }
 517
 518 1;
 519
 520 package Error::WarnDie;
 521
 522 sub gen_callstack($)
 523 {
 524     my ( $start ) = @_;
 525
 526     require Carp;
 527     local $Carp::CarpLevel = $start;
 528     my $trace = Carp::longmess("");
 529     # Remove try calls from the trace
 530     $trace =~ s/(\n\s+\S+__ANON__[^\n]+)?\n\s+eval[^\n]+\n\s+Error::subs::try[^\n]+(?=\n)//sog;
 531     $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;
 532     my @callstack = split( m/\n/, $trace );
 533     return @callstack;
 534 }
 535
 536 my $old_DIE;
 537 my $old_WARN;
 538
 539 sub DEATH
 540 {
 541     my ( $e ) = @_;
 542
 543     local $SIG{__DIE__} = $old_DIE if( defined $old_DIE );
 544
 545     die @_ if $^S;
 546
 547     my ( $etype, $message, $location, @callstack );
 548     if ( ref($e) && $e->isa( "Error" ) ) {
 549         $etype = "exception of type " . ref( $e );
 550         $message = $e->text;
 551         $location = $e->file . ":" . $e->line;
 552         @callstack = split( m/\n/, $e->stacktrace );
 553     }
 554     else {
 555         # Don't apply subsequent layer of message formatting
 556         die $e if( $e =~ m/^\nUnhandled perl error caught at toplevel:\n\n/ );
 557         $etype = "perl error";
 558         my $stackdepth = 0;
 559         while( caller( $stackdepth ) =~ m/^Error(?:$|::)/ ) {
 560             $stackdepth++
 561         }
 562
 563         @callstack = gen_callstack( $stackdepth + 1 );
 564
 565         $message = "$e";
 566         chomp $message;
 567
 568         if ( $message =~ s/ at (.*?) line (\d+)\.$// ) {
 569             $location = $1 . ":" . $2;
 570         }
 571         else {
 572             my @caller = caller( $stackdepth );
 573             $location = $caller[1] . ":" . $caller[2];
 574         }
 575     }
 576
 577     shift @callstack;
 578     # Do it this way in case there are no elements; we don't print a spurious \n
 579     my $callstack = join( "", map { "$_\n"} @callstack );
 580
 581     die "\nUnhandled $etype caught at toplevel:\n\n  $message\n\nThrown from: $location\n\nFull stack trace:\n\n$callstack\n";
 582 }
 583
 584 sub TAXES
 585 {
 586     my ( $message ) = @_;
 587
 588     local $SIG{__WARN__} = $old_WARN if( defined $old_WARN );
 589
 590     $message =~ s/ at .*? line \d+\.$//;
 591     chomp $message;
 592
 593     my @callstack = gen_callstack( 1 );
 594     my $location = shift @callstack;
 595
 596     # $location already starts in a leading space
 597     $message .= $location;
 598
 599     # Do it this way in case there are no elements; we don't print a spurious \n
 600     my $callstack = join( "", map { "$_\n"} @callstack );
 601
 602     warn "$message:\n$callstack";
 603 }
 604
 605 sub import
 606 {
 607     $old_DIE  = $SIG{__DIE__};
 608     $old_WARN = $SIG{__WARN__};
 609
 610     $SIG{__DIE__}  = \&DEATH;
 611     $SIG{__WARN__} = \&TAXES;
 612 }
 613
 614 1;
 615
 616 __END__
 617
 618 =head1 NAME
 619
 620 Error - Error/exception handling in an OO-ish way
 621
 622 =head1 WARNING
 623
 624 Using the "Error" module is B<no longer recommended> due to the black-magical
 625 nature of its syntactic sugar, which often tends to break. Its maintainers
 626 have stopped actively writing code that uses it, and discourage people
 627 from doing so. See the "SEE ALSO" section below for better recommendations.
 628
 629 =head1 SYNOPSIS
 630
 631     use Error qw(:try);
 632
 633     throw Error::Simple( "A simple error");
 634
 635     sub xyz {
 636         ...
 637         record Error::Simple("A simple error")
 638             and return;
 639     }
 640
 641     unlink($file) or throw Error::Simple("$file: $!",$!);
 642
 643     try {
 644         do_some_stuff();
 645         die "error!" if $condition;
 646         throw Error::Simple "Oops!" if $other_condition;
 647     }
 648     catch Error::IO with {
 649         my $E = shift;
 650         print STDERR "File ", $E->{'-file'}, " had a problem\n";
 651     }
 652     except {
 653         my $E = shift;
 654         my $general_handler=sub {send_message $E->{-description}};
 655         return {
 656             UserException1 => $general_handler,
 657             UserException2 => $general_handler
 658         };
 659     }
 660     otherwise {
 661         print STDERR "Well I don't know what to say\n";
 662     }
 663     finally {
 664         close_the_garage_door_already(); # Should be reliable
 665     }; # Don't forget the trailing ; or you might be surprised
 666
 667 =head1 DESCRIPTION
 668
 669 The C<Error> package provides two interfaces. Firstly C<Error> provides
 670 a procedural interface to exception handling. Secondly C<Error> is a
 671 base class for errors/exceptions that can either be thrown, for
 672 subsequent catch, or can simply be recorded.
 673
 674 Errors in the class C<Error> should not be thrown directly, but the
 675 user should throw errors from a sub-class of C<Error>.
 676
 677 =head1 PROCEDURAL INTERFACE
 678
 679 C<Error> exports subroutines to perform exception handling. These will
 680 be exported if the C<:try> tag is used in the C<use> line.
 681
 682 =over 4
 683
 684 =item try BLOCK CLAUSES
 685
 686 C<try> is the main subroutine called by the user. All other subroutines
 687 exported are clauses to the try subroutine.
 688
 689 The BLOCK will be evaluated and, if no error is throw, try will return
 690 the result of the block.
 691
 692 C<CLAUSES> are the subroutines below, which describe what to do in the
 693 event of an error being thrown within BLOCK.
 694
 695 =item catch CLASS with BLOCK
 696
 697 This clauses will cause all errors that satisfy C<$err-E<gt>isa(CLASS)>
 698 to be caught and handled by evaluating C<BLOCK>.
 699
 700 C<BLOCK> will be passed two arguments. The first will be the error
 701 being thrown. The second is a reference to a scalar variable. If this
 702 variable is set by the catch block then, on return from the catch
 703 block, try will continue processing as if the catch block was never
 704 found. The error will also be available in C<$@>.
 705
 706 To propagate the error the catch block may call C<$err-E<gt>throw>
 707
 708 If the scalar reference by the second argument is not set, and the
 709 error is not thrown. Then the current try block will return with the
 710 result from the catch block.
 711
 712 =item except BLOCK
 713
 714 When C<try> is looking for a handler, if an except clause is found
 715 C<BLOCK> is evaluated. The return value from this block should be a
 716 HASHREF or a list of key-value pairs, where the keys are class names
 717 and the values are CODE references for the handler of errors of that
 718 type.
 719
 720 =item otherwise BLOCK
 721
 722 Catch any error by executing the code in C<BLOCK>
 723
 724 When evaluated C<BLOCK> will be passed one argument, which will be the
 725 error being processed. The error will also be available in C<$@>.
 726
 727 Only one otherwise block may be specified per try block
 728
 729 =item finally BLOCK
 730
 731 Execute the code in C<BLOCK> either after the code in the try block has
 732 successfully completed, or if the try block throws an error then
 733 C<BLOCK> will be executed after the handler has completed.
 734
 735 If the handler throws an error then the error will be caught, the
 736 finally block will be executed and the error will be re-thrown.
 737
 738 Only one finally block may be specified per try block
 739
 740 =back
 741
 742 =head1 COMPATIBILITY
 743
 744 L<Moose> exports a keyword called C<with> which clashes with Error's. This
 745 example returns a prototype mismatch error:
 746
 747     package MyTest;
 748
 749     use warnings;
 750     use Moose;
 751     use Error qw(:try);
 752
 753 (Thanks to C<maik.hentsche@amd.com> for the report.).
 754
 755 =head1 CLASS INTERFACE
 756
 757 =head2 CONSTRUCTORS
 758
 759 The C<Error> object is implemented as a HASH. This HASH is initialized
 760 with the arguments that are passed to it's constructor. The elements
 761 that are used by, or are retrievable by the C<Error> class are listed
 762 below, other classes may add to these.
 763
 764         -file
 765         -line
 766         -text
 767         -value
 768         -object
 769
 770 If C<-file> or C<-line> are not specified in the constructor arguments
 771 then these will be initialized with the file name and line number where
 772 the constructor was called from.
 773
 774 If the error is associated with an object then the object should be
 775 passed as the C<-object> argument. This will allow the C<Error> package
 776 to associate the error with the object.
 777
 778 The C<Error> package remembers the last error created, and also the
 779 last error associated with a package. This could either be the last
 780 error created by a sub in that package, or the last error which passed
 781 an object blessed into that package as the C<-object> argument.
 782
 783 =over 4
 784
 785 =item Error->new()
 786
 787 See the Error::Simple documentation.
 788
 789 =item throw ( [ ARGS ] )
 790
 791 Create a new C<Error> object and throw an error, which will be caught
 792 by a surrounding C<try> block, if there is one. Otherwise it will cause
 793 the program to exit.
 794
 795 C<throw> may also be called on an existing error to re-throw it.
 796
 797 =item with ( [ ARGS ] )
 798
 799 Create a new C<Error> object and returns it. This is defined for
 800 syntactic sugar, eg
 801
 802     die with Some::Error ( ... );
 803
 804 =item record ( [ ARGS ] )
 805
 806 Create a new C<Error> object and returns it. This is defined for
 807 syntactic sugar, eg
 808
 809     record Some::Error ( ... )
 810         and return;
 811
 812 =back
 813
 814 =head2 STATIC METHODS
 815
 816 =over 4
 817
 818 =item prior ( [ PACKAGE ] )
 819
 820 Return the last error created, or the last error associated with
 821 C<PACKAGE>
 822
 823 =item flush ( [ PACKAGE ] )
 824
 825 Flush the last error created, or the last error associated with
 826 C<PACKAGE>.It is necessary to clear the error stack before exiting the
 827 package or uncaught errors generated using C<record> will be reported.
 828
 829      $Error->flush;
 830
 831 =cut
 832
 833 =back
 834
 835 =head2 OBJECT METHODS
 836
 837 =over 4
 838
 839 =item stacktrace
 840
 841 If the variable C<$Error::Debug> was non-zero when the error was
 842 created, then C<stacktrace> returns a string created by calling
 843 C<Carp::longmess>. If the variable was zero the C<stacktrace> returns
 844 the text of the error appended with the filename and line number of
 845 where the error was created, providing the text does not end with a
 846 newline.
 847
 848 =item object
 849
 850 The object this error was associated with
 851
 852 =item file
 853
 854 The file where the constructor of this error was called from
 855
 856 =item line
 857
 858 The line where the constructor of this error was called from
 859
 860 =item text
 861
 862 The text of the error
 863
 864 =item $err->associate($obj)
 865
 866 Associates an error with an object to allow error propagation. I.e:
 867
 868     $ber->encode(...) or
 869         return Error->prior($ber)->associate($ldap);
 870
 871 =back
 872
 873 =head2 OVERLOAD METHODS
 874
 875 =over 4
 876
 877 =item stringify
 878
 879 A method that converts the object into a string. This method may simply
 880 return the same as the C<text> method, or it may append more
 881 information. For example the file name and line number.
 882
 883 By default this method returns the C<-text> argument that was passed to
 884 the constructor, or the string C<"Died"> if none was given.
 885
 886 =item value
 887
 888 A method that will return a value that can be associated with the
 889 error. For example if an error was created due to the failure of a
 890 system call, then this may return the numeric value of C<$!> at the
 891 time.
 892
 893 By default this method returns the C<-value> argument that was passed
 894 to the constructor.
 895
 896 =back
 897
 898 =head1 PRE-DEFINED ERROR CLASSES
 899
 900 =head2 Error::Simple
 901
 902 This class can be used to hold simple error strings and values. It's
 903 constructor takes two arguments. The first is a text value, the second
 904 is a numeric value. These values are what will be returned by the
 905 overload methods.
 906
 907 If the text value ends with C<at file line 1> as $@ strings do, then
 908 this information will be used to set the C<-file> and C<-line> arguments
 909 of the error object.
 910
 911 This class is used internally if an eval'd block die's with an error
 912 that is a plain string. (Unless C<$Error::ObjectifyCallback> is modified)
 913
 914
 915 =head1 $Error::ObjectifyCallback
 916
 917 This variable holds a reference to a subroutine that converts errors that
 918 are plain strings to objects. It is used by Error.pm to convert textual
 919 errors to objects, and can be overridden by the user.
 920
 921 It accepts a single argument which is a hash reference to named parameters.
 922 Currently the only named parameter passed is C<'text'> which is the text
 923 of the error, but others may be available in the future.
 924
 925 For example the following code will cause Error.pm to throw objects of the
 926 class MyError::Bar by default:
 927
 928     sub throw_MyError_Bar
 929     {
 930         my $args = shift;
 931         my $err = MyError::Bar->new();
 932         $err->{'MyBarText'} = $args->{'text'};
 933         return $err;
 934     }
 935
 936     {
 937         local $Error::ObjectifyCallback = \&throw_MyError_Bar;
 938
 939         # Error handling here.
 940     }
 941
 942 =cut
 943
 944 =head1 MESSAGE HANDLERS
 945
 946 C<Error> also provides handlers to extend the output of the C<warn()> perl
 947 function, and to handle the printing of a thrown C<Error> that is not caught
 948 or otherwise handled. These are not installed by default, but are requested
 949 using the C<:warndie> tag in the C<use> line.
 950
 951  use Error qw( :warndie );
 952
 953 These new error handlers are installed in C<$SIG{__WARN__}> and
 954 C<$SIG{__DIE__}>. If these handlers are already defined when the tag is
 955 imported, the old values are stored, and used during the new code. Thus, to
 956 arrange for custom handling of warnings and errors, you will need to perform
 957 something like the following:
 958
 959  BEGIN {
 960    $SIG{__WARN__} = sub {
 961      print STDERR "My special warning handler: $_[0]"
 962    };
 963  }
 964
 965  use Error qw( :warndie );
 966
 967 Note that setting C<$SIG{__WARN__}> after the C<:warndie> tag has been
 968 imported will overwrite the handler that C<Error> provides. If this cannot be
 969 avoided, then the tag can be explicitly C<import>ed later
 970
 971  use Error;
 972
 973  $SIG{__WARN__} = ...;
 974
 975  import Error qw( :warndie );
 976
 977 =head2 EXAMPLE
 978
 979 The C<__DIE__> handler turns messages such as
 980
 981  Can't call method "foo" on an undefined value at examples/warndie.pl line 16.
 982
 983 into
 984
 985  Unhandled perl error caught at toplevel:
 986
 987    Can't call method "foo" on an undefined value
 988
 989  Thrown from: examples/warndie.pl:16
 990
 991  Full stack trace:
 992
 993          main::inner('undef') called at examples/warndie.pl line 20
 994          main::outer('undef') called at examples/warndie.pl line 23
 995
 996 =cut
 997
 998 =head1 SEE ALSO
 999
1000 See L<Exception::Class> for a different module providing Object-Oriented
1001 exception handling, along with a convenient syntax for declaring hierarchies
1002 for them. It doesn't provide Error's syntactic sugar of C<try { ... }>,
1003 C<catch { ... }>, etc. which may be a good thing or a bad thing based
1004 on what you want. (Because Error's syntactic sugar tends to break.)
1005
1006 L<Error::Exception> aims to combine L<Error> and L<Exception::Class>
1007 "with correct stringification".
1008
1009 L<TryCatch> and L<Try::Tiny> are similar in concept to Error.pm only providing
1010 a syntax that hopefully breaks less.
1011
1012 =head1 KNOWN BUGS
1013
1014 None, but that does not mean there are not any.
1015
1016 =head1 AUTHORS
1017
1018 Graham Barr <gbarr@pobox.com>
1019
1020 The code that inspired me to write this was originally written by
1021 Peter Seibel <peter@weblogic.com> and adapted by Jesse Glick
1022 <jglick@sig.bsh.com>.
1023
1024 C<:warndie> handlers added by Paul Evans <leonerd@leonerd.org.uk>
1025
1026 =head1 MAINTAINER
1027
1028 Shlomi Fish, L<https://www.shlomifish.org/> .
1029
1030 =head1 PAST MAINTAINERS
1031
1032 Arun Kumar U <u_arunkumar@yahoo.com>
1033
1034 =head1 COPYRIGHT
1035
1036 Copyright (c) 1997-8  Graham Barr. All rights reserved.
1037 This program is free software; you can redistribute it and/or modify it
1038 under the same terms as Perl itself.
1039
1040 =cut