X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FClass%2FMOP%2FAttribute.pm;h=c8ab6c0c925674134e5729774d299ce30ac1a37d;hb=3545c727b64808e435c361e061962d14ba5b3f31;hp=2eeee2d79d9842b68cdcbd3d3ea4dc9485283b04;hpb=08388f1751d9e56224fd3aaab0d3e2b326b86d1f;p=gitmo%2FClass-MOP.git diff --git a/lib/Class/MOP/Attribute.pm b/lib/Class/MOP/Attribute.pm index 2eeee2d..c8ab6c0 100644 --- a/lib/Class/MOP/Attribute.pm +++ b/lib/Class/MOP/Attribute.pm @@ -4,10 +4,15 @@ 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.08'; +our $VERSION = '0.12'; +our $AUTHORITY = 'cpan:STEVAN'; + +use base 'Class::MOP::Object'; sub meta { require Class::MOP::Class; @@ -15,7 +20,7 @@ sub meta { } # 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,26 +35,36 @@ sub new { (defined $name && $name) || confess "You must provide a name for the attribute"; + $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}, + 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, + # 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 repleace in the Class::MOP +# 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 { @@ -61,7 +76,7 @@ sub clone { } sub initialize_instance_slot { - my ($self, $instance, $params) = @_; + my ($self, $meta_instance, $instance, $params) = @_; my $init_arg = $self->{init_arg}; # try to fetch the init arg from the %params ... my $val; @@ -71,9 +86,7 @@ sub initialize_instance_slot { if (!defined $val && defined $self->{default}) { $val = $self->default($instance); } - - my $meta_instance = $self->associated_class->get_meta_instance; - $meta_instance->set_slot_value_with_init( $instance, $self->slot_name, $val ); + $meta_instance->set_slot_value($instance, $self->name, $val); } # NOTE: @@ -82,12 +95,14 @@ sub initialize_instance_slot { 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 } @@ -95,23 +110,32 @@ 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}) || '')) +} + sub default { - my $self = shift; - if (reftype($self->{default}) && reftype($self->{default}) eq 'CODE') { + my ($self, $instance) = @_; + if ($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}; } +# slots + +sub slots { (shift)->name } + # class association sub attach_to_class { @@ -126,106 +150,102 @@ sub detach_from_class { $self->{associated_class} = undef; } -# slot management +# method association -sub slot_name { # when attr <-> slot mapping is 1:1 - my $self = shift; - $self->name; +sub associate_method { + my ($self, $method) = @_; + push @{$self->{associated_methods}} => $method; } -# slot alocation +## Slot management -sub allocate_slots { - my $self = shift; - my $meta_instance = $self->associated_class->get_meta_instance; - $meta_instance->add_slot( $self->slot_name ); -} +sub set_value { + my ($self, $instance, $value) = @_; -sub deallocate_slots { - my $self = shift; - my $meta_instance = $self->associated_class->get_meta_instance; - $meta_instance->remove_slot( $self->slot_name ); + Class::MOP::Class->initialize(blessed($instance)) + ->get_meta_instance + ->set_slot_value($instance, $self->name, $value); } -## Method generation helpers +sub get_value { + my ($self, $instance) = @_; -sub generate_accessor_method { - my $self = shift; - my $meta_instance = $self->associated_class->get_meta_instance; - my $slot_name = $self->slot_name; - - sub { - $meta_instance->set_slot_value($_[0], $slot_name, $_[1]) if scalar(@_) == 2; - $meta_instance->get_slot_value($_[0], $slot_name); - }; + Class::MOP::Class->initialize(blessed($instance)) + ->get_meta_instance + ->get_slot_value($instance, $self->name); } -sub generate_reader_method { - my $self = shift; - my $meta_instance = $self->associated_class->get_meta_instance; - my $slot_name = $self->slot_name; - sub { - confess "Cannot assign a value to a read-only accessor" if @_ > 1; - $meta_instance->get_slot_value($_[0], $slot_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_writer_method { - my $self = shift; - my $meta_instance = $self->associated_class->get_meta_instance; - my $slot_name = $self->slot_name; - sub { - $meta_instance->set_slot_value($_[0], $slot_name, $_[1]); - }; +sub clear_value { + my ($self, $instance) = @_; + + Class::MOP::Class->initialize(blessed($instance)) + ->get_meta_instance + ->deinitialize_slot($instance, $self->name); } -sub generate_predicate_method { - my $self = shift; - my $meta_instance = $self->associated_class->get_meta_instance; - my $slot_name = $self->slot_name; - sub { - defined $meta_instance->get_slot_value($_[0], $slot_name); - }; -} +## load em up ... + +sub accessor_metaclass { 'Class::MOP::Method::Accessor' } sub process_accessors { - my ($self, $type, $accessor) = @_; + my ($self, $type, $accessor, $generate_as_inline_methods) = @_; if (reftype($accessor)) { (reftype($accessor) eq 'HASH') - || confess "bad accessor/reader/writer/predicate format, must be a HASH ref"; - my ($name, $method) = each %{$accessor}; - return ($name, Class::MOP::Attribute::Accessor->wrap($method)); + || 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, + as_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; } @@ -237,7 +257,7 @@ 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 { @@ -246,22 +266,12 @@ sub install_accessors { $_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__ @@ -375,12 +385,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 @@ -421,6 +430,11 @@ 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 @@ -429,6 +443,26 @@ defined, and false (C<0>) otherwise. =back +=head2 Value management + +=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 + +=item B + +=back + =head2 Informational These are all basic read-only value accessors for the values @@ -446,14 +480,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 @@ -470,6 +513,8 @@ These are all basic predicate methods for the values passed into C. =item B +=item B + =item B =item B @@ -486,18 +531,18 @@ These are all basic predicate methods for the values passed into C. =item B -=item B - -=item B - -=item B - =back =head2 Attribute Accessor generation =over 4 +=item B + +=item B + +=item B + =item B This allows the attribute to generate and install code for it's own @@ -515,22 +560,10 @@ 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. =back @@ -551,10 +584,12 @@ 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. @@ -564,4 +599,6 @@ 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 + +