From: Paul Fenwick Date: Wed, 1 Jul 2009 13:34:21 +0000 (+1000) Subject: autodie 2.03 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=eb8d423fedc51cab74c8f3c999e4055d7b90f515;p=p5sagit%2Fp5-mst-13.2.git autodie 2.03 G'day Everyone, Attached is a patch that brings blead up to autodie 2.03. The failing tests are fixed, and a number of nits have been picked. Full changes below, as well as in the commit message. Cheerio, Paul Revision history for autodie * TEST: Removed spurious warning about insufficient credit. 2.03 Wed Jul 1 15:39:16 AUSEST 2009 * BUGFIX: Stopped blog_hints.t from booching under Perl 5.8.x. because parent.pm is not installed. 2.02 Wed Jul 1 15:06:21 AUSEST 2009 * FEATURE: autodie::exception now supports ->context() to discover the context of the failing subroutine, and ->return() to get a list of what it returned. * BUGFIX: ->function from autodie::exception now returns the original name of the dying sub, rather than its imported name. For example, 'File::Copy::copy' rather than 'main::copy'. Core functions continue to always return 'CORE::whatever'. * TEST: blog_hints.t tests new hinting features against examples in my blog at http://pjf.id.au/blog/ 2.01 Wed Jul 1 01:31:24 AUSEST 2009 * DOCUMENTATION: General copyediting and tidy-up (Thanks to Toby Corkindale) * BUGFIX: Warnings are no longer emitted when undefined values are compared by hinting routines. * BUGFIX: Hints for File::Copy now operate correctly under Perl 5.10.1. * BUGFIX: Inheritance is now considered sufficient to declare allegiance to the hints provider role under Perl 5.8.x. (Thanks to Glenn Fowler) * TEST: hints.t no longer throws failures under Perl 5.10.1. * TEST: pod-coverage.t (author test) no longer fails if Sub::Identify is not installed. (Thanks to Jonathan Yu. RT #47437) -- Paul Fenwick | http://perltraining.com.au/ Director of Training | Ph: +61 3 9354 6001 Perl Training Australia | Fax: +61 3 9354 2681 From 715681c17c0f3f9f7a09971007c4c4de0d122c60 Mon Sep 17 00:00:00 2001 From: Paul Fenwick Date: Wed, 1 Jul 2009 23:30:58 +1000 Subject: [PATCH] Merge autodie 2.03 into core. Revision history for autodie * TEST: Removed spurious warning about insufficient credit. 2.03 Wed Jul 1 15:39:16 AUSEST 2009 * BUGFIX: Stopped blog_hints.t from booching under Perl 5.8.x. because parent.pm is not installed. 2.02 Wed Jul 1 15:06:21 AUSEST 2009 * FEATURE: autodie::exception now supports ->context() to discover the context of the failing subroutine, and ->return() to get a list of what it returned. * BUGFIX: ->function from autodie::exception now returns the original name of the dying sub, rather than its imported name. For example, 'File::Copy::copy' rather than 'main::copy'. Core functions continue to always return 'CORE::whatever'. * TEST: blog_hints.t tests new hinting features against examples in my blog at http://pjf.id.au/blog/ 2.01 Wed Jul 1 01:31:24 AUSEST 2009 * DOCUMENTATION: General copyediting and tidy-up (Thanks to Toby Corkindale) * BUGFIX: Warnings are no longer emitted when undefined values are compared by hinting routines. * BUGFIX: Hints for File::Copy now operate correctly under Perl 5.10.1. * BUGFIX: Inheritance is now considered sufficient to declare allegiance to the hints provider role under Perl 5.8.x. (Thanks to Glenn Fowler) * TEST: hints.t no longer throws failures under Perl 5.10.1. * TEST: pod-coverage.t (author test) no longer fails if Sub::Identify is not installed. (Thanks to Jonathan Yu. RT #47437) Signed-off-by: H.Merijn Brand --- diff --git a/MANIFEST b/MANIFEST index e839825..ded3e46 100644 --- a/MANIFEST +++ b/MANIFEST @@ -1779,6 +1779,7 @@ lib/autodie/t/autodie_test_module.pm autodie - test helper lib/autodie/t/backcompat.t autodie - More Fatal backcompat lib/autodie/t/basic_exceptions.t autodie - Basic exception tests lib/autodie/t/binmode.t autodie - Binmode testing +lib/autodie/t/blog_hints.t autodie - Tests fro PJF's blog lib/autodie/t/caller.t autodie - Caller diagnostics lib/autodie/t/context_lexical.t autodie - Context clobbering lexically lib/autodie/t/context.t autodie - Context clobbering tests @@ -1812,9 +1813,11 @@ 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/my/autodie.pm autodie - blog_hints.t helper 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/lib/Some/Module.pm autodie - blog_hints.t helper lib/autodie/t/mkdir.t autodie - filesystem tests lib/autodie/t/open.t autodie - Testing open lib/autodie/t/recv.t autodie - send/recv tests diff --git a/lib/Fatal.pm b/lib/Fatal.pm index 9caa01e..e65cc57 100644 --- a/lib/Fatal.pm +++ b/lib/Fatal.pm @@ -39,7 +39,7 @@ use constant ERROR_58_HINTS => q{Non-subroutine %s hints for %s are not supporte use constant MIN_IPC_SYS_SIMPLE_VER => 0.12; # All the Fatal/autodie modules share the same version number. -our $VERSION = '2.00'; +our $VERSION = '2.03'; our $Debug ||= 0; @@ -95,6 +95,9 @@ my %TAGS = ( ':1.999' => [qw(:default)], ':1.999_01' => [qw(:default)], ':2.00' => [qw(:default)], + ':2.01' => [qw(:default)], + ':2.02' => [qw(:default)], + ':2.03' => [qw(:default)], ); @@ -630,6 +633,13 @@ sub _one_invocation { require autodie::hints; $hints = autodie::hints->get_hints_for( $sref ); + + # We'll look up the sub's fullname. This means we + # get better reports of where it came from in our + # error messages, rather than what imported it. + + $human_sub_name = autodie::hints->sub_fullname( $sref ); + } # Checks for special core subs. @@ -685,6 +695,7 @@ sub _one_invocation { die $class->throw( function => q{$human_sub_name}, args => [ @argv ], pragma => q{$class}, errno => \$!, + context => \$context, return => \$retval, ) }; @@ -710,6 +721,8 @@ sub _one_invocation { return qq{ + my \$context = wantarray() ? "list" : "scalar"; + # Try to flock. If successful, return it immediately. my \$retval = $call(@argv); @@ -734,11 +747,16 @@ sub _one_invocation { # the 'unopened' warning class here. Especially since they # then report the wrong line number. + # Other warnings are disabled because they produce excessive + # complaints from smart-match hints under 5.10.1. + my $code = qq[ - no warnings qw(unopened); + no warnings qw(unopened uninitialized numeric); if (wantarray) { my \@results = $call(@argv); + my \$retval = \\\@results; + my \$context = "list"; ]; @@ -783,7 +801,8 @@ sub _one_invocation { # at the result. $code .= qq{ - my \$result = $call(@argv); + my \$retval = $call(@argv); + my \$context = "scalar"; }; if ( $hints and ( ref($hints->{scalar} ) || "" ) eq 'CODE' ) { @@ -792,17 +811,17 @@ sub _one_invocation { # works in 5.8.x, and always works in 5.10.1 return $code .= qq{ - if ( \$hints->{scalar}->(\$result) ) { $die }; - return \$result; + if ( \$hints->{scalar}->(\$retval) ) { $die }; + return \$retval; }; } elsif (PERL510 and $hints) { return $code . qq{ - if ( \$result ~~ \$hints->{scalar} ) { $die }; + if ( \$retval ~~ \$hints->{scalar} ) { $die }; - return \$result; + return \$retval; }; } elsif ( $hints ) { @@ -812,13 +831,13 @@ sub _one_invocation { return $code . ( $use_defined_or ? qq{ - $die if not defined \$result; + $die if not defined \$retval; - return \$result; + return \$retval; } : qq{ - return \$result || $die; + return \$retval || $die; } ) ; diff --git a/lib/autodie.pm b/lib/autodie.pm index b5756d4..72f312e 100644 --- a/lib/autodie.pm +++ b/lib/autodie.pm @@ -8,7 +8,7 @@ our @ISA = qw(Fatal); our $VERSION; BEGIN { - $VERSION = '2.00'; + $VERSION = '2.03'; } use constant ERROR_WRONG_FATAL => q{ @@ -254,7 +254,7 @@ 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 can be enabled for all of Perl's built-ins, including C and C with: use autodie qw(:all); @@ -329,8 +329,8 @@ element. =item :void cannot be used with lexical scope 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. +C. To workaround this, C may be explicitly disabled until +the end of the current block with C. To disable autodie for only a single function (eg, open) use C. @@ -348,8 +348,8 @@ See also L. =head1 BUGS "Used only once" warnings can be generated when C or C -is used with package filehandles (eg, C). It's strongly recommended -you use scalar filehandles instead. +is used with package filehandles (eg, C). Scalar filehandles are +strongly recommended instead. Under Perl 5.8 only, C I propagate into string C statements, although it can be explicitly enabled inside a string diff --git a/lib/autodie/exception.pm b/lib/autodie/exception.pm index 05f3f7d..364b134 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 = '2.00'; +our $VERSION = '2.03'; my $PACKAGE = __PACKAGE__; # Useful to have a scalar for hash keys. @@ -127,6 +127,31 @@ The line in C<< $E->file >> where the exceptional code was called. sub line { return $_[0]->{$PACKAGE}{line}; } +=head3 context + + my $context = $E->context; + +The context in which the subroutine was called. This can be +'list', 'scalar', or undefined (unknown). It will never be 'void', as +C always captures the return value in one way or another. + +=cut + +sub context { return $_[0]->{$PACKAGE}{context} } + +=head3 return + + my $return_value = $E->return; + +The value(s) returned by the failed subroutine. When the subroutine +was called in a list context, this will always be a reference to an +array containing the results. When the subroutine was called in +a scalar context, this will be the actual scalar returned. + +=cut + +sub return { return $_[0]->{$PACKAGE}{return} } + =head3 errno my $errno = $E->errno; @@ -558,6 +583,8 @@ sub format_default { args => \@_, function => "CORE::open", errno => $!, + context => 'scalar', + return => undef, ); @@ -658,6 +685,9 @@ sub _init { $this->{$PACKAGE}{errno} = $args{errno} || 0; + $this->{$PACKAGE}{context} = $args{context}; + $this->{$PACKAGE}{return} = $args{return}; + $this->{$PACKAGE}{args} = $args{args} || []; $this->{$PACKAGE}{function}= $args{function} or croak("$class->new() called without function arg"); diff --git a/lib/autodie/exception/system.pm b/lib/autodie/exception/system.pm index d51398b..d7be816 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 = '2.00'; +our $VERSION = '2.03'; my $PACKAGE = __PACKAGE__; diff --git a/lib/autodie/hints.pm b/lib/autodie/hints.pm index bd42118..71b371a 100644 --- a/lib/autodie/hints.pm +++ b/lib/autodie/hints.pm @@ -3,7 +3,9 @@ package autodie::hints; use strict; use warnings; -our $VERSION = '2.00'; +use constant PERL58 => ( $] < 5.009 ); + +our $VERSION = '2.03'; =head1 NAME @@ -79,7 +81,7 @@ A list containing a single undef, in list context 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 +with returns a string containing the word "FAIL" upon failure, or a two element list containing C<(undef, "human error message")>. To make autodie work with these sorts of subroutines, we have the I. @@ -94,15 +96,15 @@ of C itself. 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. +C considers the subroutine to 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 +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 +Hints can be provided for both scalar and list contexts. 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 @@ -129,7 +131,7 @@ The most common context-specific hints are: # Scalar failures always return zero explicitly: { scalar => '0' } - # List failures always return empty list: + # List failures always return an empty list: { list => [] } # List failures return () or (undef) [default expectation]: @@ -158,7 +160,7 @@ The most common context-specific hints are: 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 @@ -256,7 +258,7 @@ 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; + package Your::Module; # We can use the Class::DOES from the CPAN to declare adherence # to a role. @@ -333,11 +335,14 @@ use constant EMPTY_OR_FALSE => sub { @_==1 && !$_[0] }; +use constant SINGLE_TRUE => sub { @_ == 1 and not $_[0] }; + use constant DEFAULT_HINTS => { scalar => UNDEF_ONLY, list => EMPTY_OR_UNDEF, }; + use constant HINTS_PROVIDER => 'autodie::hints::provider'; use base qw(Exporter); @@ -347,18 +352,11 @@ 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] } - }, + 'File::Copy::copy' => { scalar => SINGLE_TRUE, list => SINGLE_TRUE }, + 'File::Copy::move' => { scalar => SINGLE_TRUE, list => SINGLE_TRUE }, + 'File::Copy::cp' => { scalar => SINGLE_TRUE, list => SINGLE_TRUE }, + 'File::Copy::mv' => { scalar => SINGLE_TRUE, list => SINGLE_TRUE }, ); # Start by using Sub::Identify if it exists on this system. @@ -418,6 +416,9 @@ sub load_hints { if ($package->can('DOES') and $package->DOES(HINTS_PROVIDER) ) { $hints_available = 1; } + elsif ( PERL58 and $package->isa(HINTS_PROVIDER) ) { + $hints_available = 1; + } elsif ( ${"${package}::DOES"}{HINTS_PROVIDER.""} ) { $hints_available = 1; } diff --git a/lib/autodie/t/basic_exceptions.t b/lib/autodie/t/basic_exceptions.t index 56876be..c732dd5 100755 --- a/lib/autodie/t/basic_exceptions.t +++ b/lib/autodie/t/basic_exceptions.t @@ -1,7 +1,7 @@ #!/usr/bin/perl -w use strict; -use Test::More tests => 17; +use Test::More tests => 19; use constant NO_SUCH_FILE => "this_file_had_better_not_exist"; @@ -28,6 +28,8 @@ is($@->args->[1], '<', 'Correct mode arg'); is($@->args->[2], NO_SUCH_FILE, 'Correct filename arg'); ok($@->matches('open'), 'Looks like an error from open'); ok($@->matches(':io'), 'Looks like an error from :io'); +is($@->context, 'scalar', 'Open called in scalar/void context'); +is($@->return,undef,'Open should return undef on failure'); # Testing of caller info with a real subroutine. diff --git a/lib/autodie/t/blog_hints.t b/lib/autodie/t/blog_hints.t new file mode 100755 index 0000000..395cb14 --- /dev/null +++ b/lib/autodie/t/blog_hints.t @@ -0,0 +1,30 @@ +#!/usr/bin/perl -w +use strict; +use warnings; +use Test::More 'no_plan'; + +use FindBin; +use lib "$FindBin::Bin/lib"; + +use Some::Module qw(some_sub); +use my::autodie qw(! some_sub); + +eval { some_sub() }; + +isnt("$@", "", "some_sub should die in void/scalar context"); + +isa_ok($@, 'autodie::exception'); +is($@->context, 'scalar'); +is($@->function, 'Some::Module::some_sub'); +like("$@", qr/can't be called in scalar context/); + +my @returns = eval { some_sub(0); }; +is($@, "", "Good call to some_sub"); +is_deeply(\@returns, [1,2,3], "Returns unmolested"); + +@returns = eval { some_sub(1) }; + +isnt("$@",""); +is($@->return->[0], undef); +is($@->return->[1], 'Insufficient credit'); +like("$@", qr/Insufficient credit/); diff --git a/lib/autodie/t/hints.t b/lib/autodie/t/hints.t index a097dab..ec1ef32 100755 --- a/lib/autodie/t/hints.t +++ b/lib/autodie/t/hints.t @@ -13,7 +13,8 @@ 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 constant PERL510 => ( $] >= 5.0100 ); +use constant PERL5101 => ( $] >= 5.0101 ); use Hints_test qw( fail_on_empty fail_on_false fail_on_undef @@ -29,15 +30,23 @@ 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(\&cp), + PERL5101 ? 'File::Copy::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" ); +is( $hints->sub_fullname(\&mv), + PERL5101 ? 'File::Copy::mv' : 'File::Copy::move' , "Id: mv" +); if (PERL510) { ok( $hints->get_hints_for(\©)->{scalar}->(0) , "copy() hints should fail on 0 for scalars." ); + ok( $hints->get_hints_for(\©)->{list}->(0) , + "copy() hints should fail on 0 for lists." + ); } # Scalar context test @@ -51,6 +60,10 @@ eval { isnt("$@", "", "Copying in scalar context should throw an error."); isa_ok($@, "autodie::exception"); +is($@->function, "File::Copy::copy", "Function should be original name"); +is($@->return, 0, "File::Copy returns zero on failure"); +is($@->context, "scalar", "File::Copy called in scalar context"); + # List context test. eval { @@ -62,6 +75,10 @@ eval { isnt("$@", "", "Copying in list context should throw an error."); isa_ok($@, "autodie::exception"); +is($@->function, "File::Copy::copy", "Function should be original name"); +is_deeply($@->return, [0], "File::Copy returns zero on failure"); +is($@->context, "list", "File::Copy called in list context"); + # Tests on loaded funcs. my %tests = ( diff --git a/lib/autodie/t/lib/Some/Module.pm b/lib/autodie/t/lib/Some/Module.pm new file mode 100644 index 0000000..a24ec93 --- /dev/null +++ b/lib/autodie/t/lib/Some/Module.pm @@ -0,0 +1,21 @@ +package Some::Module; +use strict; +use warnings; +use base qw(Exporter); + +our @EXPORT_OK = qw(some_sub); + +# This is an example of a subroutine that returns (undef, $msg) +# to signal failure. + +sub some_sub { + my ($arg) = @_; + + if ($arg) { + return (undef, "Insufficient credit"); + } + + return (1,2,3); +} + +1; diff --git a/lib/autodie/t/lib/my/autodie.pm b/lib/autodie/t/lib/my/autodie.pm new file mode 100644 index 0000000..1ad1250 --- /dev/null +++ b/lib/autodie/t/lib/my/autodie.pm @@ -0,0 +1,30 @@ +package my::autodie; +use strict; +use warnings; + +use base qw(autodie); +use autodie::exception; +use autodie::hints; + +autodie::hints->set_hints_for( + 'Some::Module::some_sub' => { + scalar => sub { 1 }, # No calling in scalar/void context + list => sub { @_ == 2 and not defined $_[0] } + }, +); + +autodie::exception->register( + 'Some::Module::some_sub' => sub { + my ($E) = @_; + + if ($E->context eq "scalar") { + return "some_sub() can't be called in scalar context"; + } + + my $error = $E->return->[1]; + + return "some_sub() failed: $error"; + } +); + +1;