X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FClass%2FMOP%2FAttribute.pm;h=7d9856c85eefb2990d726f520d740cd690563bcd;hb=0bfc85b88523ddd75e0868d6ec1244f4365bda07;hp=32931a99bdce4b88b6b8165519b11d17512576ee;hpb=742fb371653d58d3aca4dccadcb7dd4e7c736354;p=gitmo%2FClass-MOP.git diff --git a/lib/Class/MOP/Attribute.pm b/lib/Class/MOP/Attribute.pm index 32931a9..7d9856c 100644 --- a/lib/Class/MOP/Attribute.pm +++ b/lib/Class/MOP/Attribute.pm @@ -7,18 +7,13 @@ use warnings; use Class::MOP::Method::Accessor; use Carp 'confess'; -use Scalar::Util 'blessed', 'reftype', 'weaken'; +use Scalar::Util 'blessed', 'weaken'; -our $VERSION = '0.19'; +our $VERSION = '0.65'; 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 @@ -29,9 +24,12 @@ sub meta { # meta-objects. # - Ain't meta-circularity grand? :) sub new { - my $class = shift; - my $name = shift; - my %options = @_; + my ( $class, @args ) = @_; + + unshift @args, "name" if @args % 2 == 1; + my %options = @args; + + my $name = $options{name}; (defined $name && $name) || confess "You must provide a name for the attribute"; @@ -46,26 +44,38 @@ 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} ) ) { + confess("A required attribute must have either 'init_arg', 'builder', or 'default'"); + } + + $class->_new(%options); +} + +sub _new { + my $class = shift; + my $options = @_ == 1 ? $_[0] : {@_}; + bless { - '$!name' => $name, - '$!accessor' => $options{accessor}, - '$!reader' => $options{reader}, - '$!writer' => $options{writer}, - '$!predicate' => $options{predicate}, - '$!clearer' => $options{clearer}, - '$!builder' => $options{builder}, - '$!init_arg' => $options{init_arg}, - '$!default' => $options{default}, + 'name' => $options->{name}, + 'accessor' => $options->{accessor}, + 'reader' => $options->{reader}, + '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, + 'associated_class' => undef, # and a list of the methods # associated with this attr - '@!associated_methods' => [], - } => $class; + 'associated_methods' => [], + }, $class; } # NOTE: @@ -78,63 +88,116 @@ sub clone { my %options = @_; (blessed($self)) || confess "Can only clone an instance"; - return bless { %{$self}, %options } => blessed($self); + return bless { %{$self}, %options } => ref($self); } sub initialize_instance_slot { my ($self, $meta_instance, $instance, $params) = @_; - my $init_arg = $self->{'$!init_arg'}; + my $init_arg = $self->{'init_arg'}; + # try to fetch the init arg from the %params ... # if nothing was in the %params, we can use the # attribute's default value (if it has one) - if(exists $params->{$init_arg}){ - $meta_instance->set_slot_value($instance, $self->name, $params->{$init_arg}); + if(defined $init_arg and exists $params->{$init_arg}){ + $self->_set_initial_slot_value( + $meta_instance, + $instance, + $params->{$init_arg}, + ); } - elsif (defined $self->{'$!default'}) { - $meta_instance->set_slot_value($instance, $self->name, $self->default($instance)); + elsif (defined $self->{'default'}) { + $self->_set_initial_slot_value( + $meta_instance, + $instance, + $self->default($instance), + ); } - elsif (defined( my $builder = $self->{'$!builder'})) { + elsif (defined( my $builder = $self->{'builder'})) { if ($builder = $instance->can($builder)) { - $meta_instance->set_slot_value($instance, $self->name, $instance->$builder); + $self->_set_initial_slot_value( + $meta_instance, + $instance, + $instance->$builder, + ); } else { - confess(blessed($instance)." does not support builder method '". $self->{'$!builder'} ."' for attribute '" . $self->name . "'"); + confess(ref($instance)." does not support builder method '". $self->{'builder'} ."' for attribute '" . $self->name . "'"); } } } -# NOTE: -# the next bunch of methods will get bootstrapped -# away in the Class::MOP bootstrapping section +sub _set_initial_slot_value { + my ($self, $meta_instance, $instance, $value) = @_; -sub name { $_[0]->{'$!name'} } + my $slot_name = $self->name; -sub associated_class { $_[0]->{'$!associated_class'} } -sub associated_methods { $_[0]->{'@!associated_methods'} } + return $meta_instance->set_slot_value($instance, $slot_name, $value) + unless $self->has_initializer; -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 } + my $callback = sub { + $meta_instance->set_slot_value($instance, $slot_name, $_[0]); + }; + + my $initializer = $self->initializer; -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'} } + # 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 + +sub name { $_[0]->{'name'} } + +sub associated_class { $_[0]->{'associated_class'} } +sub associated_methods { $_[0]->{'associated_methods'} } + +sub has_accessor { defined($_[0]->{'accessor'}) } +sub has_reader { defined($_[0]->{'reader'}) } +sub has_writer { defined($_[0]->{'writer'}) } +sub has_predicate { defined($_[0]->{'predicate'}) } +sub has_clearer { defined($_[0]->{'clearer'}) } +sub has_builder { defined($_[0]->{'builder'}) } +sub has_init_arg { defined($_[0]->{'init_arg'}) } +sub has_default { defined($_[0]->{'default'}) } +sub has_initializer { defined($_[0]->{'initializer'}) } + +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 get_read_method { $_[0]->reader || $_[0]->accessor } -sub get_write_method { $_[0]->writer || $_[0]->accessor } +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; + # normal case ... + return $reader unless ref $reader; + # the HASH ref case + my ($name) = %$reader; + return $name; +} + +sub get_write_method { + my $self = shift; + my $writer = $self->writer || $self->accessor; + # normal case ... + return $writer unless ref $writer; + # the HASH ref case + my ($name) = %$writer; + return $name; +} sub get_read_method_ref { my $self = shift; @@ -142,22 +205,42 @@ 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; + } } } sub get_write_method_ref { my $self = shift; - if ((my $writer = $self->get_write_method) && $self->associated_class) { + if ((my $writer = $self->get_write_method) && $self->associated_class) { 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; + } } } sub is_default_a_coderef { - ('CODE' eq (reftype($_[0]->{'$!default'} || $_[0]->{default}) || '')) + ('CODE' eq ref($_[0]->{'default'} || $_[0]->{default})) } sub default { @@ -167,9 +250,9 @@ sub default { # we pass in the instance and default # can return a value based on that # instance. Somewhat crude, but works. - return $self->{'$!default'}->($instance); + return $self->{'default'}->($instance); } - $self->{'$!default'}; + $self->{'default'}; } # slots @@ -182,27 +265,36 @@ sub attach_to_class { my ($self, $class) = @_; (blessed($class) && $class->isa('Class::MOP::Class')) || confess "You must pass a Class::MOP::Class instance (or a subclass)"; - weaken($self->{'$!associated_class'} = $class); + weaken($self->{'associated_class'} = $class); } sub detach_from_class { my $self = shift; - $self->{'$!associated_class'} = undef; + $self->{'associated_class'} = undef; } # method association sub associate_method { my ($self, $method) = @_; - push @{$self->{'@!associated_methods'}} => $method; + push @{$self->{'associated_methods'}} => $method; } ## Slot management +sub set_initial_value { + my ($self, $instance, $value) = @_; + $self->_set_initial_slot_value( + Class::MOP::Class->initialize(ref($instance))->get_meta_instance, + $instance, + $value + ); +} + sub set_value { my ($self, $instance, $value) = @_; - Class::MOP::Class->initialize(blessed($instance)) + Class::MOP::Class->initialize(ref($instance)) ->get_meta_instance ->set_slot_value($instance, $self->name, $value); } @@ -210,7 +302,7 @@ sub set_value { sub get_value { my ($self, $instance) = @_; - Class::MOP::Class->initialize(blessed($instance)) + Class::MOP::Class->initialize(ref($instance)) ->get_meta_instance ->get_slot_value($instance, $self->name); } @@ -218,7 +310,7 @@ sub get_value { sub has_value { my ($self, $instance) = @_; - Class::MOP::Class->initialize(blessed($instance)) + Class::MOP::Class->initialize(ref($instance)) ->get_meta_instance ->is_slot_initialized($instance, $self->name); } @@ -226,7 +318,7 @@ sub has_value { sub clear_value { my ($self, $instance) = @_; - Class::MOP::Class->initialize(blessed($instance)) + Class::MOP::Class->initialize(ref($instance)) ->get_meta_instance ->deinitialize_slot($instance, $self->name); } @@ -237,11 +329,15 @@ sub accessor_metaclass { 'Class::MOP::Method::Accessor' } sub process_accessors { my ($self, $type, $accessor, $generate_as_inline_methods) = @_; - if (reftype($accessor)) { - (reftype($accessor) eq 'HASH') + if (ref($accessor)) { + (ref($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); } @@ -253,6 +349,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 $@; @@ -292,12 +390,12 @@ sub install_accessors { { my $_remove_accessor = sub { my ($accessor, $class) = @_; - if (reftype($accessor) && reftype($accessor) eq 'HASH') { + if (ref($accessor) && ref($accessor) eq 'HASH') { ($accessor) = keys %{$accessor}; } my $method = $class->get_method($accessor); $class->remove_method($accessor) - if (blessed($method) && $method->isa('Class::MOP::Method::Accessor')); + if (ref($method) && $method->isa('Class::MOP::Method::Accessor')); }; sub remove_accessors { @@ -329,14 +427,14 @@ Class::MOP::Attribute - Attribute Meta Object =head1 SYNOPSIS - Class::MOP::Attribute->new('$foo' => ( + Class::MOP::Attribute->new( foo => ( accessor => 'foo', # dual purpose get/set accessor predicate => 'has_foo' # predicate check for defined-ness init_arg => '-foo', # class->new will look for a -foo key default => 'BAR IS BAZ!' # if no -foo key is provided, use this )); - Class::MOP::Attribute->new('$.bar' => ( + Class::MOP::Attribute->new( bar => ( reader => 'bar', # getter writer => 'set_bar', # setter predicate => 'has_bar' # predicate check for defined-ness @@ -379,13 +477,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>. - -=item I - -The value of this key is the default value which -C will initialize the -attribute to. +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 @@ -394,6 +487,12 @@ called to obtain the value used to initialize the attribute. This should be a method in the class associated with the attribute, not a method in the attribute class itself. +=item I + +The value of this key is the default value which +C will initialize the +attribute to. + B If the value is a simple scalar (string or number), then it can be just passed as is. However, if you wish to initialize it with @@ -421,7 +520,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' => ( @@ -435,6 +534,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 @@ -478,9 +608,18 @@ C value to the attribute. =item I -This is a basic test to see if the value of the attribute is not -C. It will return true (C<1>) if the attribute's value is -defined, and false (C<0>) otherwise. +This is a basic test to see if any value has been set for the +attribute. It will return true (C<1>) if the attribute has been set +to any value (even C), and false (C<0>) otherwise. + +B +The predicate will return true even when you set an attribute's +value to C. This behaviour has changed as of version 0.43. In +older versions, the predicate (erroneously) checked for attribute +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 @@ -491,8 +630,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 @@ -510,6 +656,11 @@ know what you are doing. Set the value without going through the accessor. Note that this may be done to even attributes with just read only accessors. +=item B + +This method sets the value without going through the accessor -- but it is only +called when the instance data is first initialized. + =item B Return the value without going through the accessor. Note that this may be done @@ -517,7 +668,7 @@ even to attributes with just write only accessors. =item B -Returns a boolean indicating if the item in the C<$instance> has a value in it. +Return a boolean indicating if the item in the C<$instance> has a value in it. This is basically what the default C method calls. =item B @@ -547,19 +698,23 @@ passed into C. I think they are pretty much self-explanitory. =item B +=item B + =item B =item B =item B -As noted in the documentation for C above, if the I -value is a CODE reference, this accessor will pass a single additional -argument C<$instance> into it and return the value. +Return the default value for the attribute. + +If you pass in an C<$instance> argument to this accessor and the +I is a CODE reference, then the CODE reference will be +executed with the C<$instance> as its argument. =item B -Returns a list of slots required by the attribute. This is usually +Return a list of slots required by the attribute. This is usually just one, which is the name of the attribute. =item B @@ -578,9 +733,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 @@ -599,6 +762,8 @@ These are all basic predicate methods for the values passed into C. =item B +=item B + =item B =item B @@ -655,7 +820,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 @@ -696,7 +862,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 @@ -707,7 +873,7 @@ Stevan Little Estevan@iinteractive.comE =head1 COPYRIGHT AND LICENSE -Copyright 2006, 2007 by Infinity Interactive, Inc. +Copyright 2006-2008 by Infinity Interactive, Inc. L