← Index
Performance Profile   « block view • line view • sub view »
For t/test-parsing
  Run on Sun Nov 14 09:49:57 2010
Reported on Sun Nov 14 09:50:10 2010

File /usr/local/lib/perl/5.10.0/Moose/Meta/Attribute.pm
Statements Executed 847
Total Time 0.008775 seconds
Subroutines — ordered by exclusive time
Calls P F Exclusive
Time
Inclusive
Time
Subroutine
9221.18ms5.69msMoose::Meta::Attribute::::new Moose::Meta::Attribute::new
2633422µs2.92msMoose::Meta::Attribute::::inline_set Moose::Meta::Attribute::inline_set
1131301µs17.1msMoose::Meta::Attribute::::_process_accessors Moose::Meta::Attribute::_process_accessors
911207µs605µsMoose::Meta::Attribute::::_process_options Moose::Meta::Attribute::_process_options
811157µs4.15msMoose::Meta::Attribute::::interpolate_class_and_new Moose::Meta::Attribute::interpolate_class_and_new
1021141µs19.7msMoose::Meta::Attribute::::install_accessors Moose::Meta::Attribute::install_accessors
81189µs89µsMoose::Meta::Attribute::::interpolate_class Moose::Meta::Attribute::interpolate_class
111157µs57µsMoose::Meta::Attribute::::accessor_metaclass Moose::Meta::Attribute::accessor_metaclass
81155µs91µsMoose::Meta::Attribute::::_check_associated_methods Moose::Meta::Attribute::_check_associated_methods
0000s0sMoose::Meta::Attribute::::BEGIN Moose::Meta::Attribute::BEGIN
0000s0sMoose::Meta::Attribute::Custom::Moose::::register_implementationMoose::Meta::Attribute::Custom::Moose::register_implementation
0000s0sMoose::Meta::Attribute::::__ANON__[:277] Moose::Meta::Attribute::__ANON__[:277]
0000s0sMoose::Meta::Attribute::::__ANON__[:39] Moose::Meta::Attribute::__ANON__[:39]
0000s0sMoose::Meta::Attribute::::__ANON__[:438] Moose::Meta::Attribute::__ANON__[:438]
0000s0sMoose::Meta::Attribute::::__ANON__[:642] Moose::Meta::Attribute::__ANON__[:642]
0000s0sMoose::Meta::Attribute::::_call_builder Moose::Meta::Attribute::_call_builder
0000s0sMoose::Meta::Attribute::::_canonicalize_handles Moose::Meta::Attribute::_canonicalize_handles
0000s0sMoose::Meta::Attribute::::_coerce_and_verify Moose::Meta::Attribute::_coerce_and_verify
0000s0sMoose::Meta::Attribute::::_find_delegate_metaclass Moose::Meta::Attribute::_find_delegate_metaclass
0000s0sMoose::Meta::Attribute::::_get_delegate_method_list Moose::Meta::Attribute::_get_delegate_method_list
0000s0sMoose::Meta::Attribute::::_make_delegation_method Moose::Meta::Attribute::_make_delegation_method
0000s0sMoose::Meta::Attribute::::_set_initial_slot_value Moose::Meta::Attribute::_set_initial_slot_value
0000s0sMoose::Meta::Attribute::::_weaken_value Moose::Meta::Attribute::_weaken_value
0000s0sMoose::Meta::Attribute::::clone Moose::Meta::Attribute::clone
0000s0sMoose::Meta::Attribute::::clone_and_inherit_options Moose::Meta::Attribute::clone_and_inherit_options
0000s0sMoose::Meta::Attribute::::delegation_metaclass Moose::Meta::Attribute::delegation_metaclass
0000s0sMoose::Meta::Attribute::::does Moose::Meta::Attribute::does
0000s0sMoose::Meta::Attribute::::get_value Moose::Meta::Attribute::get_value
0000s0sMoose::Meta::Attribute::::illegal_options_for_inheritance Moose::Meta::Attribute::illegal_options_for_inheritance
0000s0sMoose::Meta::Attribute::::initialize_instance_slot Moose::Meta::Attribute::initialize_instance_slot
0000s0sMoose::Meta::Attribute::::install_delegation Moose::Meta::Attribute::install_delegation
0000s0sMoose::Meta::Attribute::::remove_accessors Moose::Meta::Attribute::remove_accessors
0000s0sMoose::Meta::Attribute::::remove_delegation Moose::Meta::Attribute::remove_delegation
0000s0sMoose::Meta::Attribute::::set_value Moose::Meta::Attribute::set_value
0000s0sMoose::Meta::Attribute::::throw_error Moose::Meta::Attribute::throw_error
0000s0sMoose::Meta::Attribute::::verify_against_type_constraint Moose::Meta::Attribute::verify_against_type_constraint
LineStmts.Exclusive
Time
Avg.Code
1
2package Moose::Meta::Attribute;
3
4328µs9µsuse strict;
# spent 9µs making 1 call to strict::import
5338µs13µsuse warnings;
# spent 25µs making 1 call to warnings::import
6
7331µs10µsuse Scalar::Util 'blessed', 'weaken';
# spent 50µs making 1 call to Exporter::import
8327µs9µsuse List::MoreUtils 'any';
# spent 41µs making 1 call to Exporter::import
9330µs10µsuse Try::Tiny;
# spent 58µs making 1 call to Exporter::import
10345µs15µsuse overload ();
11
1211µs1µsour $VERSION = '1.15';
131700ns700nsour $AUTHORITY = 'cpan:STEVAN';
14
15327µs9µsuse Moose::Deprecated;
163127µs42µsuse Moose::Meta::Method::Accessor;
# spent 6µs making 1 call to import
173115µs38µsuse Moose::Meta::Method::Delegation;
# spent 9µs making 1 call to import
18316µs5µsuse Moose::Util ();
193119µs40µsuse Moose::Util::TypeConstraints ();
20334µs11µsuse Class::MOP::MiniTrait;
# spent 5µs making 1 call to import
21
2234.52ms1.51msuse base 'Class::MOP::Attribute', 'Moose::Meta::Mixin::AttributeCore';
# spent 9.73ms making 1 call to base::import
23
24111µs11µsClass::MOP::MiniTrait::apply(__PACKAGE__, 'Moose::Meta::Object::Trait');
# spent 3.15ms making 1 call to Class::MOP::MiniTrait::apply
25
26118µs18µ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.
35sub 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
44sub 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
sub new {
5563962µs15µ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
63252752µs3µs 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
sub interpolate_class_and_new {
7824176µs7µ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
sub interpolate_class {
864860µs1µ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
139sub 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
157sub 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
218sub 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
sub _process_options {
24381101µs1µs my ($class, $name, $options) = @_;
244
245818µs2µs 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
254913µs1µs 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
2751236µs3µs 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 ...
287643µs7µs 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
360sub 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
401sub _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
426sub _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
446sub 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
474sub _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
483sub 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
5281122µs2µ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
sub accessor_metaclass { 'Moose::Meta::Method::Accessor' }
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
sub install_accessors {
53140160µs4µ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
sub _check_associated_methods {
5381649µs3µ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
sub _process_accessors {
55477478µs6µ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
576sub 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
sub inline_set {
584156709µs5µ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
599sub 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
637sub 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
651sub _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
695sub _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
711sub _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
727sub delegation_metaclass { 'Moose::Meta::Method::Delegation' }
728
729sub _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
746sub _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
761sub 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
776package Moose::Meta::Attribute::Custom::Moose;
777sub register_implementation { 'Moose::Meta::Attribute' }
778
779111µs11µs1;
780
781__END__
782
783=pod
784
785=head1 NAME
786
787Moose::Meta::Attribute - The Moose attribute metaclass
788
789=head1 DESCRIPTION
790
791This class is a subclass of L<Class::MOP::Attribute> that provides
792additional Moose-specific functionality.
793
794To really understand this class, you will need to start with the
795L<Class::MOP::Attribute> documentation. This class can be understood
796as a set of additional features on top of the basic feature provided
797by that parent class.
798
799=head1 INHERITANCE
800
801C<Moose::Meta::Attribute> is a subclass of L<Class::MOP::Attribute>.
802
803=head1 METHODS
804
805Many of the documented below override methods in
806L<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
814This method overrides the L<Class::MOP::Attribute> constructor.
815
816Many of the options below are described in more detail in the
817L<Moose::Manual::Attributes> document.
818
819It adds the following options to the constructor:
820
821=over 8
822
823=item * is => 'ro', 'rw', 'bare'
824
825This provides a shorthand for specifying the C<reader>, C<writer>, or
826C<accessor> names. If the attribute is read-only ('ro') then it will
827have a C<reader> method with the same attribute as the name.
828
829If it is read-write ('rw') then it will have an C<accessor> method
830with the same name. If you provide an explicit C<writer> for a
831read-write attribute, then you will have a C<reader> with the same
832name as the attribute, and a C<writer> with the name you provided.
833
834Use 'bare' when you are deliberately not installing any methods
835(accessor, reader, etc.) associated with this attribute; otherwise,
836Moose will issue a deprecation warning when this attribute is added to a
837metaclass.
838
839=item * isa => $type
840
841This option accepts a type. The type can be a string, which should be
842a type name. If the type name is unknown, it is assumed to be a class
843name.
844
845This option can also accept a L<Moose::Meta::TypeConstraint> object.
846
847If you I<also> provide a C<does> option, then your C<isa> option must
848be a class name, and that class must do the role specified with
849C<does>.
850
851=item * does => $role
852
853This is short-hand for saying that the attribute's type must be an
854object which does the named role.
855
856=item * coerce => $bool
857
858This 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
860this attribute is set.
861
862You can make both this and the C<weak_ref> option true.
863
864=item * trigger => $sub
865
866This option accepts a subroutine reference, which will be called after
867the attribute is set.
868
869=item * required => $bool
870
871An attribute which is required must be provided to the constructor. An
872attribute which is required can also have a C<default> or C<builder>,
873which will satisfy its required-ness.
874
875A required attribute must have a C<default>, C<builder> or a
876non-C<undef> C<init_arg>
877
878=item * lazy => $bool
879
880A lazy attribute must have a C<default> or C<builder>. When an
881attribute is lazy, the default value will not be calculated until the
882attribute is read.
883
884=item * weak_ref => $bool
885
886If this is true, the attribute's value will be stored as a weak
887reference.
888
889=item * auto_deref => $bool
890
891If this is true, then the reader will dereference the value when it is
892called. The attribute must have a type constraint which defines the
893attribute as an array or hash reference.
894
895=item * lazy_build => $bool
896
897Setting this to true makes the attribute lazy and provides a number of
898default methods.
899
900 has 'size' => (
901 is => 'ro',
902 lazy_build => 1,
903 );
904
905is 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
917An arbitrary string that can be retrieved later by calling C<<
918$attr->documentation >>.
919
920=back
921
922=item B<< $attr->clone(%options) >>
923
924This creates a new attribute based on attribute being cloned. You must
925supply a C<name> option to provide a new name for the attribute.
926
927The C<%options> can only specify options handled by
928L<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
938This method is used internally to initialize the attribute's slot in
939the object C<$instance>.
940
941This overrides the L<Class::MOP::Attribute> method to handle lazy
942attributes, 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
953I<Attribute (x) does not pass the type constraint (Int) with 'forty-two'>
954
955Before setting the value, a check is made on the type constraint of
956the attribute, if it has one, to see if the value passes it. If the
957value fails to pass, the set operation dies with a L</throw_error>.
958
959Any coercion to convert values is done before checking the type constraint.
960
961To check a value against a type constraint before setting it, fetch the
962attribute instance using L<Class::MOP::Class/find_attribute_by_name>,
963fetch the type_constraint from the attribute using L<Moose::Meta::Attribute/type_constraint>
964and call L<Moose::Meta::TypeConstraint/check>. See L<Moose::Cookbook::Basics::Recipe4>
965for an example.
966
967=back
968
969=head2 Attribute Accessor generation
970
971=over 4
972
973=item B<< $attr->install_accessors >>
974
975This method overrides the parent to also install delegation methods.
976
977If, after installing all methods, the attribute object has no associated
978methods, it throws an error unless C<< is => 'bare' >> was passed to the
979attribute constructor. (Trying to add an attribute that has no associated
980methods is almost always an error.)
981
982=item B<< $attr->remove_accessors >>
983
984This method overrides the parent to also remove delegation methods.
985
986=item B<< $attr->inline_set($instance_var, $value_var) >>
987
988This method return a code snippet suitable for inlining the relevant
989operation. It expect strings containing variable names to be used in the
990inlining, like C<'$self'> or C<'$_[1]'>.
991
992=item B<< $attr->install_delegation >>
993
994This method adds its delegation methods to the attribute's associated
995class, if it has any to add.
996
997=item B<< $attr->remove_delegation >>
998
999This method remove its delegation methods from the attribute's
1000associated class.
1001
1002=item B<< $attr->accessor_metaclass >>
1003
1004Returns the accessor metaclass name, which defaults to
1005L<Moose::Meta::Method::Accessor>.
1006
1007=item B<< $attr->delegation_metaclass >>
1008
1009Returns the delegation metaclass name, which defaults to
1010L<Moose::Meta::Method::Delegation>.
1011
1012=back
1013
1014=head2 Additional Moose features
1015
1016These methods are not found in the superclass. They support features
1017provided by Moose.
1018
1019=over 4
1020
1021=item B<< $attr->does($role) >>
1022
1023This indicates whether the I<attribute itself> does the given
1024role. The role can be given as a full class name, or as a resolvable
1025trait name.
1026
1027Note that this checks the attribute itself, not its type constraint,
1028so it is checking the attribute's metaclass and any traits applied to
1029the attribute.
1030
1031=item B<< Moose::Meta::Class->interpolate_class_and_new($name, %options) >>
1032
1033This is an alternate constructor that handles the C<metaclass> and
1034C<traits> options.
1035
1036Effectively, this method is a factory that finds or creates the
1037appropriate class for the given C<metaclass> and/or C<traits>.
1038
1039Once 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
1044This method supports the C<has '+foo'> feature. It does various bits
1045of processing on the supplied C<%options> before ultimately calling
1046the C<clone> method.
1047
1048One of its main tasks is to make sure that the C<%options> provided
1049does not include the options returned by the
1050C<illegal_options_for_inheritance> method.
1051
1052=item B<< $attr->illegal_options_for_inheritance >>
1053
1054This returns a blacklist of options that can not be overridden in a
1055subclass's attribute definition.
1056
1057This exists to allow a custom metaclass to change or add to the list
1058of options which can not be changed.
1059
1060=item B<< $attr->type_constraint >>
1061
1062Returns the L<Moose::Meta::TypeConstraint> object for this attribute,
1063if it has one.
1064
1065=item B<< $attr->has_type_constraint >>
1066
1067Returns true if this attribute has a type constraint.
1068
1069=item B<< $attr->verify_against_type_constraint($value) >>
1070
1071Given a value, this method returns true if the value is valid for the
1072attribute's type constraint. If the value is not valid, it throws an
1073error.
1074
1075=item B<< $attr->handles >>
1076
1077This returns the value of the C<handles> option passed to the
1078constructor.
1079
1080=item B<< $attr->has_handles >>
1081
1082Returns true if this attribute performs delegation.
1083
1084=item B<< $attr->is_weak_ref >>
1085
1086Returns true if this attribute stores its value as a weak reference.
1087
1088=item B<< $attr->is_required >>
1089
1090Returns true if this attribute is required to have a value.
1091
1092=item B<< $attr->is_lazy >>
1093
1094Returns true if this attribute is lazy.
1095
1096=item B<< $attr->is_lazy_build >>
1097
1098Returns true if the C<lazy_build> option was true when passed to the
1099constructor.
1100
1101=item B<< $attr->should_coerce >>
1102
1103Returns true if the C<coerce> option passed to the constructor was
1104true.
1105
1106=item B<< $attr->should_auto_deref >>
1107
1108Returns true if the C<auto_deref> option passed to the constructor was
1109true.
1110
1111=item B<< $attr->trigger >>
1112
1113This is the subroutine reference that was in the C<trigger> option
1114passed to the constructor, if any.
1115
1116=item B<< $attr->has_trigger >>
1117
1118Returns true if this attribute has a trigger set.
1119
1120=item B<< $attr->documentation >>
1121
1122Returns the value that was in the C<documentation> option passed to
1123the constructor, if any.
1124
1125=item B<< $attr->has_documentation >>
1126
1127Returns true if this attribute has any documentation.
1128
1129=item B<< $attr->applied_traits >>
1130
1131This returns an array reference of all the traits which were applied
1132to this attribute. If none were applied, this returns C<undef>.
1133
1134=item B<< $attr->has_applied_traits >>
1135
1136Returns true if this attribute has any traits applied.
1137
1138=back
1139
1140=head1 BUGS
1141
1142See L<Moose/BUGS> for details on reporting bugs.
1143
1144=head1 AUTHOR
1145
1146Stevan Little E<lt>stevan@iinteractive.comE<gt>
1147
1148Yuval Kogman E<lt>nothingmuch@woobling.comE<gt>
1149
1150=head1 COPYRIGHT AND LICENSE
1151
1152Copyright 2006-2010 by Infinity Interactive, Inc.
1153
1154L<http://www.iinteractive.com>
1155
1156This library is free software; you can redistribute it and/or modify
1157it under the same terms as Perl itself.
1158
1159=cut