Commit | Line | Data |
a40b446a |
1 | package Moose::Meta::Attribute::Trait::Native::MethodProvider::Array; |
e3c07b19 |
2 | use Moose::Role; |
3 | |
96539d20 |
4 | our $VERSION = '0.87'; |
e3c07b19 |
5 | $VERSION = eval $VERSION; |
6 | our $AUTHORITY = 'cpan:STEVAN'; |
7 | |
e11fb12c |
8 | sub count : method { |
9 | my ( $attr, $reader, $writer ) = @_; |
10 | return sub { |
11 | scalar @{ $reader->( $_[0] ) }; |
12 | }; |
13 | } |
14 | |
15 | sub empty : method { |
16 | my ( $attr, $reader, $writer ) = @_; |
17 | return sub { |
18 | scalar @{ $reader->( $_[0] ) } ? 1 : 0; |
19 | }; |
20 | } |
21 | |
22 | sub find : method { |
23 | my ( $attr, $reader, $writer ) = @_; |
24 | return sub { |
25 | my ( $instance, $predicate ) = @_; |
26 | foreach my $val ( @{ $reader->($instance) } ) { |
27 | return $val if $predicate->($val); |
28 | } |
29 | return; |
30 | }; |
31 | } |
32 | |
33 | sub map : method { |
34 | my ( $attr, $reader, $writer ) = @_; |
35 | return sub { |
36 | my ( $instance, $f ) = @_; |
37 | CORE::map { $f->($_) } @{ $reader->($instance) }; |
38 | }; |
39 | } |
40 | |
41 | sub sort : method { |
42 | my ( $attr, $reader, $writer ) = @_; |
43 | return sub { |
44 | my ( $instance, $predicate ) = @_; |
45 | die "Argument must be a code reference" |
46 | if $predicate && ref $predicate ne 'CODE'; |
47 | |
48 | if ($predicate) { |
49 | CORE::sort { $predicate->( $a, $b ) } @{ $reader->($instance) }; |
50 | } |
51 | else { |
52 | CORE::sort @{ $reader->($instance) }; |
53 | } |
54 | }; |
55 | } |
56 | |
57 | sub grep : method { |
58 | my ( $attr, $reader, $writer ) = @_; |
59 | return sub { |
60 | my ( $instance, $predicate ) = @_; |
61 | CORE::grep { $predicate->($_) } @{ $reader->($instance) }; |
62 | }; |
63 | } |
64 | |
65 | sub elements : method { |
66 | my ( $attr, $reader, $writer ) = @_; |
67 | return sub { |
68 | my ($instance) = @_; |
69 | @{ $reader->($instance) }; |
70 | }; |
71 | } |
72 | |
73 | sub join : method { |
74 | my ( $attr, $reader, $writer ) = @_; |
75 | return sub { |
76 | my ( $instance, $separator ) = @_; |
77 | join $separator, @{ $reader->($instance) }; |
78 | }; |
79 | } |
80 | |
81 | sub first : method { |
82 | my ( $attr, $reader, $writer ) = @_; |
83 | return sub { |
84 | $reader->( $_[0] )->[0]; |
85 | }; |
86 | } |
87 | |
88 | sub last : method { |
89 | my ( $attr, $reader, $writer ) = @_; |
90 | return sub { |
91 | $reader->( $_[0] )->[-1]; |
92 | }; |
93 | } |
e3c07b19 |
94 | |
95 | sub push : method { |
046c8b5e |
96 | my ( $attr, $reader, $writer ) = @_; |
97 | |
98 | if ( |
99 | $attr->has_type_constraint |
100 | && $attr->type_constraint->isa( |
101 | 'Moose::Meta::TypeConstraint::Parameterized') |
102 | ) { |
103 | my $container_type_constraint |
104 | = $attr->type_constraint->type_parameter; |
e3c07b19 |
105 | return sub { |
106 | my $instance = CORE::shift; |
107 | $container_type_constraint->check($_) |
046c8b5e |
108 | || confess "Value " |
109 | . ( $_ || 'undef' ) |
110 | . " did not pass container type constraint '$container_type_constraint'" |
111 | foreach @_; |
112 | CORE::push @{ $reader->($instance) } => @_; |
e3c07b19 |
113 | }; |
114 | } |
115 | else { |
116 | return sub { |
117 | my $instance = CORE::shift; |
046c8b5e |
118 | CORE::push @{ $reader->($instance) } => @_; |
e3c07b19 |
119 | }; |
120 | } |
121 | } |
122 | |
123 | sub pop : method { |
046c8b5e |
124 | my ( $attr, $reader, $writer ) = @_; |
e3c07b19 |
125 | return sub { |
046c8b5e |
126 | CORE::pop @{ $reader->( $_[0] ) }; |
e3c07b19 |
127 | }; |
128 | } |
129 | |
130 | sub unshift : method { |
046c8b5e |
131 | my ( $attr, $reader, $writer ) = @_; |
132 | if ( |
133 | $attr->has_type_constraint |
134 | && $attr->type_constraint->isa( |
135 | 'Moose::Meta::TypeConstraint::Parameterized') |
136 | ) { |
137 | my $container_type_constraint |
138 | = $attr->type_constraint->type_parameter; |
e3c07b19 |
139 | return sub { |
140 | my $instance = CORE::shift; |
141 | $container_type_constraint->check($_) |
046c8b5e |
142 | || confess "Value " |
143 | . ( $_ || 'undef' ) |
144 | . " did not pass container type constraint '$container_type_constraint'" |
145 | foreach @_; |
146 | CORE::unshift @{ $reader->($instance) } => @_; |
e3c07b19 |
147 | }; |
148 | } |
149 | else { |
150 | return sub { |
151 | my $instance = CORE::shift; |
046c8b5e |
152 | CORE::unshift @{ $reader->($instance) } => @_; |
e3c07b19 |
153 | }; |
154 | } |
155 | } |
156 | |
157 | sub shift : method { |
046c8b5e |
158 | my ( $attr, $reader, $writer ) = @_; |
e3c07b19 |
159 | return sub { |
046c8b5e |
160 | CORE::shift @{ $reader->( $_[0] ) }; |
e3c07b19 |
161 | }; |
162 | } |
163 | |
164 | sub get : method { |
046c8b5e |
165 | my ( $attr, $reader, $writer ) = @_; |
e3c07b19 |
166 | return sub { |
046c8b5e |
167 | $reader->( $_[0] )->[ $_[1] ]; |
e3c07b19 |
168 | }; |
169 | } |
170 | |
171 | sub set : method { |
046c8b5e |
172 | my ( $attr, $reader, $writer ) = @_; |
173 | if ( |
174 | $attr->has_type_constraint |
175 | && $attr->type_constraint->isa( |
176 | 'Moose::Meta::TypeConstraint::Parameterized') |
177 | ) { |
178 | my $container_type_constraint |
179 | = $attr->type_constraint->type_parameter; |
e3c07b19 |
180 | return sub { |
046c8b5e |
181 | ( $container_type_constraint->check( $_[2] ) ) |
182 | || confess "Value " |
183 | . ( $_[2] || 'undef' ) |
184 | . " did not pass container type constraint '$container_type_constraint'"; |
185 | $reader->( $_[0] )->[ $_[1] ] = $_[2]; |
e3c07b19 |
186 | }; |
187 | } |
188 | else { |
189 | return sub { |
046c8b5e |
190 | $reader->( $_[0] )->[ $_[1] ] = $_[2]; |
e3c07b19 |
191 | }; |
192 | } |
193 | } |
194 | |
195 | sub accessor : method { |
046c8b5e |
196 | my ( $attr, $reader, $writer ) = @_; |
197 | |
198 | if ( |
199 | $attr->has_type_constraint |
200 | && $attr->type_constraint->isa( |
201 | 'Moose::Meta::TypeConstraint::Parameterized') |
202 | ) { |
203 | my $container_type_constraint |
204 | = $attr->type_constraint->type_parameter; |
e3c07b19 |
205 | return sub { |
206 | my $self = shift; |
207 | |
046c8b5e |
208 | if ( @_ == 1 ) { # reader |
209 | return $reader->($self)->[ $_[0] ]; |
e3c07b19 |
210 | } |
046c8b5e |
211 | elsif ( @_ == 2 ) { # writer |
212 | ( $container_type_constraint->check( $_[1] ) ) |
213 | || confess "Value " |
214 | . ( $_[1] || 'undef' ) |
215 | . " did not pass container type constraint '$container_type_constraint'"; |
216 | $reader->($self)->[ $_[0] ] = $_[1]; |
e3c07b19 |
217 | } |
218 | else { |
219 | confess "One or two arguments expected, not " . @_; |
220 | } |
221 | }; |
222 | } |
223 | else { |
224 | return sub { |
225 | my $self = shift; |
226 | |
046c8b5e |
227 | if ( @_ == 1 ) { # reader |
228 | return $reader->($self)->[ $_[0] ]; |
e3c07b19 |
229 | } |
046c8b5e |
230 | elsif ( @_ == 2 ) { # writer |
231 | $reader->($self)->[ $_[0] ] = $_[1]; |
e3c07b19 |
232 | } |
233 | else { |
234 | confess "One or two arguments expected, not " . @_; |
235 | } |
236 | }; |
237 | } |
238 | } |
239 | |
240 | sub clear : method { |
046c8b5e |
241 | my ( $attr, $reader, $writer ) = @_; |
e3c07b19 |
242 | return sub { |
046c8b5e |
243 | @{ $reader->( $_[0] ) } = (); |
e3c07b19 |
244 | }; |
245 | } |
246 | |
247 | sub delete : method { |
046c8b5e |
248 | my ( $attr, $reader, $writer ) = @_; |
e3c07b19 |
249 | return sub { |
046c8b5e |
250 | CORE::splice @{ $reader->( $_[0] ) }, $_[1], 1; |
251 | } |
e3c07b19 |
252 | } |
253 | |
254 | sub insert : method { |
046c8b5e |
255 | my ( $attr, $reader, $writer ) = @_; |
256 | if ( |
257 | $attr->has_type_constraint |
258 | && $attr->type_constraint->isa( |
259 | 'Moose::Meta::TypeConstraint::Parameterized') |
260 | ) { |
261 | my $container_type_constraint |
262 | = $attr->type_constraint->type_parameter; |
e3c07b19 |
263 | return sub { |
046c8b5e |
264 | ( $container_type_constraint->check( $_[2] ) ) |
265 | || confess "Value " |
266 | . ( $_[2] || 'undef' ) |
267 | . " did not pass container type constraint '$container_type_constraint'"; |
268 | CORE::splice @{ $reader->( $_[0] ) }, $_[1], 0, $_[2]; |
e3c07b19 |
269 | }; |
270 | } |
271 | else { |
272 | return sub { |
046c8b5e |
273 | CORE::splice @{ $reader->( $_[0] ) }, $_[1], 0, $_[2]; |
e3c07b19 |
274 | }; |
275 | } |
276 | } |
277 | |
278 | sub splice : method { |
046c8b5e |
279 | my ( $attr, $reader, $writer ) = @_; |
280 | if ( |
281 | $attr->has_type_constraint |
282 | && $attr->type_constraint->isa( |
283 | 'Moose::Meta::TypeConstraint::Parameterized') |
284 | ) { |
285 | my $container_type_constraint |
286 | = $attr->type_constraint->type_parameter; |
e3c07b19 |
287 | return sub { |
288 | my ( $self, $i, $j, @elems ) = @_; |
046c8b5e |
289 | ( $container_type_constraint->check($_) ) |
290 | || confess "Value " |
291 | . ( defined($_) ? $_ : 'undef' ) |
292 | . " did not pass container type constraint '$container_type_constraint'" |
293 | for @elems; |
294 | CORE::splice @{ $reader->($self) }, $i, $j, @elems; |
e3c07b19 |
295 | }; |
296 | } |
297 | else { |
298 | return sub { |
299 | my ( $self, $i, $j, @elems ) = @_; |
046c8b5e |
300 | CORE::splice @{ $reader->($self) }, $i, $j, @elems; |
e3c07b19 |
301 | }; |
302 | } |
303 | } |
304 | |
305 | sub sort_in_place : method { |
046c8b5e |
306 | my ( $attr, $reader, $writer ) = @_; |
e3c07b19 |
307 | return sub { |
046c8b5e |
308 | my ( $instance, $predicate ) = @_; |
e3c07b19 |
309 | |
310 | die "Argument must be a code reference" |
311 | if $predicate && ref $predicate ne 'CODE'; |
312 | |
313 | my @sorted; |
314 | if ($predicate) { |
046c8b5e |
315 | @sorted = CORE::sort { $predicate->( $a, $b ) } |
316 | @{ $reader->($instance) }; |
e3c07b19 |
317 | } |
318 | else { |
046c8b5e |
319 | @sorted = CORE::sort @{ $reader->($instance) }; |
e3c07b19 |
320 | } |
321 | |
046c8b5e |
322 | $writer->( $instance, \@sorted ); |
e3c07b19 |
323 | }; |
324 | } |
325 | |
326 | 1; |
327 | |
328 | __END__ |
329 | |
330 | =pod |
331 | |
332 | =head1 NAME |
333 | |
a40b446a |
334 | Moose::Meta::Attribute::Trait::Native::MethodProvider::Array |
e3c07b19 |
335 | |
e11fb12c |
336 | =head1 SYNOPSIS |
337 | |
338 | package Stuff; |
339 | use Moose; |
340 | use Moose::AttributeHelpers; |
341 | |
342 | has 'options' => ( |
343 | metaclass => 'Array', |
344 | is => 'rw', |
345 | isa => 'ArrayRef[Str]', |
346 | default => sub { [] }, |
347 | auto_deref => 1, |
348 | handles => { |
349 | all_options => 'elements', |
350 | map_options => 'map', |
351 | filter_options => 'grep', |
352 | find_option => 'find', |
353 | first_option => 'first', |
354 | last_option => 'last', |
355 | get_option => 'get', |
356 | join_options => 'join', |
357 | count_options => 'count', |
358 | do_i_have_options => 'empty', |
359 | sorted_options => 'sort', |
360 | } |
361 | ); |
362 | |
363 | no Moose; |
364 | 1; |
365 | |
e3c07b19 |
366 | =head1 DESCRIPTION |
367 | |
368 | This is a role which provides the method generators for |
a40b446a |
369 | L<Moose::Meta::Attribute::Trait::Native::Array>. |
e3c07b19 |
370 | |
371 | =head1 METHODS |
372 | |
373 | =over 4 |
374 | |
375 | =item B<meta> |
376 | |
377 | =back |
378 | |
379 | =head1 PROVIDED METHODS |
380 | |
e3c07b19 |
381 | =over 4 |
382 | |
e11fb12c |
383 | =item B<count> |
384 | |
385 | Returns the number of elements in the array. |
386 | |
387 | $stuff = Stuff->new; |
388 | $stuff->options(["foo", "bar", "baz", "boo"]); |
389 | |
390 | my $count = $stuff->count_options; |
391 | print "$count\n"; # prints 4 |
392 | |
393 | =item B<empty> |
394 | |
395 | If the array is populated, returns true. Otherwise, returns false. |
396 | |
397 | $stuff->do_i_have_options ? print "Good boy.\n" : die "No options!\n" ; |
398 | |
399 | =item B<find> |
400 | |
401 | This method accepts a subroutine reference as its argument. That sub |
402 | will receive each element of the array in turn. If it returns true for |
403 | an element, that element will be returned by the C<find> method. |
404 | |
405 | my $found = $stuff->find_option( sub { $_[0] =~ /^b/ } ); |
406 | print "$found\n"; # prints "bar" |
407 | |
408 | =item B<grep> |
409 | |
410 | This method accepts a subroutine reference as its argument. This |
411 | method returns every element for which that subroutine reference |
412 | returns a true value. |
413 | |
414 | my @found = $stuff->filter_options( sub { $_[0] =~ /^b/ } ); |
415 | print "@found\n"; # prints "bar baz boo" |
416 | |
417 | =item B<map> |
418 | |
419 | This method accepts a subroutine reference as its argument. The |
420 | subroutine will be executed for each element of the array. It is |
421 | expected to return a modified version of that element. The return |
422 | value of the method is a list of the modified options. |
423 | |
424 | my @mod_options = $stuff->map_options( sub { $_[0] . "-tag" } ); |
425 | print "@mod_options\n"; # prints "foo-tag bar-tag baz-tag boo-tag" |
426 | |
427 | =item B<sort> |
428 | |
429 | Sorts and returns the elements of the array. |
430 | |
431 | You can provide an optional subroutine reference to sort with (as you |
432 | can with the core C<sort> function). However, instead of using C<$a> |
433 | and C<$b>, you will need to use C<$_[0]> and C<$_[1]> instead. |
434 | |
435 | # ascending ASCIIbetical |
436 | my @sorted = $stuff->sort_options(); |
437 | |
438 | # Descending alphabetical order |
439 | my @sorted_options = $stuff->sort_options( sub { lc $_[1] cmp lc $_[0] } ); |
440 | print "@sorted_options\n"; # prints "foo boo baz bar" |
441 | |
442 | =item B<elements> |
443 | |
444 | Returns all of the elements of the array |
445 | |
446 | my @option = $stuff->all_options; |
447 | print "@options\n"; # prints "foo bar baz boo" |
448 | |
449 | =item B<join> |
450 | |
451 | Joins every element of the array using the separator given as argument. |
452 | |
453 | my $joined = $stuff->join_options( ':' ); |
454 | print "$joined\n"; # prints "foo:bar:baz:boo" |
455 | |
e3c07b19 |
456 | =item B<get> |
457 | |
e11fb12c |
458 | Returns an element of the array by its index. |
459 | |
460 | my $option = $stuff->get_option(1); |
461 | print "$option\n"; # prints "bar" |
462 | |
463 | =item B<first> |
464 | |
465 | Returns the first element of the array. |
466 | |
467 | my $first = $stuff->first_option; |
468 | print "$first\n"; # prints "foo" |
469 | |
470 | =item B<last> |
471 | |
472 | Returns the last element of the array. |
473 | |
474 | my $last = $stuff->last_option; |
475 | print "$last\n"; # prints "boo" |
476 | |
e3c07b19 |
477 | =item B<pop> |
478 | |
479 | =item B<push> |
480 | |
481 | =item B<set> |
482 | |
483 | =item B<shift> |
484 | |
485 | =item B<unshift> |
486 | |
487 | =item B<clear> |
488 | |
489 | =item B<delete> |
490 | |
491 | =item B<insert> |
492 | |
493 | =item B<splice> |
494 | |
495 | =item B<sort_in_place> |
496 | |
497 | Sorts the array I<in place>, modifying the value of the attribute. |
498 | |
499 | You can provide an optional subroutine reference to sort with (as you |
500 | can with the core C<sort> function). However, instead of using C<$a> |
501 | and C<$b>, you will need to use C<$_[0]> and C<$_[1]> instead. |
502 | |
503 | =item B<accessor> |
504 | |
505 | If passed one argument, returns the value of the requested element. |
506 | If passed two arguments, sets the value of the requested element. |
507 | |
508 | =back |
509 | |
510 | =head1 BUGS |
511 | |
512 | All complex software has bugs lurking in it, and this module is no |
513 | exception. If you find a bug please either email me, or add the bug |
514 | to cpan-RT. |
515 | |
516 | =head1 AUTHOR |
517 | |
518 | Stevan Little E<lt>stevan@iinteractive.comE<gt> |
519 | |
520 | =head1 COPYRIGHT AND LICENSE |
521 | |
522 | Copyright 2007-2009 by Infinity Interactive, Inc. |
523 | |
524 | L<http://www.iinteractive.com> |
525 | |
526 | This library is free software; you can redistribute it and/or modify |
527 | it under the same terms as Perl itself. |
528 | |
529 | =cut |