X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FClass%2FMOP%2FMethod%2FAccessor.pm;h=c52a642419501cd5246c450ffe56448603f705ce;hb=753d754623cec6cb64d707fe5f993cef7d535788;hp=15d1168a32edc6327de50d661dd232b301ccb6ca;hpb=eca95e0476ae5a66144c4fd1f4a23c2ba4bdbf26;p=gitmo%2FClass-MOP.git diff --git a/lib/Class/MOP/Method/Accessor.pm b/lib/Class/MOP/Method/Accessor.pm index 15d1168..c52a642 100644 --- a/lib/Class/MOP/Method/Accessor.pm +++ b/lib/Class/MOP/Method/Accessor.pm @@ -6,8 +6,9 @@ use warnings; use Carp 'confess'; use Scalar::Util 'blessed', 'weaken'; +use Try::Tiny; -our $VERSION = '0.78'; +our $VERSION = '1.11'; $VERSION = eval $VERSION; our $AUTHORITY = 'cpan:STEVAN'; @@ -36,18 +37,35 @@ sub new { # needed weaken($self->{'attribute'}); - $self->initialize_body; + $self->_initialize_body; return $self; } sub _new { my $class = shift; - my $options = @_ == 1 ? $_[0] : {@_}; - $options->{is_inline} ||= 0; + return Class::MOP::Class->initialize($class)->new_object(@_) + if $class ne __PACKAGE__; - return bless $options, $class; + my $params = @_ == 1 ? $_[0] : {@_}; + + return bless { + # inherited from Class::MOP::Method + body => $params->{body}, + associated_metaclass => $params->{associated_metaclass}, + package_name => $params->{package_name}, + name => $params->{name}, + original_method => $params->{original_method}, + + # inherit from Class::MOP::Generated + is_inline => $params->{is_inline} || 0, + definition_context => $params->{definition_context}, + + # defined in this class + attribute => $params->{attribute}, + accessor_type => $params->{accessor_type}, + } => $class; } ## accessors @@ -57,149 +75,164 @@ sub accessor_type { (shift)->{'accessor_type'} } ## factory -sub initialize_body { +sub _initialize_body { my $self = shift; my $method_name = join "_" => ( - 'generate', + '_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; - return sub { - $attr->set_value($_[0], $_[1]) if scalar(@_) == 2; - $attr->get_value($_[0]); - }; -} +sub _generate_accessor_method { + my $self = shift; + my $attr = $self->associated_attribute; -sub generate_reader_method { - my $attr = (shift)->associated_attribute; return sub { - confess "Cannot assign a value to a read-only accessor" if @_ > 1; + if (@_ >= 2) { + $attr->set_value($_[0], $_[1]); + } $attr->get_value($_[0]); }; } -sub generate_writer_method { - my $attr = (shift)->associated_attribute; - return sub { - $attr->set_value($_[0], $_[1]); +sub _generate_accessor_method_inline { + my $self = shift; + my $attr = $self->associated_attribute; + + return try { + $self->_compile_code([ + 'sub {', + 'if (@_ > 1) {', + $attr->_inline_set_value('$_[0]', '$_[1]'), + '}', + $attr->_inline_get_value('$_[0]'), + '}', + ]); + } + catch { + confess "Could not generate inline accessor because : $_"; }; } -sub generate_predicate_method { - my $attr = (shift)->associated_attribute; +sub _generate_reader_method { + my $self = shift; + my $attr = $self->associated_attribute; + return sub { - $attr->has_value($_[0]) + confess "Cannot assign a value to a read-only accessor" + if @_ > 1; + $attr->get_value($_[0]); }; } -sub generate_clearer_method { - my $attr = (shift)->associated_attribute; - return sub { - $attr->clear_value($_[0]) +sub _generate_reader_method_inline { + my $self = shift; + my $attr = $self->associated_attribute; + + return try { + $self->_compile_code([ + 'sub {', + 'if (@_ > 1) {', + # XXX: this is a hack, but our error stuff is terrible + $self->_inline_throw_error( + '"Cannot assign a value to a read-only accessor"', + 'data => \@_' + ) . ';', + '}', + $attr->_inline_get_value('$_[0]'), + '}', + ]); + } + catch { + confess "Could not generate inline reader because : $_"; }; } -## Inline methods - - -sub generate_accessor_method_inline { - my $self = shift; - my $attr = $self->associated_attribute; - my $attr_name = $attr->name; - my $meta_instance = $attr->associated_class->instance_metaclass; +sub _inline_throw_error { + my $self = shift; + return 'confess ' . $_[0]; +} - my $code = $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) - . '}' - ); - confess "Could not generate inline accessor because : $@" if $@; +sub _generate_writer_method { + my $self = shift; + my $attr = $self->associated_attribute; - return $code; + return sub { + $attr->set_value($_[0], $_[1]); + }; } -sub generate_reader_method_inline { - my $self = shift; - my $attr = $self->associated_attribute; - my $attr_name = $attr->name; - my $meta_instance = $attr->associated_class->instance_metaclass; - - my $code = $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 reader because : $@" if $@; - - return $code; +sub _generate_writer_method_inline { + my $self = shift; + my $attr = $self->associated_attribute; + + return try { + $self->_compile_code([ + 'sub {', + $attr->_inline_set_value('$_[0]', '$_[1]'), + '}', + ]); + } + catch { + confess "Could not generate inline writer because : $_"; + }; } -sub generate_writer_method_inline { - my $self = shift; - my $attr = $self->associated_attribute; - my $attr_name = $attr->name; - my $meta_instance = $attr->associated_class->instance_metaclass; - - my $code = $self->_eval_closure( - {}, - 'sub {' - . $meta_instance->inline_set_slot_value('$_[0]', $attr_name, '$_[1]') - . '}' - ); - confess "Could not generate inline writer because : $@" if $@; +sub _generate_predicate_method { + my $self = shift; + my $attr = $self->associated_attribute; - return $code; + return sub { + $attr->has_value($_[0]) + }; } +sub _generate_predicate_method_inline { + my $self = shift; + my $attr = $self->associated_attribute; + + return try { + $self->_compile_code([ + 'sub {', + $attr->_inline_has_value('$_[0]'), + '}', + ]); + } + catch { + confess "Could not generate inline predicate because : $_"; + }; +} -sub generate_predicate_method_inline { - my $self = shift; - my $attr = $self->associated_attribute; - my $attr_name = $attr->name; - my $meta_instance = $attr->associated_class->instance_metaclass; - - my $code = $self->_eval_closure( - {}, - 'sub {' - . $meta_instance->inline_is_slot_initialized('$_[0]', $attr_name) - . '}' - ); - confess "Could not generate inline predicate because : $@" if $@; +sub _generate_clearer_method { + my $self = shift; + my $attr = $self->associated_attribute; - return $code; + return sub { + $attr->clear_value($_[0]) + }; } -sub generate_clearer_method_inline { - my $self = shift; - my $attr = $self->associated_attribute; - my $attr_name = $attr->name; - my $meta_instance = $attr->associated_class->instance_metaclass; - - my $code = $self->_eval_closure( - {}, - 'sub {' - . $meta_instance->inline_deinitialize_slot('$_[0]', $attr_name) - . '}' - ); - confess "Could not generate inline clearer because : $@" if $@; - - return $code; +sub _generate_clearer_method_inline { + my $self = shift; + my $attr = $self->associated_attribute; + + return try { + $self->_compile_code([ + 'sub {', + $attr->_inline_clear_value('$_[0]'), + '}', + ]); + } + catch { + confess "Could not generate inline clearer because : $_"; + }; } 1; @@ -226,86 +259,66 @@ Class::MOP::Method::Accessor - Method Meta Object for accessors =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 -methods, both as closures and as more optimized inline methods. +This is a subclass of C which is used by +C to generate accessor code. It handles +generation of readers, writers, predicates and clearers. For each type +of method, it can either create a subroutine reference, or actually +inline code by generating a string and C'ing it. =head1 METHODS =over 4 -=item B +=item B<< Class::MOP::Method::Accessor->new(%options) >> -This creates the method based on the criteria in C<%options>, -these options are: +This returns a new C based on the +C<%options> provided. =over 4 -=item I - -This must be an instance of C which this -accessor is being generated for. This paramter is B. +=item * attribute -=item I +This is the C for which accessors are being +generated. This option is required. -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 - -This is a boolean to indicate if the method should be generated -as a closure, or as a more optimized inline version. - -=back +=item * accessor_type -=item B +This is a string which should be one of "reader", "writer", +"accessor", "predicate", or "clearer". This is the type of method +being generated. This option is required. -This returns the accessor type which was passed into C. +=item * is_inline -=item B +This indicates whether or not the accessor should be inlined. This +defaults to false. -This returns the boolean which was passed into C. +=item * name -=item B +The method name (without a package name). This is required. -This returns the attribute instance which was passed into C. +=item * package_name -=item B - -This will actually generate the method based on the specified -criteria passed to the constructor. +The package name for the method. This is required. =back -=head2 Method Generators - -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 - -=item B - -=item B - -=item B +=item B<< $metamethod->accessor_type >> -=item B +Returns the accessor type which was passed to C. -=item B +=item B<< $metamethod->is_inline >> -=item B +Returns a boolean indicating whether or not the accessor is inlined. -=item B +=item B<< $metamethod->associated_attribute >> -=item B +This returns the L object which was passed to +C. -=item B +=item B<< $metamethod->body >> -=item B +The method itself is I when the accessor object is +constructed. =back @@ -315,7 +328,7 @@ Stevan Little Estevan@iinteractive.comE =head1 COPYRIGHT AND LICENSE -Copyright 2006-2008 by Infinity Interactive, Inc. +Copyright 2006-2010 by Infinity Interactive, Inc. L