diff options
| -rw-r--r-- | MANIFEST | 1 | ||||
| -rwxr-xr-x | Porting/Maintainers.pl | 2 | ||||
| -rwxr-xr-x | cpan/autodie/lib/Fatal.pm | 98 | ||||
| -rw-r--r-- | cpan/autodie/lib/autodie.pm | 4 | ||||
| -rw-r--r-- | cpan/autodie/lib/autodie/exception.pm | 2 | ||||
| -rw-r--r-- | cpan/autodie/lib/autodie/exception/system.pm | 2 | ||||
| -rw-r--r-- | cpan/autodie/lib/autodie/hints.pm | 2 | ||||
| -rwxr-xr-x | cpan/autodie/t/eval_error.t | 20 | ||||
| -rwxr-xr-x | cpan/autodie/t/flock.t | 12 | ||||
| -rwxr-xr-x | cpan/autodie/t/internal-backcompat.t | 12 | ||||
| -rwxr-xr-x | cpan/autodie/t/open.t | 29 | ||||
| -rwxr-xr-x | cpan/autodie/t/version_tag.t | 22 |
12 files changed, 164 insertions, 42 deletions
@@ -80,6 +80,7 @@ cpan/autodie/t/context_lexical.t autodie - Context clobbering lexically cpan/autodie/t/context.t autodie - Context clobbering tests cpan/autodie/t/crickey.t autodie - Like an Australian cpan/autodie/t/dbmopen.t autodie - dbm tests +cpan/autodie/t/eval_error.t cpan/autodie/t/exception_class.t autodie - Exception class subclasses cpan/autodie/t/exceptions.t autodie - 5.10 exception tests. cpan/autodie/t/exec.t autodie - exec tests. diff --git a/Porting/Maintainers.pl b/Porting/Maintainers.pl index 632b838d4b..e8d674d35e 100755 --- a/Porting/Maintainers.pl +++ b/Porting/Maintainers.pl @@ -209,7 +209,7 @@ use File::Glob qw(:case); 'autodie' => { 'MAINTAINER' => 'pjf', - 'DISTRIBUTION' => 'PJF/autodie-2.06_01.tar.gz', + 'DISTRIBUTION' => 'PJF/autodie-2.10.tar.gz', 'FILES' => q[cpan/autodie], 'EXCLUDED' => [ qr{^inc/Module/}, diff --git a/cpan/autodie/lib/Fatal.pm b/cpan/autodie/lib/Fatal.pm index 18e71ed21a..aabdf781de 100755 --- a/cpan/autodie/lib/Fatal.pm +++ b/cpan/autodie/lib/Fatal.pm @@ -5,6 +5,7 @@ use Carp; use strict; use warnings; use Tie::RefHash; # To cache subroutine refs +use Config; use constant PERL510 => ( $] >= 5.010 ); @@ -39,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.06_01'; +our $VERSION = '2.10'; our $Debug ||= 0; @@ -52,6 +53,10 @@ our %_EWOULDBLOCK = ( MSWin32 => 33, ); +# 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:: @@ -60,7 +65,7 @@ my %TAGS = ( read seek sysread syswrite sysseek )], ':dbm' => [qw(dbmopen dbmclose)], ':file' => [qw(open close flock sysopen fcntl fileno binmode - ioctl truncate)], + ioctl truncate chmod)], ':filesys' => [qw(opendir closedir chdir link unlink rename mkdir symlink rmdir readlink umask)], ':ipc' => [qw(:msg :semaphore :shm pipe)], @@ -84,26 +89,37 @@ my %TAGS = ( ':default' => [qw(:io :threads)], + # Everything in v2.07 and brefore. This was :default less chmod. + ':v207' => [qw(:threads :dbm :filesys :ipc :socket read seek sysread + syswrite sysseek open close flock sysopen fcntl fileno + binmode ioctl truncate)], + # Version specific tags. These allow someone to specify # use autodie qw(:1.994) and know exactly what they'll get. - ':1.994' => [qw(:default)], - ':1.995' => [qw(:default)], - ':1.996' => [qw(:default)], - ':1.997' => [qw(:default)], - ':1.998' => [qw(:default)], - ':1.999' => [qw(:default)], - ':1.999_01' => [qw(:default)], - ':2.00' => [qw(:default)], - ':2.01' => [qw(:default)], - ':2.02' => [qw(:default)], - ':2.03' => [qw(:default)], - ':2.04' => [qw(:default)], - ':2.05' => [qw(:default)], - ':2.06' => [qw(:default)], - ':2.06_01' => [qw(:default)], + ':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(:default)], + ':2.09' => [qw(:default)], + ':2.10' => [qw(:default)], ); +# chmod was only introduced in 2.07 + $TAGS{':all'} = [ keys %TAGS ]; # This hash contains subroutines for which we should @@ -168,6 +184,7 @@ my $NO_PACKAGE = "no $PACKAGE"; # Used to detect 'no autodie' sub import { my $class = shift(@_); + my @original_args = @_; my $void = 0; my $lexical = 0; my $insist_hints = 0; @@ -306,6 +323,16 @@ sub import { $class->_install_subs($pkg, \%unload_later); })); + # To allow others to determine when autodie was in scope, + # and with what arguments, we also set a %^H hint which + # is how we were called. + + # This feature should be considered EXPERIMENTAL, and + # may change without notice. Please e-mail pjf@cpan.org + # if you're actually using it. + + $^H{autodie} = "$PACKAGE @original_args"; + } return; @@ -449,8 +476,10 @@ sub unimport { while (my $item = shift @to_process) { if ($item =~ /^:/) { + # Expand :tags push(@to_process, @{$TAGS{$item}} ); - } else { + } + else { push(@taglist, "CORE::$item"); } } @@ -520,7 +549,17 @@ sub _write_invocation { @argv = @{shift @argvs}; $n = shift @argv; - push @out, "${else}if (\@_ == $n) {\n"; + my $condition = "\@_ == $n"; + + if (@argv and $argv[-1] =~ /#_/) { + # This argv ends with '@' in the prototype, so it matches + # any number of args >= the number of expressions in the + # argv. + $condition = "\@_ >= $n"; + } + + push @out, "${else}if ($condition) {\n"; + $else = "\t} els"; push @out, $class->_one_invocation($core,$call,$name,$void,$sub,! $lexical, $sref, @argv); @@ -594,11 +633,11 @@ sub _one_invocation { if ($void) { return qq/return (defined wantarray)?$call(@argv): - $call(@argv) || croak "Can't $name(\@_)/ . - ($core ? ': $!' : ', \$! is \"$!\"') . '"' + $call(@argv) || Carp::croak("Can't $name(\@_)/ . + ($core ? ': $!' : ', \$! is \"$!\"') . '")' } else { - return qq{return $call(@argv) || croak "Can't $name(\@_)} . - ($core ? ': $!' : ', \$! is \"$!\"') . '"'; + return qq{return $call(@argv) || Carp::croak("Can't $name(\@_)} . + ($core ? ': $!' : ', \$! is \"$!\"') . '")'; } } @@ -720,6 +759,11 @@ sub _one_invocation { 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 @@ -735,7 +779,9 @@ sub _one_invocation { # 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 ) { + if (\$_[1] & Fcntl::LOCK_NB() and + (\$! == $EWOULDBLOCK or + ($try_EAGAIN and \$! == $EAGAIN ))) { return \$retval; } @@ -1053,7 +1099,7 @@ sub _make_fatal { { local $@; - $code = eval("package $pkg; use Carp; $code"); ## no critic + $code = eval("package $pkg; require Carp; $code"); ## no critic $E = $@; } @@ -1131,7 +1177,7 @@ sub _make_fatal { >; } - $leak_guard .= qq< croak "Internal error in Fatal/autodie. Leak-guard failure"; } >; + $leak_guard .= qq< Carp::croak("Internal error in Fatal/autodie. Leak-guard failure"); } >; # warn "$leak_guard\n"; diff --git a/cpan/autodie/lib/autodie.pm b/cpan/autodie/lib/autodie.pm index 8e8e7094c7..cb14fb037b 100644 --- a/cpan/autodie/lib/autodie.pm +++ b/cpan/autodie/lib/autodie.pm @@ -8,7 +8,7 @@ our @ISA = qw(Fatal); our $VERSION; BEGIN { - $VERSION = '2.06_01'; + $VERSION = '2.10'; } use constant ERROR_WRONG_FATAL => q{ @@ -264,7 +264,7 @@ C<system> and C<exec> with: =head2 flock It is not considered an error for C<flock> to return false if it fails -to an C<EWOULDBLOCK> (or equivalent) condition. This means one can +due to an C<EWOULDBLOCK> (or equivalent) condition. This means one can still use the common convention of testing the return value of C<flock> when called with the C<LOCK_NB> option: diff --git a/cpan/autodie/lib/autodie/exception.pm b/cpan/autodie/lib/autodie/exception.pm index 8646099c4c..14d5cb0f07 100644 --- a/cpan/autodie/lib/autodie/exception.pm +++ b/cpan/autodie/lib/autodie/exception.pm @@ -14,7 +14,7 @@ use overload use if ($] >= 5.010), overload => '~~' => "matches"; -our $VERSION = '2.06_01'; +our $VERSION = '2.10'; my $PACKAGE = __PACKAGE__; # Useful to have a scalar for hash keys. diff --git a/cpan/autodie/lib/autodie/exception/system.pm b/cpan/autodie/lib/autodie/exception/system.pm index 07cd1c9a03..747fea7810 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.06_01'; +our $VERSION = '2.10'; my $PACKAGE = __PACKAGE__; diff --git a/cpan/autodie/lib/autodie/hints.pm b/cpan/autodie/lib/autodie/hints.pm index e7be03a047..89b3bc827b 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.06_01'; +our $VERSION = '2.10'; =head1 NAME diff --git a/cpan/autodie/t/eval_error.t b/cpan/autodie/t/eval_error.t new file mode 100755 index 0000000000..a2aa8939a0 --- /dev/null +++ b/cpan/autodie/t/eval_error.t @@ -0,0 +1,20 @@ +#!/usr/bin/perl -w +use strict; +use warnings; +use Test::More 'no_plan'; +use autodie; + +use constant NO_SUCH_FILE => 'this_file_had_better_not_exist'; +use constant MAGIC_STRING => 'xyzzy'; + +# Opening an eval clears $@, so it's important that we set it +# inside the eval block to see if it's successfully captured. + +eval { + $@ = MAGIC_STRING; + is($@, MAGIC_STRING, 'Sanity check on start conditions'); + open(my $fh, '<', NO_SUCH_FILE); +}; + +isa_ok($@, 'autodie::exception'); +is($@->eval_error, MAGIC_STRING, 'Previous $@ should be captured'); diff --git a/cpan/autodie/t/flock.t b/cpan/autodie/t/flock.t index a7550bad6a..6421a56aac 100755 --- a/cpan/autodie/t/flock.t +++ b/cpan/autodie/t/flock.t @@ -2,7 +2,8 @@ use strict; use Test::More; use Fcntl qw(:flock); -use POSIX qw(EWOULDBLOCK); +use POSIX qw(EWOULDBLOCK EAGAIN); +use Config; require Fatal; @@ -10,6 +11,9 @@ my $EWOULDBLOCK = eval { EWOULDBLOCK() } || $Fatal::_EWOULDBLOCK{$^O} || plan skip_all => "EWOULDBLOCK not defined on this system"; +my $try_EAGAIN = ($^O eq 'linux' and $Config{archname} =~ /hppa|parisc/) ? 1 : 0; +my $EAGAIN = eval { EAGAIN() }; + my ($self_fh, $self_fh2); eval { @@ -55,7 +59,11 @@ eval { $return = flock($self_fh2, LOCK_EX | LOCK_NB); }; -is($!+0, $EWOULDBLOCK, "Double-flocking should be EWOULDBLOCK"); +if (!$try_EAGAIN) { + is($!+0, $EWOULDBLOCK, "Double-flocking should be EWOULDBLOCK"); +} else { + ok($!+0 == $EWOULDBLOCK || $!+0 == $EAGAIN, "Double-flocking should be EWOULDBLOCK or EAGAIN"); +} ok(!$return, "flocking a file twice should fail"); is($@, "", "Non-blocking flock should not fail on EWOULDBLOCK"); diff --git a/cpan/autodie/t/internal-backcompat.t b/cpan/autodie/t/internal-backcompat.t index 9f7196c3c5..59898366c0 100755 --- a/cpan/autodie/t/internal-backcompat.t +++ b/cpan/autodie/t/internal-backcompat.t @@ -33,7 +33,7 @@ no warnings 'qw'; # Technically the outputted code varies from the classical Fatal. # However the changes are mostly whitespace. Those that aren't are -# improvements to error messages. +# improvements to error messages or bug fixes. my @write_invocation_calls = ( [ @@ -43,9 +43,9 @@ my @write_invocation_calls = ( [ 3, qw($_[0] $_[1] @_[2..$#_])] ], q{ if (@_ == 1) { -return CORE::open($_[0]) || croak "Can't open(@_): $!" } elsif (@_ == 2) { -return CORE::open($_[0], $_[1]) || croak "Can't open(@_): $!" } elsif (@_ == 3) { -return CORE::open($_[0], $_[1], @_[2..$#_]) || croak "Can't open(@_): $!" +return CORE::open($_[0]) || Carp::croak("Can't open(@_): $!") } elsif (@_ == 2) { +return CORE::open($_[0], $_[1]) || Carp::croak("Can't open(@_): $!") } elsif (@_ >= 3) { +return CORE::open($_[0], $_[1], @_[2..$#_]) || Carp::croak("Can't open(@_): $!") } die "Internal error: open(@_): Do not expect to get ", scalar(@_), " arguments"; } @@ -62,12 +62,12 @@ my @one_invocation_calls = ( # Core # Call # Name # Void # Args [ [ 1, 'CORE::open', 'open', 0, qw($_[0] $_[1] @_[2..$#_]) ], - q{return CORE::open($_[0], $_[1], @_[2..$#_]) || croak "Can't open(@_): $!"}, + q{return CORE::open($_[0], $_[1], @_[2..$#_]) || Carp::croak("Can't open(@_): $!")}, ], [ [ 1, 'CORE::open', 'open', 1, qw($_[0] $_[1] @_[2..$#_]) ], q{return (defined wantarray)?CORE::open($_[0], $_[1], @_[2..$#_]): - CORE::open($_[0], $_[1], @_[2..$#_]) || croak "Can't open(@_): $!"}, + CORE::open($_[0], $_[1], @_[2..$#_]) || Carp::croak("Can't open(@_): $!")}, ], ); diff --git a/cpan/autodie/t/open.t b/cpan/autodie/t/open.t index 9964ba0350..359eb9a9f2 100755 --- a/cpan/autodie/t/open.t +++ b/cpan/autodie/t/open.t @@ -47,3 +47,32 @@ eval { isa_ok($@, 'autodie::exception'); like( $@, qr/at \S+ line \d+/, "At least one mention"); unlike($@, qr/at \S+ line \d+\s+at \S+ line \d+/, "...but not too mentions"); + +# RT 52427. Piped open can have any many args. + +# Sniff to see if we can run 'true' on this system. Changes we can't +# on non-Unix systems. + +eval { + use autodie; + + die "Windows does not support multi-arg pipe" if $^O eq "MSWin32"; + + open(my $fh, '-|', "true"); +}; + +SKIP: { + skip('true command or list pipe not available on this system', 1) if $@; + + eval { + use autodie; + + my $fh; + 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/version_tag.t b/cpan/autodie/t/version_tag.t index 7cb533329e..89e1412e47 100755 --- a/cpan/autodie/t/version_tag.t +++ b/cpan/autodie/t/version_tag.t @@ -1,7 +1,8 @@ #!/usr/bin/perl -w use strict; use warnings; -use Test::More tests => 3; +use Test::More tests => 5; +use constant NO_SUCH_FILE => 'THIS_FILE_HAD_BETTER_NOT_EXIST'; eval { use autodie qw(:1.994); @@ -11,7 +12,6 @@ eval { isa_ok($@, 'autodie::exception', "Basic version tags work"); - # Expanding :1.00 should fail, there was no autodie :1.00 eval { my $foo = autodie->_expand_tag(":1.00"); }; @@ -24,3 +24,21 @@ eval { my $foo = autodie->_expand_tag(":$version"); }; is($@,"","Expanding :$version should succeed"); +eval { + use autodie qw(:2.07); + + # 2.07 didn't support chmod. This shouldn't throw an + # exception. + + chmod(0644,NO_SUCH_FILE); +}; + +is($@,"","chmod wasn't supported in 2.07"); + +eval { + use autodie; + + chmod(0644,NO_SUCH_FILE); +}; + +isa_ok($@, 'autodie::exception', 'Our current version supports chmod'); |