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