This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
bump autodie version for blead test fix
[perl5.git] / cpan / autodie / lib / autodie / exception.pm
CommitLineData
0b09a93a
PF
1package autodie::exception;
2use 5.008;
3use strict;
4use warnings;
5use Carp qw(croak);
6
7our $DEBUG = 0;
8
9use overload
10 q{""} => "stringify"
11;
12
13# Overload smart-match only if we're using 5.10
14
15use if ($] >= 5.010), overload => '~~' => "matches";
16
c2512f8a 17our $VERSION = '2.1001';
0b09a93a
PF
18
19my $PACKAGE = __PACKAGE__; # Useful to have a scalar for hash keys.
20
21=head1 NAME
22
23autodie::exception - Exceptions from autodying functions.
24
25=head1 SYNOPSIS
26
27 eval {
28 use autodie;
29
30 open(my $fh, '<', 'some_file.txt');
31
32 ...
33 };
34
35 if (my $E = $@) {
36 say "Ooops! ",$E->caller," had problems: $@";
37 }
38
39
40=head1 DESCRIPTION
41
42When an L<autodie> enabled function fails, it generates an
43C<autodie::exception> object. This can be interrogated to
44determine further information about the error that occurred.
45
46This document is broken into two sections; those methods that
47are most useful to the end-developer, and those methods for
48anyone wishing to subclass or get very familiar with
49C<autodie::exception>.
50
51=head2 Common Methods
52
53These methods are intended to be used in the everyday dealing
54of exceptions.
55
56The following assume that the error has been copied into
57a separate scalar:
58
59 if ($E = $@) {
60 ...
61 }
62
63This is not required, but is recommended in case any code
64is called which may reset or alter C<$@>.
65
66=cut
67
68=head3 args
69
70 my $array_ref = $E->args;
71
72Provides a reference to the arguments passed to the subroutine
73that died.
74
75=cut
76
77sub args { return $_[0]->{$PACKAGE}{args}; }
78
79=head3 function
80
81 my $sub = $E->function;
82
83The subroutine (including package) that threw the exception.
84
85=cut
86
87sub function { return $_[0]->{$PACKAGE}{function}; }
88
89=head3 file
90
91 my $file = $E->file;
92
93The file in which the error occurred (eg, C<myscript.pl> or
94C<MyTest.pm>).
95
96=cut
97
98sub file { return $_[0]->{$PACKAGE}{file}; }
99
100=head3 package
101
102 my $package = $E->package;
103
104The package from which the exceptional subroutine was called.
105
106=cut
107
108sub package { return $_[0]->{$PACKAGE}{package}; }
109
110=head3 caller
111
112 my $caller = $E->caller;
113
114The subroutine that I<called> the exceptional code.
115
116=cut
117
118sub caller { return $_[0]->{$PACKAGE}{caller}; }
119
120=head3 line
121
122 my $line = $E->line;
123
124The line in C<< $E->file >> where the exceptional code was called.
125
126=cut
127
128sub line { return $_[0]->{$PACKAGE}{line}; }
129
eb8d423f
PF
130=head3 context
131
132 my $context = $E->context;
133
134The context in which the subroutine was called. This can be
135'list', 'scalar', or undefined (unknown). It will never be 'void', as
136C<autodie> always captures the return value in one way or another.
137
138=cut
139
140sub context { return $_[0]->{$PACKAGE}{context} }
141
142=head3 return
143
144 my $return_value = $E->return;
145
146The value(s) returned by the failed subroutine. When the subroutine
147was called in a list context, this will always be a reference to an
148array containing the results. When the subroutine was called in
149a scalar context, this will be the actual scalar returned.
150
151=cut
152
153sub return { return $_[0]->{$PACKAGE}{return} }
154
0b09a93a
PF
155=head3 errno
156
157 my $errno = $E->errno;
158
159The value of C<$!> at the time when the exception occurred.
160
161B<NOTE>: This method will leave the main C<autodie::exception> class
162and become part of a role in the future. You should only call
163C<errno> for exceptions where C<$!> would reasonably have been
164set on failure.
165
166=cut
167
168# TODO: Make errno part of a role. It doesn't make sense for
169# everything.
170
171sub errno { return $_[0]->{$PACKAGE}{errno}; }
172
7840a289
DM
173=head3 eval_error
174
175 my $old_eval_error = $E->eval_error;
176
177The contents of C<$@> immediately after autodie triggered an
178exception. This may be useful when dealing with modules such
179as L<Text::Balanced> that set (but do not throw) C<$@> on error.
180
181=cut
182
183sub eval_error { return $_[0]->{$PACKAGE}{eval_error}; }
184
0b09a93a
PF
185=head3 matches
186
187 if ( $e->matches('open') ) { ... }
188
189 if ( $e ~~ 'open' ) { ... }
190
191C<matches> is used to determine whether a
192given exception matches a particular role. On Perl 5.10,
193using smart-match (C<~~>) with an C<autodie::exception> object
194will use C<matches> underneath.
195
196An exception is considered to match a string if:
197
198=over 4
199
200=item *
201
202For a string not starting with a colon, the string exactly matches the
203package and subroutine that threw the exception. For example,
204C<MyModule::log>. If the string does not contain a package name,
205C<CORE::> is assumed.
206
207=item *
208
209For a string that does start with a colon, if the subroutine
210throwing the exception I<does> that behaviour. For example, the
211C<CORE::open> subroutine does C<:file>, C<:io> and C<:all>.
212
213See L<autodie/CATEGORIES> for futher information.
214
215=back
216
217=cut
218
219{
220 my (%cache);
221
222 sub matches {
223 my ($this, $that) = @_;
224
9b657a62 225 # TODO - Handle references
0b09a93a
PF
226 croak "UNIMPLEMENTED" if ref $that;
227
228 my $sub = $this->function;
229
230 if ($DEBUG) {
231 my $sub2 = $this->function;
232 warn "Smart-matching $that against $sub / $sub2\n";
233 }
234
235 # Direct subname match.
236 return 1 if $that eq $sub;
237 return 1 if $that !~ /:/ and "CORE::$that" eq $sub;
238 return 0 if $that !~ /^:/;
239
240 # Cached match / check tags.
241 require Fatal;
242
243 if (exists $cache{$sub}{$that}) {
244 return $cache{$sub}{$that};
245 }
246
247 # This rather awful looking line checks to see if our sub is in the
248 # list of expanded tags, caches it, and returns the result.
249
250 return $cache{$sub}{$that} = grep { $_ eq $sub } @{ $this->_expand_tag($that) };
251 }
252}
253
254# This exists primarily so that child classes can override or
255# augment it if they wish.
256
257sub _expand_tag {
258 my ($this, @args) = @_;
259
260 return Fatal->_expand_tag(@args);
261}
262
263=head2 Advanced methods
264
265The following methods, while usable from anywhere, are primarily
266intended for developers wishing to subclass C<autodie::exception>,
267write code that registers custom error messages, or otherwise
268work closely with the C<autodie::exception> model.
269
270=cut
271
272# The table below records customer formatters.
273# TODO - Should this be a package var instead?
274# TODO - Should these be in a completely different file, or
275# perhaps loaded on demand? Most formatters will never
276# get used in most programs.
277
278my %formatter_of = (
279 'CORE::close' => \&_format_close,
280 'CORE::open' => \&_format_open,
281 'CORE::dbmopen' => \&_format_dbmopen,
282 'CORE::flock' => \&_format_flock,
283);
284
285# TODO: Our tests only check LOCK_EX | LOCK_NB is properly
286# formatted. Try other combinations and ensure they work
287# correctly.
288
289sub _format_flock {
290 my ($this) = @_;
291
292 require Fcntl;
293
294 my $filehandle = $this->args->[0];
295 my $raw_mode = $this->args->[1];
296
297 my $mode_type;
298 my $lock_unlock;
299
300 if ($raw_mode & Fcntl::LOCK_EX() ) {
301 $lock_unlock = "lock";
302 $mode_type = "for exclusive access";
303 }
304 elsif ($raw_mode & Fcntl::LOCK_SH() ) {
305 $lock_unlock = "lock";
306 $mode_type = "for shared access";
307 }
308 elsif ($raw_mode & Fcntl::LOCK_UN() ) {
309 $lock_unlock = "unlock";
310 $mode_type = "";
311 }
312 else {
313 # I've got no idea what they're trying to do.
314 $lock_unlock = "lock";
315 $mode_type = "with mode $raw_mode";
316 }
317
318 my $cooked_filehandle;
319
320 if ($filehandle and not ref $filehandle) {
321
322 # A package filehandle with a name!
323
324 $cooked_filehandle = " $filehandle";
325 }
326 else {
327 # Otherwise we have a scalar filehandle.
328
329 $cooked_filehandle = '';
330
331 }
332
333 local $! = $this->errno;
334
335 return "Can't $lock_unlock filehandle$cooked_filehandle $mode_type: $!";
336
337}
338
339# Default formatter for CORE::dbmopen
340sub _format_dbmopen {
341 my ($this) = @_;
342 my @args = @{$this->args};
343
344 # TODO: Presently, $args flattens out the (usually empty) hash
345 # which is passed as the first argument to dbmopen. This is
346 # a bug in our args handling code (taking a reference to it would
347 # be better), but for the moment we'll just examine the end of
348 # our arguments list for message formatting.
349
350 my $mode = $args[-1];
351 my $file = $args[-2];
352
353 # If we have a mask, then display it in octal, not decimal.
354 # We don't do this if it already looks octalish, or doesn't
355 # look like a number.
356
357 if ($mode =~ /^[^\D0]\d+$/) {
358 $mode = sprintf("0%lo", $mode);
359 };
360
361 local $! = $this->errno;
362
363 return "Can't dbmopen(%hash, '$file', $mode): '$!'";
364}
365
366# Default formatter for CORE::close
367
368sub _format_close {
369 my ($this) = @_;
370 my $close_arg = $this->args->[0];
371
372 local $! = $this->errno;
373
374 # If we've got an old-style filehandle, mention it.
375 if ($close_arg and not ref $close_arg) {
376 return "Can't close filehandle '$close_arg': '$!'";
377 }
378
379 # TODO - This will probably produce an ugly error. Test and fix.
380 return "Can't close($close_arg) filehandle: '$!'";
381
382}
383
384# Default formatter for CORE::open
385
386use constant _FORMAT_OPEN => "Can't open '%s' for %s: '%s'";
387
388sub _format_open_with_mode {
389 my ($this, $mode, $file, $error) = @_;
390
391 my $wordy_mode;
392
393 if ($mode eq '<') { $wordy_mode = 'reading'; }
394 elsif ($mode eq '>') { $wordy_mode = 'writing'; }
395 elsif ($mode eq '>>') { $wordy_mode = 'appending'; }
396
397 return sprintf _FORMAT_OPEN, $file, $wordy_mode, $error if $wordy_mode;
398
399 Carp::confess("Internal autodie::exception error: Don't know how to format mode '$mode'.");
400
401}
402
403sub _format_open {
404 my ($this) = @_;
405
406 my @open_args = @{$this->args};
407
408 # Use the default formatter for single-arg and many-arg open
409 if (@open_args <= 1 or @open_args >= 4) {
410 return $this->format_default;
411 }
412
413 # For two arg open, we have to extract the mode
414 if (@open_args == 2) {
415 my ($fh, $file) = @open_args;
416
417 if (ref($fh) eq "GLOB") {
418 $fh = '$fh';
419 }
420
421 my ($mode) = $file =~ m{
422 ^\s* # Spaces before mode
423 (
424 (?> # Non-backtracking subexp.
425 < # Reading
426 |>>? # Writing/appending
427 )
428 )
429 [^&] # Not an ampersand (which means a dup)
430 }x;
431
02b13d1d
PF
432 if (not $mode) {
433 # Maybe it's a 2-arg open without any mode at all?
434 # Detect the most simple case for this, where our
435 # file consists only of word characters.
436
437 if ( $file =~ m{^\s*\w+\s*$} ) {
438 $mode = '<'
439 }
440 else {
441 # Otherwise, we've got no idea what's going on.
442 # Use the default.
443 return $this->format_default;
444 }
445 }
0b09a93a
PF
446
447 # Localising $! means perl make make it a pretty error for us.
448 local $! = $this->errno;
449
450 return $this->_format_open_with_mode($mode, $file, $!);
451 }
452
453 # Here we must be using three arg open.
454
455 my $file = $open_args[2];
456
457 local $! = $this->errno;
458
459 my $mode = $open_args[1];
460
461 local $@;
462
463 my $msg = eval { $this->_format_open_with_mode($mode, $file, $!); };
464
465 return $msg if $msg;
466
467 # Default message (for pipes and odd things)
468
469 return "Can't open '$file' with mode '$open_args[1]': '$!'";
470}
471
472=head3 register
473
474 autodie::exception->register( 'CORE::open' => \&mysub );
475
476The C<register> method allows for the registration of a message
477handler for a given subroutine. The full subroutine name including
478the package should be used.
479
480Registered message handlers will receive the C<autodie::exception>
481object as the first parameter.
482
483=cut
484
485sub register {
486 my ($class, $symbol, $handler) = @_;
487
488 croak "Incorrect call to autodie::register" if @_ != 3;
489
490 $formatter_of{$symbol} = $handler;
491
492}
493
494=head3 add_file_and_line
495
496 say "Problem occurred",$@->add_file_and_line;
497
498Returns the string C< at %s line %d>, where C<%s> is replaced with
499the filename, and C<%d> is replaced with the line number.
500
501Primarily intended for use by format handlers.
502
503=cut
504
505# Simply produces the file and line number; intended to be added
506# to the end of error messages.
507
508sub add_file_and_line {
509 my ($this) = @_;
510
511 return sprintf(" at %s line %d\n", $this->file, $this->line);
512}
513
514=head3 stringify
515
516 say "The error was: ",$@->stringify;
517
518Formats the error as a human readable string. Usually there's no
519reason to call this directly, as it is used automatically if an
520C<autodie::exception> object is ever used as a string.
521
522Child classes can override this method to change how they're
523stringified.
524
525=cut
526
527sub stringify {
528 my ($this) = @_;
529
530 my $call = $this->function;
531
532 if ($DEBUG) {
533 my $dying_pkg = $this->package;
534 my $sub = $this->function;
535 my $caller = $this->caller;
536 warn "Stringifing exception for $dying_pkg :: $sub / $caller / $call\n";
537 }
538
539 # TODO - This isn't using inheritance. Should it?
540 if ( my $sub = $formatter_of{$call} ) {
541 return $sub->($this) . $this->add_file_and_line;
542 }
543
02b13d1d 544 return $this->format_default . $this->add_file_and_line;
0b09a93a
PF
545
546}
547
548=head3 format_default
549
550 my $error_string = $E->format_default;
551
552This produces the default error string for the given exception,
553I<without using any registered message handlers>. It is primarily
554intended to be called from a message handler when they have
555been passed an exception they don't want to format.
556
557Child classes can override this method to change how default
558messages are formatted.
559
560=cut
561
562# TODO: This produces ugly errors. Is there any way we can
563# dig around to find the actual variable names? I know perl 5.10
564# does some dark and terrible magicks to find them for undef warnings.
565
566sub format_default {
567 my ($this) = @_;
568
569 my $call = $this->function;
570
571 local $! = $this->errno;
572
573 # TODO: This is probably a good idea for CORE, is it
574 # a good idea for other subs?
575
576 # Trim package name off dying sub for error messages.
577 $call =~ s/.*:://;
578
579 # Walk through all our arguments, and...
580 #
581 # * Replace undef with the word 'undef'
582 # * Replace globs with the string '$fh'
583 # * Quote all other args.
584
585 my @args = @{ $this->args() };
586
587 foreach my $arg (@args) {
588 if (not defined($arg)) { $arg = 'undef' }
589 elsif (ref($arg) eq "GLOB") { $arg = '$fh' }
590 else { $arg = qq{'$arg'} }
591 }
592
593 # Format our beautiful error.
594
02b13d1d 595 return "Can't $call(". join(q{, }, @args) . "): $!" ;
0b09a93a
PF
596
597 # TODO - Handle user-defined errors from hash.
598
599 # TODO - Handle default error messages.
600
601}
602
603=head3 new
604
605 my $error = autodie::exception->new(
606 args => \@_,
607 function => "CORE::open",
608 errno => $!,
eb8d423f
PF
609 context => 'scalar',
610 return => undef,
0b09a93a
PF
611 );
612
613
614Creates a new C<autodie::exception> object. Normally called
615directly from an autodying function. The C<function> argument
616is required, its the function we were trying to call that
617generated the exception. The C<args> parameter is optional.
618
619The C<errno> value is optional. In versions of C<autodie::exception>
6201.99 and earlier the code would try to automatically use the
621current value of C<$!>, but this was unreliable and is no longer
622supported.
623
624Atrributes such as package, file, and caller are determined
625automatically, and cannot be specified.
626
627=cut
628
629sub new {
630 my ($class, @args) = @_;
631
632 my $this = {};
633
634 bless($this,$class);
635
636 # I'd love to use EVERY here, but it causes our code to die
637 # because it wants to stringify our objects before they're
638 # initialised, causing everything to explode.
639
640 $this->_init(@args);
641
642 return $this;
643}
644
645sub _init {
646
647 my ($this, %args) = @_;
648
649 # Capturing errno here is not necessarily reliable.
650 my $original_errno = $!;
651
652 our $init_called = 1;
653
654 my $class = ref $this;
655
656 # We're going to walk up our call stack, looking for the
657 # first thing that doesn't look like our exception
658 # code, autodie/Fatal, or some whacky eval.
659
660 my ($package, $file, $line, $sub);
661
662 my $depth = 0;
663
664 while (1) {
665 $depth++;
666
667 ($package, $file, $line, $sub) = CORE::caller($depth);
668
669 # Skip up the call stack until we find something outside
670 # of the Fatal/autodie/eval space.
671
672 next if $package->isa('Fatal');
673 next if $package->isa($class);
674 next if $package->isa(__PACKAGE__);
675 next if $file =~ /^\(eval\s\d+\)$/;
676
677 last;
678
679 }
680
db4e6d09
PF
681 # We now have everything correct, *except* for our subroutine
682 # name. If it's __ANON__ or (eval), then we need to keep on
683 # digging deeper into our stack to find the real name. However we
684 # don't update our other information, since that will be correct
685 # for our current exception.
686
687 my $first_guess_subroutine = $sub;
688
689 while (defined $sub and $sub =~ /^\(eval\)$|::__ANON__$/) {
690 $depth++;
691
692 $sub = (CORE::caller($depth))[3];
693 }
694
695 # If we end up falling out the bottom of our stack, then our
696 # __ANON__ guess is the best we can get. This includes situations
9b657a62 697 # where we were called from the top level of a program.
db4e6d09
PF
698
699 if (not defined $sub) {
700 $sub = $first_guess_subroutine;
701 }
702
0b09a93a
PF
703 $this->{$PACKAGE}{package} = $package;
704 $this->{$PACKAGE}{file} = $file;
705 $this->{$PACKAGE}{line} = $line;
706 $this->{$PACKAGE}{caller} = $sub;
707 $this->{$PACKAGE}{package} = $package;
708
709 $this->{$PACKAGE}{errno} = $args{errno} || 0;
710
eb8d423f
PF
711 $this->{$PACKAGE}{context} = $args{context};
712 $this->{$PACKAGE}{return} = $args{return};
7840a289 713 $this->{$PACKAGE}{eval_error} = $args{eval_error};
eb8d423f 714
0b09a93a
PF
715 $this->{$PACKAGE}{args} = $args{args} || [];
716 $this->{$PACKAGE}{function}= $args{function} or
717 croak("$class->new() called without function arg");
718
719 return $this;
720
721}
722
7231;
724
725__END__
726
727=head1 SEE ALSO
728
729L<autodie>, L<autodie::exception::system>
730
731=head1 LICENSE
732
733Copyright (C)2008 Paul Fenwick
734
735This is free software. You may modify and/or redistribute this
736code under the same terms as Perl 5.10 itself, or, at your option,
737any later version of Perl 5.
738
739=head1 AUTHOR
740
741Paul Fenwick E<lt>pjf@perltraining.com.auE<gt>