diff options
Diffstat (limited to 'Master/tlpkg/tlperl/lib/Fatal.pm')
-rw-r--r-- | Master/tlpkg/tlperl/lib/Fatal.pm | 189 |
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 = ''; |