cpan/autodie/lib/autodie/skip.pm
cpan/autodie/lib/Fatal.pm Make errors in functions/builtins fatal
cpan/autodie/t/00-load.t autodie - basic load
+cpan/autodie/t/args.t
cpan/autodie/t/autodie_skippy.pm
cpan/autodie/t/autodie.t autodie - Basic functionality
cpan/autodie/t/autodie_test_module.pm autodie - test helper
cpan/autodie/t/open.t autodie - Testing open
cpan/autodie/t/recv.t autodie - send/recv tests
cpan/autodie/t/repeat.t autodie - repeat autodie leak tests
+cpan/autodie/t/rt-74246.t
cpan/autodie/t/scope_leak.t autodie - file scope leak tests
cpan/autodie/t/skip.t
cpan/autodie/t/string-eval-basic.t autodie - Basic string eval test
},
'autodie' => {
- 'DISTRIBUTION' => 'PJF/autodie-2.22.tar.gz',
+ 'DISTRIBUTION' => 'PJF/autodie-2.23.tar.gz',
'FILES' => q[cpan/autodie],
'EXCLUDED' => [
qr{benchmarks},
use constant MIN_IPC_SYS_SIMPLE_VER => 0.12;
-our $VERSION = '2.22'; # VERSION: Generated by DZP::OurPkg::Version
+our $VERSION = '2.23'; # VERSION: Generated by DZP::OurPkg::Version
our $Debug ||= 0;
':2.20' => [qw(:default)],
':2.21' => [qw(:default)],
':2.22' => [qw(:default)],
+ ':2.23' => [qw(:default)],
);
# chmod was only introduced in 2.07
# pass-through unknown tags (i.e. we have to manually handle
# VOID_TAG).
#
- # TODO: Consider how to handle stuff like:
- # use autodie qw(:defaults ! :io);
- # use Fatal qw(:defaults :void :io);
+ # NB: _translate_import_args re-orders everything for us, so
+ # we don't have to worry about stuff like:
#
- # The ! and :void is currently not applied to anything in the
- # example above since duplicates are filtered out. This has been
- # autodie's behaviour for quite a while, but it might make sense
- # to change it so "!" or ":void" applies to stuff after they
- # appear (even if they are all duplicates).
+ # :default :void :io
+ #
+ # That will (correctly) translated into
+ #
+ # expand(:defaults-without-io) :void :io
+ #
+ # by _translate_import_args.
for my $func ($class->_translate_import_args(@fatalise_these)) {
if ($func eq VOID_TAG) {
# 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;
-
- # Copy symbols across to temp area.
+ # We will repeatedly mess with stuff that strict "refs" does
+ # not like. So lets just disable it once for this entire
+ # scope.
+ no strict qw(refs); ## no critic
- no strict 'refs'; ## no critic
+ my $sub_ref= $subs_to_reinstate->{$sub_name};
- local *__tmp = *{ $full_path };
+ my $full_path = $pkg_sym.$sub_name;
+ my $oldglob = *$full_path;
# Nuke the old glob.
- { no strict; delete $pkg_sym->{$sub_name}; } ## no critic
+ delete $pkg_sym->{$sub_name};
+
+ # For some reason this local *alias = *$full_path triggers an
+ # "only used once" warning. Not entirely sure why, but at
+ # least it is easy to silence.
+ no warnings qw(once);
+ local *alias = *$full_path;
+ use warnings qw(once);
# Copy innocent bystanders back. Note that we lose
# formats; it seems that Perl versions up to 5.10.0
# the scalar slot. Thanks to Ben Morrow for spotting this.
foreach my $slot (qw( SCALAR ARRAY HASH IO ) ) {
- next unless defined *__tmp{ $slot };
- *{ $full_path } = *__tmp{ $slot };
+ next unless defined *$oldglob{$slot};
+ *alias = *$oldglob{$slot};
}
- # Put back the old sub (if there was one).
-
if ($sub_ref) {
-
- no strict; ## no critic
- *{ $full_path } = $sub_ref;
+ *$full_path = $sub_ref;
}
}
sub _translate_import_args {
my ($class, @args) = @_;
my @result;
- for my $a (@args){
+ my %seen;
+
+ if (@args < 2) {
+ # Optimize for this case, as it is fairly common. (e.g. use
+ # autodie; or use autodie qw(:all); both trigger this).
+ return unless @args;
+
+ # Not a (known) tag, pass through.
+ return @args unless exists($TAGS{$args[0]});
+
+ # Strip "CORE::" from all elements in the list as import and
+ # unimport does not handle the "CORE::" prefix too well.
+ #
+ # NB: we use substr as it is faster than s/^CORE::// and
+ # it does not change the elements.
+ return map { substr($_, 6) } @{ $class->_expand_tag($args[0]) };
+ }
+
+ # We want to translate
+ #
+ # :default :void :io
+ #
+ # into (pseudo-ish):
+ #
+ # expanded(:threads) :void expanded(:io)
+ #
+ # We accomplish this by "reverse, expand + filter, reverse".
+ for my $a (reverse(@args)) {
if (exists $TAGS{$a}) {
my $expanded = $class->_expand_tag($a);
- # Strip "CORE::" from all elements in the list as import and
- # unimport does not handle the "CORE::" prefix too well.
- #
- # NB: we use substr as it is faster than s/^CORE::// and
- # it does not change the elements.
- push @result, map { substr($_, 6) } @{$expanded};
+ push(@result,
+ # Remove duplicates after ...
+ grep { !$seen{$_}++ }
+ # we have stripped CORE:: (see above)
+ map { substr($_, 6) }
+ # We take the elements in reverse order
+ # (as @result be reversed later).
+ reverse(@{$expanded}));
} else {
- #pass through
+ # pass through - no filtering here for tags.
+ #
+ # The reason for not filtering tags cases like:
+ #
+ # ":default :void :io :void :threads"
+ #
+ # As we have reversed args, we see this as:
+ #
+ # ":threads :void :io :void* :default*"
+ #
+ # (Entries marked with "*" will be filtered out completely). When
+ # reversed again, this will be:
+ #
+ # ":io :void :threads"
+ #
+ # But we would rather want it to be:
+ #
+ # ":void :io :threads" or ":void :io :void :threads"
+ #
+
+ my $letter = substr($a, 0, 1);
+ if ($letter ne ':' && $a ne INSIST_TAG) {
+ next if $seen{$a}++;
+ if ($letter eq '!' and $seen{substr($a, 1)}++) {
+ my $name = substr($a, 1);
+ # People are being silly and doing:
+ #
+ # use autodie qw(!a a);
+ #
+ # Enjoy this little O(n) clean up...
+ @result = grep { $_ ne $name } @result;
+ }
+ }
push @result, $a;
}
}
- # If @args < 2, then we have no duplicates (because _expand_tag
- # does not have duplicates and if it is not a tag, it is just a
- # single value). We optimize for this because it is a fairly
- # common case (e.g. use autodie; or use autodie qw(:all); both
- # trigger this).
- return @result if @args < 2;
-
- my %seen = ();
- # Yes, this is basically List::MoreUtils's uniq/distinct, but
- # List::MoreUtils is not in the Perl core and autodie is
- return grep { !$seen{$_}++ } @result;
+ # Reverse the result to restore the input order
+ return reverse(@result);
}
L<IPC::System::Simple> for a similar idea for calls to C<system()>
and backticks.
-=for Pod::Coverage exception_class fill_protos one_invocation throw write_invocation
+=for Pod::Coverage exception_class fill_protos one_invocation throw write_invocation ERROR_NO_IPC_SYS_SIMPLE LEXICAL_TAG
=cut
# ABSTRACT: Replace functions with ones that succeed or die with lexical scope
BEGIN {
- our $VERSION = '2.22'; # VERSION: Generated by DZP::OurPkg::Version
+ our $VERSION = '2.23'; # VERSION: Generated by DZP::OurPkg::Version
}
use constant ERROR_WRONG_FATAL => q{
=head1 FUNCTION SPECIFIC NOTES
+=head2 print
+
+The autodie pragma B<<does not check calls to C<print>>>.
+
=head2 flock
It is not considered an error for C<flock> to return false if it fails
use warnings;
use Carp qw(croak);
-our $VERSION = '2.22'; # VERSION: Generated by DZP::OurPkg:Version
+our $VERSION = '2.23'; # VERSION: Generated by DZP::OurPkg:Version
# ABSTRACT: Exceptions from autodying functions.
our $DEBUG = 0;
elsif ($mode eq '>') { $wordy_mode = 'writing'; }
elsif ($mode eq '>>') { $wordy_mode = 'appending'; }
+ $file = '<undef>' if not defined $file;
+
return sprintf _FORMAT_OPEN, $file, $wordy_mode, $error if $wordy_mode;
Carp::confess("Internal autodie::exception error: Don't know how to format mode '$mode'.");
use base 'autodie::exception';
use Carp qw(croak);
-our $VERSION = '2.22'; # VERSION: Generated by DZP::OurPkg:Version
+our $VERSION = '2.23'; # VERSION: Generated by DZP::OurPkg:Version
# ABSTRACT: Exceptions from autodying system().
use constant PERL58 => ( $] < 5.009 );
-our $VERSION = '2.22'; # VERSION: Generated by DZP::OurPkg:Version
+our $VERSION = '2.23'; # VERSION: Generated by DZP::OurPkg:Version
# ABSTRACT: Provide hints about user subroutines to autodie
use strict;
use warnings;
-our $VERSION = '2.22'; # VERSION
+our $VERSION = '2.23'; # VERSION
# This package exists purely so people can inherit from it,
# which isn't at all how roles are supposed to work, but it's
use Test::More tests => 17;
-use Fatal qw(open close :void opendir);
+use Fatal qw(:io :void opendir);
eval { open FOO, "<".NO_SUCH_FILE }; # Two arg open
like($@, qr/^Can't open/, q{Package Fatal::open});
--- /dev/null
+#!/usr/bin/perl -w
+use strict;
+use warnings;
+
+use Test::More tests => 7;
+
+require Fatal;
+
+my @default = expand(':default');
+my @threads = expand(':threads');
+my @io = expand(':io');
+my %io_hash = map { $_ => 1 } @io;
+my @default_minus_io = grep { !exists($io_hash{$_}) } @default;
+
+is_deeply(translate('!a', 'a'), ['!a'], 'Keeps insist variant');
+
+is_deeply(translate(':default'), \@default,
+ 'translate and expand agrees');
+
+is_deeply(translate(':default', ':void', ':io'),
+ [@default_minus_io, ':void', @io],
+ ':void position is respected');
+
+is_deeply(translate(':default', ':void', ':io', ':void', ':threads'),
+ [':void', @io, ':void', @threads],
+ ':void (twice) position are respected');
+
+is_deeply(translate(':default', '!', ':io'),
+ [@default_minus_io, '!', @io], '! position is respected');
+
+is_deeply(translate(':default', '!', ':io', '!', ':threads'),
+ ['!', @io, '!', @threads],
+ '! (twice) positions are respected');
+
+is_deeply(translate(':default', '!open', '!', ':io'),
+ [@default_minus_io, '!open', '!', grep { $_ ne 'open' } @io],
+ '!open ! :io works as well');
+
+sub expand {
+ # substr is to strip "CORE::" without modifying $_
+ return map { substr($_, 6) } @{Fatal->_expand_tag(@_)};
+}
+
+sub translate {
+ return [Fatal->_translate_import_args(@_)];
+}
# Sniff to see if we can run 'true' on this system. Changes we can't
# on non-Unix systems.
+use Config;
+my @true = ($^O =~ /android/
+ || ($Config{usecrosscompile} && $^O eq 'nto' ))
+ ? ('sh', '-c', 'true $@', '--')
+ : 'true';
+
eval {
use autodie;
die "Windows and VMS do not support multi-arg pipe" if $^O eq "MSWin32" or $^O eq 'VMS';
- open(my $fh, '-|', "true");
+ open(my $fh, '-|', @true);
};
SKIP: {
use autodie;
my $fh;
- open $fh, "-|", "true";
- open $fh, "-|", "true", "foo";
- open $fh, "-|", "true", "foo", "bar";
- open $fh, "-|", "true", "foo", "bar", "baz";
+ open $fh, "-|", @true;
+ open $fh, "-|", @true, "foo";
+ open $fh, "-|", @true, "foo", "bar";
+ open $fh, "-|", @true, "foo", "bar", "baz";
};
is $@, '', "multi arg piped open does not fail";
--- /dev/null
+#!/usr/bin/perl -w
+
+use strict;
+
+use Test::More tests => 1;
+
+eval q{
+ use strict;
+ no warnings; # Suppress a "helpful" warning on STDERR
+ use autodie qw(open);
+ $open = 1;
+};
+like($@, qr/Global symbol "\$open" requires explicit package name/,
+ 'autodie does not break "use strict;"');
projects / platform / upstream / perl.git / commitdiff