| File | /usr/local/lib/perl/5.10.0/Moose/Meta/Method/Delegation.pm |
| Statements Executed | 19 |
| Total Time | 0.0008446 seconds |
| Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
|---|---|---|---|---|---|
| 0 | 0 | 0 | 0s | 0s | Moose::Meta::Method::Delegation::BEGIN |
| 0 | 0 | 0 | 0s | 0s | Moose::Meta::Method::Delegation::__ANON__[:109] |
| 0 | 0 | 0 | 0s | 0s | Moose::Meta::Method::Delegation::_get_delegate_accessor |
| 0 | 0 | 0 | 0s | 0s | Moose::Meta::Method::Delegation::_initialize_body |
| 0 | 0 | 0 | 0s | 0s | Moose::Meta::Method::Delegation::_new |
| 0 | 0 | 0 | 0s | 0s | Moose::Meta::Method::Delegation::associated_attribute |
| 0 | 0 | 0 | 0s | 0s | Moose::Meta::Method::Delegation::curried_arguments |
| 0 | 0 | 0 | 0s | 0s | Moose::Meta::Method::Delegation::delegate_to_method |
| 0 | 0 | 0 | 0s | 0s | Moose::Meta::Method::Delegation::new |
| Line | Stmts. | Exclusive Time | Avg. | Code |
|---|---|---|---|---|
| 1 | ||||
| 2 | package Moose::Meta::Method::Delegation; | |||
| 3 | ||||
| 4 | 3 | 28µs | 9µs | use strict; # spent 10µs making 1 call to strict::import |
| 5 | 3 | 34µs | 11µs | use warnings; # spent 28µs making 1 call to warnings::import |
| 6 | ||||
| 7 | 3 | 30µs | 10µs | use Carp 'confess'; # spent 51µs making 1 call to Exporter::import |
| 8 | 3 | 64µs | 21µs | use Scalar::Util 'blessed', 'weaken'; # spent 48µs making 1 call to Exporter::import |
| 9 | ||||
| 10 | 1 | 800ns | 800ns | our $VERSION = '1.15'; |
| 11 | 1 | 27µs | 27µs | $VERSION = eval $VERSION; |
| 12 | 1 | 700ns | 700ns | our $AUTHORITY = 'cpan:STEVAN'; |
| 13 | ||||
| 14 | use base 'Moose::Meta::Method', # spent 142µs making 1 call to base::import | |||
| 15 | 3 | 656µs | 219µs | '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 | ||||
| 42 | ( $options{curried_arguments} && | |||
| 43 | ( 'ARRAY' eq ref $options{curried_arguments} ) ) | |||
| 44 | || confess 'You must supply a curried_arguments which is an ARRAY reference'; | |||
| 45 | ||||
| 46 | my $self = $class->_new( \%options ); | |||
| 47 | ||||
| 48 | weaken( $self->{'attribute'} ); | |||
| 49 | ||||
| 50 | $self->_initialize_body; | |||
| 51 | ||||
| 52 | return $self; | |||
| 53 | } | |||
| 54 | ||||
| 55 | sub _new { | |||
| 56 | my $class = shift; | |||
| 57 | my $options = @_ == 1 ? $_[0] : {@_}; | |||
| 58 | ||||
| 59 | return bless $options, $class; | |||
| 60 | } | |||
| 61 | ||||
| 62 | sub curried_arguments { (shift)->{'curried_arguments'} } | |||
| 63 | ||||
| 64 | sub associated_attribute { (shift)->{'attribute'} } | |||
| 65 | ||||
| 66 | sub delegate_to_method { (shift)->{'delegate_to_method'} } | |||
| 67 | ||||
| 68 | sub _initialize_body { | |||
| 69 | my $self = shift; | |||
| 70 | ||||
| 71 | my $method_to_call = $self->delegate_to_method; | |||
| 72 | return $self->{body} = $method_to_call | |||
| 73 | if ref $method_to_call; | |||
| 74 | ||||
| 75 | my $accessor = $self->_get_delegate_accessor; | |||
| 76 | ||||
| 77 | my $handle_name = $self->name; | |||
| 78 | ||||
| 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 | |||
| 88 | $self->{body} = sub { | |||
| 89 | my $instance = shift; | |||
| 90 | my $proxy = $instance->$accessor(); | |||
| 91 | ||||
| 92 | my $error | |||
| 93 | = !defined $proxy ? ' is not defined' | |||
| 94 | : ref($proxy) && !blessed($proxy) ? qq{ is not an object (got '$proxy')} | |||
| 95 | : undef; | |||
| 96 | ||||
| 97 | if ($error) { | |||
| 98 | $self->throw_error( | |||
| 99 | "Cannot delegate $handle_name to $method_to_call because " | |||
| 100 | . "the value of " | |||
| 101 | . $self->associated_attribute->name | |||
| 102 | . $error, | |||
| 103 | method_name => $method_to_call, | |||
| 104 | object => $instance | |||
| 105 | ); | |||
| 106 | } | |||
| 107 | unshift @_, @{ $self->curried_arguments }; | |||
| 108 | $proxy->$method_to_call(@_); | |||
| 109 | }; | |||
| 110 | } | |||
| 111 | ||||
| 112 | sub _get_delegate_accessor { | |||
| 113 | my $self = shift; | |||
| 114 | my $attr = $self->associated_attribute; | |||
| 115 | ||||
| 116 | # NOTE: | |||
| 117 | # always use a named method when | |||
| 118 | # possible, if you use the method | |||
| 119 | # ref and there are modifiers on | |||
| 120 | # the accessors then it will not | |||
| 121 | # pick up the modifiers too. Only | |||
| 122 | # the named method will assure that | |||
| 123 | # we also have any modifiers run. | |||
| 124 | # - SL | |||
| 125 | my $accessor = $attr->has_read_method | |||
| 126 | ? $attr->get_read_method | |||
| 127 | : $attr->get_read_method_ref; | |||
| 128 | ||||
| 129 | $accessor = $accessor->body if Scalar::Util::blessed $accessor; | |||
| 130 | ||||
| 131 | return $accessor; | |||
| 132 | } | |||
| 133 | ||||
| 134 | 1 | 4µs | 4µs | 1; |
| 135 | ||||
| 136 | __END__ | |||
| 137 | ||||
| 138 | =pod | |||
| 139 | ||||
| 140 | =head1 NAME | |||
| 141 | ||||
| 142 | Moose::Meta::Method::Delegation - A Moose Method metaclass for delegation methods | |||
| 143 | ||||
| 144 | =head1 DESCRIPTION | |||
| 145 | ||||
| 146 | This is a subclass of L<Moose::Meta::Method> for delegation | |||
| 147 | methods. | |||
| 148 | ||||
| 149 | =head1 METHODS | |||
| 150 | ||||
| 151 | =over 4 | |||
| 152 | ||||
| 153 | =item B<< Moose::Meta::Method::Delegation->new(%options) >> | |||
| 154 | ||||
| 155 | This creates the delegation methods based on the provided C<%options>. | |||
| 156 | ||||
| 157 | =over 4 | |||
| 158 | ||||
| 159 | =item I<attribute> | |||
| 160 | ||||
| 161 | This must be an instance of C<Moose::Meta::Attribute> which this | |||
| 162 | accessor is being generated for. This options is B<required>. | |||
| 163 | ||||
| 164 | =item I<delegate_to_method> | |||
| 165 | ||||
| 166 | The method in the associated attribute's value to which we | |||
| 167 | delegate. This can be either a method name or a code reference. | |||
| 168 | ||||
| 169 | =item I<curried_arguments> | |||
| 170 | ||||
| 171 | An array reference of arguments that will be prepended to the argument list for | |||
| 172 | any call to the delegating method. | |||
| 173 | ||||
| 174 | =back | |||
| 175 | ||||
| 176 | =item B<< $metamethod->associated_attribute >> | |||
| 177 | ||||
| 178 | Returns the attribute associated with this method. | |||
| 179 | ||||
| 180 | =item B<< $metamethod->curried_arguments >> | |||
| 181 | ||||
| 182 | Return any curried arguments that will be passed to the delegated method. | |||
| 183 | ||||
| 184 | =item B<< $metamethod->delegate_to_method >> | |||
| 185 | ||||
| 186 | Returns the method to which this method delegates, as passed to the | |||
| 187 | constructor. | |||
| 188 | ||||
| 189 | =back | |||
| 190 | ||||
| 191 | =head1 BUGS | |||
| 192 | ||||
| 193 | See L<Moose/BUGS> for details on reporting bugs. | |||
| 194 | ||||
| 195 | =head1 AUTHOR | |||
| 196 | ||||
| 197 | Dave Rolsky E<lt>autarch@urth.orgE<gt> | |||
| 198 | ||||
| 199 | =head1 COPYRIGHT AND LICENSE | |||
| 200 | ||||
| 201 | Copyright 2009 by Infinity Interactive, Inc. | |||
| 202 | ||||
| 203 | L<http://www.iinteractive.com> | |||
| 204 | ||||
| 205 | This library is free software; you can redistribute it and/or modify | |||
| 206 | it under the same terms as Perl itself. | |||
| 207 | ||||
| 208 | =cut |