From: Jesse Luehrs <doy@tozt.net>
Date: Mon, 29 Aug 2011 17:33:35 +0000 (-0500)
Subject: clean up duck type a bunch
X-Git-Tag: 2.0300~98
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=4f073d2df72a7501f9f16dce3dd1696aea0298f6;p=gitmo%2FMoose.git

clean up duck type a bunch
---

diff --git a/Changes b/Changes
index 0391509..b497b8f 100644
--- a/Changes
+++ b/Changes
@@ -17,6 +17,9 @@ for, noteworthy changes.
     -alias or -excludes caused a warning. However, passing other options is
     totally valid when using MooseX::Role::Parameterized. (sartak)
 
+  * Allow regexp objects in duck_type constraints (to bring this in line with
+    the Object constraint)
+
   [DEPRECATIONS]
 
   * The optimize_as option for type constraints has been deprecated. Use the
diff --git a/lib/Moose/Meta/TypeConstraint/DuckType.pm b/lib/Moose/Meta/TypeConstraint/DuckType.pm
index 09f0b86..02c12d0 100644
--- a/lib/Moose/Meta/TypeConstraint/DuckType.pm
+++ b/lib/Moose/Meta/TypeConstraint/DuckType.pm
@@ -22,12 +22,14 @@ my $inliner = sub {
     my $self = shift;
     my $val  = shift;
 
-    return 'my $val = ' . $val . '; Scalar::Util::blessed($val) '
-             . '&& Scalar::Util::blessed($val) ne "Regexp" '
-             . '&& &List::MoreUtils::all('
-                 . 'sub { $val->can($_) }, '
+    return $self->parent->_inline_check($val)
+         . ' && do {' . "\n"
+             . 'my $val = ' . $val . ';' . "\n"
+             . '&List::MoreUtils::all(' . "\n"
+                 . 'sub { $val->can($_) },' . "\n"
                  . join(', ', map { B::perlstring($_) } @{ $self->methods })
-             . ')';
+             . ');' . "\n"
+         . '}';
 };
 
 sub new {
@@ -39,8 +41,7 @@ sub new {
     my @methods = @{ $args{methods} };
     $args{constraint} = sub {
         my $val = $_[0];
-        blessed($val) && blessed($val) ne 'Regexp'
-            && all { $val->can($_) } @methods;
+        return all { $val->can($_) } @methods;
     };
 
     $args{inlined} = $inliner;
@@ -75,17 +76,6 @@ sub equals {
     return 1;
 }
 
-sub constraint {
-    my $self = shift;
-
-    my @methods = @{ $self->methods };
-
-    return sub {
-        my $obj = shift;
-        return all { $obj->can($_) } @methods
-    };
-}
-
 sub create_child_type {
     my ($self, @args) = @_;
     return Moose::Meta::TypeConstraint->new(@args, parent => $self);