diff options
Diffstat (limited to 'Master/tlpkg/tlperl/lib/autodie/exception.pm')
-rw-r--r-- | Master/tlpkg/tlperl/lib/autodie/exception.pm | 112 |
1 files changed, 81 insertions, 31 deletions
diff --git a/Master/tlpkg/tlperl/lib/autodie/exception.pm b/Master/tlpkg/tlperl/lib/autodie/exception.pm index 15d09146d8d..73058085e00 100644 --- a/Master/tlpkg/tlperl/lib/autodie/exception.pm +++ b/Master/tlpkg/tlperl/lib/autodie/exception.pm @@ -4,7 +4,7 @@ use strict; use warnings; use Carp qw(croak); -our $VERSION = '2.26'; # VERSION: Generated by DZP::OurPkg:Version +our $VERSION = '2.29'; # VERSION: Generated by DZP::OurPkg:Version # ABSTRACT: Exceptions from autodying functions. our $DEBUG = 0; @@ -292,8 +292,50 @@ my %formatter_of = ( 'CORE::read' => \&_format_readwrite, 'CORE::sysread' => \&_format_readwrite, 'CORE::syswrite' => \&_format_readwrite, + 'CORE::chmod' => \&_format_chmod, + 'CORE::mkdir' => \&_format_mkdir, ); +sub _beautify_arguments { + shift @_; + + # Walk through all our arguments, and... + # + # * Replace undef with the word 'undef' + # * Replace globs with the string '$fh' + # * Quote all other args. + foreach my $arg (@_) { + if (not defined($arg)) { $arg = 'undef' } + elsif (ref($arg) eq "GLOB") { $arg = '$fh' } + else { $arg = qq{'$arg'} } + } + + return @_; +} + +sub _trim_package_name { + # Info: The following is done since 05/2008 (which is before v1.10) + + # TODO: This is probably a good idea for CORE, is it + # a good idea for other subs? + + # Trim package name off dying sub for error messages + (my $name = $_[1]) =~ s/.*:://; + return $name; +} + +# Returns the parameter formatted as octal number +sub _octalize_number { + my $number = $_[1]; + + # Only reformat if it looks like a whole number + if ($number =~ /^\d+$/) { + $number = sprintf("%#04lo", $number); + } + + return $number; +} + # TODO: Our tests only check LOCK_EX | LOCK_NB is properly # formatted. Try other combinations and ensure they work # correctly. @@ -348,6 +390,40 @@ sub _format_flock { } +# Default formatter for CORE::chmod +sub _format_chmod { + my ($this) = @_; + my @args = @{$this->args}; + + my $mode = shift @args; + local $! = $this->errno; + + $mode = $this->_octalize_number($mode); + + @args = $this->_beautify_arguments(@args); + + return "Can't chmod($mode, ". join(q{, }, @args) ."): $!"; +} + +# Default formatter for CORE::mkdir +sub _format_mkdir { + my ($this) = @_; + my @args = @{$this->args}; + + # If no mask is specified use default formatter + if (@args < 2) { + return $this->format_default; + } + + my $file = $args[0]; + my $mask = $args[1]; + local $! = $this->errno; + + $mask = $this->_octalize_number($mask); + + return "Can't mkdir('$file', $mask): '$!'"; +} + # Default formatter for CORE::dbmopen sub _format_dbmopen { my ($this) = @_; @@ -362,13 +438,7 @@ sub _format_dbmopen { my $mode = $args[-1]; my $file = $args[-2]; - # If we have a mask, then display it in octal, not decimal. - # We don't do this if it already looks octalish, or doesn't - # look like a number. - - if ($mode =~ /^[^\D0]\d+$/) { - $mode = sprintf("0%lo", $mode); - }; + $mode = $this->_octalize_number($mode); local $! = $this->errno; @@ -399,12 +469,9 @@ sub _format_close { # may contain binary data. sub _format_readwrite { my ($this) = @_; - my $call = $this->function; + my $call = $this->_trim_package_name($this->function); local $! = $this->errno; - # Trim package name off dying sub for error messages. - $call =~ s/.*:://; - # These subs receive the following arguments (in order): # # * FILEHANDLE @@ -619,29 +686,12 @@ messages are formatted. sub format_default { my ($this) = @_; - my $call = $this->function; + my $call = $this->_trim_package_name($this->function); local $! = $this->errno; - # TODO: This is probably a good idea for CORE, is it - # a good idea for other subs? - - # Trim package name off dying sub for error messages. - $call =~ s/.*:://; - - # Walk through all our arguments, and... - # - # * Replace undef with the word 'undef' - # * Replace globs with the string '$fh' - # * Quote all other args. - my @args = @{ $this->args() }; - - foreach my $arg (@args) { - if (not defined($arg)) { $arg = 'undef' } - elsif (ref($arg) eq "GLOB") { $arg = '$fh' } - else { $arg = qq{'$arg'} } - } + @args = $this->_beautify_arguments(@args); # Format our beautiful error. |