Commit | Line | Data |
c466e58f |
1 | package Moose::Meta::Attribute::Native::MethodProvider::Array; |
e3c07b19 |
2 | use Moose::Role; |
3 | |
7960bcc0 |
4 | use List::Util; |
5 | use List::MoreUtils; |
6 | |
870d0f1a |
7 | our $VERSION = '0.94'; |
e3c07b19 |
8 | $VERSION = eval $VERSION; |
9 | our $AUTHORITY = 'cpan:STEVAN'; |
10 | |
e11fb12c |
11 | sub count : method { |
12 | my ( $attr, $reader, $writer ) = @_; |
13 | return sub { |
14 | scalar @{ $reader->( $_[0] ) }; |
15 | }; |
16 | } |
17 | |
1853a27e |
18 | sub is_empty : method { |
e11fb12c |
19 | my ( $attr, $reader, $writer ) = @_; |
20 | return sub { |
af44c00c |
21 | scalar @{ $reader->( $_[0] ) } ? 0 : 1; |
e11fb12c |
22 | }; |
23 | } |
24 | |
391c761c |
25 | sub first : method { |
e11fb12c |
26 | my ( $attr, $reader, $writer ) = @_; |
27 | return sub { |
28 | my ( $instance, $predicate ) = @_; |
31c519ab |
29 | List::Util::first { $predicate->() } @{ $reader->($instance) }; |
e11fb12c |
30 | }; |
31 | } |
32 | |
33 | sub map : method { |
34 | my ( $attr, $reader, $writer ) = @_; |
35 | return sub { |
36 | my ( $instance, $f ) = @_; |
c9edbf05 |
37 | CORE::map { $f->() } @{ $reader->($instance) }; |
e11fb12c |
38 | }; |
39 | } |
40 | |
7960bcc0 |
41 | sub reduce : method { |
42 | my ( $attr, $reader, $writer ) = @_; |
43 | return sub { |
44 | my ( $instance, $f ) = @_; |
45 | our ($a, $b); |
46 | List::Util::reduce { $f->($a, $b) } @{ $reader->($instance) }; |
47 | }; |
48 | } |
49 | |
e11fb12c |
50 | sub sort : method { |
51 | my ( $attr, $reader, $writer ) = @_; |
52 | return sub { |
53 | my ( $instance, $predicate ) = @_; |
54 | die "Argument must be a code reference" |
33f819e1 |
55 | if $predicate && ref $predicate ne 'CODE'; |
e11fb12c |
56 | |
57 | if ($predicate) { |
a163f54f |
58 | # Although it would be nice if we could support just using $a and |
59 | # $b like sort already does, using $a or $b once in a package |
60 | # triggers the 'Name "main::a" used only once' warning, and there |
61 | # is no good way to avoid that, since it happens when the file |
62 | # which defines the coderef is compiled, before we even get a |
63 | # chance to see it here. So, we have no real choice but to use |
64 | # normal parameters. --doy |
e11fb12c |
65 | CORE::sort { $predicate->( $a, $b ) } @{ $reader->($instance) }; |
66 | } |
67 | else { |
68 | CORE::sort @{ $reader->($instance) }; |
69 | } |
70 | }; |
71 | } |
72 | |
7960bcc0 |
73 | sub shuffle : method { |
74 | my ( $attr, $reader, $writer ) = @_; |
75 | return sub { |
76 | my ( $instance ) = @_; |
77 | List::Util::shuffle @{ $reader->($instance) }; |
78 | }; |
79 | } |
80 | |
e11fb12c |
81 | sub grep : method { |
82 | my ( $attr, $reader, $writer ) = @_; |
83 | return sub { |
84 | my ( $instance, $predicate ) = @_; |
c9edbf05 |
85 | CORE::grep { $predicate->() } @{ $reader->($instance) }; |
e11fb12c |
86 | }; |
87 | } |
88 | |
7960bcc0 |
89 | sub uniq : method { |
90 | my ( $attr, $reader, $writer ) = @_; |
91 | return sub { |
92 | my ( $instance ) = @_; |
93 | List::MoreUtils::uniq @{ $reader->($instance) }; |
94 | }; |
95 | } |
96 | |
e11fb12c |
97 | sub elements : method { |
98 | my ( $attr, $reader, $writer ) = @_; |
99 | return sub { |
100 | my ($instance) = @_; |
101 | @{ $reader->($instance) }; |
102 | }; |
103 | } |
104 | |
105 | sub join : method { |
106 | my ( $attr, $reader, $writer ) = @_; |
107 | return sub { |
108 | my ( $instance, $separator ) = @_; |
109 | join $separator, @{ $reader->($instance) }; |
110 | }; |
111 | } |
112 | |
e3c07b19 |
113 | sub push : method { |
046c8b5e |
114 | my ( $attr, $reader, $writer ) = @_; |
115 | |
116 | if ( |
117 | $attr->has_type_constraint |
118 | && $attr->type_constraint->isa( |
119 | 'Moose::Meta::TypeConstraint::Parameterized') |
33f819e1 |
120 | ) |
121 | { |
122 | my $container_type_constraint = $attr->type_constraint->type_parameter; |
e3c07b19 |
123 | return sub { |
124 | my $instance = CORE::shift; |
125 | $container_type_constraint->check($_) |
33f819e1 |
126 | || confess "Value " |
127 | . ( $_ || 'undef' ) |
128 | . " did not pass container type constraint '$container_type_constraint'" |
129 | foreach @_; |
046c8b5e |
130 | CORE::push @{ $reader->($instance) } => @_; |
e3c07b19 |
131 | }; |
132 | } |
133 | else { |
134 | return sub { |
135 | my $instance = CORE::shift; |
046c8b5e |
136 | CORE::push @{ $reader->($instance) } => @_; |
e3c07b19 |
137 | }; |
138 | } |
139 | } |
140 | |
141 | sub pop : method { |
046c8b5e |
142 | my ( $attr, $reader, $writer ) = @_; |
e3c07b19 |
143 | return sub { |
046c8b5e |
144 | CORE::pop @{ $reader->( $_[0] ) }; |
e3c07b19 |
145 | }; |
146 | } |
147 | |
148 | sub unshift : method { |
046c8b5e |
149 | my ( $attr, $reader, $writer ) = @_; |
150 | if ( |
151 | $attr->has_type_constraint |
152 | && $attr->type_constraint->isa( |
153 | 'Moose::Meta::TypeConstraint::Parameterized') |
33f819e1 |
154 | ) |
155 | { |
156 | my $container_type_constraint = $attr->type_constraint->type_parameter; |
e3c07b19 |
157 | return sub { |
158 | my $instance = CORE::shift; |
159 | $container_type_constraint->check($_) |
33f819e1 |
160 | || confess "Value " |
161 | . ( $_ || 'undef' ) |
162 | . " did not pass container type constraint '$container_type_constraint'" |
163 | foreach @_; |
046c8b5e |
164 | CORE::unshift @{ $reader->($instance) } => @_; |
e3c07b19 |
165 | }; |
166 | } |
167 | else { |
168 | return sub { |
169 | my $instance = CORE::shift; |
046c8b5e |
170 | CORE::unshift @{ $reader->($instance) } => @_; |
e3c07b19 |
171 | }; |
172 | } |
173 | } |
174 | |
175 | sub shift : method { |
046c8b5e |
176 | my ( $attr, $reader, $writer ) = @_; |
e3c07b19 |
177 | return sub { |
046c8b5e |
178 | CORE::shift @{ $reader->( $_[0] ) }; |
e3c07b19 |
179 | }; |
180 | } |
181 | |
182 | sub get : method { |
046c8b5e |
183 | my ( $attr, $reader, $writer ) = @_; |
e3c07b19 |
184 | return sub { |
046c8b5e |
185 | $reader->( $_[0] )->[ $_[1] ]; |
e3c07b19 |
186 | }; |
187 | } |
188 | |
189 | sub set : method { |
046c8b5e |
190 | my ( $attr, $reader, $writer ) = @_; |
191 | if ( |
192 | $attr->has_type_constraint |
193 | && $attr->type_constraint->isa( |
194 | 'Moose::Meta::TypeConstraint::Parameterized') |
33f819e1 |
195 | ) |
196 | { |
197 | my $container_type_constraint = $attr->type_constraint->type_parameter; |
e3c07b19 |
198 | return sub { |
046c8b5e |
199 | ( $container_type_constraint->check( $_[2] ) ) |
33f819e1 |
200 | || confess "Value " |
201 | . ( $_[2] || 'undef' ) |
202 | . " did not pass container type constraint '$container_type_constraint'"; |
046c8b5e |
203 | $reader->( $_[0] )->[ $_[1] ] = $_[2]; |
e3c07b19 |
204 | }; |
205 | } |
206 | else { |
207 | return sub { |
046c8b5e |
208 | $reader->( $_[0] )->[ $_[1] ] = $_[2]; |
e3c07b19 |
209 | }; |
210 | } |
211 | } |
212 | |
213 | sub accessor : method { |
046c8b5e |
214 | my ( $attr, $reader, $writer ) = @_; |
215 | |
216 | if ( |
217 | $attr->has_type_constraint |
218 | && $attr->type_constraint->isa( |
219 | 'Moose::Meta::TypeConstraint::Parameterized') |
33f819e1 |
220 | ) |
221 | { |
222 | my $container_type_constraint = $attr->type_constraint->type_parameter; |
e3c07b19 |
223 | return sub { |
224 | my $self = shift; |
225 | |
046c8b5e |
226 | if ( @_ == 1 ) { # reader |
227 | return $reader->($self)->[ $_[0] ]; |
e3c07b19 |
228 | } |
046c8b5e |
229 | elsif ( @_ == 2 ) { # writer |
230 | ( $container_type_constraint->check( $_[1] ) ) |
33f819e1 |
231 | || confess "Value " |
232 | . ( $_[1] || 'undef' ) |
233 | . " did not pass container type constraint '$container_type_constraint'"; |
046c8b5e |
234 | $reader->($self)->[ $_[0] ] = $_[1]; |
e3c07b19 |
235 | } |
236 | else { |
237 | confess "One or two arguments expected, not " . @_; |
238 | } |
239 | }; |
240 | } |
241 | else { |
242 | return sub { |
243 | my $self = shift; |
244 | |
046c8b5e |
245 | if ( @_ == 1 ) { # reader |
246 | return $reader->($self)->[ $_[0] ]; |
e3c07b19 |
247 | } |
046c8b5e |
248 | elsif ( @_ == 2 ) { # writer |
249 | $reader->($self)->[ $_[0] ] = $_[1]; |
e3c07b19 |
250 | } |
251 | else { |
252 | confess "One or two arguments expected, not " . @_; |
253 | } |
254 | }; |
255 | } |
256 | } |
257 | |
258 | sub clear : method { |
046c8b5e |
259 | my ( $attr, $reader, $writer ) = @_; |
e3c07b19 |
260 | return sub { |
046c8b5e |
261 | @{ $reader->( $_[0] ) } = (); |
e3c07b19 |
262 | }; |
263 | } |
264 | |
265 | sub delete : method { |
046c8b5e |
266 | my ( $attr, $reader, $writer ) = @_; |
e3c07b19 |
267 | return sub { |
046c8b5e |
268 | CORE::splice @{ $reader->( $_[0] ) }, $_[1], 1; |
33f819e1 |
269 | } |
e3c07b19 |
270 | } |
271 | |
272 | sub insert : method { |
046c8b5e |
273 | my ( $attr, $reader, $writer ) = @_; |
274 | if ( |
275 | $attr->has_type_constraint |
276 | && $attr->type_constraint->isa( |
277 | 'Moose::Meta::TypeConstraint::Parameterized') |
33f819e1 |
278 | ) |
279 | { |
280 | my $container_type_constraint = $attr->type_constraint->type_parameter; |
e3c07b19 |
281 | return sub { |
046c8b5e |
282 | ( $container_type_constraint->check( $_[2] ) ) |
33f819e1 |
283 | || confess "Value " |
284 | . ( $_[2] || 'undef' ) |
285 | . " did not pass container type constraint '$container_type_constraint'"; |
046c8b5e |
286 | CORE::splice @{ $reader->( $_[0] ) }, $_[1], 0, $_[2]; |
e3c07b19 |
287 | }; |
288 | } |
289 | else { |
290 | return sub { |
046c8b5e |
291 | CORE::splice @{ $reader->( $_[0] ) }, $_[1], 0, $_[2]; |
e3c07b19 |
292 | }; |
293 | } |
294 | } |
295 | |
296 | sub splice : method { |
046c8b5e |
297 | my ( $attr, $reader, $writer ) = @_; |
298 | if ( |
299 | $attr->has_type_constraint |
300 | && $attr->type_constraint->isa( |
301 | 'Moose::Meta::TypeConstraint::Parameterized') |
33f819e1 |
302 | ) |
303 | { |
304 | my $container_type_constraint = $attr->type_constraint->type_parameter; |
e3c07b19 |
305 | return sub { |
306 | my ( $self, $i, $j, @elems ) = @_; |
046c8b5e |
307 | ( $container_type_constraint->check($_) ) |
33f819e1 |
308 | || confess "Value " |
309 | . ( defined($_) ? $_ : 'undef' ) |
310 | . " did not pass container type constraint '$container_type_constraint'" |
311 | for @elems; |
046c8b5e |
312 | CORE::splice @{ $reader->($self) }, $i, $j, @elems; |
e3c07b19 |
313 | }; |
314 | } |
315 | else { |
316 | return sub { |
317 | my ( $self, $i, $j, @elems ) = @_; |
046c8b5e |
318 | CORE::splice @{ $reader->($self) }, $i, $j, @elems; |
e3c07b19 |
319 | }; |
320 | } |
321 | } |
322 | |
323 | sub sort_in_place : method { |
046c8b5e |
324 | my ( $attr, $reader, $writer ) = @_; |
e3c07b19 |
325 | return sub { |
046c8b5e |
326 | my ( $instance, $predicate ) = @_; |
e3c07b19 |
327 | |
328 | die "Argument must be a code reference" |
33f819e1 |
329 | if $predicate && ref $predicate ne 'CODE'; |
e3c07b19 |
330 | |
331 | my @sorted; |
332 | if ($predicate) { |
33f819e1 |
333 | @sorted = |
334 | CORE::sort { $predicate->( $a, $b ) } @{ $reader->($instance) }; |
e3c07b19 |
335 | } |
336 | else { |
046c8b5e |
337 | @sorted = CORE::sort @{ $reader->($instance) }; |
e3c07b19 |
338 | } |
339 | |
046c8b5e |
340 | $writer->( $instance, \@sorted ); |
e3c07b19 |
341 | }; |
342 | } |
343 | |
7960bcc0 |
344 | sub natatime : method { |
345 | my ( $attr, $reader, $writer ) = @_; |
346 | return sub { |
347 | my ( $instance, $n, $f ) = @_; |
348 | my $it = List::MoreUtils::natatime($n, @{ $reader->($instance) }); |
349 | if ($f) { |
350 | while (my @vals = $it->()) { |
351 | $f->(@vals); |
352 | } |
353 | } |
354 | $it; |
355 | }; |
356 | } |
357 | |
e3c07b19 |
358 | 1; |
359 | |
360 | __END__ |
361 | |
362 | =pod |
363 | |
364 | =head1 NAME |
365 | |
c466e58f |
366 | Moose::Meta::Attribute::Native::MethodProvider::Array |
e3c07b19 |
367 | |
368 | =head1 DESCRIPTION |
369 | |
370 | This is a role which provides the method generators for |
e22d28f2 |
371 | L<Moose::Meta::Attribute::Native::Trait::Array>. Please check there for |
9da49e13 |
372 | documentation on what methods are provided. |
e3c07b19 |
373 | |
374 | =head1 METHODS |
375 | |
376 | =over 4 |
377 | |
378 | =item B<meta> |
379 | |
380 | =back |
381 | |
e3c07b19 |
382 | =head1 BUGS |
383 | |
d4048ef3 |
384 | See L<Moose/BUGS> for details on reporting bugs. |
e3c07b19 |
385 | |
386 | =head1 AUTHOR |
387 | |
388 | Stevan Little E<lt>stevan@iinteractive.comE<gt> |
389 | |
390 | =head1 COPYRIGHT AND LICENSE |
391 | |
392 | Copyright 2007-2009 by Infinity Interactive, Inc. |
393 | |
394 | L<http://www.iinteractive.com> |
395 | |
396 | This library is free software; you can redistribute it and/or modify |
397 | it under the same terms as Perl itself. |
398 | |
399 | =cut |