pjf: dual life modules
authorPaul Fenwick <pjf@perltraining.com.au>
Mon, 29 Jun 2009 02:21:01 +0000 (12:21 +1000)
committerH.Merijn Brand <h.m.brand@xs4all.nl>
Mon, 29 Jun 2009 06:31:25 +0000 (08:31 +0200)
G'day Dave / p5p,

Attached is a patch that brings blead up to autodie 2.0, providing the new
hinting interface, and matching what's out there on the CPAN.

Cheerio,

Paul

--
Paul Fenwick <pjf@perltraining.com.au> | http://perltraining.com.au/
Director of Training                   | Ph:  +61 3 9354 6001
Perl Training Australia                | Fax: +61 3 9354 2681

From 41441253d22a31e4942ae0949102fada56b15343 Mon Sep 17 00:00:00 2001
From: Paul Fenwick <pjf@perltraining.com.au>
Date: Mon, 29 Jun 2009 12:08:21 +1000
Subject: [PATCH] Merge autodie 2.00 into CORE.

2.00  Mon Jun 29 01:24:49 AUSEST 2009

        * FEATURE: autodie can now accept hints regarding how
          user and module subroutines should be handled.  See
          autodie::hints for more information.

        * INTERFACE: The calls to the internal subroutines
          one_invocation() and write_invocation() have changed.
          An additional argument (the user subroutine reference) is
          passed as the second-last argument.  This may break code
          that previously tried to call these subroutines directly.

        * BUGFIX: Calls to subroutines to File::Copy should now
          correctly throw exceptions when called in a list context.

        * BUGFIX: An internal error where autodie could potentially
          fail to correctly report a dying function's name has been
          fixed.

        * BUGFIX: autodie will no longer clobber package scalars when
          a format has the same name as an autodying function.
          (Thanks to Ben Morrow)

        * INTERFACE: The internal interfaces for fill_protos(),
          one_invocation(), write_invocation() are now once again
          backward compatible with legacy versions of Fatal.  It is
          still strongly recommended these interfaces are NOT called
          directly.  The _make_fatal() subroutine is not backwards
          compatible.

        * TEST: Added internal-backcompat.t to test backwards
          compatibility of internal interfaces.

        * DOCUMENTATION: Expanded documentation regarding how
          autodie changes calls to system(), and how this must be
          explicitly enabled.

        * BUGFIX: A situation where certain compile-time diagnostics
          and errors from autodie would not be displayed has been
          fixed.

Signed-off-by: H.Merijn Brand <h.m.brand@xs4all.nl>
51 files changed:
MANIFEST
lib/Fatal.pm
lib/autodie.pm
lib/autodie/exception.pm
lib/autodie/exception/system.pm
lib/autodie/hints.pm [new file with mode: 0644]
lib/autodie/t/00-load.t [changed mode: 0644->0755]
lib/autodie/t/Fatal.t [changed mode: 0644->0755]
lib/autodie/t/autodie.t [changed mode: 0644->0755]
lib/autodie/t/backcompat.t [changed mode: 0644->0755]
lib/autodie/t/basic_exceptions.t [changed mode: 0644->0755]
lib/autodie/t/binmode.t [changed mode: 0644->0755]
lib/autodie/t/caller.t [changed mode: 0644->0755]
lib/autodie/t/context.t [changed mode: 0644->0755]
lib/autodie/t/context_lexical.t [changed mode: 0644->0755]
lib/autodie/t/crickey.t [changed mode: 0644->0755]
lib/autodie/t/dbmopen.t [changed mode: 0644->0755]
lib/autodie/t/exception_class.t [changed mode: 0644->0755]
lib/autodie/t/exceptions.t [changed mode: 0644->0755]
lib/autodie/t/exec.t [changed mode: 0644->0755]
lib/autodie/t/filehandles.t [changed mode: 0644->0755]
lib/autodie/t/fileno.t [changed mode: 0644->0755]
lib/autodie/t/flock.t [changed mode: 0644->0755]
lib/autodie/t/format-clobber.t [new file with mode: 0755]
lib/autodie/t/hints.t [new file with mode: 0755]
lib/autodie/t/hints_insist.t [new file with mode: 0755]
lib/autodie/t/hints_pod_examples.t [new file with mode: 0755]
lib/autodie/t/hints_provider_does.t [new file with mode: 0755]
lib/autodie/t/hints_provider_easy_does_it.t [new file with mode: 0755]
lib/autodie/t/hints_provider_isa.t [new file with mode: 0755]
lib/autodie/t/internal-backcompat.t [new file with mode: 0755]
lib/autodie/t/internal.t [changed mode: 0644->0755]
lib/autodie/t/lethal.t [changed mode: 0644->0755]
lib/autodie/t/lib/Hints_pod_examples.pm [new file with mode: 0644]
lib/autodie/t/lib/Hints_provider_does.pm [new file with mode: 0644]
lib/autodie/t/lib/Hints_provider_easy_does_it.pm [new file with mode: 0644]
lib/autodie/t/lib/Hints_provider_isa.pm [new file with mode: 0644]
lib/autodie/t/lib/Hints_test.pm [new file with mode: 0644]
lib/autodie/t/lib/OtherTypes.pm [new file with mode: 0644]
lib/autodie/t/mkdir.t [changed mode: 0644->0755]
lib/autodie/t/open.t [changed mode: 0644->0755]
lib/autodie/t/recv.t [changed mode: 0644->0755]
lib/autodie/t/repeat.t [changed mode: 0644->0755]
lib/autodie/t/scope_leak.t [changed mode: 0644->0755]
lib/autodie/t/sysopen.t [changed mode: 0644->0755]
lib/autodie/t/truncate.t [changed mode: 0644->0755]
lib/autodie/t/unlink.t [changed mode: 0644->0755]
lib/autodie/t/user-context.t [changed mode: 0644->0755]
lib/autodie/t/usersub.t [changed mode: 0644->0755]
lib/autodie/t/version.t [changed mode: 0644->0755]
lib/autodie/t/version_tag.t [changed mode: 0644->0755]

index 940a1bd..773e8e9 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -1765,6 +1765,7 @@ lib/Archive/Tar/t/src/short/foo.tgz.packed        Archive::Tar tests
 lib/assert.pl                  assertion and panic with stack trace
 lib/autodie/exception.pm       Exception class for autodie
 lib/autodie/exception/system.pm        Exception class for autodying system()
+lib/autodie/hints.pm           Hinting interface for autodie
 lib/autodie.pm                 Functions suceed or die with lexical scope
 lib/autodie/t/00-load.t                        autodie - basic load
 lib/autodie/t/autodie.t                        autodie - Basic functionality
@@ -1784,14 +1785,28 @@ lib/autodie/t/Fatal.t                   autodie - Fatal backcompatibility
 lib/autodie/t/filehandles.t            autodie - filehandle tests
 lib/autodie/t/fileno.t                 autodie - fileno tests
 lib/autodie/t/flock.t                  autodie - File locking tests
+lib/autodie/t/format-clobber.t         autodie - Don't clobber scalars
+lib/autodie/t/hints.t                  autodie - Test hints interface
+lib/autodie/t/hints_insist.t           autodie - Test hints insistance
+lib/autodie/t/hints_pod_examples.t     autodie - Test hints POD examples
+lib/autodie/t/hints_provider_does.t    autodie - Test hints/does roles
+lib/autodie/t/hints_provider_easy_does_it.t autodie - Test easy hints/does
+lib/autodie/t/hints_provider_isa.t     autodie - Test hints/inheritance
 lib/autodie/t/internal.t               autodie - internal interface tests
+lib/autodie/t/internal-backcompat.t    autodie - Back-compatibility tests
 lib/autodie/t/lethal.t                 autodie - lethal is the one true name
 lib/autodie/t/lib/autodie/test/au/exception.pm autodie - Australian helper
 lib/autodie/t/lib/autodie/test/au.pm           autodie - Austrlaian helper
 lib/autodie/t/lib/autodie/test/badname.pm      autodie - Bad exception class
 lib/autodie/t/lib/autodie/test/missing.pm      autodie - Missing exception class
 lib/autodie/t/lib/Caller_helper.pm     autodie - Caller helper
+lib/autodie/t/lib/Hints_pod_examples.pm        autodie - Hints/pod helper
+lib/autodie/t/lib/Hints_provider_does.pm    autodie - Hints/does helper
+lib/autodie/t/lib/Hints_provider_easy_does_it.pm    autodie - Hints/easy helper
+lib/autodie/t/lib/Hints_provider_isa.pm        autodie - Hints/inherit helper
+lib/autodie/t/lib/Hints_test.pm                autodie - Hints test helper
 lib/autodie/t/lib/lethal.pm            autodie - with a better name
+lib/autodie/t/lib/OtherTypes.pm                autodie - Format clobberer helper.
 lib/autodie/t/lib/pujHa/ghach/Dotlh.pm autodie - With Klingon honour
 lib/autodie/t/lib/pujHa/ghach.pm       autodie - Like a Klingon
 lib/autodie/t/mkdir.t                  autodie - filesystem tests
index 9acf4e2..9caa01e 100644 (file)
@@ -4,9 +4,13 @@ use 5.008;  # 5.8.x needed for autodie
 use Carp;
 use strict;
 use warnings;
+use Tie::RefHash;   # To cache subroutine refs
+
+use constant PERL510     => ( $] >= 5.010 );
 
 use constant LEXICAL_TAG => q{:lexical};
 use constant VOID_TAG    => q{:void};
+use constant INSIST_TAG  => q{!};
 
 use constant ERROR_NOARGS    => 'Cannot use lexical %s with no arguments';
 use constant ERROR_VOID_LEX  => VOID_TAG.' cannot be used with lexical scope';
@@ -15,6 +19,8 @@ use constant ERROR_NO_LEX    => "no %s can only start with ".LEXICAL_TAG;
 use constant ERROR_BADNAME   => "Bad subroutine name for %s: %s";
 use constant ERROR_NOTSUB    => "%s is not a Perl subroutine";
 use constant ERROR_NOT_BUILT => "%s is neither a builtin, nor a Perl subroutine";
+use constant ERROR_NOHINTS   => "No user hints defined for %s";
+
 use constant ERROR_CANT_OVERRIDE => "Cannot make the non-overridable builtin %s fatal";
 
 use constant ERROR_NO_IPC_SYS_SIMPLE => "IPC::System::Simple required for Fatalised/autodying system()";
