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.63';
  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     my $self = $class->_new( \%options );
  40
  41     weaken( $self->{'attribute'} );
  42
  43     $self->_initialize_body;
  44
  45     return $self;
  46 }
  47
  48 sub _new {
  49     my $class = shift;
  50     my $options = @_ == 1 ? $_[0] : {@_};
  51
  52     return bless $options, $class;
  53 }
  54
  55 sub associated_attribute { (shift)->{'attribute'} }
  56
  57 sub delegate_to_method { (shift)->{'delegate_to_method'} }
  58
  59 sub _initialize_body {
  60     my $self = shift;
  61
  62     my $method_to_call = $self->delegate_to_method;
  63     return $self->{body} = $method_to_call
  64         if ref $method_to_call;
  65
  66     my $accessor = $self->_get_delegate_accessor;
  67
  68     my $handle_name = $self->name;
  69
  70     # NOTE: we used to do a goto here, but the goto didn't handle
  71     # failure correctly (it just returned nothing), so I took that
  72     # out. However, the more I thought about it, the less I liked it
  73     # doing the goto, and I prefered the act of delegation being
  74     # actually represented in the stack trace.  - SL
  75     $self->{body} = sub {
  76         my $instance = shift;
  77         my $proxy    = $instance->$accessor();
  78         ( defined $proxy )
  79             || $self->throw_error(
  80             "Cannot delegate $handle_name to $method_to_call because "
  81                 . "the value of "
  82                 . $self->name
  83                 . " is not defined",
  84             method_name => $method_to_call,
  85             object      => $instance
  86             );
  87         $proxy->$method_to_call(@_);
  88     };
  89 }
  90
  91 sub _get_delegate_accessor {
  92     my $self = shift;
  93
  94     my $accessor = $self->associated_attribute->get_read_method_ref;
  95
  96     $accessor = $accessor->body if blessed $accessor;
  97
  98     return $accessor;
  99 }
 100
 101 1;
 102
 103 __END__
 104
 105 =pod
 106
 107 =head1 NAME
 108
 109 Moose::Meta::Method::Delegation - A Moose Method metaclass for delegation methods
 110
 111 =head1 DESCRIPTION
 112
 113 This is a subclass of L<Moose::Meta::Method> for delegation
 114 methods.
 115
 116 =head1 METHODS
 117
 118 =over 4
 119
 120 =item B<new (%options)>
 121
 122 This creates the method based on the criteria in C<%options>,
 123 these options are:
 124
 125 =over 4
 126
 127 =item I<attribute>
 128
 129 This must be an instance of C<Moose::Meta::Attribute> which this
 130 accessor is being generated for. This paramter is B<required>.
 131
 132 =item I<delegate_to_method>
 133
 134 The method in the associated attribute's value to which we
 135 delegate. This can be either a method name or a code reference.
 136
 137 =back
 138
 139 =item B<associated_attribute>
 140
 141 Returns the attribute associated with this method.
 142
 143 =item B<delegate_to_method>
 144
 145 Returns the method to which this method delegates.
 146
 147 =back
 148
 149 =head1 BUGS
 150
 151 All complex software has bugs lurking in it, and this module is no
 152 exception. If you find a bug please either email me, or add the bug
 153 to cpan-RT.
 154
 155 =head1 AUTHOR
 156
 157 Dave Rolsky E<lt>autarch@urth.orgE<gt>
 158
 159 =head1 COPYRIGHT AND LICENSE
 160
 161 Copyright 2008 by Infinity Interactive, Inc.
 162
 163 L<http://www.iinteractive.com>
 164
 165 This library is free software; you can redistribute it and/or modify
 166 it under the same terms as Perl itself.
 167
 168 =cut