summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl/lib/autodie/exception.pm
diff options
context:
space:
mode:
Diffstat (limited to 'Master/tlpkg/tlperl/lib/autodie/exception.pm')
-rw-r--r--Master/tlpkg/tlperl/lib/autodie/exception.pm112
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.