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