X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FClass%2FMOP%2FAttribute.pm;h=941f90a4cc7b4450f2b931566b1933a9860ffaef;hb=2367814a108bbb85efbf76b57fc58bf464d68455;hp=c780a1dbee7fa8b52efa1ae478d48911aeb2f181;hpb=7b31baf476f970830c62cafa82d8f2efcd4ac1b6;p=gitmo%2FClass-MOP.git diff --git a/lib/Class/MOP/Attribute.pm b/lib/Class/MOP/Attribute.pm index c780a1d..941f90a 100644 --- a/lib/Class/MOP/Attribute.pm +++ b/lib/Class/MOP/Attribute.pm @@ -4,18 +4,23 @@ 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.02'; +our $VERSION = '0.14'; +our $AUTHORITY = 'cpan:STEVAN'; + +use base 'Class::MOP::Object'; sub meta { require Class::MOP::Class; - Class::MOP::Class->initialize($_[0]) + Class::MOP::Class->initialize(blessed($_[0]) || $_[0]); } # NOTE: (meta-circularity) -# This method will be replaces in the +# This method will be replaced in the # boostrap section of Class::MOP, by # a new version which uses the # &Class::MOP::Class::construct_instance @@ -30,143 +35,217 @@ sub new { (defined $name && $name) || confess "You must provide a name for the attribute"; - (!exists $options{reader} && !exists $options{writer}) - || confess "You cannot declare an accessor and reader and/or writer functions" - if exists $options{accessor}; - - $options{init_arg} = $name if not exists $options{init_arg}; + + $options{init_arg} = $name + if not exists $options{init_arg}; + + (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}; bless { - name => $name, - accessor => $options{accessor}, - reader => $options{reader}, - writer => $options{writer}, - predicate => $options{predicate}, - 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; } # NOTE: +# this is a primative (and kludgy) clone operation +# for now, it will be replaced in the Class::MOP +# bootstrap with a proper one, however we know +# that this one will work fine for now. +sub clone { + my $self = shift; + my %options = @_; + (blessed($self)) + || confess "Can only clone an instance"; + return bless { %{$self}, %options } => blessed($self); +} + +sub initialize_instance_slot { + my ($self, $meta_instance, $instance, $params) = @_; + 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); + } + $meta_instance->set_slot_value($instance, $self->name, $val); +} + +# 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_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_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 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 is_default_a_coderef { + ('CODE' eq (reftype($_[0]->{'$!default'} || $_[0]->{default}) || '')) +} + sub default { - my $self = shift; - if (reftype($self->{default}) && reftype($self->{default}) eq 'CODE') { + my ($self, $instance) = @_; + 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}->(shift); + return $self->{'$!default'}->($instance); } - $self->{default}; + $self->{'$!default'}; } +# slots + +sub slots { (shift)->name } + # class association 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 generation helpers +# method association -sub generate_accessor_method { - my ($self, $attr_name) = @_; - eval qq{sub { - \$_[0]->{'$attr_name'} = \$_[1] if scalar(\@_) == 2; - \$_[0]->{'$attr_name'}; - }}; +sub associate_method { + my ($self, $method) = @_; + push @{$self->{'@!associated_methods'}} => $method; } -sub generate_reader_method { - my ($self, $attr_name) = @_; - eval qq{sub { - \$_[0]->{'$attr_name'}; - }}; +## Slot management + +sub set_value { + my ($self, $instance, $value) = @_; + + Class::MOP::Class->initialize(blessed($instance)) + ->get_meta_instance + ->set_slot_value($instance, $self->name, $value); } -sub generate_writer_method { - my ($self, $attr_name) = @_; - eval qq{sub { - \$_[0]->{'$attr_name'} = \$_[1]; - }}; +sub get_value { + my ($self, $instance) = @_; + + Class::MOP::Class->initialize(blessed($instance)) + ->get_meta_instance + ->get_slot_value($instance, $self->name); } -sub generate_predicate_method { - my ($self, $attr_name) = @_; - eval qq{sub { - defined \$_[0]->{'$attr_name'} ? 1 : 0; - }}; +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 clear_value { + my ($self, $instance) = @_; + + Class::MOP::Class->initialize(blessed($instance)) + ->get_meta_instance + ->deinitialize_slot($instance, $self->name); +} + +## load em up ... + +sub accessor_metaclass { 'Class::MOP::Method::Accessor' } + sub process_accessors { - my ($self, $type, $accessor) = @_; - if (reftype($accessor) && reftype($accessor) eq 'HASH') { - my ($name, $method) = each %{$accessor}; - return ($name, Class::MOP::Attribute::Accessor->wrap($method)); + my ($self, $type, $accessor, $generate_as_inline_methods) = @_; + if (reftype($accessor)) { + (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); + $self->associate_method($method); + return ($name, $method); } else { - my $generator = $self->can('generate_' . $type . '_method'); - ($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); } } sub install_accessors { - my $self = shift; - my $class = $self->associated_class; + my $self = shift; + my $inline = shift; + my $class = $self->associated_class; $class->add_method( - $self->process_accessors('accessor' => $self->accessor()) + $self->process_accessors('accessor' => $self->accessor(), $inline) ) if $self->has_accessor(); $class->add_method( - $self->process_accessors('reader' => $self->reader()) + $self->process_accessors('reader' => $self->reader(), $inline) ) if $self->has_reader(); $class->add_method( - $self->process_accessors('writer' => $self->writer()) + $self->process_accessors('writer' => $self->writer(), $inline) ) if $self->has_writer(); $class->add_method( - $self->process_accessors('predicate' => $self->predicate()) + $self->process_accessors('predicate' => $self->predicate(), $inline) ) if $self->has_predicate(); + + $class->add_method( + $self->process_accessors('clearer' => $self->clearer(), $inline) + ) if $self->has_clearer(); + return; } @@ -178,31 +257,26 @@ 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(); $_remove_accessor->($self->predicate(), $self->associated_class()) if $self->has_predicate(); + $_remove_accessor->($self->clearer(), $self->associated_class()) if $self->has_clearer(); return; } } -package Class::MOP::Attribute::Accessor; - -use strict; -use warnings; - -use Class::MOP::Method; - -our $VERSION = '0.01'; - -our @ISA = ('Class::MOP::Method'); - 1; __END__ @@ -316,12 +390,11 @@ an exercise to the reader :). =back -The I, I, I and I keys can -contain either; the name of the method and an appropriate default -one will be generated for you, B a HASH ref containing exactly one -key (which will be used as the name of the method) and one value, -which should contain a CODE reference which will be installed as -the method itself. +The I, I, I, I and I keys can +contain either; the name of the method and an appropriate default one will be +generated for you, B a HASH ref containing exactly one key (which will be +used as the name of the method) and one value, which should contain a CODE +reference which will be installed as the method itself. =over 4 @@ -362,10 +435,52 @@ 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. +=item I + +This is the a method that will uninitialize the attr, reverting lazy values +back to their "unfulfilled" state. + =back +=item B + +=item B + =back +=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 B + +Set the value without going through the accessor. Note that this may be done to +even attributes with just read only accessors. + +=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 These are all basic read-only value accessors for the values @@ -383,14 +498,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. +=item B + +Returns a list of slots required by the attribute. This is usually +just one, which is the name of the attribute. + =back =head2 Informational predicates @@ -407,6 +531,8 @@ These are all basic predicate methods for the values passed into C. =item B +=item B + =item B =item B @@ -415,20 +541,54 @@ 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 +This returns the metaclass this attribute is associated with. + =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 +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 =head2 Attribute Accessor generation =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 @@ -446,24 +606,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 - -=back - =item B This allows the attribute to remove the method for it's own -I. This is called by +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 @@ -482,17 +633,21 @@ of the MOP when subclassing it. =back -=head1 AUTHOR +=head1 AUTHORS Stevan Little Estevan@iinteractive.comE +Yuval Kogman Enothingmuch@woobling.comE + =head1 COPYRIGHT AND LICENSE -Copyright 2006 by Infinity Interactive, Inc. +Copyright 2006, 2007 by Infinity Interactive, Inc. L This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. -=cut \ No newline at end of file +=cut + +