0.36 Call instance_of in catch_class matching

pjfl · Feb 11, 2015 · 0c5fc4f · 0c5fc4f
1 parent 343c031
commit 0c5fc4f
Show file tree

Hide file tree

Showing 4 changed files with 22 additions and 15 deletions.
diff --git a/Changes b/Changes
@@ -1,5 +1,7 @@
 Revision history for Unexpected
 
+          - Call instance_of in catch_class matching
+
 0.36.1    2014-12-22 01:02:53
           - Added explicite bool overload
           - Broken smoker a54c1c84-6bf5-1014-b4f9-dcd54300afcd

diff --git a/lib/Unexpected.pm b/lib/Unexpected.pm
@@ -5,7 +5,7 @@ use namespace::autoclean;
 use overload '""'     => sub { $_[ 0 ]->as_string },
              bool     => sub { 1 },
              fallback => 1;
-use version; our $VERSION = qv( sprintf '0.36.%d', q$Rev: 1 $ =~ /\d+/gmx );
+use version; our $VERSION = qv( sprintf '0.36.%d', q$Rev: 2 $ =~ /\d+/gmx );
 
 use Moo;
 

diff --git a/lib/Unexpected/Functions.pm b/lib/Unexpected/Functions.pm
@@ -39,15 +39,15 @@ my $_exception_class = sub {
 };
 
 my $_match_class = sub {
-   my ($x, $ref, $blessed, $does, $key) = @_;
-
-   return !defined $key                                       ? !defined $x
-        : $key eq '*'                                         ? 1
-        : $key eq ':str'                                      ? !$ref
-        : $key eq $ref                                        ? 1
-        : $blessed && $x->can( 'class' ) && $x->class eq $key ? 1
-        : $blessed && $x->$does( $key )                       ? 1
-                                                              : 0;
+   my ($e, $ref, $blessed, $does, $key) = @_;
+
+   return !defined $key                        ? !defined $e
+        : $key eq '*'                          ? 1
+        : $key eq ':str'                       ? !$ref
+        : $key eq $ref                         ? 1
+        : $blessed && $e->can( 'instance_of' ) ? $e->instance_of( $key )
+        : $blessed && $e->$does( $key )        ? 1
+                                               : 0;
 };
 
 my $_quote_maybe = sub {
@@ -58,14 +58,14 @@ my $_gen_checker = sub {
    my @prototable = @_;
 
    return sub {
-      my $x       = shift;
-      my $ref     = ref $x;
-      my $blessed = blessed $x;
-      my $does    = ($blessed && $x->can( 'DOES' )) || 'isa';
+      my $e       = shift;
+      my $ref     = ref $e;
+      my $blessed = blessed $e;
+      my $does    = ($blessed && $e->can( 'DOES' )) || 'isa';
       my @table   = @prototable;
 
       while (my ($key, $value) = splice @table, 0, 2) {
-         $_match_class->( $x, $ref, $blessed, $does, $key ) and return $value
+         $_match_class->( $e, $ref, $blessed, $does, $key ) and return $value
       }
 
       return;

diff --git a/t/10test_script.t b/t/10test_script.t
@@ -283,6 +283,11 @@ my $v = try { $class->throw( class => 'C' ) } catch_class [ C => sub { 42 } ];
 
 is $v, 42, 'Catch class';
 
+$v = try { $class->throw( class => 'D', error => 'Must have an error' ) }
+           catch_class [ B => sub { 42 } ];
+
+is $v, 42, 'Catch class - instance_of';
+
 eval { try { $class->throw( class => 'C' ) } catch_class [ D => sub { 42 } ]; };
 
 $e = _eval_error;