X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FClass%2FMOP%2FAttribute.pm;h=fc8d58b7cfaa70e2a993769d377b16d4077e44c0;hb=6b5ac420e48ce3b29d9fe53094954821508b2925;hp=31ff9a40bc60fe870280f25964360f5b76bdf4da;hpb=2e5a2a6225146cc29a9ad1a1ae8a70cdb06b0fa5;p=gitmo%2FClass-MOP.git diff --git a/lib/Class/MOP/Attribute.pm b/lib/Class/MOP/Attribute.pm index 31ff9a4..fc8d58b 100644 --- a/lib/Class/MOP/Attribute.pm +++ b/lib/Class/MOP/Attribute.pm @@ -7,18 +7,14 @@ use warnings; use Class::MOP::Method::Accessor; use Carp 'confess'; -use Scalar::Util 'blessed', 'reftype', 'weaken'; +use Scalar::Util 'blessed', 'weaken'; -our $VERSION = '0.23'; +our $VERSION = '0.71_02'; +$VERSION = eval $VERSION; our $AUTHORITY = 'cpan:STEVAN'; use base 'Class::MOP::Object'; -sub meta { - require Class::MOP::Class; - Class::MOP::Class->initialize(blessed($_[0]) || $_[0]); -} - # NOTE: (meta-circularity) # This method will be replaced in the # boostrap section of Class::MOP, by @@ -29,9 +25,12 @@ sub meta { # meta-objects. # - Ain't meta-circularity grand? :) sub new { - my $class = shift; - my $name = shift; - my %options = @_; + my ( $class, @args ) = @_; + + unshift @args, "name" if @args % 2 == 1; + my %options = @args; + + my $name = $options{name}; (defined $name && $name) || confess "You must provide a name for the attribute"; @@ -46,33 +45,38 @@ sub new { } else { (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 [])") + "wrap the default of '$name' in a CODE reference (ex: sub { [] } and not [])") if exists $options{default} && ref $options{default}; } if( $options{required} and not( defined($options{builder}) || defined($options{init_arg}) || exists $options{default} ) ) { confess("A required attribute must have either 'init_arg', 'builder', or 'default'"); } + + $class->_new(\%options); +} + +sub _new { + my $class = shift; + my $options = @_ == 1 ? $_[0] : {@_}; + bless { - '$!name' => $name, - '$!accessor' => $options{accessor}, - '$!reader' => $options{reader}, - '$!writer' => $options{writer}, - '$!predicate' => $options{predicate}, - '$!clearer' => $options{clearer}, - '$!builder' => $options{builder}, - '$!init_arg' => $options{init_arg}, - '$!default' => $options{default}, - '$!initializer' => $options{initializer}, + 'name' => $options->{name}, + 'accessor' => $options->{accessor}, + 'reader' => $options->{reader}, + 'writer' => $options->{writer}, + 'predicate' => $options->{predicate}, + 'clearer' => $options->{clearer}, + 'builder' => $options->{builder}, + 'init_arg' => $options->{init_arg}, + 'default' => $options->{default}, + 'initializer' => $options->{initializer}, # keep a weakened link to the # class we are associated with - '$!associated_class' => undef, + 'associated_class' => undef, # and a list of the methods # associated with this attr - '@!associated_methods' => [], - # NOTE: - # protect this from silliness - init_arg => undef, - } => $class; + 'associated_methods' => [], + }, $class; } # NOTE: @@ -85,12 +89,13 @@ sub clone { my %options = @_; (blessed($self)) || confess "Can only clone an instance"; - return bless { %{$self}, %options } => blessed($self); + return bless { %{$self}, %options } => ref($self); } sub initialize_instance_slot { my ($self, $meta_instance, $instance, $params) = @_; - my $init_arg = $self->{'$!init_arg'}; + my $init_arg = $self->{'init_arg'}; + # try to fetch the init arg from the %params ... # if nothing was in the %params, we can use the @@ -102,14 +107,14 @@ sub initialize_instance_slot { $params->{$init_arg}, ); } - elsif (defined $self->{'$!default'}) { + elsif (defined $self->{'default'}) { $self->_set_initial_slot_value( $meta_instance, $instance, $self->default($instance), ); } - elsif (defined( my $builder = $self->{'$!builder'})) { + elsif (defined( my $builder = $self->{'builder'})) { if ($builder = $instance->can($builder)) { $self->_set_initial_slot_value( $meta_instance, @@ -118,7 +123,7 @@ sub initialize_instance_slot { ); } else { - confess(blessed($instance)." does not support builder method '". $self->{'$!builder'} ."' for attribute '" . $self->name . "'"); + confess(ref($instance)." does not support builder method '". $self->{'builder'} ."' for attribute '" . $self->name . "'"); } } } @@ -145,33 +150,36 @@ sub _set_initial_slot_value { # 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_builder { defined($_[0]->{'$!builder'}) ? 1 : 0 } -sub has_init_arg { defined($_[0]->{'$!init_arg'}) ? 1 : 0 } -sub has_default { defined($_[0]->{'$!default'}) ? 1 : 0 } -sub has_initializer { defined($_[0]->{'$!initializer'}) ? 1 : 0 } - -sub accessor { $_[0]->{'$!accessor'} } -sub reader { $_[0]->{'$!reader'} } -sub writer { $_[0]->{'$!writer'} } -sub predicate { $_[0]->{'$!predicate'} } -sub clearer { $_[0]->{'$!clearer'} } -sub builder { $_[0]->{'$!builder'} } -sub init_arg { $_[0]->{'$!init_arg'} } -sub initializer { $_[0]->{'$!initializer'} } +sub name { $_[0]->{'name'} } + +sub associated_class { $_[0]->{'associated_class'} } +sub associated_methods { $_[0]->{'associated_methods'} } + +sub has_accessor { defined($_[0]->{'accessor'}) } +sub has_reader { defined($_[0]->{'reader'}) } +sub has_writer { defined($_[0]->{'writer'}) } +sub has_predicate { defined($_[0]->{'predicate'}) } +sub has_clearer { defined($_[0]->{'clearer'}) } +sub has_builder { defined($_[0]->{'builder'}) } +sub has_init_arg { defined($_[0]->{'init_arg'}) } +sub has_default { defined($_[0]->{'default'}) } +sub has_initializer { defined($_[0]->{'initializer'}) } + +sub accessor { $_[0]->{'accessor'} } +sub reader { $_[0]->{'reader'} } +sub writer { $_[0]->{'writer'} } +sub predicate { $_[0]->{'predicate'} } +sub clearer { $_[0]->{'clearer'} } +sub builder { $_[0]->{'builder'} } +sub init_arg { $_[0]->{'init_arg'} } +sub initializer { $_[0]->{'initializer'} } # end bootstrapped away method section. # (all methods below here are kept intact) +sub has_read_method { $_[0]->has_reader || $_[0]->has_accessor } +sub has_write_method { $_[0]->has_writer || $_[0]->has_accessor } + sub get_read_method { my $self = shift; my $reader = $self->reader || $self->accessor; @@ -198,7 +206,17 @@ sub get_read_method_ref { return $self->associated_class->get_method($reader); } else { - return sub { $self->get_value(@_) }; + my $code = sub { $self->get_value(@_) }; + if (my $class = $self->associated_class) { + return $class->method_metaclass->wrap( + $code, + package_name => $class->name, + name => '__ANON__' + ); + } + else { + return $code; + } } } @@ -208,12 +226,22 @@ sub get_write_method_ref { return $self->associated_class->get_method($writer); } else { - return sub { $self->set_value(@_) }; + my $code = sub { $self->set_value(@_) }; + if (my $class = $self->associated_class) { + return $class->method_metaclass->wrap( + $code, + package_name => $class->name, + name => '__ANON__' + ); + } + else { + return $code; + } } } sub is_default_a_coderef { - ('CODE' eq (reftype($_[0]->{'$!default'} || $_[0]->{default}) || '')) + ('CODE' eq ref($_[0]->{'default'})) } sub default { @@ -223,9 +251,9 @@ sub default { # we pass in the instance and default # can return a value based on that # instance. Somewhat crude, but works. - return $self->{'$!default'}->($instance); + return $self->{'default'}->($instance); } - $self->{'$!default'}; + $self->{'default'}; } # slots @@ -238,19 +266,19 @@ 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); + weaken($self->{'associated_class'} = $class); } sub detach_from_class { my $self = shift; - $self->{'$!associated_class'} = undef; + $self->{'associated_class'} = undef; } # method association sub associate_method { my ($self, $method) = @_; - push @{$self->{'@!associated_methods'}} => $method; + push @{$self->{'associated_methods'}} => $method; } ## Slot management @@ -258,7 +286,7 @@ sub associate_method { sub set_initial_value { my ($self, $instance, $value) = @_; $self->_set_initial_slot_value( - Class::MOP::Class->initialize(blessed($instance))->get_meta_instance, + Class::MOP::Class->initialize(ref($instance))->get_meta_instance, $instance, $value ); @@ -267,7 +295,7 @@ sub set_initial_value { sub set_value { my ($self, $instance, $value) = @_; - Class::MOP::Class->initialize(blessed($instance)) + Class::MOP::Class->initialize(ref($instance)) ->get_meta_instance ->set_slot_value($instance, $self->name, $value); } @@ -275,7 +303,7 @@ sub set_value { sub get_value { my ($self, $instance) = @_; - Class::MOP::Class->initialize(blessed($instance)) + Class::MOP::Class->initialize(ref($instance)) ->get_meta_instance ->get_slot_value($instance, $self->name); } @@ -283,7 +311,7 @@ sub get_value { sub has_value { my ($self, $instance) = @_; - Class::MOP::Class->initialize(blessed($instance)) + Class::MOP::Class->initialize(ref($instance)) ->get_meta_instance ->is_slot_initialized($instance, $self->name); } @@ -291,7 +319,7 @@ sub has_value { sub clear_value { my ($self, $instance) = @_; - Class::MOP::Class->initialize(blessed($instance)) + Class::MOP::Class->initialize(ref($instance)) ->get_meta_instance ->deinitialize_slot($instance, $self->name); } @@ -302,11 +330,15 @@ 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') + if (ref($accessor)) { + (ref($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); + $method = $self->accessor_metaclass->wrap( + $method, + package_name => $self->associated_class->name, + name => $name, + ); $self->associate_method($method); return ($name, $method); } @@ -318,6 +350,8 @@ sub process_accessors { attribute => $self, is_inline => $inline_me, accessor_type => $type, + package_name => $self->associated_class->name, + name => $accessor, ); }; confess "Could not create the '$type' method for " . $self->name . " because : $@" if $@; @@ -357,12 +391,12 @@ sub install_accessors { { my $_remove_accessor = sub { my ($accessor, $class) = @_; - if (reftype($accessor) && reftype($accessor) eq 'HASH') { + if (ref($accessor) && ref($accessor) eq 'HASH') { ($accessor) = keys %{$accessor}; } my $method = $class->get_method($accessor); $class->remove_method($accessor) - if (blessed($method) && $method->isa('Class::MOP::Method::Accessor')); + if (ref($method) && $method->isa('Class::MOP::Method::Accessor')); }; sub remove_accessors { @@ -394,14 +428,14 @@ Class::MOP::Attribute - Attribute Meta Object =head1 SYNOPSIS - Class::MOP::Attribute->new('$foo' => ( + Class::MOP::Attribute->new( foo => ( accessor => 'foo', # dual purpose get/set accessor predicate => 'has_foo' # predicate check for defined-ness init_arg => '-foo', # class->new will look for a -foo key default => 'BAR IS BAZ!' # if no -foo key is provided, use this )); - Class::MOP::Attribute->new('$.bar' => ( + Class::MOP::Attribute->new( bar => ( reader => 'bar', # getter writer => 'set_bar', # setter predicate => 'has_bar' # predicate check for defined-ness @@ -444,7 +478,8 @@ 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>. +value of C<$name>. If an explicit C is given for an init_arg, +an attribute value can't be specified during initialization. =item I @@ -486,7 +521,7 @@ so: And lastly, if the value of your attribute is dependent upon some other aspect of the instance structure, then you can take advantage of the fact that when the I value is a CODE -reference, it is passed the raw (unblessed) instance structure +reference, it is passed the (as yet unfinished) instance structure as it's only argument. So you can do things like this: Class::MOP::Attribute->new('$object_identity' => ( @@ -500,6 +535,37 @@ something you need, you could subclass B and this class to acheive it. However, this is currently left as an exercise to the reader :). +=item I + +This may be a method name (referring to a method on the class with this +attribute) or a CODE ref. The initializer is used to set the attribute value +on an instance when the attribute is set during instance initialization. When +called, it is passed the instance (as the invocant), the value to set, a +slot-setting CODE ref, and the attribute meta-instance. The slot-setting code +is provided to make it easy to set the (possibly altered) value on the instance +without going through several more method calls. + +This contrived example shows an initializer that sets the attribute to twice +the given value. + + Class::MOP::Attribute->new('$doubled' => ( + initializer => sub { + my ($instance, $value, $set) = @_; + $set->($value * 2); + }, + )); + +As method names can be given as initializers, one can easily make +attribute initialization use the writer: + + Class::MOP::Attribute->new('$some_attr' => ( + writer => 'some_attr', + initializer => 'some_attr', + )); + +Your writer will simply need to examine it's C<@_> and determine under +which context it is being called. + =back The I, I, I, I and I keys can @@ -556,7 +622,6 @@ value definedness, instead of presence as it is now. If you really want to get rid of the value, you have to define and use a I (see below). - =item I This is the a method that will uninitialize the attr, reverting lazy values @@ -566,8 +631,15 @@ back to their "unfulfilled" state. =item B +This will return a clone of the attribute instance, allowing the overriding +of various attributes through the C<%options> supplied. + =item B +This method is used internally to initialize the approriate slot for this +attribute in a given C<$instance>, the C<$params> passed are those that were +passed to the constructor. + =back =head2 Value management @@ -662,9 +734,17 @@ Return the CODE reference of a method suitable for reading / writing the value of the attribute in the associated class. Suitable for use whether C and C or C was specified or not. -NOTE: If not reader/writer/accessor was specified, this will use the +NOTE: If no reader/writer/accessor was specified, this will use the attribute get_value/set_value methods, which can be very inefficient. +=item B + +=item B + +Return whether a method exists suitable for reading / writing the value +of the attribute in the associated class. Suitable for use whether +C and C or C was used. + =back =head2 Informational predicates @@ -741,7 +821,8 @@ used internally by the accessor generator. =item B This will return the list of methods which have been associated with -the C methods. +the C methods. This is a good way of seeing what +methods are used to manage a given attribute. =item B @@ -782,7 +863,7 @@ to this class. It should also be noted that B will actually bootstrap this module by installing a number of attribute meta-objects into -it's metaclass. This will allow this class to reap all the benifits +it's metaclass. This will allow this class to reap all the benefits of the MOP when subclassing it. =back