2 package Moose::Meta::Method::Delegation;
8 use Scalar::Util 'blessed', 'weaken';
10 our $VERSION = '0.83';
11 $VERSION = eval $VERSION;
12 our $AUTHORITY = 'cpan:STEVAN';
14 use base 'Moose::Meta::Method',
15 'Class::MOP::Method::Generated';
22 ( exists $options{attribute} )
23 || confess "You must supply an attribute to construct with";
25 ( blessed( $options{attribute} )
26 && $options{attribute}->isa('Moose::Meta::Attribute') )
28 "You must supply an attribute which is a 'Moose::Meta::Attribute' instance";
30 ( $options{package_name} && $options{name} )
32 "You must supply the package_name and name parameters $Class::MOP::Method::UPGRADE_ERROR_TEXT";
34 ( $options{delegate_to_method} && ( !ref $options{delegate_to_method} )
35 || ( 'CODE' eq ref $options{delegate_to_method} ) )
37 'You must supply a delegate_to_method which is a method name or a CODE reference';
39 ( !exists $options{curried_arguments} || (
40 $options{curried_arguments} &&
41 ( 'ARRAY' eq ref $options{curried_arguments} )
43 'You must supply a curried_arguments which is an ARRAY reference';
45 $options{curried_arguments} ||= [];
47 my $self = $class->_new( \%options );
49 weaken( $self->{'attribute'} );
51 $self->_initialize_body;
58 my $options = @_ == 1 ? $_[0] : {@_};
60 return bless $options, $class;
63 sub curried_arguments { (shift)->{'curried_arguments'} }
65 sub associated_attribute { (shift)->{'attribute'} }
67 sub delegate_to_method { (shift)->{'delegate_to_method'} }
69 sub _initialize_body {
72 my $method_to_call = $self->delegate_to_method;
73 return $self->{body} = $method_to_call
74 if ref $method_to_call;
76 my $accessor = $self->_get_delegate_accessor;
78 my $handle_name = $self->name;
80 # NOTE: we used to do a goto here, but the goto didn't handle
81 # failure correctly (it just returned nothing), so I took that
82 # out. However, the more I thought about it, the less I liked it
83 # doing the goto, and I prefered the act of delegation being
84 # actually represented in the stack trace. - SL
85 # not inlining this, since it won't really speed things up at
86 # all... the only thing that would end up different would be
87 # interpolating in $method_to_call, and a bunch of things in the
88 # error handling that mostly never gets called - doy
91 my $proxy = $instance->$accessor();
93 || $self->throw_error(
94 "Cannot delegate $handle_name to $method_to_call because "
96 . $self->associated_attribute->name
98 method_name => $method_to_call,
101 my @args = (@{ $self->curried_arguments }, @_);
102 $proxy->$method_to_call(@args);
106 sub _get_delegate_accessor {
109 my $accessor = $self->associated_attribute->get_read_method_ref;
111 $accessor = $accessor->body if blessed $accessor;
124 Moose::Meta::Method::Delegation - A Moose Method metaclass for delegation methods
128 This is a subclass of L<Moose::Meta::Method> for delegation
135 =item B<< Moose::Meta::Method::Delegation->new(%options) >>
137 This creates the delegation methods based on the provided C<%options>.
143 This must be an instance of C<Moose::Meta::Attribute> which this
144 accessor is being generated for. This options is B<required>.
146 =item I<delegate_to_method>
148 The method in the associated attribute's value to which we
149 delegate. This can be either a method name or a code reference.
151 =item I<curried_arguments>
153 An array reference of arguments that will be prepended to the argument list for
154 any call to the delegating method.
158 =item B<< $metamethod->associated_attribute >>
160 Returns the attribute associated with this method.
162 =item B<< $metamethod->curried_arguments >>
164 Return any curried arguments that will be passed to the delegated method.
166 =item B<< $metamethod->delegate_to_method >>
168 Returns the method to which this method delegates, as passed to the
175 All complex software has bugs lurking in it, and this module is no
176 exception. If you find a bug please either email me, or add the bug
181 Dave Rolsky E<lt>autarch@urth.orgE<gt>
183 =head1 COPYRIGHT AND LICENSE
185 Copyright 2009 by Infinity Interactive, Inc.
187 L<http://www.iinteractive.com>
189 This library is free software; you can redistribute it and/or modify
190 it under the same terms as Perl itself.