X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FClass%2FMOP%2FAttribute.pm;h=b496b15284ab089f29b7fda5f6dfc32adc5a1d26;hb=1a09d9cce4930577a39060a03029a32cd51d41c7;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..b496b15 100644 --- a/lib/Class/MOP/Attribute.pm +++ b/lib/Class/MOP/Attribute.pm @@ -7,15 +7,15 @@ use warnings; use Carp 'confess'; use Scalar::Util 'blessed', 'reftype', 'weaken'; -our $VERSION = '0.02'; +our $VERSION = '0.10'; 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,11 +30,8 @@ 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}; bless { name => $name, @@ -51,6 +48,33 @@ sub new { } # 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 @@ -74,18 +98,26 @@ sub init_arg { $_[0]->{init_arg} } # end bootstrapped away method section. # (all methods below here are kept intact) +sub is_default_a_coderef { + (reftype($_[0]->{default}) && reftype($_[0]->{default}) eq 'CODE') +} + 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 { @@ -100,45 +132,124 @@ sub detach_from_class { $self->{associated_class} = undef; } +## Slot management + +sub set_value { + my ( $self, $instance, $value ) = @_; + + Class::MOP::Class->initialize(Scalar::Util::blessed($instance)) + ->get_meta_instance + ->set_slot_value( $instance, $self->name, $value ); +} + +sub get_value { + my ( $self, $instance ) = @_; + + Class::MOP::Class->initialize(Scalar::Util::blessed($instance)) + ->get_meta_instance + ->get_slot_value( $instance, $self->name ); +} + ## Method generation helpers sub generate_accessor_method { - my ($self, $attr_name) = @_; - eval qq{sub { - \$_[0]->{'$attr_name'} = \$_[1] if scalar(\@_) == 2; - \$_[0]->{'$attr_name'}; - }}; + 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 ($self, $attr_name) = @_; - eval qq{sub { - \$_[0]->{'$attr_name'}; - }}; + 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 ($self, $attr_name) = @_; - eval qq{sub { - \$_[0]->{'$attr_name'} = \$_[1]; - }}; + 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, $attr_name) = @_; - eval qq{sub { - defined \$_[0]->{'$attr_name'} ? 1 : 0; - }}; + 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_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 accessor because : $@" if $@; + + return $code; } sub process_accessors { - my ($self, $type, $accessor) = @_; - if (reftype($accessor) && reftype($accessor) eq 'HASH') { - my ($name, $method) = each %{$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) = %{$accessor}; return ($name, Class::MOP::Attribute::Accessor->wrap($method)); } else { - my $generator = $self->can('generate_' . $type . '_method'); + 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)) { @@ -149,24 +260,26 @@ sub process_accessors { } 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(); + return; } @@ -364,8 +477,28 @@ defined, and false (C<0>) otherwise. =back +=item B + +=item B + =back +=head2 Value management + +=over 4 + +=item set_value $instance, $value + +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 + +Return the value without going through the accessor. Note that this may be done +even to attributes with just write only accessors. + +=back + =head2 Informational These are all basic read-only value accessors for the values @@ -385,12 +518,19 @@ passed into C. I think they are pretty much self-explanitory. =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 @@ -423,6 +563,12 @@ 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 @@ -448,13 +594,25 @@ 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 -=item B +=item B =back @@ -482,10 +640,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. @@ -495,4 +655,5 @@ 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 +