X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FClass%2FMOP%2FAttribute.pm;h=5352826313ff28986df5c3bf76c196ebb9cbddcf;hb=4d47b77fec3593e25c28c3126f9b54d7d0bae8e4;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..5352826 100644 --- a/lib/Class/MOP/Attribute.pm +++ b/lib/Class/MOP/Attribute.pm @@ -5,13 +5,13 @@ use strict; use warnings; use Carp 'confess'; -use Scalar::Util 'blessed', 'reftype'; +use Scalar::Util 'blessed', 'reftype', 'weaken'; -our $VERSION = '0.01'; +our $VERSION = '0.08'; sub meta { require Class::MOP::Class; - Class::MOP::Class->initialize($_[0]) + Class::MOP::Class->initialize(blessed($_[0]) || $_[0]); } # NOTE: (meta-circularity) @@ -30,9 +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}; bless { name => $name, @@ -41,12 +40,48 @@ sub new { writer => $options{writer}, predicate => $options{predicate}, 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, } => $class; } +# NOTE: +# this is a primative (and kludgy) clone operation +# for now, it will be repleace 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 has_accessor { defined($_[0]->{accessor}) ? 1 : 0 } sub has_reader { defined($_[0]->{reader}) ? 1 : 0 } sub has_writer { defined($_[0]->{writer}) ? 1 : 0 } @@ -60,73 +95,182 @@ sub writer { $_[0]->{writer} } sub predicate { $_[0]->{predicate} } 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}; } -{ - # 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; - }} - ); - - 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)); - } +# 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 generation helpers + +sub generate_accessor_method { + my $self = shift; + my $attr_name = $self->name; + return sub { + my $meta_instance = Class::MOP::Class->initialize(Scalar::Util::blessed($_[0]))->get_meta_instance; + $meta_instance->set_slot_value($_[0], $attr_name, $_[1]) if scalar(@_) == 2; + $meta_instance->get_slot_value($_[0], $attr_name); }; +} - 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(); - - $class->add_method( - $_inspect_accessor->($self->name, 'writer' => $self->writer()) - ) if $self->has_writer(); - - $class->add_method( - $_inspect_accessor->($self->name, 'predicate' => $self->predicate()) - ) if $self->has_predicate(); - return; +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 = shift; + my $attr_name = $self->name; + return sub { + confess "Cannot assign a value to a read-only accessor" if @_ > 1; + Class::MOP::Class->initialize(Scalar::Util::blessed($_[0])) + ->get_meta_instance + ->get_slot_value($_[0], $attr_name); + }; +} + +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 = shift; + my $attr_name = $self->name; + return sub { + Class::MOP::Class->initialize(Scalar::Util::blessed($_[0])) + ->get_meta_instance + ->set_slot_value($_[0], $attr_name, $_[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_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, $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 $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 : $@"; + } +} + +sub install_accessors { + my $self = shift; + my $inline = shift; + my $class = $self->associated_class; + + $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(); + return; } { @@ -141,13 +285,11 @@ sub default { }; 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(); return; } @@ -225,6 +367,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 @@ -322,6 +467,10 @@ defined, and false (C<0>) otherwise. =back +=item B + +=item B + =back =head2 Informational @@ -343,12 +492,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 @@ -371,17 +527,70 @@ These are all basic predicate methods for the values passed into C. =back +=head2 Class association + +=over 4 + +=item B + +=item B + +=item B + +=item B + +=item B + +=item B + +=back + =head2 Attribute Accessor generation =over 4 -=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. + +=over 4 + +=item B + +=item B + +=item B + +=item B + +=back + +=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