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