Commit | Line | Data |
d26633fc |
1 | package MooseX::AttributeHelpers::Base; |
2 | use Moose; |
8ba40fb0 |
3 | use Moose::Util::TypeConstraints; |
786dbc3d |
4 | use MooseX::AttributeHelpers::MethodProvider; |
8683383a |
5 | use MooseX::AttributeHelpers::Meta::Method::Provided; |
d26633fc |
6 | |
999f34a9 |
7 | our $VERSION = '0.04'; |
d26633fc |
8 | our $AUTHORITY = 'cpan:STEVAN'; |
9 | |
10 | extends 'Moose::Meta::Attribute'; |
11 | |
8e3fab6d |
12 | # this is the method map you define ... |
d26633fc |
13 | has 'provides' => ( |
9810162d |
14 | is => 'ro', |
15 | isa => 'HashRef', |
16 | default => sub {{}} |
d26633fc |
17 | ); |
18 | |
999f34a9 |
19 | # extend the parents stuff to make sure |
8881a8d3 |
20 | # certain bits are now required ... |
d26633fc |
21 | has '+$!default' => (required => 1); |
22 | has '+type_constraint' => (required => 1); |
23 | |
8ba40fb0 |
24 | ## Methods called prior to instantiation |
25 | |
786dbc3d |
26 | # For overriding |
8683383a |
27 | sub default_options {} |
28 | sub auto_provide {0} |
d26633fc |
29 | |
786dbc3d |
30 | # Do not override both of these things. You will be eaten. |
31 | sub method_provider {} |
32 | sub method_constructors { |
33 | get_provider_methods($_[0]->method_provider, ':all') |
34 | } |
35 | |
8ba40fb0 |
36 | sub process_options_for_provides { |
d26633fc |
37 | my ($self, $options) = @_; |
999f34a9 |
38 | |
8683383a |
39 | if (my $defaults = $self->default_options) { |
40 | foreach my $key (keys %$defaults) { |
41 | $options->{$key} = $defaults->{$key} |
42 | unless exists $options->{$key}; |
43 | } |
44 | } |
45 | |
786dbc3d |
46 | return unless $self->method_provider; |
47 | my $type = get_provider_type($self->method_provider); |
48 | $options->{isa} = $type unless exists $options->{isa}; |
49 | my $isa = $options->{isa}; |
50 | |
51 | unless (blessed($isa) && $isa->isa('Moose::Meta::TypeConstraint')) { |
52 | $isa = Moose::Util::TypeConstraints::find_or_create_type_constraint( |
53 | $isa |
54 | ); |
8ba40fb0 |
55 | } |
786dbc3d |
56 | |
57 | confess "The type constraint for a $type ($options->{isa}) " |
58 | . "must be a subtype of $type" |
59 | unless $isa->is_a_type_of($type); |
d26633fc |
60 | } |
61 | |
62 | before '_process_options' => sub { |
88aaf2bd |
63 | my ($self, $name, $options) = @_; |
38abf787 |
64 | $self->process_options_for_provides($options, $name); |
d26633fc |
65 | }; |
66 | |
8ba40fb0 |
67 | ## methods called after instantiation |
68 | |
999f34a9 |
69 | # this confirms that provides has |
8ba40fb0 |
70 | # all valid possibilities in it |
71 | sub check_provides_values { |
72 | my $self = shift; |
999f34a9 |
73 | |
8ba40fb0 |
74 | my $method_constructors = $self->method_constructors; |
999f34a9 |
75 | |
8ba40fb0 |
76 | foreach my $key (keys %{$self->provides}) { |
77 | (exists $method_constructors->{$key}) |
78 | || confess "$key is an unsupported method type"; |
79 | } |
8683383a |
80 | |
81 | my $provides = $self->provides; |
82 | if (keys %$provides == 0 and $self->auto_provide) { |
83 | my $attr_name = $self->name; |
84 | |
85 | foreach my $method (keys %$method_constructors) { |
86 | $provides->{$method} = "${method}_${attr_name}"; |
87 | } |
88 | } |
8ba40fb0 |
89 | } |
90 | |
d26633fc |
91 | after 'install_accessors' => sub { |
92 | my $attr = shift; |
93 | my $class = $attr->associated_class; |
999f34a9 |
94 | |
457dc4fb |
95 | # grab the reader and writer methods |
999f34a9 |
96 | # as well, this will be useful for |
457dc4fb |
97 | # our method provider constructors |
9a976497 |
98 | my $attr_reader = $attr->get_read_method_ref; |
99 | my $attr_writer = $attr->get_write_method_ref; |
999f34a9 |
100 | |
d26633fc |
101 | |
88aaf2bd |
102 | # before we install them, lets |
103 | # make sure they are valid |
999f34a9 |
104 | $attr->check_provides_values; |
88aaf2bd |
105 | |
d26633fc |
106 | my $method_constructors = $attr->method_constructors; |
999f34a9 |
107 | |
d26633fc |
108 | foreach my $key (keys %{$attr->provides}) { |
999f34a9 |
109 | |
110 | my $method_name = $attr->provides->{$key}; |
111 | |
9a976497 |
112 | if ($class->has_method($method_name)) { |
113 | confess "The method ($method_name) already exists in class (" . $class->name . ")"; |
999f34a9 |
114 | } |
115 | |
116 | my $method = MooseX::AttributeHelpers::Meta::Method::Provided->wrap( |
117 | $method_constructors->{$key}->( |
118 | $attr, |
119 | $attr_reader, |
120 | $attr_writer, |
8f7951c9 |
121 | ) |
d26633fc |
122 | ); |
999f34a9 |
123 | |
124 | $attr->associate_method($method); |
125 | $class->add_method($method_name => $method); |
126 | } |
127 | }; |
128 | |
129 | after 'remove_accessors' => sub { |
130 | my $attr = shift; |
131 | my $class = $attr->associated_class; |
132 | foreach my $key (keys %{$attr->provides}) { |
133 | my $method_name = $attr->provides->{$key}; |
134 | my $method = $class->get_method($method_name); |
135 | $class->remove_method($method_name) |
136 | if blessed($method) && |
137 | $method->isa('MooseX::AttributeHelpers::Meta::Method::Provided'); |
d26633fc |
138 | } |
139 | }; |
140 | |
786dbc3d |
141 | sub sugar { |
142 | my ($class, %info) = @_; |
143 | my $meta = $class->meta; |
144 | |
145 | $meta->add_method('default_options', sub {$info{default_options}}); |
146 | $meta->add_method('auto_provide', sub {$info{auto_provide} || 0}); |
147 | |
148 | my $provider = $info{method_provider}; |
149 | my $constructors = $info{method_constructors}; |
150 | |
151 | confess "Supply either method_provider or method_constructors" |
152 | if ($provider && $constructors) || !($provider || $constructors); |
153 | |
154 | if(my $provider = $info{method_provider}) { |
155 | $meta->add_method('method_provider' => sub { $provider }); |
156 | } |
157 | elsif (my $cons = $info{method_constructors}) { |
158 | $meta->add_method('method_constructors' => sub { $cons }); |
159 | } |
160 | |
161 | if (my $s = $info{shortcut}) { |
162 | $meta->create("Moose::Meta::Attribute::Custom::$s", |
163 | methods => {register_implementation => sub { $class }}, |
164 | ); |
165 | } |
166 | } |
167 | |
d26633fc |
168 | no Moose; |
8ba40fb0 |
169 | no Moose::Util::TypeConstraints; |
d26633fc |
170 | |
171 | 1; |
172 | |
173 | __END__ |
174 | |
175 | =pod |
176 | |
177 | =head1 NAME |
178 | |
5431dff2 |
179 | MooseX::AttributeHelpers::Base - Base class for attribute helpers |
999f34a9 |
180 | |
786dbc3d |
181 | SYNOPSIS |
182 | |
183 | package MooseX::AttributeHelpers::Counter; |
184 | use Moose; |
185 | use MooseX::AttributeHelpers::MethodProvider::Counter; |
186 | |
187 | extends 'MooseX::AttributeHelpers::Base'; |
188 | |
189 | __PACKAGE__->sugar( |
190 | default_options => { |
191 | is => 'ro', |
192 | default => 0, |
193 | }, |
194 | |
195 | auto_provide => 1, |
196 | method_provider => 'Counter', |
197 | shortcut => 'Counter', |
198 | ); |
199 | |
200 | no Moose; |
201 | |
202 | 1; |
203 | |
d26633fc |
204 | =head1 DESCRIPTION |
205 | |
8683383a |
206 | This class is what you inherit from when you want to make a new |
786dbc3d |
207 | AttributeHelper metaclass. Most of the work is done for you by the class |
208 | method I<sugar> if you're doing something basic. |
e295d072 |
209 | |
210 | =head1 ATTRIBUTES |
211 | |
5431dff2 |
212 | =over 4 |
213 | |
214 | =item B<provides> |
e295d072 |
215 | |
8683383a |
216 | This is the map of metaclass methods to methods that will be installed in your |
217 | class, e.g. add => 'add_to_number'. |
218 | |
5431dff2 |
219 | =back |
e295d072 |
220 | |
221 | =head1 EXTENDED ATTRIBUTES |
222 | |
5431dff2 |
223 | =over 4 |
224 | |
225 | =item B<$!default> |
e295d072 |
226 | |
227 | C<$!default> is now required. |
228 | |
5431dff2 |
229 | =item B<type_constraint> |
e295d072 |
230 | |
231 | C<type_constraint> is now required. |
232 | |
5431dff2 |
233 | =back |
234 | |
d26633fc |
235 | =head1 METHODS |
236 | |
5431dff2 |
237 | =over 4 |
238 | |
786dbc3d |
239 | =item B<method_provider> |
240 | |
241 | The name of a method provider. Usually one L<use|perlfunc/use>s a package |
242 | that defines a method provider in the registry first, but you can just as well |
243 | define one in your own code. See L<MooseX::AttributeHelpers::MethodProvider> |
244 | for details. |
245 | |
246 | =item B<method_constructors> |
247 | |
248 | You can optionally supply a hashref of names to subs instead of a class to be |
249 | used as method constructors. In that case, your methods won't be available |
250 | for use by L<Composite|MooseX::AttributeHelpers::Composite>. |
b91f57af |
251 | |
8683383a |
252 | =item B<auto_provide> |
253 | |
254 | If this method returns a true value, all available method constructors will be |
255 | provided in the format $method_$attribute_name e.g. inc_counter. This is |
256 | intended to be overridden in subclasses. |
257 | |
258 | =item B<default_options> |
259 | |
260 | Returns a Maybe[Hashref] of attribution specifications to fill in if they are |
261 | not overridden by the implementing attribute. This is intended to be |
262 | overridden in subclasses. |
263 | |
786dbc3d |
264 | =item B<sugar> |
5431dff2 |
265 | |
786dbc3d |
266 | A convenience method for subclassing declaratively. See L<"SYNOPSIS"> for an |
267 | example. The shortcut option creates a package under |
268 | Moose::Meta::Attribute::Custom to make it easier for users to find your |
269 | metaclass, but you can do this manually if you desire. |
5431dff2 |
270 | |
8683383a |
271 | =item B<check_provides_values> |
5431dff2 |
272 | |
5431dff2 |
273 | =item B<install_accessors> |
274 | |
999f34a9 |
275 | =item B<remove_accessors> |
276 | |
5431dff2 |
277 | =item B<process_options_for_provides> |
278 | |
786dbc3d |
279 | These are hooks you can use to change the behavior of the metaclass; read the |
280 | source for inspiration. |
281 | |
5431dff2 |
282 | =back |
e295d072 |
283 | |
d26633fc |
284 | =head1 BUGS |
285 | |
999f34a9 |
286 | All complex software has bugs lurking in it, and this module is no |
d26633fc |
287 | exception. If you find a bug please either email me, or add the bug |
288 | to cpan-RT. |
289 | |
290 | =head1 AUTHOR |
291 | |
292 | Stevan Little E<lt>stevan@iinteractive.comE<gt> |
293 | |
294 | =head1 COPYRIGHT AND LICENSE |
295 | |
99c62fb8 |
296 | Copyright 2007-2008 by Infinity Interactive, Inc. |
d26633fc |
297 | |
298 | L<http://www.iinteractive.com> |
299 | |
300 | This library is free software; you can redistribute it and/or modify |
301 | it under the same terms as Perl itself. |
302 | |
8a9cea9b |
303 | =cut |