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 $VERSION   = '0.83';
  11 $VERSION = eval $VERSION;
  12 our $AUTHORITY = 'cpan:STEVAN';
  13
  14 use base 'Moose::Meta::Method',
  15          'Class::MOP::Method::Generated';
  16
  17
  18 sub new {
  19     my $class   = shift;
  20     my %options = @_;
  21
  22     ( exists $options{attribute} )
  23         || confess "You must supply an attribute to construct with";
  24
  25     ( blessed( $options{attribute} )
  26             && $options{attribute}->isa('Moose::Meta::Attribute') )
  27         || confess
  28         "You must supply an attribute which is a 'Moose::Meta::Attribute' instance";
  29
  30     ( $options{package_name} && $options{name} )
  31         || confess
  32         "You must supply the package_name and name parameters $Class::MOP::Method::UPGRADE_ERROR_TEXT";
  33
  34     ( $options{delegate_to_method} && ( !ref $options{delegate_to_method} )
  35             || ( 'CODE' eq ref $options{delegate_to_method} ) )
  36         || confess
  37         'You must supply a delegate_to_method which is a method name or a CODE reference';
  38
  39     ( !exists $options{curried_arguments} || (
  40         $options{curried_arguments} &&
  41             ( 'ARRAY' eq ref $options{curried_arguments} )
  42         ) ) || confess
  43         'You must supply a curried_arguments which is an ARRAY reference';
  44
  45     $options{curried_arguments} ||= [];
  46
  47     my $self = $class->_new( \%options );
  48
  49     weaken( $self->{'attribute'} );
  50
  51     $self->_initialize_body;
  52
  53     return $self;
  54 }
  55
  56 sub _new {
  57     my $class = shift;
  58     my $options = @_ == 1 ? $_[0] : {@_};
  59
  60     return bless $options, $class;
  61 }
  62
  63 sub curried_arguments { (shift)->{'curried_arguments'} }
  64
  65 sub associated_attribute { (shift)->{'attribute'} }
  66
  67 sub delegate_to_method { (shift)->{'delegate_to_method'} }
  68
  69 sub _initialize_body {
  70     my $self = shift;
  71
  72     my $method_to_call = $self->delegate_to_method;
  73     return $self->{body} = $method_to_call
  74         if ref $method_to_call;
  75
  76     my $accessor = $self->_get_delegate_accessor;
  77
  78     my $handle_name = $self->name;
  79
  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
  89     $self->{body} = sub {
  90         my $instance = shift;
  91         my $proxy    = $instance->$accessor();
  92         ( defined $proxy )
  93             || $self->throw_error(
  94             "Cannot delegate $handle_name to $method_to_call because "
  95                 . "the value of "
  96                 . $self->associated_attribute->name
  97                 . " is not defined",
  98             method_name => $method_to_call,
  99             object      => $instance
 100             );
 101         my @args = (@{ $self->curried_arguments }, @_);
 102         $proxy->$method_to_call(@args);
 103     };
 104 }
 105
 106 sub _get_delegate_accessor {
 107     my $self = shift;
 108
 109     my $accessor = $self->associated_attribute->get_read_method_ref;
 110
 111     $accessor = $accessor->body if blessed $accessor;
 112
 113     return $accessor;
 114 }
 115
 116 1;
 117
 118 __END__
 119
 120 =pod
 121
 122 =head1 NAME
 123
 124 Moose::Meta::Method::Delegation - A Moose Method metaclass for delegation methods
 125
 126 =head1 DESCRIPTION
 127
 128 This is a subclass of L<Moose::Meta::Method> for delegation
 129 methods.
 130
 131 =head1 METHODS
 132
 133 =over 4
 134
 135 =item B<< Moose::Meta::Method::Delegation->new(%options) >>
 136
 137 This creates the delegation methods based on the provided C<%options>.
 138
 139 =over 4
 140
 141 =item I<attribute>
 142
 143 This must be an instance of C<Moose::Meta::Attribute> which this
 144 accessor is being generated for. This options is B<required>.
 145
 146 =item I<delegate_to_method>
 147
 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.
 150
 151 =item I<curried_arguments>
 152
 153 An array reference of arguments that will be prepended to the argument list for
 154 any call to the delegating method.
 155
 156 =back
 157
 158 =item B<< $metamethod->associated_attribute >>
 159
 160 Returns the attribute associated with this method.
 161
 162 =item B<< $metamethod->curried_arguments >>
 163
 164 Return any curried arguments that will be passed to the delegated method.
 165
 166 =item B<< $metamethod->delegate_to_method >>
 167
 168 Returns the method to which this method delegates, as passed to the
 169 constructor.
 170
 171 =back
 172
 173 =head1 BUGS
 174
 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
 177 to cpan-RT.
 178
 179 =head1 AUTHOR
 180
 181 Dave Rolsky E<lt>autarch@urth.orgE<gt>
 182
 183 =head1 COPYRIGHT AND LICENSE
 184
 185 Copyright 2009 by Infinity Interactive, Inc.
 186
 187 L<http://www.iinteractive.com>
 188
 189 This library is free software; you can redistribute it and/or modify
 190 it under the same terms as Perl itself.
 191
 192 =cut