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
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
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';
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()";
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;
':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)],
':1.997' => [qw(:default)],
':1.998' => [qw(:default)],
':1.999' => [qw(:default)],
+ ':1.999_01' => [qw(:default)],
+ ':2.00' => [qw(:default)],
);
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.
# 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();
# 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.
# 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.
# 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}++;
# 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 };
}
}
# 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;
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";
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
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.");
};
}
# 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') {
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(
}
- # 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 => \$!,
)
};
# 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;
# 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 =~ /::/;
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
} 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();
}
# 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';
$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";
$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;
# 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");
}
}
# 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;
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: $!";
}
our $VERSION;
BEGIN {
- $VERSION = "1.999";
+ $VERSION = '2.00';
}
use constant ERROR_WRONG_FATAL => q{
=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
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
=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.
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
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
=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
=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>
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
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.
sub matches {
my ($this, $that) = @_;
- # XXX - Handle references
+ # TODO - Handle references
croak "UNIMPLEMENTED" if ref $that;
my $sub = $this->function;
# 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;
use base 'autodie::exception';
use Carp qw(croak);
-our $VERSION = '1.999';
+our $VERSION = '2.00';
my $PACKAGE = __PACKAGE__;
--- /dev/null
+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
# 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 @_;
}
--- /dev/null
+#!/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" );
+ }
+};
--- /dev/null
+#!/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(\©), '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(\©)->{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;
--- /dev/null
+#!/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");
--- /dev/null
+#!/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;
--- /dev/null
+#!/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");
--- /dev/null
+#!/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");
--- /dev/null
+#!/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");
--- /dev/null
+#!/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.
--- /dev/null
+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;
--- /dev/null
+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;
--- /dev/null
+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;
--- /dev/null
+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;
--- /dev/null
+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;
--- /dev/null
+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;
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.
};
is($return,'foo',"Mytest returns input with autodie");
+is($@,"","No error should be thrown");
$return = eval {
use autodie qw(mytest);
#!/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
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);
projects / p5sagit/p5-mst-13.2.git / commitdiff