X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FClass%2FMOP%2FMethod%2FAccessor.pm;h=e27d3188b12cdccb012be3d2dba6503924c7b930;hb=ffe92c8b7d896623737c480b5c8bef3c727336ca;hp=36b29a4f2599a3215ff839b6169d8d1539919b91;hpb=96e38ba61b74b11f7dea0abc194617d5bd8a8601;p=gitmo%2FClass-MOP.git diff --git a/lib/Class/MOP/Method/Accessor.pm b/lib/Class/MOP/Method/Accessor.pm index 36b29a4..e27d318 100644 --- a/lib/Class/MOP/Method/Accessor.pm +++ b/lib/Class/MOP/Method/Accessor.pm @@ -7,69 +7,73 @@ use warnings; use Carp 'confess'; use Scalar::Util 'blessed', 'weaken'; -our $VERSION = '0.01'; +our $VERSION = '0.77'; +$VERSION = eval $VERSION; our $AUTHORITY = 'cpan:STEVAN'; -use base 'Class::MOP::Method'; +use base 'Class::MOP::Method::Generated'; sub new { my $class = shift; my %options = @_; - + (exists $options{attribute}) || confess "You must supply an attribute to construct with"; - + (exists $options{accessor_type}) - || confess "You must supply an accessor_type to construct with"; - + || confess "You must supply an accessor_type to construct with"; + (blessed($options{attribute}) && $options{attribute}->isa('Class::MOP::Attribute')) - || confess "You must supply an attribute which is a 'Class::MOP::Attribute' instance"; - - my $self = bless { - # from our superclass - '&!body' => undef, - # specific to this subclass - '$!attribute' => $options{attribute}, - '$!is_inline' => ($options{is_inline} || 0), - '$!accessor_type' => $options{accessor_type}, - } => $class; - - # we don't want this creating - # a cycle in the code, if not + || confess "You must supply an attribute which is a 'Class::MOP::Attribute' instance"; + + ($options{package_name} && $options{name}) + || confess "You must supply the package_name and name parameters $Class::MOP::Method::UPGRADE_ERROR_TEXT"; + + my $self = $class->_new(\%options); + + # we don't want this creating + # a cycle in the code, if not # needed - weaken($self->{'$!attribute'}); - - $self->intialize_body; - + weaken($self->{'attribute'}); + + $self->initialize_body; + return $self; } +sub _new { + my $class = shift; + my $options = @_ == 1 ? $_[0] : {@_}; + + $options->{is_inline} ||= 0; + + return bless $options, $class; +} + ## accessors -sub associated_attribute { (shift)->{'$!attribute'} } -sub accessor_type { (shift)->{'$!accessor_type'} } -sub is_inline { (shift)->{'$!is_inline'} } +sub associated_attribute { (shift)->{'attribute'} } +sub accessor_type { (shift)->{'accessor_type'} } -## factory +## factory -sub intialize_body { +sub initialize_body { my $self = shift; - + my $method_name = join "_" => ( - 'generate', - $self->accessor_type, + 'generate', + $self->accessor_type, 'method', ($self->is_inline ? 'inline' : ()) ); - - eval { $self->{'&!body'} = $self->$method_name() }; - die $@ if $@; + + $self->{'body'} = $self->$method_name(); } ## generators sub generate_accessor_method { - my $attr = (shift)->associated_attribute; + my $attr = (shift)->associated_attribute; return sub { $attr->set_value($_[0], $_[1]) if scalar(@_) == 2; $attr->get_value($_[0]); @@ -77,30 +81,30 @@ sub generate_accessor_method { } sub generate_reader_method { - my $attr = (shift)->associated_attribute; - return sub { + my $attr = (shift)->associated_attribute; + return sub { confess "Cannot assign a value to a read-only accessor" if @_ > 1; $attr->get_value($_[0]); - }; + }; } sub generate_writer_method { - my $attr = (shift)->associated_attribute; + my $attr = (shift)->associated_attribute; return sub { $attr->set_value($_[0], $_[1]); }; } sub generate_predicate_method { - my $attr = (shift)->associated_attribute; - return sub { + my $attr = (shift)->associated_attribute; + return sub { $attr->has_value($_[0]) }; } sub generate_clearer_method { - my $attr = (shift)->associated_attribute; - return sub { + my $attr = (shift)->associated_attribute; + return sub { $attr->clear_value($_[0]) }; } @@ -109,71 +113,77 @@ sub generate_clearer_method { sub generate_accessor_method_inline { - my $attr = (shift)->associated_attribute; + my $self = shift; + my $attr = $self->associated_attribute; my $attr_name = $attr->name; my $meta_instance = $attr->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; + return $self->_eval_closure( + {}, + 'sub {' + . $meta_instance->inline_set_slot_value('$_[0]', $attr_name, '$_[1]') + . ' if scalar(@_) == 2; ' + . $meta_instance->inline_get_slot_value('$_[0]', $attr_name) + . '}' + ); } sub generate_reader_method_inline { - my $attr = (shift)->associated_attribute; + my $self = shift; + my $attr = $self->associated_attribute; my $attr_name = $attr->name; my $meta_instance = $attr->associated_class->instance_metaclass; - my $code = eval 'sub {' + return $self->_eval_closure( + {}, + '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_inline { - my $attr = (shift)->associated_attribute; + my $self = shift; + my $attr = $self->associated_attribute; my $attr_name = $attr->name; my $meta_instance = $attr->associated_class->instance_metaclass; - my $code = eval 'sub {' + return $self->_eval_closure( + {}, + '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_inline { - my $attr = (shift)->associated_attribute; + my $self = shift; + my $attr = $self->associated_attribute; my $attr_name = $attr->name; my $meta_instance = $attr->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 predicate because : $@" if $@; - - return $code; + return $self->_eval_closure( + {}, + 'sub {' + . $meta_instance->inline_is_slot_initialized('$_[0]', "'$attr_name'") + . '}' + ); } sub generate_clearer_method_inline { - my $attr = (shift)->associated_attribute; + my $self = shift; + my $attr = $self->associated_attribute; my $attr_name = $attr->name; my $meta_instance = $attr->associated_class->instance_metaclass; - my $code = eval 'sub {' + return $self->_eval_closure( + {}, + 'sub {' . $meta_instance->inline_deinitialize_slot('$_[0]', "'$attr_name'") - . '}'; - confess "Could not generate inline clearer because : $@" if $@; - - return $code; + . '}' + ); } 1; @@ -182,7 +192,7 @@ __END__ =pod -=head1 NAME +=head1 NAME Class::MOP::Method::Accessor - Method Meta Object for accessors @@ -195,14 +205,14 @@ Class::MOP::Method::Accessor - Method Meta Object for accessors is_inline => 1, accessor_type => 'reader', ); - - $reader->body->($instance); # call the reader method + + $reader->body->execute($instance); # call the reader method =head1 DESCRIPTION -This is a C subclass which is used interally -by C to generate accessor code. It can -handle generation of readers, writers, predicate and clearer +This is a C subclass which is used interally +by C to generate accessor code. It can +handle generation of readers, writers, predicate and clearer methods, both as closures and as more optimized inline methods. =head1 METHODS @@ -211,20 +221,20 @@ methods, both as closures and as more optimized inline methods. =item B -This creates the method based on the criteria in C<%options>, +This creates the method based on the criteria in C<%options>, these options are: =over 4 =item I -This must be an instance of C which this +This must be an instance of C which this accessor is being generated for. This paramter is B. =item I -This is a string from the following set; reader, writer, accessor, -predicate or clearer. This is used to determine which type of +This is a string from the following set; reader, writer, accessor, +predicate or clearer. This is used to determine which type of method is to be generated. =item I @@ -246,17 +256,17 @@ This returns the boolean which was passed into C. This returns the attribute instance which was passed into C. -=item B +=item B -This will actually generate the method based on the specified +This will actually generate the method based on the specified criteria passed to the constructor. =back =head2 Method Generators -These methods will generate appropriate code references for -the various types of accessors which are supported by +These methods will generate appropriate code references for +the various types of accessors which are supported by C. The names pretty much explain it all. =over 4 @@ -289,12 +299,12 @@ Stevan Little Estevan@iinteractive.comE =head1 COPYRIGHT AND LICENSE -Copyright 2006, 2007 by Infinity Interactive, Inc. +Copyright 2006-2008 by Infinity Interactive, Inc. L This library is free software; you can redistribute it and/or modify -it under the same terms as Perl itself. +it under the same terms as Perl itself. =cut