diff --git a/lib/Fatal.pm b/lib/Fatal.pm index d84dc1e..73ca368 100644 --- a/lib/Fatal.pm +++ b/lib/Fatal.pm @@ -17,7 +17,12 @@ use autodie::Util qw( on_end_of_compile_scope ); -use constant PERL510 => ( $] >= 5.010 ); +use constant SMARTMATCH_ALLOWED => ( $] >= 5.010 && $] < 5.041 ); +use constant SMARTMATCH_CATEGORY => ( + !SMARTMATCH_ALLOWED || $] < 5.018 ? undef + : exists $warnings::Offsets{'experimental::smartmatch'} ? 'experimental::smartmatch' + : 'deprecated' +); use constant LEXICAL_TAG => q{:lexical}; use constant VOID_TAG => q{:void}; @@ -48,7 +53,9 @@ 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}; +use constant ERROR_SMARTMATCH_HINTS => q{%s hints for %s must be code, regexp, or undef. Use of other values is deprecated and only supported on Perl 5.10 through 5.40.}; + +use constant WARNING_SMARTMATCH_DEPRECATED => q{%s hints for %s must be code, regexp, or undef. Use of other values is deprecated and will be removed before Perl 5.42.}; # Older versions of IPC::System::Simple don't support all the # features we need. @@ -1089,8 +1096,6 @@ sub _one_invocation { my $code = qq[ no warnings qw(unopened uninitialized numeric); - no if \$\] >= 5.017011, warnings => "experimental::smartmatch"; - no if \$warnings::Offsets{"deprecated::smartmatch"}, warnings => "deprecated"; if (wantarray) { my \@results = $call(@argv); @@ -1101,25 +1106,37 @@ sub _one_invocation { my $retval_action = $Retval_action{$call} || ''; - if ( $hints and ( ref($hints->{list} ) || "" ) eq 'CODE' ) { + if ( $hints && exists $hints->{list} ) { + my $match; + if ( 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. - # 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. + $match = q[ $hints->{list}->(@results) ]; + } + elsif ( ref($hints->{list}) eq 'Regexp' ) { + $match = q[ grep $_ =~ $hints->{list}, @results ]; + } + elsif ( !defined $hints->{list} ) { + $match = q[ grep !defined, @results ]; + } + elsif ( SMARTMATCH_ALLOWED ) { + $match = q[ @results ~~ $hints->{list} ]; + warnings::warnif('deprecated', sprintf(WARNING_SMARTMATCH_DEPRECATED, 'list', $sub)); + if (SMARTMATCH_CATEGORY) { + $match = sprintf q[ do { no warnings '%s'; %s } ], SMARTMATCH_CATEGORY, $match; + } + } + else { + croak sprintf(ERROR_SMARTMATCH_HINTS, 'list', $sub); + } $code .= qq{ - if ( \$hints->{list}->(\@results) ) { $die }; - }; - } - elsif ( PERL510 and $hints ) { - $code .= qq{ - if ( \@results ~~ \$hints->{list} ) { $die }; + if ( $match ) { $die }; }; } - elsif ( $hints ) { - croak sprintf(ERROR_58_HINTS, 'list', $sub); - } else { $code .= qq{ # An empty list, or a single undef is failure @@ -1146,29 +1163,37 @@ sub _one_invocation { my \$context = "scalar"; }; - 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 + if ( $hints && exists $hints->{scalar} ) { + my $match; - return $code .= qq{ - if ( \$hints->{scalar}->(\$retval) ) { $die }; - $retval_action - return \$retval; - }; + if ( 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 + $match = q[ $hints->{scalar}->($retval) ]; + } + elsif ( ref($hints->{scalar}) eq 'Regexp' ) { + $match = q[ $retval =~ $hints->{scalar} ]; + } + elsif ( !defined $hints->{scalar} ) { + $match = q[ !defined $retval ]; + } + elsif (SMARTMATCH_ALLOWED) { + $match = q[ $retval ~~ $hints->{scalar} ]; + warnings::warnif('deprecated', sprintf(WARNING_SMARTMATCH_DEPRECATED, 'scalar', $sub)); + if (SMARTMATCH_CATEGORY) { + $match = sprintf q[ do { no warnings '%s'; %s } ], SMARTMATCH_CATEGORY, $match; + } + } + else { + croak sprintf(ERROR_SMARTMATCH_HINTS, 'scalar', $sub); + } - } - elsif (PERL510 and $hints) { return $code . qq{ - - if ( \$retval ~~ \$hints->{scalar} ) { $die }; + if ( $match ) { $die }; $retval_action return \$retval; }; } - elsif ( $hints ) { - croak sprintf(ERROR_58_HINTS, 'scalar', $sub); - } return $code . ( $use_defined_or ? qq{ diff --git a/lib/autodie/exception.pm b/lib/autodie/exception.pm index a6f2e24..f27a4f8 100644 --- a/lib/autodie/exception.pm +++ b/lib/autodie/exception.pm @@ -14,8 +14,8 @@ our $DEBUG = 0; use overload q{""} => "stringify", # Overload smart-match only if we're using 5.10 or up - ($] >= 5.010 ? ('~~' => "matches") : ()), - fallback => 1 + (( $] >= 5.010 && $] < 5.041 ) ? ('~~' => "matches") : ()), + fallback => 1, ; my $PACKAGE = __PACKAGE__; # Useful to have a scalar for hash keys. diff --git a/lib/autodie/hints.pm b/lib/autodie/hints.pm index 14b3b43..bd7ab6f 100644 --- a/lib/autodie/hints.pm +++ b/lib/autodie/hints.pm @@ -101,10 +101,11 @@ return value of an autodying subroutine. If the match returns true, 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 -only subroutine hints are supported in these versions. +the complete return value to that subroutine. If the hint is a regexp object, +then C will match it against the return value. If the hint is undef, +the return value must be undef. On Perl versions 5.10 and newer, any other +value can be provided and it will be smart matched against the value provided. +However, smart matched values like this are deprecated. Hints can be provided for both scalar and list contexts. Note that an autodying subroutine will never see a void context, as diff --git a/t/basic_exceptions.t b/t/basic_exceptions.t index c732dd5..82fb68a 100644 --- a/t/basic_exceptions.t +++ b/t/basic_exceptions.t @@ -1,7 +1,7 @@ #!/usr/bin/perl -w use strict; -use Test::More tests => 19; +use Test::More tests => 24; use constant NO_SUCH_FILE => "this_file_had_better_not_exist"; @@ -46,3 +46,21 @@ eval { xyzzy(); }; isa_ok($@, 'autodie::exception'); is($@->caller, __PACKAGE__."::xyzzy", "Subroutine caller test"); is($@->line, $line2, "Subroutine line test"); + +eval { + no warnings 'once'; # To prevent the following close from complaining. + close(THIS_FILEHANDLE_AINT_OPEN); +}; + +ok(! $@, "Close without autodie should fail silent"); + +eval { + use autodie ':io'; + close(THIS_FILEHANDLE_AINT_OPEN); +}; + +like($@, qr{Can't close filehandle 'THIS_FILEHANDLE_AINT_OPEN'},"Nice msg from close"); + +ok($@, 'boolean overload works'); +ok $@ eq $@.'', "string overloading is complete (eq)"; +ok( ($@ cmp $@.'') == 0, "string overloading is complete (cmp)" ); diff --git a/t/exceptions.t b/t/exceptions-smartmatch.t old mode 100644 new mode 100755 similarity index 53% rename from t/exceptions.t rename to t/exceptions-smartmatch.t index 54d3b16..9e74da3 --- a/t/exceptions.t +++ b/t/exceptions-smartmatch.t @@ -1,18 +1,17 @@ #!/usr/bin/perl -w use strict; use Test::More; +use Fatal (); -BEGIN { plan skip_all => "Perl 5.10 only tests" if $] < 5.010; } +BEGIN { plan skip_all => "requires perl with smartmatch support" unless Fatal::SMARTMATCH_ALLOWED; } -# These are tests that depend upon 5.10 (eg, smart-match). +# These are tests that depend upon smartmatch. # Basic tests should go in basic_exceptions.t use 5.010; use warnings (); use constant NO_SUCH_FILE => 'this_file_had_better_not_exist_xyzzy'; -no if $] >= 5.017011, warnings => "experimental::smartmatch"; -no if exists $warnings::Offsets{"deprecated::smartmatch"}, - warnings => "deprecated"; +no if Fatal::SMARTMATCH_CATEGORY, 'warnings', Fatal::SMARTMATCH_CATEGORY; plan 'no_plan'; @@ -27,25 +26,12 @@ ok(':file' ~~ $@, "Exception from open / class :file" ); ok(':io' ~~ $@, "Exception from open / class :io" ); ok(':all' ~~ $@, "Exception from open / class :all" ); -eval { - no warnings 'once'; # To prevent the following close from complaining. - close(THIS_FILEHANDLE_AINT_OPEN); -}; - -ok(! $@, "Close without autodie should fail silent"); - eval { use autodie ':io'; close(THIS_FILEHANDLE_AINT_OPEN); }; -like($@, qr{Can't close filehandle 'THIS_FILEHANDLE_AINT_OPEN'},"Nice msg from close"); - -ok($@, "Exception thrown" ); ok('close' ~~ $@, "Exception from close" ); ok(':file' ~~ $@, "Exception from close / class :file" ); ok(':io' ~~ $@, "Exception from close / class :io" ); ok(':all' ~~ $@, "Exception from close / class :all" ); - -ok $@ eq $@.'', "string overloading is complete (eq)"; -ok( ($@ cmp $@.'') == 0, "string overloading is complete (cmp)" );