X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FClass%2FMOP%2FAttribute.pm;h=bf61239a02d525c9ddbeff3c7044b1013492410b;hb=d004c8d565f9b314da7652e9368aeb4587ffaa3d;hp=53e0a1042fb3a3d801d037d9d4eacccc3796ac12;hpb=a6710c607743a769b40827d2bfefc2f0e19f313b;p=gitmo%2FClass-MOP.git diff --git a/lib/Class/MOP/Attribute.pm b/lib/Class/MOP/Attribute.pm index 53e0a10..bf61239 100644 --- a/lib/Class/MOP/Attribute.pm +++ b/lib/Class/MOP/Attribute.pm @@ -8,12 +8,13 @@ use Class::MOP::Method::Accessor; use Carp 'confess'; use Scalar::Util 'blessed', 'weaken'; +use Try::Tiny; -our $VERSION = '0.78'; +our $VERSION = '1.12'; $VERSION = eval $VERSION; our $AUTHORITY = 'cpan:STEVAN'; -use base 'Class::MOP::Object'; +use base 'Class::MOP::Object', 'Class::MOP::Mixin::AttributeCore'; # NOTE: (meta-circularity) # This method will be replaced in the @@ -32,7 +33,7 @@ sub new { my $name = $options{name}; - (defined $name && $name) + (defined $name) || confess "You must provide a name for the attribute"; $options{init_arg} = $name @@ -43,7 +44,7 @@ sub new { confess("Setting both default and builder is not allowed.") if exists $options{default}; } else { - (is_default_a_coderef(\%options)) + ($class->is_default_a_coderef(\%options)) || confess("References are not allowed as default values, you must ". "wrap the default of '$name' in a CODE reference (ex: sub { [] } and not [])") if exists $options{default} && ref $options{default}; @@ -57,6 +58,10 @@ sub new { sub _new { my $class = shift; + + return Class::MOP::Class->initialize($class)->new_object(@_) + if $class ne __PACKAGE__; + my $options = @_ == 1 ? $_[0] : {@_}; bless { @@ -68,7 +73,9 @@ sub _new { 'clearer' => $options->{clearer}, 'builder' => $options->{builder}, 'init_arg' => $options->{init_arg}, - 'default' => $options->{default}, + exists $options->{default} + ? ('default' => $options->{default}) + : (), 'initializer' => $options->{initializer}, 'definition_context' => $options->{definition_context}, # keep a weakened link to the @@ -77,6 +84,10 @@ sub _new { # and a list of the methods # associated with this attr 'associated_methods' => [], + # this let's us keep track of + # our order inside the associated + # class + 'insertion_order' => undef, }, $class; } @@ -108,7 +119,7 @@ sub initialize_instance_slot { $params->{$init_arg}, ); } - elsif (defined $self->{'default'}) { + elsif (exists $self->{'default'}) { $self->_set_initial_slot_value( $meta_instance, $instance, @@ -137,48 +148,24 @@ sub _set_initial_slot_value { return $meta_instance->set_slot_value($instance, $slot_name, $value) unless $self->has_initializer; - my $callback = sub { - $meta_instance->set_slot_value($instance, $slot_name, $_[0]); - }; - + my $callback = $self->_make_initializer_writer_callback( + $meta_instance, $instance, $slot_name + ); + my $initializer = $self->initializer; # most things will just want to set a value, so make it first arg $instance->$initializer($value, $callback, $self); } -# NOTE: -# the next bunch of methods will get bootstrapped -# away in the Class::MOP bootstrapping section - -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'} } -sub definition_context { $_[0]->{'definition_context'} } - -# 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 _make_initializer_writer_callback { + my $self = shift; + my ($meta_instance, $instance, $slot_name) = @_; + + return sub { + $meta_instance->set_slot_value($instance, $slot_name, $_[0]); + }; +} sub get_read_method { my $self = shift; @@ -240,22 +227,6 @@ sub get_write_method_ref { } } -sub is_default_a_coderef { - ('CODE' eq ref($_[0]->{'default'})) -} - -sub default { - my ($self, $instance) = @_; - if (defined $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'}->($instance); - } - $self->{'default'}; -} - # slots sub slots { (shift)->name } @@ -292,47 +263,98 @@ sub set_initial_value { ); } -sub set_value { - my ($self, $instance, $value) = @_; +sub set_value { shift->set_raw_value(@_) } - Class::MOP::Class->initialize(ref($instance)) - ->get_meta_instance - ->set_slot_value($instance, $self->name, $value); +sub set_raw_value { + my $self = shift; + my ($instance, $value) = @_; + + my $mi = Class::MOP::Class->initialize(ref($instance))->get_meta_instance; + return $mi->set_slot_value($instance, $self->name, $value); +} + +sub _inline_set_value { + my $self = shift; + return $self->_inline_instance_set(@_) . ';'; +} + +sub _inline_instance_set { + my $self = shift; + my ($instance, $value) = @_; + + my $mi = $self->associated_class->get_meta_instance; + return $mi->inline_set_slot_value($instance, $self->name, $value); +} + +sub get_value { shift->get_raw_value(@_) } + +sub get_raw_value { + my $self = shift; + my ($instance) = @_; + + my $mi = Class::MOP::Class->initialize(ref($instance))->get_meta_instance; + return $mi->get_slot_value($instance, $self->name); } -sub get_value { - my ($self, $instance) = @_; +sub _inline_get_value { + my $self = shift; + return $self->_inline_instance_get(@_) . ';'; +} + +sub _inline_instance_get { + my $self = shift; + my ($instance) = @_; - Class::MOP::Class->initialize(ref($instance)) - ->get_meta_instance - ->get_slot_value($instance, $self->name); + my $mi = $self->associated_class->get_meta_instance; + return $mi->inline_get_slot_value($instance, $self->name); } sub has_value { - my ($self, $instance) = @_; + my $self = shift; + my ($instance) = @_; - Class::MOP::Class->initialize(ref($instance)) - ->get_meta_instance - ->is_slot_initialized($instance, $self->name); + my $mi = Class::MOP::Class->initialize(ref($instance))->get_meta_instance; + return $mi->is_slot_initialized($instance, $self->name); +} + +sub _inline_has_value { + my $self = shift; + return $self->_inline_instance_has(@_) . ';'; +} + +sub _inline_instance_has { + my $self = shift; + my ($instance) = @_; + + my $mi = $self->associated_class->get_meta_instance; + return $mi->inline_is_slot_initialized($instance, $self->name); } sub clear_value { - my ($self, $instance) = @_; + my $self = shift; + my ($instance) = @_; - Class::MOP::Class->initialize(ref($instance)) - ->get_meta_instance - ->deinitialize_slot($instance, $self->name); + my $mi = Class::MOP::Class->initialize(ref($instance))->get_meta_instance; + return $mi->deinitialize_slot($instance, $self->name); } -## load em up ... +sub _inline_clear_value { + my $self = shift; + return $self->_inline_instance_clear(@_) . ';'; +} -sub accessor_metaclass { 'Class::MOP::Method::Accessor' } +sub _inline_instance_clear { + my $self = shift; + my ($instance) = @_; -sub process_accessors { - warn "The process_accessors method has been made private and this public alias will be removed in a future release."; - goto &_process_accessors; + my $mi = $self->associated_class->get_meta_instance; + return $mi->inline_deinitialize_slot($instance, $self->name); } +## load em up ... + +sub accessor_metaclass { 'Class::MOP::Method::Accessor' } + sub _process_accessors { my ($self, $type, $accessor, $generate_as_inline_methods) = @_; @@ -358,7 +380,7 @@ sub _process_accessors { else { my $inline_me = ($generate_as_inline_methods && $self->associated_class->instance_metaclass->is_inlinable); my $method; - eval { + try { if ( $method_ctx ) { my $desc = "accessor $accessor"; if ( $accessor ne $self->name ) { @@ -376,8 +398,10 @@ sub _process_accessors { name => $accessor, definition_context => $method_ctx, ); + } + catch { + confess "Could not create the '$type' method for " . $self->name . " because : $_"; }; - confess "Could not create the '$type' method for " . $self->name . " because : $@" if $@; $self->associate_method($method); return ($accessor, $method); } @@ -494,25 +518,25 @@ C<%options> are added as key-value pairs. =over 8 -=item I +=item * init_arg This is a string value representing the expected key in an initialization hash. For instance, if we have an C value of C<-foo>, then the following code will Just Work. - MyClass->meta->construct_instance( -foo => 'Hello There' ); + MyClass->meta->new_object( -foo => 'Hello There' ); If an init_arg is not assigned, it will automatically use the attribute's name. If C is explicitly set to C, the attribute cannot be specified during initialization. -=item I +=item * builder This provides the name of a method that will be called to initialize the attribute. This method will be called on the object after it is constructed. It is expected to return a valid value for the attribute. -=item I +=item * default This can be used to provide an explicit default for initializing the attribute. If the default you provide is a subroutine reference, then @@ -562,7 +586,7 @@ Note that there is no guarantee that attributes are initialized in any particular order, so you cannot rely on the value of some other attribute when generating the default. -=item I +=item * initializer This option can be either a method name or a subroutine reference. This method will be called when setting the attribute's @@ -583,7 +607,7 @@ twice the given value. Class::MOP::Attribute->new( 'doubled' => ( initializer => sub { - my ( $instance, $value, $set ) = @_; + my ( $self, $value, $set, $attr ) = @_; $set->( $value * 2 ); }, ) @@ -612,9 +636,9 @@ containing exactly one key (the method name) and one value. The value should be a subroutine reference, which will be installed as the method itself. -=over 4 +=over 8 -=item I +=item * accessor An C is a standard Perl-style read/write accessor. It will return the value of the attribute, and if a value is passed as an @@ -624,12 +648,12 @@ Note that C is a legitimate value, so this will work: $object->set_something(undef); -=item I +=item * reader This is a basic read-only accessor. It returns the value of the attribute. -=item I +=item * writer This is a basic write accessor, it accepts a single argument, and assigns that value to the attribute. @@ -638,7 +662,7 @@ Note that C is a legitimate value, so this will work: $object->set_something(undef); -=item I +=item * predicate The predicate method returns a boolean indicating whether or not the attribute has been explicitly set. @@ -646,12 +670,12 @@ attribute has been explicitly set. Note that the predicate returns true even if the attribute was set to a false value (C<0> or C). -=item I +=item * clearer This method will uninitialize the attribute. After an attribute is cleared, its C will return false. -=item I +=item * definition_context Mostly, this exists as a hook for the benefit of Moose. @@ -683,6 +707,8 @@ the constructor. =item B<< $attr->name >> +Returns the attribute's name. + =item B<< $attr->accessor >> =item B<< $attr->reader >> @@ -750,6 +776,11 @@ writing the attribute's value in the associated class. These methods always return a subroutine reference, regardless of whether or not the attribute is read- or write-only. +=item B<< $attr->insertion_order >> + +If this attribute has been inserted into a class, this returns a zero +based index regarding the order of insertion. + =back =head2 Informational predicates @@ -781,6 +812,10 @@ C is the default C anyway. =item B<< $attr->has_builder >> +=item B<< $attr->has_insertion_order >> + +This will be I if this attribute has not be inserted into a class + =back =head2 Value management @@ -808,6 +843,12 @@ It's unlikely that you'll need to call this method yourself. Sets the value without going through the accessor. Note that this works even with read-only attributes. +=item B<< $attr->set_raw_value($instance, $value) >> + +Sets the value with no side effects such as a trigger. + +This doesn't actually apply to Class::MOP attributes, only to subclasses. + =item B<< $attr->set_initial_value($instance, $value) >> Sets the value without going through the accessor. This method is only @@ -818,6 +859,12 @@ called when the instance is first being initialized. Returns the value without going through the accessor. Note that this works even with write-only accessors. +=item B<< $attr->get_raw_value($instance) >> + +Returns the value without any side effects such as lazy attributes. + +Doesn't actually apply to Class::MOP attributes, only to subclasses. + =item B<< $attr->has_value($instance) >> Return a boolean indicating whether the attribute has been set in @@ -906,13 +953,25 @@ attribute. This does not currently remove methods from the list returned by C. +=item B<< $attr->inline_get >> + +=item B<< $attr->inline_set >> + +=item B<< $attr->inline_has >> + +=item B<< $attr->inline_clear >> + +These methods return a code snippet suitable for inlining the relevant +operation. They expect strings containing variable names to be used in the +inlining, like C<'$self'> or C<'$_[1]'>. + =back =head2 Introspection =over 4 -=item B<< $attr->meta >> +=item B<< Class::MOP::Attribute->meta >> This will return a L instance for this class. @@ -928,7 +987,7 @@ Stevan Little Estevan@iinteractive.comE =head1 COPYRIGHT AND LICENSE -Copyright 2006-2009 by Infinity Interactive, Inc. +Copyright 2006-2010 by Infinity Interactive, Inc. L