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 add_before_modifier {
146 my $modifier = shift;
147 (exists $MODIFIERS{$code})
148 || confess "You must first wrap your method before adding a modifier";
150 || confess "Can only ask the package name of a blessed CODE";
151 ('CODE' eq (reftype($code) || ''))
152 || confess "You must supply a CODE reference for a modifier";
153 unshift @{$MODIFIERS{$code}->{before}} => $modifier;
154 $_build_wrapped_method->($MODIFIERS{$code});
157 sub add_after_modifier {
159 my $modifier = shift;
160 (exists $MODIFIERS{$code})
161 || confess "You must first wrap your method before adding a modifier";
163 || confess "Can only ask the package name of a blessed CODE";
164 ('CODE' eq (reftype($code) || ''))
165 || confess "You must supply a CODE reference for a modifier";
166 push @{$MODIFIERS{$code}->{after}} => $modifier;
167 $_build_wrapped_method->($MODIFIERS{$code});
172 # this is another possible canidate for
173 # optimization as well. There is an overhead
174 # associated with the currying that, if
175 # eliminated might make around modifiers
177 my $compile_around_method = sub {{
179 return $f1 unless @_;
181 push @_, sub { $f2->( $f1, @_ ) };
185 sub add_around_modifier {
187 my $modifier = shift;
188 (exists $MODIFIERS{$code})
189 || confess "You must first wrap your method before adding a modifier";
191 || confess "Can only ask the package name of a blessed CODE";
192 ('CODE' eq (reftype($code) || ''))
193 || confess "You must supply a CODE reference for a modifier";
194 unshift @{$MODIFIERS{$code}->{around}->{methods}} => $modifier;
195 $MODIFIERS{$code}->{around}->{cache} = $compile_around_method->(
196 @{$MODIFIERS{$code}->{around}->{methods}},
197 $MODIFIERS{$code}->{orig}
199 $_build_wrapped_method->($MODIFIERS{$code});
211 Class::MOP::Method - Method Meta Object
215 # ... more to come later maybe
219 The Method Protocol is very small, since methods in Perl 5 are just
220 subroutines within the particular package. Basically all we do is to
221 bless the subroutine.
223 Currently this package is largely unused. Future plans are to provide
224 some very simple introspection methods for the methods themselves.
225 Suggestions for this are welcome.
235 This will return a B<Class::MOP::Class> instance which is related
244 =item B<wrap (&code)>
246 This simply blesses the C<&code> reference passed to it.
256 =item B<package_name>
258 =item B<fully_qualified_name>
262 =head1 Class::MOP::Method::Wrapped METHODS
268 =item B<wrap (&code)>
270 This simply blesses the C<&code> reference passed to it.
278 =item B<add_before_modifier ($code)>
280 =item B<add_after_modifier ($code)>
282 =item B<add_around_modifier ($code)>
288 Stevan Little E<lt>stevan@iinteractive.comE<gt>
290 =head1 COPYRIGHT AND LICENSE
292 Copyright 2006 by Infinity Interactive, Inc.
294 L<http://www.iinteractive.com>
296 This library is free software; you can redistribute it and/or modify
297 it under the same terms as Perl itself.