| File | /usr/local/lib/perl5/site_perl/5.10.1/darwin-2level/Moose/Meta/Method/Delegation.pm |
| Statements Executed | 19 |
| Statement Execution Time | 816µs |
| Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
|---|---|---|---|---|---|
| 1 | 1 | 1 | 48µs | 52µs | Moose::Meta::Method::Delegation::BEGIN@4 |
| 1 | 1 | 1 | 9µs | 38µs | Moose::Meta::Method::Delegation::BEGIN@8 |
| 1 | 1 | 1 | 8µs | 17µs | Moose::Meta::Method::Delegation::BEGIN@5 |
| 1 | 1 | 1 | 7µs | 34µs | Moose::Meta::Method::Delegation::BEGIN@7 |
| 1 | 1 | 1 | 7µs | 74µs | Moose::Meta::Method::Delegation::BEGIN@14 |
| 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 | State ments |
Time on line |
Calls | Time in subs |
Code |
|---|---|---|---|---|---|
| 1 | |||||
| 2 | package Moose::Meta::Method::Delegation; | ||||
| 3 | |||||
| 4 | 3 | 31µs | 2 | 56µs | # spent 52µs (48+4) within Moose::Meta::Method::Delegation::BEGIN@4 which was called
# once (48µs+4µs) by Moose::Meta::Attribute::BEGIN@16 at line 4 # spent 52µs making 1 call to Moose::Meta::Method::Delegation::BEGIN@4
# spent 4µs making 1 call to strict::import |
| 5 | 3 | 28µs | 2 | 27µs | # spent 17µs (8+10) within Moose::Meta::Method::Delegation::BEGIN@5 which was called
# once (8µs+10µs) by Moose::Meta::Attribute::BEGIN@16 at line 5 # spent 17µs making 1 call to Moose::Meta::Method::Delegation::BEGIN@5
# spent 10µs making 1 call to warnings::import |
| 6 | |||||
| 7 | 3 | 298µs | 2 | 61µs | # spent 34µs (7+27) within Moose::Meta::Method::Delegation::BEGIN@7 which was called
# once (7µs+27µs) by Moose::Meta::Attribute::BEGIN@16 at line 7 # spent 34µs making 1 call to Moose::Meta::Method::Delegation::BEGIN@7
# spent 27µs making 1 call to Exporter::import |
| 8 | 3 | 54µs | 2 | 66µs | # spent 38µs (9+29) within Moose::Meta::Method::Delegation::BEGIN@8 which was called
# once (9µs+29µs) by Moose::Meta::Attribute::BEGIN@16 at line 8 # spent 38µs making 1 call to Moose::Meta::Method::Delegation::BEGIN@8
# spent 29µs making 1 call to Exporter::import |
| 9 | |||||
| 10 | 1 | 700ns | our $VERSION = '0.98'; | ||
| 11 | 1 | 14µs | $VERSION = eval $VERSION; | ||
| 12 | 1 | 300ns | our $AUTHORITY = 'cpan:STEVAN'; | ||
| 13 | |||||
| 14 | # spent 74µs (7+67) within Moose::Meta::Method::Delegation::BEGIN@14 which was called
# once (7µs+67µs) by Moose::Meta::Attribute::BEGIN@16 at line 15 # spent 67µs making 1 call to base::import | ||||
| 15 | 3 | 380µs | 1 | 74µs | 'Class::MOP::Method::Generated'; # spent 74µs making 1 call to Moose::Meta::Method::Delegation::BEGIN@14 |
| 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 | 10µ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 |