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