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; |
2eb717d5 |
25 | (reftype($code) && reftype($code) eq 'CODE') |
de19f115 |
26 | || confess "You must supply a CODE reference to bless"; |
27 | bless $code => blessed($class) || $class; |
28 | } |
29 | |
30 | { |
31 | my %MODIFIERS; |
32 | |
33 | sub wrap { |
34 | my $code = shift; |
35 | (blessed($code)) |
36 | || confess "Can only ask the package name of a blessed CODE"; |
37 | my $modifier_table = { before => [], after => [] }; |
38 | my $method = $code->new(sub { |
39 | $_->(@_) for @{$modifier_table->{before}}; |
40 | # NOTE: |
41 | # we actually need to be sure to preserve |
42 | # the calling context and call this method |
43 | # with the same context too. This just |
44 | # requires some bookkeeping code, thats all. |
45 | my @rval = $code->(@_); |
46 | $_->(@_) for @{$modifier_table->{after}}; |
47 | return wantarray ? @rval : $rval[0]; |
48 | }); |
49 | $MODIFIERS{$method} = $modifier_table; |
50 | $method; |
51 | } |
52 | |
53 | sub add_before_modifier { |
54 | my $code = shift; |
55 | my $modifier = shift; |
56 | (exists $MODIFIERS{$code}) |
57 | || confess "You must first wrap your method before adding a modifier"; |
58 | (blessed($code)) |
59 | || confess "Can only ask the package name of a blessed CODE"; |
60 | (reftype($modifier) && reftype($modifier) eq 'CODE') |
61 | || confess "You must supply a CODE reference for a modifier"; |
62 | unshift @{$MODIFIERS{$code}->{before}} => $modifier; |
63 | } |
64 | |
65 | sub add_after_modifier { |
66 | my $code = shift; |
67 | my $modifier = shift; |
68 | (exists $MODIFIERS{$code}) |
69 | || confess "You must first wrap your method before adding a modifier"; |
70 | (blessed($code)) |
71 | || confess "Can only ask the package name of a blessed CODE"; |
72 | (reftype($modifier) && reftype($modifier) eq 'CODE') |
73 | || confess "You must supply a CODE reference for a modifier"; |
74 | push @{$MODIFIERS{$code}->{after}} => $modifier; |
75 | } |
76 | } |
77 | |
78 | # informational |
79 | |
80 | sub package_name { |
81 | my $code = shift; |
82 | (blessed($code)) |
83 | || confess "Can only ask the package name of a blessed CODE"; |
84 | svref_2object($code)->GV->STASH->NAME; |
85 | } |
86 | |
87 | sub name { |
88 | my $code = shift; |
89 | (blessed($code)) |
90 | || confess "Can only ask the package name of a blessed CODE"; |
91 | svref_2object($code)->GV->NAME; |
2eb717d5 |
92 | } |
de19f115 |
93 | |
8b978dd5 |
94 | 1; |
95 | |
96 | __END__ |
97 | |
98 | =pod |
99 | |
100 | =head1 NAME |
101 | |
102 | Class::MOP::Method - Method Meta Object |
103 | |
104 | =head1 SYNOPSIS |
105 | |
fe122940 |
106 | # ... more to come later maybe |
107 | |
8b978dd5 |
108 | =head1 DESCRIPTION |
109 | |
552e3d24 |
110 | The Method Protocol is very small, since methods in Perl 5 are just |
111 | subroutines within the particular package. Basically all we do is to |
fe122940 |
112 | bless the subroutine. |
113 | |
114 | Currently this package is largely unused. Future plans are to provide |
115 | some very simple introspection methods for the methods themselves. |
116 | Suggestions for this are welcome. |
552e3d24 |
117 | |
2eb717d5 |
118 | =head1 METHODS |
119 | |
de19f115 |
120 | =head2 Introspection |
2eb717d5 |
121 | |
de19f115 |
122 | =over 4 |
fe122940 |
123 | |
2eb717d5 |
124 | =item B<meta> |
125 | |
fe122940 |
126 | This will return a B<Class::MOP::Class> instance which is related |
127 | to this class. |
128 | |
2eb717d5 |
129 | =back |
130 | |
de19f115 |
131 | =head2 Construction |
132 | |
133 | =over 4 |
134 | |
135 | =item B<new (&code)> |
136 | |
137 | This simply blesses the C<&code> reference passed to it. |
138 | |
139 | =back |
140 | |
141 | =head2 Informational |
142 | |
143 | =over 4 |
144 | |
145 | =item B<name> |
146 | |
147 | =item B<package_name> |
148 | |
149 | =back |
150 | |
151 | =head1 SEE ALSO |
152 | |
153 | http://dirtsimple.org/2005/01/clos-style-method-combination-for.html |
154 | |
155 | http://www.gigamonkeys.com/book/object-reorientation-generic-functions.html |
156 | |
8b978dd5 |
157 | =head1 AUTHOR |
158 | |
a2e85e6c |
159 | Stevan Little E<lt>stevan@iinteractive.comE<gt> |
8b978dd5 |
160 | |
161 | =head1 COPYRIGHT AND LICENSE |
162 | |
163 | Copyright 2006 by Infinity Interactive, Inc. |
164 | |
165 | L<http://www.iinteractive.com> |
166 | |
167 | This library is free software; you can redistribute it and/or modify |
168 | it under the same terms as Perl itself. |
169 | |
170 | =cut |