diff options
Diffstat (limited to 'Master/tlpkg/tlperl/lib/Fatal.pm')
| -rw-r--r-- | Master/tlpkg/tlperl/lib/Fatal.pm | 99 |
1 files changed, 73 insertions, 26 deletions
diff --git a/Master/tlpkg/tlperl/lib/Fatal.pm b/Master/tlpkg/tlperl/lib/Fatal.pm index 18e71ed21a3..55b920ba5b1 100644 --- a/Master/tlpkg/tlperl/lib/Fatal.pm +++ b/Master/tlpkg/tlperl/lib/Fatal.pm @@ -5,6 +5,7 @@ use Carp; use strict; use warnings; use Tie::RefHash; # To cache subroutine refs +use Config; use constant PERL510 => ( $] >= 5.010 ); @@ -39,7 +40,7 @@ use constant ERROR_58_HINTS => q{Non-subroutine %s hints for %s are not supporte use constant MIN_IPC_SYS_SIMPLE_VER => 0.12; # All the Fatal/autodie modules share the same version number. -our $VERSION = '2.06_01'; +our $VERSION = '2.1001'; our $Debug ||= 0; @@ -52,6 +53,10 @@ our %_EWOULDBLOCK = ( MSWin32 => 33, ); +# the linux parisc port has separate EAGAIN and EWOULDBLOCK, +# and the kernel returns EAGAIN +my $try_EAGAIN = ($^O eq 'linux' and $Config{archname} =~ /hppa|parisc/) ? 1 : 0; + # We have some tags that can be passed in for use with import. # These are all assumed to be CORE:: @@ -60,7 +65,7 @@ my %TAGS = ( read seek sysread syswrite sysseek )], ':dbm' => [qw(dbmopen dbmclose)], ':file' => [qw(open close flock sysopen fcntl fileno binmode - ioctl truncate)], + ioctl truncate chmod)], ':filesys' => [qw(opendir closedir chdir link unlink rename mkdir symlink rmdir readlink umask)], ':ipc' => [qw(:msg :semaphore :shm pipe)], @@ -84,26 +89,38 @@ my %TAGS = ( ':default' => [qw(:io :threads)], + # Everything in v2.07 and brefore. This was :default less chmod. + ':v207' => [qw(:threads :dbm :filesys :ipc :socket read seek sysread + syswrite sysseek open close flock sysopen fcntl fileno + binmode ioctl truncate)], + # Version specific tags. These allow someone to specify # use autodie qw(:1.994) and know exactly what they'll get. - ':1.994' => [qw(:default)], - ':1.995' => [qw(:default)], - ':1.996' => [qw(:default)], - ':1.997' => [qw(:default)], - ':1.998' => [qw(:default)], - ':1.999' => [qw(:default)], - ':1.999_01' => [qw(:default)], - ':2.00' => [qw(:default)], - ':2.01' => [qw(:default)], - ':2.02' => [qw(:default)], - ':2.03' => [qw(:default)], - ':2.04' => [qw(:default)], - ':2.05' => [qw(:default)], - ':2.06' => [qw(:default)], - ':2.06_01' => [qw(:default)], + ':1.994' => [qw(:v207)], + ':1.995' => [qw(:v207)], + ':1.996' => [qw(:v207)], + ':1.997' => [qw(:v207)], + ':1.998' => [qw(:v207)], + ':1.999' => [qw(:v207)], + ':1.999_01' => [qw(:v207)], + ':2.00' => [qw(:v207)], + ':2.01' => [qw(:v207)], + ':2.02' => [qw(:v207)], + ':2.03' => [qw(:v207)], + ':2.04' => [qw(:v207)], + ':2.05' => [qw(:v207)], + ':2.06' => [qw(:v207)], + ':2.06_01' => [qw(:v207)], + ':2.07' => [qw(:v207)], # Last release without chmod + ':2.08' => [qw(:default)], + ':2.09' => [qw(:default)], + ':2.10' => [qw(:default)], + ':2.1001' => [qw(:default)], ); +# chmod was only introduced in 2.07 + $TAGS{':all'} = [ keys %TAGS ]; # This hash contains subroutines for which we should @@ -168,6 +185,7 @@ my $NO_PACKAGE = "no $PACKAGE"; # Used to detect 'no autodie' sub import { my $class = shift(@_); + my @original_args = @_; my $void = 0; my $lexical = 0; my $insist_hints = 0; @@ -306,6 +324,16 @@ sub import { $class->_install_subs($pkg, \%unload_later); })); + # To allow others to determine when autodie was in scope, + # and with what arguments, we also set a %^H hint which + # is how we were called. + + # This feature should be considered EXPERIMENTAL, and + # may change without notice. Please e-mail pjf@cpan.org + # if you're actually using it. + + $^H{autodie} = "$PACKAGE @original_args"; + } return; @@ -449,8 +477,10 @@ sub unimport { while (my $item = shift @to_process) { if ($item =~ /^:/) { + # Expand :tags push(@to_process, @{$TAGS{$item}} ); - } else { + } + else { push(@taglist, "CORE::$item"); } } @@ -520,7 +550,17 @@ sub _write_invocation { @argv = @{shift @argvs}; $n = shift @argv; - push @out, "${else}if (\@_ == $n) {\n"; + my $condition = "\@_ == $n"; + + if (@argv and $argv[-1] =~ /#_/) { + # This argv ends with '@' in the prototype, so it matches + # any number of args >= the number of expressions in the + # argv. + $condition = "\@_ >= $n"; + } + + push @out, "${else}if ($condition) {\n"; + $else = "\t} els"; push @out, $class->_one_invocation($core,$call,$name,$void,$sub,! $lexical, $sref, @argv); @@ -594,11 +634,11 @@ sub _one_invocation { if ($void) { return qq/return (defined wantarray)?$call(@argv): - $call(@argv) || croak "Can't $name(\@_)/ . - ($core ? ': $!' : ', \$! is \"$!\"') . '"' + $call(@argv) || Carp::croak("Can't $name(\@_)/ . + ($core ? ': $!' : ', \$! is \"$!\"') . '")' } else { - return qq{return $call(@argv) || croak "Can't $name(\@_)} . - ($core ? ': $!' : ', \$! is \"$!\"') . '"'; + return qq{return $call(@argv) || Carp::croak("Can't $name(\@_)} . + ($core ? ': $!' : ', \$! is \"$!\"') . '")'; } } @@ -720,6 +760,11 @@ sub _one_invocation { my $EWOULDBLOCK = eval { POSIX::EWOULDBLOCK(); } || $_EWOULDBLOCK{$^O} || _autocroak("Internal error - can't overload flock - EWOULDBLOCK not defined on this system."); + my $EAGAIN = $EWOULDBLOCK; + if ($try_EAGAIN) { + $EAGAIN = eval { POSIX::EAGAIN(); } + || _autocroak("Internal error - can't overload flock - EAGAIN not defined on this system."); + } require Fcntl; # For Fcntl::LOCK_NB @@ -735,7 +780,9 @@ sub _one_invocation { # If we failed, but we're using LOCK_NB and # returned EWOULDBLOCK, it's not a real error. - if (\$_[1] & Fcntl::LOCK_NB() and \$! == $EWOULDBLOCK ) { + if (\$_[1] & Fcntl::LOCK_NB() and + (\$! == $EWOULDBLOCK or + ($try_EAGAIN and \$! == $EAGAIN ))) { return \$retval; } @@ -1053,7 +1100,7 @@ sub _make_fatal { { local $@; - $code = eval("package $pkg; use Carp; $code"); ## no critic + $code = eval("package $pkg; require Carp; $code"); ## no critic $E = $@; } @@ -1131,7 +1178,7 @@ sub _make_fatal { >; } - $leak_guard .= qq< croak "Internal error in Fatal/autodie. Leak-guard failure"; } >; + $leak_guard .= qq< Carp::croak("Internal error in Fatal/autodie. Leak-guard failure"); } >; # warn "$leak_guard\n"; |