Commit | Line | Data |
---|---|---|
e92e55da MB |
1 | package Fatal; |
2 | ||
273225d4 CBW |
3 | # ABSTRACT: Replace functions with equivalents which succeed or die |
4 | ||
0b09a93a | 5 | use 5.008; # 5.8.x needed for autodie |
e92e55da MB |
6 | use Carp; |
7 | use strict; | |
0b09a93a | 8 | use warnings; |
9b657a62 | 9 | use Tie::RefHash; # To cache subroutine refs |
a009834b | 10 | use Config; |
273225d4 | 11 | use Scalar::Util qw(set_prototype); |
9b657a62 PF |
12 | |
13 | use constant PERL510 => ( $] >= 5.010 ); | |
e92e55da | 14 | |
0b09a93a PF |
15 | use constant LEXICAL_TAG => q{:lexical}; |
16 | use constant VOID_TAG => q{:void}; | |
9b657a62 | 17 | use constant INSIST_TAG => q{!}; |
e92e55da | 18 | |
082a4c42 SH |
19 | # Keys for %Cached_fatalised_sub (used in 3rd level) |
20 | use constant CACHE_AUTODIE_LEAK_GUARD => 0; | |
21 | use constant CACHE_FATAL_WRAPPER => 1; | |
22 | use constant CACHE_FATAL_VOID => 2; | |
23 | ||
24 | ||
0b09a93a PF |
25 | use constant ERROR_NOARGS => 'Cannot use lexical %s with no arguments'; |
26 | use constant ERROR_VOID_LEX => VOID_TAG.' cannot be used with lexical scope'; | |
27 | use constant ERROR_LEX_FIRST => LEXICAL_TAG.' must be used as first argument'; | |
28 | use constant ERROR_NO_LEX => "no %s can only start with ".LEXICAL_TAG; | |
29 | use constant ERROR_BADNAME => "Bad subroutine name for %s: %s"; | |
30 | use constant ERROR_NOTSUB => "%s is not a Perl subroutine"; | |
31 | use constant ERROR_NOT_BUILT => "%s is neither a builtin, nor a Perl subroutine"; | |
9b657a62 PF |
32 | use constant ERROR_NOHINTS => "No user hints defined for %s"; |
33 | ||
0b09a93a PF |
34 | use constant ERROR_CANT_OVERRIDE => "Cannot make the non-overridable builtin %s fatal"; |
35 | ||
36 | use constant ERROR_NO_IPC_SYS_SIMPLE => "IPC::System::Simple required for Fatalised/autodying system()"; | |
37 | ||
38 | use constant ERROR_IPC_SYS_SIMPLE_OLD => "IPC::System::Simple version %f required for Fatalised/autodying system(). We only have version %f"; | |
39 | ||
40 | use constant ERROR_AUTODIE_CONFLICT => q{"no autodie '%s'" is not allowed while "use Fatal '%s'" is in effect}; | |
41 | ||
42 | use constant ERROR_FATAL_CONFLICT => q{"use Fatal '%s'" is not allowed while "no autodie '%s'" is in effect}; | |
43 | ||
9b657a62 PF |
44 | use constant ERROR_58_HINTS => q{Non-subroutine %s hints for %s are not supported under Perl 5.8.x}; |
45 | ||
0b09a93a PF |
46 | # Older versions of IPC::System::Simple don't support all the |
47 | # features we need. | |
48 | ||
49 | use constant MIN_IPC_SYS_SIMPLE_VER => 0.12; | |
50 | ||
c7e47358 | 51 | our $VERSION = '2.23'; # VERSION: Generated by DZP::OurPkg::Version |
0b09a93a PF |
52 | |
53 | our $Debug ||= 0; | |
54 | ||
55 | # EWOULDBLOCK values for systems that don't supply their own. | |
56 | # Even though this is defined with our, that's to help our | |
57 | # test code. Please don't rely upon this variable existing in | |
58 | # the future. | |
59 | ||
60 | our %_EWOULDBLOCK = ( | |
61 | MSWin32 => 33, | |
62 | ); | |
63 | ||
a009834b CBW |
64 | # the linux parisc port has separate EAGAIN and EWOULDBLOCK, |
65 | # and the kernel returns EAGAIN | |
66 | my $try_EAGAIN = ($^O eq 'linux' and $Config{archname} =~ /hppa|parisc/) ? 1 : 0; | |
67 | ||
0b09a93a PF |
68 | # We have some tags that can be passed in for use with import. |
69 | # These are all assumed to be CORE:: | |
70 | ||
71 | my %TAGS = ( | |
72 | ':io' => [qw(:dbm :file :filesys :ipc :socket | |
73 | read seek sysread syswrite sysseek )], | |
74 | ':dbm' => [qw(dbmopen dbmclose)], | |
75 | ':file' => [qw(open close flock sysopen fcntl fileno binmode | |
273225d4 | 76 | ioctl truncate)], |
0b09a93a | 77 | ':filesys' => [qw(opendir closedir chdir link unlink rename mkdir |
273225d4 CBW |
78 | symlink rmdir readlink umask chmod chown utime)], |
79 | ':ipc' => [qw(:msg :semaphore :shm pipe kill)], | |
0b09a93a PF |
80 | ':msg' => [qw(msgctl msgget msgrcv msgsnd)], |
81 | ':threads' => [qw(fork)], | |
82 | ':semaphore'=>[qw(semctl semget semop)], | |
83 | ':shm' => [qw(shmctl shmget shmread)], | |
84 | ':system' => [qw(system exec)], | |
85 | ||
86 | # Can we use qw(getpeername getsockname)? What do they do on failure? | |
9b657a62 | 87 | # TODO - Can socket return false? |
0b09a93a PF |
88 | ':socket' => [qw(accept bind connect getsockopt listen recv send |
89 | setsockopt shutdown socketpair)], | |
90 | ||
91 | # Our defaults don't include system(), because it depends upon | |
92 | # an optional module, and it breaks the exotic form. | |
93 | # | |
94 | # This *may* change in the future. I'd love IPC::System::Simple | |
95 | # to be a dependency rather than a recommendation, and hence for | |
96 | # system() to be autodying by default. | |
97 | ||
98 | ':default' => [qw(:io :threads)], | |
99 | ||
273225d4 CBW |
100 | # Everything in v2.07 and brefore. This was :default less chmod and chown |
101 | ':v207' => [qw(:threads :dbm :socket read seek sysread | |
a009834b | 102 | syswrite sysseek open close flock sysopen fcntl fileno |
273225d4 CBW |
103 | binmode ioctl truncate opendir closedir chdir link unlink |
104 | rename mkdir symlink rmdir readlink umask | |
105 | :msg :semaphore :shm pipe)], | |
106 | ||
107 | # Chmod was added in 2.13 | |
108 | ':v213' => [qw(:v207 chmod)], | |
109 | ||
110 | # chown, utime, kill were added in 2.14 | |
111 | ':v214' => [qw(:v213 chown utime kill)], | |
a009834b | 112 | |
0b09a93a PF |
113 | # Version specific tags. These allow someone to specify |
114 | # use autodie qw(:1.994) and know exactly what they'll get. | |
115 | ||
a009834b CBW |
116 | ':1.994' => [qw(:v207)], |
117 | ':1.995' => [qw(:v207)], | |
118 | ':1.996' => [qw(:v207)], | |
119 | ':1.997' => [qw(:v207)], | |
120 | ':1.998' => [qw(:v207)], | |
121 | ':1.999' => [qw(:v207)], | |
122 | ':1.999_01' => [qw(:v207)], | |
123 | ':2.00' => [qw(:v207)], | |
124 | ':2.01' => [qw(:v207)], | |
125 | ':2.02' => [qw(:v207)], | |
126 | ':2.03' => [qw(:v207)], | |
127 | ':2.04' => [qw(:v207)], | |
128 | ':2.05' => [qw(:v207)], | |
129 | ':2.06' => [qw(:v207)], | |
130 | ':2.06_01' => [qw(:v207)], | |
131 | ':2.07' => [qw(:v207)], # Last release without chmod | |
273225d4 CBW |
132 | ':2.08' => [qw(:v213)], |
133 | ':2.09' => [qw(:v213)], | |
134 | ':2.10' => [qw(:v213)], | |
135 | ':2.11' => [qw(:v213)], | |
136 | ':2.12' => [qw(:v213)], | |
137 | ':2.13' => [qw(:v213)], | |
138 | ':2.14' => [qw(:default)], | |
139 | ':2.15' => [qw(:default)], | |
140 | ':2.16' => [qw(:default)], | |
141 | ':2.17' => [qw(:default)], | |
142 | ':2.18' => [qw(:default)], | |
143 | ':2.19' => [qw(:default)], | |
391c7215 | 144 | ':2.20' => [qw(:default)], |
082a4c42 | 145 | ':2.21' => [qw(:default)], |
ff4ad1c0 | 146 | ':2.22' => [qw(:default)], |
c7e47358 | 147 | ':2.23' => [qw(:default)], |
0b09a93a PF |
148 | ); |
149 | ||
a009834b | 150 | # chmod was only introduced in 2.07 |
273225d4 | 151 | # chown was only introduced in 2.14 |
a009834b | 152 | |
082a4c42 SH |
153 | { |
154 | # Expand :all immediately by expanding and flattening all tags. | |
155 | # _expand_tag is not really optimised for expanding the ":all" | |
156 | # case (i.e. keys %TAGS, or values %TAGS for that matter), so we | |
157 | # just do it here. | |
158 | # | |
159 | # NB: The %tag_cache/_expand_tag relies on $TAGS{':all'} being | |
160 | # pre-expanded. | |
161 | my %seen; | |
162 | my @all = grep { | |
163 | !/^:/ && !$seen{$_}++ | |
164 | } map { @{$_} } values %TAGS; | |
165 | $TAGS{':all'} = \@all; | |
166 | } | |
0b09a93a PF |
167 | |
168 | # This hash contains subroutines for which we should | |
169 | # subroutine() // die() rather than subroutine() || die() | |
170 | ||
171 | my %Use_defined_or; | |
172 | ||
173 | # CORE::open returns undef on failure. It can legitimately return | |
174 | # 0 on success, eg: open(my $fh, '-|') || exec(...); | |
175 | ||
176 | @Use_defined_or{qw( | |
177 | CORE::fork | |
178 | CORE::recv | |
179 | CORE::send | |
180 | CORE::open | |
181 | CORE::fileno | |
182 | CORE::read | |
183 | CORE::readlink | |
184 | CORE::sysread | |
185 | CORE::syswrite | |
186 | CORE::sysseek | |
187 | CORE::umask | |
188 | )} = (); | |
189 | ||
273225d4 CBW |
190 | # Some functions can return true because they changed *some* things, but |
191 | # not all of them. This is a list of offending functions, and how many | |
192 | # items to subtract from @_ to determine the "success" value they return. | |
20da2e5b | 193 | |
273225d4 CBW |
194 | my %Returns_num_things_changed = ( |
195 | 'CORE::chmod' => 1, | |
196 | 'CORE::chown' => 2, | |
197 | 'CORE::kill' => 1, # TODO: Could this return anything on negative args? | |
198 | 'CORE::unlink' => 0, | |
199 | 'CORE::utime' => 2, | |
200 | ); | |
20da2e5b CBW |
201 | |
202 | # Optional actions to take on the return value before returning it. | |
203 | ||
204 | my %Retval_action = ( | |
205 | "CORE::open" => q{ | |
206 | ||
207 | # apply the open pragma from our caller | |
208 | if( defined $retval ) { | |
209 | # Get the caller's hint hash | |
210 | my $hints = (caller 0)[10]; | |
211 | ||
212 | # Decide if we're reading or writing and apply the appropriate encoding | |
213 | # These keys are undocumented. | |
214 | # Match what PerlIO_context_layers() does. Read gets the read layer, | |
215 | # everything else gets the write layer. | |
216 | my $encoding = $_[1] =~ /^\+?>/ ? $hints->{"open>"} : $hints->{"open<"}; | |
217 | ||
218 | # Apply the encoding, if any. | |
219 | if( $encoding ) { | |
220 | binmode $_[0], $encoding; | |
221 | } | |
222 | } | |
223 | ||
224 | }, | |
225 | "CORE::sysopen" => q{ | |
226 | ||
227 | # apply the open pragma from our caller | |
228 | if( defined $retval ) { | |
229 | # Get the caller's hint hash | |
230 | my $hints = (caller 0)[10]; | |
231 | ||
232 | require Fcntl; | |
233 | ||
234 | # Decide if we're reading or writing and apply the appropriate encoding. | |
235 | # Match what PerlIO_context_layers() does. Read gets the read layer, | |
236 | # everything else gets the write layer. | |
237 | my $open_read_only = !($_[2] ^ Fcntl::O_RDONLY()); | |
238 | my $encoding = $open_read_only ? $hints->{"open<"} : $hints->{"open>"}; | |
239 | ||
240 | # Apply the encoding, if any. | |
241 | if( $encoding ) { | |
242 | binmode $_[0], $encoding; | |
243 | } | |
244 | } | |
245 | ||
246 | }, | |
247 | ); | |
248 | ||
273225d4 CBW |
249 | my %reusable_builtins; |
250 | ||
251 | # "Wait!" I hear you cry, "truncate() and chdir() are not reuseable! They can | |
252 | # take file and directory handles, which are package depedent." | |
253 | # | |
254 | # You would be correct, except that prototype() returns signatures which don't | |
255 | # allow for passing of globs, and nobody's complained about that. You can | |
256 | # still use \*FILEHANDLE, but that results in a reference coming through, | |
257 | # and it's already pointing to the filehandle in the caller's packge, so | |
258 | # it's all okay. | |
259 | ||
260 | @reusable_builtins{qw( | |
261 | CORE::fork | |
262 | CORE::kill | |
263 | CORE::truncate | |
264 | CORE::chdir | |
265 | CORE::link | |
266 | CORE::unlink | |
267 | CORE::rename | |
268 | CORE::mkdir | |
269 | CORE::symlink | |
270 | CORE::rmdir | |
271 | CORE::readlink | |
272 | CORE::umask | |
273 | CORE::chmod | |
274 | CORE::chown | |
275 | CORE::utime | |
276 | CORE::msgctl | |
277 | CORE::msgget | |
278 | CORE::msgrcv | |
279 | CORE::msgsnd | |
280 | CORE::semctl | |
281 | CORE::semget | |
282 | CORE::semop | |
283 | CORE::shmctl | |
284 | CORE::shmget | |
285 | CORE::shmread | |
286 | )} = (); | |
287 | ||
0b09a93a PF |
288 | # Cached_fatalised_sub caches the various versions of our |
289 | # fatalised subs as they're produced. This means we don't | |
290 | # have to build our own replacement of CORE::open and friends | |
291 | # for every single package that wants to use them. | |
292 | ||
293 | my %Cached_fatalised_sub = (); | |
294 | ||
295 | # Every time we're called with package scope, we record the subroutine | |
296 | # (including package or CORE::) in %Package_Fatal. This allows us | |
297 | # to detect illegal combinations of autodie and Fatal, and makes sure | |
298 | # we don't accidently make a Fatal function autodying (which isn't | |
299 | # very useful). | |
300 | ||
301 | my %Package_Fatal = (); | |
302 | ||
303 | # The first time we're called with a user-sub, we cache it here. | |
304 | # In the case of a "no autodie ..." we put back the cached copy. | |
305 | ||
306 | my %Original_user_sub = (); | |
307 | ||
9b657a62 PF |
308 | # Is_fatalised_sub simply records a big map of fatalised subroutine |
309 | # refs. It means we can avoid repeating work, or fatalising something | |
310 | # we've already processed. | |
311 | ||
312 | my %Is_fatalised_sub = (); | |
313 | tie %Is_fatalised_sub, 'Tie::RefHash'; | |
314 | ||
273225d4 CBW |
315 | # Our trampoline cache allows us to cache trampolines which are used to |
316 | # bounce leaked wrapped core subroutines to their actual core counterparts. | |
317 | ||
318 | my %Trampoline_cache; | |
319 | ||
082a4c42 SH |
320 | # A cache mapping "CORE::<name>" to their prototype. Turns out that if |
321 | # you "use autodie;" enough times, this pays off. | |
322 | my %CORE_prototype_cache; | |
323 | ||
0b09a93a PF |
324 | # We use our package in a few hash-keys. Having it in a scalar is |
325 | # convenient. The "guard $PACKAGE" string is used as a key when | |
326 | # setting up lexical guards. | |
327 | ||
328 | my $PACKAGE = __PACKAGE__; | |
329 | my $PACKAGE_GUARD = "guard $PACKAGE"; | |
330 | my $NO_PACKAGE = "no $PACKAGE"; # Used to detect 'no autodie' | |
331 | ||
332 | # Here's where all the magic happens when someone write 'use Fatal' | |
333 | # or 'use autodie'. | |
e92e55da MB |
334 | |
335 | sub import { | |
9b657a62 | 336 | my $class = shift(@_); |
a009834b | 337 | my @original_args = @_; |
9b657a62 PF |
338 | my $void = 0; |
339 | my $lexical = 0; | |
340 | my $insist_hints = 0; | |
0b09a93a PF |
341 | |
342 | my ($pkg, $filename) = caller(); | |
343 | ||
344 | @_ or return; # 'use Fatal' is a no-op. | |
345 | ||
346 | # If we see the :lexical flag, then _all_ arguments are | |
347 | # changed lexically | |
348 | ||
349 | if ($_[0] eq LEXICAL_TAG) { | |
350 | $lexical = 1; | |
351 | shift @_; | |
352 | ||
353 | # If we see no arguments and :lexical, we assume they | |
354 | # wanted ':default'. | |
355 | ||
356 | if (@_ == 0) { | |
357 | push(@_, ':default'); | |
358 | } | |
359 | ||
360 | # Don't allow :lexical with :void, it's needlessly confusing. | |
361 | if ( grep { $_ eq VOID_TAG } @_ ) { | |
362 | croak(ERROR_VOID_LEX); | |
363 | } | |
364 | } | |
365 | ||
366 | if ( grep { $_ eq LEXICAL_TAG } @_ ) { | |
367 | # If we see the lexical tag as the non-first argument, complain. | |
368 | croak(ERROR_LEX_FIRST); | |
369 | } | |
370 | ||
371 | my @fatalise_these = @_; | |
372 | ||
082a4c42 | 373 | # These subs will get unloaded at the end of lexical scope. |
0b09a93a | 374 | my %unload_later; |
082a4c42 SH |
375 | # These subs are to be installed into callers namespace. |
376 | my %install_subs; | |
0b09a93a | 377 | |
391c7215 CBW |
378 | # Use _translate_import_args to expand tags for us. It will |
379 | # pass-through unknown tags (i.e. we have to manually handle | |
380 | # VOID_TAG). | |
381 | # | |
c7e47358 CBW |
382 | # NB: _translate_import_args re-orders everything for us, so |
383 | # we don't have to worry about stuff like: | |
391c7215 | 384 | # |
c7e47358 CBW |
385 | # :default :void :io |
386 | # | |
387 | # That will (correctly) translated into | |
388 | # | |
389 | # expand(:defaults-without-io) :void :io | |
390 | # | |
391 | # by _translate_import_args. | |
391c7215 | 392 | for my $func ($class->_translate_import_args(@fatalise_these)) { |
0b09a93a PF |
393 | |
394 | if ($func eq VOID_TAG) { | |
395 | ||
396 | # When we see :void, set the void flag. | |
397 | $void = 1; | |
398 | ||
9b657a62 PF |
399 | } elsif ($func eq INSIST_TAG) { |
400 | ||
401 | $insist_hints = 1; | |
402 | ||
0b09a93a PF |
403 | } else { |
404 | ||
405 | # Otherwise, fatalise it. | |
406 | ||
9b657a62 PF |
407 | # Check to see if there's an insist flag at the front. |
408 | # If so, remove it, and insist we have hints for this sub. | |
082a4c42 | 409 | my $insist_this = $insist_hints; |
9b657a62 | 410 | |
082a4c42 SH |
411 | if (substr($func, 0, 1) eq '!') { |
412 | $func = substr($func, 1); | |
9b657a62 PF |
413 | $insist_this = 1; |
414 | } | |
415 | ||
0b09a93a PF |
416 | # We're going to make a subroutine fatalistic. |
417 | # However if we're being invoked with 'use Fatal qw(x)' | |
418 | # and we've already been called with 'no autodie qw(x)' | |
419 | # in the same scope, we consider this to be an error. | |
420 | # Mixing Fatal and autodie effects was considered to be | |
421 | # needlessly confusing on p5p. | |
422 | ||
423 | my $sub = $func; | |
424 | $sub = "${pkg}::$sub" unless $sub =~ /::/; | |
425 | ||
426 | # If we're being called as Fatal, and we've previously | |
427 | # had a 'no X' in scope for the subroutine, then complain | |
428 | # bitterly. | |
429 | ||
430 | if (! $lexical and $^H{$NO_PACKAGE}{$sub}) { | |
431 | croak(sprintf(ERROR_FATAL_CONFLICT, $func, $func)); | |
432 | } | |
433 | ||
434 | # We're not being used in a confusing way, so make | |
435 | # the sub fatal. Note that _make_fatal returns the | |
436 | # old (original) version of the sub, or undef for | |
437 | # built-ins. | |
438 | ||
439 | my $sub_ref = $class->_make_fatal( | |
9b657a62 | 440 | $func, $pkg, $void, $lexical, $filename, |
082a4c42 | 441 | $insist_this, \%install_subs, |
0b09a93a PF |
442 | ); |
443 | ||
0b09a93a PF |
444 | $Original_user_sub{$sub} ||= $sub_ref; |
445 | ||
446 | # If we're making lexical changes, we need to arrange | |
447 | # for them to be cleaned at the end of our scope, so | |
448 | # record them here. | |
449 | ||
450 | $unload_later{$func} = $sub_ref if $lexical; | |
451 | } | |
452 | } | |
453 | ||
082a4c42 SH |
454 | $class->_install_subs($pkg, \%install_subs); |
455 | ||
0b09a93a PF |
456 | if ($lexical) { |
457 | ||
458 | # Dark magic to have autodie work under 5.8 | |
459 | # Copied from namespace::clean, that copied it from | |
460 | # autobox, that found it on an ancient scroll written | |
461 | # in blood. | |
462 | ||
463 | # This magic bit causes %^H to be lexically scoped. | |
464 | ||
465 | $^H |= 0x020000; | |
466 | ||
467 | # Our package guard gets invoked when we leave our lexical | |
468 | # scope. | |
469 | ||
470 | push(@ { $^H{$PACKAGE_GUARD} }, autodie::Scope::Guard->new(sub { | |
471 | $class->_install_subs($pkg, \%unload_later); | |
472 | })); | |
473 | ||
a009834b CBW |
474 | # To allow others to determine when autodie was in scope, |
475 | # and with what arguments, we also set a %^H hint which | |
476 | # is how we were called. | |
477 | ||
478 | # This feature should be considered EXPERIMENTAL, and | |
479 | # may change without notice. Please e-mail pjf@cpan.org | |
480 | # if you're actually using it. | |
481 | ||
482 | $^H{autodie} = "$PACKAGE @original_args"; | |
483 | ||
0b09a93a PF |
484 | } |
485 | ||
486 | return; | |
487 | ||
488 | } | |
489 | ||
490 | # The code here is originally lifted from namespace::clean, | |
491 | # by Robert "phaylon" Sedlacek. | |
492 | # | |
493 | # It's been redesigned after feedback from ikegami on perlmonks. | |
494 | # See http://perlmonks.org/?node_id=693338 . Ikegami rocks. | |
495 | # | |
496 | # Given a package, and hash of (subname => subref) pairs, | |
497 | # we install the given subroutines into the package. If | |
498 | # a subref is undef, the subroutine is removed. Otherwise | |
499 | # it replaces any existing subs which were already there. | |
500 | ||
501 | sub _install_subs { | |
502 | my ($class, $pkg, $subs_to_reinstate) = @_; | |
503 | ||
504 | my $pkg_sym = "${pkg}::"; | |
505 | ||
91d419ac YO |
506 | # It does not hurt to do this in a predictable order, and might help debugging. |
507 | foreach my $sub_name (sort keys %$subs_to_reinstate) { | |
0b09a93a | 508 | |
c7e47358 CBW |
509 | # We will repeatedly mess with stuff that strict "refs" does |
510 | # not like. So lets just disable it once for this entire | |
511 | # scope. | |
512 | no strict qw(refs); ## no critic | |
0b09a93a | 513 | |
c7e47358 | 514 | my $sub_ref= $subs_to_reinstate->{$sub_name}; |
0b09a93a | 515 | |
c7e47358 CBW |
516 | my $full_path = $pkg_sym.$sub_name; |
517 | my $oldglob = *$full_path; | |
0b09a93a PF |
518 | |
519 | # Nuke the old glob. | |
c7e47358 CBW |
520 | delete $pkg_sym->{$sub_name}; |
521 | ||
522 | # For some reason this local *alias = *$full_path triggers an | |
523 | # "only used once" warning. Not entirely sure why, but at | |
524 | # least it is easy to silence. | |
525 | no warnings qw(once); | |
526 | local *alias = *$full_path; | |
527 | use warnings qw(once); | |
0b09a93a | 528 | |
9b657a62 PF |
529 | # Copy innocent bystanders back. Note that we lose |
530 | # formats; it seems that Perl versions up to 5.10.0 | |
531 | # have a bug which causes copying formats to end up in | |
532 | # the scalar slot. Thanks to Ben Morrow for spotting this. | |
0b09a93a | 533 | |
9b657a62 | 534 | foreach my $slot (qw( SCALAR ARRAY HASH IO ) ) { |
c7e47358 CBW |
535 | next unless defined *$oldglob{$slot}; |
536 | *alias = *$oldglob{$slot}; | |
0b09a93a PF |
537 | } |
538 | ||
0b09a93a | 539 | if ($sub_ref) { |
c7e47358 | 540 | *$full_path = $sub_ref; |
0b09a93a PF |
541 | } |
542 | } | |
543 | ||
544 | return; | |
545 | } | |
546 | ||
547 | sub unimport { | |
548 | my $class = shift; | |
549 | ||
550 | # Calling "no Fatal" must start with ":lexical" | |
551 | if ($_[0] ne LEXICAL_TAG) { | |
552 | croak(sprintf(ERROR_NO_LEX,$class)); | |
553 | } | |
554 | ||
555 | shift @_; # Remove :lexical | |
556 | ||
557 | my $pkg = (caller)[0]; | |
558 | ||
559 | # If we've been called with arguments, then the developer | |
560 | # has explicitly stated 'no autodie qw(blah)', | |
561 | # in which case, we disable Fatalistic behaviour for 'blah'. | |
562 | ||
563 | my @unimport_these = @_ ? @_ : ':all'; | |
082a4c42 | 564 | my %uninstall_subs; |
0b09a93a | 565 | |
391c7215 | 566 | for my $symbol ($class->_translate_import_args(@unimport_these)) { |
0b09a93a PF |
567 | |
568 | my $sub = $symbol; | |
569 | $sub = "${pkg}::$sub" unless $sub =~ /::/; | |
570 | ||
571 | # If 'blah' was already enabled with Fatal (which has package | |
572 | # scope) then, this is considered an error. | |
573 | ||
574 | if (exists $Package_Fatal{$sub}) { | |
575 | croak(sprintf(ERROR_AUTODIE_CONFLICT,$symbol,$symbol)); | |
576 | } | |
577 | ||
578 | # Record 'no autodie qw($sub)' as being in effect. | |
579 | # This is to catch conflicting semantics elsewhere | |
580 | # (eg, mixing Fatal with no autodie) | |
581 | ||
582 | $^H{$NO_PACKAGE}{$sub} = 1; | |
583 | ||
584 | if (my $original_sub = $Original_user_sub{$sub}) { | |
585 | # Hey, we've got an original one of these, put it back. | |
082a4c42 | 586 | $uninstall_subs{$symbol} = $original_sub; |
0b09a93a PF |
587 | next; |
588 | } | |
589 | ||
590 | # We don't have an original copy of the sub, on the assumption | |
591 | # it's core (or doesn't exist), we'll just nuke it. | |
592 | ||
082a4c42 | 593 | $uninstall_subs{$symbol} = undef; |
0b09a93a PF |
594 | |
595 | } | |
596 | ||
082a4c42 SH |
597 | $class->_install_subs($pkg, \%uninstall_subs); |
598 | ||
0b09a93a PF |
599 | return; |
600 | ||
601 | } | |
602 | ||
391c7215 CBW |
603 | sub _translate_import_args { |
604 | my ($class, @args) = @_; | |
605 | my @result; | |
c7e47358 CBW |
606 | my %seen; |
607 | ||
608 | if (@args < 2) { | |
609 | # Optimize for this case, as it is fairly common. (e.g. use | |
610 | # autodie; or use autodie qw(:all); both trigger this). | |
611 | return unless @args; | |
612 | ||
613 | # Not a (known) tag, pass through. | |
614 | return @args unless exists($TAGS{$args[0]}); | |
615 | ||
616 | # Strip "CORE::" from all elements in the list as import and | |
617 | # unimport does not handle the "CORE::" prefix too well. | |
618 | # | |
619 | # NB: we use substr as it is faster than s/^CORE::// and | |
620 | # it does not change the elements. | |
621 | return map { substr($_, 6) } @{ $class->_expand_tag($args[0]) }; | |
622 | } | |
623 | ||
624 | # We want to translate | |
625 | # | |
626 | # :default :void :io | |
627 | # | |
628 | # into (pseudo-ish): | |
629 | # | |
630 | # expanded(:threads) :void expanded(:io) | |
631 | # | |
632 | # We accomplish this by "reverse, expand + filter, reverse". | |
633 | for my $a (reverse(@args)) { | |
391c7215 CBW |
634 | if (exists $TAGS{$a}) { |
635 | my $expanded = $class->_expand_tag($a); | |
c7e47358 CBW |
636 | push(@result, |
637 | # Remove duplicates after ... | |
638 | grep { !$seen{$_}++ } | |
639 | # we have stripped CORE:: (see above) | |
640 | map { substr($_, 6) } | |
641 | # We take the elements in reverse order | |
642 | # (as @result be reversed later). | |
643 | reverse(@{$expanded})); | |
391c7215 | 644 | } else { |
c7e47358 CBW |
645 | # pass through - no filtering here for tags. |
646 | # | |
647 | # The reason for not filtering tags cases like: | |
648 | # | |
649 | # ":default :void :io :void :threads" | |
650 | # | |
651 | # As we have reversed args, we see this as: | |
652 | # | |
653 | # ":threads :void :io :void* :default*" | |
654 | # | |
655 | # (Entries marked with "*" will be filtered out completely). When | |
656 | # reversed again, this will be: | |
657 | # | |
658 | # ":io :void :threads" | |
659 | # | |
660 | # But we would rather want it to be: | |
661 | # | |
662 | # ":void :io :threads" or ":void :io :void :threads" | |
663 | # | |
664 | ||
665 | my $letter = substr($a, 0, 1); | |
666 | if ($letter ne ':' && $a ne INSIST_TAG) { | |
667 | next if $seen{$a}++; | |
668 | if ($letter eq '!' and $seen{substr($a, 1)}++) { | |
669 | my $name = substr($a, 1); | |
670 | # People are being silly and doing: | |
671 | # | |
672 | # use autodie qw(!a a); | |
673 | # | |
674 | # Enjoy this little O(n) clean up... | |
675 | @result = grep { $_ ne $name } @result; | |
676 | } | |
677 | } | |
391c7215 CBW |
678 | push @result, $a; |
679 | } | |
680 | } | |
c7e47358 CBW |
681 | # Reverse the result to restore the input order |
682 | return reverse(@result); | |
391c7215 CBW |
683 | } |
684 | ||
0b09a93a PF |
685 | |
686 | # NB: Perl::Critic's dump-autodie-tag-contents depends upon this | |
687 | # continuing to work. | |
688 | ||
689 | { | |
082a4c42 SH |
690 | # We assume that $TAGS{':all'} is pre-expanded and just fill it in |
691 | # from the beginning. | |
692 | my %tag_cache = ( | |
693 | 'all' => [map { "CORE::$_" } @{$TAGS{':all'}}], | |
694 | ); | |
0b09a93a | 695 | |
391c7215 CBW |
696 | # Expand a given tag (e.g. ":default") into a listref containing |
697 | # all sub names covered by that tag. Each sub is returned as | |
698 | # "CORE::<name>" (i.e. "CORE::open" rather than "open"). | |
699 | # | |
700 | # NB: the listref must not be modified. | |
0b09a93a PF |
701 | sub _expand_tag { |
702 | my ($class, $tag) = @_; | |
703 | ||
704 | if (my $cached = $tag_cache{$tag}) { | |
705 | return $cached; | |
706 | } | |
707 | ||
708 | if (not exists $TAGS{$tag}) { | |
709 | croak "Invalid exception class $tag"; | |
710 | } | |
711 | ||
712 | my @to_process = @{$TAGS{$tag}}; | |
713 | ||
391c7215 CBW |
714 | # If the tag is basically an alias of another tag (like e.g. ":2.11"), |
715 | # then just share the resulting reference with the original content (so | |
716 | # we only pay for an extra reference for the alias memory-wise). | |
717 | if (@to_process == 1 && substr($to_process[0], 0, 1) eq ':') { | |
718 | # We could do this for "non-tags" as well, but that only occurs | |
719 | # once at the time of writing (":threads" => ["fork"]), so | |
720 | # probably not worth it. | |
721 | my $expanded = $class->_expand_tag($to_process[0]); | |
722 | $tag_cache{$tag} = $expanded; | |
723 | return $expanded; | |
724 | } | |
725 | ||
726 | my %seen = (); | |
0b09a93a PF |
727 | my @taglist = (); |
728 | ||
391c7215 CBW |
729 | for my $item (@to_process) { |
730 | # substr is more efficient than m/^:/ for stuff like this, | |
731 | # at the price of being a bit more verbose/low-level. | |
732 | if (substr($item, 0, 1) eq ':') { | |
733 | # Use recursion here to ensure we expand a tag at most once. | |
391c7215 CBW |
734 | |
735 | my $expanded = $class->_expand_tag($item); | |
736 | push @taglist, grep { !$seen{$_}++ } @{$expanded}; | |
737 | } else { | |
738 | my $subname = "CORE::$item"; | |
739 | push @taglist, $subname | |
740 | unless $seen{$subname}++; | |
0b09a93a PF |
741 | } |
742 | } | |
743 | ||
744 | $tag_cache{$tag} = \@taglist; | |
745 | ||
746 | return \@taglist; | |
747 | ||
748 | } | |
749 | ||
e92e55da MB |
750 | } |
751 | ||
0b09a93a | 752 | # This code is from the original Fatal. It scares me. |
9b657a62 PF |
753 | # It is 100% compatible with the 5.10.0 Fatal module, right down |
754 | # to the scary 'XXXX' comment. ;) | |
0b09a93a | 755 | |
e92e55da | 756 | sub fill_protos { |
0b09a93a PF |
757 | my $proto = shift; |
758 | my ($n, $isref, @out, @out1, $seen_semi) = -1; | |
391c7215 CBW |
759 | if ($proto =~ m{^\s* (?: [;] \s*)? \@}x) { |
760 | # prototype is entirely slurp - special case that does not | |
761 | # require any handling. | |
762 | return ([0, '@_']); | |
763 | } | |
764 | ||
0b09a93a PF |
765 | while ($proto =~ /\S/) { |
766 | $n++; | |
767 | push(@out1,[$n,@out]) if $seen_semi; | |
768 | push(@out, $1 . "{\$_[$n]}"), next if $proto =~ s/^\s*\\([\@%\$\&])//; | |
769 | push(@out, "\$_[$n]"), next if $proto =~ s/^\s*([_*\$&])//; | |
770 | push(@out, "\@_[$n..\$#_]"), last if $proto =~ s/^\s*(;\s*)?\@//; | |
771 | $seen_semi = 1, $n--, next if $proto =~ s/^\s*;//; # XXXX ???? | |
772 | die "Internal error: Unknown prototype letters: \"$proto\""; | |
773 | } | |
774 | push(@out1,[$n+1,@out]); | |
775 | return @out1; | |
e92e55da MB |
776 | } |
777 | ||
9b657a62 PF |
778 | # This is a backwards compatible version of _write_invocation. It's |
779 | # recommended you don't use it. | |
0b09a93a | 780 | |
e92e55da | 781 | sub write_invocation { |
9b657a62 PF |
782 | my ($core, $call, $name, $void, @args) = @_; |
783 | ||
784 | return Fatal->_write_invocation( | |
785 | $core, $call, $name, $void, | |
786 | 0, # Lexical flag | |
787 | undef, # Sub, unused in legacy mode | |
788 | undef, # Subref, unused in legacy mode. | |
789 | @args | |
790 | ); | |
791 | } | |
792 | ||
793 | # This version of _write_invocation is used internally. It's not | |
794 | # recommended you call it from external code, as the interface WILL | |
795 | # change in the future. | |
796 | ||
797 | sub _write_invocation { | |
798 | ||
799 | my ($class, $core, $call, $name, $void, $lexical, $sub, $sref, @argvs) = @_; | |
0b09a93a PF |
800 | |
801 | if (@argvs == 1) { # No optional arguments | |
802 | ||
803 | my @argv = @{$argvs[0]}; | |
804 | shift @argv; | |
805 | ||
9b657a62 | 806 | return $class->_one_invocation($core,$call,$name,$void,$sub,! $lexical, $sref, @argv); |
0b09a93a PF |
807 | |
808 | } else { | |
809 | my $else = "\t"; | |
810 | my (@out, @argv, $n); | |
811 | while (@argvs) { | |
812 | @argv = @{shift @argvs}; | |
813 | $n = shift @argv; | |
814 | ||
a009834b CBW |
815 | my $condition = "\@_ == $n"; |
816 | ||
391c7215 | 817 | if (@argv and $argv[-1] =~ /[#@]_/) { |
a009834b CBW |
818 | # This argv ends with '@' in the prototype, so it matches |
819 | # any number of args >= the number of expressions in the | |
820 | # argv. | |
821 | $condition = "\@_ >= $n"; | |
822 | } | |
823 | ||
824 | push @out, "${else}if ($condition) {\n"; | |
825 | ||
0b09a93a PF |
826 | $else = "\t} els"; |
827 | ||
9b657a62 | 828 | push @out, $class->_one_invocation($core,$call,$name,$void,$sub,! $lexical, $sref, @argv); |
0b09a93a | 829 | } |
9b657a62 | 830 | push @out, qq[ |
0b09a93a | 831 | } |
9b657a62 | 832 | die "Internal error: $name(\@_): Do not expect to get ", scalar(\@_), " arguments"; |
0b09a93a PF |
833 | ]; |
834 | ||
835 | return join '', @out; | |
836 | } | |
e92e55da MB |
837 | } |
838 | ||
9b657a62 PF |
839 | |
840 | # This is a slim interface to ensure backward compatibility with | |
841 | # anyone doing very foolish things with old versions of Fatal. | |
842 | ||
e92e55da | 843 | sub one_invocation { |
9b657a62 PF |
844 | my ($core, $call, $name, $void, @argv) = @_; |
845 | ||
846 | return Fatal->_one_invocation( | |
847 | $core, $call, $name, $void, | |
848 | undef, # Sub. Unused in back-compat mode. | |
849 | 1, # Back-compat flag | |
850 | undef, # Subref, unused in back-compat mode. | |
851 | @argv | |
852 | ); | |
853 | ||
854 | } | |
855 | ||
856 | # This is the internal interface that generates code. | |
857 | # NOTE: This interface WILL change in the future. Please do not | |
858 | # call this subroutine directly. | |
859 | ||
860 | # TODO: Whatever's calling this code has already looked up hints. Pass | |
861 | # them in, rather than look them up a second time. | |
862 | ||
863 | sub _one_invocation { | |
864 | my ($class, $core, $call, $name, $void, $sub, $back_compat, $sref, @argv) = @_; | |
865 | ||
0b09a93a PF |
866 | |
867 | # If someone is calling us directly (a child class perhaps?) then | |
868 | # they could try to mix void without enabling backwards | |
869 | # compatibility. We just don't support this at all, so we gripe | |
870 | # about it rather than doing something unwise. | |
871 | ||
872 | if ($void and not $back_compat) { | |
873 | Carp::confess("Internal error: :void mode not supported with $class"); | |
874 | } | |
875 | ||
876 | # @argv only contains the results of the in-built prototype | |
877 | # function, and is therefore safe to interpolate in the | |
878 | # code generators below. | |
879 | ||
880 | # TODO - The following clobbers context, but that's what the | |
881 | # old Fatal did. Do we care? | |
882 | ||
883 | if ($back_compat) { | |
884 | ||
9b657a62 PF |
885 | # Use Fatal qw(system) will never be supported. It generated |
886 | # a compile-time error with legacy Fatal, and there's no reason | |
887 | # to support it when autodie does a better job. | |
0b09a93a PF |
888 | |
889 | if ($call eq 'CORE::system') { | |
890 | return q{ | |
9b657a62 | 891 | croak("UNIMPLEMENTED: use Fatal qw(system) not supported."); |
0b09a93a PF |
892 | }; |
893 | } | |
894 | ||
895 | local $" = ', '; | |
896 | ||
897 | if ($void) { | |
898 | return qq/return (defined wantarray)?$call(@argv): | |
a009834b CBW |
899 | $call(@argv) || Carp::croak("Can't $name(\@_)/ . |
900 | ($core ? ': $!' : ', \$! is \"$!\"') . '")' | |
0b09a93a | 901 | } else { |
a009834b CBW |
902 | return qq{return $call(@argv) || Carp::croak("Can't $name(\@_)} . |
903 | ($core ? ': $!' : ', \$! is \"$!\"') . '")'; | |
0b09a93a PF |
904 | } |
905 | } | |
906 | ||
907 | # The name of our original function is: | |
908 | # $call if the function is CORE | |
909 | # $sub if our function is non-CORE | |
910 | ||
273225d4 | 911 | # The reason for this is that $call is what we're actually |
0b09a93a PF |
912 | # calling. For our core functions, this is always |
913 | # CORE::something. However for user-defined subs, we're about to | |
914 | # replace whatever it is that we're calling; as such, we actually | |
915 | # calling a subroutine ref. | |
916 | ||
9b657a62 PF |
917 | my $human_sub_name = $core ? $call : $sub; |
918 | ||
919 | # Should we be testing to see if our result is defined, or | |
920 | # just true? | |
921 | ||
922 | my $use_defined_or; | |
923 | ||
924 | my $hints; # All user-sub hints, including list hints. | |
925 | ||
926 | if ( $core ) { | |
927 | ||
928 | # Core hints are built into autodie. | |
929 | ||
930 | $use_defined_or = exists ( $Use_defined_or{$call} ); | |
931 | ||
932 | } | |
933 | else { | |
934 | ||
935 | # User sub hints are looked up using autodie::hints, | |
936 | # since users may wish to add their own hints. | |
937 | ||
938 | require autodie::hints; | |
939 | ||
940 | $hints = autodie::hints->get_hints_for( $sref ); | |
eb8d423f PF |
941 | |
942 | # We'll look up the sub's fullname. This means we | |
943 | # get better reports of where it came from in our | |
944 | # error messages, rather than what imported it. | |
945 | ||
946 | $human_sub_name = autodie::hints->sub_fullname( $sref ); | |
947 | ||
9b657a62 | 948 | } |
0b09a93a | 949 | |
9b657a62 | 950 | # Checks for special core subs. |
0b09a93a PF |
951 | |
952 | if ($call eq 'CORE::system') { | |
953 | ||
954 | # Leverage IPC::System::Simple if we're making an autodying | |
955 | # system. | |
956 | ||
957 | local $" = ", "; | |
958 | ||
959 | # We need to stash $@ into $E, rather than using | |
960 | # local $@ for the whole sub. If we don't then | |
961 | # any exceptions from internal errors in autodie/Fatal | |
273225d4 | 962 | # will mysteriously disappear before propagating |
0b09a93a PF |
963 | # upwards. |
964 | ||
965 | return qq{ | |
966 | my \$retval; | |
967 | my \$E; | |
968 | ||
969 | ||
970 | { | |
971 | local \$@; | |
972 | ||
973 | eval { | |
974 | \$retval = IPC::System::Simple::system(@argv); | |
975 | }; | |
976 | ||
977 | \$E = \$@; | |
978 | } | |
979 | ||
980 | if (\$E) { | |
981 | ||
9b657a62 | 982 | # TODO - This can't be overridden in child |
0b09a93a PF |
983 | # classes! |
984 | ||
985 | die autodie::exception::system->new( | |
986 | function => q{CORE::system}, args => [ @argv ], | |
987 | message => "\$E", errno => \$!, | |
988 | ); | |
989 | } | |
990 | ||
991 | return \$retval; | |
992 | }; | |
993 | ||
994 | } | |
995 | ||
0b09a93a PF |
996 | local $" = ', '; |
997 | ||
998 | # If we're going to throw an exception, here's the code to use. | |
999 | my $die = qq{ | |
1000 | die $class->throw( | |
9b657a62 | 1001 | function => q{$human_sub_name}, args => [ @argv ], |
0b09a93a | 1002 | pragma => q{$class}, errno => \$!, |
eb8d423f | 1003 | context => \$context, return => \$retval, |
7840a289 | 1004 | eval_error => \$@ |
0b09a93a PF |
1005 | ) |
1006 | }; | |
1007 | ||
1008 | if ($call eq 'CORE::flock') { | |
1009 | ||
1010 | # flock needs special treatment. When it fails with | |
1011 | # LOCK_UN and EWOULDBLOCK, then it's not really fatal, it just | |
1012 | # means we couldn't get the lock right now. | |
1013 | ||
1014 | require POSIX; # For POSIX::EWOULDBLOCK | |
1015 | ||
1016 | local $@; # Don't blat anyone else's $@. | |
1017 | ||
1018 | # Ensure that our vendor supports EWOULDBLOCK. If they | |
1019 | # don't (eg, Windows), then we use known values for its | |
1020 | # equivalent on other systems. | |
1021 | ||
1022 | my $EWOULDBLOCK = eval { POSIX::EWOULDBLOCK(); } | |
1023 | || $_EWOULDBLOCK{$^O} | |
1024 | || _autocroak("Internal error - can't overload flock - EWOULDBLOCK not defined on this system."); | |
a009834b CBW |
1025 | my $EAGAIN = $EWOULDBLOCK; |
1026 | if ($try_EAGAIN) { | |
1027 | $EAGAIN = eval { POSIX::EAGAIN(); } | |
1028 | || _autocroak("Internal error - can't overload flock - EAGAIN not defined on this system."); | |
1029 | } | |
0b09a93a PF |
1030 | |
1031 | require Fcntl; # For Fcntl::LOCK_NB | |
1032 | ||
1033 | return qq{ | |
1034 | ||
eb8d423f PF |
1035 | my \$context = wantarray() ? "list" : "scalar"; |
1036 | ||
0b09a93a PF |
1037 | # Try to flock. If successful, return it immediately. |
1038 | ||
1039 | my \$retval = $call(@argv); | |
1040 | return \$retval if \$retval; | |
1041 | ||
1042 | # If we failed, but we're using LOCK_NB and | |
1043 | # returned EWOULDBLOCK, it's not a real error. | |
1044 | ||
a009834b CBW |
1045 | if (\$_[1] & Fcntl::LOCK_NB() and |
1046 | (\$! == $EWOULDBLOCK or | |
1047 | ($try_EAGAIN and \$! == $EAGAIN ))) { | |
0b09a93a PF |
1048 | return \$retval; |
1049 | } | |
1050 | ||
1051 | # Otherwise, we failed. Die noisily. | |
1052 | ||
1053 | $die; | |
1054 | ||
1055 | }; | |
1056 | } | |
1057 | ||
273225d4 CBW |
1058 | if (exists $Returns_num_things_changed{$call}) { |
1059 | ||
1060 | # Some things return the number of things changed (like | |
1061 | # chown, kill, chmod, etc). We only consider these successful | |
1062 | # if *all* the things are changed. | |
1063 | ||
1064 | return qq[ | |
1065 | my \$num_things = \@_ - $Returns_num_things_changed{$call}; | |
1066 | my \$retval = $call(@argv); | |
1067 | ||
1068 | if (\$retval != \$num_things) { | |
1069 | ||
1070 | # We need \$context to throw an exception. | |
1071 | # It's *always* set to scalar, because that's how | |
1072 | # autodie calls chown() above. | |
1073 | ||
1074 | my \$context = "scalar"; | |
1075 | $die; | |
1076 | } | |
1077 | ||
1078 | return \$retval; | |
1079 | ]; | |
1080 | } | |
1081 | ||
0b09a93a PF |
1082 | # AFAIK everything that can be given an unopned filehandle |
1083 | # will fail if it tries to use it, so we don't really need | |
1084 | # the 'unopened' warning class here. Especially since they | |
1085 | # then report the wrong line number. | |
1086 | ||
eb8d423f PF |
1087 | # Other warnings are disabled because they produce excessive |
1088 | # complaints from smart-match hints under 5.10.1. | |
1089 | ||
9b657a62 | 1090 | my $code = qq[ |
eb8d423f | 1091 | no warnings qw(unopened uninitialized numeric); |
3f5e3f2f | 1092 | no if \$\] >= 5.017011, warnings => "experimental::smartmatch"; |
0b09a93a PF |
1093 | |
1094 | if (wantarray) { | |
1095 | my \@results = $call(@argv); | |
eb8d423f PF |
1096 | my \$retval = \\\@results; |
1097 | my \$context = "list"; | |
9b657a62 PF |
1098 | |
1099 | ]; | |
1100 | ||
20da2e5b CBW |
1101 | my $retval_action = $Retval_action{$call} || ''; |
1102 | ||
9b657a62 PF |
1103 | if ( $hints and ( ref($hints->{list} ) || "" ) eq 'CODE' ) { |
1104 | ||
1105 | # NB: Subroutine hints are passed as a full list. | |
1106 | # This differs from the 5.10.0 smart-match behaviour, | |
1107 | # but means that context unaware subroutines can use | |
1108 | # the same hints in both list and scalar context. | |
1109 | ||
1110 | $code .= qq{ | |
1111 | if ( \$hints->{list}->(\@results) ) { $die }; | |
1112 | }; | |
1113 | } | |
1114 | elsif ( PERL510 and $hints ) { | |
1115 | $code .= qq{ | |
1116 | if ( \@results ~~ \$hints->{list} ) { $die }; | |
1117 | }; | |
1118 | } | |
1119 | elsif ( $hints ) { | |
1120 | croak sprintf(ERROR_58_HINTS, 'list', $sub); | |
1121 | } | |
1122 | else { | |
1123 | $code .= qq{ | |
1124 | # An empty list, or a single undef is failure | |
0b09a93a PF |
1125 | if (! \@results or (\@results == 1 and ! defined \$results[0])) { |
1126 | $die; | |
9b657a62 PF |
1127 | } |
1128 | } | |
1129 | } | |
1130 | ||
1131 | # Tidy up the end of our wantarray call. | |
1132 | ||
1133 | $code .= qq[ | |
0b09a93a PF |
1134 | return \@results; |
1135 | } | |
9b657a62 | 1136 | ]; |
0b09a93a | 1137 | |
0b09a93a | 1138 | |
9b657a62 PF |
1139 | # Otherwise, we're in scalar context. |
1140 | # We're never in a void context, since we have to look | |
1141 | # at the result. | |
1142 | ||
1143 | $code .= qq{ | |
eb8d423f PF |
1144 | my \$retval = $call(@argv); |
1145 | my \$context = "scalar"; | |
9b657a62 PF |
1146 | }; |
1147 | ||
1148 | if ( $hints and ( ref($hints->{scalar} ) || "" ) eq 'CODE' ) { | |
1149 | ||
1150 | # We always call code refs directly, since that always | |
1151 | # works in 5.8.x, and always works in 5.10.1 | |
1152 | ||
1153 | return $code .= qq{ | |
eb8d423f | 1154 | if ( \$hints->{scalar}->(\$retval) ) { $die }; |
20da2e5b | 1155 | $retval_action |
eb8d423f | 1156 | return \$retval; |
9b657a62 | 1157 | }; |
0b09a93a | 1158 | |
9b657a62 PF |
1159 | } |
1160 | elsif (PERL510 and $hints) { | |
1161 | return $code . qq{ | |
1162 | ||
eb8d423f | 1163 | if ( \$retval ~~ \$hints->{scalar} ) { $die }; |
20da2e5b | 1164 | $retval_action |
eb8d423f | 1165 | return \$retval; |
9b657a62 PF |
1166 | }; |
1167 | } | |
1168 | elsif ( $hints ) { | |
1169 | croak sprintf(ERROR_58_HINTS, 'scalar', $sub); | |
1170 | } | |
1171 | ||
1172 | return $code . | |
1173 | ( $use_defined_or ? qq{ | |
0b09a93a | 1174 | |
eb8d423f | 1175 | $die if not defined \$retval; |
20da2e5b | 1176 | $retval_action |
eb8d423f | 1177 | return \$retval; |
0b09a93a PF |
1178 | |
1179 | } : qq{ | |
1180 | ||
20da2e5b | 1181 | $retval_action |
eb8d423f | 1182 | return \$retval || $die; |
0b09a93a PF |
1183 | |
1184 | } ) ; | |
1185 | ||
e92e55da MB |
1186 | } |
1187 | ||
0b09a93a PF |
1188 | # This returns the old copy of the sub, so we can |
1189 | # put it back at end of scope. | |
1190 | ||
1191 | # TODO : Check to make sure prototypes are restored correctly. | |
1192 | ||
1193 | # TODO: Taking a huge list of arguments is awful. Rewriting to | |
1194 | # take a hash would be lovely. | |
1195 | ||
9b657a62 PF |
1196 | # TODO - BACKCOMPAT - This is not yet compatible with 5.10.0 |
1197 | ||
e92e55da | 1198 | sub _make_fatal { |
082a4c42 SH |
1199 | my($class, $sub, $pkg, $void, $lexical, $filename, $insist, $install_subs) = @_; |
1200 | my($code, $sref, $real_proto, $proto, $core, $call, $hints, $cache, $cache_type); | |
e92e55da | 1201 | my $ini = $sub; |
082a4c42 SH |
1202 | my $name = $sub; |
1203 | ||
1204 | ||
1205 | if (index($sub, '::') == -1) { | |
1206 | $sub = "${pkg}::$sub"; | |
1207 | if (substr($name, 0, 1) eq '&') { | |
1208 | $name = substr($name, 1); | |
1209 | } | |
1210 | } else { | |
1211 | $name =~ s/.*:://; | |
1212 | } | |
e92e55da | 1213 | |
0b09a93a PF |
1214 | |
1215 | # Figure if we're using lexical or package semantics and | |
1216 | # twiddle the appropriate bits. | |
1217 | ||
1218 | if (not $lexical) { | |
1219 | $Package_Fatal{$sub} = 1; | |
1220 | } | |
1221 | ||
1222 | # TODO - We *should* be able to do skipping, since we know when | |
1223 | # we've lexicalised / unlexicalised a subroutine. | |
1224 | ||
0b09a93a PF |
1225 | |
1226 | warn "# _make_fatal: sub=$sub pkg=$pkg name=$name void=$void\n" if $Debug; | |
1227 | croak(sprintf(ERROR_BADNAME, $class, $name)) unless $name =~ /^\w+$/; | |
1228 | ||
1229 | if (defined(&$sub)) { # user subroutine | |
1230 | ||
9b657a62 PF |
1231 | # NOTE: Previously we would localise $@ at this point, so |
1232 | # the following calls to eval {} wouldn't interfere with anything | |
1233 | # that's already in $@. Unfortunately, it would also stop | |
1234 | # any of our croaks from triggering(!), which is even worse. | |
1235 | ||
0b09a93a PF |
1236 | # This could be something that we've fatalised that |
1237 | # was in core. | |
1238 | ||
082a4c42 | 1239 | if ( $Package_Fatal{$sub} and exists($CORE_prototype_cache{"CORE::$name"})) { |
0b09a93a PF |
1240 | |
1241 | # Something we previously made Fatal that was core. | |
1242 | # This is safe to replace with an autodying to core | |
1243 | # version. | |
1244 | ||
1245 | $core = 1; | |
1246 | $call = "CORE::$name"; | |
082a4c42 | 1247 | $proto = $CORE_prototype_cache{$call}; |
0b09a93a PF |
1248 | |
1249 | # We return our $sref from this subroutine later | |
1250 | # on, indicating this subroutine should be placed | |
1251 | # back when we're finished. | |
1252 | ||
1253 | $sref = \&$sub; | |
1254 | ||
1255 | } else { | |
1256 | ||
9b657a62 PF |
1257 | # If this is something we've already fatalised or played with, |
1258 | # then look-up the name of the original sub for the rest of | |
1259 | # our processing. | |
1260 | ||
082a4c42 SH |
1261 | if (exists($Is_fatalised_sub{\&$sub})) { |
1262 | # $sub is one of our wrappers around a CORE sub or a | |
1263 | # user sub. Instead of wrapping our wrapper, lets just | |
1264 | # generate a new wrapper for the original sub. | |
1265 | # - NB: the current wrapper might be for a different class | |
1266 | # than the one we are generating now (e.g. some limited | |
1267 | # mixing between use Fatal + use autodie can occur). | |
1268 | # - Even for nested autodie, we need this as the leak guards | |
1269 | # differ. | |
1270 | my $s = $Is_fatalised_sub{\&$sub}; | |
1271 | if (defined($s)) { | |
1272 | # It is a wrapper for a user sub | |
1273 | $sub = $s; | |
1274 | } else { | |
1275 | # It is a wrapper for a CORE:: sub | |
1276 | $core = 1; | |
1277 | $call = "CORE::$name"; | |
1278 | $proto = $CORE_prototype_cache{$call}; | |
1279 | } | |
1280 | } | |
9b657a62 | 1281 | |
0b09a93a PF |
1282 | # A regular user sub, or a user sub wrapping a |
1283 | # core sub. | |
1284 | ||
1285 | $sref = \&$sub; | |
082a4c42 SH |
1286 | if (!$core) { |
1287 | # A non-CORE sub might have hints and such... | |
1288 | $proto = prototype($sref); | |
1289 | $call = '&$sref'; | |
1290 | require autodie::hints; | |
9b657a62 | 1291 | |
082a4c42 | 1292 | $hints = autodie::hints->get_hints_for( $sref ); |
9b657a62 | 1293 | |
082a4c42 SH |
1294 | # If we've insisted on hints, but don't have them, then |
1295 | # bail out! | |
9b657a62 | 1296 | |
082a4c42 SH |
1297 | if ($insist and not $hints) { |
1298 | croak(sprintf(ERROR_NOHINTS, $name)); | |
1299 | } | |
9b657a62 | 1300 | |
082a4c42 SH |
1301 | # Otherwise, use the default hints if we don't have |
1302 | # any. | |
9b657a62 | 1303 | |
082a4c42 SH |
1304 | $hints ||= autodie::hints::DEFAULT_HINTS(); |
1305 | } | |
0b09a93a PF |
1306 | |
1307 | } | |
1308 | ||
910ad8dd | 1309 | } elsif ($sub eq $ini && $sub !~ /^CORE::GLOBAL::/) { |
0b09a93a PF |
1310 | # Stray user subroutine |
1311 | croak(sprintf(ERROR_NOTSUB,$sub)); | |
1312 | ||
1313 | } elsif ($name eq 'system') { | |
1314 | ||
1315 | # If we're fatalising system, then we need to load | |
1316 | # helper code. | |
1317 | ||
9b657a62 PF |
1318 | # The business with $E is to avoid clobbering our caller's |
1319 | # $@, and to avoid $@ being localised when we croak. | |
0b09a93a | 1320 | |
9b657a62 | 1321 | my $E; |
0b09a93a | 1322 | |
9b657a62 PF |
1323 | { |
1324 | local $@; | |
1325 | ||
1326 | eval { | |
1327 | require IPC::System::Simple; # Only load it if we need it. | |
1328 | require autodie::exception::system; | |
1329 | }; | |
1330 | $E = $@; | |
1331 | } | |
1332 | ||
1333 | if ($E) { croak ERROR_NO_IPC_SYS_SIMPLE; } | |
1334 | ||
1335 | # Make sure we're using a recent version of ISS that actually | |
1336 | # support fatalised system. | |
1337 | if ($IPC::System::Simple::VERSION < MIN_IPC_SYS_SIMPLE_VER) { | |
1338 | croak sprintf( | |
1339 | ERROR_IPC_SYS_SIMPLE_OLD, MIN_IPC_SYS_SIMPLE_VER, | |
1340 | $IPC::System::Simple::VERSION | |
1341 | ); | |
1342 | } | |
0b09a93a PF |
1343 | |
1344 | $call = 'CORE::system'; | |
db4e6d09 | 1345 | $core = 1; |
0b09a93a PF |
1346 | |
1347 | } elsif ($name eq 'exec') { | |
1348 | # Exec doesn't have a prototype. We don't care. This | |
1349 | # breaks the exotic form with lexical scope, and gives | |
273225d4 | 1350 | # the regular form a "do or die" behavior as expected. |
0b09a93a PF |
1351 | |
1352 | $call = 'CORE::exec'; | |
0b09a93a PF |
1353 | $core = 1; |
1354 | ||
1355 | } else { # CORE subroutine | |
082a4c42 SH |
1356 | $call = "CORE::$name"; |
1357 | if (exists($CORE_prototype_cache{$call})) { | |
1358 | $proto = $CORE_prototype_cache{$call}; | |
1359 | } else { | |
1360 | my $E; | |
1361 | { | |
1362 | local $@; | |
1363 | $proto = eval { prototype $call }; | |
1364 | $E = $@; | |
1365 | } | |
1366 | croak(sprintf(ERROR_NOT_BUILT,$name)) if $E; | |
1367 | croak(sprintf(ERROR_CANT_OVERRIDE,$name)) if not defined $proto; | |
1368 | $CORE_prototype_cache{$call} = $proto; | |
9b657a62 | 1369 | } |
0b09a93a | 1370 | $core = 1; |
e92e55da | 1371 | } |
0b09a93a | 1372 | |
0b09a93a PF |
1373 | # TODO: This caching works, but I don't like using $void and |
1374 | # $lexical as keys. In particular, I suspect our code may end up | |
1375 | # wrapping already wrapped code when autodie and Fatal are used | |
1376 | # together. | |
1377 | ||
1378 | # NB: We must use '$sub' (the name plus package) and not | |
1379 | # just '$name' (the short name) here. Failing to do so | |
1380 | # results code that's in the wrong package, and hence has | |
1381 | # access to the wrong package filehandles. | |
1382 | ||
082a4c42 SH |
1383 | $cache = $Cached_fatalised_sub{$class}{$sub}; |
1384 | if ($lexical) { | |
1385 | $cache_type = CACHE_AUTODIE_LEAK_GUARD; | |
1386 | } else { | |
1387 | $cache_type = CACHE_FATAL_WRAPPER; | |
1388 | $cache_type = CACHE_FATAL_VOID if $void; | |
1389 | } | |
1390 | ||
1391 | if (my $subref = $cache->{$cache_type}) { | |
1392 | $install_subs->{$name} = $subref; | |
0b09a93a | 1393 | return $sref; |
e92e55da | 1394 | } |
0b09a93a | 1395 | |
273225d4 CBW |
1396 | # If our subroutine is reusable (ie, not package depdendent), |
1397 | # then check to see if we've got a cached copy, and use that. | |
1398 | # See RT #46984. (Thanks to Niels Thykier for being awesome!) | |
1399 | ||
1400 | if ($core && exists $reusable_builtins{$call}) { | |
1401 | # For non-lexical subs, we can just use this cache directly | |
1402 | # - for lexical variants, we need a leak guard as well. | |
1403 | $code = $reusable_builtins{$call}{$lexical}; | |
1404 | if (!$lexical && defined($code)) { | |
082a4c42 | 1405 | $install_subs->{$name} = $code; |
273225d4 CBW |
1406 | return $sref; |
1407 | } | |
1408 | } | |
0b09a93a | 1409 | |
082a4c42 | 1410 | if (!($lexical && $core) && !defined($code)) { |
273225d4 | 1411 | # No code available, generate it now. |
082a4c42 SH |
1412 | my $wrapper_pkg = $pkg; |
1413 | $wrapper_pkg = undef if (exists($reusable_builtins{$call})); | |
1414 | $code = $class->_compile_wrapper($wrapper_pkg, $core, $call, $name, | |
1415 | $void, $lexical, $sub, $sref, | |
1416 | $hints, $proto); | |
1417 | if (!defined($wrapper_pkg)) { | |
1418 | # cache it so we don't recompile this part again | |
1419 | $reusable_builtins{$call}{$lexical} = $code; | |
0b09a93a PF |
1420 | } |
1421 | } | |
1422 | ||
1423 | # Now we need to wrap our fatalised sub inside an itty bitty | |
1424 | # closure, which can detect if we've leaked into another file. | |
1425 | # Luckily, we only need to do this for lexical (autodie) | |
1426 | # subs. Fatal subs can leak all they want, it's considered | |
1427 | # a "feature" (or at least backwards compatible). | |
1428 | ||
1429 | # TODO: Cache our leak guards! | |
1430 | ||
1431 | # TODO: This is pretty hairy code. A lot more tests would | |
1432 | # be really nice for this. | |
1433 | ||
082a4c42 | 1434 | my $installed_sub = $code; |
0b09a93a PF |
1435 | |
1436 | if ($lexical) { | |
082a4c42 SH |
1437 | my $real_proto = ''; |
1438 | if (defined $proto) { | |
1439 | $real_proto = " ($proto)"; | |
1440 | } else { | |
1441 | $proto = '@'; | |
1442 | } | |
1443 | $installed_sub = $class->_make_leak_guard($filename, $code, $sref, $call, | |
1444 | $pkg, $proto, $real_proto); | |
0b09a93a PF |
1445 | } |
1446 | ||
082a4c42 | 1447 | $cache->{$cache_type} = $code; |
9b657a62 | 1448 | |
082a4c42 | 1449 | $install_subs->{$name} = $installed_sub; |
9b657a62 | 1450 | |
273225d4 | 1451 | # Cache that we've now overridden this sub. If we get called |
9b657a62 | 1452 | # again, we may need to find that find subroutine again (eg, for hints). |
0b09a93a | 1453 | |
9b657a62 | 1454 | $Is_fatalised_sub{$installed_sub} = $sref; |
0b09a93a PF |
1455 | |
1456 | return $sref; | |
1457 | ||
1458 | } | |
1459 | ||
1460 | # This subroutine exists primarily so that child classes can override | |
1461 | # it to point to their own exception class. Doing this is significantly | |
1462 | # less complex than overriding throw() | |
1463 | ||
1464 | sub exception_class { return "autodie::exception" }; | |
1465 | ||
1466 | { | |
1467 | my %exception_class_for; | |
1468 | my %class_loaded; | |
1469 | ||
1470 | sub throw { | |
1471 | my ($class, @args) = @_; | |
1472 | ||
1473 | # Find our exception class if we need it. | |
1474 | my $exception_class = | |
1475 | $exception_class_for{$class} ||= $class->exception_class; | |
1476 | ||
1477 | if (not $class_loaded{$exception_class}) { | |
1478 | if ($exception_class =~ /[^\w:']/) { | |
1479 | confess "Bad exception class '$exception_class'.\nThe '$class->exception_class' method wants to use $exception_class\nfor exceptions, but it contains characters which are not word-characters or colons."; | |
1480 | } | |
1481 | ||
1482 | # Alas, Perl does turn barewords into modules unless they're | |
1483 | # actually barewords. As such, we're left doing a string eval | |
1484 | # to make sure we load our file correctly. | |
1485 | ||
1486 | my $E; | |
1487 | ||
1488 | { | |
1489 | local $@; # We can't clobber $@, it's wrong! | |
32374c8c CBW |
1490 | my $pm_file = $exception_class . ".pm"; |
1491 | $pm_file =~ s{ (?: :: | ' ) }{/}gx; | |
1492 | eval { require $pm_file }; | |
0b09a93a PF |
1493 | $E = $@; # Save $E despite ending our local. |
1494 | } | |
1495 | ||
1496 | # We need quotes around $@ to make sure it's stringified | |
1497 | # while still in scope. Without them, we run the risk of | |
1498 | # $@ having been cleared by us exiting the local() block. | |
1499 | ||
1500 | confess "Failed to load '$exception_class'.\nThis may be a typo in the '$class->exception_class' method,\nor the '$exception_class' module may not exist.\n\n $E" if $E; | |
1501 | ||
1502 | $class_loaded{$exception_class}++; | |
1503 | ||
1504 | } | |
1505 | ||
1506 | return $exception_class->new(@args); | |
2ba6ecf4 | 1507 | } |
e92e55da MB |
1508 | } |
1509 | ||
391c7215 CBW |
1510 | # Creates and returns a leak guard (with prototype if needed). |
1511 | sub _make_leak_guard { | |
082a4c42 | 1512 | my ($class, $filename, $wrapped_sub, $orig_sub, $call, $pkg, $proto, $real_proto) = @_; |
273225d4 | 1513 | |
391c7215 CBW |
1514 | # The leak guard is rather lengthly (in fact it makes up the most |
1515 | # of _make_leak_guard). It is possible to split it into a large | |
1516 | # "generic" part and a small wrapper with call-specific | |
1517 | # information. This was done in v2.19 and profiling suggested | |
1518 | # that we ended up using a substantial amount of runtime in "goto" | |
1519 | # between the leak guard(s) and the final sub. Therefore, the two | |
1520 | # parts were merged into one to reduce the runtime overhead. | |
273225d4 | 1521 | |
391c7215 CBW |
1522 | my $leak_guard = sub { |
1523 | my $caller_level = 0; | |
1524 | my $caller; | |
273225d4 | 1525 | |
391c7215 | 1526 | while ( ($caller = (caller $caller_level)[1]) =~ m{^\(eval \d+\)$} ) { |
273225d4 | 1527 | |
391c7215 CBW |
1528 | # If our filename is actually an eval, and we |
1529 | # reach it, then go to our autodying code immediatately. | |
273225d4 | 1530 | |
391c7215 CBW |
1531 | last if ($caller eq $filename); |
1532 | $caller_level++; | |
1533 | } | |
273225d4 | 1534 | |
391c7215 CBW |
1535 | # We're now out of the eval stack. |
1536 | ||
1537 | if ($caller eq $filename) { | |
1538 | # No leak, call the wrapper. NB: In this case, it doesn't | |
1539 | # matter if it is a CORE sub or not. | |
082a4c42 SH |
1540 | if (!defined($wrapped_sub)) { |
1541 | # CORE sub that we were too lazy to compile when we | |
1542 | # created this leak guard. | |
1543 | die "$call is not CORE::<something>" | |
1544 | if substr($call, 0, 6) ne 'CORE::'; | |
1545 | ||
1546 | my $name = substr($call, 6); | |
1547 | my $sub = $name; | |
1548 | my $lexical = 1; | |
1549 | my $wrapper_pkg = $pkg; | |
1550 | my $code; | |
1551 | if (exists($reusable_builtins{$call})) { | |
1552 | $code = $reusable_builtins{$call}{$lexical}; | |
1553 | $wrapper_pkg = undef; | |
1554 | } | |
1555 | if (!defined($code)) { | |
1556 | $code = $class->_compile_wrapper($wrapper_pkg, | |
1557 | 1, # core | |
1558 | $call, | |
1559 | $name, | |
1560 | 0, # void | |
1561 | $lexical, | |
1562 | $sub, | |
1563 | undef, # subref (not used for core) | |
1564 | undef, # hints (not used for core) | |
1565 | $proto); | |
1566 | ||
1567 | if (!defined($wrapper_pkg)) { | |
1568 | # cache it so we don't recompile this part again | |
1569 | $reusable_builtins{$call}{$lexical} = $code; | |
1570 | } | |
1571 | } | |
1572 | # As $wrapped_sub is "closed over", updating its value will | |
1573 | # be "remembered" for the next call. | |
1574 | $wrapped_sub = $code; | |
1575 | } | |
391c7215 CBW |
1576 | goto $wrapped_sub; |
1577 | } | |
273225d4 | 1578 | |
391c7215 CBW |
1579 | # We leaked, time to call the original function. |
1580 | # - for non-core functions that will be $orig_sub | |
082a4c42 | 1581 | # - for CORE functions, $orig_sub may be a trampoline |
391c7215 CBW |
1582 | goto $orig_sub if defined($orig_sub); |
1583 | ||
082a4c42 SH |
1584 | # We are wrapping a CORE sub and we do not have a trampoline |
1585 | # yet. | |
1586 | # | |
1587 | # If we've cached a trampoline, then use it. Usually only | |
1588 | # resuable subs will have cache hits, but non-reusuably ones | |
1589 | # can get it as well in (very) rare cases. It is mostly in | |
1590 | # cases where a package uses autodie multiple times and leaks | |
1591 | # from multiple places. Possibly something like: | |
1592 | # | |
1593 | # package Pkg::With::LeakyCode; | |
1594 | # sub a { | |
1595 | # use autodie; | |
1596 | # code_that_leaks(); | |
1597 | # } | |
1598 | # | |
1599 | # sub b { | |
1600 | # use autodie; | |
1601 | # more_leaky_code(); | |
1602 | # } | |
1603 | # | |
1604 | # Note that we use "Fatal" as package name for reusable subs | |
1605 | # because A) that allows us to trivially re-use the | |
1606 | # trampolines as well and B) because the reusable sub is | |
1607 | # compiled into "package Fatal" as well. | |
273225d4 | 1608 | |
082a4c42 SH |
1609 | $pkg = 'Fatal' if exists $reusable_builtins{$call}; |
1610 | $orig_sub = $Trampoline_cache{$pkg}{$call}; | |
273225d4 | 1611 | |
082a4c42 | 1612 | if (not $orig_sub) { |
273225d4 | 1613 | # If we don't have a trampoline, we need to build it. |
273225d4 | 1614 | # |
391c7215 CBW |
1615 | # We only generate trampolines when we need them, and |
1616 | # we can cache them by subroutine + package. | |
082a4c42 SH |
1617 | # |
1618 | # As $orig_sub is "closed over", updating its value will | |
1619 | # be "remembered" for the next call. | |
273225d4 | 1620 | |
082a4c42 | 1621 | $orig_sub = _make_core_trampoline($call, $pkg, $proto); |
273225d4 | 1622 | |
082a4c42 SH |
1623 | # We still cache it despite remembering it in $orig_sub as |
1624 | # well. In particularly, we rely on this to avoid | |
1625 | # re-compiling the reusable trampolines. | |
1626 | $Trampoline_cache{$pkg}{$call} = $orig_sub; | |
273225d4 CBW |
1627 | } |
1628 | ||
1629 | # Bounce to our trampoline, which takes us to our core sub. | |
082a4c42 | 1630 | goto $orig_sub; |
391c7215 CBW |
1631 | }; # <-- end of leak guard |
1632 | ||
1633 | # If there is a prototype on the original sub, copy it to the leak | |
1634 | # guard. | |
1635 | if ($real_proto ne '') { | |
1636 | # The "\&" may appear to be redundant but set_prototype | |
1637 | # croaks when it is removed. | |
1638 | set_prototype(\&$leak_guard, $proto); | |
1639 | } | |
1640 | ||
1641 | return $leak_guard; | |
1642 | } | |
1643 | ||
1644 | # Create a trampoline for calling a core sub. Essentially, a tiny sub | |
1645 | # that figures out how we should be calling our core sub, puts in the | |
1646 | # arguments in the right way, and bounces our control over to it. | |
1647 | # | |
1648 | # If we could use `goto &` on core builtins, we wouldn't need this. | |
1649 | sub _make_core_trampoline { | |
1650 | my ($call, $pkg, $proto_str) = @_; | |
1651 | my $trampoline_code = 'sub {'; | |
1652 | my $trampoline_sub; | |
1653 | my @protos = fill_protos($proto_str); | |
1654 | ||
1655 | # TODO: It may be possible to combine this with write_invocation(). | |
1656 | ||
1657 | foreach my $proto (@protos) { | |
1658 | local $" = ", "; # So @args is formatted correctly. | |
1659 | my ($count, @args) = @$proto; | |
1660 | if (@args && $args[-1] =~ m/[@#]_/) { | |
1661 | $trampoline_code .= qq/ | |
1662 | if (\@_ >= $count) { | |
1663 | return $call(@args); | |
1664 | } | |
1665 | /; | |
1666 | } else { | |
1667 | $trampoline_code .= qq< | |
1668 | if (\@_ == $count) { | |
1669 | return $call(@args); | |
1670 | } | |
1671 | >; | |
1672 | } | |
1673 | } | |
1674 | ||
1675 | $trampoline_code .= qq< Carp::croak("Internal error in Fatal/autodie. Leak-guard failure"); } >; | |
1676 | my $E; | |
1677 | ||
1678 | { | |
1679 | local $@; | |
1680 | $trampoline_sub = eval "package $pkg;\n $trampoline_code"; ## no critic | |
1681 | $E = $@; | |
273225d4 | 1682 | } |
391c7215 CBW |
1683 | die "Internal error in Fatal/autodie: Leak-guard installation failure: $E" |
1684 | if $E; | |
273225d4 | 1685 | |
391c7215 | 1686 | return $trampoline_sub; |
273225d4 CBW |
1687 | } |
1688 | ||
082a4c42 SH |
1689 | sub _compile_wrapper { |
1690 | my ($class, $wrapper_pkg, $core, $call, $name, $void, $lexical, $sub, $sref, $hints, $proto) = @_; | |
1691 | my $real_proto = ''; | |
1692 | my @protos; | |
1693 | my $code; | |
1694 | if (defined $proto) { | |
1695 | $real_proto = " ($proto)"; | |
1696 | } else { | |
1697 | $proto = '@'; | |
1698 | } | |
1699 | ||
1700 | @protos = fill_protos($proto); | |
1701 | $code = qq[ | |
1702 | sub$real_proto { | |
1703 | ]; | |
1704 | ||
1705 | if (!$lexical) { | |
1706 | $code .= q[ | |
1707 | local($", $!) = (', ', 0); | |
1708 | ]; | |
1709 | } | |
1710 | ||
1711 | # Don't have perl whine if exec fails, since we'll be handling | |
1712 | # the exception now. | |
1713 | $code .= "no warnings qw(exec);\n" if $call eq "CORE::exec"; | |
1714 | ||
1715 | $code .= $class->_write_invocation($core, $call, $name, $void, $lexical, | |
1716 | $sub, $sref, @protos); | |
1717 | $code .= "}\n"; | |
1718 | warn $code if $Debug; | |
1719 | ||
1720 | # I thought that changing package was a monumental waste of | |
1721 | # time for CORE subs, since they'll always be the same. However | |
1722 | # that's not the case, since they may refer to package-based | |
1723 | # filehandles (eg, with open). | |
1724 | # | |
1725 | # The %reusable_builtins hash defines ones we can aggressively | |
1726 | # cache as they never depend upon package-based symbols. | |
1727 | ||
1728 | my $E; | |
1729 | ||
1730 | { | |
1731 | no strict 'refs'; ## no critic # to avoid: Can't use string (...) as a symbol ref ... | |
1732 | local $@; | |
1733 | if (defined($wrapper_pkg)) { | |
1734 | $code = eval("package $wrapper_pkg; require Carp; $code"); ## no critic | |
1735 | } else { | |
1736 | $code = eval("require Carp; $code"); ## no critic | |
1737 | ||
1738 | } | |
1739 | $E = $@; | |
1740 | } | |
1741 | ||
1742 | if (not $code) { | |
1743 | my $true_name = $core ? $call : $sub; | |
1744 | croak("Internal error in autodie/Fatal processing $true_name: $E"); | |
1745 | } | |
1746 | return $code; | |
1747 | } | |
1748 | ||
0b09a93a PF |
1749 | # For some reason, dying while replacing our subs doesn't |
1750 | # kill our calling program. It simply stops the loading of | |
1751 | # autodie and keeps going with everything else. The _autocroak | |
273225d4 | 1752 | # sub allows us to die with a vengeance. It should *only* ever be |
0b09a93a PF |
1753 | # used for serious internal errors, since the results of it can't |
1754 | # be captured. | |
1755 | ||
1756 | sub _autocroak { | |
1757 | warn Carp::longmess(@_); | |
1758 | exit(255); # Ugh! | |
1759 | } | |
1760 | ||
1761 | package autodie::Scope::Guard; | |
1762 | ||
1763 | # This code schedules the cleanup of subroutines at the end of | |
1764 | # scope. It's directly inspired by chocolateboy's excellent | |
1765 | # Scope::Guard module. | |
1766 | ||
1767 | sub new { | |
1768 | my ($class, $handler) = @_; | |
1769 | ||
1770 | return bless $handler, $class; | |
1771 | } | |
1772 | ||
1773 | sub DESTROY { | |
1774 | my ($self) = @_; | |
1775 | ||
1776 | $self->(); | |
1777 | } | |
1778 | ||
e92e55da MB |
1779 | 1; |
1780 | ||
1781 | __END__ | |
1782 | ||
1783 | =head1 NAME | |
1784 | ||
0b09a93a | 1785 | Fatal - Replace functions with equivalents which succeed or die |
e92e55da MB |
1786 | |
1787 | =head1 SYNOPSIS | |
1788 | ||
1789 | use Fatal qw(open close); | |
1790 | ||
0b09a93a PF |
1791 | open(my $fh, "<", $filename); # No need to check errors! |
1792 | ||
1793 | use File::Copy qw(move); | |
1794 | use Fatal qw(move); | |
1795 | ||
1796 | move($file1, $file2); # No need to check errors! | |
1797 | ||
e92e55da | 1798 | sub juggle { . . . } |
0b09a93a PF |
1799 | Fatal->import('juggle'); |
1800 | ||
1801 | =head1 BEST PRACTICE | |
1802 | ||
1803 | B<Fatal has been obsoleted by the new L<autodie> pragma.> Please use | |
1804 | L<autodie> in preference to C<Fatal>. L<autodie> supports lexical scoping, | |
1805 | throws real exception objects, and provides much nicer error messages. | |
1806 | ||
1807 | The use of C<:void> with Fatal is discouraged. | |
e92e55da MB |
1808 | |
1809 | =head1 DESCRIPTION | |
1810 | ||
0b09a93a PF |
1811 | C<Fatal> provides a way to conveniently replace |
1812 | functions which normally return a false value when they fail with | |
1813 | equivalents which raise exceptions if they are not successful. This | |
1814 | lets you use these functions without having to test their return | |
1815 | values explicitly on each call. Exceptions can be caught using | |
1816 | C<eval{}>. See L<perlfunc> and L<perlvar> for details. | |
e92e55da MB |
1817 | |
1818 | The do-or-die equivalents are set up simply by calling Fatal's | |
1819 | C<import> routine, passing it the names of the functions to be | |
1820 | replaced. You may wrap both user-defined functions and overridable | |
0b09a93a PF |
1821 | CORE operators (except C<exec>, C<system>, C<print>, or any other |
1822 | built-in that cannot be expressed via prototypes) in this way. | |
e92e55da | 1823 | |
91c7a880 GS |
1824 | If the symbol C<:void> appears in the import list, then functions |
1825 | named later in that import list raise an exception only when | |
1826 | these are called in void context--that is, when their return | |
1827 | values are ignored. For example | |
1828 | ||
0b09a93a | 1829 | use Fatal qw/:void open close/; |
91c7a880 | 1830 | |
0b09a93a | 1831 | # properly checked, so no exception raised on error |
9b657a62 | 1832 | if (not open(my $fh, '<', '/bogotic') { |
0b09a93a PF |
1833 | warn "Can't open /bogotic: $!"; |
1834 | } | |
91c7a880 | 1835 | |
0b09a93a PF |
1836 | # not checked, so error raises an exception |
1837 | close FH; | |
1838 | ||
1839 | The use of C<:void> is discouraged, as it can result in exceptions | |
1840 | not being thrown if you I<accidentally> call a method without | |
1841 | void context. Use L<autodie> instead if you need to be able to | |
1842 | disable autodying/Fatal behaviour for a small block of code. | |
1843 | ||
1844 | =head1 DIAGNOSTICS | |
1845 | ||
1846 | =over 4 | |
1847 | ||
1848 | =item Bad subroutine name for Fatal: %s | |
1849 | ||
1850 | You've called C<Fatal> with an argument that doesn't look like | |
1851 | a subroutine name, nor a switch that this version of Fatal | |
1852 | understands. | |
1853 | ||
1854 | =item %s is not a Perl subroutine | |
1855 | ||
1856 | You've asked C<Fatal> to try and replace a subroutine which does not | |
1857 | exist, or has not yet been defined. | |
1858 | ||
1859 | =item %s is neither a builtin, nor a Perl subroutine | |
1860 | ||
1861 | You've asked C<Fatal> to replace a subroutine, but it's not a Perl | |
1862 | built-in, and C<Fatal> couldn't find it as a regular subroutine. | |
1863 | It either doesn't exist or has not yet been defined. | |
1864 | ||
1865 | =item Cannot make the non-overridable %s fatal | |
1866 | ||
1867 | You've tried to use C<Fatal> on a Perl built-in that can't be | |
1868 | overridden, such as C<print> or C<system>, which means that | |
1869 | C<Fatal> can't help you, although some other modules might. | |
1870 | See the L</"SEE ALSO"> section of this documentation. | |
1871 | ||
1872 | =item Internal error: %s | |
1873 | ||
1874 | You've found a bug in C<Fatal>. Please report it using | |
1875 | the C<perlbug> command. | |
1876 | ||
1877 | =back | |
91c7a880 | 1878 | |
a6fd7f3f RGS |
1879 | =head1 BUGS |
1880 | ||
0b09a93a PF |
1881 | C<Fatal> clobbers the context in which a function is called and always |
1882 | makes it a scalar context, except when the C<:void> tag is used. | |
1883 | This problem does not exist in L<autodie>. | |
a6fd7f3f | 1884 | |
3776a202 PF |
1885 | "Used only once" warnings can be generated when C<autodie> or C<Fatal> |
1886 | is used with package filehandles (eg, C<FILE>). It's strongly recommended | |
1887 | you use scalar filehandles instead. | |
1888 | ||
e92e55da MB |
1889 | =head1 AUTHOR |
1890 | ||
0b09a93a | 1891 | Original module by Lionel Cons (CERN). |
e92e55da | 1892 | |
10af26ed | 1893 | Prototype updates by Ilya Zakharevich <ilya@math.ohio-state.edu>. |
e92e55da | 1894 | |
0b09a93a PF |
1895 | L<autodie> support, bugfixes, extended diagnostics, C<system> |
1896 | support, and major overhauling by Paul Fenwick <pjf@perltraining.com.au> | |
1897 | ||
1898 | =head1 LICENSE | |
1899 | ||
1900 | This module is free software, you may distribute it under the | |
1901 | same terms as Perl itself. | |
1902 | ||
1903 | =head1 SEE ALSO | |
1904 | ||
1905 | L<autodie> for a nicer way to use lexical Fatal. | |
1906 | ||
1907 | L<IPC::System::Simple> for a similar idea for calls to C<system()> | |
1908 | and backticks. | |
1909 | ||
c7e47358 | 1910 | =for Pod::Coverage exception_class fill_protos one_invocation throw write_invocation ERROR_NO_IPC_SYS_SIMPLE LEXICAL_TAG |
273225d4 | 1911 | |
e92e55da | 1912 | =cut |