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 12package Error; 13 14use strict; 15use vars qw($VERSION); 16use5.004; 17 18$VERSION="0.15009"; 19 20use overload ( 21'""'=>'stringify', 22'0+'=>'value', 23'bool'=>sub{return1; }, 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 32my$LAST;# Last error created 33my%ERROR;# Last error associated with package 34 35sub throw_Error_Simple 36{ 37my$args=shift; 38return Error::Simple->new($args->{'text'}); 39} 40 41$Error::ObjectifyCallback = \&throw_Error_Simple; 42 43 44# Exported subs are defined in Error::subs 45 46use Scalar::Util (); 47 48sub import { 49shift; 50local$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 57sub prior { 58shift;# ignore 59 60return$LASTunless@_; 61 62my$pkg=shift; 63returnexists$ERROR{$pkg} ?$ERROR{$pkg} :undef 64unlessref($pkg); 65 66my$obj=$pkg; 67my$err=undef; 68if($obj->isa('HASH')) { 69$err=$obj->{'__Error__'} 70ifexists$obj->{'__Error__'}; 71} 72elsif($obj->isa('GLOB')) { 73$err= ${*$obj}{'__Error__'} 74ifexists${*$obj}{'__Error__'}; 75} 76 77$err; 78} 79 80sub flush { 81shift;#ignore 82 83unless(@_) { 84$LAST=undef; 85return; 86} 87 88my$pkg=shift; 89return unlessref($pkg); 90 91undef$ERROR{$pkg}ifdefined$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 98sub stacktrace { 99my$self=shift; 100 101return$self->{'-stacktrace'} 102ifexists$self->{'-stacktrace'}; 103 104my$text=exists$self->{'-text'} ?$self->{'-text'} :"Died"; 105 106$text.=sprintf(" at%sline%d.\n",$self->file,$self->line) 107unless($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 117sub associate { 118my$err=shift; 119my$obj=shift; 120 121return unlessref($obj); 122 123if($obj->isa('HASH')) { 124$obj->{'__Error__'} =$err; 125} 126elsif($obj->isa('GLOB')) { 127${*$obj}{'__Error__'} =$err; 128} 129$obj=ref($obj); 130$ERROR{ref($obj) } =$err; 131 132return; 133} 134 135sub new { 136my$self=shift; 137my($pkg,$file,$line) =caller($Error::Depth); 138 139my$err=bless{ 140'-package'=>$pkg, 141'-file'=>$file, 142'-line'=>$line, 143@_ 144},$self; 145 146$err->associate($err->{'-object'}) 147if(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 152if($Error::Debug) { 153require Carp; 154local$Carp::CarpLevel =$Error::Depth; 155my$text=defined($err->{'-text'}) ?$err->{'-text'} :"Error"; 156my$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 168sub throw { 169my$self=shift; 170local$Error::Depth =$Error::Depth +1; 171 172# if we are not rethrow-ing then create the object to throw 173$self=$self->new(@_)unlessref($self); 174 175die$Error::THROWN =$self; 176} 177 178# syntactic sugar for 179# 180# die with Error( ... ); 181 182sub with { 183my$self=shift; 184local$Error::Depth =$Error::Depth +1; 185 186$self->new(@_); 187} 188 189# syntactic sugar for 190# 191# record Error( ... ) and return; 192 193sub record { 194my$self=shift; 195local$Error::Depth =$Error::Depth +1; 196 197$self->new(@_); 198} 199 200# catch clause for 201# 202# try { ... } catch CLASS with { ... } 203 204sub catch { 205my$pkg=shift; 206my$code=shift; 207my$clauses=shift|| {}; 208my$catch=$clauses->{'catch'} ||= []; 209 210unshift@$catch,$pkg,$code; 211 212$clauses; 213} 214 215# Object query methods 216 217sub object { 218my$self=shift; 219exists$self->{'-object'} ?$self->{'-object'} :undef; 220} 221 222sub file { 223my$self=shift; 224exists$self->{'-file'} ?$self->{'-file'} :undef; 225} 226 227sub line { 228my$self=shift; 229exists$self->{'-line'} ?$self->{'-line'} :undef; 230} 231 232sub text { 233my$self=shift; 234exists$self->{'-text'} ?$self->{'-text'} :undef; 235} 236 237# overload methods 238 239sub stringify { 240my$self=shift; 241defined$self->{'-text'} ?$self->{'-text'} :"Died"; 242} 243 244sub value { 245my$self=shift; 246exists$self->{'-value'} ?$self->{'-value'} :undef; 247} 248 249package Error::Simple; 250 251@Error::Simple::ISA =qw(Error); 252 253sub new { 254my$self=shift; 255my$text="".shift; 256my$value=shift; 257my(@args) = (); 258 259local$Error::Depth =$Error::Depth +1; 260 261@args= ( -file =>$1, -line =>$2) 262if($text=~s/\s+at\s+(\S+)\s+line\s+(\d+)(?:,\s*<[^>]*>\s+line\s+\d+)?\.?\n?$//s); 263push(@args,'-value',0+$value) 264ifdefined($value); 265 266$self->SUPER::new(-text =>$text,@args); 267} 268 269sub stringify { 270my$self=shift; 271my$text=$self->SUPER::stringify; 272$text.=sprintf(" at%sline%d.\n",$self->file,$self->line) 273unless($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 283package Error::subs; 284 285use Exporter (); 286use 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 293sub run_clauses ($$$\@) { 294my($clauses,$err,$wantarray,$result) =@_; 295my$code=undef; 296 297$err=$Error::ObjectifyCallback->({'text'=>$err})unlessref($err); 298 299CATCH: { 300 301# catch 302my$catch; 303if(defined($catch=$clauses->{'catch'})) { 304my$i=0; 305 306 CATCHLOOP: 307for( ;$i<@$catch;$i+=2) { 308my$pkg=$catch->[$i]; 309unless(defined$pkg) { 310#except 311splice(@$catch,$i,2,$catch->[$i+1]->()); 312$i-=2; 313next CATCHLOOP; 314} 315elsif(Scalar::Util::blessed($err) &&$err->isa($pkg)) { 316$code=$catch->[$i+1]; 317while(1) { 318my$more=0; 319local($Error::THROWN); 320my$ok=eval{ 321if($wantarray) { 322@{$result} =$code->($err,\$more); 323} 324elsif(defined($wantarray)) { 325@{$result} = (); 326$result->[0] =$code->($err,\$more); 327} 328else{ 329$code->($err,\$more); 330} 3311; 332}; 333if($ok) { 334next CATCHLOOP if$more; 335undef$err; 336} 337else{ 338$err=defined($Error::THROWN) 339?$Error::THROWN :$@; 340$err=$Error::ObjectifyCallback->({'text'=>$err}) 341unlessref($err); 342} 343last CATCH; 344}; 345} 346} 347} 348 349# otherwise 350my$owise; 351if(defined($owise=$clauses->{'otherwise'})) { 352my$code=$clauses->{'otherwise'}; 353my$more=0; 354my$ok=eval{ 355if($wantarray) { 356@{$result} =$code->($err,\$more); 357} 358elsif(defined($wantarray)) { 359@{$result} = (); 360$result->[0] =$code->($err,\$more); 361} 362else{ 363$code->($err,\$more); 364} 3651; 366}; 367if($ok) { 368undef$err; 369} 370else{ 371$err=defined($Error::THROWN) 372?$Error::THROWN :$@; 373 374$err=$Error::ObjectifyCallback->({'text'=>$err}) 375unlessref($err); 376} 377} 378} 379$err; 380} 381 382subtry(&;$) { 383my$try=shift; 384my$clauses=@_?shift: {}; 385my$ok=0; 386my$err=undef; 387my@result= (); 388 389unshift@Error::STACK,$clauses; 390 391my$wantarray=wantarray(); 392 393do{ 394local$Error::THROWN =undef; 395local$@=undef; 396 397$ok=eval{ 398if($wantarray) { 399@result=$try->(); 400} 401elsif(defined$wantarray) { 402$result[0] =$try->(); 403} 404else{ 405$try->(); 406} 4071; 408}; 409 410$err=defined($Error::THROWN) ?$Error::THROWN :$@ 411unless$ok; 412}; 413 414shift@Error::STACK; 415 416$err= run_clauses($clauses,$err,wantarray,@result) 417unless($ok); 418 419$clauses->{'finally'}->() 420if(defined($clauses->{'finally'})); 421 422if(defined($err)) 423{ 424if(Scalar::Util::blessed($err) &&$err->can('throw')) 425{ 426 throw $err; 427} 428else 429{ 430die$err; 431} 432} 433 434wantarray?@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 451sub with (&;$) { 452@_ 453} 454 455sub finally (&) { 456my$code=shift; 457my$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 464sub except (&;$) { 465my$code=shift; 466my$clauses=shift|| {}; 467my$catch=$clauses->{'catch'} ||= []; 468 469my$sub=sub{ 470my$ref; 471my(@array) =$code->($_[0]); 472if(@array==1&&ref($array[0])) { 473$ref=$array[0]; 474$ref= [%$ref] 475if(UNIVERSAL::isa($ref,'HASH')); 476} 477else{ 478$ref= \@array; 479} 480@$ref 481}; 482 483unshift@{$catch},undef,$sub; 484 485$clauses; 486} 487 488sub otherwise (&;$) { 489my$code=shift; 490my$clauses=shift|| {}; 491 492if(exists$clauses->{'otherwise'}) { 493require Carp; 494 Carp::croak("Multiple otherwise clauses"); 495} 496 497$clauses->{'otherwise'} =$code; 498 499$clauses; 500} 501 5021; 503__END__ 504 505=head1 NAME 506 507Error - 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 549The C<Error> package provides two interfaces. Firstly C<Error> provides 550a procedural interface to exception handling. Secondly C<Error> is a 551base class for errors/exceptions that can either be thrown, for 552subsequent catch, or can simply be recorded. 553 554Errors in the class C<Error> should not be thrown directly, but the 555user should throw errors from a sub-class of C<Error>. 556 557=head1 PROCEDURAL INTERFACE 558 559C<Error> exports subroutines to perform exception handling. These will 560be exported if the C<:try> tag is used in the C<use> line. 561 562=over 4 563 564=item try BLOCK CLAUSES 565 566C<try> is the main subroutine called by the user. All other subroutines 567exported are clauses to the try subroutine. 568 569The BLOCK will be evaluated and, if no error is throw, try will return 570the result of the block. 571 572C<CLAUSES> are the subroutines below, which describe what to do in the 573event of an error being thrown within BLOCK. 574 575=item catch CLASS with BLOCK 576 577This clauses will cause all errors that satisfy C<$err-E<gt>isa(CLASS)> 578to be caught and handled by evaluating C<BLOCK>. 579 580C<BLOCK> will be passed two arguments. The first will be the error 581being thrown. The second is a reference to a scalar variable. If this 582variable is set by the catch block then, on return from the catch 583block, try will continue processing as if the catch block was never 584found. 585 586To propagate the error the catch block may call C<$err-E<gt>throw> 587 588If the scalar reference by the second argument is not set, and the 589error is not thrown. Then the current try block will return with the 590result from the catch block. 591 592=item except BLOCK 593 594When C<try> is looking for a handler, if an except clause is found 595C<BLOCK> is evaluated. The return value from this block should be a 596HASHREF or a list of key-value pairs, where the keys are class names 597and the values are CODE references for the handler of errors of that 598type. 599 600=item otherwise BLOCK 601 602Catch any error by executing the code in C<BLOCK> 603 604When evaluated C<BLOCK> will be passed one argument, which will be the 605error being processed. 606 607Only one otherwise block may be specified per try block 608 609=item finally BLOCK 610 611Execute the code in C<BLOCK> either after the code in the try block has 612successfully completed, or if the try block throws an error then 613C<BLOCK> will be executed after the handler has completed. 614 615If the handler throws an error then the error will be caught, the 616finally block will be executed and the error will be re-thrown. 617 618Only one finally block may be specified per try block 619 620=back 621 622=head1 CLASS INTERFACE 623 624=head2 CONSTRUCTORS 625 626The C<Error> object is implemented as a HASH. This HASH is initialized 627with the arguments that are passed to it's constructor. The elements 628that are used by, or are retrievable by the C<Error> class are listed 629below, other classes may add to these. 630 631 -file 632 -line 633 -text 634 -value 635 -object 636 637If C<-file> or C<-line> are not specified in the constructor arguments 638then these will be initialized with the file name and line number where 639the constructor was called from. 640 641If the error is associated with an object then the object should be 642passed as the C<-object> argument. This will allow the C<Error> package 643to associate the error with the object. 644 645The C<Error> package remembers the last error created, and also the 646last error associated with a package. This could either be the last 647error created by a sub in that package, or the last error which passed 648an object blessed into that package as the C<-object> argument. 649 650=over 4 651 652=item throw ( [ ARGS ] ) 653 654Create a new C<Error> object and throw an error, which will be caught 655by a surrounding C<try> block, if there is one. Otherwise it will cause 656the program to exit. 657 658C<throw> may also be called on an existing error to re-throw it. 659 660=item with ( [ ARGS ] ) 661 662Create a new C<Error> object and returns it. This is defined for 663syntactic sugar, eg 664 665 die with Some::Error ( ... ); 666 667=item record ( [ ARGS ] ) 668 669Create a new C<Error> object and returns it. This is defined for 670syntactic 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 683Return the last error created, or the last error associated with 684C<PACKAGE> 685 686=item flush ( [ PACKAGE ] ) 687 688Flush the last error created, or the last error associated with 689C<PACKAGE>.It is necessary to clear the error stack before exiting the 690package 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 704If the variable C<$Error::Debug> was non-zero when the error was 705created, then C<stacktrace> returns a string created by calling 706C<Carp::longmess>. If the variable was zero the C<stacktrace> returns 707the text of the error appended with the filename and line number of 708where the error was created, providing the text does not end with a 709newline. 710 711=item object 712 713The object this error was associated with 714 715=item file 716 717The file where the constructor of this error was called from 718 719=item line 720 721The line where the constructor of this error was called from 722 723=item text 724 725The text of the error 726 727=back 728 729=head2 OVERLOAD METHODS 730 731=over 4 732 733=item stringify 734 735A method that converts the object into a string. This method may simply 736return the same as the C<text> method, or it may append more 737information. For example the file name and line number. 738 739By default this method returns the C<-text> argument that was passed to 740the constructor, or the string C<"Died"> if none was given. 741 742=item value 743 744A method that will return a value that can be associated with the 745error. For example if an error was created due to the failure of a 746system call, then this may return the numeric value of C<$!> at the 747time. 748 749By default this method returns the C<-value> argument that was passed 750to the constructor. 751 752=back 753 754=head1 PRE-DEFINED ERROR CLASSES 755 756=over 4 757 758=item Error::Simple 759 760This class can be used to hold simple error strings and values. It's 761constructor takes two arguments. The first is a text value, the second 762is a numeric value. These values are what will be returned by the 763overload methods. 764 765If the text value ends with C<at file line 1> as $@ strings do, then 766this infomation will be used to set the C<-file> and C<-line> arguments 767of the error object. 768 769This class is used internally if an eval'd block die's with an error 770that is a plain string. (Unless C<$Error::ObjectifyCallback> is modified) 771 772=back 773 774=head1 $Error::ObjectifyCallback 775 776This variable holds a reference to a subroutine that converts errors that 777are plain strings to objects. It is used by Error.pm to convert textual 778errors to objects, and can be overrided by the user. 779 780It accepts a single argument which is a hash reference to named parameters. 781Currently the only named parameter passed is C<'text'> which is the text 782of the error, but others may be available in the future. 783 784For example the following code will cause Error.pm to throw objects of the 785class 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 803None, but that does not mean there are not any. 804 805=head1 AUTHORS 806 807Graham Barr <gbarr@pobox.com> 808 809The code that inspired me to write this was originally written by 810Peter Seibel <peter@weblogic.com> and adapted by Jesse Glick 811<jglick@sig.bsh.com>. 812 813=head1 MAINTAINER 814 815Shlomi Fish <shlomif@iglu.org.il> 816 817=head1 PAST MAINTAINERS 818 819Arun Kumar U <u_arunkumar@yahoo.com> 820 821=cut