X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FMouse%2FAttribute.pm;h=115af444f3b2934323a879ab99f562dae4259b95;hb=c3cc36426995c03e0b44d087c6d0cf3f2a3ceb69;hp=22e86e03f3c0e065db4763f47fc3498a0178dadd;hpb=186657a92e5f7f1466dfdc7928f84be2f4c0ece1;p=gitmo%2FMouse.git

diff --git a/lib/Mouse/Attribute.pm b/lib/Mouse/Attribute.pm
index 22e86e0..115af44 100644
--- a/lib/Mouse/Attribute.pm
+++ b/lib/Mouse/Attribute.pm
@@ -4,6 +4,7 @@ use strict;
 use warnings;
 
 use Carp 'confess';
+use Scalar::Util 'blessed';
 
 sub new {
     my $class = shift;
@@ -18,46 +19,77 @@ sub new {
 
 sub name            { $_[0]->{name}            }
 sub class           { $_[0]->{class}           }
+sub _is_metadata    { $_[0]->{is}              }
+sub is_required     { $_[0]->{required}        }
 sub default         { $_[0]->{default}         }
+sub is_lazy         { $_[0]->{lazy}            }
 sub predicate       { $_[0]->{predicate}       }
 sub clearer         { $_[0]->{clearer}         }
 sub handles         { $_[0]->{handles}         }
 sub weak_ref        { $_[0]->{weak_ref}        }
 sub init_arg        { $_[0]->{init_arg}        }
 sub type_constraint { $_[0]->{type_constraint} }
+sub trigger         { $_[0]->{trigger}         }
+sub builder         { $_[0]->{builder}         }
+
+sub has_default         { exists $_[0]->{default}         }
+sub has_predicate       { exists $_[0]->{predicate}       }
+sub has_clearer         { exists $_[0]->{clearer}         }
+sub has_handles         { exists $_[0]->{handles}         }
+sub has_type_constraint { exists $_[0]->{type_constraint} }
+sub has_trigger         { exists $_[0]->{trigger}         }
+sub has_builder         { exists $_[0]->{builder}         }
 
 sub generate_accessor {
     my $attribute = shift;
 
-    my $key     = $attribute->{init_arg};
-    my $default = $attribute->{default};
-    my $trigger = $attribute->{trigger};
+    my $name       = $attribute->name;
+    my $key        = $attribute->init_arg;
+    my $default    = $attribute->default;
+    my $trigger    = $attribute->trigger;
+    my $type       = $attribute->type_constraint;
+    my $constraint = $attribute->find_type_constraint;
+    my $builder    = $attribute->builder;
 
     my $accessor = 'sub {
         my $self = shift;';
 
-    if ($attribute->{is} eq 'rw') {
+    if ($attribute->_is_metadata eq 'rw') {
         $accessor .= 'if (@_) {
-            $self->{$key} = $_[0];';
+            local $_ = $_[0];';
+
+        if ($constraint) {
+            $accessor .= 'do {
+                my $display = defined($_) ? $_ : "undef";
+                Carp::confess("Attribute ($name) does not pass the type constraint because: Validation failed for \'$type\' failed with value $display") unless $constraint->();
+            };'
+        }
 
-        if ($attribute->{weak_ref}) {
+        $accessor .= '$self->{$key} = $_;';
+
+        if ($attribute->weak_ref) {
             $accessor .= 'Scalar::Util::weaken($self->{$key});';
         }
 
         if ($trigger) {
-            $accessor .= '$trigger->($self, $_[0], $attribute);';
+            $accessor .= '$trigger->($self, $_, $attribute);';
         }
 
         $accessor .= '}';
     }
     else {
+        $accessor .= 'confess "Cannot assign a value to a read-only accessor" if @_;';
     }
 
-    if ($attribute->{lazy}) {
+    if ($attribute->is_lazy) {
         $accessor .= '$self->{$key} = ';
-        $accessor .= ref($attribute->{default}) eq 'CODE'
-                   ? '$default->($self)'
-                   : '$default';
+
+        $accessor .= $attribute->has_builder
+                   ? '$self->$builder'
+                     : ref($default) eq 'CODE'
+                     ? '$default->($self)'
+                     : '$default';
+
         $accessor .= ' if !exists($self->{$key});';
     }
 
@@ -69,7 +101,7 @@ sub generate_accessor {
 
 sub generate_predicate {
     my $attribute = shift;
-    my $key = $attribute->{init_arg};
+    my $key = $attribute->init_arg;
 
     my $predicate = 'sub { exists($_[0]->{$key}) }';
 
@@ -78,7 +110,7 @@ sub generate_predicate {
 
 sub generate_clearer {
     my $attribute = shift;
-    my $key = $attribute->{init_arg};
+    my $key = $attribute->init_arg;
 
     my $predicate = 'sub { delete($_[0]->{$key}) }';
 
@@ -87,12 +119,13 @@ sub generate_clearer {
 
 sub generate_handles {
     my $attribute = shift;
-    my $reader = $attribute->{name};
+    my $reader = $attribute->name;
+    my %handles = $attribute->_canonicalize_handles($attribute->handles);
 
     my %method_map;
 
-    for my $local_method (keys %{ $attribute->{handles} }) {
-        my $remote_method = $attribute->{handles}{$local_method};
+    for my $local_method (keys %handles) {
+        my $remote_method = $handles{$local_method};
 
         my $method = 'sub {
             my $self = shift;
@@ -108,25 +141,15 @@ sub generate_handles {
 sub create {
     my ($self, $class, $name, %args) = @_;
 
-    confess "You must specify a default for lazy attribute '$name'"
-        if $args{lazy} && !exists($args{default});
-
-    confess "Trigger is not allowed on read-only attribute '$name'"
-        if $args{trigger} && $args{is} ne 'rw';
+    confess "You cannot have lazy attribute ($name) without specifying a default value for it"
+        if $args{lazy} && !exists($args{default}) && !exists($args{builder});
 
     confess "References are not allowed as default values, you must wrap the default of '$name' in a CODE reference (ex: sub { [] } and not [])"
         if ref($args{default})
         && ref($args{default}) ne 'CODE';
 
-    $args{handles} = { map { $_ => $_ } @{ $args{handles} } }
-        if $args{handles}
-        && ref($args{handles}) eq 'ARRAY';
-
-    confess "You must pass a HASH or ARRAY to handles"
-        if exists($args{handles})
-        && ref($args{handles}) ne 'HASH';
-
-    $args{type_constraint} = delete $args{isa};
+    $args{type_constraint} = delete $args{isa}
+        if exists $args{isa};
 
     my $attribute = $self->new(%args, name => $name, class => $class);
     my $meta = $class->meta;
@@ -134,22 +157,23 @@ sub create {
     $meta->add_attribute($attribute);
 
     # install an accessor
-    if ($attribute->{is} eq 'rw' || $attribute->{is} eq 'ro') {
+    if ($attribute->_is_metadata eq 'rw' || $attribute->_is_metadata eq 'ro') {
         my $accessor = $attribute->generate_accessor;
         no strict 'refs';
         *{ $class . '::' . $name } = $accessor;
     }
 
     for my $method (qw/predicate clearer/) {
-        if (exists $attribute->{$method}) {
+        my $predicate = "has_$method";
+        if ($attribute->$predicate) {
             my $generator = "generate_$method";
             my $coderef = $attribute->$generator;
             no strict 'refs';
-            *{ $class . '::' . $attribute->{$method} } = $coderef;
+            *{ $class . '::' . $attribute->$method } = $coderef;
         }
     }
 
-    if ($attribute->{handles}) {
+    if ($attribute->has_handles) {
         my $method_map = $attribute->generate_handles;
         for my $method_name (keys %$method_map) {
             no strict 'refs';
@@ -160,6 +184,48 @@ sub create {
     return $attribute;
 }
 
+sub find_type_constraint {
+    my $self = shift;
+    my $type = $self->type_constraint;
+
+    return unless $type;
+
+    my $checker = Mouse::TypeRegistry->optimized_constraints->{$type};
+    return $checker if $checker;
+
+    return sub { blessed($_) && blessed($_) eq $type };
+}
+
+sub verify_type_constraint {
+    my $self = shift;
+    local $_ = shift;
+
+    my $type = $self->type_constraint
+        or return 1;
+    my $constraint = $self->find_type_constraint;
+
+    return 1 if $constraint->($_);
+
+    my $name = $self->name;
+    local $_ = "undef" unless defined($_);
+    Carp::confess("Attribute ($name) does not pass the type constraint because: Validation failed for \'$type\' failed with value $_");
+}
+
+sub _canonicalize_handles {
+    my $self    = shift;
+    my $handles = shift;
+
+    if (ref($handles) eq 'HASH') {
+        return %$handles;
+    }
+    elsif (ref($handles) eq 'ARRAY') {
+        return map { $_ => $_ } @$handles;
+    }
+    else {
+        confess "Unable to canonicalize the 'handles' option with $handles";
+    }
+}
+
 1;
 
 __END__
@@ -183,18 +249,42 @@ installed. Some error checking is done.
 
 =head2 class -> OwnerClass
 
-=head2 default -> Value
+=head2 is_required -> Bool
+
+=head2 default -> Item
 
-=head2 predicate -> MethodName
+=head2 has_default -> Bool
 
-=head2 clearer -> MethodName
+=head2 is_lazy -> Bool
+
+=head2 predicate -> MethodName | Undef
+
+=head2 has_predicate -> Bool
+
+=head2 clearer -> MethodName | Undef
+
+=head2 has_clearer -> Bool
 
 =head2 handles -> { LocalName => RemoteName }
 
+=head2 has_handles -> Bool
+
 =head2 weak_ref -> Bool
 
 =head2 init_arg -> Str
 
+=head2 type_constraint -> Str
+
+=head2 has_type_constraint -> Bool
+
+=head2 trigger => CODE | Undef
+
+=head2 has_trigger -> Bool
+
+=head2 builder => MethodName | Undef
+
+=head2 has_builder -> Bool
+
 Informational methods.
 
 =head2 generate_accessor -> CODE
@@ -213,5 +303,15 @@ Creates a new code reference for the attribute's clearer.
 
 Creates a new code reference for each of the attribute's handles methods.
 
+=head2 find_type_constraint -> CODE
+
+Returns a code reference which can be used to check that a given value passes
+this attribute's type constraint;
+
+=head2 verify_type_constraint Item -> 1 | ERROR
+
+Checks that the given value passes this attribute's type constraint. Returns 1
+on success, otherwise C<confess>es.
+
 =cut