autodie
view release on metacpan or search on metacpan
lib/Fatal.pm view on Meta::CPAN
use constant ERROR_NOARGS => 'Cannot use lexical %s with no arguments';
use constant ERROR_VOID_LEX => VOID_TAG.' cannot be used with lexical scope';
use constant ERROR_LEX_FIRST => LEXICAL_TAG.' must be used as first argument';
use constant ERROR_NO_LEX => "no %s can only start with ".LEXICAL_TAG;
use constant ERROR_BADNAME => "Bad subroutine name for %s: %s";
use constant ERROR_NOTSUB => "%s is not a Perl subroutine";
use constant ERROR_NOT_BUILT => "%s is neither a builtin, nor a Perl subroutine";
use constant ERROR_NOHINTS => "No user hints defined for %s";
use constant ERROR_CANT_OVERRIDE => "Cannot make the non-overridable builtin %s fatal";
use constant ERROR_NO_IPC_SYS_SIMPLE => "IPC::System::Simple required for Fatalised/autodying system()";
use constant ERROR_IPC_SYS_SIMPLE_OLD => "IPC::System::Simple version %f required for Fatalised/autodying system(). We only have version %f";
use constant ERROR_AUTODIE_CONFLICT => q{"no autodie '%s'" is not allowed while "use Fatal '%s'" is in effect};
use constant ERROR_FATAL_CONFLICT => q{"use Fatal '%s'" is not allowed while "no autodie '%s'" is in effect};
use constant ERROR_SMARTMATCH_HINTS => q{%s hints for %s must be code, regexp, or undef. Use of other values is deprecated and only supported on Perl 5.10 through 5.40.};
use constant WARNING_SMARTMATCH_DEPRECATED => q{%s hints for %s must be code, regexp, or undef. Use of other values is deprecated and will be removed before Perl 5.42.};
# Older versions of IPC::System::Simple don't support all the
# features we need.
use constant MIN_IPC_SYS_SIMPLE_VER => 0.12;
our $VERSION = '2.37'; # VERSION: Generated by DZP::OurPkg::Version
our $Debug ||= 0;
# EWOULDBLOCK values for systems that don't supply their own.
# Even though this is defined with our, that's to help our
# test code. Please don't rely upon this variable existing in
# the future.
our %_EWOULDBLOCK = (
MSWin32 => 33,
);
$Carp::CarpInternal{'Fatal'} = 1;
$Carp::CarpInternal{'autodie'} = 1;
$Carp::CarpInternal{'autodie::exception'} = 1;
# the linux parisc port has separate EAGAIN and EWOULDBLOCK,
# and the kernel returns EAGAIN
my $try_EAGAIN = ($^O eq 'linux' and $Config{archname} =~ /hppa|parisc/) ? 1 : 0;
# We have some tags that can be passed in for use with import.
# These are all assumed to be CORE::
my %TAGS = (
':io' => [qw(:dbm :file :filesys :ipc :socket
read seek sysread syswrite sysseek )],
':dbm' => [qw(dbmopen dbmclose)],
':file' => [qw(open close flock sysopen fcntl binmode
ioctl truncate)],
':filesys' => [qw(opendir closedir chdir link unlink rename mkdir
symlink rmdir readlink chmod chown utime)],
':ipc' => [qw(:msg :semaphore :shm pipe kill)],
':msg' => [qw(msgctl msgget msgrcv msgsnd)],
':threads' => [qw(fork)],
':semaphore'=>[qw(semctl semget semop)],
':shm' => [qw(shmctl shmget shmread)],
':system' => [qw(system exec)],
# Can we use qw(getpeername getsockname)? What do they do on failure?
# TODO - Can socket return false?
':socket' => [qw(accept bind connect getsockopt listen recv send
setsockopt shutdown socketpair)],
# Our defaults don't include system(), because it depends upon
# an optional module, and it breaks the exotic form.
#
# This *may* change in the future. I'd love IPC::System::Simple
# to be a dependency rather than a recommendation, and hence for
# system() to be autodying by default.
':default' => [qw(:io :threads)],
# Everything in v2.07 and before. This was :default less chmod and chown
':v207' => [qw(:threads :dbm :socket read seek sysread
syswrite sysseek open close flock sysopen fcntl fileno
binmode ioctl truncate opendir closedir chdir link unlink
rename mkdir symlink rmdir readlink umask
:msg :semaphore :shm pipe)],
# Chmod was added in 2.13
':v213' => [qw(:v207 chmod)],
# chown, utime, kill were added in 2.14
':v214' => [qw(:v213 chown utime kill)],
# umask was removed in 2.26
':v225' => [qw(:io :threads umask fileno)],
# Version specific tags. These allow someone to specify
# use autodie qw(:1.994) and know exactly what they'll get.
':1.994' => [qw(:v207)],
':1.995' => [qw(:v207)],
':1.996' => [qw(:v207)],
':1.997' => [qw(:v207)],
':1.998' => [qw(:v207)],
':1.999' => [qw(:v207)],
':1.999_01' => [qw(:v207)],
':2.00' => [qw(:v207)],
':2.01' => [qw(:v207)],
':2.02' => [qw(:v207)],
':2.03' => [qw(:v207)],
':2.04' => [qw(:v207)],
':2.05' => [qw(:v207)],
':2.06' => [qw(:v207)],
':2.06_01' => [qw(:v207)],
':2.07' => [qw(:v207)], # Last release without chmod
':2.08' => [qw(:v213)],
':2.09' => [qw(:v213)],
':2.10' => [qw(:v213)],
':2.11' => [qw(:v213)],
':2.12' => [qw(:v213)],
':2.13' => [qw(:v213)], # Last release without chown
':2.14' => [qw(:v225)],
':2.15' => [qw(:v225)],
':2.16' => [qw(:v225)],
':2.17' => [qw(:v225)],
':2.18' => [qw(:v225)],
':2.19' => [qw(:v225)],
':2.20' => [qw(:v225)],
':2.21' => [qw(:v225)],
':2.22' => [qw(:v225)],
':2.23' => [qw(:v225)],
':2.24' => [qw(:v225)],
':2.25' => [qw(:v225)],
':2.26' => [qw(:default)],
':2.27' => [qw(:default)],
':2.28' => [qw(:default)],
':2.29' => [qw(:default)],
':2.30' => [qw(:default)],
':2.31' => [qw(:default)],
':2.32' => [qw(:default)],
':2.33' => [qw(:default)],
':2.34' => [qw(:default)],
':2.35' => [qw(:default)],
':2.36' => [qw(:default)],
':2.37' => [qw(:default)],
);
{
# Expand :all immediately by expanding and flattening all tags.
# _expand_tag is not really optimised for expanding the ":all"
# case (i.e. keys %TAGS, or values %TAGS for that matter), so we
# just do it here.
#
# NB: The %tag_cache/_expand_tag relies on $TAGS{':all'} being
# pre-expanded.
my %seen;
my @all = grep {
!/^:/ && !$seen{$_}++
} map { @{$_} } values %TAGS;
$TAGS{':all'} = \@all;
}
# This hash contains subroutines for which we should
# subroutine() // die() rather than subroutine() || die()
my %Use_defined_or;
# CORE::open returns undef on failure. It can legitimately return
# 0 on success, eg: open(my $fh, '-|') || exec(...);
@Use_defined_or{qw(
CORE::fork
CORE::recv
CORE::send
CORE::open
CORE::fileno
CORE::read
CORE::readlink
CORE::sysread
CORE::syswrite
CORE::sysseek
CORE::umask
)} = ();
# Some functions can return true because they changed *some* things, but
# not all of them. This is a list of offending functions, and how many
# items to subtract from @_ to determine the "success" value they return.
my %Returns_num_things_changed = (
'CORE::chmod' => 1,
'CORE::chown' => 2,
'CORE::kill' => 1, # TODO: Could this return anything on negative args?
'CORE::unlink' => 0,
'CORE::utime' => 2,
);
# 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 && !( @_ >= 3 && $_[1] =~ /:/ )) {
# 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;
}
}
},
);
my %reusable_builtins;
# "Wait!" I hear you cry, "truncate() and chdir() are not reuseable! They can
# take file and directory handles, which are package depedent."
#
# You would be correct, except that prototype() returns signatures which don't
# allow for passing of globs, and nobody's complained about that. You can
# still use \*FILEHANDLE, but that results in a reference coming through,
# and it's already pointing to the filehandle in the caller's packge, so
# it's all okay.
@reusable_builtins{qw(
CORE::fork
CORE::kill
CORE::truncate
CORE::chdir
CORE::link
CORE::unlink
CORE::rename
CORE::mkdir
CORE::symlink
CORE::rmdir
CORE::readlink
CORE::umask
CORE::chmod
CORE::chown
CORE::utime
CORE::msgctl
CORE::msgget
CORE::msgrcv
CORE::msgsnd
CORE::semctl
CORE::semget
CORE::semop
CORE::shmctl
CORE::shmget
CORE::shmread
CORE::exec
CORE::system
)} = ();
# 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
# for every single package that wants to use them.
my %Cached_fatalised_sub = ();
# Every time we're called with package scope, we record the subroutine
# (including package or CORE::) in %Package_Fatal. This allows us
# to detect illegal combinations of autodie and Fatal, and makes sure
# we don't accidently make a Fatal function autodying (which isn't
# very useful).
my %Package_Fatal = ();
# The first time we're called with a user-sub, we cache it here.
# In the case of a "no autodie ..." we put back the cached copy.
my %Original_user_sub = ();
# Is_fatalised_sub simply records a big map of fatalised subroutine
# refs. It means we can avoid repeating work, or fatalising something
# we've already processed.
my %Is_fatalised_sub = ();
tie %Is_fatalised_sub, 'Tie::RefHash';
# Our trampoline cache allows us to cache trampolines which are used to
# bounce leaked wrapped core subroutines to their actual core counterparts.
my %Trampoline_cache;
# A cache mapping "CORE::<name>" to their prototype. Turns out that if
# you "use autodie;" enough times, this pays off.
my %CORE_prototype_cache;
# We use our package in a few hash-keys. Having it in a scalar is
# convenient. The "guard $PACKAGE" string is used as a key when
# setting up lexical guards.
my $PACKAGE = __PACKAGE__;
my $NO_PACKAGE = "no $PACKAGE"; # Used to detect 'no autodie'
# Here's where all the magic happens when someone write 'use Fatal'
# or 'use autodie'.
lib/Fatal.pm view on Meta::CPAN
my $EWOULDBLOCK = eval { POSIX::EWOULDBLOCK(); }
|| $_EWOULDBLOCK{$^O}
|| _autocroak("Internal error - can't overload flock - EWOULDBLOCK not defined on this system.");
my $EAGAIN = $EWOULDBLOCK;
if ($try_EAGAIN) {
$EAGAIN = eval { POSIX::EAGAIN(); }
|| _autocroak("Internal error - can't overload flock - EAGAIN not defined on this system.");
}
require Fcntl; # For Fcntl::LOCK_NB
return qq{
my \$context = wantarray() ? "list" : "scalar";
# Try to flock. If successful, return it immediately.
my \$retval = $call(@argv);
return \$retval if \$retval;
# If we failed, but we're using LOCK_NB and
# returned EWOULDBLOCK, it's not a real error.
if (\$_[1] & Fcntl::LOCK_NB() and
(\$! == $EWOULDBLOCK or
($try_EAGAIN and \$! == $EAGAIN ))) {
return \$retval;
}
# Otherwise, we failed. Die noisily.
$die;
};
}
if ($call eq 'CORE::kill') {
return qq[
my \$num_things = \@_ - $Returns_num_things_changed{$call};
my \$context = ! defined wantarray() ? 'void' : 'scalar';
my \$signal = \$_[0];
my \$retval = $call(@argv);
my \$sigzero = looks_like_number( \$signal ) && \$signal == 0;
if ( ( \$sigzero && \$context eq 'void' )
or ( ! \$sigzero && \$retval != \$num_things ) ) {
$die;
}
return \$retval;
];
}
if (exists $Returns_num_things_changed{$call}) {
# Some things return the number of things changed (like
# chown, kill, chmod, etc). We only consider these successful
# if *all* the things are changed.
return qq[
my \$num_things = \@_ - $Returns_num_things_changed{$call};
my \$retval = $call(@argv);
if (\$retval != \$num_things) {
# We need \$context to throw an exception.
# It's *always* set to scalar, because that's how
# autodie calls chown() above.
my \$context = "scalar";
$die;
}
return \$retval;
];
}
# AFAIK everything that can be given an unopned filehandle
# will fail if it tries to use it, so we don't really need
# the 'unopened' warning class here. Especially since they
# then report the wrong line number.
# Other warnings are disabled because they produce excessive
# complaints from smart-match hints under 5.10.1.
my $code = qq[
no warnings qw(unopened uninitialized numeric);
if (wantarray) {
my \@results = $call(@argv);
my \$retval = \\\@results;
my \$context = "list";
];
my $retval_action = $Retval_action{$call} || '';
if ( $hints && exists $hints->{list} ) {
my $match;
if ( ref($hints->{list}) eq 'CODE' ) {
# NB: Subroutine hints are passed as a full list.
# This differs from the 5.10.0 smart-match behaviour,
# but means that context unaware subroutines can use
# the same hints in both list and scalar context.
$match = q[ $hints->{list}->(@results) ];
}
elsif ( ref($hints->{list}) eq 'Regexp' ) {
$match = q[ grep $_ =~ $hints->{list}, @results ];
}
elsif ( !defined $hints->{list} ) {
$match = q[ grep !defined, @results ];
}
elsif ( SMARTMATCH_ALLOWED ) {
$match = q[ @results ~~ $hints->{list} ];
warnings::warnif('deprecated', sprintf(WARNING_SMARTMATCH_DEPRECATED, 'list', $sub));
if (SMARTMATCH_CATEGORY) {
$match = sprintf q[ do { no warnings '%s'; %s } ], SMARTMATCH_CATEGORY, $match;
}
}
else {
croak sprintf(ERROR_SMARTMATCH_HINTS, 'list', $sub);
}
$code .= qq{
if ( $match ) { $die };
};
}
( run in 0.785 second using v1.01-cache-2.11-cpan-5511b514fd6 )