summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl/lib/autodie/Util.pm
diff options
context:
space:
mode:
Diffstat (limited to 'Master/tlpkg/tlperl/lib/autodie/Util.pm')
-rw-r--r--Master/tlpkg/tlperl/lib/autodie/Util.pm250
1 files changed, 250 insertions, 0 deletions
diff --git a/Master/tlpkg/tlperl/lib/autodie/Util.pm b/Master/tlpkg/tlperl/lib/autodie/Util.pm
new file mode 100644
index 00000000000..2a308a89778
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/autodie/Util.pm
@@ -0,0 +1,250 @@
+package autodie::Util;
+
+use strict;
+use warnings;
+
+use Exporter 5.57 qw(import);
+
+use autodie::Scope::GuardStack;
+
+our @EXPORT_OK = qw(
+ fill_protos
+ install_subs
+ make_core_trampoline
+ on_end_of_compile_scope
+);
+
+our $VERSION = '2.29'; # VERSION: Generated by DZP::OurPkg:Version
+
+# ABSTRACT: Internal Utility subroutines for autodie and Fatal
+
+# docs says we should pick __PACKAGE__ /<whatever>
+my $H_STACK_KEY = __PACKAGE__ . '/stack';
+
+sub on_end_of_compile_scope {
+ my ($hook) = @_;
+
+ # Dark magic to have autodie work under 5.8
+ # Copied from namespace::clean, that copied it from
+ # autobox, that found it on an ancient scroll written
+ # in blood.
+
+ # This magic bit causes %^H to be lexically scoped.
+ $^H |= 0x020000;
+
+ my $stack = $^H{$H_STACK_KEY};
+ if (not defined($stack)) {
+ $stack = autodie::Scope::GuardStack->new;
+ $^H{$H_STACK_KEY} = $stack;
+ }
+
+ $stack->push_hook($hook);
+ return;
+}
+
+# This code is based on code from the original Fatal. The "XXXX"
+# remark is from the original code and its meaning is (sadly) unknown.
+sub fill_protos {
+ my ($proto) = @_;
+ my ($n, $isref, @out, @out1, $seen_semi) = -1;
+ if ($proto =~ m{^\s* (?: [;] \s*)? \@}x) {
+ # prototype is entirely slurply - 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;
+}
+
+
+sub make_core_trampoline {
+ my ($call, $pkg, $proto_str) = @_;
+ my $trampoline_code = 'sub {';
+ my $trampoline_sub;
+ my @protos = fill_protos($proto_str);
+
+ 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< require Carp; 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;
+}
+
+# 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 ($target_pkg, $subs_to_reinstate) = @_;
+
+ my $pkg_sym = "${target_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;
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+autodie::Util - Internal Utility subroutines for autodie and Fatal
+
+=head1 SYNOPSIS
+
+ # INTERNAL API for autodie and Fatal only!
+
+ use autodie::Util qw(on_end_of_compile_scope);
+ on_end_of_compile_scope(sub { print "Hallo world\n"; });
+
+=head1 DESCRIPTION
+
+Interal Utilities for autodie and Fatal! This module is not a part of
+autodie's public API.
+
+This module contains utility subroutines for abstracting away the
+underlying magic of autodie and (ab)uses of C<%^H> to call subs at the
+end of a (compile-time) scopes.
+
+Note that due to how C<%^H> works, some of these utilities are only
+useful during the compilation phase of a perl module and relies on the
+internals of how perl handles references in C<%^H>.
+
+=head2 Methods
+
+=head3 on_end_of_compile_scope
+
+ on_end_of_compile_scope(sub { print "Hallo world\n"; });
+
+Will invoke a sub at the end of a (compile-time) scope. The sub is
+called once with no arguments. Can be called multiple times (even in
+the same "compile-time" scope) to install multiple subs. Subs are
+called in a "first-in-last-out"-order (FILO or "stack"-order).
+
+=head3 fill_protos
+
+ fill_protos('*$$;$@')
+
+Given a Perl subroutine prototype, return a list of invocation
+specifications. Each specification is a listref, where the first
+member is the (minimum) number of arguments for this invocation
+specification. The remaining arguments are a string representation of
+how to pass the arguments correctly to a sub with the given prototype,
+when called with the given number of arguments.
+
+The specifications are returned in increasing order of arguments
+starting at 0 (e.g. ';$') or 1 (e.g. '$@'). Note that if the
+prototype is "slurpy" (e.g. ends with a "@"), the number of arguments
+for the last specification is a "minimum" number rather than an exact
+number. This can be detected by the last member of the last
+specification matching m/[@#]_/.
+
+=head3 make_core_trampoline
+
+ make_core_trampoline('CORE::open', 'main', prototype('CORE::open'))
+
+Creates 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 reliably use `goto &` on core builtins, we wouldn't need
+this subroutine.
+
+=head3 install_subs
+
+ install_subs('My::Module', { 'read' => sub { die("Hallo\n"), ... }})
+
+Given a package name and a hashref mapping names to a subroutine
+reference (or C<undef>), this subroutine will install said subroutines
+on their given name in that module. If a name mapes to C<undef>, any
+subroutine with that name in the target module will be remove
+(possibly "unshadowing" a CORE sub of same name).
+
+=head1 AUTHOR
+
+Copyright 2013-2014, Niels Thykier E<lt>niels@thykier.netE<gt>
+
+=head1 LICENSE
+
+This module is free software. You may distribute it under the
+same terms as Perl itself.