X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FClass%2FMOP%2FAttribute.pm;h=67e07d5494c8554a27ff6e1a0b59cca86339e62a;hb=c81de280d40e74b36c550d8f1a6727f250f35500;hp=c14eca35dcc96d551bf993554e9f7ecf989ca1c7;hpb=f8dfcfb7a421e85b1a84cd4308e8eb5136293adb;p=gitmo%2FClass-MOP.git diff --git a/lib/Class/MOP/Attribute.pm b/lib/Class/MOP/Attribute.pm index c14eca3..67e07d5 100644 --- a/lib/Class/MOP/Attribute.pm +++ b/lib/Class/MOP/Attribute.pm @@ -4,10 +4,12 @@ package Class::MOP::Attribute; use strict; use warnings; +use Class::MOP::Method::Accessor; + use Carp 'confess'; use Scalar::Util 'blessed', 'reftype', 'weaken'; -our $VERSION = '0.12'; +our $VERSION = '0.14'; our $AUTHORITY = 'cpan:STEVAN'; use base 'Class::MOP::Object'; @@ -43,17 +45,20 @@ sub new { if exists $options{default} && ref $options{default}; bless { - name => $name, - accessor => $options{accessor}, - reader => $options{reader}, - writer => $options{writer}, - predicate => $options{predicate}, - clearer => $options{clearer}, - init_arg => $options{init_arg}, - default => $options{default}, + '$!name' => $name, + '$!accessor' => $options{accessor}, + '$!reader' => $options{reader}, + '$!writer' => $options{writer}, + '$!predicate' => $options{predicate}, + '$!clearer' => $options{clearer}, + '$!init_arg' => $options{init_arg}, + '$!default' => $options{default}, # 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; } @@ -72,13 +77,13 @@ sub clone { 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}) { + if (!defined $val && defined $self->{'$!default'}) { $val = $self->default($instance); } $meta_instance->set_slot_value($instance, $self->name, $val); @@ -88,42 +93,46 @@ sub initialize_instance_slot { # 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_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_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_init_arg { defined($_[0]->{'$!init_arg'}) ? 1 : 0 } +sub has_default { defined($_[0]->{'$!default'}) ? 1 : 0 } -sub accessor { $_[0]->{accessor} } -sub reader { $_[0]->{reader} } -sub writer { $_[0]->{writer} } -sub predicate { $_[0]->{predicate} } -sub clearer { $_[0]->{clearer} } -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 init_arg { $_[0]->{'$!init_arg'} } # 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 is_default_a_coderef { - ('CODE' eq (reftype($_[0]->{default}) || '')) + ('CODE' eq (reftype($_[0]->{'$!default'} || $_[0]->{default}) || '')) } sub default { my ($self, $instance) = @_; - if ($instance && $self->is_default_a_coderef) { + if (defined $instance && $self->is_default_a_coderef) { # if the default is a CODE ref, then # 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 @@ -136,12 +145,19 @@ 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; } ## Slot management @@ -149,130 +165,38 @@ sub detach_from_class { sub set_value { my ($self, $instance, $value) = @_; - Class::MOP::Class->initialize(Scalar::Util::blessed($instance)) + Class::MOP::Class->initialize(blessed($instance)) ->get_meta_instance - ->set_slot_value( $instance, $self->name, $value ); + ->set_slot_value($instance, $self->name, $value); } sub get_value { my ($self, $instance) = @_; - Class::MOP::Class->initialize(Scalar::Util::blessed($instance)) + Class::MOP::Class->initialize(blessed($instance)) ->get_meta_instance ->get_slot_value($instance, $self->name); } -## Method generation helpers - -sub generate_accessor_method { - my $attr = shift; - return sub { - $attr->set_value($_[0], $_[1]) if scalar(@_) == 2; - $attr->get_value($_[0]); - }; -} - -sub generate_accessor_method_inline { - my $self = shift; - my $attr_name = $self->name; - my $meta_instance = $self->associated_class->instance_metaclass; - - my $code = eval 'sub {' - . $meta_instance->inline_set_slot_value('$_[0]', "'$attr_name'", '$_[1]') . ' if scalar(@_) == 2; ' - . $meta_instance->inline_get_slot_value('$_[0]', "'$attr_name'") - . '}'; - confess "Could not generate inline accessor because : $@" if $@; - - return $code; -} - -sub generate_reader_method { - my $attr = shift; - return sub { - confess "Cannot assign a value to a read-only accessor" if @_ > 1; - $attr->get_value($_[0]); - }; -} - -sub generate_reader_method_inline { - my $self = shift; - my $attr_name = $self->name; - my $meta_instance = $self->associated_class->instance_metaclass; - - my $code = eval 'sub {' - . 'confess "Cannot assign a value to a read-only accessor" if @_ > 1;' - . $meta_instance->inline_get_slot_value('$_[0]', "'$attr_name'") - . '}'; - confess "Could not generate inline accessor because : $@" if $@; - - return $code; -} - -sub generate_writer_method { - my $attr = shift; - return sub { - $attr->set_value($_[0], $_[1]); - }; -} - -sub generate_writer_method_inline { - my $self = shift; - my $attr_name = $self->name; - my $meta_instance = $self->associated_class->instance_metaclass; - - my $code = eval 'sub {' - . $meta_instance->inline_set_slot_value('$_[0]', "'$attr_name'", '$_[1]') - . '}'; - confess "Could not generate inline accessor because : $@" if $@; - - return $code; -} - -sub generate_predicate_method { - my $self = shift; - my $attr_name = $self->name; - return sub { - defined Class::MOP::Class->initialize(Scalar::Util::blessed($_[0])) - ->get_meta_instance - ->get_slot_value($_[0], $attr_name) ? 1 : 0; - }; -} - -sub generate_clearer_method { - my $self = shift; - my $attr_name = $self->name; - return sub { - Class::MOP::Class->initialize(Scalar::Util::blessed($_[0])) - ->get_meta_instance - ->deinitialize_slot($_[0], $attr_name); - }; +sub has_value { + my ($self, $instance) = @_; + + defined Class::MOP::Class->initialize(blessed($instance)) + ->get_meta_instance + ->get_slot_value($instance, $self->name) ? 1 : 0; } -sub generate_predicate_method_inline { - my $self = shift; - my $attr_name = $self->name; - my $meta_instance = $self->associated_class->instance_metaclass; - - my $code = eval 'sub {' - . 'defined ' . $meta_instance->inline_get_slot_value('$_[0]', "'$attr_name'") . ' ? 1 : 0' - . '}'; - confess "Could not generate inline predicate because : $@" if $@; - - return $code; +sub clear_value { + my ($self, $instance) = @_; + + Class::MOP::Class->initialize(blessed($instance)) + ->get_meta_instance + ->deinitialize_slot($instance, $self->name); } -sub generate_clearer_method_inline { - my $self = shift; - my $attr_name = $self->name; - my $meta_instance = $self->associated_class->instance_metaclass; +## load em up ... - my $code = eval 'sub {' - . $meta_instance->inline_deinitialize_slot('$_[0]', "'$attr_name'") - . '}'; - confess "Could not generate inline clearer because : $@" if $@; - - return $code; -} +sub accessor_metaclass { 'Class::MOP::Method::Accessor' } sub process_accessors { my ($self, $type, $accessor, $generate_as_inline_methods) = @_; @@ -280,17 +204,23 @@ sub process_accessors { (reftype($accessor) eq 'HASH') || confess "bad accessor/reader/writer/predicate/clearer format, must be a HASH ref"; my ($name, $method) = %{$accessor}; - return ($name, Class::MOP::Attribute::Accessor->wrap($method)); + $method = $self->accessor_metaclass->wrap($method); + $self->associate_method($method); + return ($name, $method); } else { - my $inline_me = ($generate_as_inline_methods && $self->associated_class->instance_metaclass->is_inlinable); - my $generator = $self->can('generate_' . $type . '_method' . ($inline_me ? '_inline' : '')); - ($generator) - || confess "There is no method generator for the type='$type'"; - if (my $method = $self->$generator($self->name)) { - return ($accessor => Class::MOP::Attribute::Accessor->wrap($method)); - } - confess "Could not create the '$type' method for " . $self->name . " because : $@"; + my $inline_me = ($generate_as_inline_methods && $self->associated_class->instance_metaclass->is_inlinable); + my $method; + eval { + $method = $self->accessor_metaclass->new( + attribute => $self, + is_inline => $inline_me, + accessor_type => $type, + ); + }; + confess "Could not create the '$type' method for " . $self->name . " because : $@" if $@; + $self->associate_method($method); + return ($accessor, $method); } } @@ -330,11 +260,16 @@ sub install_accessors { } my $method = $class->get_method($accessor); $class->remove_method($accessor) - if (blessed($method) && $method->isa('Class::MOP::Attribute::Accessor')); + if (blessed($method) && $method->isa('Class::MOP::Method::Accessor')); }; sub remove_accessors { my $self = shift; + # TODO: + # we really need to make sure to remove from the + # associates methods here as well. But this is + # such a slimly used method, I am not worried + # about it right now. $_remove_accessor->($self->accessor(), $self->associated_class()) if $self->has_accessor(); $_remove_accessor->($self->reader(), $self->associated_class()) if $self->has_reader(); $_remove_accessor->($self->writer(), $self->associated_class()) if $self->has_writer(); @@ -345,18 +280,6 @@ sub install_accessors { } -package Class::MOP::Attribute::Accessor; - -use strict; -use warnings; - -use Class::MOP::Method; - -our $VERSION = '0.02'; -our $AUTHORITY = 'cpan:STEVAN'; - -use base 'Class::MOP::Method'; - 1; __END__ @@ -530,18 +453,35 @@ back to their "unfulfilled" state. =head2 Value management +These methods are basically "backdoors" to the instance, which can be used +to bypass the regular accessors, but still stay within the context of the MOP. + +These methods are not for general use, and should only be used if you really +know what you are doing. + =over 4 -=item set_value $instance, $value +=item B Set the value without going through the accessor. Note that this may be done to even attributes with just read only accessors. -=item get_value $instance +=item B Return the value without going through the accessor. Note that this may be done 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. +This is basically what the default C method calls. + +=item B + +This will clear the value in the C<$instance>. This is basically what the default +C would call. Note that this may be done even if the attirbute does not +have any associated read, write or clear methods. + =back =head2 Informational @@ -578,6 +518,14 @@ argument C<$instance> into it and return the value. Returns 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. + =back =head2 Informational predicates @@ -604,19 +552,31 @@ These are all basic predicate methods for the values passed into C. =head2 Class association +These methods allow you to manage the attributes association with +the class that contains it. These methods should not be used +lightly, nor are they very magical, they are mostly used internally +and by metaclass instances. + =over 4 =item B -=item B +This returns the metaclass this attribute is associated with. -=item B +=item B -=item B +This will store a weaken reference to C<$class> internally. You should +note that just changing the class assocation will not remove the attribute +from it's old class, and initialize it (and it's accessors) in the new +C<$class>. It is up to you to do this manually. -=item B +=item B -=item B +This will remove the weakened reference to the class. It does B +remove the attribute itself from the class (or remove it's accessors), +you must do that yourself if you want too. Actually if that is what +you want to do, you should probably be looking at +L instead. =back @@ -624,6 +584,22 @@ These are all basic predicate methods for the values passed into C. =over 4 +=item B + +Accessors are generated by an accessor metaclass, which is usually +a subclass of C. This method returns +the name of the accessor metaclass that this attribute uses. + +=item B + +This will associate a C<$method> with the given attribute which is +used internally by the accessor generator. + +=item B + +This will return the list of methods which have been associated with +the C methods. + =item B This allows the attribute to generate and install code for it's own @@ -641,40 +617,15 @@ different types). It will then either generate the method itself (using the C methods listed below) or it will use the custom method passed through the constructor. -=over 4 - -=item B - -=item B - -=item B - -=item B - -=item B - -=back - -=over 4 - -=item B - -=item B - -=item B - -=item B - -=item B - -=back - =item B This allows the attribute to remove the method for it's own I. This is called by C. +NOTE: This does not currently remove methods from the list returned +by C, that is on the TODO list. + =back =head2 Introspection @@ -701,7 +652,7 @@ Yuval Kogman Enothingmuch@woobling.comE =head1 COPYRIGHT AND LICENSE -Copyright 2006 by Infinity Interactive, Inc. +Copyright 2006, 2007 by Infinity Interactive, Inc. L