@@ -25,13 +31,15 @@ use constant ERROR_AUTODIE_CONFLICT => q{"no autodie '%s'" is not allowed while
 
 use constant ERROR_FATAL_CONFLICT => q{"use Fatal '%s'" is not allowed while "no autodie '%s'" is in effect};
 
+use constant ERROR_58_HINTS => q{Non-subroutine %s hints for %s are not supported under Perl 5.8.x};
+
 # Older versions of IPC::System::Simple don't support all the
 # features we need.
 
 use constant MIN_IPC_SYS_SIMPLE_VER => 0.12;
 
 # All the Fatal/autodie modules share the same version number.
-our $VERSION = '1.999';
+our $VERSION = '2.00';
 
 our $Debug ||= 0;
 
@@ -63,7 +71,7 @@ my %TAGS = (
     ':system'  => [qw(system exec)],
 
     # Can we use qw(getpeername getsockname)? What do they do on failure?
-    # XXX - Can socket return false?
+    # TODO - Can socket return false?
     ':socket'  => [qw(accept bind connect getsockopt listen recv send
                    setsockopt shutdown socketpair)],
 
@@ -85,6 +93,8 @@ my %TAGS = (
     ':1.997' => [qw(:default)],
     ':1.998' => [qw(:default)],
     ':1.999' => [qw(:default)],
+    ':1.999_01' => [qw(:default)],
+    ':2.00'  => [qw(:default)],
 
 );
 
@@ -132,6 +142,13 @@ my %Package_Fatal = ();
 
 my %Original_user_sub = ();
 
+# Is_fatalised_sub simply records a big map of fatalised subroutine
+# refs.  It means we can avoid repeating work, or fatalising something
+# we've already processed.
+
+my  %Is_fatalised_sub = ();
+tie %Is_fatalised_sub, 'Tie::RefHash';
+
 # 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.
@@ -144,9 +161,10 @@ my $NO_PACKAGE    = "no $PACKAGE";      # Used to detect 'no autodie'
 # or 'use autodie'.
 
 sub import {
-    my $class   = shift(@_);
-    my $void    = 0;
-    my $lexical = 0;
+    my $class        = shift(@_);
+    my $void         = 0;
+    my $lexical      = 0;
+    my $insist_hints = 0;
 
     my ($pkg, $filename) = caller();
 
@@ -195,6 +213,10 @@ sub import {
             # When we see :void, set the void flag.
             $void = 1;
 
+        } elsif ($func eq INSIST_TAG) {
+
+            $insist_hints = 1;
+
         } elsif (exists $TAGS{$func}) {
 
             # When it's a tag, expand it.
@@ -204,6 +226,17 @@ sub import {
 
             # Otherwise, fatalise it.
 
+            # Check to see if there's an insist flag at the front.
+            # If so, remove it, and insist we have hints for this sub.
+            my $insist_this;
+
+            if ($func =~ s/^!//) {
+                $insist_this = 1;
+            }
+
+            # TODO: Even if we've already fatalised, we should
+            # check we've done it with hints (if $insist_hints).
+
             # If we've already made something fatal this call,
             # then don't do it twice.
 
@@ -233,7 +266,8 @@ sub import {
             # built-ins.
 
             my $sub_ref = $class->_make_fatal(
-                $func, $pkg, $void, $lexical, $filename
+                $func, $pkg, $void, $lexical, $filename,
+                ( $insist_this || $insist_hints )
             );
 
             $done_this{$func}++;
@@ -301,9 +335,12 @@ sub _install_subs {
         # Nuke the old glob.
         { no strict; delete $pkg_sym->{$sub_name}; }    ## no critic
 
-        # Copy innocent bystanders back.
+        # Copy innocent bystanders back.  Note that we lose
+        # formats; it seems that Perl versions up to 5.10.0
+        # have a bug which causes copying formats to end up in
+        # the scalar slot.  Thanks to Ben Morrow for spotting this.
 
-        foreach my $slot (qw( SCALAR ARRAY HASH IO FORMAT ) ) {
+        foreach my $slot (qw( SCALAR ARRAY HASH IO ) ) {
             next unless defined *__tmp{ $slot };
             *{ $full_path } = *__tmp{ $slot };
         }
@@ -421,6 +458,8 @@ sub unimport {
 }
 
 # This code is from the original Fatal.  It scares me.
+# It is 100% compatible with the 5.10.0 Fatal module, right down
+# to the scary 'XXXX' comment.  ;)
 
 sub fill_protos {
     my $proto = shift;
@@ -438,17 +477,35 @@ sub fill_protos {
     return @out1;
 }
 
-# This generates the code that will become our fatalised subroutine.
+# This is a backwards compatible version of _write_invocation.  It's
+# recommended you don't use it.
 
 sub write_invocation {
-    my ($class, $core, $call, $name, $void, $lexical, $sub, @argvs) = @_;
+    my ($core, $call, $name, $void, @args) = @_;
+
+    return Fatal->_write_invocation(
+        $core, $call, $name, $void,
+        0,      # Lexical flag
+        undef,  # Sub, unused in legacy mode
+        undef,  # Subref, unused in legacy mode.
+        @args
+    );
+}
+
+# This version of _write_invocation is used internally.  It's not
+# recommended you call it from external code, as the interface WILL
+# change in the future.
+
+sub _write_invocation {
+
+    my ($class, $core, $call, $name, $void, $lexical, $sub, $sref, @argvs) = @_;
 
     if (@argvs == 1) {        # No optional arguments
 
         my @argv = @{$argvs[0]};
         shift @argv;
 
-        return $class->one_invocation($core,$call,$name,$void,$sub,! $lexical,@argv);
+        return $class->_one_invocation($core,$call,$name,$void,$sub,! $lexical, $sref, @argv);
 
     } else {
         my $else = "\t";
@@ -460,19 +517,44 @@ sub write_invocation {
             push @out, "${else}if (\@_ == $n) {\n";
             $else = "\t} els";
 
-        push @out, $class->one_invocation($core,$call,$name,$void,$sub,! $lexical,@argv);
+        push @out, $class->_one_invocation($core,$call,$name,$void,$sub,! $lexical, $sref, @argv);
         }
-        push @out, q[
+        push @out, qq[
             }
-            die "Internal error: $name(\@_): Do not expect to get ", scalar \@_, " arguments";
+            die "Internal error: $name(\@_): Do not expect to get ", scalar(\@_), " arguments";
     ];
 
         return join '', @out;
     }
 }
 
+
+# This is a slim interface to ensure backward compatibility with
+# anyone doing very foolish things with old versions of Fatal.
+
 sub one_invocation {
-    my ($class, $core, $call, $name, $void, $sub, $back_compat, @argv) = @_;
+    my ($core, $call, $name, $void, @argv) = @_;
+
+    return Fatal->_one_invocation(
+        $core, $call, $name, $void,
+        undef,   # Sub.  Unused in back-compat mode.
+        1,       # Back-compat flag
+        undef,   # Subref, unused in back-compat mode.
+        @argv
+    );
+
+}
+
+# This is the internal interface that generates code.
+# NOTE: This interface WILL change in the future.  Please do not
+# call this subroutine directly.
+
+# TODO: Whatever's calling this code has already looked up hints.  Pass
+# them in, rather than look them up a second time.
+
+sub _one_invocation {
+    my ($class, $core, $call, $name, $void, $sub, $back_compat, $sref, @argv) = @_;
+
 
     # If someone is calling us directly (a child class perhaps?) then
     # they could try to mix void without enabling backwards
@@ -492,11 +574,13 @@ sub one_invocation {
 
     if ($back_compat) {
 
-        # TODO - Use Fatal qw(system) is not yet supported.  It should be!
+        # Use Fatal qw(system) will never be supported.  It generated
+        # a compile-time error with legacy Fatal, and there's no reason
+        # to support it when autodie does a better job.
 
         if ($call eq 'CORE::system') {
             return q{
-                croak("UNIMPLEMENTED: use Fatal qw(system) not yet supported.");
+                croak("UNIMPLEMENTED: use Fatal qw(system) not supported.");
             };
         }
 
@@ -522,14 +606,33 @@ sub one_invocation {
     # replace whatever it is that we're calling; as such, we actually
     # calling a subroutine ref.
 
-    # Unfortunately, none of this tells us the *ultimate* name.
-    # For example, if I export 'copy' from File::Copy, I'd like my
-    # ultimate name to be File::Copy::copy.
-    #
-    # TODO - Is there any way to find the ultimate name of a sub, as
-    # described above?
+    my $human_sub_name = $core ? $call : $sub;
+
+    # Should we be testing to see if our result is defined, or
+    # just true?
+
+    my $use_defined_or;
+
+    my $hints;      # All user-sub hints, including list hints.
+
+    if ( $core ) {
+
+        # Core hints are built into autodie.
+
+        $use_defined_or = exists ( $Use_defined_or{$call} );
+
+    }
+    else {
+
+        # User sub hints are looked up using autodie::hints,
+        # since users may wish to add their own hints.
+
+        require autodie::hints;
+
+        $hints = autodie::hints->get_hints_for( $sref );
+    }
 
-    my $true_sub_name = $core ? $call : $sub;
+    # Checks for special core subs.
 
     if ($call eq 'CORE::system') {
 
@@ -561,7 +664,7 @@ sub one_invocation {
 
             if (\$E) {
 
-                # XXX - TODO - This can't be overridden in child
+                # TODO - This can't be overridden in child
                 # classes!
 
                 die autodie::exception::system->new(
@@ -575,16 +678,12 @@ sub one_invocation {
 
     }
 
-    # Should we be testing to see if our result is defined, or
-    # just true?
-    my $use_defined_or = exists ( $Use_defined_or{$call} );
-
     local $" = ', ';
 
     # If we're going to throw an exception, here's the code to use.
     my $die = qq{
         die $class->throw(
-            function => q{$true_sub_name}, args => [ @argv ],
+            function => q{$human_sub_name}, args => [ @argv ],
             pragma => q{$class}, errno => \$!,
         )
     };
@@ -635,26 +734,83 @@ sub one_invocation {
     # the 'unopened' warning class here.  Especially since they
     # then report the wrong line number.
 
-    return qq{
+    my $code = qq[
         no warnings qw(unopened);
 
         if (wantarray) {
             my \@results = $call(@argv);
-            # If we got back nothing, or we got back a single
-            # undef, we die.
+
+    ];
+
+    if ( $hints and ( ref($hints->{list} ) || "" ) eq 'CODE' ) {
+
+        # NB: Subroutine hints are passed as a full list.
+        # This differs from the 5.10.0 smart-match behaviour,
+        # but means that context unaware subroutines can use
+        # the same hints in both list and scalar context.
+
+        $code .= qq{
+            if ( \$hints->{list}->(\@results) ) { $die };
+        };
+    }
+    elsif ( PERL510 and $hints ) {
+        $code .= qq{
+            if ( \@results ~~ \$hints->{list} ) { $die };
+        };
+    }
+    elsif ( $hints ) {
+        croak sprintf(ERROR_58_HINTS, 'list', $sub);
+    }
+    else {
+        $code .= qq{
+            # An empty list, or a single undef is failure
             if (! \@results or (\@results == 1 and ! defined \$results[0])) {
                 $die;
-            };
+            }
+        }
+    }
+
+    # Tidy up the end of our wantarray call.
+
+    $code .= qq[
             return \@results;
         }
+    ];
 
-        # Otherwise, we're in scalar context.
-        # We're never in a void context, since we have to look
-        # at the result.
 
+    # Otherwise, we're in scalar context.
+    # We're never in a void context, since we have to look
+    # at the result.
+
+    $code .= qq{
         my \$result = $call(@argv);
+    };
+
+    if ( $hints and ( ref($hints->{scalar} ) || "" ) eq 'CODE' ) {
+
+        # We always call code refs directly, since that always
+        # works in 5.8.x, and always works in 5.10.1
+
+        return $code .= qq{
+            if ( \$hints->{scalar}->(\$result) ) { $die };
+            return \$result;
+        };
 
-    } . ( $use_defined_or ? qq{
+    }
+    elsif (PERL510 and $hints) {
+        return $code . qq{
+
+            if ( \$result ~~ \$hints->{scalar} ) { $die };
+
+            return \$result;
+        };
+    }
+    elsif ( $hints ) {
+        croak sprintf(ERROR_58_HINTS, 'scalar', $sub);
+    }
+
+    return $code .
+    ( $use_defined_or ? qq{
 
         $die if not defined \$result;
 
@@ -676,9 +832,11 @@ sub one_invocation {
 # TODO: Taking a huge list of arguments is awful.  Rewriting to
 #       take a hash would be lovely.
 
+# TODO - BACKCOMPAT - This is not yet compatible with 5.10.0
+
 sub _make_fatal {
-    my($class, $sub, $pkg, $void, $lexical, $filename) = @_;
-    my($name, $code, $sref, $real_proto, $proto, $core, $call);
+    my($class, $sub, $pkg, $void, $lexical, $filename, $insist) = @_;
+    my($name, $code, $sref, $real_proto, $proto, $core, $call, $hints);
     my $ini = $sub;
 
     $sub = "${pkg}::$sub" unless $sub =~ /::/;
@@ -701,12 +859,15 @@ sub _make_fatal {
 
     if (defined(&$sub)) {   # user subroutine
 
+        # NOTE: Previously we would localise $@ at this point, so
+        # the following calls to eval {} wouldn't interfere with anything
+        # that's already in $@.  Unfortunately, it would also stop
+        # any of our croaks from triggering(!), which is even worse.
+
         # This could be something that we've fatalised that
         # was in core.
 
-        local $@; # Don't clobber anyone else's $@
-
-        if ( $Package_Fatal{$sub} and eval { prototype "CORE::$name" } ) {
+        if ( $Package_Fatal{$sub} and do { local $@; eval { prototype "CORE::$name" } } ) {
 
             # Something we previously made Fatal that was core.
             # This is safe to replace with an autodying to core
@@ -724,12 +885,33 @@ sub _make_fatal {
 
         } else {
 
+            # If this is something we've already fatalised or played with,
+            # then look-up the name of the original sub for the rest of
+            # our processing.
+
+            $sub = $Is_fatalised_sub{\&$sub} || $sub;
+
             # A regular user sub, or a user sub wrapping a
             # core sub.
 
             $sref = \&$sub;
             $proto = prototype $sref;
             $call = '&$sref';
+            require autodie::hints;
+
+            $hints = autodie::hints->get_hints_for( $sref );
+
+            # If we've insisted on hints, but don't have them, then
+            # bail out!
+
+            if ($insist and not $hints) {
+                croak(sprintf(ERROR_NOHINTS, $name));
+            }
+
+            # Otherwise, use the default hints if we don't have
+            # any.
+
+            $hints ||= autodie::hints::DEFAULT_HINTS();
 
         }
 
@@ -742,21 +924,31 @@ sub _make_fatal {
         # If we're fatalising system, then we need to load
         # helper code.
 
-        eval {
-            require IPC::System::Simple; # Only load it if we need it.
-            require autodie::exception::system;
-        };
+        # The business with $E is to avoid clobbering our caller's
+        # $@, and to avoid $@ being localised when we croak.
 
-        if ($@) { croak ERROR_NO_IPC_SYS_SIMPLE; }
+        my $E;
 
-            # Make sure we're using a recent version of ISS that actually
-            # support fatalised system.
-            if ($IPC::System::Simple::VERSION < MIN_IPC_SYS_SIMPLE_VER) {
-                croak sprintf(
-                ERROR_IPC_SYS_SIMPLE_OLD, MIN_IPC_SYS_SIMPLE_VER,
-                $IPC::System::Simple::VERSION
-                );
-            }
+        {
+            local $@;
+
+            eval {
+                require IPC::System::Simple; # Only load it if we need it.
+                require autodie::exception::system;
+            };
+            $E = $@;
+        }
+
+        if ($E) { croak ERROR_NO_IPC_SYS_SIMPLE; }
+
+        # Make sure we're using a recent version of ISS that actually
+        # support fatalised system.
+        if ($IPC::System::Simple::VERSION < MIN_IPC_SYS_SIMPLE_VER) {
+            croak sprintf(
+            ERROR_IPC_SYS_SIMPLE_OLD, MIN_IPC_SYS_SIMPLE_VER,
+            $IPC::System::Simple::VERSION
+            );
+        }
 
         $call = 'CORE::system';
         $name = 'system';
@@ -772,8 +964,13 @@ sub _make_fatal {
         $core = 1;
 
     } else {            # CORE subroutine
-        $proto = eval { prototype "CORE::$name" };
-        croak(sprintf(ERROR_NOT_BUILT,$name)) if $@;
+        my $E;
+        {
+            local $@;
+            $proto = eval { prototype "CORE::$name" };
+            $E = $@;
+        }
+        croak(sprintf(ERROR_NOT_BUILT,$name)) if $E;
         croak(sprintf(ERROR_CANT_OVERRIDE,$name)) if not defined $proto;
         $core = 1;
         $call = "CORE::$name";
@@ -813,7 +1010,7 @@ sub _make_fatal {
     $code .= "no warnings qw(exec);\n" if $call eq "CORE::exec";
 
     my @protos = fill_protos($proto);
-    $code .= $class->write_invocation($core, $call, $name, $void, $lexical, $sub, @protos);
+    $code .= $class->_write_invocation($core, $call, $name, $void, $lexical, $sub, $sref, @protos);
     $code .= "}\n";
     warn $code if $Debug;
 
@@ -827,18 +1024,18 @@ sub _make_fatal {
     # and filehandles.
 
     {
-        local $@;
         no strict 'refs'; ## no critic # to avoid: Can't use string (...) as a symbol ref ...
-        $code = eval("package $pkg; use Carp; $code");  ## no critic
-        if (not $code) {
 
-            # For some reason, using a die, croak, or confess in here
-            # results in the error being completely surpressed. As such,
-            # we need to do our own reporting.
-            #
-            # TODO: Fix the above.
+        my $E;
+
+        {
+            local $@;
+            $code = eval("package $pkg; use Carp; $code");  ## no critic
+            $E = $@;
+        }
 
-            _autocroak("Internal error in autodie/Fatal processing $true_name: $@");
+        if (not $code) {
+            croak("Internal error in autodie/Fatal processing $true_name: $E");
 
         }
     }
@@ -906,16 +1103,28 @@ sub _make_fatal {
 
         # warn "$leak_guard\n";
 
-        local $@;
+        my $E;
+        {
+            local $@;
+
+            $leak_guard = eval $leak_guard;  ## no critic
 
-        $leak_guard = eval $leak_guard;  ## no critic
+            $E = $@;
+        }
 
-        die "Internal error in $class: Leak-guard installation failure: $@" if $@;
+        die "Internal error in $class: Leak-guard installation failure: $E" if $E;
     }
 
-    $class->_install_subs($pkg, { $name => $leak_guard || $code });
+    my $installed_sub = $leak_guard || $code;
+
+    $class->_install_subs($pkg, { $name => $installed_sub });
+
+    $Cached_fatalised_sub{$class}{$sub}{$void}{$lexical} = $installed_sub;
+
+    # Cache that we've now overriddent this sub.  If we get called
+    # again, we may need to find that find subroutine again (eg, for hints).
 
-    $Cached_fatalised_sub{$class}{$sub}{$void}{$lexical} = $leak_guard || $code;
+    $Is_fatalised_sub{$installed_sub} = $sref;
 
     return $sref;
 
@@ -1052,7 +1261,7 @@ values are ignored.  For example
     use Fatal qw/:void open close/;
 
     # properly checked, so no exception raised on error
-    if (not open(my $fh, '<' '/bogotic') {
+    if (not open(my $fh, '<', '/bogotic') {
         warn "Can't open /bogotic: $!";
     }
 
index cb999a8..b5756d4 100644 (file)
@@ -8,7 +8,7 @@ our @ISA = qw(Fatal);
 our $VERSION;
 
 BEGIN {
-    $VERSION = "1.999";
+    $VERSION = '2.00';
 }
 
 use constant ERROR_WRONG_FATAL => q{
@@ -73,7 +73,9 @@ autodie - Replace functions with ones that succeed or die with lexical scope
 
 =head1 SYNOPSIS
 
-    use autodie;    # Recommended, implies 'use autodie qw(:default)'
+    use autodie;            # Recommended: implies 'use autodie qw(:default)'
+
+    use autodie qw(:all);   # Recommended more: defaults and system/exec.
 
     use autodie qw(open close);   # open/close succeed or die
 
@@ -248,10 +250,15 @@ The syntax:
     use autodie qw(:1.994);
 
 allows the C<:default> list from a particular version to be used.  This
-provides the convenience of using the default methods, but the surity
+provides the convenience of using the default methods, but the surety
 that no behavorial changes will occur if the C<autodie> module is
 upgraded.
 
+You can enable C<autodie> for all of Perl's built-ins, including
+C<system> and C<exec> with:
+
+    use autodie qw(:all);
+
 =head1 FUNCTION SPECIFIC NOTES
 
 =head2 flock
@@ -272,6 +279,36 @@ false with any other error.
 
 =head2 system/exec
 
+The C<system> built-in is considered to have failed in the following
+circumstances:
+
+=over 4
+
+=item *
+
+The command does not start.
+
+=item *
+
+The command is killed by a signal.
+
+=item *
+
+The command returns a non-zero exit value (but see below).
+
+=back
+
+On success, the autodying form of C<system> returns the I<exit value>
+rather than the contents of C<$?>.
+
+Additional allowable exit values can be supplied as an optional first
+argument to autodying C<system>:
+
+    system( [ 0, 1, 2 ], $cmd, @args);  # 0,1,2 are good exit values
+
+C<autodie> uses the L<IPC::System::Simple> module to change C<system>.
+See its documentation for further information.
+
 Applying C<autodie> to C<system> or C<exec> causes the exotic
 forms C<system { $cmd } @args > or C<exec { $cmd } @args>
 to be considered a syntax error until the end of the lexical scope.
@@ -295,7 +332,14 @@ The C<:void> option is supported in L<Fatal>, but not
 C<autodie>.  However you can explicitly disable autodie
 end the end of the current block with C<no autodie>.
 To disable autodie for only a single function (eg, open)
-use or C<no autodie qw(open)>.
+use C<no autodie qw(open)>.
+
+=item No user hints defined for %s
+
+You've insisted on hints for user-subroutines, either by pre-pending
+a C<!> to the subroutine name itself, or earlier in the list of arguments
+to C<autodie>.  However the subroutine in question does not have
+any hints available.
 
 =back
 
@@ -315,9 +359,12 @@ any version of Perl.
 When using C<autodie> or C<Fatal> with user subroutines, the
 declaration of those subroutines must appear before the first use of
 C<Fatal> or C<autodie>, or have been exported from a module.
-Attempting to ue C<Fatal> or C<autodie> on other user subroutines will
+Attempting to use C<Fatal> or C<autodie> on other user subroutines will
 result in a compile-time error.
 
+Due to a bug in Perl, C<autodie> may "lose" any format which has the
+same name as an autodying built-in or function.
+
 =head2 REPORTING BUGS
 
 Please report bugs via the CPAN Request Tracker at
@@ -335,7 +382,7 @@ E<lt>pjf@perltraining.com.auE<gt>.
 
 =head1 AUTHOR
 
-Copyright 2008, Paul Fenwick E<lt>pjf@perltraining.com.auE<gt>
+Copyright 2008-2009, Paul Fenwick E<lt>pjf@perltraining.com.auE<gt>
 
 =head1 LICENSE
 
@@ -344,7 +391,7 @@ same terms as Perl itself.
 
 =head1 SEE ALSO
 
-L<Fatal>, L<autodie::exception>, L<IPC::System::Simple>
+L<Fatal>, L<autodie::exception>, L<autodie::hints>, L<IPC::System::Simple>
 
 I<Perl tips, autodie> at
 L<http://perltraining.com.au/tips/2008-08-20.html>
@@ -355,6 +402,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/AUTHORS> .
+L<http://github.com/pfenwick/autodie/tree/master/AUTHORS> .
 
 =cut
index f297bf8..05f3f7d 100644 (file)
@@ -14,7 +14,7 @@ use overload
 
 use if ($] >= 5.010), overload => '~~'  => "matches";
 
-our $VERSION = '1.999';
+our $VERSION = '2.00';
 
 my $PACKAGE = __PACKAGE__;  # Useful to have a scalar for hash keys.
 
@@ -185,7 +185,7 @@ See L<autodie/CATEGORIES> for futher information.
     sub matches {
         my ($this, $that) = @_;
 
-        # XXX - Handle references
+        # TODO - Handle references
         croak "UNIMPLEMENTED" if ref $that;
 
         my $sub = $this->function;
@@ -644,7 +644,7 @@ sub _init {
 
     # If we end up falling out the bottom of our stack, then our
     # __ANON__ guess is the best we can get.  This includes situations
-    # where we were called from thetop level of a program.
+    # where we were called from the top level of a program.
 
     if (not defined $sub) {
         $sub = $first_guess_subroutine;
index 6b11440..d51398b 100644 (file)
@@ -5,7 +5,7 @@ use warnings;
 use base 'autodie::exception';
 use Carp qw(croak);
 
-our $VERSION = '1.999';
+our $VERSION = '2.00';
 
 my $PACKAGE = __PACKAGE__;
 
diff --git a/lib/autodie/hints.pm b/lib/autodie/hints.pm
new file mode 100644 (file)
index 0000000..bd42118
--- /dev/null
@@ -0,0 +1,597 @@
+package autodie::hints;
+
+use strict;
+use warnings;
+
+our $VERSION = '2.00';
+
+=head1 NAME
+
+autodie::hints - Provide hints about user subroutines to autodie
+
+=head1 SYNOPSIS
+
+    package Your::Module;
+
+    our %DOES = ( 'autodie::hints::provider' => 1 );
+
+    sub AUTODIE_HINTS {
+        return {
+            foo => { scalar => HINTS, list => SOME_HINTS },
+            bar => { scalar => HINTS, list => MORE_HINTS },
+        }
+    }
+
+    # Later, in your main program...
+
+    use Your::Module qw(foo bar);
+    use autodie      qw(:default foo bar);
+
+    foo();         # succeeds or dies based on scalar hints
+
+    # Alternatively, hints can be set on subroutines we've
+    # imported.
+
+    use autodie::hints;
+    use Some::Module qw(think_positive);
+
+    BEGIN {
+        autodie::hints->set_hints_for(
+            \&think_positive,
+            {
+                fail => sub { $_[0] <= 0 }
+            }
+        )
+    }
+    use autodie qw(think_positive);
+
+    think_positive(...);    # Returns positive or dies.
+
+
+=head1 DESCRIPTION
+
+=head2 Introduction
+
+The L<autodie> pragma is very smart when it comes to working with
+Perl's built-in functions.  The behaviour for these functions are
+fixed, and C<autodie> knows exactly how they try to signal failure.
+
+But what about user-defined subroutines from modules?  If you use
+C<autodie> on a user-defined subroutine then it assumes the following
+behaviour to demonstrate failure:
+
+=over
+
+=item *
+
+A false value, in scalar context
+
+=item * 
+
+An empty list, in list context
+
+=item *
+
+A list containing a single undef, in list context
+
+=back
+
+All other return values (including the list of the single zero, and the
+list containing a single empty string) are considered successful.  However,
+real-world code isn't always that easy.  Perhaps the code you're working
+with returns a string containing the word "FAIL" in it upon failure, or a
+two element list containing C<(undef, "human error message")>.  To make
+autodie work with these sorts of subroutines, we have
+the I<hinting interface>.
+
+The hinting interface allows I<hints> to be provided to C<autodie>
+on how it should detect failure from user-defined subroutines.  While
+these I<can> be provided by the end-user of C<autodie>, they are ideally
+written into the module itself, or into a helper module or sub-class
+of C<autodie> itself.
+
+=head2 What are hints?
+
+A I<hint> is a subroutine or value that is checked against the
+return value of an autodying subroutine.  If the match returns true,
+C<autodie> considers the subroutine have failed.
+
+If the hint provided is a subroutine, then C<autodie> will pass
+the complete return value to that subroutine.  If the hint is
+any other value, then C<autodie> will smart-match against the
+value provided.  In Perl 5.8.x, there is no smart-match operator, and as such
+only subroutine hints are supported in these versions.
+
+Hints can be provided for both scalar context and list context.  Note
+that an autodying subroutine will never see a void context, as
+C<autodie> always needs to capture the return value for examination.
+Autodying subroutines called in void context act as if they're called
+in a scalar context, but their return value is discarded after it
+has been checked.
+
+=head2 Example hints
+
+Hints may consist of scalars, array references, regular expressions and
+subroutine references.  You can specify different hints for how
+failure should be identified in scalar and list contexts.
+
+These examples apply for use in the C<AUTODIE_HINTS> subroutine and when
+calling C<autodie::hints->set_hints_for()>.
+
+The most common context-specific hints are:
+
+        # Scalar failures always return undef:
+            {  scalar => undef  }
+
+        # Scalar failures return any false value [default expectation]:
+            {  scalar => sub { ! $_[0] }  }
+
+        # Scalar failures always return zero explicitly:
+            {  scalar => '0'  }
+
+        # List failures always return empty list:
+            {  list => []  }
+
+        # List failures return () or (undef) [default expectation]:
+            {  list => sub { ! @_ || @_ == 1 && !defined $_[0] }  }
+
+        # List failures return () or a single false value:
+            {  list => sub { ! @_ || @_ == 1 && !$_[0] }  }
+
+        # List failures return (undef, "some string")
+            {  list => sub { @_ == 2 && !defined $_[0] }  }
+
+        # Unsuccessful foo() returns 'FAIL' or '_FAIL' in scalar context,
+        #                    returns (-1) in list context...
+        autodie::hints->set_hints_for(
+            \&foo,
+            {
+                scalar => qr/^ _? FAIL $/xms,
+                list   => [-1],
+            }
+        );
+
+        # Unsuccessful foo() returns 0 in all contexts...
+        autodie::hints->set_hints_for(
+            \&foo,
+            {
+                scalar => 0,
+                list   => [0],
+            }
+       );
+
+This "in all contexts" construction is very common, and can be
+abbreviated, using the 'fail' key.  This sets both the C<scalar>
+and C<list> hints to the same value:
+
+        # Unsuccessful foo() returns 0 in all contexts...
+        autodie::hints->set_hints_for(
+            \&foo,
+            {
+                fail => sub { @_ == 1 and defined $_[0] and $_[0] == 0 }
+            }
+       );
+
+        # Unsuccessful think_positive() returns negative number on failure...
+        autodie::hints->set_hints_for(
+            \&think_positive,
+            {
+                fail => sub { $_[0] < 0 }
+            }
+       );
+
+        # Unsuccessful my_system() returns non-zero on failure...
+        autodie::hints->set_hints_for(
+            \&my_system,
+            {
+                fail => sub { $_[0] != 0 }
+            }
+       );
+
+=head1 Manually setting hints from within your program
+
+If you are using a module which returns something special on failure, then
+you can manually create hints for each of the desired subroutines.  Once
+the hints are specified, they are available for all files and modules loaded
+thereafter, thus you can move this work into a module and it will still
+work.
+
+       use Some::Module qw(foo bar);
+       use autodie::hints;
+
+       autodie::hints->set_hints_for(
+               \&foo,
+               {
+                       scalar => SCALAR_HINT,
+                       list   => LIST_HINT,
+               }
+       );
+       autodie::hints->set_hints_for(
+               \&bar,
+                { fail => SOME_HINT, }
+       );
+
+It is possible to pass either a subroutine reference (recommended) or a fully
+qualified subroutine name as the first argument.  This means you can set hints
+on modules that I<might> get loaded:
+
+       use autodie::hints;
+       autodie::hints->set_hints_for(
+               'Some::Module:bar', { fail => SCALAR_HINT, }
+       );
+
+This technique is most useful when you have a project that uses a
+lot of third-party modules.  You can define all your possible hints
+in one-place.  This can even be in a sub-class of autodie.  For
+example:
+
+        package my::autodie;
+
+        use parent qw(autodie);
+        use autodie::hints;
+
+        autodie::hints->set_hints_for(...);
+
+        1;
+
+You can now C<use my::autodie>, which will work just like the standard
+C<autodie>, but is now aware of any hints that you've set.
+
+=head1 Adding hints to your module
+
+C<autodie> provides a passive interface to allow you to declare hints for
+your module.  These hints will be found and used by C<autodie> if it
+is loaded, but otherwise have no effect (or dependencies) without autodie.
+To set these, your module needs to declare that it I<does> the
+C<autodie::hints::provider> role.  This can be done by writing your
+own C<DOES> method, using a system such as C<Class::DOES> to handle
+the heavy-lifting for you, or declaring a C<%DOES> package variable
+with a C<autodie::hints::provider> key and a corresponding true value.
+
+Note that checking for a C<%DOES> hash is an C<autodie>-only
+short-cut.  Other modules do not use this mechanism for checking
+roles, although you can use the C<Class::DOES> module from the
+CPAN to allow it.
+
+In addition, you must define a C<AUTODIE_HINTS> subroutine that returns
+a hash-reference containing the hints for your subroutines:
+
+       package Your::Module;
+
+        # We can use the Class::DOES from the CPAN to declare adherence
+        # to a role.
+
+        use Class::DOES 'autodie::hints::provider' => 1;
+
+        # Alternatively, we can declare the role in %DOES.  Note that
+        # this is an autodie specific optimisation, although Class::DOES
+        # can be used to promote this to a true role declaration.
+
+        our %DOES = ( 'autodie::hints::provider' => 1 );
+
+        # Finally, we must define the hints themselves.
+
+       sub AUTODIE_HINTS {
+           return {
+               foo => { scalar => HINTS, list => SOME_HINTS },
+               bar => { scalar => HINTS, list => MORE_HINTS },
+               baz => { fail => HINTS },
+           }
+       }
+
+This allows your code to set hints without relying on C<autodie> and
+C<autodie::hints> being loaded, or even installed.  In this way your
+code can do the right thing when C<autodie> is installed, but does not
+need to depend upon it to function.
+
+=head1 Insisting on hints
+
+When a user-defined subroutine is wrapped by C<autodie>, it will
+use hints if they are available, and otherwise reverts to the
+I<default behaviour> described in the introduction of this document.
+This can be problematic if we expect a hint to exist, but (for
+whatever reason) it has not been loaded.
+
+We can ask autodie to I<insist> that a hint be used by prefixing
+an exclamation mark to the start of the subroutine name.  A lone
+exclamation mark indicates that I<all> subroutines after it must
+have hints declared.
+
+       # foo() and bar() must have their hints defined
+       use autodie qw( !foo !bar baz );
+
+       # Everything must have hints (recommended).
+       use autodie qw( ! foo bar baz );
+
+       # bar() and baz() must have their hints defined
+       use autodie qw( foo ! bar baz );
+
+        # Enable autodie for all of Perl's supported built-ins,
+        # as well as for foo(), bar() and baz().  Everything must
+        # have hints.
+        use autodie qw( ! :all foo bar baz );
+
+If hints are not available for the specified subroutines, this will cause a
+compile-time error.  Insisting on hints for Perl's built-in functions
+(eg, C<open> and C<close>) is always successful.
+
+Insisting on hints is I<strongly> recommended.
+
+=cut
+
+# TODO: implement regular expression hints
+
+use constant UNDEF_ONLY       => sub { not defined $_[0] };
+use constant EMPTY_OR_UNDEF   => sub {
+    ! @_ or
+    @_==1 && !defined $_[0]
+};
+
+use constant EMPTY_ONLY     => sub { @_ == 0 };
+use constant EMPTY_OR_FALSE => sub {
+    ! @_ or
+    @_==1 && !$_[0]
+};
+
+use constant DEFAULT_HINTS => {
+    scalar => UNDEF_ONLY,
+    list   => EMPTY_OR_UNDEF,
+};
+
+use constant HINTS_PROVIDER => 'autodie::hints::provider';
+
+use base qw(Exporter);
+
+our $DEBUG = 0;
+
+# Only ( undef ) is a strange but possible situation for very
+# badly written code.  It's not supported yet.
+
+# TODO: Ugh, those sub refs look awful!  Give them proper
+# names!
+
+my %Hints = (
+    'File::Copy::copy' => {
+        scalar => sub { not $_[0] },
+        list   => sub { @_ == 1 and not $_[0] }
+    },
+    'File::Copy::move' => {
+        scalar => sub { not $_[0] },
+        list   => sub { @_ == 1 and not $_[0] }
+    },
+);
+
+# Start by using Sub::Identify if it exists on this system.
+
+eval { require Sub::Identify; Sub::Identify->import('get_code_info'); };
+
+# If it doesn't exist, we'll define our own.  This code is directly
+# taken from Rafael Garcia's Sub::Identify 0.04, used under the same
+# license as Perl itself.
+
+if ($@) {
+    require B;
+
+    no warnings 'once';
+
+    *get_code_info = sub ($) {
+
+        my ($coderef) = @_;
+        ref $coderef or return;
+        my $cv = B::svref_2object($coderef);
+        $cv->isa('B::CV') or return;
+        # bail out if GV is undefined
+        $cv->GV->isa('B::SPECIAL') and return;
+
+        return ($cv->GV->STASH->NAME, $cv->GV->NAME);
+    };
+
+}
+
+sub sub_fullname {
+    return join( '::', get_code_info( $_[1] ) );
+}
+
+my %Hints_loaded = ();
+
+sub load_hints {
+    my ($class, $sub) = @_;
+
+    my ($package) = ( $sub =~ /(.*)::/ );
+
+    if (not defined $package) {
+        require Carp;
+        Carp::croak(
+            "Internal error in autodie::hints::load_hints - no package found.
+        ");
+    }
+
+    # Do nothing if we've already tried to load hints for
+    # this package.
+    return if $Hints_loaded{$package}++;
+
+    my $hints_available = 0;
+
+    {
+        no strict 'refs';   ## no critic
+
+        if ($package->can('DOES') and $package->DOES(HINTS_PROVIDER) ) {
+            $hints_available = 1;
+        }
+        elsif ( ${"${package}::DOES"}{HINTS_PROVIDER.""} ) {
+            $hints_available = 1;
+        }
+    }
+
+    return if not $hints_available;
+
+    my %package_hints = %{ $package->AUTODIE_HINTS };
+
+    foreach my $sub (keys %package_hints) {
+
+        my $hint = $package_hints{$sub};
+
+        # Ensure we have a package name.
+        $sub = "${package}::$sub" if $sub !~ /::/;
+
+        # TODO - Currently we don't check for conflicts, should we?
+        $Hints{$sub} = $hint;
+
+        $class->normalise_hints(\%Hints, $sub);
+    }
+
+    return;
+
+}
+
+sub normalise_hints {
+    my ($class, $hints, $sub) = @_;
+
+    if ( exists $hints->{$sub}->{fail} ) {
+
+        if ( exists $hints->{$sub}->{scalar} or
+             exists $hints->{$sub}->{list}
+        ) {
+            # TODO: Turn into a proper diagnostic.
+            require Carp;
+            local $Carp::CarpLevel = 1;
+            Carp::croak("fail hints cannot be provided with either scalar or list hints for $sub");
+        }
+
+        # Set our scalar and list hints.
+
+        $hints->{$sub}->{scalar} = 
+        $hints->{$sub}->{list} = delete $hints->{$sub}->{fail};
+
+        return;
+
+    }
+
+    # Check to make sure all our hints exist.
+
+    foreach my $hint (qw(scalar list)) {
+        if ( not exists $hints->{$sub}->{$hint} ) {
+            # TODO: Turn into a proper diagnostic.
+            require Carp;
+            local $Carp::CarpLevel = 1;
+            Carp::croak("$hint hint missing for $sub");
+        }
+    }
+
+    return;
+}
+
+sub get_hints_for {
+    my ($class, $sub) = @_;
+
+    my $subname = $class->sub_fullname( $sub );
+
+    # If we have hints loaded for a sub, then return them.
+
+    if ( exists $Hints{ $subname } ) {
+        return $Hints{ $subname };
+    }
+
+    # If not, we try to load them...
+
+    $class->load_hints( $subname );
+
+    # ...and try again!
+
+    if ( exists $Hints{ $subname } ) {
+        return $Hints{ $subname };
+    }
+
+    # It's the caller's responsibility to use defaults if desired.
+    # This allows on autodie to insist on hints if needed.
+
+    return;
+
+}
+
+sub set_hints_for {
+    my ($class, $sub, $hints) = @_;
+
+    if (ref $sub) {
+        $sub = $class->sub_fullname( $sub );
+
+        require Carp;
+
+        $sub or Carp::croak("Attempts to set_hints_for unidentifiable subroutine");
+    }
+
+    if ($DEBUG) {
+        warn "autodie::hints: Setting $sub to hints: $hints\n";
+    }
+
+    $Hints{ $sub } = $hints;
+
+    $class->normalise_hints(\%Hints, $sub);
+
+    return;
+}
+
+1;
+
+__END__
+
+
+=head1 Diagnostics
+
+=over 4
+
+=item Attempts to set_hints_for unidentifiable subroutine
+
+You've called C<< autodie::hints->set_hints_for() >> using a subroutine
+reference, but that reference could not be resolved back to a
+subroutine name.  It may be an anonymous subroutine (which can't
+be made autodying), or may lack a name for other reasons.
+
+If you receive this error with a subroutine that has a real name,
+then you may have found a bug in autodie.  See L<autodie/BUGS>
+for how to report this.
+
+=item fail hints cannot be provided with either scalar or list hints for %s
+
+When defining hints, you can either supply both C<list> and
+C<scalar> keywords, I<or> you can provide a single C<fail> keyword.
+You can't mix and match them.
+
+=item %s hint missing for %s
+
+You've provided either a C<scalar> hint without supplying
+a C<list> hint, or vice-versa.  You I<must> supply both C<scalar>
+and C<list> hints, I<or> a single C<fail> hint.
+
+=back
+
+=head1 ACKNOWLEDGEMENTS
+
+=over 
+
+=item *
+
+Dr Damian Conway for suggesting the hinting interface and providing the
+example usage.
+
+=item *
+
+Jacinta Richardson for translating much of my ideas into this
+documentation.
+
+=back
+
+=head1 AUTHOR
+
+Copyright 2009, Paul Fenwick E<lt>pjf@perltraining.com.auE<gt>
+
+=head1 LICENSE
+
+This module is free software.  You may distribute it under the
+same terms as Perl itself.
+
+=head1 SEE ALSO
+
+L<autodie>, L<Class::DOES>
+
+=cut
old mode 100644 (file)
new mode 100755 (executable)
old mode 100644 (file)
new mode 100755 (executable)
old mode 100644 (file)
new mode 100755 (executable)
old mode 100644 (file)
new mode 100755 (executable)
old mode 100644 (file)
new mode 100755 (executable)
old mode 100644 (file)
new mode 100755 (executable)
old mode 100644 (file)
new mode 100755 (executable)
old mode 100644 (file)
new mode 100755 (executable)
old mode 100644 (file)
new mode 100755 (executable)
index eeb1a54..ce50b75
@@ -9,9 +9,13 @@ plan 'no_plan';
 # undef if given a list of a single undef.  This mimics the
 # behaviour of many user-defined subs and built-ins (eg: open) that
 # always return undef regardless of context.
+#
+# We also do an 'empty return' if no arguments are passed.  This
+# mimics the PBP guideline for returning nothing.
 
 sub list_mirror {
     return undef if (@_ == 1 and not defined $_[0]);
+    return if not @_;
     return @_;
 
 }
old mode 100644 (file)
new mode 100755 (executable)
old mode 100644 (file)
new mode 100755 (executable)
old mode 100644 (file)
new mode 100755 (executable)
old mode 100644 (file)
new mode 100755 (executable)
old mode 100644 (file)
new mode 100755 (executable)
old mode 100644 (file)
new mode 100755 (executable)
old mode 100644 (file)
new mode 100755 (executable)
old mode 100644 (file)
new mode 100755 (executable)
diff --git a/lib/autodie/t/format-clobber.t b/lib/autodie/t/format-clobber.t
new file mode 100755 (executable)
index 0000000..ee8e8bd
--- /dev/null
@@ -0,0 +1,67 @@
+#!/usr/bin/env perl
+use warnings;
+use strict;
+
+use FindBin;
+use lib "$FindBin::Bin/lib";
+use Test::More tests => 21;
+
+our ($pvio, $pvfm);
+
+use_ok('OtherTypes');
+
+# Since we use use_ok, this is effectively 'compile time'.
+
+ok( defined *OtherTypes::foo{SCALAR},
+    "SCALAR slot intact at compile time" );
+ok( defined *OtherTypes::foo{ARRAY},
+    "ARRAY slot intact at compile time" );
+ok( defined *OtherTypes::foo{HASH},
+    "HASH slot intact at compile time" );
+ok( defined *OtherTypes::foo{IO},
+    "IO slot intact at compile time" );
+ok( defined *OtherTypes::foo{FORMAT},
+    "FORMAT slot intact at compile time" );
+
+is( $OtherTypes::foo, 23,
+    "SCALAR slot correct at compile time" );
+is( $OtherTypes::foo[0], "bar",
+    "ARRAY slot correct at compile time" );
+is( $OtherTypes::foo{mouse}, "trap",
+    "HASH slot correct at compile time" );
+is( *OtherTypes::foo{IO}, $pvio,
+    "IO slot correct at compile time" );
+is( *OtherTypes::foo{FORMAT}, $pvfm,
+    "FORMAT slot correct at compile time" );
+
+eval q{
+    ok( defined *OtherTypes::foo{SCALAR},
+        "SCALAR slot intact at run time" );
+    ok( defined *OtherTypes::foo{ARRAY},
+        "ARRAY slot intact at run time" );
+    ok( defined *OtherTypes::foo{HASH},
+        "HASH slot intact at run time" );
+    ok( defined *OtherTypes::foo{IO},
+        "IO slot intact at run time" );
+
+    TODO: {
+        local $TODO = "Copying formats fails due to a bug in Perl.";
+        ok( defined *OtherTypes::foo{FORMAT},
+            "FORMAT slot intact at run time" );
+    }
+
+    is( $OtherTypes::foo, 23,
+        "SCALAR slot correct at run time" );
+    is( $OtherTypes::foo[0], "bar",
+        "ARRAY slot correct at run time" );
+    is( $OtherTypes::foo{mouse}, "trap",
+        "HASH slot correct at run time" );
+    is( *OtherTypes::foo{IO}, $pvio,
+        "IO slot correct at run time" );
+
+    TODO: {
+        local $TODO = "Copying formats fails due to a bug in Perl.";
+        is( *OtherTypes::foo{FORMAT}, $pvfm,
+            "FORMAT slot correct at run time" );
+    }
+};
diff --git a/lib/autodie/t/hints.t b/lib/autodie/t/hints.t
new file mode 100755 (executable)
index 0000000..a097dab
--- /dev/null
@@ -0,0 +1,115 @@
+#!/usr/bin/perl -w
+use strict;
+use warnings;
+use autodie::hints;
+
+use FindBin;
+use lib "$FindBin::Bin/lib";
+
+use File::Copy qw(copy move cp mv);
+
+use Test::More 'no_plan';
+
+use constant NO_SUCH_FILE  => "this_file_had_better_not_exist";
+use constant NO_SUCH_FILE2 => "this_file_had_better_not_exist_xyzzy";
+
+use constant PERL510 => ( $] >= 5.010 );
+
+use Hints_test qw(
+    fail_on_empty fail_on_false fail_on_undef
+);
+
+use autodie qw(fail_on_empty fail_on_false fail_on_undef);
+
+diag("Sub::Identify ", exists( $INC{'Sub/Identify.pm'} ) ? "is" : "is not",
+     " loaded");
+
+my $hints = "autodie::hints";
+
+# Basic hinting tests
+
+is( $hints->sub_fullname(\&copy), 'File::Copy::copy' , "Id: copy" );
+is( $hints->sub_fullname(\&cp),   'File::Copy::copy' , "Id: cp"   );
+
+is( $hints->sub_fullname(\&move), 'File::Copy::move' , "Id: move" );
+is( $hints->sub_fullname(\&mv),   'File::Copy::move' , "Id: mv"   );
+
+if (PERL510) {
+    ok( $hints->get_hints_for(\&copy)->{scalar}->(0) ,
+        "copy() hints should fail on 0 for scalars."
+    );
+}
+
+# Scalar context test
+
+eval {
+    use autodie qw(copy);
+
+    my $scalar_context = copy(NO_SUCH_FILE, NO_SUCH_FILE2);
+};
+
+isnt("$@", "", "Copying in scalar context should throw an error.");
+isa_ok($@, "autodie::exception");
+
+# List context test.
+
+eval {
+    use autodie qw(copy);
+
+    my @list_context = copy(NO_SUCH_FILE, NO_SUCH_FILE2);
+};
+
+isnt("$@", "", "Copying in list context should throw an error.");
+isa_ok($@, "autodie::exception");
+
+# Tests on loaded funcs.
+
+my %tests = (
+
+    # Test code             # Exception expected?
+
+    'fail_on_empty()'       => 1,
+    'fail_on_empty(0)'      => 0,
+    'fail_on_empty(undef)'  => 0,
+    'fail_on_empty(1)'      => 0,
+
+    'fail_on_false()'       => 1,
+    'fail_on_false(0)'      => 1,
+    'fail_on_false(undef)'  => 1,
+    'fail_on_false(1)'      => 0,
+
+    'fail_on_undef()'       => 1,
+    'fail_on_undef(0)'      => 0,
+    'fail_on_undef(undef)'  => 1,
+    'fail_on_undef(1)'      => 0,
+
+);
+
+# On Perl 5.8, autodie doesn't correctly propagate into string evals.
+# The following snippet forces the use of autodie inside the eval if
+# we really really have to.  For 5.10+, we don't want to include this
+# fix, because the tests will act as a canary if we screw up string
+# eval propagation.
+
+my $perl58_fix = (
+    $] >= 5.010 ?
+    "" :
+    "use autodie qw(fail_on_empty fail_on_false fail_on_undef); "
+);
+
+while (my ($test, $exception_expected) = each %tests) {
+    eval "
+        $perl58_fix
+        my \@array = $test;
+    ";
+
+
+    if ($exception_expected) {
+        isnt("$@", "", $test);
+    }
+    else {
+        is($@, "", $test);
+    }
+}
+
+1;
diff --git a/lib/autodie/t/hints_insist.t b/lib/autodie/t/hints_insist.t
new file mode 100755 (executable)
index 0000000..ab618d2
--- /dev/null
@@ -0,0 +1,23 @@
+#!/usr/bin/perl -w
+use strict;
+use warnings;
+use autodie;
+
+use Test::More tests => 5;
+
+use FindBin qw($Bin);
+use lib "$Bin/lib";
+
+use Hints_provider_does qw(always_pass always_fail no_hints);
+
+eval "use autodie qw( ! always_pass always_fail); ";
+is("$@", "", "Insisting on good hints (distributed insist)");
+
+is(always_pass(), "foo", "Always_pass() should still work");
+is(always_fail(), "foo", "Always_pass() should still work");
+
+eval "use autodie qw(!always_pass !always_fail); ";
+is("$@", "", "Insisting on good hints (individual insist)");
+
+my $ret = eval "use autodie qw(!no_hints); 1;";
+isnt("$@", "", "Asking for non-existent hints");
diff --git a/lib/autodie/t/hints_pod_examples.t b/lib/autodie/t/hints_pod_examples.t
new file mode 100755 (executable)
index 0000000..a3c6f0f
--- /dev/null
@@ -0,0 +1,184 @@
+#!/usr/bin/perl -w
+use strict;
+use warnings;
+use autodie::hints;
+use Test::More;
+
+use constant PERL510 => ( $] >= 5.010 );
+
+BEGIN {
+    if (not PERL510) {
+        plan skip_all => "Only subroutine hints supported in 5.8.x";
+    }
+    else {
+        plan 'no_plan';
+    }
+}
+
+use FindBin;
+use lib "$FindBin::Bin/lib";
+use Hints_pod_examples qw(
+       undef_scalar false_scalar zero_scalar empty_list default_list
+       empty_or_false_list undef_n_error_list foo re_fail bar
+       think_positive my_system
+);
+use autodie qw( !
+       undef_scalar false_scalar zero_scalar empty_list default_list
+       empty_or_false_list undef_n_error_list foo re_fail bar
+       think_positive my_system
+);
+
+my %scalar_tests = (
+
+    # Test code             # Exception expected?
+
+    'undef_scalar()'        => 1,
+    'undef_scalar(1)',      => 0,
+    'undef_scalar(0)',      => 0,
+    'undef_scalar("")',     => 0,
+
+    'false_scalar(0)',      => 1,
+    'false_scalar()',       => 1,
+    'false_scalar(undef)',  => 1,
+    'false_scalar("")',     => 1,
+    'false_scalar(1)',      => 0,
+    'false_scalar("1")',    => 0,
+
+    'zero_scalar("0")',     => 1,
+    'zero_scalar(0)',       => 1,
+    'zero_scalar(1)',       => 0,
+    'zero_scalar(undef)',   => 0,
+    'zero_scalar("")',      => 0,
+
+    'foo(0)',              => 1,
+    'foo(undef)',          => 0,
+    'foo(1)',              => 0,
+
+    'bar(0)',              => 1,
+    'bar(undef)',          => 0,
+    'bar(1)',              => 0,
+
+    're_fail(-1)',          => 0,
+    're_fail("FAIL")',      => 1,
+    're_fail("_FAIL")',     => 1,
+    're_fail("_fail")',     => 0,
+    're_fail("fail")',      => 0,
+
+    'think_positive(-1)'    => 1,
+    'think_positive(-2)'    => 1,
+    'think_positive(0)'     => 0,
+    'think_positive(1)'     => 0,
+    'think_positive(2)'     => 0,
+
+    'my_system(1)'          => 1,
+    'my_system(2)'          => 1,
+    'my_system(0)'          => 0,
+
+);
+
+my %list_tests = (
+
+    'empty_list()',         => 1,
+    'empty_list(())',       => 1,
+    'empty_list([])',       => 0,
+    'empty_list(0)',        => 0,
+    'empty_list("")',       => 0,
+    'empty_list(undef)',    => 0,
+
+    'default_list()',       => 1,
+    'default_list(0)',      => 0,
+    'default_list("")',     => 0,
+    'default_list(undef)',  => 1,
+    'default_list(1)',      => 0,
+    'default_list("str")',  => 0,
+    'default_list(1, 2)',   => 0,
+
+    'empty_or_false_list()',     => 1,
+    'empty_or_false_list(())',   => 1,
+    'empty_or_false_list(0)',    => 1,
+    'empty_or_false_list(undef)',=> 1,
+    'empty_or_false_list("")',   => 1,
+    'empty_or_false_list("0")',  => 1,
+    'empty_or_false_list(1,2)',  => 0,
+    'empty_or_false_list("a")',  => 0,
+
+    'undef_n_error_list(undef, 1)'   => 1,
+    'undef_n_error_list(undef, "a")' => 1,
+    'undef_n_error_list()'           => 0,
+    'undef_n_error_list(0, 1)'       => 0,
+    'undef_n_error_list("", 1)'      => 0,
+    'undef_n_error_list(1)'          => 0,
+
+    'foo(0)',              => 1,
+    'foo(undef)',          => 0,
+    'foo(1)',              => 0,
+
+    'bar(0)',              => 1,
+    'bar(undef)',          => 0,
+    'bar(1)',              => 0,
+
+    're_fail(-1)',          => 1,
+    're_fail("FAIL")',      => 0,
+    're_fail("_FAIL")',     => 0,
+    're_fail("_fail")',     => 0,
+    're_fail("fail")',      => 0,
+
+    'think_positive(-1)'    => 1,
+    'think_positive(-2)'    => 1,
+    'think_positive(0)'     => 0,
+    'think_positive(1)'     => 0,
+    'think_positive(2)'     => 0,
+
+    'my_system(1)'          => 1,
+    'my_system(2)'          => 1,
+    'my_system(0)'          => 0,
+
+);
+
+# On Perl 5.8, autodie doesn't correctly propagate into string evals.
+# The following snippet forces the use of autodie inside the eval if
+# we really really have to.  For 5.10+, we don't want to include this
+# fix, because the tests will act as a canary if we screw up string
+# eval propagation.
+
+my $perl58_fix = (
+    PERL510 ?
+    q{} :
+    q{use autodie qw(
+       undef_scalar false_scalar zero_scalar empty_list default_list
+       empty_or_false_list undef_n_error_list foo re_fail bar
+       think_positive my_system bizarro_system    
+    );}
+);
+
+# Some of the tests provide different hints for scalar or list context
+
+while (my ($test, $exception_expected) = each %scalar_tests) {
+    eval "
+        $perl58_fix
+        my \$scalar = $test;
+    ";
+
+    if ($exception_expected) {
+        isnt("$@", "", "scalar test - $test");
+    }
+    else {
+        is($@, "", "scalar test - $test");
+    }
+}
+
+while (my ($test, $exception_expected) = each %list_tests) {
+    eval "
+        $perl58_fix
+        my \@array = $test;
+    ";
+
+    if ($exception_expected) {
+        isnt("$@", "", "array test - $test");
+    }
+    else {
+        is($@, "", "array test - $test");
+    }
+}
+
+1;
diff --git a/lib/autodie/t/hints_provider_does.t b/lib/autodie/t/hints_provider_does.t
new file mode 100755 (executable)
index 0000000..a671b73
--- /dev/null
@@ -0,0 +1,24 @@
+#!/usr/bin/perl -w
+use strict;
+use warnings;
+use autodie;
+
+use Test::More 'no_plan';
+
+use FindBin qw($Bin);
+use lib "$Bin/lib";
+
+use Hints_provider_does qw(always_pass always_fail);
+use autodie qw(always_pass always_fail);
+
+eval { my $x = always_pass() };
+is("$@", "", "always_pass in scalar context");
+
+eval { my @x = always_pass() };
+is("$@", "", "always_pass in list context");
+
+eval { my $x = always_fail() };
+isnt("$@", "", "always_fail in scalar context");
+
+eval { my @x = always_fail() };
+isnt("$@", "", "always_fail in list context");
diff --git a/lib/autodie/t/hints_provider_easy_does_it.t b/lib/autodie/t/hints_provider_easy_does_it.t
new file mode 100755 (executable)
index 0000000..2606ff8
--- /dev/null
@@ -0,0 +1,24 @@
+#!/usr/bin/perl -w
+use strict;
+use warnings;
+use autodie;
+
+use Test::More 'no_plan';
+
+use FindBin qw($Bin);
+use lib "$Bin/lib";
+
+use Hints_provider_easy_does_it qw(always_pass always_fail);
+use autodie qw(always_pass always_fail);
+
+eval { my $x = always_pass() };
+is("$@", "", "always_pass in scalar context");
+
+eval { my @x = always_pass() };
+is("$@", "", "always_pass in list context");
+
+eval { my $x = always_fail() };
+isnt("$@", "", "always_fail in scalar context");
+
+eval { my @x = always_fail() };
+isnt("$@", "", "always_fail in list context");
diff --git a/lib/autodie/t/hints_provider_isa.t b/lib/autodie/t/hints_provider_isa.t
new file mode 100755 (executable)
index 0000000..022b34f
--- /dev/null
@@ -0,0 +1,24 @@
+#!/usr/bin/perl -w
+use strict;
+use warnings;
+use autodie;
+
+use Test::More 'no_plan';
+
+use FindBin qw($Bin);
+use lib "$Bin/lib";
+
+use Hints_provider_isa qw(always_pass always_fail);
+use autodie qw(always_pass always_fail);
+
+eval { my $x = always_pass() };
+is("$@", "", "always_pass in scalar context");
+
+eval { my @x = always_pass() };
+is("$@", "", "always_pass in list context");
+
+eval { my $x = always_fail() };
+isnt("$@", "", "always_fail in scalar context");
+
+eval { my @x = always_fail() };
+isnt("$@", "", "always_fail in list context");
diff --git a/lib/autodie/t/internal-backcompat.t b/lib/autodie/t/internal-backcompat.t
new file mode 100755 (executable)
index 0000000..9f7196c
--- /dev/null
@@ -0,0 +1,81 @@
+#!/usr/bin/perl -w
+use strict;
+use warnings;
+use Fatal;
+use Test::More 'no_plan';
+
+# Tests to determine if Fatal's internal interfaces remain backwards
+# compatible.
+#
+# WARNING: This file contains a lot of very ugly code, hard-coded
+# strings, and nasty API calls.  It may frighten small children.
+# Viewer discretion is advised.
+
+# fill_protos.  This hasn't been changed since the original Fatal,
+# and so should always be the same.
+
+my %protos = (
+    '$'     => [ [ 1, '$_[0]' ] ],
+    '$$'    => [ [ 2, '$_[0]', '$_[1]' ] ],
+    '$$@'   => [ [ 3, '$_[0]', '$_[1]', '@_[2..$#_]' ] ],
+    '\$'    => [ [ 1, '${$_[0]}' ] ],
+    '\%'    => [ [ 1, '%{$_[0]}' ] ],
+    '\%;$*' => [ [ 1, '%{$_[0]}' ], [ 2, '%{$_[0]}', '$_[1]' ],
+                 [ 3, '%{$_[0]}', '$_[1]', '$_[2]' ] ],
+);
+
+while (my ($proto, $code) = each %protos) {
+    is_deeply( [ Fatal::fill_protos($proto) ], $code, $proto);
+}
+
+# write_invocation tests
+no warnings 'qw';
+
+# Technically the outputted code varies from the classical Fatal.
+# However the changes are mostly whitespace.  Those that aren't are
+# improvements to error messages.
+
+my @write_invocation_calls = (
+    [
+        # Core  # Call          # Name  # Void  # Args
+        [ 1,    'CORE::open',   'open', 0,      [ 1, qw($_[0]) ],
+                                                [ 2, qw($_[0] $_[1]) ],
+                                                [ 3, qw($_[0] $_[1] @_[2..$#_])]
+        ],
+        q{     if (@_ == 1) {
+return CORE::open($_[0]) || croak "Can't open(@_): $!" } elsif (@_ == 2) {
+return CORE::open($_[0], $_[1]) || croak "Can't open(@_): $!"  } elsif (@_ == 3) {
+return CORE::open($_[0], $_[1], @_[2..$#_]) || croak "Can't open(@_): $!"
+            }
+            die "Internal error: open(@_): Do not expect to get ", scalar(@_), " arguments";
+    }
+    ]
+);
+
+foreach my $test (@write_invocation_calls) {
+    is(Fatal::write_invocation( @{ $test->[0] } ), $test->[1], 'write_inovcation');
+}
+
+# one_invocation tests.
+
+my @one_invocation_calls = (
+        # Core  # Call          # Name  # Void   # Args
+    [
+        [ 1,    'CORE::open',   'open', 0,      qw($_[0] $_[1] @_[2..$#_]) ],
+        q{return CORE::open($_[0], $_[1], @_[2..$#_]) || croak "Can't open(@_): $!"},
+    ],
+    [
+        [ 1,    'CORE::open',   'open', 1,      qw($_[0] $_[1] @_[2..$#_]) ],
+        q{return (defined wantarray)?CORE::open($_[0], $_[1], @_[2..$#_]):
+                   CORE::open($_[0], $_[1], @_[2..$#_]) || croak "Can't open(@_): $!"},
+    ],
+);
+
+foreach my $test (@one_invocation_calls) {
+    is(Fatal::one_invocation( @{ $test->[0] } ), $test->[1], 'one_inovcation');
+}
+
+# TODO: _make_fatal
+# Since this subroutine has always started with an underscore,
+# I think it's pretty clear that it's internal-only.  I'm not
+# testing it here, and it doesn't yet have backcompat.
old mode 100644 (file)
new mode 100755 (executable)
old mode 100644 (file)
new mode 100755 (executable)
diff --git a/lib/autodie/t/lib/Hints_pod_examples.pm b/lib/autodie/t/lib/Hints_pod_examples.pm
new file mode 100644 (file)
index 0000000..d88d98e
--- /dev/null
@@ -0,0 +1,108 @@
+package Hints_pod_examples;
+use strict;
+use warnings;
+
+use base qw(Exporter);
+
+our %DOES = ( 'autodie::hints::provider' => 1 );
+
+our @EXPORT_OK = qw(
+       undef_scalar false_scalar zero_scalar empty_list default_list
+       empty_or_false_list undef_n_error_list foo re_fail bar
+       think_positive my_system bizarro_system 
+);
+
+use autodie::hints;
+
+sub AUTODIE_HINTS {
+    return {
+        # Scalar failures always return undef:
+        undef_scalar =>    {  fail => undef  },
+
+        # Scalar failures return any false value [default behaviour]:
+        false_scalar =>    {  fail => sub { return ! $_[0] }  },
+
+        # Scalar failures always return zero explicitly:
+        zero_scalar =>     {  fail => '0'  },
+
+        # List failures always return empty list:
+        # We never want these called in a scalar context
+        empty_list  =>     {  scalar => sub { 1 }, list => []  },
+
+        # List failures return C<()> or C<(undef)> [default expectation]:
+        default_list => {  fail => sub { ! @_ || @_ == 1 && !defined $_[0] }  },
+
+        # List failures return C<()> or a single false value:
+        empty_or_false_list => {  fail => sub { ! @_ || @_ == 1 && !$_[0] }  },
+
+        # List failures return (undef, "some string")
+        undef_n_error_list => {  fail => sub { @_ == 2 && !defined $_[0] }  },
+    };
+}      
+
+# Define some subs that all just return their arguments
+sub undef_scalar { return wantarray ? @_ : $_[0] }
+sub false_scalar { return wantarray ? @_ : $_[0] }
+sub zero_scalar  { return wantarray ? @_ : $_[0] }
+sub empty_list   { return wantarray ? @_ : $_[0] }
+sub default_list { return wantarray ? @_ : $_[0] }
+sub empty_or_false_list { return wantarray ? @_ : $_[0] }
+sub undef_n_error_list { return wantarray ? @_  : $_[0] }
+
+
+# Unsuccessful foo() returns 0 in all contexts...
+autodie::hints->set_hints_for(
+    \&foo,
+    {
+       scalar => 0,
+       list   => [0],
+    }
+);
+
+sub foo { return wantarray ? @_ : $_[0] }
+
+# Unsuccessful re_fail() returns 'FAIL' or '_FAIL' in scalar context,
+#                    returns (-1) in list context...
+autodie::hints->set_hints_for(
+    \&re_fail,
+    {
+       scalar => qr/^ _? FAIL $/xms,
+       list   => [-1],
+    }
+);
+
+sub re_fail { return wantarray ? @_ : $_[0] }
+
+# Unsuccessful bar() returns 0 in all contexts...
+autodie::hints->set_hints_for(
+    \&bar,
+    {
+       scalar => 0,
+       list   => [0],
+    }
+);
+
+sub bar { return wantarray ? @_ : $_[0] }
+
+# Unsuccessful think_positive() returns negative number on failure...
+autodie::hints->set_hints_for(
+    \&think_positive,
+    {
+       scalar => sub { $_[0] < 0 },
+       list   => sub { $_[0] < 0 },
+    }
+);
+
+sub think_positive { return wantarray ? @_ : $_[0] }
+
+# Unsuccessful my_system() returns non-zero on failure...
+autodie::hints->set_hints_for(
+    \&my_system,
+    {
+       scalar => sub { $_[0] != 0 },
+       list   => sub { $_[0] != 0 },
+    }
+);
+sub my_system { return wantarray ? @_ : $_[0] };
+
+1;
diff --git a/lib/autodie/t/lib/Hints_provider_does.pm b/lib/autodie/t/lib/Hints_provider_does.pm
new file mode 100644 (file)
index 0000000..403e4b4
--- /dev/null
@@ -0,0 +1,29 @@
+package Hints_provider_does;
+use strict;
+use warnings;
+use base qw(Exporter);
+
+our @EXPORT_OK = qw(always_fail always_pass no_hints);
+
+sub DOES {
+    my ($class, $arg) = @_;
+
+    return 1 if ($arg eq 'autodie::hints::provider');
+    return $class->SUPER::DOES($arg) if $class->SUPER::can('DOES');
+    return $class->isa($arg);
+}
+
+my $package = __PACKAGE__;
+
+sub AUTODIE_HINTS {
+    return {
+        always_fail => { list => sub { 1 }, scalar => sub { 1 } },
+        always_pass => { list => sub { 0 }, scalar => sub { 0 } },
+    };
+}
+
+sub always_fail { return "foo" };
+sub always_pass { return "foo" };
+sub no_hints    { return "foo" };
+
+1;
diff --git a/lib/autodie/t/lib/Hints_provider_easy_does_it.pm b/lib/autodie/t/lib/Hints_provider_easy_does_it.pm
new file mode 100644 (file)
index 0000000..27dbcb2
--- /dev/null
@@ -0,0 +1,23 @@
+package Hints_provider_easy_does_it;
+use strict;
+use warnings;
+use base qw(Exporter);
+
+our @EXPORT_OK = qw(always_fail always_pass no_hints);
+
+our %DOES = ( 'autodie::hints::provider' => 1 );
+
+my $package = __PACKAGE__;
+
+sub AUTODIE_HINTS {
+    return {
+        always_fail => { list => sub { 1 }, scalar => sub { 1 } },
+        always_pass => { list => sub { 0 }, scalar => sub { 0 } },
+    };
+}
+
+sub always_fail { return "foo" };
+sub always_pass { return "foo" };
+sub no_hints    { return "foo" };
+
+1;
diff --git a/lib/autodie/t/lib/Hints_provider_isa.pm b/lib/autodie/t/lib/Hints_provider_isa.pm
new file mode 100644 (file)
index 0000000..ad15e3b
--- /dev/null
@@ -0,0 +1,25 @@
+package Hints_provider_isa;
+use strict;
+use warnings;
+use base qw(Exporter);
+
+our @EXPORT_OK = qw(always_fail always_pass no_hints);
+
+{ package autodie::hints::provider; }
+
+push(our @ISA, 'autodie::hints::provider');
+
+my $package = __PACKAGE__;
+
+sub AUTODIE_HINTS {
+    return {
+        always_fail => { list => sub { 1 }, scalar => sub { 1 } },
+        always_pass => { list => sub { 0 }, scalar => sub { 0 } },
+    };
+}
+
+sub always_fail { return "foo" };
+sub always_pass { return "foo" };
+sub no_hints    { return "foo" };
+
+1;
diff --git a/lib/autodie/t/lib/Hints_test.pm b/lib/autodie/t/lib/Hints_test.pm
new file mode 100644 (file)
index 0000000..4010788
--- /dev/null
@@ -0,0 +1,42 @@
+package Hints_test;
+use strict;
+use warnings;
+
+use base qw(Exporter);
+
+our @EXPORT_OK = qw(
+    fail_on_empty fail_on_false fail_on_undef
+);
+
+use autodie::hints;
+
+# Create some dummy subs that just return their arguments.
+
+sub fail_on_empty { return @_; }
+sub fail_on_false { return @_; }
+sub fail_on_undef { return @_; }
+
+# Set them to different failure modes when used with autodie.
+
+autodie::hints->set_hints_for(
+    \&fail_on_empty, { 
+        list => autodie::hints::EMPTY_ONLY ,
+        scalar => autodie::hints::EMPTY_ONLY 
+    }
+);
+
+autodie::hints->set_hints_for(
+    \&fail_on_false, {
+        list => autodie::hints::EMPTY_OR_FALSE ,
+        scalar => autodie::hints::EMPTY_OR_FALSE
+    }
+);
+
+autodie::hints->set_hints_for(
+    \&fail_on_undef, {
+        list => autodie::hints::EMPTY_OR_UNDEF ,
+        scalar => autodie::hints::EMPTY_OR_UNDEF 
+    }
+);
+
+1;
diff --git a/lib/autodie/t/lib/OtherTypes.pm b/lib/autodie/t/lib/OtherTypes.pm
new file mode 100644 (file)
index 0000000..122a356
--- /dev/null
@@ -0,0 +1,22 @@
+package OtherTypes;
+no warnings;
+
+our $foo = 23;
+our @foo = "bar";
+our %foo = (mouse => "trap");
+open foo, "<", $0;
+
+format foo =
+foo
+.
+
+BEGIN {
+    $main::pvio = *foo{IO};
+    $main::pvfm = *foo{FORMAT};
+}
+
+sub foo { 1 }
+
+use autodie 'foo';
+
+1;
old mode 100644 (file)
new mode 100755 (executable)
old mode 100644 (file)
new mode 100755 (executable)
old mode 100644 (file)
new mode 100755 (executable)
old mode 100644 (file)
new mode 100755 (executable)
old mode 100644 (file)
new mode 100755 (executable)
old mode 100644 (file)
new mode 100755 (executable)
old mode 100644 (file)
new mode 100755 (executable)
old mode 100644 (file)
new mode 100755 (executable)
old mode 100644 (file)
new mode 100755 (executable)
index 96a0390..65b6a88
@@ -29,11 +29,7 @@ eval {
     my @x = copy(NO_SUCH_FILE, 'xyzzy');
 };
 
-TODO: {
-    local $TODO = "Fixed in 'hints' branch";
-
-    isa_ok($@,EXCEPTION,"This shouldn't change with array context");
-}
+isa_ok($@,EXCEPTION,"This shouldn't change with array context");
 
 # For good measure, test with built-ins.
 
old mode 100644 (file)
new mode 100755 (executable)
index 7e15576..4266804
@@ -21,6 +21,7 @@ $return = eval {
 };
 
 is($return,'foo',"Mytest returns input with autodie");
+is($@,"","No error should be thrown");
 
 $return = eval {
     use autodie qw(mytest);
old mode 100644 (file)
new mode 100755 (executable)
index 7a68f7f..a729129
@@ -1,6 +1,6 @@
 #!/usr/bin/perl -w
 use strict;
-use Test::More tests => 3;
+use Test::More tests => 4;
 
 # For the moment, we'd like all our versions to be the same.
 # In order to play nicely with some code scanners, they need to be
@@ -9,9 +9,11 @@ use Test::More tests => 3;
 
 require Fatal;
 require autodie;
+require autodie::hints;
 require autodie::exception;
 require autodie::exception::system;
 
 is($Fatal::VERSION, $autodie::VERSION);
 is($autodie::VERSION, $autodie::exception::VERSION);
 is($autodie::exception::VERSION, $autodie::exception::system::VERSION);
+is($Fatal::VERSION, $autodie::hints::VERSION);
old mode 100644 (file)
new mode 100755 (executable)