New tlperl part XIV

git-svn-id: svn://tug.org/texlive/trunk@21436 c570f23f-e606-0410-a88d-b1316a301751

3 files changed, 1420 insertions, 0 deletions

diff --git a/Master/tlpkg/tlperl/lib/autodie/exception.pm b/Master/tlpkg/tlperl/lib/autodie/exception.pm
new file mode 100644
index 00000000000..8646099c4c8
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/autodie/exception.pm
@@ -0,0 +1,741 @@
+package autodie::exception;
+use 5.008;
+use strict;
+use warnings;
+use Carp qw(croak);
+
+our $DEBUG = 0;
+
+use overload
+    q{""} => "stringify"
+;
+
+# Overload smart-match only if we're using 5.10
+
+use if ($] >= 5.010), overload => '~~'  => "matches";
+
+our $VERSION = '2.06_01';
+
+my $PACKAGE = __PACKAGE__;  # Useful to have a scalar for hash keys.
+
+=head1 NAME
+
+autodie::exception - Exceptions from autodying functions.
+
+=head1 SYNOPSIS
+
+    eval {
+        use autodie;
+
+        open(my $fh, '<', 'some_file.txt');
+
+        ...
+    };
+
+    if (my $E = $@) {
+        say "Ooops!  ",$E->caller," had problems: $@";
+    }
+
+
+=head1 DESCRIPTION
+
+When an L<autodie> enabled function fails, it generates an
+C<autodie::exception> object.  This can be interrogated to
+determine further information about the error that occurred.
+
+This document is broken into two sections; those methods that
+are most useful to the end-developer, and those methods for
+anyone wishing to subclass or get very familiar with
+C<autodie::exception>.
+
+=head2 Common Methods
+
+These methods are intended to be used in the everyday dealing
+of exceptions.
+
+The following assume that the error has been copied into
+a separate scalar:
+
+    if ($E = $@) {
+        ...
+    }
+
+This is not required, but is recommended in case any code
+is called which may reset or alter C<$@>.
+
+=cut
+
+=head3 args
+
+    my $array_ref = $E->args;
+
+Provides a reference to the arguments passed to the subroutine
+that died.
+
+=cut
+
+sub args        { return $_[0]->{$PACKAGE}{args}; }
+
+=head3 function
+
+    my $sub = $E->function;
+
+The subroutine (including package) that threw the exception.
+
+=cut
+
+sub function   { return $_[0]->{$PACKAGE}{function};  }
+
+=head3 file
+
+    my $file = $E->file;
+
+The file in which the error occurred (eg, C<myscript.pl> or
+C<MyTest.pm>).
+
+=cut
+
+sub file        { return $_[0]->{$PACKAGE}{file};  }
+
+=head3 package
+
+    my $package = $E->package;
+
+The package from which the exceptional subroutine was called.
+
+=cut
+
+sub package     { return $_[0]->{$PACKAGE}{package}; }
+
+=head3 caller
+
+    my $caller = $E->caller;
+
+The subroutine that I<called> the exceptional code.
+
+=cut
+
+sub caller      { return $_[0]->{$PACKAGE}{caller};  }
+
+=head3 line
+
+    my $line = $E->line;
+
+The line in C<< $E->file >> where the exceptional code was called.
+
+=cut
+
+sub line        { return $_[0]->{$PACKAGE}{line};  }
+
+=head3 context
+
+    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.
+
+=cut
+
+sub context     { return $_[0]->{$PACKAGE}{context} }
+
+=head3 return
+
+    my $return_value = $E->return;
+
+The value(s) returned by the failed subroutine.  When the subroutine
+was called in a list context, this will always be a reference to an
+array containing the results.  When the subroutine was called in
+a scalar context, this will be the actual scalar returned.
+
+=cut
+
+sub return      { return $_[0]->{$PACKAGE}{return} }
+
+=head3 errno
+
+    my $errno = $E->errno;
+
+The value of C<$!> at the time when the exception occurred.
+
+B<NOTE>: This method will leave the main C<autodie::exception> class
+and become part of a role in the future.  You should only call
+C<errno> for exceptions where C<$!> would reasonably have been
+set on failure.
+
+=cut
+
+# TODO: Make errno part of a role.  It doesn't make sense for
+# everything.
+
+sub errno       { return $_[0]->{$PACKAGE}{errno}; }
+
+=head3 eval_error
+
+    my $old_eval_error = $E->eval_error;
+
+The contents of C<$@> immediately after autodie triggered an
+exception.  This may be useful when dealing with modules such
+as L<Text::Balanced> that set (but do not throw) C<$@> on error.
+
+=cut
+
+sub eval_error { return $_[0]->{$PACKAGE}{eval_error}; }
+
+=head3 matches
+
+    if ( $e->matches('open') ) { ... }
+
+    if ( $e ~~ 'open' ) { ... }
+
+C<matches> is used to determine whether a
+given exception matches a particular role.  On Perl 5.10,
+using smart-match (C<~~>) with an C<autodie::exception> object
+will use C<matches> underneath.
+
+An exception is considered to match a string if:
+
+=over 4
+
+=item *
+
+For a string not starting with a colon, the string exactly matches the
+package and subroutine that threw the exception.  For example,
+C<MyModule::log>.  If the string does not contain a package name,
+C<CORE::> is assumed.
+
+=item *
+
+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.
+
+=back
+
+=cut
+
+{
+    my (%cache);
+
+    sub matches {
+        my ($this, $that) = @_;
+
+        # TODO - Handle references
+        croak "UNIMPLEMENTED" if ref $that;
+
+        my $sub = $this->function;
+
+        if ($DEBUG) {
+            my $sub2 = $this->function;
+            warn "Smart-matching $that against $sub / $sub2\n";
+        }
+
+        # Direct subname match.
+        return 1 if $that eq $sub;
+        return 1 if $that !~ /:/ and "CORE::$that" eq $sub;
+        return 0 if $that !~ /^:/;
+
+        # Cached match / check tags.
+        require Fatal;
+
+        if (exists $cache{$sub}{$that}) {
+            return $cache{$sub}{$that};
+        }
+
+        # This rather awful looking line checks to see if our sub is in the
+        # list of expanded tags, caches it, and returns the result.
+
+        return $cache{$sub}{$that} = grep { $_ eq $sub } @{ $this->_expand_tag($that) };
+    }
+}
+
+# This exists primarily so that child classes can override or
+# augment it if they wish.
+
+sub _expand_tag {
+    my ($this, @args) = @_;
+
+    return Fatal->_expand_tag(@args);
+}
+
+=head2 Advanced methods
+
+The following methods, while usable from anywhere, are primarily
+intended for developers wishing to subclass C<autodie::exception>,
+write code that registers custom error messages, or otherwise
+work closely with the C<autodie::exception> model.
+
+=cut
+
+# The table below records customer formatters.
+# TODO - Should this be a package var instead?
+# TODO - Should these be in a completely different file, or
+#        perhaps loaded on demand?  Most formatters will never
+#        get used in most programs.
+
+my %formatter_of = (
+    'CORE::close'   => \&_format_close,
+    'CORE::open'    => \&_format_open,
+    'CORE::dbmopen' => \&_format_dbmopen,
+    'CORE::flock'   => \&_format_flock,
+);
+
+# TODO: Our tests only check LOCK_EX | LOCK_NB is properly
+# formatted.  Try other combinations and ensure they work
+# correctly.
+
+sub _format_flock {
+    my ($this) = @_;
+
+    require Fcntl;
+
+    my $filehandle = $this->args->[0];
+    my $raw_mode   = $this->args->[1];
+
+    my $mode_type;
+    my $lock_unlock;
+
+    if ($raw_mode & Fcntl::LOCK_EX() ) {
+        $lock_unlock = "lock";
+        $mode_type = "for exclusive access";
+    }
+    elsif ($raw_mode & Fcntl::LOCK_SH() ) {
+        $lock_unlock = "lock";
+        $mode_type = "for shared access";
+    }
+    elsif ($raw_mode & Fcntl::LOCK_UN() ) {
+        $lock_unlock = "unlock";
+        $mode_type = "";
+    }
+    else {
+        # I've got no idea what they're trying to do.
+        $lock_unlock = "lock";
+        $mode_type = "with mode $raw_mode";
+    }
+
+    my $cooked_filehandle;
+
+    if ($filehandle and not ref $filehandle) {
+
+        # A package filehandle with a name!
+
+        $cooked_filehandle = " $filehandle";
+    }
+    else {
+        # Otherwise we have a scalar filehandle.
+
+        $cooked_filehandle = '';
+
+    }
+
+    local $! = $this->errno;
+
+    return "Can't $lock_unlock filehandle$cooked_filehandle $mode_type: $!";
+
+}
+
+# Default formatter for CORE::dbmopen
+sub _format_dbmopen {
+    my ($this) = @_;
+    my @args   = @{$this->args};
+
+    # TODO: Presently, $args flattens out the (usually empty) hash
+    # which is passed as the first argument to dbmopen.  This is
+    # a bug in our args handling code (taking a reference to it would
+    # be better), but for the moment we'll just examine the end of
+    # our arguments list for message formatting.
+
+    my $mode = $args[-1];
+    my $file = $args[-2];
+
+    # If we have a mask, then display it in octal, not decimal.
+    # We don't do this if it already looks octalish, or doesn't
+    # look like a number.
+
+    if ($mode =~ /^[^\D0]\d+$/) {
+        $mode = sprintf("0%lo", $mode);
+    };
+
+    local $! = $this->errno;
+
+    return "Can't dbmopen(%hash, '$file', $mode): '$!'";
+}
+
+# Default formatter for CORE::close
+
+sub _format_close {
+    my ($this) = @_;
+    my $close_arg = $this->args->[0];
+
+    local $! = $this->errno;
+
+    # If we've got an old-style filehandle, mention it.
+    if ($close_arg and not ref $close_arg) {
+        return "Can't close filehandle '$close_arg': '$!'";
+    }
+
+    # TODO - This will probably produce an ugly error.  Test and fix.
+    return "Can't close($close_arg) filehandle: '$!'";
+
+}
+
+# Default formatter for CORE::open
+
+use constant _FORMAT_OPEN => "Can't open '%s' for %s: '%s'";
+
+sub _format_open_with_mode {
+    my ($this, $mode, $file, $error) = @_;
+
+    my $wordy_mode;
+
+    if    ($mode eq '<')  { $wordy_mode = 'reading';   }
+    elsif ($mode eq '>')  { $wordy_mode = 'writing';   }
+    elsif ($mode eq '>>') { $wordy_mode = 'appending'; }
+
+    return sprintf _FORMAT_OPEN, $file, $wordy_mode, $error if $wordy_mode;
+
+    Carp::confess("Internal autodie::exception error: Don't know how to format mode '$mode'.");
+
+}
+
+sub _format_open {
+    my ($this) = @_;
+
+    my @open_args = @{$this->args};
+
+    # Use the default formatter for single-arg and many-arg open
+    if (@open_args <= 1 or @open_args >= 4) {
+        return $this->format_default;
+    }
+
+    # For two arg open, we have to extract the mode
+    if (@open_args == 2) {
+        my ($fh, $file) = @open_args;
+
+        if (ref($fh) eq "GLOB") {
+            $fh = '$fh';
+        }
+
+        my ($mode) = $file =~ m{
+            ^\s*                # Spaces before mode
+            (
+                (?>             # Non-backtracking subexp.
+                    <           # Reading
+                    |>>?        # Writing/appending
+                )
+            )
+            [^&]                # Not an ampersand (which means a dup)
+        }x;
+
+        if (not $mode) {
+            # Maybe it's a 2-arg open without any mode at all?
+            # Detect the most simple case for this, where our
+            # file consists only of word characters.
+
+            if ( $file =~ m{^\s*\w+\s*$} ) {
+                $mode = '<'
+            }
+            else {
+                # Otherwise, we've got no idea what's going on.
+                # Use the default.
+                return $this->format_default;
+            }
+        }
+
+        # Localising $! means perl make make it a pretty error for us.
+        local $! = $this->errno;
+
+        return $this->_format_open_with_mode($mode, $file, $!);
+    }
+
+    # Here we must be using three arg open.
+
+    my $file = $open_args[2];
+
+    local $! = $this->errno;
+
+    my $mode = $open_args[1];
+
+    local $@;
+
+    my $msg = eval { $this->_format_open_with_mode($mode, $file, $!); };
+
+    return $msg if $msg;
+
+    # Default message (for pipes and odd things)
+
+    return "Can't open '$file' with mode '$open_args[1]': '$!'";
+}
+
+=head3 register
+
+    autodie::exception->register( 'CORE::open' => \&mysub );
+
+The C<register> method allows for the registration of a message
+handler for a given subroutine.  The full subroutine name including
+the package should be used.
+
+Registered message handlers will receive the C<autodie::exception>
+object as the first parameter.
+
+=cut
+
+sub register {
+    my ($class, $symbol, $handler) = @_;
+
+    croak "Incorrect call to autodie::register" if @_ != 3;
+
+    $formatter_of{$symbol} = $handler;
+
+}
+
+=head3 add_file_and_line
+
+    say "Problem occurred",$@->add_file_and_line;
+
+Returns the string C< at %s line %d>, where C<%s> is replaced with
+the filename, and C<%d> is replaced with the line number.
+
+Primarily intended for use by format handlers.
+
+=cut
+
+# Simply produces the file and line number; intended to be added
+# to the end of error messages.
+
+sub add_file_and_line {
+    my ($this) = @_;
+
+    return sprintf(" at %s line %d\n", $this->file, $this->line);
+}
+
+=head3 stringify
+
+    say "The error was: ",$@->stringify;
+
+Formats the error as a human readable string.  Usually there's no
+reason to call this directly, as it is used automatically if an
+C<autodie::exception> object is ever used as a string.
+
+Child classes can override this method to change how they're
+stringified.
+
+=cut
+
+sub stringify {
+    my ($this) = @_;
+
+    my $call        =  $this->function;
+
+    if ($DEBUG) {
+        my $dying_pkg   = $this->package;
+        my $sub   = $this->function;
+        my $caller = $this->caller;
+        warn "Stringifing exception for $dying_pkg :: $sub / $caller / $call\n";
+    }
+
+    # TODO - This isn't using inheritance.  Should it?
+    if ( my $sub = $formatter_of{$call} ) {
+        return $sub->($this) . $this->add_file_and_line;
+    }
+
+    return $this->format_default . $this->add_file_and_line;
+
+}
+
+=head3 format_default
+
+    my $error_string = $E->format_default;
+
+This produces the default error string for the given exception,
+I<without using any registered message handlers>.  It is primarily
+intended to be called from a message handler when they have
+been passed an exception they don't want to format.
+
+Child classes can override this method to change how default
+messages are formatted.
+
+=cut
+
+# TODO: This produces ugly errors.  Is there any way we can
+# dig around to find the actual variable names?  I know perl 5.10
+# does some dark and terrible magicks to find them for undef warnings.
+
+sub format_default {
+    my ($this) = @_;
+
+    my $call        =  $this->function;
+
+    local $! = $this->errno;
+
+    # TODO: This is probably a good idea for CORE, is it
+    # a good idea for other subs?
+
+    # Trim package name off dying sub for error messages.
+    $call =~ s/.*:://;
+
+    # Walk through all our arguments, and...
+    #
+    #   * Replace undef with the word 'undef'
+    #   * Replace globs with the string '$fh'
+    #   * Quote all other args.
+
+    my @args = @{ $this->args() };
+
+    foreach my $arg (@args) {
+       if    (not defined($arg))   { $arg = 'undef' }
+       elsif (ref($arg) eq "GLOB") { $arg = '$fh'   }
+       else                        { $arg = qq{'$arg'} }
+    }
+
+    # Format our beautiful error.
+
+    return "Can't $call(".  join(q{, }, @args) . "): $!" ;
+
+    # TODO - Handle user-defined errors from hash.
+
+    # TODO - Handle default error messages.
+
+}
+
+=head3 new
+
+    my $error = autodie::exception->new(
+        args => \@_,
+        function => "CORE::open",
+        errno => $!,
+        context => 'scalar',
+        return => undef,
+    );
+
+
+Creates a new C<autodie::exception> object.  Normally called
+directly from an autodying function.  The C<function> argument
+is required, its the function we were trying to call that
+generated the exception.  The C<args> parameter is optional.
+
+The C<errno> value is optional.  In versions of C<autodie::exception>
+1.99 and earlier the code would try to automatically use the
+current value of C<$!>, but this was unreliable and is no longer
+supported.
+
+Atrributes such as package, file, and caller are determined
+automatically, and cannot be specified.
+
+=cut
+
+sub new {
+    my ($class, @args) = @_;
+
+    my $this = {};
+
+    bless($this,$class);
+
+    # I'd love to use EVERY here, but it causes our code to die
+    # because it wants to stringify our objects before they're
+    # initialised, causing everything to explode.
+
+    $this->_init(@args);
+
+    return $this;
+}
+
+sub _init {
+
+    my ($this, %args) = @_;
+
+    # Capturing errno here is not necessarily reliable.
+    my $original_errno = $!;
+
+    our $init_called = 1;
+
+    my $class = ref $this;
+
+    # We're going to walk up our call stack, looking for the
+    # first thing that doesn't look like our exception
+    # code, autodie/Fatal, or some whacky eval.
+
+    my ($package, $file, $line, $sub);
+
+    my $depth = 0;
+
+    while (1) {
+        $depth++;
+
+        ($package, $file, $line, $sub) = CORE::caller($depth);
+
+        # Skip up the call stack until we find something outside
+        # of the Fatal/autodie/eval space.
+
+        next if $package->isa('Fatal');
+        next if $package->isa($class);
+        next if $package->isa(__PACKAGE__);
+        next if $file =~ /^\(eval\s\d+\)$/;
+
+        last;
+
+    }
+
+    # We now have everything correct, *except* for our subroutine
+    # name.  If it's __ANON__ or (eval), then we need to keep on
+    # digging deeper into our stack to find the real name.  However we
+    # don't update our other information, since that will be correct
+    # for our current exception.
+
+    my $first_guess_subroutine = $sub;
+
+    while (defined $sub and $sub =~ /^\(eval\)$|::__ANON__$/) {
+        $depth++;
+
+        $sub = (CORE::caller($depth))[3];
+    }
+
+    # 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 the top level of a program.
+
+    if (not defined $sub) {
+        $sub = $first_guess_subroutine;
+    }
+
+    $this->{$PACKAGE}{package} = $package;
+    $this->{$PACKAGE}{file}    = $file;
+    $this->{$PACKAGE}{line}    = $line;
+    $this->{$PACKAGE}{caller}  = $sub;
+    $this->{$PACKAGE}{package} = $package;
+
+    $this->{$PACKAGE}{errno}   = $args{errno} || 0;
+
+    $this->{$PACKAGE}{context} = $args{context};
+    $this->{$PACKAGE}{return}  = $args{return};
+    $this->{$PACKAGE}{eval_error}  = $args{eval_error};
+
+    $this->{$PACKAGE}{args}    = $args{args} || [];
+    $this->{$PACKAGE}{function}= $args{function} or
+              croak("$class->new() called without function arg");
+
+    return $this;
+
+}
+
+1;
+
+__END__
+
+=head1 SEE ALSO
+
+L<autodie>, L<autodie::exception::system>
+
+=head1 LICENSE
+
+Copyright (C)2008 Paul Fenwick
+
+This is free software.  You may modify and/or redistribute this
+code under the same terms as Perl 5.10 itself, or, at your option,
+any later version of Perl 5.
+
+=head1 AUTHOR
+
+Paul Fenwick E<lt>pjf@perltraining.com.auE<gt>
diff --git a/Master/tlpkg/tlperl/lib/autodie/exception/system.pm b/Master/tlpkg/tlperl/lib/autodie/exception/system.pm
new file mode 100644
index 00000000000..07cd1c9a038
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/autodie/exception/system.pm
@@ -0,0 +1,81 @@
+package autodie::exception::system;
+use 5.008;
+use strict;
+use warnings;
+use base 'autodie::exception';
+use Carp qw(croak);
+
+our $VERSION = '2.06_01';
+
+my $PACKAGE = __PACKAGE__;
+
+=head1 NAME
+
+autodie::exception::system - Exceptions from autodying system().
+
+=head1 SYNOPSIS
+
+    eval {
+        use autodie qw(system);
+
+        system($cmd, @args);
+
+    };
+
+    if (my $E = $@) {
+        say "Ooops!  ",$E->caller," had problems: $@";
+    }
+
+
+=head1 DESCRIPTION
+
+This is a L<autodie::exception> class for failures from the
+C<system> command.
+
+Presently there is no way to interrogate an C<autodie::exception::system>
+object for the command, exit status, and other information you'd expect
+such an object to hold.  The interface will be expanded to accommodate
+this in the future.
+
+=cut
+
+sub _init {
+    my ($this, %args) = @_;
+
+    $this->{$PACKAGE}{message} = $args{message}
+        || croak "'message' arg not supplied to autodie::exception::system->new";
+
+    return $this->SUPER::_init(%args);
+
+}
+
+=head2 stringify
+
+When stringified, C<autodie::exception::system> objects currently
+use the message generated by L<IPC::System::Simple>.
+
+=cut
+
+sub stringify {
+
+    my ($this) = @_;
+
+    return $this->{$PACKAGE}{message} . $this->add_file_and_line;
+
+}
+
+1;
+
+__END__
+
+=head1 LICENSE
+
+Copyright (C)2008 Paul Fenwick
+
+This is free software.  You may modify and/or redistribute this
+code under the same terms as Perl 5.10 itself, or, at your option,
+any later version of Perl 5.
+
+=head1 AUTHOR
+
+Paul Fenwick E<lt>pjf@perltraining.com.auE<gt>
diff --git a/Master/tlpkg/tlperl/lib/autodie/hints.pm b/Master/tlpkg/tlperl/lib/autodie/hints.pm
new file mode 100644
index 00000000000..e7be03a047a
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/autodie/hints.pm
@@ -0,0 +1,598 @@
+package autodie::hints;
+
+use strict;
+use warnings;
+
+use constant PERL58 => ( $] < 5.009 );
+
+our $VERSION = '2.06_01';
+
+=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" 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 to 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 and list contexts.  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 an 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 SINGLE_TRUE => sub { @_ == 1 and not $_[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.
+
+my %Hints = (
+    'File::Copy::copy' => { scalar => SINGLE_TRUE, list => SINGLE_TRUE },
+    'File::Copy::move' => { scalar => SINGLE_TRUE, list => SINGLE_TRUE },
+    'File::Copy::cp'   => { scalar => SINGLE_TRUE, list => SINGLE_TRUE },
+    'File::Copy::mv'   => { scalar => SINGLE_TRUE, list => SINGLE_TRUE },
+);
+
+# 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 ( PERL58 and $package->isa(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