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