2 package Class::MOP::Method;
8 use Scalar::Util 'reftype', 'blessed';
11 our $VERSION = '0.04';
12 our $AUTHORITY = 'cpan:STEVAN';
14 use base 'Class::MOP::Object';
17 # if poked in the right way,
18 # they should act like CODE refs.
19 use overload '&{}' => sub { $_[0]->{body} }, fallback => 1;
24 require Class::MOP::Class;
25 Class::MOP::Class->initialize(blessed($_[0]) || $_[0]);
33 ('CODE' eq (reftype($code) || ''))
34 || confess "You must supply a CODE reference to bless, not (" . ($code || 'undef') . ")";
37 } => blessed($class) || $class;
42 sub body { (shift)->{body} }
44 # TODO - add associated_class
49 # this may not be the same name
50 # as the class you got it from
51 # This gets the package stash name
52 # associated with the actual CODE-ref
54 my $code = (shift)->{body};
55 svref_2object($code)->GV->STASH->NAME;
59 # this may not be the same name
60 # as the method name it is stored
61 # with. This gets the name associated
62 # with the actual CODE-ref
64 my $code = (shift)->{body};
65 svref_2object($code)->GV->NAME;
68 sub fully_qualified_name {
70 $code->package_name . '::' . $code->name;
73 package Class::MOP::Method::Wrapped;
79 use Scalar::Util 'reftype', 'blessed';
80 use Sub::Name 'subname';
82 our $VERSION = '0.02';
83 our $AUTHORITY = 'cpan:STEVAN';
85 use base 'Class::MOP::Method';
88 # this ugly beast is the result of trying
89 # to micro optimize this as much as possible
90 # while not completely loosing maintainability.
91 # At this point it's "fast enough", after all
92 # you can't get something for nothing :)
93 my $_build_wrapped_method = sub {
94 my $modifier_table = shift;
95 my ($before, $after, $around) = (
96 $modifier_table->{before},
97 $modifier_table->{after},
98 $modifier_table->{around},
100 if (@$before && @$after) {
101 $modifier_table->{cache} = sub {
102 $_->(@_) for @{$before};
104 ((defined wantarray) ?
106 (@rval = $around->{cache}->(@_))
108 ($rval[0] = $around->{cache}->(@_)))
110 $around->{cache}->(@_));
111 $_->(@_) for @{$after};
112 return unless defined wantarray;
113 return wantarray ? @rval : $rval[0];
116 elsif (@$before && !@$after) {
117 $modifier_table->{cache} = sub {
118 $_->(@_) for @{$before};
119 return $around->{cache}->(@_);
122 elsif (@$after && !@$before) {
123 $modifier_table->{cache} = sub {
125 ((defined wantarray) ?
127 (@rval = $around->{cache}->(@_))
129 ($rval[0] = $around->{cache}->(@_)))
131 $around->{cache}->(@_));
132 $_->(@_) for @{$after};
133 return unless defined wantarray;
134 return wantarray ? @rval : $rval[0];
138 $modifier_table->{cache} = $around->{cache};
145 (blessed($code) && $code->isa('Class::MOP::Method'))
146 || confess "Can only wrap blessed CODE";
147 my $modifier_table = {
153 cache => $code->body,
157 $_build_wrapped_method->($modifier_table);
158 my $method = $class->SUPER::wrap(sub { $modifier_table->{cache}->(@_) });
159 $method->{modifier_table} = $modifier_table;
163 sub get_original_method {
165 $code->{modifier_table}->{orig};
168 sub add_before_modifier {
170 my $modifier = shift;
171 unshift @{$code->{modifier_table}->{before}} => $modifier;
172 $_build_wrapped_method->($code->{modifier_table});
175 sub add_after_modifier {
177 my $modifier = shift;
178 push @{$code->{modifier_table}->{after}} => $modifier;
179 $_build_wrapped_method->($code->{modifier_table});
184 # this is another possible canidate for
185 # optimization as well. There is an overhead
186 # associated with the currying that, if
187 # eliminated might make around modifiers
189 my $compile_around_method = sub {{
191 return $f1 unless @_;
193 push @_, sub { $f2->( $f1, @_ ) };
197 sub add_around_modifier {
199 my $modifier = shift;
200 unshift @{$code->{modifier_table}->{around}->{methods}} => $modifier;
201 $code->{modifier_table}->{around}->{cache} = $compile_around_method->(
202 @{$code->{modifier_table}->{around}->{methods}},
203 $code->{modifier_table}->{orig}->body
205 $_build_wrapped_method->($code->{modifier_table});
217 Class::MOP::Method - Method Meta Object
221 # ... more to come later maybe
225 The Method Protocol is very small, since methods in Perl 5 are just
226 subroutines within the particular package. Basically all we do is to
227 bless the subroutine.
229 Currently this package is largely unused. Future plans are to provide
230 some very simple introspection methods for the methods themselves.
231 Suggestions for this are welcome.
241 This will return a B<Class::MOP::Class> instance which is related
250 =item B<wrap (&code)>
252 This simply blesses the C<&code> reference passed to it.
264 =item B<package_name>
266 =item B<fully_qualified_name>
270 =head1 Class::MOP::Method::Wrapped METHODS
276 =item B<wrap (&code)>
278 This simply blesses the C<&code> reference passed to it.
280 =item B<get_original_method>
288 =item B<add_before_modifier ($code)>
290 =item B<add_after_modifier ($code)>
292 =item B<add_around_modifier ($code)>
298 Stevan Little E<lt>stevan@iinteractive.comE<gt>
300 Yuval Kogman E<lt>nothingmuch@woobling.comE<gt>
302 =head1 COPYRIGHT AND LICENSE
304 Copyright 2006 by Infinity Interactive, Inc.
306 L<http://www.iinteractive.com>
308 This library is free software; you can redistribute it and/or modify
309 it under the same terms as Perl itself.