Commit | Line | Data |
8b978dd5 |
1 | |
2 | package Class::MOP::Method; |
3 | |
4 | use strict; |
5 | use warnings; |
6 | |
2eb717d5 |
7 | use Carp 'confess'; |
aa448b16 |
8 | use Scalar::Util 'reftype', 'blessed'; |
de19f115 |
9 | use B 'svref_2object'; |
2eb717d5 |
10 | |
de19f115 |
11 | our $VERSION = '0.02'; |
12 | |
13 | # introspection |
2eb717d5 |
14 | |
727919c5 |
15 | sub meta { |
16 | require Class::MOP::Class; |
aa448b16 |
17 | Class::MOP::Class->initialize(blessed($_[0]) || $_[0]); |
727919c5 |
18 | } |
2eb717d5 |
19 | |
de19f115 |
20 | # construction |
21 | |
22 | sub new { |
2eb717d5 |
23 | my $class = shift; |
24 | my $code = shift; |
ee5e71d4 |
25 | ('CODE' eq (reftype($code) || '')) |
de19f115 |
26 | || confess "You must supply a CODE reference to bless"; |
27 | bless $code => blessed($class) || $class; |
28 | } |
29 | |
de19f115 |
30 | # informational |
31 | |
32 | sub package_name { |
33 | my $code = shift; |
34 | (blessed($code)) |
35 | || confess "Can only ask the package name of a blessed CODE"; |
36 | svref_2object($code)->GV->STASH->NAME; |
37 | } |
38 | |
39 | sub name { |
40 | my $code = shift; |
41 | (blessed($code)) |
42 | || confess "Can only ask the package name of a blessed CODE"; |
43 | svref_2object($code)->GV->NAME; |
2eb717d5 |
44 | } |
de19f115 |
45 | |
ddc8edba |
46 | package Class::MOP::Method::Wrapped; |
47 | |
48 | use strict; |
49 | use warnings; |
50 | |
51 | use Carp 'confess'; |
52 | use Scalar::Util 'reftype', 'blessed'; |
53 | |
54 | our $VERSION = '0.01'; |
55 | |
56 | our @ISA = ('Class::MOP::Method'); |
57 | |
58 | my %MODIFIERS; |
59 | |
60 | sub wrap { |
61 | my $class = shift; |
62 | my $code = shift; |
63 | (blessed($code) && $code->isa('Class::MOP::Method')) |
64 | || confess "Can only wrap blessed CODE"; |
65 | my $modifier_table = { |
66 | orig => $code, |
67 | before => [], |
68 | after => [], |
69 | around => { |
70 | cache => $code, |
71 | methods => [], |
72 | }, |
73 | }; |
74 | my $method = $class->new(sub { |
75 | $_->(@_) for @{$modifier_table->{before}}; |
76 | my (@rlist, $rval); |
77 | if (defined wantarray) { |
78 | if (wantarray) { |
79 | @rlist = $modifier_table->{around}->{cache}->(@_); |
80 | } |
81 | else { |
82 | $rval = $modifier_table->{around}->{cache}->(@_); |
83 | } |
84 | } |
85 | else { |
86 | $modifier_table->{around}->{cache}->(@_); |
87 | } |
88 | $_->(@_) for @{$modifier_table->{after}}; |
89 | return unless defined wantarray; |
90 | return wantarray ? @rlist : $rval; |
91 | }); |
92 | $MODIFIERS{$method} = $modifier_table; |
93 | $method; |
94 | } |
95 | |
96 | sub add_before_modifier { |
97 | my $code = shift; |
98 | my $modifier = shift; |
99 | (exists $MODIFIERS{$code}) |
100 | || confess "You must first wrap your method before adding a modifier"; |
101 | (blessed($code)) |
102 | || confess "Can only ask the package name of a blessed CODE"; |
103 | ('CODE' eq (reftype($code) || '')) |
104 | || confess "You must supply a CODE reference for a modifier"; |
105 | unshift @{$MODIFIERS{$code}->{before}} => $modifier; |
106 | } |
107 | |
108 | sub add_after_modifier { |
109 | my $code = shift; |
110 | my $modifier = shift; |
111 | (exists $MODIFIERS{$code}) |
112 | || confess "You must first wrap your method before adding a modifier"; |
113 | (blessed($code)) |
114 | || confess "Can only ask the package name of a blessed CODE"; |
115 | ('CODE' eq (reftype($code) || '')) |
116 | || confess "You must supply a CODE reference for a modifier"; |
117 | push @{$MODIFIERS{$code}->{after}} => $modifier; |
118 | } |
119 | |
120 | { |
121 | my $compile_around_method = sub {{ |
122 | my $f1 = pop; |
123 | return $f1 unless @_; |
124 | my $f2 = pop; |
125 | push @_, sub { $f2->( $f1, @_ ) }; |
126 | redo; |
127 | }}; |
128 | |
129 | sub add_around_modifier { |
130 | my $code = shift; |
131 | my $modifier = shift; |
132 | (exists $MODIFIERS{$code}) |
133 | || confess "You must first wrap your method before adding a modifier"; |
134 | (blessed($code)) |
135 | || confess "Can only ask the package name of a blessed CODE"; |
136 | ('CODE' eq (reftype($code) || '')) |
137 | || confess "You must supply a CODE reference for a modifier"; |
138 | unshift @{$MODIFIERS{$code}->{around}->{methods}} => $modifier; |
139 | $MODIFIERS{$code}->{around}->{cache} = $compile_around_method->( |
140 | @{$MODIFIERS{$code}->{around}->{methods}}, |
141 | $MODIFIERS{$code}->{orig} |
142 | ); |
143 | } |
144 | } |
145 | |
8b978dd5 |
146 | 1; |
147 | |
148 | __END__ |
149 | |
150 | =pod |
151 | |
152 | =head1 NAME |
153 | |
154 | Class::MOP::Method - Method Meta Object |
155 | |
156 | =head1 SYNOPSIS |
157 | |
fe122940 |
158 | # ... more to come later maybe |
159 | |
8b978dd5 |
160 | =head1 DESCRIPTION |
161 | |
552e3d24 |
162 | The Method Protocol is very small, since methods in Perl 5 are just |
163 | subroutines within the particular package. Basically all we do is to |
fe122940 |
164 | bless the subroutine. |
165 | |
166 | Currently this package is largely unused. Future plans are to provide |
167 | some very simple introspection methods for the methods themselves. |
168 | Suggestions for this are welcome. |
552e3d24 |
169 | |
2eb717d5 |
170 | =head1 METHODS |
171 | |
de19f115 |
172 | =head2 Introspection |
2eb717d5 |
173 | |
de19f115 |
174 | =over 4 |
fe122940 |
175 | |
2eb717d5 |
176 | =item B<meta> |
177 | |
fe122940 |
178 | This will return a B<Class::MOP::Class> instance which is related |
179 | to this class. |
180 | |
2eb717d5 |
181 | =back |
182 | |
de19f115 |
183 | =head2 Construction |
184 | |
185 | =over 4 |
186 | |
187 | =item B<new (&code)> |
188 | |
189 | This simply blesses the C<&code> reference passed to it. |
190 | |
ee5e71d4 |
191 | =item B<wrap> |
192 | |
193 | This wraps an existing method so that it can handle method modifiers. |
194 | |
de19f115 |
195 | =back |
196 | |
197 | =head2 Informational |
198 | |
199 | =over 4 |
200 | |
201 | =item B<name> |
202 | |
203 | =item B<package_name> |
204 | |
205 | =back |
206 | |
ee5e71d4 |
207 | =head2 Modifiers |
208 | |
209 | =over 4 |
de19f115 |
210 | |
ee5e71d4 |
211 | =item B<add_before_modifier ($code)> |
de19f115 |
212 | |
ee5e71d4 |
213 | =item B<add_after_modifier ($code)> |
214 | |
215 | =item B<add_around_modifier ($code)> |
216 | |
217 | =back |
de19f115 |
218 | |
8b978dd5 |
219 | =head1 AUTHOR |
220 | |
a2e85e6c |
221 | Stevan Little E<lt>stevan@iinteractive.comE<gt> |
8b978dd5 |
222 | |
223 | =head1 COPYRIGHT AND LICENSE |
224 | |
225 | Copyright 2006 by Infinity Interactive, Inc. |
226 | |
227 | L<http://www.iinteractive.com> |
228 | |
229 | This library is free software; you can redistribute it and/or modify |
230 | it under the same terms as Perl itself. |
231 | |
232 | =cut |