X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FMouse%2FAttribute.pm;h=2076297b39606e487838d7a5bf2f2aeec5ebddb7;hb=af745d5a30ceb45518de556943e95dfdc03f451a;hp=41a56df0a6599013884870a92ea942b7c7deea5f;hpb=c3398f5bd45f2851b7cd40ca9823bcf7d2378469;p=gitmo%2FMouse.git diff --git a/lib/Mouse/Attribute.pm b/lib/Mouse/Attribute.pm index 41a56df..2076297 100644 --- a/lib/Mouse/Attribute.pm +++ b/lib/Mouse/Attribute.pm @@ -4,46 +4,74 @@ use strict; use warnings; use Carp 'confess'; +use Scalar::Util 'blessed'; sub new { my $class = shift; my %args = @_; - $args{init_arg} ||= $args{name}; + $args{init_arg} = $args{name} + unless exists $args{init_arg}; $args{is} ||= ''; bless \%args, $class; } -sub name { $_[0]->{name} } -sub class { $_[0]->{class} } -sub default { $_[0]->{default} } -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 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 $accessor = 'sub { my $self = shift;'; - if ($attribute->{is} eq 'rw') { + if ($attribute->_is_metadata eq 'rw') { $accessor .= 'if (@_) { - $self->{$key} = $_[0];'; + local $_ = $_[0];'; - if ($attribute->{weak_ref}) { + 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->(); + };' + } + + $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 .= '}'; @@ -51,9 +79,9 @@ sub generate_accessor { else { } - if ($attribute->{lazy}) { + if ($attribute->is_lazy) { $accessor .= '$self->{$key} = '; - $accessor .= ref($attribute->{default}) eq 'CODE' + $accessor .= ref($default) eq 'CODE' ? '$default->($self)' : '$default'; $accessor .= ' if !exists($self->{$key});'; @@ -67,7 +95,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}) }'; @@ -76,7 +104,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}) }'; @@ -85,12 +113,12 @@ sub generate_clearer { sub generate_handles { my $attribute = shift; - my $reader = $attribute->{name}; + my $reader = $attribute->name; my %method_map; - for my $local_method (keys %{ $attribute->{handles} }) { - my $remote_method = $attribute->{handles}{$local_method}; + for my $local_method (keys %{ $attribute->handles }) { + my $remote_method = $attribute->handles->{$local_method}; my $method = 'sub { my $self = shift; @@ -116,36 +144,34 @@ sub create { if ref($args{default}) && ref($args{default}) ne 'CODE'; - $args{handles} = { map { $_ => $_ } @{ $args{handles} } } - if $args{handles} - && ref($args{handles}) eq 'ARRAY'; + $args{handles} = { $self->_canonicalize_handles($args{handles}) } + if $args{handles}; - 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}; my $attribute = $self->new(%args, name => $name, class => $class); my $meta = $class->meta; + $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; } - $meta->add_attribute($attribute); - 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'; @@ -156,6 +182,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__ @@ -179,18 +247,42 @@ installed. Some error checking is done. =head2 class -> OwnerClass -=head2 default -> Value +=head2 is_required -> Bool + +=head2 default -> Item + +=head2 has_default -> Bool + +=head2 is_lazy -> Bool -=head2 predicate -> MethodName +=head2 predicate -> MethodName | Undef -=head2 clearer -> MethodName +=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