2 package Class::MOP::Method;
8 use Scalar::Util 'reftype', 'blessed';
11 our $VERSION = '0.03';
12 our $AUTHORITY = 'cpan:STEVAN';
17 require Class::MOP::Class;
18 Class::MOP::Class->initialize(blessed($_[0]) || $_[0]);
26 ('CODE' eq (reftype($code) || ''))
27 || confess "You must supply a CODE reference to bless, not (" . ($code || 'undef') . ")";
28 bless $code => blessed($class) || $class;
36 || confess "Can only ask the package name of a blessed CODE";
37 svref_2object($code)->GV->STASH->NAME;
43 || confess "Can only ask the package name of a blessed CODE";
44 svref_2object($code)->GV->NAME;
47 sub fully_qualified_name {
50 || confess "Can only ask the package name of a blessed CODE";
51 $code->package_name . '::' . $code->name;
54 package Class::MOP::Method::Wrapped;
60 use Scalar::Util 'reftype', 'blessed';
61 use Sub::Name 'subname';
63 our $VERSION = '0.01';
65 our @ISA = ('Class::MOP::Method');
68 # this ugly beast is the result of trying
69 # to micro optimize this as much as possible
70 # while not completely loosing maintainability.
71 # At this point it's "fast enough", after all
72 # you can't get something for nothing :)
73 my $_build_wrapped_method = sub {
74 my $modifier_table = shift;
75 my ($before, $after, $around) = (
76 $modifier_table->{before},
77 $modifier_table->{after},
78 $modifier_table->{around},
80 if (@$before && @$after) {
81 $modifier_table->{cache} = sub {
82 $_->(@_) for @{$before};
84 ((defined wantarray) ?
86 (@rval = $around->{cache}->(@_))
88 ($rval[0] = $around->{cache}->(@_)))
90 $around->{cache}->(@_));
91 $_->(@_) for @{$after};
92 return unless defined wantarray;
93 return wantarray ? @rval : $rval[0];
96 elsif (@$before && !@$after) {
97 $modifier_table->{cache} = sub {
98 $_->(@_) for @{$before};
99 return $around->{cache}->(@_);
102 elsif (@$after && !@$before) {
103 $modifier_table->{cache} = sub {
105 ((defined wantarray) ?
107 (@rval = $around->{cache}->(@_))
109 ($rval[0] = $around->{cache}->(@_)))
111 $around->{cache}->(@_));
112 $_->(@_) for @{$after};
113 return unless defined wantarray;
114 return wantarray ? @rval : $rval[0];
118 $modifier_table->{cache} = $around->{cache};
127 (blessed($code) && $code->isa('Class::MOP::Method'))
128 || confess "Can only wrap blessed CODE";
129 my $modifier_table = {
139 $_build_wrapped_method->($modifier_table);
140 my $method = $class->SUPER::wrap(sub { $modifier_table->{cache}->(@_) });
141 $MODIFIERS{$method} = $modifier_table;
145 sub get_original_method {
147 $MODIFIERS{$code}->{orig}
148 if exists $MODIFIERS{$code};
151 sub add_before_modifier {
153 my $modifier = shift;
154 (exists $MODIFIERS{$code})
155 || confess "You must first wrap your method before adding a modifier";
157 || confess "Can only ask the package name of a blessed CODE";
158 ('CODE' eq (reftype($code) || ''))
159 || confess "You must supply a CODE reference for a modifier";
160 unshift @{$MODIFIERS{$code}->{before}} => $modifier;
161 $_build_wrapped_method->($MODIFIERS{$code});
164 sub add_after_modifier {
166 my $modifier = shift;
167 (exists $MODIFIERS{$code})
168 || confess "You must first wrap your method before adding a modifier";
170 || confess "Can only ask the package name of a blessed CODE";
171 ('CODE' eq (reftype($code) || ''))
172 || confess "You must supply a CODE reference for a modifier";
173 push @{$MODIFIERS{$code}->{after}} => $modifier;
174 $_build_wrapped_method->($MODIFIERS{$code});
179 # this is another possible canidate for
180 # optimization as well. There is an overhead
181 # associated with the currying that, if
182 # eliminated might make around modifiers
184 my $compile_around_method = sub {{
186 return $f1 unless @_;
188 push @_, sub { $f2->( $f1, @_ ) };
192 sub add_around_modifier {
194 my $modifier = shift;
195 (exists $MODIFIERS{$code})
196 || confess "You must first wrap your method before adding a modifier";
198 || confess "Can only ask the package name of a blessed CODE";
199 ('CODE' eq (reftype($code) || ''))
200 || confess "You must supply a CODE reference for a modifier";
201 unshift @{$MODIFIERS{$code}->{around}->{methods}} => $modifier;
202 $MODIFIERS{$code}->{around}->{cache} = $compile_around_method->(
203 @{$MODIFIERS{$code}->{around}->{methods}},
204 $MODIFIERS{$code}->{orig}
206 $_build_wrapped_method->($MODIFIERS{$code});
218 Class::MOP::Method - Method Meta Object
222 # ... more to come later maybe
226 The Method Protocol is very small, since methods in Perl 5 are just
227 subroutines within the particular package. Basically all we do is to
228 bless the subroutine.
230 Currently this package is largely unused. Future plans are to provide
231 some very simple introspection methods for the methods themselves.
232 Suggestions for this are welcome.
242 This will return a B<Class::MOP::Class> instance which is related
251 =item B<wrap (&code)>
253 This simply blesses the C<&code> reference passed to it.
263 =item B<package_name>
265 =item B<fully_qualified_name>
269 =head1 Class::MOP::Method::Wrapped METHODS
275 =item B<wrap (&code)>
277 This simply blesses the C<&code> reference passed to it.
279 =item B<get_original_method>
287 =item B<add_before_modifier ($code)>
289 =item B<add_after_modifier ($code)>
291 =item B<add_around_modifier ($code)>
297 Stevan Little E<lt>stevan@iinteractive.comE<gt>
299 Yuval Kogman E<lt>nothingmuch@woobling.comE<gt>
301 =head1 COPYRIGHT AND LICENSE
303 Copyright 2006 by Infinity Interactive, Inc.
305 L<http://www.iinteractive.com>
307 This library is free software; you can redistribute it and/or modify
308 it under the same terms as Perl itself.