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.pm189
1 files changed, 53 insertions, 136 deletions
diff --git a/Master/tlpkg/tlperl/lib/Fatal.pm b/Master/tlpkg/tlperl/lib/Fatal.pm
index 8fe7899819e..16e17434742 100644
--- a/Master/tlpkg/tlperl/lib/Fatal.pm
+++ b/Master/tlpkg/tlperl/lib/Fatal.pm
@@ -10,7 +10,12 @@ 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 autodie::Util qw(
+ fill_protos
+ install_subs
+ make_core_trampoline
+ on_end_of_compile_scope
+);
use constant PERL510 => ( $] >= 5.010 );
@@ -50,7 +55,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.26'; # VERSION: Generated by DZP::OurPkg::Version
+our $VERSION = '2.29'; # VERSION: Generated by DZP::OurPkg::Version
our $Debug ||= 0;
@@ -103,7 +108,7 @@ my %TAGS = (
':default' => [qw(:io :threads)],
- # Everything in v2.07 and brefore. This was :default less chmod and chown
+ # Everything in v2.07 and before. This was :default less chmod and chown
':v207' => [qw(:threads :dbm :socket read seek sysread
syswrite sysseek open close flock sysopen fcntl fileno
binmode ioctl truncate opendir closedir chdir link unlink
@@ -157,6 +162,9 @@ my %TAGS = (
':2.24' => [qw(:v225)],
':2.25' => [qw(:v225)],
':2.26' => [qw(:default)],
+ ':2.27' => [qw(:default)],
+ ':2.28' => [qw(:default)],
+ ':2.29' => [qw(:default)],
);
@@ -293,6 +301,8 @@ my %reusable_builtins;
CORE::shmctl
CORE::shmget
CORE::shmread
+ CORE::exec
+ CORE::system
)} = ();
# Cached_fatalised_sub caches the various versions of our
@@ -359,6 +369,41 @@ sub import {
$lexical = 1;
shift @_;
+ # It is currently an implementation detail that autodie is
+ # implemented as "use Fatal qw(:lexical ...)". For backwards
+ # compatibility, we allow it - but not without a warning.
+ # NB: Optimise for autodie as it is quite possibly the most
+ # freq. consumer of this case.
+ if ($class ne 'autodie' and not $class->isa('autodie')) {
+ if ($class eq 'Fatal') {
+ warnings::warnif(
+ 'deprecated',
+ '[deprecated] The "use Fatal qw(:lexical ...)" '
+ . 'should be replaced by "use autodie qw(...)". '
+ . 'Seen' # warnif appends " at <...>"
+ );
+ } else {
+ warnings::warnif(
+ 'deprecated',
+ "[deprecated] The class/Package $class is a "
+ . 'subclass of Fatal and used the :lexical. '
+ . 'If $class provides lexical error checking '
+ . 'it should extend autodie instead of using :lexical. '
+ . 'Seen' # warnif appends " at <...>"
+ );
+ }
+ # "Promote" the call to autodie from here on. This is
+ # already mostly the case (e.g. use Fatal qw(:lexical ...)
+ # would throw autodie::exceptions on error rather than the
+ # Fatal errors.
+ $class = 'autodie';
+ # This requires that autodie is in fact loaded; otherwise
+ # the "$class->X()" method calls below will explode.
+ require autodie;
+ # TODO, when autodie and Fatal are cleanly separated, we
+ # should go a "goto &autodie::import" here instead.
+ }
+
# If we see no arguments and :lexical, we assume they
# wanted ':default'.
@@ -460,7 +505,7 @@ sub import {
}
}
- $class->_install_subs($pkg, \%install_subs);
+ install_subs($pkg, \%install_subs);
if ($lexical) {
@@ -477,7 +522,7 @@ sub import {
# scope.
on_end_of_compile_scope(sub {
- $class->_install_subs($pkg, \%unload_later);
+ install_subs($pkg, \%unload_later);
});
# To allow others to determine when autodie was in scope,
@@ -496,63 +541,6 @@ sub import {
}
-# The code here is originally lifted from namespace::clean,
-# by Robert "phaylon" Sedlacek.
-#
-# It's been redesigned after feedback from ikegami on perlmonks.
-# See http://perlmonks.org/?node_id=693338 . Ikegami rocks.
-#
-# Given a package, and hash of (subname => subref) pairs,
-# we install the given subroutines into the package. If
-# a subref is undef, the subroutine is removed. Otherwise
-# it replaces any existing subs which were already there.
-
-sub _install_subs {
- my ($class, $pkg, $subs_to_reinstate) = @_;
-
- my $pkg_sym = "${pkg}::";
-
- # It does not hurt to do this in a predictable order, and might help debugging.
- foreach my $sub_name (sort keys %$subs_to_reinstate) {
-
- # We will repeatedly mess with stuff that strict "refs" does
- # not like. So lets just disable it once for this entire
- # scope.
- no strict qw(refs); ## no critic
-
- my $sub_ref= $subs_to_reinstate->{$sub_name};
-
- my $full_path = $pkg_sym.$sub_name;
- my $oldglob = *$full_path;
-
- # Nuke the old glob.
- delete $pkg_sym->{$sub_name};
-
- # For some reason this local *alias = *$full_path triggers an
- # "only used once" warning. Not entirely sure why, but at
- # least it is easy to silence.
- no warnings qw(once);
- local *alias = *$full_path;
- use warnings qw(once);
-
- # Copy innocent bystanders back. Note that we lose
- # formats; it seems that Perl versions up to 5.10.0
- # have a bug which causes copying formats to end up in
- # the scalar slot. Thanks to Ben Morrow for spotting this.
-
- foreach my $slot (qw( SCALAR ARRAY HASH IO ) ) {
- next unless defined *$oldglob{$slot};
- *alias = *$oldglob{$slot};
- }
-
- if ($sub_ref) {
- *$full_path = $sub_ref;
- }
- }
-
- return;
-}
-
sub unimport {
my $class = shift;
@@ -597,9 +585,9 @@ sub unimport {
}
- $class->_install_subs($pkg, \%uninstall_subs);
+ install_subs($pkg, \%uninstall_subs);
on_end_of_compile_scope(sub {
- $class->_install_subs($pkg, \%reinstall_subs);
+ install_subs($pkg, \%reinstall_subs);
});
return;
@@ -755,32 +743,6 @@ sub _translate_import_args {
}
-# This code is from the original Fatal. It scares me.
-# It is 100% compatible with the 5.10.0 Fatal module, right down
-# to the scary 'XXXX' comment. ;)
-
-sub fill_protos {
- my $proto = shift;
- my ($n, $isref, @out, @out1, $seen_semi) = -1;
- if ($proto =~ m{^\s* (?: [;] \s*)? \@}x) {
- # prototype is entirely slurp - special case that does not
- # require any handling.
- return ([0, '@_']);
- }
-
- while ($proto =~ /\S/) {
- $n++;
- push(@out1,[$n,@out]) if $seen_semi;
- push(@out, $1 . "{\$_[$n]}"), next if $proto =~ s/^\s*\\([\@%\$\&])//;
- push(@out, "\$_[$n]"), next if $proto =~ s/^\s*([_*\$&])//;
- push(@out, "\@_[$n..\$#_]"), last if $proto =~ s/^\s*(;\s*)?\@//;
- $seen_semi = 1, $n--, next if $proto =~ s/^\s*;//; # XXXX ????
- die "Internal error: Unknown prototype letters: \"$proto\"";
- }
- push(@out1,[$n+1,@out]);
- return @out1;
-}
-
# This is a backwards compatible version of _write_invocation. It's
# recommended you don't use it.
@@ -1620,7 +1582,7 @@ sub _make_leak_guard {
# As $orig_sub is "closed over", updating its value will
# be "remembered" for the next call.
- $orig_sub = _make_core_trampoline($call, $pkg, $proto);
+ $orig_sub = make_core_trampoline($call, $pkg, $proto);
# We still cache it despite remembering it in $orig_sub as
# well. In particularly, we rely on this to avoid
@@ -1643,51 +1605,6 @@ sub _make_leak_guard {
return $leak_guard;
}
-# Create a trampoline for calling a core sub. Essentially, a tiny sub
-# that figures out how we should be calling our core sub, puts in the
-# arguments in the right way, and bounces our control over to it.
-#
-# If we could use `goto &` on core builtins, we wouldn't need this.
-sub _make_core_trampoline {
- my ($call, $pkg, $proto_str) = @_;
- my $trampoline_code = 'sub {';
- my $trampoline_sub;
- my @protos = fill_protos($proto_str);
-
- # TODO: It may be possible to combine this with write_invocation().
-
- foreach my $proto (@protos) {
- local $" = ", "; # So @args is formatted correctly.
- my ($count, @args) = @$proto;
- if (@args && $args[-1] =~ m/[@#]_/) {
- $trampoline_code .= qq/
- if (\@_ >= $count) {
- return $call(@args);
- }
- /;
- } else {
- $trampoline_code .= qq<
- if (\@_ == $count) {
- return $call(@args);
- }
- >;
- }
- }
-
- $trampoline_code .= qq< Carp::croak("Internal error in Fatal/autodie. Leak-guard failure"); } >;
- my $E;
-
- {
- local $@;
- $trampoline_sub = eval "package $pkg;\n $trampoline_code"; ## no critic
- $E = $@;
- }
- die "Internal error in Fatal/autodie: Leak-guard installation failure: $E"
- if $E;
-
- return $trampoline_sub;
-}
-
sub _compile_wrapper {
my ($class, $wrapper_pkg, $core, $call, $name, $void, $lexical, $sub, $sref, $hints, $proto) = @_;
my $real_proto = '';