X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FClass%2FMOP%2FAttribute.pm;h=6ccf691af468a9adf5a8b738f2e29493f85ef51e;hb=d7d3f3cb72ab15c6f256c7e7d26d8b9b15ed2823;hp=6bc203a21d703df99ba6eaf4f342e23b163c5fd3;hpb=c09219327ecf55f83be207b58a80967a1baa199b;p=gitmo%2FClass-MOP.git diff --git a/lib/Class/MOP/Attribute.pm b/lib/Class/MOP/Attribute.pm index 6bc203a..6ccf691 100644 --- a/lib/Class/MOP/Attribute.pm +++ b/lib/Class/MOP/Attribute.pm @@ -9,16 +9,11 @@ use Class::MOP::Method::Accessor; use Carp 'confess'; use Scalar::Util 'blessed', 'reftype', 'weaken'; -our $VERSION = '0.23'; +our $VERSION = '0.24'; our $AUTHORITY = 'cpan:STEVAN'; use base 'Class::MOP::Object'; -sub meta { - require Class::MOP::Class; - Class::MOP::Class->initialize(blessed($_[0]) || $_[0]); -} - # NOTE: (meta-circularity) # This method will be replaced in the # boostrap section of Class::MOP, by @@ -46,7 +41,7 @@ sub new { } else { (is_default_a_coderef(\%options)) || confess("References are not allowed as default values, you must ". - "wrap then in a CODE reference (ex: sub { [] } and not [])") + "wrap the default of '$name' in a CODE reference (ex: sub { [] } and not [])") if exists $options{default} && ref $options{default}; } if( $options{required} and not( defined($options{builder}) || defined($options{init_arg}) || exists $options{default} ) ) { @@ -56,22 +51,22 @@ sub new { '$!name' => $name, '$!accessor' => $options{accessor}, '$!reader' => $options{reader}, - # NOTE: - # protect this from silliness - init_arg => '!............( DO NOT DO THIS )............!', - '$!writer' => $options{writer}, - '$!predicate' => $options{predicate}, - '$!clearer' => $options{clearer}, - '$!builder' => $options{builder}, - '$!init_arg' => $options{init_arg}, - '$!default' => $options{default}, + '$!writer' => $options{writer}, + '$!predicate' => $options{predicate}, + '$!clearer' => $options{clearer}, + '$!builder' => $options{builder}, + '$!init_arg' => $options{init_arg}, + '$!default' => $options{default}, + '$!initializer' => $options{initializer}, # keep a weakened link to the # class we are associated with '$!associated_class' => undef, - '$!initializer' => $options{initializer}, # and a list of the methods # associated with this attr '@!associated_methods' => [], + # NOTE: + # protect this from silliness + init_arg => undef, } => $class; } @@ -96,28 +91,25 @@ sub initialize_instance_slot { # if nothing was in the %params, we can use the # attribute's default value (if it has one) if(defined $init_arg and exists $params->{$init_arg}){ - $meta_instance->_set_initial_slot_value( + $self->_set_initial_slot_value( + $meta_instance, $instance, - $self->name, $params->{$init_arg}, - $self->initializer, ); } elsif (defined $self->{'$!default'}) { - $meta_instance->_set_initial_slot_value( + $self->_set_initial_slot_value( + $meta_instance, $instance, - $self->name, $self->default($instance), - $self->initializer, ); } elsif (defined( my $builder = $self->{'$!builder'})) { if ($builder = $instance->can($builder)) { - $meta_instance->_set_initial_slot_value( + $self->_set_initial_slot_value( + $meta_instance, $instance, - $self->name, $instance->$builder, - $self->initializer, ); } else { @@ -126,6 +118,24 @@ sub initialize_instance_slot { } } +sub _set_initial_slot_value { + my ($self, $meta_instance, $instance, $value) = @_; + + my $slot_name = $self->name; + + return $meta_instance->set_slot_value($instance, $slot_name, $value) + unless $self->has_initializer; + + my $callback = sub { + $meta_instance->set_slot_value($instance, $slot_name, $_[0]); + }; + + my $initializer = $self->initializer; + + # most things will just want to set a value, so make it first arg + $instance->$initializer($value, $callback, $self); +} + # NOTE: # the next bunch of methods will get bootstrapped # away in the Class::MOP bootstrapping section @@ -135,28 +145,31 @@ sub name { $_[0]->{'$!name'} } sub associated_class { $_[0]->{'$!associated_class'} } sub associated_methods { $_[0]->{'@!associated_methods'} } -sub has_accessor { defined($_[0]->{'$!accessor'}) ? 1 : 0 } -sub has_reader { defined($_[0]->{'$!reader'}) ? 1 : 0 } -sub has_writer { defined($_[0]->{'$!writer'}) ? 1 : 0 } -sub has_predicate { defined($_[0]->{'$!predicate'}) ? 1 : 0 } -sub has_clearer { defined($_[0]->{'$!clearer'}) ? 1 : 0 } -sub has_builder { defined($_[0]->{'$!builder'}) ? 1 : 0 } -sub has_init_arg { defined($_[0]->{'$!init_arg'}) ? 1 : 0 } -sub has_default { defined($_[0]->{'$!default'}) ? 1 : 0 } +sub has_accessor { defined($_[0]->{'$!accessor'}) ? 1 : 0 } +sub has_reader { defined($_[0]->{'$!reader'}) ? 1 : 0 } +sub has_writer { defined($_[0]->{'$!writer'}) ? 1 : 0 } +sub has_predicate { defined($_[0]->{'$!predicate'}) ? 1 : 0 } +sub has_clearer { defined($_[0]->{'$!clearer'}) ? 1 : 0 } +sub has_builder { defined($_[0]->{'$!builder'}) ? 1 : 0 } +sub has_init_arg { defined($_[0]->{'$!init_arg'}) ? 1 : 0 } +sub has_default { defined($_[0]->{'$!default'}) ? 1 : 0 } sub has_initializer { defined($_[0]->{'$!initializer'}) ? 1 : 0 } -sub accessor { $_[0]->{'$!accessor'} } -sub reader { $_[0]->{'$!reader'} } -sub writer { $_[0]->{'$!writer'} } -sub predicate { $_[0]->{'$!predicate'} } -sub clearer { $_[0]->{'$!clearer'} } -sub builder { $_[0]->{'$!builder'} } -sub init_arg { $_[0]->{'$!init_arg'} } +sub accessor { $_[0]->{'$!accessor'} } +sub reader { $_[0]->{'$!reader'} } +sub writer { $_[0]->{'$!writer'} } +sub predicate { $_[0]->{'$!predicate'} } +sub clearer { $_[0]->{'$!clearer'} } +sub builder { $_[0]->{'$!builder'} } +sub init_arg { $_[0]->{'$!init_arg'} } sub initializer { $_[0]->{'$!initializer'} } # end bootstrapped away method section. # (all methods below here are kept intact) +sub has_read_method { $_[0]->has_reader || $_[0]->has_accessor } +sub has_write_method { $_[0]->has_writer || $_[0]->has_accessor } + sub get_read_method { my $self = shift; my $reader = $self->reader || $self->accessor; @@ -183,7 +196,17 @@ sub get_read_method_ref { return $self->associated_class->get_method($reader); } else { - return sub { $self->get_value(@_) }; + my $code = sub { $self->get_value(@_) }; + if (my $class = $self->associated_class) { + return $class->method_metaclass->wrap( + $code, + package_name => $class->name, + name => '__ANON__' + ); + } + else { + return $code; + } } } @@ -193,7 +216,17 @@ sub get_write_method_ref { return $self->associated_class->get_method($writer); } else { - return sub { $self->set_value(@_) }; + my $code = sub { $self->set_value(@_) }; + if (my $class = $self->associated_class) { + return $class->method_metaclass->wrap( + $code, + package_name => $class->name, + name => '__ANON__' + ); + } + else { + return $code; + } } } @@ -242,10 +275,11 @@ sub associate_method { sub set_initial_value { my ($self, $instance, $value) = @_; - - Class::MOP::Class->initialize(blessed($instance)) - ->get_meta_instance - ->_set_initial_slot_value($instance, $self->name, $value, $self->initializer); + $self->_set_initial_slot_value( + Class::MOP::Class->initialize(blessed($instance))->get_meta_instance, + $instance, + $value + ); } sub set_value { @@ -290,7 +324,11 @@ sub process_accessors { (reftype($accessor) eq 'HASH') || confess "bad accessor/reader/writer/predicate/clearer format, must be a HASH ref"; my ($name, $method) = %{$accessor}; - $method = $self->accessor_metaclass->wrap($method); + $method = $self->accessor_metaclass->wrap( + $method, + package_name => $self->associated_class->name, + name => $name, + ); $self->associate_method($method); return ($name, $method); } @@ -302,6 +340,8 @@ sub process_accessors { attribute => $self, is_inline => $inline_me, accessor_type => $type, + package_name => $self->associated_class->name, + name => $accessor, ); }; confess "Could not create the '$type' method for " . $self->name . " because : $@" if $@; @@ -428,7 +468,8 @@ value of C<-foo>, then the following code will Just Work. MyClass->meta->construct_instance(-foo => "Hello There"); In an init_arg is not assigned, it will automatically use the -value of C<$name>. +value of C<$name>. If an explicit C is given for an init_arg, +an attribute value can't be specified during initialization. =item I @@ -470,7 +511,7 @@ so: And lastly, if the value of your attribute is dependent upon some other aspect of the instance structure, then you can take advantage of the fact that when the I value is a CODE -reference, it is passed the raw (unblessed) instance structure +reference, it is passed the (as yet unfinished) instance structure as it's only argument. So you can do things like this: Class::MOP::Attribute->new('$object_identity' => ( @@ -484,6 +525,37 @@ something you need, you could subclass B and this class to acheive it. However, this is currently left as an exercise to the reader :). +=item I + +This may be a method name (referring to a method on the class with this +attribute) or a CODE ref. The initializer is used to set the attribute value +on an instance when the attribute is set during instance initialization. When +called, it is passed the instance (as the invocant), the value to set, a +slot-setting CODE ref, and the attribute meta-instance. The slot-setting code +is provided to make it easy to set the (possibly altered) value on the instance +without going through several more method calls. + +This contrived example shows an initializer that sets the attribute to twice +the given value. + + Class::MOP::Attribute->new('$doubled' => ( + initializer => sub { + my ($instance, $value, $set) = @_; + $set->($value * 2); + }, + )); + +As method names can be given as initializers, one can easily make +attribute initialization use the writer: + + Class::MOP::Attribute->new('$some_attr' => ( + writer => 'some_attr', + initializer => 'some_attr', + )); + +Your writer will simply need to examine it's C<@_> and determine under +which context it is being called. + =back The I, I, I, I and I keys can @@ -540,7 +612,6 @@ value definedness, instead of presence as it is now. If you really want to get rid of the value, you have to define and use a I (see below). - =item I This is the a method that will uninitialize the attr, reverting lazy values @@ -550,8 +621,15 @@ back to their "unfulfilled" state. =item B +This will return a clone of the attribute instance, allowing the overriding +of various attributes through the C<%options> supplied. + =item B +This method is used internally to initialize the approriate slot for this +attribute in a given C<$instance>, the C<$params> passed are those that were +passed to the constructor. + =back =head2 Value management @@ -646,9 +724,17 @@ Return the CODE reference of a method suitable for reading / writing the value of the attribute in the associated class. Suitable for use whether C and C or C was specified or not. -NOTE: If not reader/writer/accessor was specified, this will use the +NOTE: If no reader/writer/accessor was specified, this will use the attribute get_value/set_value methods, which can be very inefficient. +=item B + +=item B + +Return whether a method exists suitable for reading / writing the value +of the attribute in the associated class. Suitable for use whether +C and C or C was used. + =back =head2 Informational predicates @@ -725,7 +811,8 @@ used internally by the accessor generator. =item B This will return the list of methods which have been associated with -the C methods. +the C methods. This is a good way of seeing what +methods are used to manage a given attribute. =item B @@ -766,7 +853,7 @@ to this class. It should also be noted that B will actually bootstrap this module by installing a number of attribute meta-objects into -it's metaclass. This will allow this class to reap all the benifits +it's metaclass. This will allow this class to reap all the benefits of the MOP when subclassing it. =back