diff options
26 files changed, 946 insertions, 165 deletions
@@ -42,8 +42,10 @@ cpan/autodie/lib/autodie/exception.pm Exception class for autodie cpan/autodie/lib/autodie/exception/system.pm Exception class for autodying system() cpan/autodie/lib/autodie/hints.pm Hinting interface for autodie cpan/autodie/lib/autodie.pm Functions succeed or die with lexical scope +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/autodie_skippy.pm cpan/autodie/t/autodie.t autodie - Basic functionality cpan/autodie/t/autodie_test_module.pm autodie - test helper cpan/autodie/t/backcompat.t autodie - More Fatal backcompat @@ -51,8 +53,11 @@ cpan/autodie/t/basic_exceptions.t autodie - Basic exception tests cpan/autodie/t/binmode.t autodie - Binmode testing cpan/autodie/t/blog_hints.t autodie - Tests fro PJF's blog cpan/autodie/t/caller.t autodie - Caller diagnostics +cpan/autodie/t/chmod.t +cpan/autodie/t/chown.t cpan/autodie/t/context_lexical.t autodie - Context clobbering lexically cpan/autodie/t/context.t autodie - Context clobbering tests +cpan/autodie/t/core-trampoline-slurp.t cpan/autodie/t/crickey.t autodie - Like an Australian cpan/autodie/t/dbmopen.t autodie - dbm tests cpan/autodie/t/eval_error.t @@ -72,6 +77,7 @@ cpan/autodie/t/hints_provider_isa.t autodie - Test hints/inheritance cpan/autodie/t/hints.t autodie - Test hints interface cpan/autodie/t/internal-backcompat.t autodie - Back-compatibility tests cpan/autodie/t/internal.t autodie - internal interface tests +cpan/autodie/t/kill.t cpan/autodie/t/lethal.t autodie - lethal is the one true name cpan/autodie/t/lib/autodie/test/au/exception.pm autodie - Australian helper cpan/autodie/t/lib/autodie/test/au.pm autodie - Australian helper @@ -90,17 +96,23 @@ cpan/autodie/t/lib/pujHa/ghach/Dotlh.pm autodie - With Klingon honour cpan/autodie/t/lib/pujHa/ghach.pm autodie - Like a Klingon cpan/autodie/t/lib/Some/Module.pm autodie - blog_hints.t helper cpan/autodie/t/mkdir.t autodie - filesystem tests +cpan/autodie/t/no_carp.t 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/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 cpan/autodie/t/string-eval-leak.t autodie - String eval leak test cpan/autodie/t/sysopen.t autodie - sysopen tests +cpan/autodie/t/touch_me +cpan/autodie/t/truncate_me cpan/autodie/t/truncate.t autodie - File truncation tests cpan/autodie/t/unlink.t autodie - Unlink system tests. cpan/autodie/t/user-context.t autodie - Context changes for usersubs cpan/autodie/t/usersub.t autodie - user subroutine tests +cpan/autodie/t/utf8_open.t +cpan/autodie/t/utime.t cpan/autodie/t/version.t autodie - versioning tests cpan/autodie/t/version_tag.t cpan/AutoLoader/lib/AutoLoader.pm Autoloader base class diff --git a/Porting/Maintainers.pl b/Porting/Maintainers.pl index a570de8432..27fcdc469e 100755 --- a/Porting/Maintainers.pl +++ b/Porting/Maintainers.pl @@ -223,22 +223,25 @@ use File::Glob qw(:case); 'autodie' => { 'MAINTAINER' => 'pjf', - 'DISTRIBUTION' => 'PJF/autodie-2.13.tar.gz', + 'DISTRIBUTION' => 'PJF/autodie-2.19.tar.gz', 'FILES' => q[cpan/autodie], 'EXCLUDED' => [ qr{^inc/Module/}, - + qr{benchmarks}, # All these tests depend upon external # modules that don't exist when we're # building the core. Hence, they can # never run, and should not be merged. qw( t/boilerplate.t + t/author-critic.t t/critic.t t/fork.t t/kwalitee.t t/lex58.t t/pod-coverage.t t/pod.t + t/release-pod-coverage.t + t/release-pod-syntax.t t/socket.t t/system.t ) diff --git a/Porting/exec-bit.txt b/Porting/exec-bit.txt index 0073e77cb6..8489dda0e0 100644 --- a/Porting/exec-bit.txt +++ b/Porting/exec-bit.txt @@ -10,6 +10,7 @@ cflags.SH configpm configure.gnu config_h.SH +cpan/autodie/t/chmod.t cpan/Test-Harness/t/source_tests/source.sh cpan/Test-Harness/t/source_tests/source_args.sh installperl diff --git a/cpan/autodie/lib/Fatal.pm b/cpan/autodie/lib/Fatal.pm index c6a3d1b329..8c6536b802 100644 --- a/cpan/autodie/lib/Fatal.pm +++ b/cpan/autodie/lib/Fatal.pm @@ -1,11 +1,14 @@ package Fatal; +# ABSTRACT: Replace functions with equivalents which succeed or die + use 5.008; # 5.8.x needed for autodie use Carp; use strict; use warnings; use Tie::RefHash; # To cache subroutine refs use Config; +use Scalar::Util qw(set_prototype); use constant PERL510 => ( $] >= 5.010 ); @@ -39,8 +42,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.13'; +our $VERSION = '2.19'; # VERSION: Generated by DZP::OurPkg::Version our $Debug ||= 0; @@ -65,10 +67,10 @@ my %TAGS = ( read seek sysread syswrite sysseek )], ':dbm' => [qw(dbmopen dbmclose)], ':file' => [qw(open close flock sysopen fcntl fileno binmode - ioctl truncate chmod)], + ioctl truncate)], ':filesys' => [qw(opendir closedir chdir link unlink rename mkdir - symlink rmdir readlink umask)], - ':ipc' => [qw(:msg :semaphore :shm pipe)], + symlink rmdir readlink umask chmod chown utime)], + ':ipc' => [qw(:msg :semaphore :shm pipe kill)], ':msg' => [qw(msgctl msgget msgrcv msgsnd)], ':threads' => [qw(fork)], ':semaphore'=>[qw(semctl semget semop)], @@ -89,10 +91,18 @@ 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 + # Everything in v2.07 and brefore. 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)], + 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)], # Version specific tags. These allow someone to specify # use autodie qw(:1.994) and know exactly what they'll get. @@ -113,15 +123,22 @@ my %TAGS = ( ':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)], - ':2.11' => [qw(:default)], - ':2.12' => [qw(:default)], - ':2.13' => [qw(:default)], + ':2.08' => [qw(:v213)], + ':2.09' => [qw(:v213)], + ':2.10' => [qw(:v213)], + ':2.11' => [qw(:v213)], + ':2.12' => [qw(:v213)], + ':2.13' => [qw(:v213)], + ':2.14' => [qw(:default)], + ':2.15' => [qw(:default)], + ':2.16' => [qw(:default)], + ':2.17' => [qw(:default)], + ':2.18' => [qw(:default)], + ':2.19' => [qw(:default)], ); # chmod was only introduced in 2.07 +# chown was only introduced in 2.14 $TAGS{':all'} = [ keys %TAGS ]; @@ -147,10 +164,17 @@ my %Use_defined_or; 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. -# A snippet of code to apply the open pragma to a handle - - +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. @@ -199,6 +223,45 @@ my %Retval_action = ( }, ); +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 +)} = (); + # 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 @@ -226,6 +289,11 @@ my %Original_user_sub = (); 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; + # 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. @@ -278,7 +346,7 @@ sub import { # Thiese subs will get unloaded at the end of lexical scope. my %unload_later; - # This hash helps us track if we've alredy done work. + # This hash helps us track if we've already done work. my %done_this; # NB: we're using while/shift rather than foreach, since @@ -702,7 +770,7 @@ sub _one_invocation { # $call if the function is CORE # $sub if our function is non-CORE - # The reason for this is that $call is what we're actualling + # The reason for this is that $call is what we're actually # calling. For our core functions, this is always # CORE::something. However for user-defined subs, we're about to # replace whatever it is that we're calling; as such, we actually @@ -753,7 +821,7 @@ sub _one_invocation { # We need to stash $@ into $E, rather than using # local $@ for the whole sub. If we don't then # any exceptions from internal errors in autodie/Fatal - # will mysteriously disappear before propogating + # will mysteriously disappear before propagating # upwards. return qq{ @@ -849,6 +917,30 @@ sub _one_invocation { }; } + 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 @@ -1088,7 +1180,7 @@ sub _make_fatal { } elsif ($name eq 'exec') { # Exec doesn't have a prototype. We don't care. This # breaks the exotic form with lexical scope, and gives - # the regular form a "do or die" beaviour as expected. + # the regular form a "do or die" behavior as expected. $call = 'CORE::exec'; $name = 'exec'; @@ -1107,6 +1199,7 @@ sub _make_fatal { $call = "CORE::$name"; } + if (defined $proto) { $real_proto = " ($proto)"; } else { @@ -1131,43 +1224,70 @@ sub _make_fatal { return $sref; } - $code = qq[ - sub$real_proto { - local(\$", \$!) = (', ', 0); # TODO - Why do we do this? - ]; - - # Don't have perl whine if exec fails, since we'll be handling - # the exception now. - $code .= "no warnings qw(exec);\n" if $call eq "CORE::exec"; + # If our subroutine is reusable (ie, not package depdendent), + # then check to see if we've got a cached copy, and use that. + # See RT #46984. (Thanks to Niels Thykier for being awesome!) + + if ($core && exists $reusable_builtins{$call}) { + # For non-lexical subs, we can just use this cache directly + # - for lexical variants, we need a leak guard as well. + $code = $reusable_builtins{$call}{$lexical}; + if (!$lexical && defined($code)) { + $class->_install_subs($pkg, { $name => $code }); + return $sref; + } + } my @protos = fill_protos($proto); - $code .= $class->_write_invocation($core, $call, $name, $void, $lexical, $sub, $sref, @protos); - $code .= "}\n"; - warn $code if $Debug; - - # I thought that changing package was a monumental waste of - # time for CORE subs, since they'll always be the same. However - # that's not the case, since they may refer to package-based - # filehandles (eg, with open). - # - # There is potential to more aggressively cache core subs - # that we know will never want to interact with package variables - # and filehandles. - { - no strict 'refs'; ## no critic # to avoid: Can't use string (...) as a symbol ref ... + if (!defined($code)) { + # No code available, generate it now. - my $E; + $code = qq[ + sub$real_proto { + local(\$", \$!) = (', ', 0); # TODO - Why do we do this? + ]; + + # Don't have perl whine if exec fails, since we'll be handling + # the exception now. + $code .= "no warnings qw(exec);\n" if $call eq "CORE::exec"; + + $code .= $class->_write_invocation($core, $call, $name, $void, $lexical, + $sub, $sref, @protos); + $code .= "}\n"; + warn $code if $Debug; + + # I thought that changing package was a monumental waste of + # time for CORE subs, since they'll always be the same. However + # that's not the case, since they may refer to package-based + # filehandles (eg, with open). + # + # The %reusable_builtins hash defines ones we can aggressively + # cache as they never depend upon package-based symbols. { - local $@; - $code = eval("package $pkg; require Carp; $code"); ## no critic - $E = $@; - } + no strict 'refs'; ## no critic # to avoid: Can't use string (...) as a symbol ref ... + + my $E; - if (not $code) { - croak("Internal error in autodie/Fatal processing $true_name: $E"); + { + local $@; + if (!exists($reusable_builtins{$call})) { + $code = eval("package $pkg; require Carp; $code"); ## no critic + } else { + $code = eval("require Carp; $code"); ## no critic + if (exists $reusable_builtins{$call}) { + # cache it so we don't recompile this part again + $reusable_builtins{$call}{$lexical} = $code; + } + } + $E = $@; + } + if (not $code) { + croak("Internal error in autodie/Fatal processing $true_name: $E"); + + } } } @@ -1185,74 +1305,20 @@ sub _make_fatal { my $leak_guard; if ($lexical) { + # Do a little dance because set_prototype does not accept code + # refs (i.e. "my $s = sub {}; set_prototype($s, '$$);" fails) + if ($real_proto ne '') { + $leak_guard = set_prototype(sub { + unshift @_, [$filename, $code, $sref, $call, \@protos, $pkg]; + goto \&_leak_guard; + }, $proto); - $leak_guard = qq< - package $pkg; - - sub$real_proto { - - # If we're inside a string eval, we can end up with a - # whacky filename. The following code allows autodie - # to propagate correctly into string evals. - - my \$caller_level = 0; - - my \$caller; - - while ( (\$caller = (caller \$caller_level)[1]) =~ m{^\\(eval \\d+\\)\$} ) { - - # If our filename is actually an eval, and we - # reach it, then go to our autodying code immediatately. - - goto &\$code if (\$caller eq \$filename); - \$caller_level++; - } - - # We're now out of the eval stack. - - # If we're called from the correct file, then use the - # autodying code. - goto &\$code if ((caller \$caller_level)[1] eq \$filename); - - # Oh bother, we've leaked into another file. Call the - # original code. Note that \$sref may actually be a - # reference to a Fatalised version of a core built-in. - # That's okay, because Fatal *always* leaks between files. - - goto &\$sref if \$sref; - >; - - - # If we're here, it must have been a core subroutine called. - # Warning: The following code may disturb some viewers. - - # TODO: It should be possible to combine this with - # write_invocation(). - - foreach my $proto (@protos) { - local $" = ", "; # So @args is formatted correctly. - my ($count, @args) = @$proto; - $leak_guard .= qq< - if (\@_ == $count) { - return $call(@args); - } - >; - } - - $leak_guard .= qq< Carp::croak("Internal error in Fatal/autodie. Leak-guard failure"); } >; - - # warn "$leak_guard\n"; - - my $E; - { - local $@; - - $leak_guard = eval $leak_guard; ## no critic - - $E = $@; + } else { + $leak_guard = sub { + unshift @_, [$filename, $code, $sref, $call, \@protos, $pkg]; + goto \&_leak_guard; + }; } - - die "Internal error in $class: Leak-guard installation failure: $E" if $E; } my $installed_sub = $leak_guard || $code; @@ -1261,7 +1327,7 @@ sub _make_fatal { $Cached_fatalised_sub{$class}{$sub}{$void}{$lexical} = $installed_sub; - # Cache that we've now overriddent this sub. If we get called + # Cache that we've now overridden this sub. If we get called # again, we may need to find that find subroutine again (eg, for hints). $Is_fatalised_sub{$installed_sub} = $sref; @@ -1320,10 +1386,108 @@ sub exception_class { return "autodie::exception" }; } } +sub _leak_guard { + my $call_data = shift; + my ($filename, $wrapped_sub, $orig_sub, $call, $protos, $pkg) = @{$call_data}; + my $caller_level = 0; + my $caller; + my $leaked = 0; + + # NB: if we are wrapping a CORE sub, $orig_sub will be undef. + + while ( ($caller = (caller $caller_level)[1]) =~ m{^\(eval \d+\)$} ) { + + # If our filename is actually an eval, and we + # reach it, then go to our autodying code immediatately. + + last if ($caller eq $filename); + $caller_level++; + } + # We're now out of the eval stack. + + if ($caller ne $filename) { + # Oh bother, we've leaked into another file. + $leaked = 1; + } + + if (defined($orig_sub)) { + # User sub. + goto $wrapped_sub unless $leaked; + goto $orig_sub; + } + + # Core sub + if ($leaked) { + # If we're here, it must have been a core subroutine called. + + # If we've cached a trampoline, then use it. + my $trampoline_sub = $Trampoline_cache{$pkg}{$call}; + + if (not $trampoline_sub) { + # If we don't have a trampoline, we need to build it. + + # We need to build a 'trampoline'. Essentially, a tiny sub that figures + # out how we should be calling our core sub, puts in the arguments + # in the right way, and bounces our control over to it. + # + # If we could use `goto &` on core builtins, we wouldn't need this. + # + # We only generate trampolines when we need them, and we can cache + # them by subroutine + package. + + # TODO: Consider caching on reusable_builtins status as well. + # (In which case we can also remove the package line in the eval + # later in this block.) + + # TODO: It may be possible to combine this with write_invocation(). + + my $trampoline_code = 'sub {'; + + foreach my $proto (@{$protos}) { + local $" = ", "; # So @args is formatted correctly. + my ($count, @args) = @$proto; + if ($args[-1] =~ m/[@#]_/) { + $trampoline_code .= qq/ + if (\@_ >= $count) { + return $call(@args); + } + /; + } else { + $trampoline_code .= qq< + if (\@_ == $count) { + return $call(@args); + } + >; + } + } + + $trampoline_code .= qq< Carp::croak("Internal error in Fatal/autodie. Leak-guard failure"); } >; + my $E; + + { + local $@; + $trampoline_sub = eval "package $pkg;\n $trampoline_code"; ## no critic + $E = $@; + } + die "Internal error in Fatal/autodie: Leak-guard installation failure: $E" + if $E; + + # Phew! Let's cache that, so we don't have to do it again. + $Trampoline_cache{$pkg}{$call} = $trampoline_sub; + } + + # Bounce to our trampoline, which takes us to our core sub. + goto \&$trampoline_sub; + } + + # No leak, do a regular goto. + goto $wrapped_sub; +} + # For some reason, dying while replacing our subs doesn't # kill our calling program. It simply stops the loading of # autodie and keeps going with everything else. The _autocroak -# sub allows us to die with a vegence. It should *only* ever be +# sub allows us to die with a vengeance. It should *only* ever be # used for serious internal errors, since the results of it can't # be captured. @@ -1481,4 +1645,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 + =cut diff --git a/cpan/autodie/lib/autodie.pm b/cpan/autodie/lib/autodie.pm index 71a6a5e761..6416d2cbb7 100644 --- a/cpan/autodie/lib/autodie.pm +++ b/cpan/autodie/lib/autodie.pm @@ -7,8 +7,10 @@ use Fatal (); our @ISA = qw(Fatal); our $VERSION; +# ABSTRACT: Replace functions with ones that succeed or die with lexical scope + BEGIN { - $VERSION = '2.13'; + our $VERSION = '2.19'; # VERSION: Generated by DZP::OurPkg::Version } use constant ERROR_WRONG_FATAL => q{ @@ -185,6 +187,8 @@ The categories are currently: :file binmode close + chmod + chown fcntl fileno flock @@ -251,7 +255,7 @@ The syntax: allows the C<:default> list from a particular version to be used. This provides the convenience of using the default methods, but the surety -that no behavorial changes will occur if the C<autodie> module is +that no behavioral changes will occur if the C<autodie> module is upgraded. C<autodie> can be enabled for all of Perl's built-ins, including @@ -423,6 +427,6 @@ Mark Reed and Roland Giersig -- Klingon translators. See the F<AUTHORS> file for full credits. The latest version of this file can be found at -L<http://github.com/pfenwick/autodie/tree/master/AUTHORS> . +L<http://github.com/pjf/autodie/tree/master/AUTHORS> . =cut diff --git a/cpan/autodie/lib/autodie/exception.pm b/cpan/autodie/lib/autodie/exception.pm index 45c723d56a..ffdd4c804f 100644 --- a/cpan/autodie/lib/autodie/exception.pm +++ b/cpan/autodie/lib/autodie/exception.pm @@ -4,6 +4,9 @@ use strict; use warnings; use Carp qw(croak); +our $VERSION = '2.19'; # VERSION: Generated by DZP::OurPkg:Version +# ABSTRACT: Exceptions from autodying functions. + our $DEBUG = 0; use overload @@ -14,8 +17,6 @@ use overload use if ($] >= 5.010), overload => '~~' => "matches"; -our $VERSION = '2.13'; - my $PACKAGE = __PACKAGE__; # Useful to have a scalar for hash keys. =head1 NAME @@ -131,12 +132,21 @@ sub line { return $_[0]->{$PACKAGE}{line}; } my $context = $E->context; -The context in which the subroutine was called. This can be -'list', 'scalar', or undefined (unknown). It will never be 'void', as -C<autodie> always captures the return value in one way or another. +The context in which the subroutine was called by autodie; usually +the same as the context in which you called the autodying subroutine. +This can be 'list', 'scalar', or undefined (unknown). It will never +be 'void', as C<autodie> always captures the return value in one way +or another. + +For some core functions that always return a scalar value regardless +of their context (eg, C<chown>), this may be 'scalar', even if you +used a list context. =cut +# TODO: The comments above say this can be undefined. Is that actually +# the case? (With 'system', perhaps?) + sub context { return $_[0]->{$PACKAGE}{context} } =head3 return @@ -210,7 +220,7 @@ For a string that does start with a colon, if the subroutine throwing the exception I<does> that behaviour. For example, the C<CORE::open> subroutine does C<:file>, C<:io> and C<:all>. -See L<autodie/CATEGORIES> for futher information. +See L<autodie/CATEGORIES> for further information. =back @@ -444,7 +454,7 @@ sub _format_open { } } - # Localising $! means perl make make it a pretty error for us. + # Localising $! means perl makes it a pretty error for us. local $! = $this->errno; return $this->_format_open_with_mode($mode, $file, $!); @@ -672,6 +682,12 @@ sub _init { next if $package->isa('Fatal'); next if $package->isa($class); next if $package->isa(__PACKAGE__); + + # Anything with the 'autodie::skip' role wants us to skip it. + # https://github.com/pjf/autodie/issues/15 + + next if ($package->can('DOES') and $package->DOES('autodie::skip')); + next if $file =~ /^\(eval\s\d+\)$/; last; diff --git a/cpan/autodie/lib/autodie/exception/system.pm b/cpan/autodie/lib/autodie/exception/system.pm index 0489b61d11..137bff1654 100644 --- a/cpan/autodie/lib/autodie/exception/system.pm +++ b/cpan/autodie/lib/autodie/exception/system.pm @@ -5,7 +5,9 @@ use warnings; use base 'autodie::exception'; use Carp qw(croak); -our $VERSION = '2.13'; +our $VERSION = '2.19'; # VERSION: Generated by DZP::OurPkg:Version + +# ABSTRACT: Exceptions from autodying system(). my $PACKAGE = __PACKAGE__; diff --git a/cpan/autodie/lib/autodie/hints.pm b/cpan/autodie/lib/autodie/hints.pm index 36715e979d..350738e18a 100644 --- a/cpan/autodie/lib/autodie/hints.pm +++ b/cpan/autodie/lib/autodie/hints.pm @@ -5,7 +5,9 @@ use warnings; use constant PERL58 => ( $] < 5.009 ); -our $VERSION = '2.13'; +our $VERSION = '2.19'; # VERSION: Generated by DZP::OurPkg:Version + +# ABSTRACT: Provide hints about user subroutines to autodie =head1 NAME @@ -595,4 +597,6 @@ same terms as Perl itself. L<autodie>, L<Class::DOES> +=for Pod::Coverage get_hints_for load_hints normalise_hints sub_fullname + =cut diff --git a/cpan/autodie/lib/autodie/skip.pm b/cpan/autodie/lib/autodie/skip.pm new file mode 100644 index 0000000000..a9bac8300c --- /dev/null +++ b/cpan/autodie/lib/autodie/skip.pm @@ -0,0 +1,54 @@ +package autodie::skip; +use strict; +use warnings; + +our $VERSION = '2.19'; # 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 +# how people will use them anyway. + +if ($] < 5.010) { + # Older Perls don't have a native ->DOES. Let's provide a cheap + # imitation here. + + *DOES = sub { return shift->isa(@_); }; +} + +1; + +__END__ + +=head1 NAME + +autodie::skip - Skip a package when throwing autodie exceptions + +=head1 SYNPOSIS + + use parent qw(autodie::skip); + +=head1 DESCRIPTION + +This dummy class exists to signal that the class inheriting it should +be skipped when reporting exceptions from autodie. This is useful +for utility classes like L<Path::Tiny> that wish to report the location +of where they were called on failure. + +If your class has a better way of doing roles, then you should not +load this class and instead simply say that your class I<DOES> +C<autodie::skip> instead. + +=head1 AUTHOR + +Copyright 2013, Paul Fenwick <pjf@cpan.org> + +=head1 LICENSE + +This module is free software. You may distribute it under the same +terms as Perl itself. + +=head1 SEE ALSO + +L<autodie>, L<autodie::exception> + +=cut diff --git a/cpan/autodie/t/autodie_skippy.pm b/cpan/autodie/t/autodie_skippy.pm new file mode 100644 index 0000000000..3baa9b571e --- /dev/null +++ b/cpan/autodie/t/autodie_skippy.pm @@ -0,0 +1,22 @@ +package autodie_skippy; +use strict; +use warnings; +use autodie; +use base qw(autodie::skip); + +# This should skip upwards to the caller. + +sub fail_open { + open(my $fh, '<', 'this_file_had_better_not_exist'); +} + +package autodie_unskippy; +use autodie; + +# This should not skip upwards. + +sub fail_open { + open(my $fh, '<', 'this_file_had_better_not_exist'); +} + +1; diff --git a/cpan/autodie/t/autodie_test_module.pm b/cpan/autodie/t/autodie_test_module.pm index e8e824c522..f2c1405e37 100644 --- a/cpan/autodie/t/autodie_test_module.pm +++ b/cpan/autodie/t/autodie_test_module.pm @@ -2,12 +2,30 @@ package main; use strict; use warnings; +use constant NOFILE1 => 'this_file_had_better_not_exist'; +use constant NOFILE2 => NOFILE1 . '2'; +use constant NOFILE3 => NOFILE1 . '3'; + # Calls open, while still in the main package. This shouldn't # be autodying. sub leak_test { return open(my $fh, '<', $_[0]); } +# This rename shouldn't be autodying, either. +sub leak_test_rename { + return rename($_[0], $_[1]); +} + +# These are used by core-trampoline-slurp.t +sub slurp_leak_unlink { + unlink(NOFILE1, NOFILE2, NOFILE3); +} + +sub slurp_leak_open { + open(1,2,3,4,5); +} + package autodie_test_module; # This should be calling CORE::open @@ -15,4 +33,14 @@ sub your_open { return open(my $fh, '<', $_[0]); } +# This should be calling CORE::rename +sub your_rename { + return rename($_[0], $_[1]); +} + +sub your_dying_rename { + use autodie qw(rename); + return rename($_[0], $_[1]); +} + 1; diff --git a/cpan/autodie/t/chmod.t b/cpan/autodie/t/chmod.t new file mode 100755 index 0000000000..9093b52c4f --- /dev/null +++ b/cpan/autodie/t/chmod.t @@ -0,0 +1,17 @@ +#!/usr/bin/perl -w +use strict; +use Test::More tests => 4; +use constant NO_SUCH_FILE => "this_file_had_better_not_exist"; +use autodie; + +# This tests RT #50423, Debian #550462 + +eval { chmod(0755, NO_SUCH_FILE); }; +isa_ok($@, 'autodie::exception', 'exception thrown for chmod'); + +eval { chmod(0755, $0); }; +ok(! $@, "We can chmod ourselves just fine."); + +eval { chmod(0755, $0, NO_SUCH_FILE) }; +isa_ok($@, 'autodie::exception', 'chmod exception on any file failure.'); +is($@->return,1,"Confirm autodie on a 'true' chown failure."); diff --git a/cpan/autodie/t/chown.t b/cpan/autodie/t/chown.t new file mode 100644 index 0000000000..90c4d3bf76 --- /dev/null +++ b/cpan/autodie/t/chown.t @@ -0,0 +1,28 @@ +#!/usr/bin/perl -w +use strict; +use Test::More; +use constant NO_SUCH_FILE => "this_file_had_better_not_exist"; +use autodie; + +if ($^O eq 'MSWin32') { + plan skip_all => 'chown() seems to always succeed on Windows'; +} + +plan tests => 4; + +eval { + chown(1234, 1234, NO_SUCH_FILE); +}; + +isa_ok($@, 'autodie::exception', 'exception thrown for chown'); + +# Chown returns the number of files that we chowned. So really we +# should die if the return value is not equal to the number of arguments +# minus two. + +eval { chown($<, -1, $0); }; +ok(! $@, "Can chown ourselves just fine."); + +eval { chown($<, -1, $0, NO_SUCH_FILE); }; +isa_ok($@, 'autodie::exception', "Exception if ANY file changemode fails"); +is($@->return, 1, "Confirm we're dying on a 'true' chown failure."); diff --git a/cpan/autodie/t/core-trampoline-slurp.t b/cpan/autodie/t/core-trampoline-slurp.t new file mode 100644 index 0000000000..b9450bf7f8 --- /dev/null +++ b/cpan/autodie/t/core-trampoline-slurp.t @@ -0,0 +1,24 @@ +#!/usr/bin/perl +use strict; +use warnings; +use Test::More tests => 3; + +# Tests for GH #22 +# +# Slurpy calls (like open, unlink, chown, etc) could not be +# interpreted properly if they leak into another file which +# doesn't have autodie enabled. + +use autodie; +use FindBin qw($Bin); +use lib $Bin; +use autodie_test_module; + +# This will throw an error, but it shouldn't throw a leak-guard +# failure. +eval { slurp_leak_open(); }; +unlike($@,qr/Leak-guard failure/, "Leak guard failure (open)"); + +eval { slurp_leak_unlink(); }; +is($@,"","No error should be thrown by leaked guards (unlink)"); +unlike($@,qr/Leak-guard failure/, "Leak guard failure (unlink)"); diff --git a/cpan/autodie/t/kill.t b/cpan/autodie/t/kill.t new file mode 100644 index 0000000000..22d4b36c82 --- /dev/null +++ b/cpan/autodie/t/kill.t @@ -0,0 +1,26 @@ +#!/usr/bin/perl -w +use strict; +use Test::More; +use autodie; + +use constant SYSINIT => 1; + +if (not CORE::kill(0,$$)) { + plan skip_all => "Can't send signals to own process on this system."; +} + +if (CORE::kill(0, SYSINIT)) { + plan skip_all => "Can unexpectedly signal process 1. Won't run as root."; +} + +plan tests => 4; + +eval { kill(0, $$); }; +is($@, '', "Signalling self is fine"); + +eval { kill(0, SYSINIT ) }; +isa_ok($@, 'autodie::exception', "Signalling init is not allowed."); + +eval { kill(0, $$, SYSINIT) }; +isa_ok($@, 'autodie::exception', 'kill exception on single failure.'); +is($@->return, 1, "kill fails correctly on a 'true' failure."); diff --git a/cpan/autodie/t/no_carp.t b/cpan/autodie/t/no_carp.t new file mode 100644 index 0000000000..1ac0615434 --- /dev/null +++ b/cpan/autodie/t/no_carp.t @@ -0,0 +1,12 @@ +#!/usr/bin/perl -w + +# Test that autodie doesn't pollute the caller with carp and croak. + +use strict; + +use Test::More tests => 2; + +use autodie; + +ok !defined &main::carp; +ok !defined &main::croak; diff --git a/cpan/autodie/t/open.t b/cpan/autodie/t/open.t index 67f6f0cf55..d11dda5772 100644 --- a/cpan/autodie/t/open.t +++ b/cpan/autodie/t/open.t @@ -76,3 +76,16 @@ SKIP: { is $@, '', "multi arg piped open does not fail"; } + +# Github 6 +# Non-vanilla modes (such as <:utf8) would cause the formatter in +# autodie::exception to fail. + +eval { + use autodie; + open(my $fh, '<:utf8', NO_SUCH_FILE); +}; + +ok( $@, "Error thrown."); +unlike($@, qr/Don't know how to format mode/, "No error on exotic open."); +like( $@, qr/Can't open .*? with mode '<:utf8'/, "Nicer looking error."); diff --git a/cpan/autodie/t/scope_leak.t b/cpan/autodie/t/scope_leak.t index 529daa3ecd..c97b82f2df 100644 --- a/cpan/autodie/t/scope_leak.t +++ b/cpan/autodie/t/scope_leak.t @@ -9,14 +9,15 @@ use lib $FindBin::Bin; use Test::More 'no_plan'; -use constant NO_SUCH_FILE => 'this_file_had_better_not_exist'; -use autodie qw(open); +use constant NO_SUCH_FILE => 'this_file_had_better_not_exist'; +use constant NO_SUCH_FILE2 => 'this_file_had_better_not_exist_either'; +use autodie qw(open rename); -eval { - open(my $fh, '<', NO_SUCH_FILE); -}; +eval { open(my $fh, '<', NO_SUCH_FILE); }; +ok($@, "basic autodie test - open"); -ok($@, "basic autodie test"); +eval { rename(NO_SUCH_FILE, NO_SUCH_FILE2); }; +ok($@, "basic autodie test - rename"); use autodie_test_module; @@ -24,18 +25,26 @@ use autodie_test_module; # just loaded will still have an autodying main::open (although # its own open should be unaffected). -eval { - leak_test(NO_SUCH_FILE); -}; - +eval { leak_test(NO_SUCH_FILE); }; is($@,"","autodying main::open should not leak to other files"); -eval { - autodie_test_module::your_open(NO_SUCH_FILE); -}; - +eval { autodie_test_module::your_open(NO_SUCH_FILE); }; is($@,"","Other package open should be unaffected"); +# The same should apply for rename (which is different, because +# it doesn't depend upon packages, and could be cached more +# aggressively.) + +eval { leak_test_rename(NO_SUCH_FILE, NO_SUCH_FILE2); }; +is($@,"","autodying main::rename should not leak to other files"); + +eval { autodie_test_module::your_rename(NO_SUCH_FILE, NO_SUCH_FILE2); }; +is($@,"","Other package rename should be unaffected"); + +# Dying rename in the other package should still die. +eval { autodie_test_module::your_dying_rename(NO_SUCH_FILE, NO_SUCH_FILE2); }; +ok($@, "rename in loaded module should remain autodying."); + # Due to odd filenames reported when doing string evals, # older versions of autodie would not propogate into string evals. diff --git a/cpan/autodie/t/skip.t b/cpan/autodie/t/skip.t new file mode 100644 index 0000000000..724cd659aa --- /dev/null +++ b/cpan/autodie/t/skip.t @@ -0,0 +1,19 @@ +#!/usr/bin/perl +use strict; +use warnings; +use Test::More tests => 6; +use FindBin qw($Bin); +use lib $Bin; +use autodie_skippy; + +eval { autodie_skippy->fail_open() }; + +ok($@, "autodie_skippy throws exceptions."); +isa_ok($@, 'autodie::exception', 'Autodie exceptions correct class'); +is($@->package, 'main', 'Skippy classes are skipped.'); + +eval { autodie_unskippy->fail_open() }; + +ok($@, "autodie_skippy throws exceptions."); +isa_ok($@, 'autodie::exception', 'Autodie exceptions correct class'); +is($@->package, 'autodie_unskippy','Unskippy classes are not skipped.'); diff --git a/cpan/autodie/t/touch_me b/cpan/autodie/t/touch_me new file mode 100644 index 0000000000..6b0f32e913 --- /dev/null +++ b/cpan/autodie/t/touch_me @@ -0,0 +1,2 @@ +For testing utime. +Contents of this file are irrelevant. diff --git a/cpan/autodie/t/truncate.t b/cpan/autodie/t/truncate.t index e69ee32d2e..2472139a1a 100644 --- a/cpan/autodie/t/truncate.t +++ b/cpan/autodie/t/truncate.t @@ -4,9 +4,20 @@ use strict; use Test::More; use File::Temp qw(tempfile); use IO::Handle; +use File::Spec; +use FindBin qw($Bin); +use constant TRUNCATE_ME => File::Spec->catfile($Bin,'truncate_me'); -my $tmpfh = tempfile(); -my $truncate_status; +my ($truncate_status, $tmpfh); + +# Some systems have a screwy tempfile. We don't run our tests there. +eval { + $tmpfh = tempfile(); +}; + +if ($@ or !defined $tmpfh) { + plan skip_all => 'tempfile() not happy on this system.'; +} eval { $truncate_status = truncate($tmpfh, 0); @@ -16,7 +27,7 @@ if ($@ || !defined($truncate_status)) { plan skip_all => 'Truncate not implemented or not working on this system'; } -plan tests => 3; +plan tests => 12; SKIP: { my $can_truncate_stdout = truncate(\*STDOUT,0); @@ -51,3 +62,96 @@ eval { }; is($@, "", "Truncating a normal file should be fine"); + +# Time to test truncating via globs. + +# Firstly, truncating a closed filehandle should fail. +# I know we tested this above, but we'll do a full dance of +# opening and closing TRUNCATE_FH here. + +eval { + use autodie qw(truncate); + truncate(\*TRUNCATE_FH, 0); +}; + +isa_ok($@, 'autodie::exception', "Truncating unopened file (TRUNCATE_FH)"); + +# Now open the file. If this throws an exception, there's something +# wrong with our tests, or autodie... +{ + use autodie qw(open); + open(TRUNCATE_FH, '+<', TRUNCATE_ME); +} + +# Now try truncating the filehandle. This should succeed. + +eval { + use autodie qw(truncate); + truncate(\*TRUNCATE_FH,0); +}; + +is($@, "", 'Truncating an opened glob (\*TRUNCATE_FH)'); + +eval { + use autodie qw(truncate); + truncate(*TRUNCATE_FH,0); +}; + +is($@, "", 'Truncating an opened glob (*TRUNCATE_FH)'); + +# Now let's change packages, since globs are package dependent + +eval { + package Fatal::Test; + no warnings 'once'; + use autodie qw(truncate); + truncate(\*TRUNCATE_FH,0); # Should die, as now unopened +}; + +isa_ok($@, 'autodie::exception', 'Truncating unopened file in different package (\*TRUNCATE_FH)'); + +eval { + package Fatal::Test; + no warnings 'once'; + use autodie qw(truncate); + truncate(*TRUNCATE_FH,0); # Should die, as now unopened +}; + +isa_ok($@, 'autodie::exception', 'Truncating unopened file in different package (*TRUNCATE_FH)'); + +# Now back to our previous test, just to make sure it hasn't changed +# the original file. + +eval { + use autodie qw(truncate); + truncate(\*TRUNCATE_FH,0); +}; + +is($@, "", 'Truncating an opened glob #2 (\*TRUNCATE_FH)'); + +eval { + use autodie qw(truncate); + truncate(*TRUNCATE_FH,0); +}; + +is($@, "", 'Truncating an opened glob #2 (*TRUNCATE_FH)'); + +# Now to close the file and retry. +{ + use autodie qw(close); + close(TRUNCATE_FH); +} + +eval { + use autodie qw(truncate); + truncate(\*TRUNCATE_FH,0); +}; + +isa_ok($@, 'autodie::exception', 'Truncating freshly closed glob (\*TRUNCATE_FH)'); + +eval { + use autodie qw(truncate); + truncate(*TRUNCATE_FH,0); +}; + +isa_ok($@, 'autodie::exception', 'Truncating freshly closed glob (*TRUNCATE_FH)'); diff --git a/cpan/autodie/t/truncate_me b/cpan/autodie/t/truncate_me new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/cpan/autodie/t/truncate_me diff --git a/cpan/autodie/t/unlink.t b/cpan/autodie/t/unlink.t index f301500fda..c9d5168e64 100644 --- a/cpan/autodie/t/unlink.t +++ b/cpan/autodie/t/unlink.t @@ -2,13 +2,10 @@ use strict; use Test::More; use FindBin qw($Bin); -use constant TMPFILE => "$Bin/unlink_test_delete_me"; +use constant TMPFILE => "$Bin/unlink_test_delete_me"; +use constant NO_SUCH_FILE => 'this_file_had_better_not_be_here_at_all'; -# Create a file to practice unlinking -open(my $fh, ">", TMPFILE) - or plan skip_all => "Unable to create test file: $!"; -print {$fh} "Test\n"; -close $fh; +make_file(TMPFILE); # Check that file now exists -e TMPFILE or plan skip_all => "Failed to create test file"; @@ -20,17 +17,14 @@ unlink TMPFILE; if(-e TMPFILE) {plan skip_all => "Failed to delete test file: $!";} # Re-create file -open(my $fh2, ">", TMPFILE) - or plan skip_all => "Unable to create test file: $!"; -print {$fh2} "Test\n"; -close $fh2; +make_file(TMPFILE); # Check that file now exists -e TMPFILE or plan skip_all => "Failed to create test file"; -plan tests => 6; +plan tests => 10; -# Try to delete directory (this should succeed) +# Try to delete file (this should succeed) eval { use autodie; @@ -50,3 +44,25 @@ isa_ok($@, "autodie::exception", "... errors are of the correct type"); ok($@->matches("unlink"), "... it's also a unlink object"); ok($@->matches(":filesys"), "... and a filesys object"); +# Autodie should throw if we delete a LIST of files, but can only +# delete some of them. + +make_file(TMPFILE); +ok(-e TMPFILE, "Sanity: file exists"); + +eval { + use autodie; + + unlink TMPFILE, NO_SUCH_FILE; +}; + +ok($@, "Failure when trying to delete missing file in list."); +isa_ok($@, "autodie::exception", "... errors are of the correct type"); +is($@->return,1, "Failure on deleting missing file but true return value"); + +sub make_file { + open(my $fh, ">", $_[0]) + or plan skip_all => "Unable to create test file $_[0]: $!"; + print {$fh} "Test\n"; + close $fh; +} diff --git a/cpan/autodie/t/utf8_open.t b/cpan/autodie/t/utf8_open.t new file mode 100644 index 0000000000..1cc2df00cb --- /dev/null +++ b/cpan/autodie/t/utf8_open.t @@ -0,0 +1,127 @@ +#!/usr/bin/perl -w + +# Test that open still honors the open pragma. + +use strict; +use warnings; + +use autodie; + +use Fcntl; +use File::Temp; + +use Test::More; + +if( $] < '5.01000' ) { + plan skip_all => "autodie does not honor the open pragma before 5.10"; +} +else { + plan "no_plan"; +} + +# Test with an open pragma on +{ + use open IN => ':encoding(utf8)', OUT => ':utf8'; + + # Test the standard handles and all newly opened handles are utf8 + my $file = File::Temp->new; + my $txt = "autodie is MËTÁŁ"; + + # open for writing + { + open my $fh, ">", $file; + + my @layers = PerlIO::get_layers($fh); + ok( (grep { $_ eq 'utf8' } @layers), "open write honors open pragma" ) or diag join ", ", @layers; + + print $fh $txt; + close $fh; + } + + # open for reading, explicit + { + open my $fh, "<", $file; + + my @layers = PerlIO::get_layers($fh); + ok( (grep { $_ eq 'encoding(utf8)' } @layers), "open read honors open pragma" ) or diag join ", ", @layers; + + is join("\n", <$fh>), $txt; + } + + # open for reading, implicit + { + open my($fh), $file; + + my @layers = PerlIO::get_layers($fh); + ok( (grep { $_ eq 'encoding(utf8)' } @layers), "open implicit read honors open pragma" ) or diag join ", ", @layers; + + is join("\n", <$fh>), $txt; + } + + # open for read/write + { + open my $fh, "+>", $file; + + my @layers = PerlIO::get_layers($fh); + ok( (grep { $_ eq 'utf8' } @layers), "open implicit read honors open pragma" ) or diag join ", ", @layers; + } + + # open for append + { + open my $fh, ">>", $file; + + my @layers = PerlIO::get_layers($fh); + ok( (grep { $_ eq 'utf8' } @layers), "open implicit read honors open pragma" ) or diag join ", ", @layers; + } +} + + +# Test without open pragma +{ + my $file = File::Temp->new; + open my $fh, ">", $file; + + my @layers = PerlIO::get_layers($fh); + ok( grep(!/utf8/, @layers), "open pragma remains lexical" ) or diag join ", ", @layers; +} + + +# sysopen +{ + use open IN => ':encoding(utf8)', OUT => ':utf8'; + + # Test the standard handles and all newly opened handles are utf8 + my $file = File::Temp->new; + my $txt = "autodie is MËTÁŁ"; + + # open for writing only + { + sysopen my $fh, $file, O_CREAT|O_WRONLY; + + my @layers = PerlIO::get_layers($fh); + ok( (grep { $_ eq 'utf8' } @layers), "open write honors open pragma" ) or diag join ", ", @layers; + + print $fh $txt; + close $fh; + } + + # open for reading only + { + sysopen my $fh, $file, O_RDONLY; + + my @layers = PerlIO::get_layers($fh); + ok( (grep { $_ eq 'encoding(utf8)' } @layers), "open read honors open pragma" ) or diag join ", ", @layers; + + is join("\n", <$fh>), $txt; + } + + # open for reading and writing + { + sysopen my $fh, $file, O_RDWR; + + my @layers = PerlIO::get_layers($fh); + ok( (grep { $_ eq 'utf8' } @layers), "open read/write honors open write pragma" ) or diag join ", ", @layers; + + is join("\n", <$fh>), $txt; + } +} diff --git a/cpan/autodie/t/utime.t b/cpan/autodie/t/utime.t new file mode 100644 index 0000000000..983ca9c667 --- /dev/null +++ b/cpan/autodie/t/utime.t @@ -0,0 +1,18 @@ +#!/usr/bin/perl -w +use strict; +use Test::More tests => 4; +use constant NO_SUCH_FILE => "this_file_had_better_not_exist"; +use FindBin qw($Bin); +use File::Spec; +use constant TOUCH_ME => File::Spec->catfile($Bin, 'touch_me'); +use autodie; + +eval { utime(undef, undef, NO_SUCH_FILE); }; +isa_ok($@, 'autodie::exception', 'exception thrown for utime'); + +eval { utime(undef, undef, TOUCH_ME); }; +ok(! $@, "We can utime a file just fine.") or diag $@; + +eval { utime(undef, undef, NO_SUCH_FILE, TOUCH_ME); }; +isa_ok($@, 'autodie::exception', 'utime exception on single failure.'); +is($@->return, 1, "utime fails correctly on a 'true' failure."); diff --git a/cpan/autodie/t/version_tag.t b/cpan/autodie/t/version_tag.t index 89e1412e47..2a01351b4c 100644 --- a/cpan/autodie/t/version_tag.t +++ b/cpan/autodie/t/version_tag.t @@ -1,7 +1,7 @@ #!/usr/bin/perl -w use strict; use warnings; -use Test::More tests => 5; +use Test::More tests => 10; use constant NO_SUCH_FILE => 'THIS_FILE_HAD_BETTER_NOT_EXIST'; eval { @@ -19,10 +19,15 @@ isnt($@,"","Expanding :1.00 should fail"); my $version = $autodie::VERSION; -# Expanding our current version should work! -eval { my $foo = autodie->_expand_tag(":$version"); }; +SKIP: { -is($@,"","Expanding :$version should succeed"); + if ($version =~ /_/) { skip "Tag test skipped on dev release", 1 } + + # Expanding our current version should work! + eval { my $foo = autodie->_expand_tag(":$version"); }; + + is($@,"","Expanding :$version should succeed"); +} eval { use autodie qw(:2.07); @@ -42,3 +47,52 @@ eval { }; isa_ok($@, 'autodie::exception', 'Our current version supports chmod'); + +eval { + use autodie qw(:2.13); + + # 2.13 didn't support chown. This shouldn't throw an + # exception. + + chown(12345, 12345, NO_SUCH_FILE); +}; + +is($@,"","chown wasn't supported in 2.13"); + +SKIP: { + + if ($^O eq "MSWin32") { skip("chown() on Windows always succeeds.", 1) } + + eval { + use autodie; + + chown(12345, 12345, NO_SUCH_FILE); + }; + + isa_ok($@, 'autodie::exception', 'Our current version supports chown'); +} + +# The patch in RT 46984 would have utime being set even if an +# older version of autodie semantics was requested. Let's see if +# it's coming from outside the eval context below. + +eval { utime undef, undef, NO_SUCH_FILE; }; +is($@,"","utime is not autodying outside of any autodie context."); + +# Now do our regular versioning checks for utime. + +eval { + use autodie qw(:2.13); + + utime undef, undef, NO_SUCH_FILE; +}; + +is($@,"","utime wasn't supported in 2.13"); + +eval { + use autodie; + + utime undef, undef, NO_SUCH_FILE; +}; + +isa_ok($@, 'autodie::exception', 'Our current version supports utime'); |