diff options
Diffstat (limited to 'cpan/autodie')
| -rw-r--r-- | cpan/autodie/lib/Fatal.pm | 144 | ||||
| -rw-r--r-- | cpan/autodie/lib/autodie.pm | 6 | ||||
| -rw-r--r-- | cpan/autodie/lib/autodie/exception.pm | 4 | ||||
| -rw-r--r-- | cpan/autodie/lib/autodie/exception/system.pm | 2 | ||||
| -rw-r--r-- | cpan/autodie/lib/autodie/hints.pm | 2 | ||||
| -rw-r--r-- | cpan/autodie/lib/autodie/skip.pm | 2 | ||||
| -rw-r--r-- | cpan/autodie/t/Fatal.t | 2 | ||||
| -rw-r--r-- | cpan/autodie/t/args.t | 46 | ||||
| -rw-r--r-- | cpan/autodie/t/open.t | 16 | ||||
| -rw-r--r-- | cpan/autodie/t/rt-74246.t | 14 |
10 files changed, 184 insertions, 54 deletions
diff --git a/cpan/autodie/lib/Fatal.pm b/cpan/autodie/lib/Fatal.pm index bea5231420..e538e20d68 100644 --- a/cpan/autodie/lib/Fatal.pm +++ b/cpan/autodie/lib/Fatal.pm @@ -48,7 +48,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; -our $VERSION = '2.22'; # VERSION: Generated by DZP::OurPkg::Version +our $VERSION = '2.23'; # VERSION: Generated by DZP::OurPkg::Version our $Debug ||= 0; @@ -144,6 +144,7 @@ my %TAGS = ( ':2.20' => [qw(:default)], ':2.21' => [qw(:default)], ':2.22' => [qw(:default)], + ':2.23' => [qw(:default)], ); # chmod was only introduced in 2.07 @@ -378,15 +379,16 @@ sub import { # 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) { @@ -503,18 +505,26 @@ sub _install_subs { # 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 @@ -522,16 +532,12 @@ sub _install_subs { # 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; } } @@ -597,31 +603,83 @@ sub unimport { 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); } @@ -1849,6 +1907,6 @@ L<autodie> for a nicer way to use lexical Fatal. 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 diff --git a/cpan/autodie/lib/autodie.pm b/cpan/autodie/lib/autodie.pm index 1e9f85273c..ed5a612efe 100644 --- a/cpan/autodie/lib/autodie.pm +++ b/cpan/autodie/lib/autodie.pm @@ -10,7 +10,7 @@ our $VERSION; # 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{ @@ -265,6 +265,10 @@ C<system> and C<exec> with: =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 diff --git a/cpan/autodie/lib/autodie/exception.pm b/cpan/autodie/lib/autodie/exception.pm index 142e5db692..0081860576 100644 --- a/cpan/autodie/lib/autodie/exception.pm +++ b/cpan/autodie/lib/autodie/exception.pm @@ -4,7 +4,7 @@ use strict; 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; @@ -404,6 +404,8 @@ sub _format_open_with_mode { 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'."); diff --git a/cpan/autodie/lib/autodie/exception/system.pm b/cpan/autodie/lib/autodie/exception/system.pm index 7bb1f5f192..2d734fe7f2 100644 --- a/cpan/autodie/lib/autodie/exception/system.pm +++ b/cpan/autodie/lib/autodie/exception/system.pm @@ -5,7 +5,7 @@ use warnings; 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(). diff --git a/cpan/autodie/lib/autodie/hints.pm b/cpan/autodie/lib/autodie/hints.pm index d63849f82d..17c898a900 100644 --- a/cpan/autodie/lib/autodie/hints.pm +++ b/cpan/autodie/lib/autodie/hints.pm @@ -5,7 +5,7 @@ use warnings; 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 diff --git a/cpan/autodie/lib/autodie/skip.pm b/cpan/autodie/lib/autodie/skip.pm index 9eb4cf4404..af40662810 100644 --- a/cpan/autodie/lib/autodie/skip.pm +++ b/cpan/autodie/lib/autodie/skip.pm @@ -2,7 +2,7 @@ package autodie::skip; 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 diff --git a/cpan/autodie/t/Fatal.t b/cpan/autodie/t/Fatal.t index a291837d13..b0db13d63e 100644 --- a/cpan/autodie/t/Fatal.t +++ b/cpan/autodie/t/Fatal.t @@ -5,7 +5,7 @@ use constant NO_SUCH_FILE => "this_file_or_dir_had_better_not_exist_XYZZY"; 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}); diff --git a/cpan/autodie/t/args.t b/cpan/autodie/t/args.t new file mode 100644 index 0000000000..d44bb830d8 --- /dev/null +++ b/cpan/autodie/t/args.t @@ -0,0 +1,46 @@ +#!/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(@_)]; +} diff --git a/cpan/autodie/t/open.t b/cpan/autodie/t/open.t index d11dda5772..51a1f2df20 100644 --- a/cpan/autodie/t/open.t +++ b/cpan/autodie/t/open.t @@ -53,12 +53,18 @@ unlike($@, qr/at \S+ line \d+\s+at \S+ line \d+/, "...but not too mentions"); # 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: { @@ -68,10 +74,10 @@ 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"; diff --git a/cpan/autodie/t/rt-74246.t b/cpan/autodie/t/rt-74246.t new file mode 100644 index 0000000000..e4d6210609 --- /dev/null +++ b/cpan/autodie/t/rt-74246.t @@ -0,0 +1,14 @@ +#!/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;"'); |