diff options
Diffstat (limited to 'Master/tlpkg/tlperl/lib/Fatal.pm')
-rw-r--r-- | Master/tlpkg/tlperl/lib/Fatal.pm | 112 |
1 files changed, 48 insertions, 64 deletions
diff --git a/Master/tlpkg/tlperl/lib/Fatal.pm b/Master/tlpkg/tlperl/lib/Fatal.pm index e538e20d682..8fe7899819e 100644 --- a/Master/tlpkg/tlperl/lib/Fatal.pm +++ b/Master/tlpkg/tlperl/lib/Fatal.pm @@ -10,6 +10,8 @@ use Tie::RefHash; # To cache subroutine refs use Config; use Scalar::Util qw(set_prototype); +use autodie::ScopeUtil qw(on_end_of_compile_scope); + use constant PERL510 => ( $] >= 5.010 ); use constant LEXICAL_TAG => q{:lexical}; @@ -48,7 +50,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; -our $VERSION = '2.23'; # VERSION: Generated by DZP::OurPkg::Version +our $VERSION = '2.26'; # VERSION: Generated by DZP::OurPkg::Version our $Debug ||= 0; @@ -61,6 +63,10 @@ our %_EWOULDBLOCK = ( MSWin32 => 33, ); +$Carp::CarpInternal{'Fatal'} = 1; +$Carp::CarpInternal{'autodie'} = 1; +$Carp::CarpInternal{'autodie::exception'} = 1; + # 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; @@ -72,10 +78,10 @@ my %TAGS = ( ':io' => [qw(:dbm :file :filesys :ipc :socket read seek sysread syswrite sysseek )], ':dbm' => [qw(dbmopen dbmclose)], - ':file' => [qw(open close flock sysopen fcntl fileno binmode + ':file' => [qw(open close flock sysopen fcntl binmode ioctl truncate)], ':filesys' => [qw(opendir closedir chdir link unlink rename mkdir - symlink rmdir readlink umask chmod chown utime)], + symlink rmdir readlink chmod chown utime)], ':ipc' => [qw(:msg :semaphore :shm pipe kill)], ':msg' => [qw(msgctl msgget msgrcv msgsnd)], ':threads' => [qw(fork)], @@ -110,6 +116,9 @@ my %TAGS = ( # chown, utime, kill were added in 2.14 ':v214' => [qw(:v213 chown utime kill)], + # umask was removed in 2.26 + ':v225' => [qw(:io :threads umask fileno)], + # Version specific tags. These allow someone to specify # use autodie qw(:1.994) and know exactly what they'll get. @@ -134,21 +143,22 @@ my %TAGS = ( ':2.10' => [qw(:v213)], ':2.11' => [qw(:v213)], ':2.12' => [qw(:v213)], - ':2.13' => [qw(:v213)], - ':2.14' => [qw(:default)], - ':2.15' => [qw(:default)], - ':2.16' => [qw(:default)], - ':2.17' => [qw(:default)], - ':2.18' => [qw(:default)], - ':2.19' => [qw(:default)], - ':2.20' => [qw(:default)], - ':2.21' => [qw(:default)], - ':2.22' => [qw(:default)], - ':2.23' => [qw(:default)], + ':2.13' => [qw(:v213)], # Last release without chown + ':2.14' => [qw(:v225)], + ':2.15' => [qw(:v225)], + ':2.16' => [qw(:v225)], + ':2.17' => [qw(:v225)], + ':2.18' => [qw(:v225)], + ':2.19' => [qw(:v225)], + ':2.20' => [qw(:v225)], + ':2.21' => [qw(:v225)], + ':2.22' => [qw(:v225)], + ':2.23' => [qw(:v225)], + ':2.24' => [qw(:v225)], + ':2.25' => [qw(:v225)], + ':2.26' => [qw(:default)], ); -# chmod was only introduced in 2.07 -# chown was only introduced in 2.14 { # Expand :all immediately by expanding and flattening all tags. @@ -205,7 +215,7 @@ my %Retval_action = ( "CORE::open" => q{ # apply the open pragma from our caller - if( defined $retval ) { + if( defined $retval && !( @_ >= 3 && $_[1] =~ /:/ )) { # Get the caller's hint hash my $hints = (caller 0)[10]; @@ -326,7 +336,6 @@ my %CORE_prototype_cache; # setting up lexical guards. my $PACKAGE = __PACKAGE__; -my $PACKAGE_GUARD = "guard $PACKAGE"; my $NO_PACKAGE = "no $PACKAGE"; # Used to detect 'no autodie' # Here's where all the magic happens when someone write 'use Fatal' @@ -467,9 +476,9 @@ sub import { # Our package guard gets invoked when we leave our lexical # scope. - push(@ { $^H{$PACKAGE_GUARD} }, autodie::Scope::Guard->new(sub { + on_end_of_compile_scope(sub { $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 @@ -561,7 +570,7 @@ sub unimport { # in which case, we disable Fatalistic behaviour for 'blah'. my @unimport_these = @_ ? @_ : ':all'; - my %uninstall_subs; + my (%uninstall_subs, %reinstall_subs); for my $symbol ($class->_translate_import_args(@unimport_these)) { @@ -580,21 +589,18 @@ sub unimport { # (eg, mixing Fatal with no autodie) $^H{$NO_PACKAGE}{$sub} = 1; - - if (my $original_sub = $Original_user_sub{$sub}) { - # Hey, we've got an original one of these, put it back. - $uninstall_subs{$symbol} = $original_sub; - next; - } - - # We don't have an original copy of the sub, on the assumption - # it's core (or doesn't exist), we'll just nuke it. - - $uninstall_subs{$symbol} = undef; + # Record the current sub to be reinstalled at end of scope + # and then restore the original (can be undef for "CORE::" + # subs) + $reinstall_subs{$symbol} = \&$sub; + $uninstall_subs{$symbol} = $Original_user_sub{$sub}; } $class->_install_subs($pkg, \%uninstall_subs); + on_end_of_compile_scope(sub { + $class->_install_subs($pkg, \%reinstall_subs); + }); return; @@ -1197,7 +1203,7 @@ sub _one_invocation { sub _make_fatal { my($class, $sub, $pkg, $void, $lexical, $filename, $insist, $install_subs) = @_; - my($code, $sref, $real_proto, $proto, $core, $call, $hints, $cache, $cache_type); + my($code, $sref, $proto, $core, $call, $hints, $cache, $cache_type); my $ini = $sub; my $name = $sub; @@ -1236,6 +1242,9 @@ sub _make_fatal { # This could be something that we've fatalised that # was in core. + # Store the current sub in case we need to restore it. + $sref = \&$sub; + if ( $Package_Fatal{$sub} and exists($CORE_prototype_cache{"CORE::$name"})) { # Something we previously made Fatal that was core. @@ -1250,7 +1259,7 @@ sub _make_fatal { # on, indicating this subroutine should be placed # back when we're finished. - $sref = \&$sub; + } else { @@ -1258,7 +1267,7 @@ sub _make_fatal { # then look-up the name of the original sub for the rest of # our processing. - if (exists($Is_fatalised_sub{\&$sub})) { + if (exists($Is_fatalised_sub{$sref})) { # $sub is one of our wrappers around a CORE sub or a # user sub. Instead of wrapping our wrapper, lets just # generate a new wrapper for the original sub. @@ -1267,7 +1276,7 @@ sub _make_fatal { # mixing between use Fatal + use autodie can occur). # - Even for nested autodie, we need this as the leak guards # differ. - my $s = $Is_fatalised_sub{\&$sub}; + my $s = $Is_fatalised_sub{$sref}; if (defined($s)) { # It is a wrapper for a user sub $sub = $s; @@ -1282,7 +1291,6 @@ sub _make_fatal { # A regular user sub, or a user sub wrapping a # core sub. - $sref = \&$sub; if (!$core) { # A non-CORE sub might have hints and such... $proto = prototype($sref); @@ -1434,14 +1442,8 @@ sub _make_fatal { my $installed_sub = $code; if ($lexical) { - my $real_proto = ''; - if (defined $proto) { - $real_proto = " ($proto)"; - } else { - $proto = '@'; - } $installed_sub = $class->_make_leak_guard($filename, $code, $sref, $call, - $pkg, $proto, $real_proto); + $pkg, $proto); } $cache->{$cache_type} = $code; @@ -1509,7 +1511,7 @@ sub exception_class { return "autodie::exception" }; # Creates and returns a leak guard (with prototype if needed). sub _make_leak_guard { - my ($class, $filename, $wrapped_sub, $orig_sub, $call, $pkg, $proto, $real_proto) = @_; + my ($class, $filename, $wrapped_sub, $orig_sub, $call, $pkg, $proto) = @_; # The leak guard is rather lengthly (in fact it makes up the most # of _make_leak_guard). It is possible to split it into a large @@ -1632,7 +1634,7 @@ sub _make_leak_guard { # If there is a prototype on the original sub, copy it to the leak # guard. - if ($real_proto ne '') { + if (defined $proto) { # The "\&" may appear to be redundant but set_prototype # croaks when it is removed. set_prototype(\&$leak_guard, $proto); @@ -1758,24 +1760,6 @@ sub _autocroak { exit(255); # Ugh! } -package autodie::Scope::Guard; - -# This code schedules the cleanup of subroutines at the end of -# scope. It's directly inspired by chocolateboy's excellent -# Scope::Guard module. - -sub new { - my ($class, $handler) = @_; - - return bless $handler, $class; -} - -sub DESTROY { - my ($self) = @_; - - $self->(); -} - 1; __END__ |