X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FMoose%2FMeta%2FMethod%2FDelegation.pm;h=de6a62acd83423ffd8af22c5bc77f78f9e0a1588;hb=3eb89f709f04907580b508f821d6be2316fcb65f;hp=49449ce0f5ac2e990481c05290338bdaeeb631f8;hpb=01cd78f8093d58c0a9c8633ba0361a3340426e30;p=gitmo%2FMoose.git diff --git a/lib/Moose/Meta/Method/Delegation.pm b/lib/Moose/Meta/Method/Delegation.pm index 49449ce..de6a62a 100644 --- a/lib/Moose/Meta/Method/Delegation.pm +++ b/lib/Moose/Meta/Method/Delegation.pm @@ -7,29 +7,47 @@ use warnings; use Carp 'confess'; use Scalar::Util 'blessed', 'weaken'; -our $VERSION = '0.57'; +our $VERSION = '1.01'; $VERSION = eval $VERSION; our $AUTHORITY = 'cpan:STEVAN'; -use base 'Moose::Meta::Method'; +use base 'Moose::Meta::Method', + 'Class::MOP::Method::Generated'; sub new { my $class = shift; my %options = @_; - (exists $options{attribute}) + ( exists $options{attribute} ) || confess "You must supply an attribute to construct with"; - (blessed($options{attribute}) && $options{attribute}->isa('Moose::Meta::Attribute')) - || confess "You must supply an attribute which is a 'Moose::Meta::Attribute' instance"; + ( blessed( $options{attribute} ) + && $options{attribute}->isa('Moose::Meta::Attribute') ) + || confess + "You must supply an attribute which is a 'Moose::Meta::Attribute' instance"; - ($options{package_name} && $options{name}) - || confess "You must supply the package_name and name parameters $Class::MOP::Method::UPGRADE_ERROR_TEXT"; + ( $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); + ( $options{delegate_to_method} && ( !ref $options{delegate_to_method} ) + || ( 'CODE' eq ref $options{delegate_to_method} ) ) + || confess + 'You must supply a delegate_to_method which is a method name or a CODE reference'; - weaken($self->{'attribute'}); + exists $options{curried_arguments} + || ( $options{curried_arguments} = [] ); + + ( $options{curried_arguments} && + ( 'ARRAY' eq ref $options{curried_arguments} ) ) + || confess 'You must supply a curried_arguments which is an ARRAY reference'; + + my $self = $class->_new( \%options ); + + weaken( $self->{'attribute'} ); + + $self->_initialize_body; return $self; } @@ -41,8 +59,78 @@ sub _new { return bless $options, $class; } +sub curried_arguments { (shift)->{'curried_arguments'} } + sub associated_attribute { (shift)->{'attribute'} } +sub delegate_to_method { (shift)->{'delegate_to_method'} } + +sub _initialize_body { + my $self = shift; + + my $method_to_call = $self->delegate_to_method; + return $self->{body} = $method_to_call + if ref $method_to_call; + + my $accessor = $self->_get_delegate_accessor; + + my $handle_name = $self->name; + + # NOTE: we used to do a goto here, but the goto didn't handle + # failure correctly (it just returned nothing), so I took that + # out. However, the more I thought about it, the less I liked it + # doing the goto, and I preferred the act of delegation being + # actually represented in the stack trace. - SL + # not inlining this, since it won't really speed things up at + # all... the only thing that would end up different would be + # interpolating in $method_to_call, and a bunch of things in the + # error handling that mostly never gets called - doy + $self->{body} = sub { + my $instance = shift; + my $proxy = $instance->$accessor(); + + my $error + = !defined $proxy ? ' is not defined' + : ref($proxy) && !blessed($proxy) ? qq{ is not an object (got '$proxy')} + : undef; + + if ($error) { + $self->throw_error( + "Cannot delegate $handle_name to $method_to_call because " + . "the value of " + . $self->associated_attribute->name + . $error, + method_name => $method_to_call, + object => $instance + ); + } + unshift @_, @{ $self->curried_arguments }; + $proxy->$method_to_call(@_); + }; +} + +sub _get_delegate_accessor { + my $self = shift; + my $attr = $self->associated_attribute; + + # NOTE: + # always use a named method when + # possible, if you use the method + # ref and there are modifiers on + # the accessors then it will not + # pick up the modifiers too. Only + # the named method will assure that + # we also have any modifiers run. + # - SL + my $accessor = $attr->has_read_method + ? $attr->get_read_method + : $attr->get_read_method_ref; + + $accessor = $accessor->body if Scalar::Util::blessed $accessor; + + return $accessor; +} + 1; __END__ @@ -62,31 +150,47 @@ methods. =over 4 -=item B +=item B<< Moose::Meta::Method::Delegation->new(%options) >> -This creates the method based on the criteria in C<%options>, -these options are: +This creates the delegation methods based on the provided C<%options>. =over 4 =item I This must be an instance of C which this -accessor is being generated for. This paramter is B. +accessor is being generated for. This options is B. + +=item I + +The method in the associated attribute's value to which we +delegate. This can be either a method name or a code reference. + +=item I + +An array reference of arguments that will be prepended to the argument list for +any call to the delegating method. =back -=item B +=item B<< $metamethod->associated_attribute >> Returns the attribute associated with this method. +=item B<< $metamethod->curried_arguments >> + +Return any curried arguments that will be passed to the delegated method. + +=item B<< $metamethod->delegate_to_method >> + +Returns the method to which this method delegates, as passed to the +constructor. + =back =head1 BUGS -All complex software has bugs lurking in it, and this module is no -exception. If you find a bug please either email me, or add the bug -to cpan-RT. +See L for details on reporting bugs. =head1 AUTHOR @@ -94,7 +198,7 @@ Dave Rolsky Eautarch@urth.orgE =head1 COPYRIGHT AND LICENSE -Copyright 2008 by Infinity Interactive, Inc. +Copyright 2009 by Infinity Interactive, Inc. L