Merge pull request #117 from haarg/deprecate-smartmatch

Deprecate smartmatch handling

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{

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.

lib/autodie/hints.pm

@@ -101,10 +101,11 @@ return value of an autodying subroutine.  If the match returns true,
 C<autodie> considers the subroutine to have failed.
 
 If the hint provided is a subroutine, then C<autodie> will pass
-the complete return value to that subroutine.  If the hint is
-any other value, then C<autodie> will smart-match against the
-value provided.  In Perl 5.8.x there is no smart-match operator, and as such
-only subroutine hints are supported in these versions.
+the complete return value to that subroutine.  If the hint is a regexp object,
+then C<autodie> 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

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)" );

t/exceptions.t → 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)" );