1package autodie::Util; 2 3use strict; 4use warnings; 5 6use Exporter 5.57 qw(import); 7 8use autodie::Scope::GuardStack; 9 10our @EXPORT_OK = qw( 11 fill_protos 12 install_subs 13 make_core_trampoline 14 on_end_of_compile_scope 15); 16 17our $VERSION = '2.37'; # VERSION: Generated by DZP::OurPkg:Version 18 19# ABSTRACT: Internal Utility subroutines for autodie and Fatal 20 21# docs says we should pick __PACKAGE__ /<whatever> 22my $H_STACK_KEY = __PACKAGE__ . '/stack'; 23 24sub on_end_of_compile_scope { 25 my ($hook) = @_; 26 27 # Dark magic to have autodie work under 5.8 28 # Copied from namespace::clean, that copied it from 29 # autobox, that found it on an ancient scroll written 30 # in blood. 31 32 # This magic bit causes %^H to be lexically scoped. 33 $^H |= 0x020000; 34 35 my $stack = $^H{$H_STACK_KEY}; 36 if (not defined($stack)) { 37 $stack = autodie::Scope::GuardStack->new; 38 $^H{$H_STACK_KEY} = $stack; 39 } 40 41 $stack->push_hook($hook); 42 return; 43} 44 45# This code is based on code from the original Fatal. The "XXXX" 46# remark is from the original code and its meaning is (sadly) unknown. 47sub fill_protos { 48 my ($proto) = @_; 49 my ($n, $isref, @out, @out1, $seen_semi) = -1; 50 if ($proto =~ m{^\s* (?: [;] \s*)? \@}x) { 51 # prototype is entirely slurply - special case that does not 52 # require any handling. 53 return ([0, '@_']); 54 } 55 56 while ($proto =~ /\S/) { 57 $n++; 58 push(@out1,[$n,@out]) if $seen_semi; 59 push(@out, $1 . "{\$_[$n]}"), next if $proto =~ s/^\s*\\([\@%\$\&])//; 60 push(@out, "\$_[$n]"), next if $proto =~ s/^\s*([_*\$&])//; 61 push(@out, "\@_[$n..\$#_]"), last if $proto =~ s/^\s*(;\s*)?\@//; 62 $seen_semi = 1, $n--, next if $proto =~ s/^\s*;//; # XXXX ???? 63 die "Internal error: Unknown prototype letters: \"$proto\""; 64 } 65 push(@out1,[$n+1,@out]); 66 return @out1; 67} 68 69 70sub make_core_trampoline { 71 my ($call, $pkg, $proto_str) = @_; 72 my $trampoline_code = 'sub {'; 73 my $trampoline_sub; 74 my @protos = fill_protos($proto_str); 75 76 foreach my $proto (@protos) { 77 local $" = ", "; # So @args is formatted correctly. 78 my ($count, @args) = @$proto; 79 if (@args && $args[-1] =~ m/[@#]_/) { 80 $trampoline_code .= qq/ 81 if (\@_ >= $count) { 82 return $call(@args); 83 } 84 /; 85 } else { 86 $trampoline_code .= qq< 87 if (\@_ == $count) { 88 return $call(@args); 89 } 90 >; 91 } 92 } 93 94 $trampoline_code .= qq< require Carp; Carp::croak("Internal error in Fatal/autodie. Leak-guard failure"); } >; 95 my $E; 96 97 { 98 local $@; 99 $trampoline_sub = eval "package $pkg;\n $trampoline_code"; ## no critic 100 $E = $@; 101 } 102 die "Internal error in Fatal/autodie: Leak-guard installation failure: $E" 103 if $E; 104 105 return $trampoline_sub; 106} 107 108# The code here is originally lifted from namespace::clean, 109# by Robert "phaylon" Sedlacek. 110# 111# It's been redesigned after feedback from ikegami on perlmonks. 112# See http://perlmonks.org/?node_id=693338 . Ikegami rocks. 113# 114# Given a package, and hash of (subname => subref) pairs, 115# we install the given subroutines into the package. If 116# a subref is undef, the subroutine is removed. Otherwise 117# it replaces any existing subs which were already there. 118 119sub install_subs { 120 my ($target_pkg, $subs_to_reinstate) = @_; 121 122 my $pkg_sym = "${target_pkg}::"; 123 124 # It does not hurt to do this in a predictable order, and might help debugging. 125 foreach my $sub_name (sort keys(%{$subs_to_reinstate})) { 126 127 # We will repeatedly mess with stuff that strict "refs" does 128 # not like. So lets just disable it once for this entire 129 # scope. 130 no strict qw(refs); ## no critic 131 132 my $sub_ref = $subs_to_reinstate->{$sub_name}; 133 134 my $full_path = ${pkg_sym}.${sub_name}; 135 my $oldglob = *$full_path; 136 137 # Nuke the old glob. 138 delete($pkg_sym->{$sub_name}); 139 140 # For some reason this local *alias = *$full_path triggers an 141 # "only used once" warning. Not entirely sure why, but at 142 # least it is easy to silence. 143 no warnings qw(once); 144 local *alias = *$full_path; 145 use warnings qw(once); 146 147 # Copy innocent bystanders back. Note that we lose 148 # formats; it seems that Perl versions up to 5.10.0 149 # have a bug which causes copying formats to end up in 150 # the scalar slot. Thanks to Ben Morrow for spotting this. 151 152 foreach my $slot (qw( SCALAR ARRAY HASH IO ) ) { 153 next unless defined(*$oldglob{$slot}); 154 *alias = *$oldglob{$slot}; 155 } 156 157 if ($sub_ref) { 158 *$full_path = $sub_ref; 159 } 160 } 161 162 return; 163} 164 1651; 166 167__END__ 168 169=head1 NAME 170 171autodie::Util - Internal Utility subroutines for autodie and Fatal 172 173=head1 SYNOPSIS 174 175 # INTERNAL API for autodie and Fatal only! 176 177 use autodie::Util qw(on_end_of_compile_scope); 178 on_end_of_compile_scope(sub { print "Hallo world\n"; }); 179 180=head1 DESCRIPTION 181 182Internal Utilities for autodie and Fatal! This module is not a part of 183autodie's public API. 184 185This module contains utility subroutines for abstracting away the 186underlying magic of autodie and (ab)uses of C<%^H> to call subs at the 187end of a (compile-time) scopes. 188 189Note that due to how C<%^H> works, some of these utilities are only 190useful during the compilation phase of a perl module and relies on the 191internals of how perl handles references in C<%^H>. 192 193=head2 Methods 194 195=head3 on_end_of_compile_scope 196 197 on_end_of_compile_scope(sub { print "Hallo world\n"; }); 198 199Will invoke a sub at the end of a (compile-time) scope. The sub is 200called once with no arguments. Can be called multiple times (even in 201the same "compile-time" scope) to install multiple subs. Subs are 202called in a "first-in-last-out"-order (FILO or "stack"-order). 203 204=head3 fill_protos 205 206 fill_protos('*$$;$@') 207 208Given a Perl subroutine prototype, return a list of invocation 209specifications. Each specification is a listref, where the first 210member is the (minimum) number of arguments for this invocation 211specification. The remaining arguments are a string representation of 212how to pass the arguments correctly to a sub with the given prototype, 213when called with the given number of arguments. 214 215The specifications are returned in increasing order of arguments 216starting at 0 (e.g. ';$') or 1 (e.g. '$@'). Note that if the 217prototype is "slurpy" (e.g. ends with a "@"), the number of arguments 218for the last specification is a "minimum" number rather than an exact 219number. This can be detected by the last member of the last 220specification matching m/[@#]_/. 221 222=head3 make_core_trampoline 223 224 make_core_trampoline('CORE::open', 'main', prototype('CORE::open')) 225 226Creates a trampoline for calling a core sub. Essentially, a tiny sub 227that figures out how we should be calling our core sub, puts in the 228arguments in the right way, and bounces our control over to it. 229 230If we could reliably use `goto &` on core builtins, we wouldn't need 231this subroutine. 232 233=head3 install_subs 234 235 install_subs('My::Module', { 'read' => sub { die("Hallo\n"), ... }}) 236 237Given a package name and a hashref mapping names to a subroutine 238reference (or C<undef>), this subroutine will install said subroutines 239on their given name in that module. If a name mapes to C<undef>, any 240subroutine with that name in the target module will be removed 241(possibly "unshadowing" a CORE sub of same name). 242 243=head1 AUTHOR 244 245Copyright 2013-2014, Niels Thykier E<lt>niels@thykier.netE<gt> 246 247=head1 LICENSE 248 249This module is free software. You may distribute it under the 250same terms as Perl itself. 251