2 package Class::MOP::Method;
8 use Scalar::Util 'reftype', 'blessed';
11 our $VERSION = '0.02';
16 require Class::MOP::Class;
17 Class::MOP::Class->initialize(blessed($_[0]) || $_[0]);
25 ('CODE' eq (reftype($code) || ''))
26 || confess "You must supply a CODE reference to bless";
27 bless $code => blessed($class) || $class;
35 || confess "Can only ask the package name of a blessed CODE";
36 svref_2object($code)->GV->STASH->NAME;
42 || confess "Can only ask the package name of a blessed CODE";
43 svref_2object($code)->GV->NAME;
46 sub fully_qualified_name {
49 || confess "Can only ask the package name of a blessed CODE";
50 $code->package_name . '::' . $code->name;
53 package Class::MOP::Method::Wrapped;
59 use Scalar::Util 'reftype', 'blessed';
60 use Sub::Name 'subname';
62 our $VERSION = '0.01';
64 our @ISA = ('Class::MOP::Method');
67 # this ugly beast is the result of trying
68 # to micro optimize this as much as possible
69 # while not completely loosing maintainability.
70 # At this point it's "fast enough", after all
71 # you can't get something for nothing :)
72 my $_build_wrapped_method = sub {
73 my $modifier_table = shift;
74 my ($before, $after, $around) = (
75 $modifier_table->{before},
76 $modifier_table->{after},
77 $modifier_table->{around},
79 if (@$before && @$after) {
80 $modifier_table->{cache} = sub {
81 $_->(@_) for @{$before};
83 ((defined wantarray) ?
85 (@rval = $around->{cache}->(@_))
87 ($rval[0] = $around->{cache}->(@_)))
89 $around->{cache}->(@_));
90 $_->(@_) for @{$after};
91 return unless defined wantarray;
92 return wantarray ? @rval : $rval[0];
95 elsif (@$before && !@$after) {
96 $modifier_table->{cache} = sub {
97 $_->(@_) for @{$before};
98 return $around->{cache}->(@_);
101 elsif (@$after && !@$before) {
102 $modifier_table->{cache} = sub {
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];
117 $modifier_table->{cache} = $around->{cache};
126 (blessed($code) && $code->isa('Class::MOP::Method'))
127 || confess "Can only wrap blessed CODE";
128 my $modifier_table = {
138 $_build_wrapped_method->($modifier_table);
139 my $method = $class->SUPER::wrap(sub { $modifier_table->{cache}->(@_) });
140 $MODIFIERS{$method} = $modifier_table;
144 sub get_original_method {
146 $MODIFIERS{$code}->{orig}
147 if exists $MODIFIERS{$code};
150 sub add_before_modifier {
152 my $modifier = shift;
153 (exists $MODIFIERS{$code})
154 || confess "You must first wrap your method before adding a modifier";
156 || confess "Can only ask the package name of a blessed CODE";
157 ('CODE' eq (reftype($code) || ''))
158 || confess "You must supply a CODE reference for a modifier";
159 unshift @{$MODIFIERS{$code}->{before}} => $modifier;
160 $_build_wrapped_method->($MODIFIERS{$code});
163 sub add_after_modifier {
165 my $modifier = shift;
166 (exists $MODIFIERS{$code})
167 || confess "You must first wrap your method before adding a modifier";
169 || confess "Can only ask the package name of a blessed CODE";
170 ('CODE' eq (reftype($code) || ''))
171 || confess "You must supply a CODE reference for a modifier";
172 push @{$MODIFIERS{$code}->{after}} => $modifier;
173 $_build_wrapped_method->($MODIFIERS{$code});
178 # this is another possible canidate for
179 # optimization as well. There is an overhead
180 # associated with the currying that, if
181 # eliminated might make around modifiers
183 my $compile_around_method = sub {{
185 return $f1 unless @_;
187 push @_, sub { $f2->( $f1, @_ ) };
191 sub add_around_modifier {
193 my $modifier = shift;
194 (exists $MODIFIERS{$code})
195 || confess "You must first wrap your method before adding a modifier";
197 || confess "Can only ask the package name of a blessed CODE";
198 ('CODE' eq (reftype($code) || ''))
199 || confess "You must supply a CODE reference for a modifier";
200 unshift @{$MODIFIERS{$code}->{around}->{methods}} => $modifier;
201 $MODIFIERS{$code}->{around}->{cache} = $compile_around_method->(
202 @{$MODIFIERS{$code}->{around}->{methods}},
203 $MODIFIERS{$code}->{orig}
205 $_build_wrapped_method->($MODIFIERS{$code});
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.
262 =item B<package_name>
264 =item B<fully_qualified_name>
268 =head1 Class::MOP::Method::Wrapped METHODS
274 =item B<wrap (&code)>
276 This simply blesses the C<&code> reference passed to it.
278 =item B<get_original_method>
286 =item B<add_before_modifier ($code)>
288 =item B<add_after_modifier ($code)>
290 =item B<add_around_modifier ($code)>
296 Stevan Little E<lt>stevan@iinteractive.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.