git

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
1041