lib/Moose/Meta/Method/Delegation.pm

   1
   2 package Moose::Meta::Method::Delegation;
   3
   4 use strict;
   5 use warnings;
   6
   7 use Carp         'confess';
   8 use Scalar::Util 'blessed', 'weaken';
   9
  10 our $AUTHORITY = 'cpan:STEVAN';
  11
  12 use base 'Moose::Meta::Method',
  13          'Class::MOP::Method::Generated';
  14
  15
  16 sub new {
  17     my $class   = shift;
  18     my %options = @_;
  19
  20     ( exists $options{attribute} )
  21         || confess "You must supply an attribute to construct with";
  22
  23     ( blessed( $options{attribute} )
  24             && $options{attribute}->isa('Moose::Meta::Attribute') )
  25         || confess
  26         "You must supply an attribute which is a 'Moose::Meta::Attribute' instance";
  27
  28     ( $options{package_name} && $options{name} )
  29         || confess
  30         "You must supply the package_name and name parameters $Class::MOP::Method::UPGRADE_ERROR_TEXT";
  31
  32     ( $options{delegate_to_method} && ( !ref $options{delegate_to_method} )
  33             || ( 'CODE' eq ref $options{delegate_to_method} ) )
  34         || confess
  35         'You must supply a delegate_to_method which is a method name or a CODE reference';
  36
  37     exists $options{curried_arguments}
  38         || ( $options{curried_arguments} = [] );
  39
  40     ( $options{curried_arguments} &&
  41         ( 'ARRAY' eq ref $options{curried_arguments} ) )
  42         || confess 'You must supply a curried_arguments which is an ARRAY reference';
  43
  44     my $self = $class->_new( \%options );
  45
  46     weaken( $self->{'attribute'} );
  47
  48     $self->_initialize_body;
  49
  50     return $self;
  51 }
  52
  53 sub _new {
  54     my $class = shift;
  55     my $options = @_ == 1 ? $_[0] : {@_};
  56
  57     return bless $options, $class;
  58 }
  59
  60 sub curried_arguments { (shift)->{'curried_arguments'} }
  61
  62 sub associated_attribute { (shift)->{'attribute'} }
  63
  64 sub delegate_to_method { (shift)->{'delegate_to_method'} }
  65
  66 sub _initialize_body {
  67     my $self = shift;
  68
  69     my $method_to_call = $self->delegate_to_method;
  70     return $self->{body} = $method_to_call
  71         if ref $method_to_call;
  72
  73     my $accessor = $self->_get_delegate_accessor;
  74
  75     my $handle_name = $self->name;
  76
  77     # NOTE: we used to do a goto here, but the goto didn't handle
  78     # failure correctly (it just returned nothing), so I took that
  79     # out. However, the more I thought about it, the less I liked it
  80     # doing the goto, and I preferred the act of delegation being
  81     # actually represented in the stack trace.  - SL
  82     # not inlining this, since it won't really speed things up at
  83     # all... the only thing that would end up different would be
  84     # interpolating in $method_to_call, and a bunch of things in the
  85     # error handling that mostly never gets called - doy
  86     $self->{body} = sub {
  87         my $instance = shift;
  88         my $proxy    = $instance->$accessor();
  89
  90         my $error
  91             = !defined $proxy                 ? ' is not defined'
  92             : ref($proxy) && !blessed($proxy) ? qq{ is not an object (got '$proxy')}
  93             : undef;
  94
  95         if ($error) {
  96             $self->throw_error(
  97                 "Cannot delegate $handle_name to $method_to_call because "
  98                     . "the value of "
  99                     . $self->associated_attribute->name
 100                     . $error,
 101                 method_name => $method_to_call,
 102                 object      => $instance
 103             );
 104         }
 105         unshift @_, @{ $self->curried_arguments };
 106         $proxy->$method_to_call(@_);
 107     };
 108 }
 109
 110 sub _get_delegate_accessor {
 111     my $self = shift;
 112     my $attr = $self->associated_attribute;
 113
 114     # NOTE:
 115     # always use a named method when
 116     # possible, if you use the method
 117     # ref and there are modifiers on
 118     # the accessors then it will not
 119     # pick up the modifiers too. Only
 120     # the named method will assure that
 121     # we also have any modifiers run.
 122     # - SL
 123     my $accessor = $attr->has_read_method
 124         ? $attr->get_read_method
 125         : $attr->get_read_method_ref;
 126
 127     $accessor = $accessor->body if Scalar::Util::blessed $accessor;
 128
 129     return $accessor;
 130 }
 131
 132 1;
 133
 134 # ABSTRACT: A Moose Method metaclass for delegation methods
 135
 136 __END__
 137
 138 =pod
 139
 140 =head1 DESCRIPTION
 141
 142 This is a subclass of L<Moose::Meta::Method> for delegation
 143 methods.
 144
 145 =head1 METHODS
 146
 147 =over 4
 148
 149 =item B<< Moose::Meta::Method::Delegation->new(%options) >>
 150
 151 This creates the delegation methods based on the provided C<%options>.
 152
 153 =over 4
 154
 155 =item I<attribute>
 156
 157 This must be an instance of C<Moose::Meta::Attribute> which this
 158 accessor is being generated for. This options is B<required>.
 159
 160 =item I<delegate_to_method>
 161
 162 The method in the associated attribute's value to which we
 163 delegate. This can be either a method name or a code reference.
 164
 165 =item I<curried_arguments>
 166
 167 An array reference of arguments that will be prepended to the argument list for
 168 any call to the delegating method.
 169
 170 =back
 171
 172 =item B<< $metamethod->associated_attribute >>
 173
 174 Returns the attribute associated with this method.
 175
 176 =item B<< $metamethod->curried_arguments >>
 177
 178 Return any curried arguments that will be passed to the delegated method.
 179
 180 =item B<< $metamethod->delegate_to_method >>
 181
 182 Returns the method to which this method delegates, as passed to the
 183 constructor.
 184
 185 =back
 186
 187 =head1 BUGS
 188
 189 See L<Moose/BUGS> for details on reporting bugs.
 190
 191 =cut