From: Shawn M Moore <sartak@gmail.com>
Date: Sun, 21 Dec 2008 23:10:19 +0000 (+0000)
Subject: Moose::Meta::Attribute->check_type_constraint
X-Git-Tag: 0.64~10
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=2b86e02bf0ee5f21387989c0af89dc7feec412e3;p=gitmo%2FMoose.git

Moose::Meta::Attribute->check_type_constraint
---

diff --git a/Changes b/Changes
index 54550ce..42e4537 100644
--- a/Changes
+++ b/Changes
@@ -5,6 +5,8 @@ Revision history for Perl extension Moose
       - Always inline predicate and clearer methods (Sartak)
     * Moose::Meta::Attribute
       - Support for parameterized traits (Sartak)
+      - check_type_constraint method to avoid duplication and
+        enhance extensibility (Sartak)
     * Moose::Meta::Class
       - Tests (but no support yet) for parameterized traits (Sartak)
 
diff --git a/lib/Moose/Meta/Attribute.pm b/lib/Moose/Meta/Attribute.pm
index cac68ed..88d3756 100644
--- a/lib/Moose/Meta/Attribute.pm
+++ b/lib/Moose/Meta/Attribute.pm
@@ -411,11 +411,7 @@ sub initialize_instance_slot {
         if ($self->should_coerce && $type_constraint->has_coercion) {
             $val = $type_constraint->coerce($val);
         }
-        $type_constraint->check($val)
-            || $self->throw_error("Attribute (" 
-                     . $self->name 
-                     . ") does not pass the type constraint because: " 
-                     . $type_constraint->get_message($val), data => $val, object => $instance);
+        $self->check_type_constraint($val, instance => $instance);
     }
 
     $self->set_initial_value($instance, $val);
@@ -467,11 +463,7 @@ sub _set_initial_slot_value {
         if ($type_constraint) {
             $val = $type_constraint->coerce($val)
                 if $can_coerce;
-            $type_constraint->check($val)
-                || $self->throw_error("Attribute (" 
-                         . $slot_name 
-                         . ") does not pass the type constraint because: " 
-                         . $type_constraint->get_message($val), data => $val, object => $instance);
+            $self->check_type_constraint($val, object => $instance);
         }
         $meta_instance->set_slot_value($instance, $slot_name, $val);
     };
@@ -535,10 +527,7 @@ sub get_value {
                 my $type_constraint = $self->type_constraint;
                 $value = $type_constraint->coerce($value)
                     if ($self->should_coerce);
-                $type_constraint->check($value) 
-                  || $self->throw_error("Attribute (" . $self->name
-                      . ") does not pass the type constraint because: "
-                      . $type_constraint->get_message($value), type_constraint => $type_constraint, data => $value);
+                $self->check_type_constraint($value);
             }
             $self->set_initial_value($instance, $value);
         }
@@ -731,6 +720,21 @@ sub _make_delegation_method {
     );
 }
 
+sub check_type_constraint {
+    my $self = shift;
+    my $val  = shift;
+
+    return 1 if !$self->has_type_constraint;
+
+    my $type_constraint = $self->type_constraint;
+
+    $type_constraint->check($val)
+        || $self->throw_error("Attribute ("
+                 . $self->name
+                 . ") does not pass the type constraint because: "
+                 . $type_constraint->get_message($val), data => $val, @_);
+}
+
 package Moose::Meta::Attribute::Custom::Moose;
 sub register_implementation { 'Moose::Meta::Attribute' }
 
@@ -846,6 +850,11 @@ A read-only accessor for this meta-attribute's type constraint. For
 more information on what you can do with this, see the documentation
 for L<Moose::Meta::TypeConstraint>.
 
+=item B<check_type_constraint>
+
+Confirms that the given value is valid under this attribute's type
+constraint, otherwise throws an error.
+
 =item B<has_handles>
 
 Returns true if this meta-attribute performs delegation.