b274ee21b18d07b048af205479137e9bbca5f3f1
[gitmo/MooseX-AttributeHelpers.git] / lib / MooseX / AttributeHelpers / Base.pm
1
2 package MooseX::AttributeHelpers::Base;
3 use Moose;
4 use Moose::Util::TypeConstraints;
5
6 our $VERSION   = '0.04';
7 our $AUTHORITY = 'cpan:STEVAN';
8
9 extends 'Moose::Meta::Attribute';
10
11 # this is the method map you define ...
12 has 'provides' => (
13     is      => 'ro',
14     isa     => 'HashRef',
15     default => sub {{}}
16 );
17
18 has 'curries' => (
19     is      => 'ro',
20     isa     => 'HashRef',
21     default => sub {{}}
22 );
23
24
25 # these next two are the possible methods
26 # you can use in the 'provides' map.
27
28 # provide a Class or Role which we can
29 # collect the method providers from
30 has 'method_provider' => (
31     is        => 'ro',
32     isa       => 'ClassName',
33     predicate => 'has_method_provider',
34 );
35
36 # or you can provide a HASH ref of anon subs
37 # yourself. This will also collect and store
38 # the methods from a method_provider as well
39 has 'method_constructors' => (
40     is      => 'ro',
41     isa     => 'HashRef',
42     lazy    => 1,
43     default => sub {
44         my $self = shift;
45         return +{} unless $self->has_method_provider;
46         # or grab them from the role/class
47         my $method_provider = $self->method_provider->meta;
48         return +{
49             map {
50                 $_ => $method_provider->get_method($_)
51             } $method_provider->get_method_list
52         };
53     },
54 );
55
56 # extend the parents stuff to make sure
57 # certain bits are now required ...
58 has '+$!default'       => (required => 1);
59 has '+type_constraint' => (required => 1);
60
61 ## Methods called prior to instantiation
62
63 sub helper_type { () }
64
65 sub process_options_for_provides {
66     my ($self, $options) = @_;
67
68     if (my $type = $self->helper_type) {
69         (exists $options->{isa})
70             || confess "You must define a type with the $type metaclass";
71
72         my $isa = $options->{isa};
73
74         unless (blessed($isa) && $isa->isa('Moose::Meta::TypeConstraint')) {
75             $isa = Moose::Util::TypeConstraints::find_or_create_type_constraint($isa);
76         }
77
78         ($isa->is_a_type_of($type))
79             || confess "The type constraint for a $type ($options->{isa}) must be a subtype of $type";
80     }
81 }
82
83 before '_process_options' => sub {
84     my ($self, $name, $options) = @_;
85     $self->process_options_for_provides($options, $name);
86 };
87
88 ## methods called after instantiation
89
90 # this confirms that provides has
91 # all valid possibilities in it
92 sub check_provides_values {
93     my $self = shift;
94
95     my $method_constructors = $self->method_constructors;
96
97     foreach my $key (keys %{$self->provides}) {
98         (exists $method_constructors->{$key})
99             || confess "$key is an unsupported method type";
100     }
101 }
102
103 sub _curry {
104     my $self = shift;
105     my $code = shift;
106
107     my @args = @_;
108     return sub { my $self = shift; $code->($self, @args, @_) };
109 }
110
111 sub _curry_sub {
112     my $self = shift;
113     my $body = shift;
114     my $code = shift;
115
116     warn "installing sub!";
117
118     return sub { my $self = shift; $code->($self, $body, @_) };
119 }
120
121 after 'install_accessors' => sub {
122     my $attr  = shift;
123     my $class = $attr->associated_class;
124
125     # grab the reader and writer methods
126     # as well, this will be useful for
127     # our method provider constructors
128     my $attr_reader = $attr->get_read_method_ref;
129     my $attr_writer = $attr->get_write_method_ref;
130
131
132     # before we install them, lets
133     # make sure they are valid
134     $attr->check_provides_values;
135 #    $attr->check_curries_values;
136
137     my $method_constructors = $attr->method_constructors;
138
139     my $class_name = $class->name;
140
141     while (my ($constructor, $constructed) = each %{$attr->curries}) {
142         my $method_code;
143         while (my ($curried_name, $curried_arg) = each(%$constructed)) {
144             if ($class->has_method($curried_name)) {
145                 confess
146                     "The method ($curried_name) already ".
147                     "exists in class (" . $class->name . ")";
148             }
149             my $body = $method_constructors->{$constructor}->(
150                        $attr,
151                        $attr_reader,
152                        $attr_writer,
153             );
154
155             if (ref $curried_arg eq 'ARRAY') {
156                 $method_code = $attr->_curry($body, @$curried_arg);
157             }
158             elsif (ref $curried_arg eq 'CODE') {
159                 $method_code = $attr->_curry_sub($body, $curried_arg);
160             }
161             else {
162                 confess "curries parameter must be ref type HASH or CODE";
163             }
164
165             my $method = MooseX::AttributeHelpers::Meta::Method::Curried->wrap(
166                 $method_code,
167                 package_name => $class_name,
168                 name => $curried_name,
169             );
170                 
171             $attr->associate_method($method);
172             $class->add_method($curried_name => $method);
173         }
174     }
175
176     foreach my $key (keys %{$attr->provides}) {
177
178         my $method_name = $attr->provides->{$key};
179
180         if ($class->has_method($method_name)) {
181             confess "The method ($method_name) already exists in class (" . $class->name . ")";
182         }
183
184         my $method = MooseX::AttributeHelpers::Meta::Method::Provided->wrap(
185             $method_constructors->{$key}->(
186                 $attr,
187                 $attr_reader,
188                 $attr_writer,
189             ),
190             package_name => $class_name,
191             name => $method_name,
192         );
193         
194         $attr->associate_method($method);
195         $class->add_method($method_name => $method);
196     }
197 };
198
199 after 'remove_accessors' => sub {
200     my $attr  = shift;
201     my $class = $attr->associated_class;
202     foreach my $key (keys %{$attr->provides}) {
203         my $method_name = $attr->provides->{$key};
204         my $method = $class->get_method($method_name);
205         $class->remove_method($method_name)
206             if blessed($method) &&
207                $method->isa('MooseX::AttributeHelpers::Meta::Method::Provided');
208     }
209 };
210
211 no Moose;
212 no Moose::Util::TypeConstraints;
213
214 1;
215
216 __END__
217
218 =pod
219
220 =head1 NAME
221
222 MooseX::AttributeHelpers::Base - Base class for attribute helpers
223
224 =head1 DESCRIPTION
225
226 Documentation to come.
227
228 =head1 ATTRIBUTES
229
230 =over 4
231
232 =item B<provides>
233
234 =item B<method_provider>
235
236 =item B<method_constructors>
237
238 =back
239
240 =head1 EXTENDED ATTRIBUTES
241
242 =over 4
243
244 =item B<$!default>
245
246 C<$!default> is now required.
247
248 =item B<type_constraint>
249
250 C<type_constraint> is now required.
251
252 =back
253
254 =head1 METHODS
255
256 =over 4
257
258 =item B<meta>
259
260 =item B<helper_type>
261
262 =item B<check_provides_values>
263
264 =item B<has_default>
265
266 =item B<has_method_provider>
267
268 =item B<has_type_constraint>
269
270 =item B<install_accessors>
271
272 =item B<remove_accessors>
273
274 =item B<process_options_for_provides>
275
276 =back
277
278 =head1 BUGS
279
280 All complex software has bugs lurking in it, and this module is no
281 exception. If you find a bug please either email me, or add the bug
282 to cpan-RT.
283
284 =head1 AUTHOR
285
286 Stevan Little E<lt>stevan@iinteractive.comE<gt>
287
288 =head1 COPYRIGHT AND LICENSE
289
290 Copyright 2007-2008 by Infinity Interactive, Inc.
291
292 L<http://www.iinteractive.com>
293
294 This library is free software; you can redistribute it and/or modify
295 it under the same terms as Perl itself.
296
297 =cut