| File | /usr/local/lib/perl/5.10.0/Moose/Meta/Attribute.pm |
| Statements Executed | 847 |
| Total Time | 0.00877499999999998 seconds |
| Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
|---|---|---|---|---|---|
| 9 | 2 | 2 | 1.18ms | 5.69ms | Moose::Meta::Attribute::new |
| 26 | 3 | 3 | 422µs | 2.92ms | Moose::Meta::Attribute::inline_set |
| 11 | 3 | 1 | 301µs | 17.1ms | Moose::Meta::Attribute::_process_accessors |
| 9 | 1 | 1 | 207µs | 605µs | Moose::Meta::Attribute::_process_options |
| 8 | 1 | 1 | 157µs | 4.15ms | Moose::Meta::Attribute::interpolate_class_and_new |
| 10 | 2 | 1 | 141µs | 19.7ms | Moose::Meta::Attribute::install_accessors |
| 8 | 1 | 1 | 89µs | 89µs | Moose::Meta::Attribute::interpolate_class |
| 11 | 1 | 1 | 57µs | 57µs | Moose::Meta::Attribute::accessor_metaclass |
| 8 | 1 | 1 | 55µs | 91µs | Moose::Meta::Attribute::_check_associated_methods |
| 0 | 0 | 0 | 0s | 0s | Moose::Meta::Attribute::BEGIN |
| 0 | 0 | 0 | 0s | 0s | Moose::Meta::Attribute::Custom::Moose::register_implementation |
| 0 | 0 | 0 | 0s | 0s | Moose::Meta::Attribute::__ANON__[:277] |
| 0 | 0 | 0 | 0s | 0s | Moose::Meta::Attribute::__ANON__[:39] |
| 0 | 0 | 0 | 0s | 0s | Moose::Meta::Attribute::__ANON__[:438] |
| 0 | 0 | 0 | 0s | 0s | Moose::Meta::Attribute::__ANON__[:642] |
| 0 | 0 | 0 | 0s | 0s | Moose::Meta::Attribute::_call_builder |
| 0 | 0 | 0 | 0s | 0s | Moose::Meta::Attribute::_canonicalize_handles |
| 0 | 0 | 0 | 0s | 0s | Moose::Meta::Attribute::_coerce_and_verify |
| 0 | 0 | 0 | 0s | 0s | Moose::Meta::Attribute::_find_delegate_metaclass |
| 0 | 0 | 0 | 0s | 0s | Moose::Meta::Attribute::_get_delegate_method_list |
| 0 | 0 | 0 | 0s | 0s | Moose::Meta::Attribute::_make_delegation_method |
| 0 | 0 | 0 | 0s | 0s | Moose::Meta::Attribute::_set_initial_slot_value |
| 0 | 0 | 0 | 0s | 0s | Moose::Meta::Attribute::_weaken_value |
| 0 | 0 | 0 | 0s | 0s | Moose::Meta::Attribute::clone |
| 0 | 0 | 0 | 0s | 0s | Moose::Meta::Attribute::clone_and_inherit_options |
| 0 | 0 | 0 | 0s | 0s | Moose::Meta::Attribute::delegation_metaclass |
| 0 | 0 | 0 | 0s | 0s | Moose::Meta::Attribute::does |
| 0 | 0 | 0 | 0s | 0s | Moose::Meta::Attribute::get_value |
| 0 | 0 | 0 | 0s | 0s | Moose::Meta::Attribute::illegal_options_for_inheritance |
| 0 | 0 | 0 | 0s | 0s | Moose::Meta::Attribute::initialize_instance_slot |
| 0 | 0 | 0 | 0s | 0s | Moose::Meta::Attribute::install_delegation |
| 0 | 0 | 0 | 0s | 0s | Moose::Meta::Attribute::remove_accessors |
| 0 | 0 | 0 | 0s | 0s | Moose::Meta::Attribute::remove_delegation |
| 0 | 0 | 0 | 0s | 0s | Moose::Meta::Attribute::set_value |
| 0 | 0 | 0 | 0s | 0s | Moose::Meta::Attribute::throw_error |
| 0 | 0 | 0 | 0s | 0s | Moose::Meta::Attribute::verify_against_type_constraint |
| Line | Stmts. | Exclusive Time | Avg. | Code |
|---|---|---|---|---|
| 1 | ||||
| 2 | package Moose::Meta::Attribute; | |||
| 3 | ||||
| 4 | 3 | 28µs | 9µs | use strict; # spent 9µs making 1 call to strict::import |
| 5 | 3 | 38µs | 13µs | use warnings; # spent 25µs making 1 call to warnings::import |
| 6 | ||||
| 7 | 3 | 31µs | 10µs | use Scalar::Util 'blessed', 'weaken'; # spent 50µs making 1 call to Exporter::import |
| 8 | 3 | 27µs | 9µs | use List::MoreUtils 'any'; # spent 41µs making 1 call to Exporter::import |
| 9 | 3 | 30µs | 10µs | use Try::Tiny; # spent 58µs making 1 call to Exporter::import |
| 10 | 3 | 45µs | 15µs | use overload (); |
| 11 | ||||
| 12 | 1 | 1µs | 1µs | our $VERSION = '1.15'; |
| 13 | 1 | 700ns | 700ns | our $AUTHORITY = 'cpan:STEVAN'; |
| 14 | ||||
| 15 | 3 | 27µs | 9µs | use Moose::Deprecated; # spent 15µs making 1 call to Package::DeprecationManager::__ANON__[/usr/local/share/perl/5.10.0/Package/DeprecationManager.pm:61] |
| 16 | 3 | 127µs | 42µs | use Moose::Meta::Method::Accessor; # spent 6µs making 1 call to import |
| 17 | 3 | 115µs | 38µs | use Moose::Meta::Method::Delegation; # spent 9µs making 1 call to import |
| 18 | 3 | 16µs | 5µs | use Moose::Util (); |
| 19 | 3 | 119µs | 40µs | use Moose::Util::TypeConstraints (); |
| 20 | 3 | 34µs | 11µs | use Class::MOP::MiniTrait; # spent 5µs making 1 call to import |
| 21 | ||||
| 22 | 3 | 4.52ms | 1.51ms | use base 'Class::MOP::Attribute', 'Moose::Meta::Mixin::AttributeCore'; # spent 9.73ms making 1 call to base::import |
| 23 | ||||
| 24 | 1 | 11µs | 11µs | Class::MOP::MiniTrait::apply(__PACKAGE__, 'Moose::Meta::Object::Trait'); # spent 3.15ms making 1 call to Class::MOP::MiniTrait::apply |
| 25 | ||||
| 26 | 1 | 18µs | 18µs | __PACKAGE__->meta->add_attribute('traits' => ( # spent 813µs making 1 call to Class::MOP::Mixin::HasAttributes::add_attribute
# spent 24µs making 1 call to Class::MOP::Object::meta |
| 27 | reader => 'applied_traits', | |||
| 28 | predicate => 'has_applied_traits', | |||
| 29 | )); | |||
| 30 | ||||
| 31 | # we need to have a ->does method in here to | |||
| 32 | # more easily support traits, and the introspection | |||
| 33 | # of those traits. We extend the does check to look | |||
| 34 | # for metatrait aliases. | |||
| 35 | sub does { | |||
| 36 | my ($self, $role_name) = @_; | |||
| 37 | my $name = try { | |||
| 38 | Moose::Util::resolve_metatrait_alias(Attribute => $role_name) | |||
| 39 | }; | |||
| 40 | return 0 if !defined($name); # failed to load class | |||
| 41 | return $self->Moose::Object::does($name); | |||
| 42 | } | |||
| 43 | ||||
| 44 | sub throw_error { | |||
| 45 | my $self = shift; | |||
| 46 | my $class = ( ref $self && $self->associated_class ) || "Moose::Meta::Class"; | |||
| 47 | unshift @_, "message" if @_ % 2 == 1; | |||
| 48 | unshift @_, attr => $self if ref $self; | |||
| 49 | unshift @_, $class; | |||
| 50 | my $handler = $class->can("throw_error"); # to avoid incrementing depth by 1 | |||
| 51 | goto $handler; | |||
| 52 | } | |||
| 53 | ||||
| 54 | # spent 5.69ms (1.18+4.51) within Moose::Meta::Attribute::new which was called 9 times, avg 633µs/call:
# 8 times (1.03ms+2.87ms) by Moose::Meta::Attribute::interpolate_class_and_new at line 82, avg 487µs/call
# once (152µs+1.64ms) at line 20 of /usr/local/lib/perl/5.10.0/Moose/Meta/TypeCoercion.pm | |||
| 55 | 315 | 1.71ms | 5µs | my ($class, $name, %options) = @_; |
| 56 | $class->_process_options($name, \%options) unless $options{__hack_no_process_options}; # used from clone()... YECHKKK FIXME ICKY YUCK GROSS # spent 605µs making 9 calls to Moose::Meta::Attribute::_process_options, avg 67µs/call | |||
| 57 | ||||
| 58 | delete $options{__hack_no_process_options}; | |||
| 59 | ||||
| 60 | my %attrs = | |||
| 61 | ( map { $_ => 1 } | |||
| 62 | grep { defined } # spent 1.14ms making 252 calls to Class::MOP::Mixin::AttributeCore::init_arg, avg 5µs/call | |||
| 63 | map { $_->init_arg() } # spent 393µs making 8 calls to Class::MOP::Class::Immutable::Class::MOP::Class::get_all_attributes, avg 49µs/call
# spent 218µs making 9 calls to Class::MOP::Object::meta, avg 24µs/call
# spent 182µs making 1 call to Class::MOP::Class::get_all_attributes | |||
| 64 | $class->meta()->get_all_attributes() | |||
| 65 | ); | |||
| 66 | ||||
| 67 | my @bad = sort grep { ! $attrs{$_} } keys %options; | |||
| 68 | ||||
| 69 | if (@bad) | |||
| 70 | { | |||
| 71 | Carp::cluck "Found unknown argument(s) passed to '$name' attribute constructor in '$class': @bad"; | |||
| 72 | } | |||
| 73 | ||||
| 74 | return $class->SUPER::new($name, %options); # spent 1.98ms making 9 calls to Class::MOP::Attribute::new, avg 220µs/call | |||
| 75 | } | |||
| 76 | ||||
| 77 | # spent 4.15ms (157µs+3.99) within Moose::Meta::Attribute::interpolate_class_and_new which was called 8 times, avg 518µs/call:
# 8 times (157µs+3.99ms) by Moose::Meta::Class::_process_new_attribute at line 431 of /usr/local/lib/perl/5.10.0/Moose/Meta/Class.pm, avg 518µs/call | |||
| 78 | 24 | 176µs | 7µs | my ($class, $name, %args) = @_; |
| 79 | ||||
| 80 | my ( $new_class, @traits ) = $class->interpolate_class(\%args); # spent 89µs making 8 calls to Moose::Meta::Attribute::interpolate_class, avg 11µs/call | |||
| 81 | ||||
| 82 | $new_class->new($name, %args, ( scalar(@traits) ? ( traits => \@traits ) : () ) ); # spent 3.90ms making 8 calls to Moose::Meta::Attribute::new, avg 487µs/call | |||
| 83 | } | |||
| 84 | ||||
| 85 | # spent 89µs within Moose::Meta::Attribute::interpolate_class which was called 8 times, avg 11µs/call:
# 8 times (89µs+0s) by Moose::Meta::Attribute::interpolate_class_and_new at line 80, avg 11µs/call | |||
| 86 | 48 | 60µs | 1µs | my ($class, $options) = @_; |
| 87 | ||||
| 88 | $class = ref($class) || $class; | |||
| 89 | ||||
| 90 | if ( my $metaclass_name = delete $options->{metaclass} ) { | |||
| 91 | my $new_class = Moose::Util::resolve_metaclass_alias( Attribute => $metaclass_name ); | |||
| 92 | ||||
| 93 | if ( $class ne $new_class ) { | |||
| 94 | if ( $new_class->can("interpolate_class") ) { | |||
| 95 | return $new_class->interpolate_class($options); | |||
| 96 | } else { | |||
| 97 | $class = $new_class; | |||
| 98 | } | |||
| 99 | } | |||
| 100 | } | |||
| 101 | ||||
| 102 | my @traits; | |||
| 103 | ||||
| 104 | if (my $traits = $options->{traits}) { | |||
| 105 | my $i = 0; | |||
| 106 | while ($i < @$traits) { | |||
| 107 | my $trait = $traits->[$i++]; | |||
| 108 | next if ref($trait); # options to a trait we discarded | |||
| 109 | ||||
| 110 | $trait = Moose::Util::resolve_metatrait_alias(Attribute => $trait) | |||
| 111 | || $trait; | |||
| 112 | ||||
| 113 | next if $class->does($trait); | |||
| 114 | ||||
| 115 | push @traits, $trait; | |||
| 116 | ||||
| 117 | # are there options? | |||
| 118 | push @traits, $traits->[$i++] | |||
| 119 | if $traits->[$i] && ref($traits->[$i]); | |||
| 120 | } | |||
| 121 | ||||
| 122 | if (@traits) { | |||
| 123 | my $anon_class = Moose::Meta::Class->create_anon_class( | |||
| 124 | superclasses => [ $class ], | |||
| 125 | roles => [ @traits ], | |||
| 126 | cache => 1, | |||
| 127 | ); | |||
| 128 | ||||
| 129 | $class = $anon_class->name; | |||
| 130 | } | |||
| 131 | } | |||
| 132 | ||||
| 133 | return ( wantarray ? ( $class, @traits ) : $class ); | |||
| 134 | } | |||
| 135 | ||||
| 136 | # ... | |||
| 137 | ||||
| 138 | # method-generating options shouldn't be overridden | |||
| 139 | sub illegal_options_for_inheritance { | |||
| 140 | qw(reader writer accessor clearer predicate) | |||
| 141 | } | |||
| 142 | ||||
| 143 | # NOTE/TODO | |||
| 144 | # This method *must* be able to handle | |||
| 145 | # Class::MOP::Attribute instances as | |||
| 146 | # well. Yes, I know that is wrong, but | |||
| 147 | # apparently we didn't realize it was | |||
| 148 | # doing that and now we have some code | |||
| 149 | # which is dependent on it. The real | |||
| 150 | # solution of course is to push this | |||
| 151 | # feature back up into Class::MOP::Attribute | |||
| 152 | # but I not right now, I am too lazy. | |||
| 153 | # However if you are reading this and | |||
| 154 | # looking for something to do,.. please | |||
| 155 | # be my guest. | |||
| 156 | # - stevan | |||
| 157 | sub clone_and_inherit_options { | |||
| 158 | my ($self, %options) = @_; | |||
| 159 | ||||
| 160 | # NOTE: | |||
| 161 | # we may want to extends a Class::MOP::Attribute | |||
| 162 | # in which case we need to be able to use the | |||
| 163 | # core set of legal options that have always | |||
| 164 | # been here. But we allows Moose::Meta::Attribute | |||
| 165 | # instances to changes them. | |||
| 166 | # - SL | |||
| 167 | my @illegal_options = $self->can('illegal_options_for_inheritance') | |||
| 168 | ? $self->illegal_options_for_inheritance | |||
| 169 | : (); | |||
| 170 | ||||
| 171 | my @found_illegal_options = grep { exists $options{$_} && exists $self->{$_} ? $_ : undef } @illegal_options; | |||
| 172 | (scalar @found_illegal_options == 0) | |||
| 173 | || $self->throw_error("Illegal inherited options => (" . (join ', ' => @found_illegal_options) . ")", data => \%options); | |||
| 174 | ||||
| 175 | if ($options{isa}) { | |||
| 176 | my $type_constraint; | |||
| 177 | if (blessed($options{isa}) && $options{isa}->isa('Moose::Meta::TypeConstraint')) { | |||
| 178 | $type_constraint = $options{isa}; | |||
| 179 | } | |||
| 180 | else { | |||
| 181 | $type_constraint = Moose::Util::TypeConstraints::find_or_create_isa_type_constraint($options{isa}); | |||
| 182 | (defined $type_constraint) | |||
| 183 | || $self->throw_error("Could not find the type constraint '" . $options{isa} . "'", data => $options{isa}); | |||
| 184 | } | |||
| 185 | ||||
| 186 | $options{type_constraint} = $type_constraint; | |||
| 187 | } | |||
| 188 | ||||
| 189 | if ($options{does}) { | |||
| 190 | my $type_constraint; | |||
| 191 | if (blessed($options{does}) && $options{does}->isa('Moose::Meta::TypeConstraint')) { | |||
| 192 | $type_constraint = $options{does}; | |||
| 193 | } | |||
| 194 | else { | |||
| 195 | $type_constraint = Moose::Util::TypeConstraints::find_or_create_does_type_constraint($options{does}); | |||
| 196 | (defined $type_constraint) | |||
| 197 | || $self->throw_error("Could not find the type constraint '" . $options{does} . "'", data => $options{does}); | |||
| 198 | } | |||
| 199 | ||||
| 200 | $options{type_constraint} = $type_constraint; | |||
| 201 | } | |||
| 202 | ||||
| 203 | # NOTE: | |||
| 204 | # this doesn't apply to Class::MOP::Attributes, | |||
| 205 | # so we can ignore it for them. | |||
| 206 | # - SL | |||
| 207 | if ($self->can('interpolate_class')) { | |||
| 208 | ( $options{metaclass}, my @traits ) = $self->interpolate_class(\%options); | |||
| 209 | ||||
| 210 | my %seen; | |||
| 211 | my @all_traits = grep { $seen{$_}++ } @{ $self->applied_traits || [] }, @traits; | |||
| 212 | $options{traits} = \@all_traits if @all_traits; | |||
| 213 | } | |||
| 214 | ||||
| 215 | $self->clone(%options); | |||
| 216 | } | |||
| 217 | ||||
| 218 | sub clone { | |||
| 219 | my ( $self, %params ) = @_; | |||
| 220 | ||||
| 221 | my $class = delete $params{metaclass} || ref $self; | |||
| 222 | ||||
| 223 | my ( @init, @non_init ); | |||
| 224 | ||||
| 225 | foreach my $attr ( grep { $_->has_value($self) } Class::MOP::class_of($self)->get_all_attributes ) { | |||
| 226 | push @{ $attr->has_init_arg ? \@init : \@non_init }, $attr; | |||
| 227 | } | |||
| 228 | ||||
| 229 | my %new_params = ( ( map { $_->init_arg => $_->get_value($self) } @init ), %params ); | |||
| 230 | ||||
| 231 | my $name = delete $new_params{name}; | |||
| 232 | ||||
| 233 | my $clone = $class->new($name, %new_params, __hack_no_process_options => 1 ); | |||
| 234 | ||||
| 235 | foreach my $attr ( @non_init ) { | |||
| 236 | $attr->set_value($clone, $attr->get_value($self)); | |||
| 237 | } | |||
| 238 | ||||
| 239 | return $clone; | |||
| 240 | } | |||
| 241 | ||||
| 242 | # spent 605µs (207+398) within Moose::Meta::Attribute::_process_options which was called 9 times, avg 67µs/call:
# 9 times (207µs+398µs) by Moose::Meta::Attribute::new at line 56, avg 67µs/call | |||
| 243 | 116 | 211µs | 2µs | my ($class, $name, $options) = @_; |
| 244 | ||||
| 245 | if (exists $options->{is}) { | |||
| 246 | ||||
| 247 | ### ------------------------- | |||
| 248 | ## is => ro, writer => _foo # turns into (reader => foo, writer => _foo) as before | |||
| 249 | ## is => rw, writer => _foo # turns into (reader => foo, writer => _foo) | |||
| 250 | ## is => rw, accessor => _foo # turns into (accessor => _foo) | |||
| 251 | ## is => ro, accessor => _foo # error, accesor is rw | |||
| 252 | ### ------------------------- | |||
| 253 | ||||
| 254 | if ($options->{is} eq 'ro') { | |||
| 255 | $class->throw_error("Cannot define an accessor name on a read-only attribute, accessors are read/write", data => $options) | |||
| 256 | if exists $options->{accessor}; | |||
| 257 | $options->{reader} ||= $name; | |||
| 258 | } | |||
| 259 | elsif ($options->{is} eq 'rw') { | |||
| 260 | if ($options->{writer}) { | |||
| 261 | $options->{reader} ||= $name; | |||
| 262 | } | |||
| 263 | else { | |||
| 264 | $options->{accessor} ||= $name; | |||
| 265 | } | |||
| 266 | } | |||
| 267 | elsif ($options->{is} eq 'bare') { | |||
| 268 | # do nothing, but don't complain (later) about missing methods | |||
| 269 | } | |||
| 270 | else { | |||
| 271 | $class->throw_error("I do not understand this option (is => " . $options->{is} . ") on attribute ($name)", data => $options->{is}); | |||
| 272 | } | |||
| 273 | } | |||
| 274 | ||||
| 275 | if (exists $options->{isa}) { | |||
| 276 | if (exists $options->{does}) { | |||
| 277 | if (try { $options->{isa}->can('does') }) { | |||
| 278 | ($options->{isa}->does($options->{does})) | |||
| 279 | || $class->throw_error("Cannot have an isa option and a does option if the isa does not do the does on attribute ($name)", data => $options); | |||
| 280 | } | |||
| 281 | else { | |||
| 282 | $class->throw_error("Cannot have an isa option which cannot ->does() on attribute ($name)", data => $options); | |||
| 283 | } | |||
| 284 | } | |||
| 285 | ||||
| 286 | # allow for anon-subtypes here ... | |||
| 287 | if (blessed($options->{isa}) && $options->{isa}->isa('Moose::Meta::TypeConstraint')) { # spent 18µs making 6 calls to Scalar::Util::blessed, avg 3µs/call | |||
| 288 | $options->{type_constraint} = $options->{isa}; | |||
| 289 | } | |||
| 290 | else { | |||
| 291 | $options->{type_constraint} = Moose::Util::TypeConstraints::find_or_create_isa_type_constraint($options->{isa}); # spent 380µs making 6 calls to Moose::Util::TypeConstraints::find_or_create_isa_type_constraint, avg 63µs/call | |||
| 292 | } | |||
| 293 | } | |||
| 294 | elsif (exists $options->{does}) { | |||
| 295 | # allow for anon-subtypes here ... | |||
| 296 | if (blessed($options->{does}) && $options->{does}->isa('Moose::Meta::TypeConstraint')) { | |||
| 297 | $options->{type_constraint} = $options->{does}; | |||
| 298 | } | |||
| 299 | else { | |||
| 300 | $options->{type_constraint} = Moose::Util::TypeConstraints::find_or_create_does_type_constraint($options->{does}); | |||
| 301 | } | |||
| 302 | } | |||
| 303 | ||||
| 304 | if (exists $options->{coerce} && $options->{coerce}) { | |||
| 305 | (exists $options->{type_constraint}) | |||
| 306 | || $class->throw_error("You cannot have coercion without specifying a type constraint on attribute ($name)", data => $options); | |||
| 307 | $class->throw_error("You cannot have a weak reference to a coerced value on attribute ($name)", data => $options) | |||
| 308 | if $options->{weak_ref}; | |||
| 309 | ||||
| 310 | unless ( $options->{type_constraint}->has_coercion ) { | |||
| 311 | my $type = $options->{type_constraint}->name; | |||
| 312 | ||||
| 313 | Moose::Deprecated::deprecated( | |||
| 314 | feature => 'coerce without coercion', | |||
| 315 | message => | |||
| 316 | "You cannot coerce an attribute ($name) unless its type ($type) has a coercion" | |||
| 317 | ); | |||
| 318 | } | |||
| 319 | } | |||
| 320 | ||||
| 321 | if (exists $options->{trigger}) { | |||
| 322 | ('CODE' eq ref $options->{trigger}) | |||
| 323 | || $class->throw_error("Trigger must be a CODE ref on attribute ($name)", data => $options->{trigger}); | |||
| 324 | } | |||
| 325 | ||||
| 326 | if (exists $options->{auto_deref} && $options->{auto_deref}) { | |||
| 327 | (exists $options->{type_constraint}) | |||
| 328 | || $class->throw_error("You cannot auto-dereference without specifying a type constraint on attribute ($name)", data => $options); | |||
| 329 | ($options->{type_constraint}->is_a_type_of('ArrayRef') || | |||
| 330 | $options->{type_constraint}->is_a_type_of('HashRef')) | |||
| 331 | || $class->throw_error("You cannot auto-dereference anything other than a ArrayRef or HashRef on attribute ($name)", data => $options); | |||
| 332 | } | |||
| 333 | ||||
| 334 | if (exists $options->{lazy_build} && $options->{lazy_build} == 1) { | |||
| 335 | $class->throw_error("You can not use lazy_build and default for the same attribute ($name)", data => $options) | |||
| 336 | if exists $options->{default}; | |||
| 337 | $options->{lazy} = 1; | |||
| 338 | $options->{builder} ||= "_build_${name}"; | |||
| 339 | if ($name =~ /^_/) { | |||
| 340 | $options->{clearer} ||= "_clear${name}"; | |||
| 341 | $options->{predicate} ||= "_has${name}"; | |||
| 342 | } | |||
| 343 | else { | |||
| 344 | $options->{clearer} ||= "clear_${name}"; | |||
| 345 | $options->{predicate} ||= "has_${name}"; | |||
| 346 | } | |||
| 347 | } | |||
| 348 | ||||
| 349 | if (exists $options->{lazy} && $options->{lazy}) { | |||
| 350 | (exists $options->{default} || defined $options->{builder} ) | |||
| 351 | || $class->throw_error("You cannot have lazy attribute ($name) without specifying a default value for it", data => $options); | |||
| 352 | } | |||
| 353 | ||||
| 354 | if ( $options->{required} && !( ( !exists $options->{init_arg} || defined $options->{init_arg} ) || exists $options->{default} || defined $options->{builder} ) ) { | |||
| 355 | $class->throw_error("You cannot have a required attribute ($name) without a default, builder, or an init_arg", data => $options); | |||
| 356 | } | |||
| 357 | ||||
| 358 | } | |||
| 359 | ||||
| 360 | sub initialize_instance_slot { | |||
| 361 | my ($self, $meta_instance, $instance, $params) = @_; | |||
| 362 | my $init_arg = $self->init_arg(); | |||
| 363 | # try to fetch the init arg from the %params ... | |||
| 364 | ||||
| 365 | my $val; | |||
| 366 | my $value_is_set; | |||
| 367 | if ( defined($init_arg) and exists $params->{$init_arg}) { | |||
| 368 | $val = $params->{$init_arg}; | |||
| 369 | $value_is_set = 1; | |||
| 370 | } | |||
| 371 | else { | |||
| 372 | # skip it if it's lazy | |||
| 373 | return if $self->is_lazy; | |||
| 374 | # and die if it's required and doesn't have a default value | |||
| 375 | $self->throw_error("Attribute (" . $self->name . ") is required", object => $instance, data => $params) | |||
| 376 | if $self->is_required && !$self->has_default && !$self->has_builder; | |||
| 377 | ||||
| 378 | # if nothing was in the %params, we can use the | |||
| 379 | # attribute's default value (if it has one) | |||
| 380 | if ($self->has_default) { | |||
| 381 | $val = $self->default($instance); | |||
| 382 | $value_is_set = 1; | |||
| 383 | } | |||
| 384 | elsif ($self->has_builder) { | |||
| 385 | $val = $self->_call_builder($instance); | |||
| 386 | $value_is_set = 1; | |||
| 387 | } | |||
| 388 | } | |||
| 389 | ||||
| 390 | return unless $value_is_set; | |||
| 391 | ||||
| 392 | $val = $self->_coerce_and_verify( $val, $instance ); | |||
| 393 | ||||
| 394 | $self->set_initial_value($instance, $val); | |||
| 395 | ||||
| 396 | if ( ref $val && $self->is_weak_ref ) { | |||
| 397 | $self->_weaken_value($instance); | |||
| 398 | } | |||
| 399 | } | |||
| 400 | ||||
| 401 | sub _call_builder { | |||
| 402 | my ( $self, $instance ) = @_; | |||
| 403 | ||||
| 404 | my $builder = $self->builder(); | |||
| 405 | ||||
| 406 | return $instance->$builder() | |||
| 407 | if $instance->can( $self->builder ); | |||
| 408 | ||||
| 409 | $self->throw_error( blessed($instance) | |||
| 410 | . " does not support builder method '" | |||
| 411 | . $self->builder | |||
| 412 | . "' for attribute '" | |||
| 413 | . $self->name | |||
| 414 | . "'", | |||
| 415 | object => $instance, | |||
| 416 | ); | |||
| 417 | } | |||
| 418 | ||||
| 419 | ## Slot management | |||
| 420 | ||||
| 421 | # FIXME: | |||
| 422 | # this duplicates too much code from | |||
| 423 | # Class::MOP::Attribute, we need to | |||
| 424 | # refactor these bits eventually. | |||
| 425 | # - SL | |||
| 426 | sub _set_initial_slot_value { | |||
| 427 | my ($self, $meta_instance, $instance, $value) = @_; | |||
| 428 | ||||
| 429 | my $slot_name = $self->name; | |||
| 430 | ||||
| 431 | return $meta_instance->set_slot_value($instance, $slot_name, $value) | |||
| 432 | unless $self->has_initializer; | |||
| 433 | ||||
| 434 | my $callback = sub { | |||
| 435 | my $val = $self->_coerce_and_verify( shift, $instance );; | |||
| 436 | ||||
| 437 | $meta_instance->set_slot_value($instance, $slot_name, $val); | |||
| 438 | }; | |||
| 439 | ||||
| 440 | my $initializer = $self->initializer; | |||
| 441 | ||||
| 442 | # most things will just want to set a value, so make it first arg | |||
| 443 | $instance->$initializer($value, $callback, $self); | |||
| 444 | } | |||
| 445 | ||||
| 446 | sub set_value { | |||
| 447 | my ($self, $instance, @args) = @_; | |||
| 448 | my $value = $args[0]; | |||
| 449 | ||||
| 450 | my $attr_name = $self->name; | |||
| 451 | ||||
| 452 | if ($self->is_required and not @args) { | |||
| 453 | $self->throw_error("Attribute ($attr_name) is required", object => $instance); | |||
| 454 | } | |||
| 455 | ||||
| 456 | $value = $self->_coerce_and_verify( $value, $instance ); | |||
| 457 | ||||
| 458 | my @old; | |||
| 459 | if ( $self->has_trigger && $self->has_value($instance) ) { | |||
| 460 | @old = $self->get_value($instance, 'for trigger'); | |||
| 461 | } | |||
| 462 | ||||
| 463 | $self->SUPER::set_value($instance, $value); | |||
| 464 | ||||
| 465 | if ( ref $value && $self->is_weak_ref ) { | |||
| 466 | $self->_weaken_value($instance); | |||
| 467 | } | |||
| 468 | ||||
| 469 | if ($self->has_trigger) { | |||
| 470 | $self->trigger->($instance, $value, @old); | |||
| 471 | } | |||
| 472 | } | |||
| 473 | ||||
| 474 | sub _weaken_value { | |||
| 475 | my ( $self, $instance ) = @_; | |||
| 476 | ||||
| 477 | my $meta_instance = Class::MOP::Class->initialize( blessed($instance) ) | |||
| 478 | ->get_meta_instance; | |||
| 479 | ||||
| 480 | $meta_instance->weaken_slot_value( $instance, $self->name ); | |||
| 481 | } | |||
| 482 | ||||
| 483 | sub get_value { | |||
| 484 | my ($self, $instance, $for_trigger) = @_; | |||
| 485 | ||||
| 486 | if ($self->is_lazy) { | |||
| 487 | unless ($self->has_value($instance)) { | |||
| 488 | my $value; | |||
| 489 | if ($self->has_default) { | |||
| 490 | $value = $self->default($instance); | |||
| 491 | } elsif ( $self->has_builder ) { | |||
| 492 | $value = $self->_call_builder($instance); | |||
| 493 | } | |||
| 494 | ||||
| 495 | $value = $self->_coerce_and_verify( $value, $instance ); | |||
| 496 | ||||
| 497 | $self->set_initial_value($instance, $value); | |||
| 498 | } | |||
| 499 | } | |||
| 500 | ||||
| 501 | if ( $self->should_auto_deref && ! $for_trigger ) { | |||
| 502 | ||||
| 503 | my $type_constraint = $self->type_constraint; | |||
| 504 | ||||
| 505 | if ($type_constraint->is_a_type_of('ArrayRef')) { | |||
| 506 | my $rv = $self->SUPER::get_value($instance); | |||
| 507 | return unless defined $rv; | |||
| 508 | return wantarray ? @{ $rv } : $rv; | |||
| 509 | } | |||
| 510 | elsif ($type_constraint->is_a_type_of('HashRef')) { | |||
| 511 | my $rv = $self->SUPER::get_value($instance); | |||
| 512 | return unless defined $rv; | |||
| 513 | return wantarray ? %{ $rv } : $rv; | |||
| 514 | } | |||
| 515 | else { | |||
| 516 | $self->throw_error("Can not auto de-reference the type constraint '" . $type_constraint->name . "'", object => $instance, type_constraint => $type_constraint); | |||
| 517 | } | |||
| 518 | ||||
| 519 | } | |||
| 520 | else { | |||
| 521 | ||||
| 522 | return $self->SUPER::get_value($instance); | |||
| 523 | } | |||
| 524 | } | |||
| 525 | ||||
| 526 | ## installing accessors | |||
| 527 | ||||
| 528 | 11 | 22µs | 2µs | # spent 57µs within Moose::Meta::Attribute::accessor_metaclass which was called 11 times, avg 5µs/call:
# 11 times (57µs+0s) by Class::MOP::Attribute::_process_accessors or Class::MOP::Attribute::__ANON__[/usr/local/lib/perl/5.10.0/Class/MOP/Attribute.pm:342] at line 334 of /usr/local/lib/perl/5.10.0/Class/MOP/Attribute.pm, avg 5µs/call |
| 529 | ||||
| 530 | # spent 19.7ms (141µs+19.5) within Moose::Meta::Attribute::install_accessors which was called 10 times, avg 1.97ms/call:
# 9 times (123µs+17.6ms) by Class::MOP::Class::_post_add_attribute or Class::MOP::Class::__ANON__[/usr/local/lib/perl/5.10.0/Class/MOP/Class.pm:768] at line 767 of /usr/local/lib/perl/5.10.0/Class/MOP/Class.pm, avg 1.97ms/call
# once (18µs+1.94ms) by Class::MOP::Class::_inline_accessors at line 1273 of /usr/local/lib/perl/5.10.0/Class/MOP/Class.pm | |||
| 531 | 40 | 160µs | 4µs | my $self = shift; |
| 532 | $self->SUPER::install_accessors(@_); # spent 19.3ms making 10 calls to Class::MOP::Attribute::install_accessors, avg 1.93ms/call | |||
| 533 | $self->install_delegation if $self->has_handles; # spent 175µs making 10 calls to Moose::Meta::Mixin::AttributeCore::has_handles, avg 17µs/call | |||
| 534 | return; | |||
| 535 | } | |||
| 536 | ||||
| 537 | # spent 91µs (55+36) within Moose::Meta::Attribute::_check_associated_methods which was called 8 times, avg 11µs/call:
# 8 times (55µs+36µs) by Moose::Meta::Class::add_attribute at line 301 of /usr/local/lib/perl/5.10.0/Moose/Meta/Class.pm, avg 11µs/call | |||
| 538 | 16 | 49µs | 3µs | my $self = shift; |
| 539 | unless ( # spent 36µs making 8 calls to Class::MOP::Attribute::associated_methods, avg 4µs/call | |||
| 540 | @{ $self->associated_methods } | |||
| 541 | || ($self->_is_metadata || '') eq 'bare' | |||
| 542 | ) { | |||
| 543 | Carp::cluck( | |||
| 544 | 'Attribute (' . $self->name . ') of class ' | |||
| 545 | . $self->associated_class->name | |||
| 546 | . ' has no associated methods' | |||
| 547 | . ' (did you mean to provide an "is" argument?)' | |||
| 548 | . "\n" | |||
| 549 | ) | |||
| 550 | } | |||
| 551 | } | |||
| 552 | ||||
| 553 | # spent 17.1ms (301µs+16.8) within Moose::Meta::Attribute::_process_accessors which was called 11 times, avg 1.56ms/call:
# 7 times (186µs+9.44ms) by Class::MOP::Attribute::install_accessors at line 356 of /usr/local/lib/perl/5.10.0/Class/MOP/Attribute.pm, avg 1.38ms/call
# 3 times (91µs+6.25ms) by Class::MOP::Attribute::install_accessors at line 360 of /usr/local/lib/perl/5.10.0/Class/MOP/Attribute.pm, avg 2.11ms/call
# once (25µs+1.15ms) by Class::MOP::Attribute::install_accessors at line 364 of /usr/local/lib/perl/5.10.0/Class/MOP/Attribute.pm | |||
| 554 | 77 | 478µs | 6µs | my $self = shift; |
| 555 | my ($type, $accessor, $generate_as_inline_methods) = @_; | |||
| 556 | $accessor = (keys %$accessor)[0] if (ref($accessor)||'') eq 'HASH'; | |||
| 557 | my $method = $self->associated_class->get_method($accessor); # spent 993µs making 11 calls to Class::MOP::Mixin::HasMethods::get_method, avg 90µs/call
# spent 40µs making 11 calls to Class::MOP::Attribute::associated_class, avg 4µs/call | |||
| 558 | if ($method && !$method->isa('Class::MOP::Method::Accessor') # spent 10µs making 1 call to UNIVERSAL::isa | |||
| 559 | && (!$self->definition_context | |||
| 560 | || $method->package_name eq $self->definition_context->{package})) { | |||
| 561 | Carp::cluck( | |||
| 562 | "You are overwriting a locally defined method ($accessor) with " | |||
| 563 | . "an accessor" | |||
| 564 | ); | |||
| 565 | } | |||
| 566 | if (!$self->associated_class->has_method($accessor) # spent 581µs making 11 calls to Class::MOP::Mixin::HasMethods::has_method, avg 53µs/call
# spent 471µs making 10 calls to Class::MOP::Package::has_package_symbol, avg 47µs/call
# spent 74µs making 21 calls to Class::MOP::Attribute::associated_class, avg 4µs/call | |||
| 567 | && $self->associated_class->has_package_symbol('&' . $accessor)) { | |||
| 568 | Carp::cluck( | |||
| 569 | "You are overwriting a locally defined function ($accessor) with " | |||
| 570 | . "an accessor" | |||
| 571 | ); | |||
| 572 | } | |||
| 573 | $self->SUPER::_process_accessors(@_); # spent 14.7ms making 11 calls to Class::MOP::Attribute::_process_accessors, avg 1.33ms/call | |||
| 574 | } | |||
| 575 | ||||
| 576 | sub remove_accessors { | |||
| 577 | my $self = shift; | |||
| 578 | $self->SUPER::remove_accessors(@_); | |||
| 579 | $self->remove_delegation if $self->has_handles; | |||
| 580 | return; | |||
| 581 | } | |||
| 582 | ||||
| 583 | # spent 2.92ms (422µs+2.49) within Moose::Meta::Attribute::inline_set which was called 26 times, avg 112µs/call:
# 16 times (222µs+572µs) by Moose::Meta::Method::Constructor::_generate_slot_assignment at line 281 of /usr/local/lib/perl/5.10.0/Moose/Meta/Method/Constructor.pm, avg 50µs/call
# 8 times (141µs+1.66ms) by Moose::Meta::Method::Accessor::_inline_store at line 252 of /usr/local/lib/perl/5.10.0/Moose/Meta/Method/Accessor.pm, avg 226µs/call
# 2 times (58µs+257µs) by Class::MOP::Method::Constructor::_generate_slot_initializer at line 142 of /usr/local/lib/perl/5.10.0/Class/MOP/Method/Constructor.pm, avg 158µs/call | |||
| 584 | 156 | 709µs | 5µs | my $self = shift; |
| 585 | my ( $instance, $value ) = @_; | |||
| 586 | ||||
| 587 | my $mi = $self->associated_class->get_meta_instance; # spent 1.46ms making 23 calls to Class::MOP::Class::get_meta_instance, avg 64µs/call
# spent 106µs making 26 calls to Class::MOP::Attribute::associated_class, avg 4µs/call
# spent 42µs making 2 calls to Class::MOP::Class::Immutable::Moose::Meta::Class::get_meta_instance, avg 21µs/call
# spent 30µs making 1 call to Class::MOP::Class::Immutable::Class::MOP::Class::get_meta_instance | |||
| 588 | ||||
| 589 | my $code # spent 407µs making 26 calls to Class::MOP::Instance::inline_set_slot_value, avg 16µs/call
# spent 182µs making 26 calls to Class::MOP::Attribute::slots, avg 7µs/call | |||
| 590 | = $mi->inline_set_slot_value( $instance, $self->slots, $value ) . ";"; | |||
| 591 | $code # spent 221µs making 26 calls to Moose::Meta::Mixin::AttributeCore::is_weak_ref, avg 9µs/call
# spent 32µs making 2 calls to Class::MOP::Instance::inline_weaken_slot_value, avg 16µs/call
# spent 13µs making 2 calls to Class::MOP::Attribute::slots, avg 6µs/call | |||
| 592 | .= $mi->inline_weaken_slot_value( $instance, $self->slots, $value ) | |||
| 593 | . " if ref $value;" | |||
| 594 | if $self->is_weak_ref; | |||
| 595 | ||||
| 596 | return $code; | |||
| 597 | } | |||
| 598 | ||||
| 599 | sub install_delegation { | |||
| 600 | my $self = shift; | |||
| 601 | ||||
| 602 | # NOTE: | |||
| 603 | # Here we canonicalize the 'handles' option | |||
| 604 | # this will sort out any details and always | |||
| 605 | # return an hash of methods which we want | |||
| 606 | # to delagate to, see that method for details | |||
| 607 | my %handles = $self->_canonicalize_handles; | |||
| 608 | ||||
| 609 | ||||
| 610 | # install the delegation ... | |||
| 611 | my $associated_class = $self->associated_class; | |||
| 612 | foreach my $handle (keys %handles) { | |||
| 613 | my $method_to_call = $handles{$handle}; | |||
| 614 | my $class_name = $associated_class->name; | |||
| 615 | my $name = "${class_name}::${handle}"; | |||
| 616 | ||||
| 617 | (!$associated_class->has_method($handle)) | |||
| 618 | || $self->throw_error("You cannot overwrite a locally defined method ($handle) with a delegation", method_name => $handle); | |||
| 619 | ||||
| 620 | # NOTE: | |||
| 621 | # handles is not allowed to delegate | |||
| 622 | # any of these methods, as they will | |||
| 623 | # override the ones in your class, which | |||
| 624 | # is almost certainly not what you want. | |||
| 625 | ||||
| 626 | # FIXME warn when $handle was explicitly specified, but not if the source is a regex or something | |||
| 627 | #cluck("Not delegating method '$handle' because it is a core method") and | |||
| 628 | next if $class_name->isa("Moose::Object") and $handle =~ /^BUILD|DEMOLISH$/ || Moose::Object->can($handle); | |||
| 629 | ||||
| 630 | my $method = $self->_make_delegation_method($handle, $method_to_call); | |||
| 631 | ||||
| 632 | $self->associated_class->add_method($method->name, $method); | |||
| 633 | $self->associate_method($method); | |||
| 634 | } | |||
| 635 | } | |||
| 636 | ||||
| 637 | sub remove_delegation { | |||
| 638 | my $self = shift; | |||
| 639 | my %handles = $self->_canonicalize_handles; | |||
| 640 | my $associated_class = $self->associated_class; | |||
| 641 | foreach my $handle (keys %handles) { | |||
| 642 | next unless any { $handle eq $_ } | |||
| 643 | map { $_->name } | |||
| 644 | @{ $self->associated_methods }; | |||
| 645 | $self->associated_class->remove_method($handle); | |||
| 646 | } | |||
| 647 | } | |||
| 648 | ||||
| 649 | # private methods to help delegation ... | |||
| 650 | ||||
| 651 | sub _canonicalize_handles { | |||
| 652 | my $self = shift; | |||
| 653 | my $handles = $self->handles; | |||
| 654 | if (my $handle_type = ref($handles)) { | |||
| 655 | if ($handle_type eq 'HASH') { | |||
| 656 | return %{$handles}; | |||
| 657 | } | |||
| 658 | elsif ($handle_type eq 'ARRAY') { | |||
| 659 | return map { $_ => $_ } @{$handles}; | |||
| 660 | } | |||
| 661 | elsif ($handle_type eq 'Regexp') { | |||
| 662 | ($self->has_type_constraint) | |||
| 663 | || $self->throw_error("Cannot delegate methods based on a Regexp without a type constraint (isa)", data => $handles); | |||
| 664 | return map { ($_ => $_) } | |||
| 665 | grep { /$handles/ } $self->_get_delegate_method_list; | |||
| 666 | } | |||
| 667 | elsif ($handle_type eq 'CODE') { | |||
| 668 | return $handles->($self, $self->_find_delegate_metaclass); | |||
| 669 | } | |||
| 670 | elsif (blessed($handles) && $handles->isa('Moose::Meta::TypeConstraint::DuckType')) { | |||
| 671 | return map { $_ => $_ } @{ $handles->methods }; | |||
| 672 | } | |||
| 673 | elsif (blessed($handles) && $handles->isa('Moose::Meta::TypeConstraint::Role')) { | |||
| 674 | $handles = $handles->role; | |||
| 675 | } | |||
| 676 | else { | |||
| 677 | $self->throw_error("Unable to canonicalize the 'handles' option with $handles", data => $handles); | |||
| 678 | } | |||
| 679 | } | |||
| 680 | ||||
| 681 | Class::MOP::load_class($handles); | |||
| 682 | my $role_meta = Class::MOP::class_of($handles); | |||
| 683 | ||||
| 684 | (blessed $role_meta && $role_meta->isa('Moose::Meta::Role')) | |||
| 685 | || $self->throw_error("Unable to canonicalize the 'handles' option with $handles because its metaclass is not a Moose::Meta::Role", data => $handles); | |||
| 686 | ||||
| 687 | return map { $_ => $_ } | |||
| 688 | map { $_->name } | |||
| 689 | grep { !$_->isa('Class::MOP::Method::Meta') } ( | |||
| 690 | $role_meta->_get_local_methods, | |||
| 691 | $role_meta->get_required_method_list, | |||
| 692 | ); | |||
| 693 | } | |||
| 694 | ||||
| 695 | sub _find_delegate_metaclass { | |||
| 696 | my $self = shift; | |||
| 697 | if (my $class = $self->_isa_metadata) { | |||
| 698 | # we might be dealing with a non-Moose class, | |||
| 699 | # and need to make our own metaclass. if there's | |||
| 700 | # already a metaclass, it will be returned | |||
| 701 | return Class::MOP::Class->initialize($class); | |||
| 702 | } | |||
| 703 | elsif (my $role = $self->_does_metadata) { | |||
| 704 | return Class::MOP::class_of($role); | |||
| 705 | } | |||
| 706 | else { | |||
| 707 | $self->throw_error("Cannot find delegate metaclass for attribute " . $self->name); | |||
| 708 | } | |||
| 709 | } | |||
| 710 | ||||
| 711 | sub _get_delegate_method_list { | |||
| 712 | my $self = shift; | |||
| 713 | my $meta = $self->_find_delegate_metaclass; | |||
| 714 | if ($meta->isa('Class::MOP::Class')) { | |||
| 715 | return map { $_->name } # NOTE: !never! delegate &meta | |||
| 716 | grep { $_->package_name ne 'Moose::Object' && !$_->isa('Class::MOP::Method::Meta') } | |||
| 717 | $meta->get_all_methods; | |||
| 718 | } | |||
| 719 | elsif ($meta->isa('Moose::Meta::Role')) { | |||
| 720 | return $meta->get_method_list; | |||
| 721 | } | |||
| 722 | else { | |||
| 723 | $self->throw_error("Unable to recognize the delegate metaclass '$meta'", data => $meta); | |||
| 724 | } | |||
| 725 | } | |||
| 726 | ||||
| 727 | sub delegation_metaclass { 'Moose::Meta::Method::Delegation' } | |||
| 728 | ||||
| 729 | sub _make_delegation_method { | |||
| 730 | my ( $self, $handle_name, $method_to_call ) = @_; | |||
| 731 | ||||
| 732 | my @curried_arguments; | |||
| 733 | ||||
| 734 | ($method_to_call, @curried_arguments) = @$method_to_call | |||
| 735 | if 'ARRAY' eq ref($method_to_call); | |||
| 736 | ||||
| 737 | return $self->delegation_metaclass->new( | |||
| 738 | name => $handle_name, | |||
| 739 | package_name => $self->associated_class->name, | |||
| 740 | attribute => $self, | |||
| 741 | delegate_to_method => $method_to_call, | |||
| 742 | curried_arguments => \@curried_arguments, | |||
| 743 | ); | |||
| 744 | } | |||
| 745 | ||||
| 746 | sub _coerce_and_verify { | |||
| 747 | my $self = shift; | |||
| 748 | my $val = shift; | |||
| 749 | my $instance = shift; | |||
| 750 | ||||
| 751 | return $val unless $self->has_type_constraint; | |||
| 752 | ||||
| 753 | $val = $self->type_constraint->coerce($val) | |||
| 754 | if $self->should_coerce && $self->type_constraint->has_coercion; | |||
| 755 | ||||
| 756 | $self->verify_against_type_constraint($val, instance => $instance); | |||
| 757 | ||||
| 758 | return $val; | |||
| 759 | } | |||
| 760 | ||||
| 761 | sub verify_against_type_constraint { | |||
| 762 | my $self = shift; | |||
| 763 | my $val = shift; | |||
| 764 | ||||
| 765 | return 1 if !$self->has_type_constraint; | |||
| 766 | ||||
| 767 | my $type_constraint = $self->type_constraint; | |||
| 768 | ||||
| 769 | $type_constraint->check($val) | |||
| 770 | || $self->throw_error("Attribute (" | |||
| 771 | . $self->name | |||
| 772 | . ") does not pass the type constraint because: " | |||
| 773 | . $type_constraint->get_message($val), data => $val, @_); | |||
| 774 | } | |||
| 775 | ||||
| 776 | package Moose::Meta::Attribute::Custom::Moose; | |||
| 777 | sub register_implementation { 'Moose::Meta::Attribute' } | |||
| 778 | ||||
| 779 | 1 | 11µs | 11µs | 1; |
| 780 | ||||
| 781 | __END__ | |||
| 782 | ||||
| 783 | =pod | |||
| 784 | ||||
| 785 | =head1 NAME | |||
| 786 | ||||
| 787 | Moose::Meta::Attribute - The Moose attribute metaclass | |||
| 788 | ||||
| 789 | =head1 DESCRIPTION | |||
| 790 | ||||
| 791 | This class is a subclass of L<Class::MOP::Attribute> that provides | |||
| 792 | additional Moose-specific functionality. | |||
| 793 | ||||
| 794 | To really understand this class, you will need to start with the | |||
| 795 | L<Class::MOP::Attribute> documentation. This class can be understood | |||
| 796 | as a set of additional features on top of the basic feature provided | |||
| 797 | by that parent class. | |||
| 798 | ||||
| 799 | =head1 INHERITANCE | |||
| 800 | ||||
| 801 | C<Moose::Meta::Attribute> is a subclass of L<Class::MOP::Attribute>. | |||
| 802 | ||||
| 803 | =head1 METHODS | |||
| 804 | ||||
| 805 | Many of the documented below override methods in | |||
| 806 | L<Class::MOP::Attribute> and add Moose specific features. | |||
| 807 | ||||
| 808 | =head2 Creation | |||
| 809 | ||||
| 810 | =over 4 | |||
| 811 | ||||
| 812 | =item B<< Moose::Meta::Attribute->new(%options) >> | |||
| 813 | ||||
| 814 | This method overrides the L<Class::MOP::Attribute> constructor. | |||
| 815 | ||||
| 816 | Many of the options below are described in more detail in the | |||
| 817 | L<Moose::Manual::Attributes> document. | |||
| 818 | ||||
| 819 | It adds the following options to the constructor: | |||
| 820 | ||||
| 821 | =over 8 | |||
| 822 | ||||
| 823 | =item * is => 'ro', 'rw', 'bare' | |||
| 824 | ||||
| 825 | This provides a shorthand for specifying the C<reader>, C<writer>, or | |||
| 826 | C<accessor> names. If the attribute is read-only ('ro') then it will | |||
| 827 | have a C<reader> method with the same attribute as the name. | |||
| 828 | ||||
| 829 | If it is read-write ('rw') then it will have an C<accessor> method | |||
| 830 | with the same name. If you provide an explicit C<writer> for a | |||
| 831 | read-write attribute, then you will have a C<reader> with the same | |||
| 832 | name as the attribute, and a C<writer> with the name you provided. | |||
| 833 | ||||
| 834 | Use 'bare' when you are deliberately not installing any methods | |||
| 835 | (accessor, reader, etc.) associated with this attribute; otherwise, | |||
| 836 | Moose will issue a deprecation warning when this attribute is added to a | |||
| 837 | metaclass. | |||
| 838 | ||||
| 839 | =item * isa => $type | |||
| 840 | ||||
| 841 | This option accepts a type. The type can be a string, which should be | |||
| 842 | a type name. If the type name is unknown, it is assumed to be a class | |||
| 843 | name. | |||
| 844 | ||||
| 845 | This option can also accept a L<Moose::Meta::TypeConstraint> object. | |||
| 846 | ||||
| 847 | If you I<also> provide a C<does> option, then your C<isa> option must | |||
| 848 | be a class name, and that class must do the role specified with | |||
| 849 | C<does>. | |||
| 850 | ||||
| 851 | =item * does => $role | |||
| 852 | ||||
| 853 | This is short-hand for saying that the attribute's type must be an | |||
| 854 | object which does the named role. | |||
| 855 | ||||
| 856 | =item * coerce => $bool | |||
| 857 | ||||
| 858 | This option is only valid for objects with a type constraint | |||
| 859 | (C<isa>) that defined a coercion. If this is true, then coercions will be applied whenever | |||
| 860 | this attribute is set. | |||
| 861 | ||||
| 862 | You can make both this and the C<weak_ref> option true. | |||
| 863 | ||||
| 864 | =item * trigger => $sub | |||
| 865 | ||||
| 866 | This option accepts a subroutine reference, which will be called after | |||
| 867 | the attribute is set. | |||
| 868 | ||||
| 869 | =item * required => $bool | |||
| 870 | ||||
| 871 | An attribute which is required must be provided to the constructor. An | |||
| 872 | attribute which is required can also have a C<default> or C<builder>, | |||
| 873 | which will satisfy its required-ness. | |||
| 874 | ||||
| 875 | A required attribute must have a C<default>, C<builder> or a | |||
| 876 | non-C<undef> C<init_arg> | |||
| 877 | ||||
| 878 | =item * lazy => $bool | |||
| 879 | ||||
| 880 | A lazy attribute must have a C<default> or C<builder>. When an | |||
| 881 | attribute is lazy, the default value will not be calculated until the | |||
| 882 | attribute is read. | |||
| 883 | ||||
| 884 | =item * weak_ref => $bool | |||
| 885 | ||||
| 886 | If this is true, the attribute's value will be stored as a weak | |||
| 887 | reference. | |||
| 888 | ||||
| 889 | =item * auto_deref => $bool | |||
| 890 | ||||
| 891 | If this is true, then the reader will dereference the value when it is | |||
| 892 | called. The attribute must have a type constraint which defines the | |||
| 893 | attribute as an array or hash reference. | |||
| 894 | ||||
| 895 | =item * lazy_build => $bool | |||
| 896 | ||||
| 897 | Setting this to true makes the attribute lazy and provides a number of | |||
| 898 | default methods. | |||
| 899 | ||||
| 900 | has 'size' => ( | |||
| 901 | is => 'ro', | |||
| 902 | lazy_build => 1, | |||
| 903 | ); | |||
| 904 | ||||
| 905 | is equivalent to this: | |||
| 906 | ||||
| 907 | has 'size' => ( | |||
| 908 | is => 'ro', | |||
| 909 | lazy => 1, | |||
| 910 | builder => '_build_size', | |||
| 911 | clearer => 'clear_size', | |||
| 912 | predicate => 'has_size', | |||
| 913 | ); | |||
| 914 | ||||
| 915 | =item * documentation | |||
| 916 | ||||
| 917 | An arbitrary string that can be retrieved later by calling C<< | |||
| 918 | $attr->documentation >>. | |||
| 919 | ||||
| 920 | =back | |||
| 921 | ||||
| 922 | =item B<< $attr->clone(%options) >> | |||
| 923 | ||||
| 924 | This creates a new attribute based on attribute being cloned. You must | |||
| 925 | supply a C<name> option to provide a new name for the attribute. | |||
| 926 | ||||
| 927 | The C<%options> can only specify options handled by | |||
| 928 | L<Class::MOP::Attribute>. | |||
| 929 | ||||
| 930 | =back | |||
| 931 | ||||
| 932 | =head2 Value management | |||
| 933 | ||||
| 934 | =over 4 | |||
| 935 | ||||
| 936 | =item B<< $attr->initialize_instance_slot($meta_instance, $instance, $params) >> | |||
| 937 | ||||
| 938 | This method is used internally to initialize the attribute's slot in | |||
| 939 | the object C<$instance>. | |||
| 940 | ||||
| 941 | This overrides the L<Class::MOP::Attribute> method to handle lazy | |||
| 942 | attributes, weak references, and type constraints. | |||
| 943 | ||||
| 944 | =item B<get_value> | |||
| 945 | ||||
| 946 | =item B<set_value> | |||
| 947 | ||||
| 948 | eval { $point->meta->get_attribute('x')->set_value($point, 'forty-two') }; | |||
| 949 | if($@) { | |||
| 950 | print "Oops: $@\n"; | |||
| 951 | } | |||
| 952 | ||||
| 953 | I<Attribute (x) does not pass the type constraint (Int) with 'forty-two'> | |||
| 954 | ||||
| 955 | Before setting the value, a check is made on the type constraint of | |||
| 956 | the attribute, if it has one, to see if the value passes it. If the | |||
| 957 | value fails to pass, the set operation dies with a L</throw_error>. | |||
| 958 | ||||
| 959 | Any coercion to convert values is done before checking the type constraint. | |||
| 960 | ||||
| 961 | To check a value against a type constraint before setting it, fetch the | |||
| 962 | attribute instance using L<Class::MOP::Class/find_attribute_by_name>, | |||
| 963 | fetch the type_constraint from the attribute using L<Moose::Meta::Attribute/type_constraint> | |||
| 964 | and call L<Moose::Meta::TypeConstraint/check>. See L<Moose::Cookbook::Basics::Recipe4> | |||
| 965 | for an example. | |||
| 966 | ||||
| 967 | =back | |||
| 968 | ||||
| 969 | =head2 Attribute Accessor generation | |||
| 970 | ||||
| 971 | =over 4 | |||
| 972 | ||||
| 973 | =item B<< $attr->install_accessors >> | |||
| 974 | ||||
| 975 | This method overrides the parent to also install delegation methods. | |||
| 976 | ||||
| 977 | If, after installing all methods, the attribute object has no associated | |||
| 978 | methods, it throws an error unless C<< is => 'bare' >> was passed to the | |||
| 979 | attribute constructor. (Trying to add an attribute that has no associated | |||
| 980 | methods is almost always an error.) | |||
| 981 | ||||
| 982 | =item B<< $attr->remove_accessors >> | |||
| 983 | ||||
| 984 | This method overrides the parent to also remove delegation methods. | |||
| 985 | ||||
| 986 | =item B<< $attr->inline_set($instance_var, $value_var) >> | |||
| 987 | ||||
| 988 | This method return a code snippet suitable for inlining the relevant | |||
| 989 | operation. It expect strings containing variable names to be used in the | |||
| 990 | inlining, like C<'$self'> or C<'$_[1]'>. | |||
| 991 | ||||
| 992 | =item B<< $attr->install_delegation >> | |||
| 993 | ||||
| 994 | This method adds its delegation methods to the attribute's associated | |||
| 995 | class, if it has any to add. | |||
| 996 | ||||
| 997 | =item B<< $attr->remove_delegation >> | |||
| 998 | ||||
| 999 | This method remove its delegation methods from the attribute's | |||
| 1000 | associated class. | |||
| 1001 | ||||
| 1002 | =item B<< $attr->accessor_metaclass >> | |||
| 1003 | ||||
| 1004 | Returns the accessor metaclass name, which defaults to | |||
| 1005 | L<Moose::Meta::Method::Accessor>. | |||
| 1006 | ||||
| 1007 | =item B<< $attr->delegation_metaclass >> | |||
| 1008 | ||||
| 1009 | Returns the delegation metaclass name, which defaults to | |||
| 1010 | L<Moose::Meta::Method::Delegation>. | |||
| 1011 | ||||
| 1012 | =back | |||
| 1013 | ||||
| 1014 | =head2 Additional Moose features | |||
| 1015 | ||||
| 1016 | These methods are not found in the superclass. They support features | |||
| 1017 | provided by Moose. | |||
| 1018 | ||||
| 1019 | =over 4 | |||
| 1020 | ||||
| 1021 | =item B<< $attr->does($role) >> | |||
| 1022 | ||||
| 1023 | This indicates whether the I<attribute itself> does the given | |||
| 1024 | role. The role can be given as a full class name, or as a resolvable | |||
| 1025 | trait name. | |||
| 1026 | ||||
| 1027 | Note that this checks the attribute itself, not its type constraint, | |||
| 1028 | so it is checking the attribute's metaclass and any traits applied to | |||
| 1029 | the attribute. | |||
| 1030 | ||||
| 1031 | =item B<< Moose::Meta::Class->interpolate_class_and_new($name, %options) >> | |||
| 1032 | ||||
| 1033 | This is an alternate constructor that handles the C<metaclass> and | |||
| 1034 | C<traits> options. | |||
| 1035 | ||||
| 1036 | Effectively, this method is a factory that finds or creates the | |||
| 1037 | appropriate class for the given C<metaclass> and/or C<traits>. | |||
| 1038 | ||||
| 1039 | Once it has the appropriate class, it will call C<< $class->new($name, | |||
| 1040 | %options) >> on that class. | |||
| 1041 | ||||
| 1042 | =item B<< $attr->clone_and_inherit_options(%options) >> | |||
| 1043 | ||||
| 1044 | This method supports the C<has '+foo'> feature. It does various bits | |||
| 1045 | of processing on the supplied C<%options> before ultimately calling | |||
| 1046 | the C<clone> method. | |||
| 1047 | ||||
| 1048 | One of its main tasks is to make sure that the C<%options> provided | |||
| 1049 | does not include the options returned by the | |||
| 1050 | C<illegal_options_for_inheritance> method. | |||
| 1051 | ||||
| 1052 | =item B<< $attr->illegal_options_for_inheritance >> | |||
| 1053 | ||||
| 1054 | This returns a blacklist of options that can not be overridden in a | |||
| 1055 | subclass's attribute definition. | |||
| 1056 | ||||
| 1057 | This exists to allow a custom metaclass to change or add to the list | |||
| 1058 | of options which can not be changed. | |||
| 1059 | ||||
| 1060 | =item B<< $attr->type_constraint >> | |||
| 1061 | ||||
| 1062 | Returns the L<Moose::Meta::TypeConstraint> object for this attribute, | |||
| 1063 | if it has one. | |||
| 1064 | ||||
| 1065 | =item B<< $attr->has_type_constraint >> | |||
| 1066 | ||||
| 1067 | Returns true if this attribute has a type constraint. | |||
| 1068 | ||||
| 1069 | =item B<< $attr->verify_against_type_constraint($value) >> | |||
| 1070 | ||||
| 1071 | Given a value, this method returns true if the value is valid for the | |||
| 1072 | attribute's type constraint. If the value is not valid, it throws an | |||
| 1073 | error. | |||
| 1074 | ||||
| 1075 | =item B<< $attr->handles >> | |||
| 1076 | ||||
| 1077 | This returns the value of the C<handles> option passed to the | |||
| 1078 | constructor. | |||
| 1079 | ||||
| 1080 | =item B<< $attr->has_handles >> | |||
| 1081 | ||||
| 1082 | Returns true if this attribute performs delegation. | |||
| 1083 | ||||
| 1084 | =item B<< $attr->is_weak_ref >> | |||
| 1085 | ||||
| 1086 | Returns true if this attribute stores its value as a weak reference. | |||
| 1087 | ||||
| 1088 | =item B<< $attr->is_required >> | |||
| 1089 | ||||
| 1090 | Returns true if this attribute is required to have a value. | |||
| 1091 | ||||
| 1092 | =item B<< $attr->is_lazy >> | |||
| 1093 | ||||
| 1094 | Returns true if this attribute is lazy. | |||
| 1095 | ||||
| 1096 | =item B<< $attr->is_lazy_build >> | |||
| 1097 | ||||
| 1098 | Returns true if the C<lazy_build> option was true when passed to the | |||
| 1099 | constructor. | |||
| 1100 | ||||
| 1101 | =item B<< $attr->should_coerce >> | |||
| 1102 | ||||
| 1103 | Returns true if the C<coerce> option passed to the constructor was | |||
| 1104 | true. | |||
| 1105 | ||||
| 1106 | =item B<< $attr->should_auto_deref >> | |||
| 1107 | ||||
| 1108 | Returns true if the C<auto_deref> option passed to the constructor was | |||
| 1109 | true. | |||
| 1110 | ||||
| 1111 | =item B<< $attr->trigger >> | |||
| 1112 | ||||
| 1113 | This is the subroutine reference that was in the C<trigger> option | |||
| 1114 | passed to the constructor, if any. | |||
| 1115 | ||||
| 1116 | =item B<< $attr->has_trigger >> | |||
| 1117 | ||||
| 1118 | Returns true if this attribute has a trigger set. | |||
| 1119 | ||||
| 1120 | =item B<< $attr->documentation >> | |||
| 1121 | ||||
| 1122 | Returns the value that was in the C<documentation> option passed to | |||
| 1123 | the constructor, if any. | |||
| 1124 | ||||
| 1125 | =item B<< $attr->has_documentation >> | |||
| 1126 | ||||
| 1127 | Returns true if this attribute has any documentation. | |||
| 1128 | ||||
| 1129 | =item B<< $attr->applied_traits >> | |||
| 1130 | ||||
| 1131 | This returns an array reference of all the traits which were applied | |||
| 1132 | to this attribute. If none were applied, this returns C<undef>. | |||
| 1133 | ||||
| 1134 | =item B<< $attr->has_applied_traits >> | |||
| 1135 | ||||
| 1136 | Returns true if this attribute has any traits applied. | |||
| 1137 | ||||
| 1138 | =back | |||
| 1139 | ||||
| 1140 | =head1 BUGS | |||
| 1141 | ||||
| 1142 | See L<Moose/BUGS> for details on reporting bugs. | |||
| 1143 | ||||
| 1144 | =head1 AUTHOR | |||
| 1145 | ||||
| 1146 | Stevan Little E<lt>stevan@iinteractive.comE<gt> | |||
| 1147 | ||||
| 1148 | Yuval Kogman E<lt>nothingmuch@woobling.comE<gt> | |||
| 1149 | ||||
| 1150 | =head1 COPYRIGHT AND LICENSE | |||
| 1151 | ||||
| 1152 | Copyright 2006-2010 by Infinity Interactive, Inc. | |||
| 1153 | ||||
| 1154 | L<http://www.iinteractive.com> | |||
| 1155 | ||||
| 1156 | This library is free software; you can redistribute it and/or modify | |||
| 1157 | it under the same terms as Perl itself. | |||
| 1158 | ||||
| 1159 | =cut |