X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FClass%2FMOP%2FAttribute.pm;h=1dfc3b3b1480dcd9f7d2d5b4d280aee32e67db58;hb=aa448b163f4882fc3e4b92a1c1f22e3c9ad9f933;hp=5548c7a75a20b4c2f72c3a81b120d67008f37377;hpb=fe122940cbe91ce499fbe50ad706fe3dc7c44fdf;p=gitmo%2FClass-MOP.git diff --git a/lib/Class/MOP/Attribute.pm b/lib/Class/MOP/Attribute.pm index 5548c7a..1dfc3b3 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.04'; 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,34 @@ 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); +} + +# 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,6 +81,9 @@ 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 default { my $self = shift; if (reftype($self->{default}) && reftype($self->{default}) eq 'CODE') { @@ -72,61 +96,88 @@ sub default { $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 { - return 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)); - } - }; +# class association - 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 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, $attr_name) = @_; + eval qq{sub { + \$_[0]->{'$attr_name'} = \$_[1] if scalar(\@_) == 2; + \$_[0]->{'$attr_name'}; + }}; +} + +sub generate_reader_method { + my ($self, $attr_name) = @_; + eval qq{sub { + \$_[0]->{'$attr_name'}; + }}; +} + +sub generate_writer_method { + my ($self, $attr_name) = @_; + eval qq{sub { + \$_[0]->{'$attr_name'} = \$_[1]; + }}; +} + +sub generate_predicate_method { + my ($self, $attr_name) = @_; + eval qq{sub { + defined \$_[0]->{'$attr_name'} ? 1 : 0; + }}; +} + +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)); } + 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 : $@"; + } +} + +sub install_accessors { + my $self = shift; + my $class = $self->associated_class; + $class->add_method( + $self->process_accessors('accessor' => $self->accessor()) + ) if $self->has_accessor(); + + $class->add_method( + $self->process_accessors('reader' => $self->reader()) + ) if $self->has_reader(); + + $class->add_method( + $self->process_accessors('writer' => $self->writer()) + ) if $self->has_writer(); + + $class->add_method( + $self->process_accessors('predicate' => $self->predicate()) + ) if $self->has_predicate(); + return; } { @@ -141,13 +192,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; } @@ -212,9 +261,11 @@ object attributes. =item B An attribute must (at the very least), have a C<$name>. All other -C<%options> are contained added as key-valeue pairs. Acceptable keys +C<%options> are contained added as key-value pairs. Acceptable keys are as follows: +=item B + =over 4 =item I @@ -225,6 +276,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,7 +328,7 @@ an exercise to the reader :). =back -This I, I, I and I keys can +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, @@ -353,7 +407,7 @@ argument C<$instance> into it and return the value. =head2 Informational predicates -These are all basic predicate methodfor the values passed into C. +These are all basic predicate methods for the values passed into C. =over 4 @@ -371,20 +425,55 @@ These are all basic predicate methodfor the values passed into C. =back +=head2 Class association + +=over 4 + +=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 -accessor/reader/writer/predicate methods. This is called by +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 + +=item B This allows the attribute to remove the method for it's own -accessor/reader/writer/predicate. This is called by +I. This is called by C. =back @@ -407,7 +496,7 @@ of the MOP when subclassing it. =head1 AUTHOR -Stevan Little Estevan@iinteractive.comE +Stevan Little Estevan@iinteractive.comE =head1 COPYRIGHT AND LICENSE