From: Stevan Little Date: Sun, 15 Oct 2006 19:23:01 +0000 (+0000) Subject: more-method-refactoring X-Git-Tag: 0_36~2^2~4 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=ba38bf08d30369c19a2c25997a0243c0d30be3d5;p=gitmo%2FClass-MOP.git more-method-refactoring --- diff --git a/examples/AttributesWithHistory.pod b/examples/AttributesWithHistory.pod index 3d21281..5e33d0d 100644 --- a/examples/AttributesWithHistory.pod +++ b/examples/AttributesWithHistory.pod @@ -5,7 +5,7 @@ package # hide the package from PAUSE use strict; use warnings; -our $VERSION = '0.04'; +our $VERSION = '0.05'; use base 'Class::MOP::Attribute'; @@ -25,10 +25,30 @@ AttributesWithHistory->meta->add_attribute('_history' => ( default => sub { {} }, )); +sub accessor_metaclass { 'AttributesWithHistory::Method::Accessor' } + +AttributesWithHistory->meta->add_after_method_modifier('install_accessors' => sub { + my ($self) = @_; + # and now add the history accessor + $self->associated_class->add_method( + $self->process_accessors('history_accessor' => $self->history_accessor()) + ) if $self->has_history_accessor(); +}); + +package # hide the package from PAUSE + AttributesWithHistory::Method::Accessor; + +use strict; +use warnings; + +our $VERSION = '0.01'; + +use base 'Class::MOP::Method::Accessor'; + # generate the methods sub generate_history_accessor_method { - my ($self, $attr_name) = @_; + my $attr_name = (shift)->associated_attribute->name; eval qq{sub { unless (ref \$_[0]->meta->get_attribute('$attr_name')->_history()->\{\$_[0]\}) \{ \$_[0]->meta->get_attribute('$attr_name')->_history()->\{\$_[0]\} = []; @@ -38,7 +58,7 @@ sub generate_history_accessor_method { } sub generate_accessor_method { - my ($self, $attr_name) = @_; + my $attr_name = (shift)->associated_attribute->name; eval qq{sub { if (scalar(\@_) == 2) { unless (ref \$_[0]->meta->get_attribute('$attr_name')->_history()->\{\$_[0]\}) \{ @@ -52,7 +72,7 @@ sub generate_accessor_method { } sub generate_writer_method { - my ($self, $attr_name) = @_; + my $attr_name = (shift)->associated_attribute->name; eval qq{sub { unless (ref \$_[0]->meta->get_attribute('$attr_name')->_history()->\{\$_[0]\}) \{ \$_[0]->meta->get_attribute('$attr_name')->_history()->\{\$_[0]\} = []; @@ -60,15 +80,7 @@ sub generate_writer_method { push \@\{\$_[0]->meta->get_attribute('$attr_name')->_history()->\{\$_[0]\}\} => \$_[1]; \$_[0]->{'$attr_name'} = \$_[1]; }}; -} - -AttributesWithHistory->meta->add_after_method_modifier('install_accessors' => sub { - my ($self) = @_; - # and now add the history accessor - $self->associated_class->add_method( - $self->process_accessors('history_accessor' => $self->history_accessor()) - ) if $self->has_history_accessor(); -}); +} 1; diff --git a/examples/InsideOutClass.pod b/examples/InsideOutClass.pod index 1d975f3..e99237e 100644 --- a/examples/InsideOutClass.pod +++ b/examples/InsideOutClass.pod @@ -5,7 +5,7 @@ package # hide the package from PAUSE use strict; use warnings; -our $VERSION = '0.01'; +our $VERSION = '0.02'; use Carp 'confess'; use Scalar::Util 'refaddr'; @@ -28,12 +28,27 @@ sub initialize_instance_slot { $_meta_instance->set_slot_value($instance, $self->name, $val); } +sub accessor_metaclass { 'InsideOutClass::Method::Accessor' } + +package # hide the package from PAUSE + InsideOutClass::Method::Accessor; + +use strict; +use warnings; + +our $VERSION = '0.01'; + +use Carp 'confess'; +use Scalar::Util 'refaddr'; + +use base 'Class::MOP::Method::Accessor'; + ## Method generation helpers sub generate_accessor_method { - my $self = shift; - my $meta_class = $self->associated_class; - my $attr_name = $self->name; + my $attr = (shift)->associated_attribute; + my $meta_class = $attr->associated_class; + my $attr_name = $attr->name; return sub { my $meta_instance = $meta_class->get_meta_instance; $meta_instance->set_slot_value($_[0], $attr_name, $_[1]) if scalar(@_) == 2; @@ -42,9 +57,9 @@ sub generate_accessor_method { } sub generate_reader_method { - my $self = shift; - my $meta_class = $self->associated_class; - my $attr_name = $self->name; + my $attr = (shift)->associated_attribute; + my $meta_class = $attr->associated_class; + my $attr_name = $attr->name; return sub { confess "Cannot assign a value to a read-only accessor" if @_ > 1; $meta_class->get_meta_instance @@ -53,9 +68,9 @@ sub generate_reader_method { } sub generate_writer_method { - my $self = shift; - my $meta_class = $self->associated_class; - my $attr_name = $self->name; + my $attr = (shift)->associated_attribute; + my $meta_class = $attr->associated_class; + my $attr_name = $attr->name; return sub { $meta_class->get_meta_instance ->set_slot_value($_[0], $attr_name, $_[1]); @@ -63,9 +78,9 @@ sub generate_writer_method { } sub generate_predicate_method { - my $self = shift; - my $meta_class = $self->associated_class; - my $attr_name = $self->name; + my $attr = (shift)->associated_attribute; + my $meta_class = $attr->associated_class; + my $attr_name = $attr->name; return sub { defined $meta_class->get_meta_instance ->get_slot_value($_[0], $attr_name) ? 1 : 0; diff --git a/examples/LazyClass.pod b/examples/LazyClass.pod index d884096..7c9d00a 100644 --- a/examples/LazyClass.pod +++ b/examples/LazyClass.pod @@ -7,7 +7,7 @@ use warnings; use Carp 'confess'; -our $VERSION = '0.04'; +our $VERSION = '0.05'; use base 'Class::MOP::Attribute'; @@ -24,8 +24,22 @@ sub initialize_instance_slot { } } +sub accessor_metaclass { 'LazyClass::Method::Accessor' } + +package # hide the package from PAUSE + LazyClass::Method::Accessor; + +use strict; +use warnings; + +use Carp 'confess'; + +our $VERSION = '0.01'; + +use base 'Class::MOP::Method::Accessor'; + sub generate_accessor_method { - my $attr = shift; + my $attr = (shift)->associated_attribute; my $attr_name = $attr->name; my $meta_instance = $attr->associated_class->get_meta_instance; @@ -46,7 +60,7 @@ sub generate_accessor_method { } sub generate_reader_method { - my $attr = shift; + my $attr = (shift)->associated_attribute; my $attr_name = $attr->name; my $meta_instance = $attr->associated_class->get_meta_instance; @@ -63,8 +77,6 @@ sub generate_reader_method { }; } - - package # hide the package from PAUSE LazyClass::Instance; diff --git a/lib/Class/MOP.pm b/lib/Class/MOP.pm index 05d08dd..0c7d0c9 100644 --- a/lib/Class/MOP.pm +++ b/lib/Class/MOP.pm @@ -405,7 +405,7 @@ $_->meta->make_immutable( Class::MOP::Object - Class::MOP::Attribute::Accessor + Class::MOP::Method::Accessor Class::MOP::Method::Wrapped /; diff --git a/lib/Class/MOP/Attribute.pm b/lib/Class/MOP/Attribute.pm index c14eca3..6f13f38 100644 --- a/lib/Class/MOP/Attribute.pm +++ b/lib/Class/MOP/Attribute.pm @@ -4,6 +4,8 @@ package Class::MOP::Attribute; use strict; use warnings; +use Class::MOP::Method::Accessor; + use Carp 'confess'; use Scalar::Util 'blessed', 'reftype', 'weaken'; @@ -162,117 +164,9 @@ sub get_value { ->get_slot_value($instance, $self->name); } -## Method generation helpers - -sub generate_accessor_method { - my $attr = shift; - return sub { - $attr->set_value($_[0], $_[1]) if scalar(@_) == 2; - $attr->get_value($_[0]); - }; -} - -sub generate_accessor_method_inline { - my $self = shift; - my $attr_name = $self->name; - my $meta_instance = $self->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; -} - -sub generate_reader_method { - my $attr = shift; - return sub { - confess "Cannot assign a value to a read-only accessor" if @_ > 1; - $attr->get_value($_[0]); - }; -} - -sub generate_reader_method_inline { - my $self = shift; - my $attr_name = $self->name; - my $meta_instance = $self->associated_class->instance_metaclass; - - my $code = eval '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 { - my $attr = shift; - return sub { - $attr->set_value($_[0], $_[1]); - }; -} - -sub generate_writer_method_inline { - my $self = shift; - my $attr_name = $self->name; - my $meta_instance = $self->associated_class->instance_metaclass; - - my $code = eval '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 { - my $self = shift; - my $attr_name = $self->name; - return sub { - defined Class::MOP::Class->initialize(Scalar::Util::blessed($_[0])) - ->get_meta_instance - ->get_slot_value($_[0], $attr_name) ? 1 : 0; - }; -} - -sub generate_clearer_method { - my $self = shift; - my $attr_name = $self->name; - return sub { - Class::MOP::Class->initialize(Scalar::Util::blessed($_[0])) - ->get_meta_instance - ->deinitialize_slot($_[0], $attr_name); - }; -} - -sub generate_predicate_method_inline { - my $self = shift; - my $attr_name = $self->name; - my $meta_instance = $self->associated_class->instance_metaclass; +## load em up ... - 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; -} - -sub generate_clearer_method_inline { - my $self = shift; - my $attr_name = $self->name; - my $meta_instance = $self->associated_class->instance_metaclass; - - my $code = eval 'sub {' - . $meta_instance->inline_deinitialize_slot('$_[0]', "'$attr_name'") - . '}'; - confess "Could not generate inline clearer because : $@" if $@; - - return $code; -} +sub accessor_metaclass { 'Class::MOP::Method::Accessor' } sub process_accessors { my ($self, $type, $accessor, $generate_as_inline_methods) = @_; @@ -280,17 +174,20 @@ sub process_accessors { (reftype($accessor) eq 'HASH') || confess "bad accessor/reader/writer/predicate/clearer format, must be a HASH ref"; my ($name, $method) = %{$accessor}; - return ($name, Class::MOP::Attribute::Accessor->wrap($method)); + return ($name, $self->accessor_metaclass->wrap($method)); } else { - my $inline_me = ($generate_as_inline_methods && $self->associated_class->instance_metaclass->is_inlinable); - my $generator = $self->can('generate_' . $type . '_method' . ($inline_me ? '_inline' : '')); - ($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 : $@"; + my $inline_me = ($generate_as_inline_methods && $self->associated_class->instance_metaclass->is_inlinable); + my $method; + eval { + $method = $self->accessor_metaclass->new( + attribute => $self, + as_inline => $inline_me, + accessor_type => $type, + ); + }; + confess "Could not create the '$type' method for " . $self->name . " because : $@" if $@; + return ($accessor, $method); } } @@ -330,7 +227,7 @@ sub install_accessors { } my $method = $class->get_method($accessor); $class->remove_method($accessor) - if (blessed($method) && $method->isa('Class::MOP::Attribute::Accessor')); + if (blessed($method) && $method->isa('Class::MOP::Method::Accessor')); }; sub remove_accessors { @@ -345,18 +242,6 @@ sub install_accessors { } -package Class::MOP::Attribute::Accessor; - -use strict; -use warnings; - -use Class::MOP::Method; - -our $VERSION = '0.02'; -our $AUTHORITY = 'cpan:STEVAN'; - -use base 'Class::MOP::Method'; - 1; __END__ @@ -624,6 +509,8 @@ These are all basic predicate methods for the values passed into C. =over 4 +=item B + =item B This allows the attribute to generate and install code for it's own @@ -641,34 +528,6 @@ 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 - -=item B - -=back - -=over 4 - -=item B - -=item B - -=item B - -=item B - -=item B - -=back - =item B This allows the attribute to remove the method for it's own diff --git a/lib/Class/MOP/Class.pm b/lib/Class/MOP/Class.pm index 425364b..30760be 100644 --- a/lib/Class/MOP/Class.pm +++ b/lib/Class/MOP/Class.pm @@ -4,6 +4,9 @@ package Class::MOP::Class; use strict; use warnings; +use Class::MOP::Instance; +use Class::MOP::Method::Wrapped; + use Carp 'confess'; use Scalar::Util 'blessed', 'reftype', 'weaken'; use Sub::Name 'subname'; @@ -14,8 +17,6 @@ our $AUTHORITY = 'cpan:STEVAN'; use base 'Class::MOP::Module'; -use Class::MOP::Instance; - # Self-introspection sub meta { Class::MOP::Class->initialize(blessed($_[0]) || $_[0]) } diff --git a/lib/Class/MOP/Method.pm b/lib/Class/MOP/Method.pm index 06123a6..247b333 100644 --- a/lib/Class/MOP/Method.pm +++ b/lib/Class/MOP/Method.pm @@ -70,142 +70,6 @@ sub fully_qualified_name { $code->package_name . '::' . $code->name; } -package Class::MOP::Method::Wrapped; - -use strict; -use warnings; - -use Carp 'confess'; -use Scalar::Util 'reftype', 'blessed'; -use Sub::Name 'subname'; - -our $VERSION = '0.02'; -our $AUTHORITY = 'cpan:STEVAN'; - -use base 'Class::MOP::Method'; - -# NOTE: -# this ugly beast is the result of trying -# to micro optimize this as much as possible -# while not completely loosing maintainability. -# At this point it's "fast enough", after all -# you can't get something for nothing :) -my $_build_wrapped_method = sub { - my $modifier_table = shift; - my ($before, $after, $around) = ( - $modifier_table->{before}, - $modifier_table->{after}, - $modifier_table->{around}, - ); - if (@$before && @$after) { - $modifier_table->{cache} = sub { - $_->(@_) for @{$before}; - my @rval; - ((defined wantarray) ? - ((wantarray) ? - (@rval = $around->{cache}->(@_)) - : - ($rval[0] = $around->{cache}->(@_))) - : - $around->{cache}->(@_)); - $_->(@_) for @{$after}; - return unless defined wantarray; - return wantarray ? @rval : $rval[0]; - } - } - elsif (@$before && !@$after) { - $modifier_table->{cache} = sub { - $_->(@_) for @{$before}; - return $around->{cache}->(@_); - } - } - elsif (@$after && !@$before) { - $modifier_table->{cache} = sub { - my @rval; - ((defined wantarray) ? - ((wantarray) ? - (@rval = $around->{cache}->(@_)) - : - ($rval[0] = $around->{cache}->(@_))) - : - $around->{cache}->(@_)); - $_->(@_) for @{$after}; - return unless defined wantarray; - return wantarray ? @rval : $rval[0]; - } - } - else { - $modifier_table->{cache} = $around->{cache}; - } -}; - -sub wrap { - my $class = shift; - my $code = shift; - (blessed($code) && $code->isa('Class::MOP::Method')) - || confess "Can only wrap blessed CODE"; - my $modifier_table = { - cache => undef, - orig => $code, - before => [], - after => [], - around => { - cache => $code->body, - methods => [], - }, - }; - $_build_wrapped_method->($modifier_table); - my $method = $class->SUPER::wrap(sub { $modifier_table->{cache}->(@_) }); - $method->{modifier_table} = $modifier_table; - $method; -} - -sub get_original_method { - my $code = shift; - $code->{modifier_table}->{orig}; -} - -sub add_before_modifier { - my $code = shift; - my $modifier = shift; - unshift @{$code->{modifier_table}->{before}} => $modifier; - $_build_wrapped_method->($code->{modifier_table}); -} - -sub add_after_modifier { - my $code = shift; - my $modifier = shift; - push @{$code->{modifier_table}->{after}} => $modifier; - $_build_wrapped_method->($code->{modifier_table}); -} - -{ - # NOTE: - # this is another possible canidate for - # optimization as well. There is an overhead - # associated with the currying that, if - # eliminated might make around modifiers - # more manageable. - my $compile_around_method = sub {{ - my $f1 = pop; - return $f1 unless @_; - my $f2 = pop; - push @_, sub { $f2->( $f1, @_ ) }; - redo; - }}; - - sub add_around_modifier { - my $code = shift; - my $modifier = shift; - unshift @{$code->{modifier_table}->{around}->{methods}} => $modifier; - $code->{modifier_table}->{around}->{cache} = $compile_around_method->( - @{$code->{modifier_table}->{around}->{methods}}, - $code->{modifier_table}->{orig}->body - ); - $_build_wrapped_method->($code->{modifier_table}); - } -} - 1; __END__ @@ -226,9 +90,6 @@ The Method Protocol is very small, since methods in Perl 5 are just subroutines within the particular package. We provide a very basic introspection interface. -This also contains the Class::MOP::Method::Wrapped subclass, which -provides the features for before, after and around method modifiers. - =head1 METHODS =head2 Introspection @@ -264,30 +125,6 @@ to this class. =back -=head1 Class::MOP::Method::Wrapped METHODS - -=head2 Construction - -=over 4 - -=item B - -=item B - -=back - -=head2 Modifiers - -=over 4 - -=item B - -=item B - -=item B - -=back - =head1 AUTHORS Stevan Little Estevan@iinteractive.comE diff --git a/lib/Class/MOP/Method/Accessor.pm b/lib/Class/MOP/Method/Accessor.pm new file mode 100644 index 0000000..9264eda --- /dev/null +++ b/lib/Class/MOP/Method/Accessor.pm @@ -0,0 +1,268 @@ + +package Class::MOP::Method::Accessor; + +use strict; +use warnings; + +use Carp 'confess'; +use Scalar::Util 'blessed', 'weaken'; + +our $VERSION = '0.02'; +our $AUTHORITY = 'cpan:STEVAN'; + +use base 'Class::MOP::Method'; + +=pod + +So, the idea here is that we have an accessor class +which takes a weak-link to the attribute and can +generate the actual code ref needed. This might allow +for more varied approaches. + +And if the attribute type can also declare what +kind of accessor method metaclass it uses, then +this relationship can be handled by delegation. + +=cut + +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"; + + (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}, + as_inline => ($options{as_inline} || 0), + accessor_type => $options{accessor_type}, + } => $class; + + # we don't want this creating + # a cycle in the code, if not + # needed + weaken($self->{attribute}); + + $self->intialize_body; + + return $self; +} + +## accessors + +sub associated_attribute { (shift)->{attribute} } +sub accessor_type { (shift)->{accessor_type} } +sub as_inline { (shift)->{as_inline} } + +## factory + +sub intialize_body { + my $self = shift; + + my $method_name = join "_" => ( + 'generate', + $self->accessor_type, + 'method', + ($self->as_inline ? 'inline' : ()) + ); + + eval { + $self->{body} = $self->$method_name(); + }; + die $@ if $@; +} + +## 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_reader_method { + 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; + return sub { + $attr->set_value($_[0], $_[1]); + }; +} + +sub generate_predicate_method { + my $attr = (shift)->associated_attribute; + my $attr_name = $attr->name; + return sub { + defined Class::MOP::Class->initialize(Scalar::Util::blessed($_[0])) + ->get_meta_instance + ->get_slot_value($_[0], $attr_name) ? 1 : 0; + }; +} + +sub generate_clearer_method { + my $attr = (shift)->associated_attribute; + my $attr_name = $attr->name; + return sub { + Class::MOP::Class->initialize(Scalar::Util::blessed($_[0])) + ->get_meta_instance + ->deinitialize_slot($_[0], $attr_name); + }; +} + +## Inline methods + + +sub generate_accessor_method_inline { + my $attr = (shift)->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; +} + +sub generate_reader_method_inline { + my $attr = (shift)->associated_attribute; + my $attr_name = $attr->name; + my $meta_instance = $attr->associated_class->instance_metaclass; + + my $code = eval '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 $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]') + . '}'; + confess "Could not generate inline accessor because : $@" if $@; + + return $code; +} + + +sub generate_predicate_method_inline { + my $attr = (shift)->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; +} + +sub generate_clearer_method_inline { + my $attr = (shift)->associated_attribute; + my $attr_name = $attr->name; + my $meta_instance = $attr->associated_class->instance_metaclass; + + my $code = eval 'sub {' + . $meta_instance->inline_deinitialize_slot('$_[0]', "'$attr_name'") + . '}'; + confess "Could not generate inline clearer because : $@" if $@; + + return $code; +} + +1; + +__END__ + +=pod + +=head1 NAME + +Class::MOP::Method::Accessor - Method Meta Object for accessors + +=head1 SYNOPSIS + + # ... more to come later maybe + +=head1 DESCRIPTION + +=head1 METHODS + +=over 4 + +=item B + +=item B + +=item B + +=item B + +=item B + +=item B + +=item B + +=item B + +=item B + +=item B + +=item B + +=item B + +=item B + +=item B + +=item B + +=back + +=head1 AUTHORS + +Stevan Little Estevan@iinteractive.comE + +Yuval Kogman Enothingmuch@woobling.comE + +=head1 COPYRIGHT AND LICENSE + +Copyright 2006 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. + +=cut + diff --git a/lib/Class/MOP/Method/Wrapped.pm b/lib/Class/MOP/Method/Wrapped.pm new file mode 100644 index 0000000..0aa4a3b --- /dev/null +++ b/lib/Class/MOP/Method/Wrapped.pm @@ -0,0 +1,194 @@ + +package Class::MOP::Method::Wrapped; + +use strict; +use warnings; + +use Carp 'confess'; +use Scalar::Util 'reftype', 'blessed'; +use Sub::Name 'subname'; + +our $VERSION = '0.02'; +our $AUTHORITY = 'cpan:STEVAN'; + +use base 'Class::MOP::Method'; + +# NOTE: +# this ugly beast is the result of trying +# to micro optimize this as much as possible +# while not completely loosing maintainability. +# At this point it's "fast enough", after all +# you can't get something for nothing :) +my $_build_wrapped_method = sub { + my $modifier_table = shift; + my ($before, $after, $around) = ( + $modifier_table->{before}, + $modifier_table->{after}, + $modifier_table->{around}, + ); + if (@$before && @$after) { + $modifier_table->{cache} = sub { + $_->(@_) for @{$before}; + my @rval; + ((defined wantarray) ? + ((wantarray) ? + (@rval = $around->{cache}->(@_)) + : + ($rval[0] = $around->{cache}->(@_))) + : + $around->{cache}->(@_)); + $_->(@_) for @{$after}; + return unless defined wantarray; + return wantarray ? @rval : $rval[0]; + } + } + elsif (@$before && !@$after) { + $modifier_table->{cache} = sub { + $_->(@_) for @{$before}; + return $around->{cache}->(@_); + } + } + elsif (@$after && !@$before) { + $modifier_table->{cache} = sub { + my @rval; + ((defined wantarray) ? + ((wantarray) ? + (@rval = $around->{cache}->(@_)) + : + ($rval[0] = $around->{cache}->(@_))) + : + $around->{cache}->(@_)); + $_->(@_) for @{$after}; + return unless defined wantarray; + return wantarray ? @rval : $rval[0]; + } + } + else { + $modifier_table->{cache} = $around->{cache}; + } +}; + +sub wrap { + my $class = shift; + my $code = shift; + (blessed($code) && $code->isa('Class::MOP::Method')) + || confess "Can only wrap blessed CODE"; + my $modifier_table = { + cache => undef, + orig => $code, + before => [], + after => [], + around => { + cache => $code->body, + methods => [], + }, + }; + $_build_wrapped_method->($modifier_table); + my $method = $class->SUPER::wrap(sub { $modifier_table->{cache}->(@_) }); + $method->{modifier_table} = $modifier_table; + $method; +} + +sub get_original_method { + my $code = shift; + $code->{modifier_table}->{orig}; +} + +sub add_before_modifier { + my $code = shift; + my $modifier = shift; + unshift @{$code->{modifier_table}->{before}} => $modifier; + $_build_wrapped_method->($code->{modifier_table}); +} + +sub add_after_modifier { + my $code = shift; + my $modifier = shift; + push @{$code->{modifier_table}->{after}} => $modifier; + $_build_wrapped_method->($code->{modifier_table}); +} + +{ + # NOTE: + # this is another possible canidate for + # optimization as well. There is an overhead + # associated with the currying that, if + # eliminated might make around modifiers + # more manageable. + my $compile_around_method = sub {{ + my $f1 = pop; + return $f1 unless @_; + my $f2 = pop; + push @_, sub { $f2->( $f1, @_ ) }; + redo; + }}; + + sub add_around_modifier { + my $code = shift; + my $modifier = shift; + unshift @{$code->{modifier_table}->{around}->{methods}} => $modifier; + $code->{modifier_table}->{around}->{cache} = $compile_around_method->( + @{$code->{modifier_table}->{around}->{methods}}, + $code->{modifier_table}->{orig}->body + ); + $_build_wrapped_method->($code->{modifier_table}); + } +} + +1; + +__END__ + +=pod + +=head1 NAME + +Class::MOP::Method::Wrapped - Method Meta Object to handle before/around/after modifiers + +=head1 SYNOPSIS + + # ... more to come later maybe + +=head1 DESCRIPTION + +=head1 METHODS + +=head2 Construction + +=over 4 + +=item B + +=item B + +=back + +=head2 Modifiers + +=over 4 + +=item B + +=item B + +=item B + +=back + +=head1 AUTHORS + +Stevan Little Estevan@iinteractive.comE + +Yuval Kogman Enothingmuch@woobling.comE + +=head1 COPYRIGHT AND LICENSE + +Copyright 2006 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. + +=cut + diff --git a/t/000_load.t b/t/000_load.t index 40d59ff..cb43aef 100644 --- a/t/000_load.t +++ b/t/000_load.t @@ -18,7 +18,7 @@ BEGIN { my %METAS = ( 'Class::MOP::Attribute' => Class::MOP::Attribute->meta, - 'Class::MOP::Attribute::Accessor' => Class::MOP::Attribute::Accessor->meta, + 'Class::MOP::Method::Accessor' => Class::MOP::Method::Accessor->meta, 'Class::MOP::Package' => Class::MOP::Package->meta, 'Class::MOP::Module' => Class::MOP::Module->meta, 'Class::MOP::Class' => Class::MOP::Class->meta, @@ -38,11 +38,11 @@ is_deeply( is_deeply( [ sort { $a->name cmp $b->name } Class::MOP::get_all_metaclass_instances ], [ - Class::MOP::Attribute->meta, - Class::MOP::Attribute::Accessor->meta, + Class::MOP::Attribute->meta, Class::MOP::Class->meta, Class::MOP::Instance->meta, Class::MOP::Method->meta, + Class::MOP::Method::Accessor->meta, Class::MOP::Method::Wrapped->meta, Class::MOP::Module->meta, Class::MOP::Object->meta, @@ -53,11 +53,11 @@ is_deeply( is_deeply( [ sort { $a cmp $b } Class::MOP::get_all_metaclass_names() ], [ qw/ - Class::MOP::Attribute - Class::MOP::Attribute::Accessor + Class::MOP::Attribute Class::MOP::Class Class::MOP::Instance Class::MOP::Method + Class::MOP::Method::Accessor Class::MOP::Method::Wrapped Class::MOP::Module Class::MOP::Object @@ -69,10 +69,10 @@ is_deeply( [ map { $_->meta->identifier } sort { $a cmp $b } Class::MOP::get_all_metaclass_names() ], [ "Class::MOP::Attribute-" . $Class::MOP::Attribute::VERSION . "-cpan:STEVAN", - "Class::MOP::Attribute::Accessor-" . $Class::MOP::Attribute::Accessor::VERSION . "-cpan:STEVAN", "Class::MOP::Class-" . $Class::MOP::Class::VERSION . "-cpan:STEVAN", "Class::MOP::Instance-" . $Class::MOP::Instance::VERSION . "-cpan:STEVAN", "Class::MOP::Method-" . $Class::MOP::Method::VERSION . "-cpan:STEVAN", + "Class::MOP::Method::Accessor-" . $Class::MOP::Method::Accessor::VERSION . "-cpan:STEVAN", "Class::MOP::Method::Wrapped-" . $Class::MOP::Method::Wrapped::VERSION . "-cpan:STEVAN", "Class::MOP::Module-" . $Class::MOP::Module::VERSION . "-cpan:STEVAN", "Class::MOP::Object-" . $Class::MOP::Object::VERSION . "-cpan:STEVAN", diff --git a/t/005_attributes.t b/t/005_attributes.t index 63158f1..73bda5b 100644 --- a/t/005_attributes.t +++ b/t/005_attributes.t @@ -54,7 +54,7 @@ my $BAR_ATTR_2 = Class::MOP::Attribute->new('$bar'); ::is($meta->get_attribute('$bar'), $BAR_ATTR, '... got the right attribute back for Bar'); ::ok($meta->has_method('bar'), '... an accessor has been created'); - ::isa_ok($meta->get_method('bar'), 'Class::MOP::Attribute::Accessor'); + ::isa_ok($meta->get_method('bar'), 'Class::MOP::Method::Accessor'); } { package Baz; @@ -70,8 +70,8 @@ my $BAR_ATTR_2 = Class::MOP::Attribute->new('$bar'); ::ok($meta->has_method('get_baz'), '... a reader has been created'); ::ok($meta->has_method('set_baz'), '... a writer has been created'); - ::isa_ok($meta->get_method('get_baz'), 'Class::MOP::Attribute::Accessor'); - ::isa_ok($meta->get_method('set_baz'), 'Class::MOP::Attribute::Accessor'); + ::isa_ok($meta->get_method('get_baz'), 'Class::MOP::Method::Accessor'); + ::isa_ok($meta->get_method('set_baz'), 'Class::MOP::Method::Accessor'); } { diff --git a/t/014_attribute_introspection.t b/t/014_attribute_introspection.t index a85e087..e33edf6 100644 --- a/t/014_attribute_introspection.t +++ b/t/014_attribute_introspection.t @@ -3,7 +3,7 @@ use strict; use warnings; -use Test::More tests => 53; +use Test::More tests => 44; use Test::Exception; BEGIN { @@ -39,19 +39,9 @@ BEGIN { set_value associated_class - attach_to_class detach_from_class + attach_to_class detach_from_class - generate_accessor_method - generate_reader_method - generate_writer_method - generate_predicate_method - generate_clearer_method - - generate_accessor_method_inline - generate_reader_method_inline - generate_writer_method_inline - generate_predicate_method_inline - generate_clearer_method_inline + accessor_metaclass process_accessors install_accessors diff --git a/t/050_scala_style_mixin_composition.t b/t/050_scala_style_mixin_composition.t index 290747c..fca7310 100644 --- a/t/050_scala_style_mixin_composition.t +++ b/t/050_scala_style_mixin_composition.t @@ -86,7 +86,7 @@ sub ::with ($) { my $method = $mixin->get_method($_); # we want to ignore accessors since # they will be created with the attrs - (blessed($method) && $method->isa('Class::MOP::Attribute::Accessor')) + (blessed($method) && $method->isa('Class::MOP::Method::Accessor')) ? () : ($_ => $method) } $mixin->get_method_list;