PageRenderTime 68ms CodeModel.GetById 36ms RepoModel.GetById 0ms app.codeStats 0ms

/module/lib/Error.pm

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