This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Update autodie to CPAN version 2.19
authorChris 'BinGOs' Williams <chris@bingosnet.co.uk>
Sun, 26 May 2013 12:56:17 +0000 (13:56 +0100)
committerChris 'BinGOs' Williams <chris@bingosnet.co.uk>
Sun, 26 May 2013 13:18:01 +0000 (14:18 +0100)
  [DELTA]

2.19      2013-05-13 10:02:15 Australia/Melbourne

        * BUGFIX: Loading a file that does not change packages while
          autodie in effect no longer causes weird behaviour when
          slurpy built-ins (like open() and unlink()) are called. GH #22
          Thanks to Niels Thykier.

        * TEST: Tests for leak guard failures for slurpy core functions.

2.18      2013-05-12 18:12:14 Australia/Melbourne

        * TEST: More testing in scope_leak.t.

        * TEST: More testing around packages in truncate.t.

        * SPEED / INTERNAL: Significant improvements in load time,
          especially when autodie is used across multiple files,
          by caching reuseable subroutines and reducing calls to eval "".
          Huge thanks to Niels Thykier, who is a hero of the
          free people, and completely and utterly awesome.
          (RT #46984)

        * DOCUMENTATION: Spelling and correction fixes,
          courtesy David Steinbrunner.

        * DEVEL: Faster and more robust testing with travis-ci.

        * DEVEL: Some simple benchmarks bundled in the benchmarks/ directory.

2.17      2013-04-29 01:03:50 Australia/Melbourne

        * DOCS: Spelling fixes thanks to dsteinbrunner! (RT #84897)

        * DOCS: Fixed github links to point to 'pjf' rather than
          'pfenwick' (GH #18, thanks to Lx!)

        * INTERNAL: Silence warnings about experimental smart-match on
          5.17.11+ (via Brian Fraser and p5p)

        * TEST / BUILD: Generate .travis.yml files for CI testing via
          dzil.

2.16      2013-02-23 01:49:16 Australia/Melbourne

        * BUGFIX: Fix breakages under 5.8.x related to the new
          autodie::skip feature.

        * BUILD / BUGFIX: Remove dependency on parent.pm.

2.15      2013-02-22 23:55:22 Australia/Melbourne

        * BUILD / BUGFIX: Correct meta-info that wanted at least Perl
          v5.8.40, rather than v5.8.4.  Giant thanks to Paul Howarth
          for spotting this!

2.14      2013-02-22 15:43:33 Australia/Melbourne

        * FEATURE: Classes which claim they ->DOES('autodie::skip') are now
          skipped when generating exceptions.  This is mainly of use to
          utility classes. See `perldoc autodie::skip` for more details.
          (GH Issue #15)

        * FEATURE / BUGFIX / INCOMPAT: 'chmod' is now in the ':filesys'
          category (was in ':file').

        * BUGFIX: Added support for 'chown' and 'utime', that was
          previously overlooked. Mad props to RsrchBoy for spotting this.
          These are all in the ':filesys' category.
          (GH Pull #13)

        * BUGFIX: Added support for 'kill'. This is part of the
          ':ipc' category.

        * BUGFIX: Fixed bug whereby chmod, chown, kill, unlink and
          utime would not throw an exception when they didn't
          change all their files or signal all their processes.

        * TEST: truncate.t is now skipped on systems that don't have a
          working File::Temp.

        * TEST: open.t has a few more tests for exotic modes.

        * TEST: chown() tests are skipped on Win32, as chown on Windows
          is a no-op. (Thanks to Mithaldu for spotting this!)

        * TEST: Author tests now look for the AUTHOR_TESTING env
          variable (for dzil compliance).

        * TEST: Better testing for chown, chmod, and unlink.

        * TEST: Better testing for utime.

        * TEST: kwalitee.t is now only run when $ENV{RELEASE_TESTING} is set.

        * BUGFIX: Removed executable bits from some bundled text files.

        * BUILD: We now use dzil to manage autodie.

        * BUILD: Only Perl 5.8.4 and above is supported by autodie.
          Please upgrade your Perl distro if you're using 5.8.3 or
          below.

26 files changed:
MANIFEST
Porting/Maintainers.pl
Porting/exec-bit.txt
cpan/autodie/lib/Fatal.pm
cpan/autodie/lib/autodie.pm
cpan/autodie/lib/autodie/exception.pm
cpan/autodie/lib/autodie/exception/system.pm
cpan/autodie/lib/autodie/hints.pm
cpan/autodie/lib/autodie/skip.pm [new file with mode: 0644]
cpan/autodie/t/autodie_skippy.pm [new file with mode: 0644]
cpan/autodie/t/autodie_test_module.pm
cpan/autodie/t/chmod.t [new file with mode: 0755]
cpan/autodie/t/chown.t [new file with mode: 0644]
cpan/autodie/t/core-trampoline-slurp.t [new file with mode: 0644]
cpan/autodie/t/kill.t [new file with mode: 0644]
cpan/autodie/t/no_carp.t [new file with mode: 0644]
cpan/autodie/t/open.t
cpan/autodie/t/scope_leak.t
cpan/autodie/t/skip.t [new file with mode: 0644]
cpan/autodie/t/touch_me [new file with mode: 0644]
cpan/autodie/t/truncate.t
cpan/autodie/t/truncate_me [new file with mode: 0644]
cpan/autodie/t/unlink.t
cpan/autodie/t/utf8_open.t [new file with mode: 0644]
cpan/autodie/t/utime.t [new file with mode: 0644]
cpan/autodie/t/version_tag.t

index e3e3b8f..8dfd5f9 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -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
index a570de8..27fcdc4 100755 (executable)
@@ -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
                 )
index 0073e77..8489dda 100644 (file)
@@ -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
index c6a3d1b..8c6536b 100644 (file)
@@ -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
index 71a6a5e..6416d2c 100644 (file)
@@ -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
index 45c723d..ffdd4c8 100644 (file)
@@ -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;
index 0489b61..137bff1 100644 (file)
@@ -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__;
 
index 36715e9..350738e 100644 (file)
@@ -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 (file)
index 0000000..a9bac83
--- /dev/null
@@ -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 (file)
index 0000000..3baa9b5
--- /dev/null
@@ -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;
index e8e824c..f2c1405 100644 (file)
@@ -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 (executable)
index 0000000..9093b52
--- /dev/null
@@ -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 (file)
index 0000000..90c4d3b
--- /dev/null
@@ -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 (file)
index 0000000..b9450bf
--- /dev/null
@@ -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 (file)
index 0000000..22d4b36
--- /dev/null
@@ -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 (file)
index 0000000..1ac0615
--- /dev/null
@@ -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;
index 67f6f0c..d11dda5 100644 (file)
@@ -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.");
index 529daa3..c97b82f 100644 (file)
@@ -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 (file)
index 0000000..724cd65
--- /dev/null
@@ -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 (file)
index 0000000..6b0f32e
--- /dev/null
@@ -0,0 +1,2 @@
+For testing utime.
+Contents of this file are irrelevant.
index e69ee32..2472139 100644 (file)
@@ -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 (file)
index 0000000..e69de29
index f301500..c9d5168 100644 (file)
@@ -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 (file)
index 0000000..1cc2df0
--- /dev/null
@@ -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 (file)
index 0000000..983ca9c
--- /dev/null
@@ -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.");
index 89e1412..2a01351 100644 (file)
@@ -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');