2 package Moose::Meta::Method::Delegation;
8 use Scalar::Util 'blessed', 'weaken';
10 our $VERSION = '0.89_02';
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} = [] );
42 ( $options{curried_arguments} &&
43 ( 'ARRAY' eq ref $options{curried_arguments} ) )
44 || confess 'You must supply a curried_arguments which is an ARRAY reference';
46 my $self = $class->_new( \%options );
48 weaken( $self->{'attribute'} );
50 $self->_initialize_body;
57 my $options = @_ == 1 ? $_[0] : {@_};
59 return bless $options, $class;
62 sub curried_arguments { (shift)->{'curried_arguments'} }
64 sub associated_attribute { (shift)->{'attribute'} }
66 sub delegate_to_method { (shift)->{'delegate_to_method'} }
68 sub _initialize_body {
71 my $method_to_call = $self->delegate_to_method;
72 return $self->{body} = $method_to_call
73 if ref $method_to_call;
75 my $accessor = $self->_get_delegate_accessor;
77 my $handle_name = $self->name;
79 # NOTE: we used to do a goto here, but the goto didn't handle
80 # failure correctly (it just returned nothing), so I took that
81 # out. However, the more I thought about it, the less I liked it
82 # doing the goto, and I preferred the act of delegation being
83 # actually represented in the stack trace. - SL
84 # not inlining this, since it won't really speed things up at
85 # all... the only thing that would end up different would be
86 # interpolating in $method_to_call, and a bunch of things in the
87 # error handling that mostly never gets called - doy
90 my $proxy = $instance->$accessor();
93 = !defined $proxy ? ' is not defined'
94 : ref($proxy) && !blessed($proxy) ? qq{ is not an object (got '$proxy')}
99 "Cannot delegate $handle_name to $method_to_call because "
101 . $self->associated_attribute->name
103 method_name => $method_to_call,
107 my @args = (@{ $self->curried_arguments }, @_);
108 $proxy->$method_to_call(@args);
112 sub _get_delegate_accessor {
115 my $accessor = $self->associated_attribute->get_read_method_ref;
117 $accessor = $accessor->body if blessed $accessor;
130 Moose::Meta::Method::Delegation - A Moose Method metaclass for delegation methods
134 This is a subclass of L<Moose::Meta::Method> for delegation
141 =item B<< Moose::Meta::Method::Delegation->new(%options) >>
143 This creates the delegation methods based on the provided C<%options>.
149 This must be an instance of C<Moose::Meta::Attribute> which this
150 accessor is being generated for. This options is B<required>.
152 =item I<delegate_to_method>
154 The method in the associated attribute's value to which we
155 delegate. This can be either a method name or a code reference.
157 =item I<curried_arguments>
159 An array reference of arguments that will be prepended to the argument list for
160 any call to the delegating method.
164 =item B<< $metamethod->associated_attribute >>
166 Returns the attribute associated with this method.
168 =item B<< $metamethod->curried_arguments >>
170 Return any curried arguments that will be passed to the delegated method.
172 =item B<< $metamethod->delegate_to_method >>
174 Returns the method to which this method delegates, as passed to the
181 All complex software has bugs lurking in it, and this module is no
182 exception. If you find a bug please either email me, or add the bug
187 Dave Rolsky E<lt>autarch@urth.orgE<gt>
189 =head1 COPYRIGHT AND LICENSE
191 Copyright 2009 by Infinity Interactive, Inc.
193 L<http://www.iinteractive.com>
195 This library is free software; you can redistribute it and/or modify
196 it under the same terms as Perl itself.