diff options
Diffstat (limited to 'Master/tlpkg/tlperl/lib/Fatal.pm')
-rw-r--r-- | Master/tlpkg/tlperl/lib/Fatal.pm | 74 |
1 files changed, 69 insertions, 5 deletions
diff --git a/Master/tlpkg/tlperl/lib/Fatal.pm b/Master/tlpkg/tlperl/lib/Fatal.pm index aabdf781de0..c6a3d1b3290 100644 --- a/Master/tlpkg/tlperl/lib/Fatal.pm +++ b/Master/tlpkg/tlperl/lib/Fatal.pm @@ -40,7 +40,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; # All the Fatal/autodie modules share the same version number. -our $VERSION = '2.10'; +our $VERSION = '2.13'; our $Debug ||= 0; @@ -116,6 +116,9 @@ my %TAGS = ( ':2.08' => [qw(:default)], ':2.09' => [qw(:default)], ':2.10' => [qw(:default)], + ':2.11' => [qw(:default)], + ':2.12' => [qw(:default)], + ':2.13' => [qw(:default)], ); # chmod was only introduced in 2.07 @@ -144,6 +147,58 @@ my %Use_defined_or; CORE::umask )} = (); + +# A snippet of code to apply the open pragma to a handle + + + +# Optional actions to take on the return value before returning it. + +my %Retval_action = ( + "CORE::open" => q{ + + # apply the open pragma from our caller + if( defined $retval ) { + # Get the caller's hint hash + my $hints = (caller 0)[10]; + + # Decide if we're reading or writing and apply the appropriate encoding + # These keys are undocumented. + # Match what PerlIO_context_layers() does. Read gets the read layer, + # everything else gets the write layer. + my $encoding = $_[1] =~ /^\+?>/ ? $hints->{"open>"} : $hints->{"open<"}; + + # Apply the encoding, if any. + if( $encoding ) { + binmode $_[0], $encoding; + } + } + +}, + "CORE::sysopen" => q{ + + # apply the open pragma from our caller + if( defined $retval ) { + # Get the caller's hint hash + my $hints = (caller 0)[10]; + + require Fcntl; + + # Decide if we're reading or writing and apply the appropriate encoding. + # Match what PerlIO_context_layers() does. Read gets the read layer, + # everything else gets the write layer. + my $open_read_only = !($_[2] ^ Fcntl::O_RDONLY()); + my $encoding = $open_read_only ? $hints->{"open<"} : $hints->{"open>"}; + + # Apply the encoding, if any. + if( $encoding ) { + binmode $_[0], $encoding; + } + } + +}, +); + # Cached_fatalised_sub caches the various versions of our # fatalised subs as they're produced. This means we don't # have to build our own replacement of CORE::open and friends @@ -355,7 +410,9 @@ sub _install_subs { my $pkg_sym = "${pkg}::"; - while(my ($sub_name, $sub_ref) = each %$subs_to_reinstate) { + # It does not hurt to do this in a predictable order, and might help debugging. + foreach my $sub_name (sort keys %$subs_to_reinstate) { + my $sub_ref= $subs_to_reinstate->{$sub_name}; my $full_path = $pkg_sym.$sub_name; @@ -802,6 +859,7 @@ sub _one_invocation { my $code = qq[ no warnings qw(unopened uninitialized numeric); + no if \$\] >= 5.017011, warnings => "experimental::smartmatch"; if (wantarray) { my \@results = $call(@argv); @@ -810,6 +868,8 @@ sub _one_invocation { ]; + my $retval_action = $Retval_action{$call} || ''; + if ( $hints and ( ref($hints->{list} ) || "" ) eq 'CODE' ) { # NB: Subroutine hints are passed as a full list. @@ -862,6 +922,7 @@ sub _one_invocation { return $code .= qq{ if ( \$hints->{scalar}->(\$retval) ) { $die }; + $retval_action return \$retval; }; @@ -870,7 +931,7 @@ sub _one_invocation { return $code . qq{ if ( \$retval ~~ \$hints->{scalar} ) { $die }; - + $retval_action return \$retval; }; } @@ -882,11 +943,12 @@ sub _one_invocation { ( $use_defined_or ? qq{ $die if not defined \$retval; - + $retval_action return \$retval; } : qq{ + $retval_action return \$retval || $die; } ) ; @@ -1238,7 +1300,9 @@ sub exception_class { return "autodie::exception" }; { local $@; # We can't clobber $@, it's wrong! - eval "require $exception_class"; ## no critic + my $pm_file = $exception_class . ".pm"; + $pm_file =~ s{ (?: :: | ' ) }{/}gx; + eval { require $pm_file }; $E = $@; # Save $E despite ending our local. } |