2 package Class::MOP::Method;
8 use Scalar::Util 'reftype', 'blessed';
11 our $VERSION = '0.03';
12 our $AUTHORITY = 'cpan:STEVAN';
15 # if poked in the right way,
16 # they should act like CODE refs.
17 use overload '&{}' => sub { $_[0]->{body} }, fallback => 1;
22 require Class::MOP::Class;
23 Class::MOP::Class->initialize(blessed($_[0]) || $_[0]);
31 ('CODE' eq (reftype($code) || ''))
32 || confess "You must supply a CODE reference to bless, not (" . ($code || 'undef') . ")";
35 } => blessed($class) || $class;
40 sub body { (shift)->{body} }
45 # this may not be the same name
46 # as the class you got it from
47 # This gets the package stash name
48 # associated with the actual CODE-ref
50 my $code = (shift)->{body};
51 svref_2object($code)->GV->STASH->NAME;
55 # this may not be the same name
56 # as the method name it is stored
57 # with. This gets the name associated
58 # with the actual CODE-ref
60 my $code = (shift)->{body};
61 svref_2object($code)->GV->NAME;
64 sub fully_qualified_name {
66 $code->package_name . '::' . $code->name;
69 package Class::MOP::Method::Wrapped;
75 use Scalar::Util 'reftype', 'blessed';
76 use Sub::Name 'subname';
78 our $VERSION = '0.02';
79 our $AUTHORITY = 'cpan:STEVAN';
81 use base 'Class::MOP::Method';
84 # this ugly beast is the result of trying
85 # to micro optimize this as much as possible
86 # while not completely loosing maintainability.
87 # At this point it's "fast enough", after all
88 # you can't get something for nothing :)
89 my $_build_wrapped_method = sub {
90 my $modifier_table = shift;
91 my ($before, $after, $around) = (
92 $modifier_table->{before},
93 $modifier_table->{after},
94 $modifier_table->{around},
96 if (@$before && @$after) {
97 $modifier_table->{cache} = sub {
98 $_->(@_) for @{$before};
100 ((defined wantarray) ?
102 (@rval = $around->{cache}->(@_))
104 ($rval[0] = $around->{cache}->(@_)))
106 $around->{cache}->(@_));
107 $_->(@_) for @{$after};
108 return unless defined wantarray;
109 return wantarray ? @rval : $rval[0];
112 elsif (@$before && !@$after) {
113 $modifier_table->{cache} = sub {
114 $_->(@_) for @{$before};
115 return $around->{cache}->(@_);
118 elsif (@$after && !@$before) {
119 $modifier_table->{cache} = sub {
121 ((defined wantarray) ?
123 (@rval = $around->{cache}->(@_))
125 ($rval[0] = $around->{cache}->(@_)))
127 $around->{cache}->(@_));
128 $_->(@_) for @{$after};
129 return unless defined wantarray;
130 return wantarray ? @rval : $rval[0];
134 $modifier_table->{cache} = $around->{cache};
141 (blessed($code) && $code->isa('Class::MOP::Method'))
142 || confess "Can only wrap blessed CODE";
143 my $modifier_table = {
149 cache => $code->body,
153 $_build_wrapped_method->($modifier_table);
154 my $method = $class->SUPER::wrap(sub { $modifier_table->{cache}->(@_) });
155 $method->{modifier_table} = $modifier_table;
159 sub get_original_method {
161 $code->{modifier_table}->{orig};
164 sub add_before_modifier {
166 my $modifier = shift;
167 unshift @{$code->{modifier_table}->{before}} => $modifier;
168 $_build_wrapped_method->($code->{modifier_table});
171 sub add_after_modifier {
173 my $modifier = shift;
174 push @{$code->{modifier_table}->{after}} => $modifier;
175 $_build_wrapped_method->($code->{modifier_table});
180 # this is another possible canidate for
181 # optimization as well. There is an overhead
182 # associated with the currying that, if
183 # eliminated might make around modifiers
185 my $compile_around_method = sub {{
187 return $f1 unless @_;
189 push @_, sub { $f2->( $f1, @_ ) };
193 sub add_around_modifier {
195 my $modifier = shift;
196 unshift @{$code->{modifier_table}->{around}->{methods}} => $modifier;
197 $code->{modifier_table}->{around}->{cache} = $compile_around_method->(
198 @{$code->{modifier_table}->{around}->{methods}},
199 $code->{modifier_table}->{orig}->body
201 $_build_wrapped_method->($code->{modifier_table});
213 Class::MOP::Method - Method Meta Object
217 # ... more to come later maybe
221 The Method Protocol is very small, since methods in Perl 5 are just
222 subroutines within the particular package. Basically all we do is to
223 bless the subroutine.
225 Currently this package is largely unused. Future plans are to provide
226 some very simple introspection methods for the methods themselves.
227 Suggestions for this are welcome.
237 This will return a B<Class::MOP::Class> instance which is related
246 =item B<wrap (&code)>
248 This simply blesses the C<&code> reference passed to it.
260 =item B<package_name>
262 =item B<fully_qualified_name>
266 =head1 Class::MOP::Method::Wrapped METHODS
272 =item B<wrap (&code)>
274 This simply blesses the C<&code> reference passed to it.
276 =item B<get_original_method>
284 =item B<add_before_modifier ($code)>
286 =item B<add_after_modifier ($code)>
288 =item B<add_around_modifier ($code)>
294 Stevan Little E<lt>stevan@iinteractive.comE<gt>
296 Yuval Kogman E<lt>nothingmuch@woobling.comE<gt>
298 =head1 COPYRIGHT AND LICENSE
300 Copyright 2006 by Infinity Interactive, Inc.
302 L<http://www.iinteractive.com>
304 This library is free software; you can redistribute it and/or modify
305 it under the same terms as Perl itself.