X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FClass%2FMOP%2FAttribute.pm;h=c8ab6c0c925674134e5729774d299ce30ac1a37d;hb=fdbdb5e6eb0e4f6c54629f0bde376aba5e69df14;hp=299342c6b61a519c3c0507a9756b91120f0698e6;hpb=a2e85e6c752e6dd43555a7eb5623696a86afa858;p=gitmo%2FClass-MOP.git diff --git a/lib/Class/MOP/Attribute.pm b/lib/Class/MOP/Attribute.pm index 299342c..c8ab6c0 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'; +use Scalar::Util 'blessed', 'reftype', 'weaken'; + +our $VERSION = '0.12'; +our $AUTHORITY = 'cpan:STEVAN'; -our $VERSION = '0.01'; +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,9 +35,14 @@ 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}; + + (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, @@ -40,17 +50,59 @@ sub new { reader => $options{reader}, writer => $options{writer}, predicate => $options{predicate}, + clearer => $options{clearer}, init_arg => $options{init_arg}, - default => $options{default} + 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 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 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 } @@ -58,75 +110,143 @@ 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}; } -{ - # this is just a utility routine to - # handle the details of accessors - my $_inspect_accessor = sub { - my ($attr_name, $type, $accessor) = @_; - - my %ACCESSOR_TEMPLATES = ( - 'accessor' => qq{sub { - \$_[0]->{'$attr_name'} = \$_[1] if scalar(\@_) == 2; - \$_[0]->{'$attr_name'}; - }}, - 'reader' => qq{sub { - \$_[0]->{'$attr_name'}; - }}, - 'writer' => qq{sub { - \$_[0]->{'$attr_name'} = \$_[1]; - }}, - 'predicate' => qq{sub { - defined \$_[0]->{'$attr_name'} ? 1 : 0; - }} - ); +# 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); +} + +sub detach_from_class { + my $self = shift; + $self->{associated_class} = undef; +} + +# method association + +sub associate_method { + my ($self, $method) = @_; + push @{$self->{associated_methods}} => $method; +} + +## 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 get_value { + my ($self, $instance) = @_; + + Class::MOP::Class->initialize(blessed($instance)) + ->get_meta_instance + ->get_slot_value($instance, $self->name); +} + +sub has_value { + my ($self, $instance) = @_; - if (reftype($accessor) && reftype($accessor) eq 'HASH') { - my ($name, $method) = each %{$accessor}; - return ($name, Class::MOP::Attribute::Accessor->wrap($method)); - } - else { - my $method = eval $ACCESSOR_TEMPLATES{$type}; - confess "Could not create the $type for $attr_name CODE(\n" . $ACCESSOR_TEMPLATES{$type} . "\n) : $@" if $@; - return ($accessor => Class::MOP::Attribute::Accessor->wrap($method)); - } - }; + 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 install_accessors { - my ($self, $class) = @_; - (blessed($class) && $class->isa('Class::MOP::Class')) - || confess "You must pass a Class::MOP::Class instance (or a subclass)"; - $class->add_method( - $_inspect_accessor->($self->name, 'accessor' => $self->accessor()) - ) if $self->has_accessor(); - - $class->add_method( - $_inspect_accessor->($self->name, 'reader' => $self->reader()) - ) if $self->has_reader(); +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') + || 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 $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 $inline = shift; + my $class = $self->associated_class; - $class->add_method( - $_inspect_accessor->($self->name, 'writer' => $self->writer()) - ) if $self->has_writer(); + $class->add_method( + $self->process_accessors('accessor' => $self->accessor(), $inline) + ) if $self->has_accessor(); + + $class->add_method( + $self->process_accessors('reader' => $self->reader(), $inline) + ) if $self->has_reader(); + + $class->add_method( + $self->process_accessors('writer' => $self->writer(), $inline) + ) if $self->has_writer(); + + $class->add_method( + $self->process_accessors('predicate' => $self->predicate(), $inline) + ) if $self->has_predicate(); - $class->add_method( - $_inspect_accessor->($self->name, 'predicate' => $self->predicate()) - ) if $self->has_predicate(); - return; - } + $class->add_method( + $self->process_accessors('clearer' => $self->clearer(), $inline) + ) if $self->has_clearer(); + return; } { @@ -137,33 +257,21 @@ sub default { } 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, $class) = @_; - (blessed($class) && $class->isa('Class::MOP::Class')) - || confess "You must pass a Class::MOP::Class instance (or a subclass)"; - $_remove_accessor->($self->accessor(), $class) if $self->has_accessor(); - $_remove_accessor->($self->reader(), $class) if $self->has_reader(); - $_remove_accessor->($self->writer(), $class) if $self->has_writer(); - $_remove_accessor->($self->predicate(), $class) if $self->has_predicate(); + my $self = shift; + $_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__ @@ -225,6 +333,9 @@ 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 @@ -274,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 @@ -320,10 +430,39 @@ 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 + +=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 @@ -341,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 @@ -365,26 +513,57 @@ These are all basic predicate methods for the values passed into C. =item B +=item B + =item B =item B =back +=head2 Class association + +=over 4 + +=item B + +=item B + +=item B + +=back + =head2 Attribute Accessor generation =over 4 -=item B +=item B + +=item B + +=item B + +=item B This allows the attribute to generate and install code for it's own I methods. This is called by C. -=item B +This method will call C for each of the possible +method types (accessor, reader, writer & predicate). + +=item B + +This takes a C<$type> (accessor, reader, writer or predicate), and +a C<$value> (the value passed into the constructor for each of the +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. + +=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 @@ -405,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. @@ -418,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 + +