X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FClass%2FMOP%2FAttribute.pm;h=d24710ea07fb1d3f0b6d0c681a4785eebcaa8aa8;hb=9457b59678c67b47f31e82d284ed57c10d7fc091;hp=90f7d57add64bbc930ae0c76081f2886a9da9e19;hpb=1d68af0454f55a8b088f8bc1887a0a5ce54d2a22;p=gitmo%2FClass-MOP.git diff --git a/lib/Class/MOP/Attribute.pm b/lib/Class/MOP/Attribute.pm index 90f7d57..d24710e 100644 --- a/lib/Class/MOP/Attribute.pm +++ b/lib/Class/MOP/Attribute.pm @@ -7,18 +7,14 @@ use warnings; use Class::MOP::Method::Accessor; use Carp 'confess'; -use Scalar::Util 'blessed', 'reftype', 'weaken'; +use Scalar::Util 'blessed', 'weaken'; -our $VERSION = '0.16'; +our $VERSION = '0.64_06'; +$VERSION = eval $VERSION; 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 +25,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"; @@ -43,29 +42,41 @@ sub new { if ref $options{builder} || !(defined $options{builder}); confess("Setting both default and builder is not allowed.") if exists $options{default}; + } else { + (is_default_a_coderef(\%options)) + || confess("References are not allowed as default values, you must ". + "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'"); } - (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 [])") - if exists $options{default} && ref $options{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 +89,159 @@ 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 ... - my $val; - $val = $params->{$init_arg} if exists $params->{$init_arg}; + # if nothing was in the %params, we can use the # attribute's default value (if it has one) - if (!defined $val && defined $self->{'$!default'}) { - $val = $self->default($instance); - } - if (!defined $val && defined $self->{'$!builder'}) { - my $builder = $self->{'$!builder'}; - confess(blessed($instance)." does not support builder method '$builder' for attribute '" . $self->name . "'") - unless $instance->can($builder); - $val = $instance->$builder; + if(defined $init_arg and exists $params->{$init_arg}){ + $self->_set_initial_slot_value( + $meta_instance, + $instance, + $params->{$init_arg}, + ); + } + elsif (defined $self->{'default'}) { + $self->_set_initial_slot_value( + $meta_instance, + $instance, + $self->default($instance), + ); + } + elsif (defined( my $builder = $self->{'builder'})) { + if ($builder = $instance->can($builder)) { + $self->_set_initial_slot_value( + $meta_instance, + $instance, + $instance->$builder, + ); + } + else { + confess(ref($instance)." does not support builder method '". $self->{'builder'} ."' for attribute '" . $self->name . "'"); + } } - $meta_instance->set_slot_value($instance, $self->name, $val); +} + +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 -sub name { $_[0]->{'$!name'} } +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'} } -sub associated_class { $_[0]->{'$!associated_class'} } -sub associated_methods { $_[0]->{'@!associated_methods'} } +# end bootstrapped away method section. +# (all methods below here are kept intact) -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_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 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 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; +} -# end bootstrapped away method section. -# (all methods below here are kept intact) +sub get_read_method_ref { + my $self = shift; + if ((my $reader = $self->get_read_method) && $self->associated_class) { + return $self->associated_class->get_method($reader); + } + else { + 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_read_method { $_[0]->reader || $_[0]->accessor } -sub get_write_method { $_[0]->writer || $_[0]->accessor } +sub get_write_method_ref { + my $self = shift; + if ((my $writer = $self->get_write_method) && $self->associated_class) { + return $self->associated_class->get_method($writer); + } + else { + 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 { @@ -144,9 +251,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 @@ -159,27 +266,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); } @@ -187,7 +303,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); } @@ -195,15 +311,15 @@ sub get_value { sub has_value { my ($self, $instance) = @_; - defined Class::MOP::Class->initialize(blessed($instance)) - ->get_meta_instance - ->get_slot_value($instance, $self->name) ? 1 : 0; + Class::MOP::Class->initialize(ref($instance)) + ->get_meta_instance + ->is_slot_initialized($instance, $self->name); } 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); } @@ -214,11 +330,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); } @@ -230,6 +350,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 $@; @@ -269,12 +391,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 { @@ -306,14 +428,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 @@ -356,13 +478,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 @@ -371,6 +488,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 @@ -398,7 +521,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' => ( @@ -412,6 +535,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 @@ -455,9 +609,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 @@ -468,8 +631,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 @@ -487,6 +657,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 @@ -494,7 +669,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 @@ -524,28 +699,51 @@ 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 =item B -Return the name 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 used. +Return the name of a method name suitable for reading / writing the value +of the attribute in the associated class. Suitable for use whether +C and C or C was used. + +=item B + +=item B + +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 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 @@ -565,10 +763,14 @@ These are all basic predicate methods for the values passed into C. =item B +=item B + =item B =item B +=item B + =back =head2 Class association @@ -619,7 +821,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 @@ -660,7 +863,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 @@ -671,7 +874,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