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