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