Commit | Line | Data |
e3c07b19 |
1 | package Moose::AttributeHelpers::MethodProvider::Array; |
2 | use Moose::Role; |
3 | |
37b7c240 |
4 | our $VERSION = '0.84'; |
e3c07b19 |
5 | $VERSION = eval $VERSION; |
6 | our $AUTHORITY = 'cpan:STEVAN'; |
7 | |
8 | with 'Moose::AttributeHelpers::MethodProvider::List'; |
9 | |
10 | sub push : method { |
046c8b5e |
11 | my ( $attr, $reader, $writer ) = @_; |
12 | |
13 | if ( |
14 | $attr->has_type_constraint |
15 | && $attr->type_constraint->isa( |
16 | 'Moose::Meta::TypeConstraint::Parameterized') |
17 | ) { |
18 | my $container_type_constraint |
19 | = $attr->type_constraint->type_parameter; |
e3c07b19 |
20 | return sub { |
21 | my $instance = CORE::shift; |
22 | $container_type_constraint->check($_) |
046c8b5e |
23 | || confess "Value " |
24 | . ( $_ || 'undef' ) |
25 | . " did not pass container type constraint '$container_type_constraint'" |
26 | foreach @_; |
27 | CORE::push @{ $reader->($instance) } => @_; |
e3c07b19 |
28 | }; |
29 | } |
30 | else { |
31 | return sub { |
32 | my $instance = CORE::shift; |
046c8b5e |
33 | CORE::push @{ $reader->($instance) } => @_; |
e3c07b19 |
34 | }; |
35 | } |
36 | } |
37 | |
38 | sub pop : method { |
046c8b5e |
39 | my ( $attr, $reader, $writer ) = @_; |
e3c07b19 |
40 | return sub { |
046c8b5e |
41 | CORE::pop @{ $reader->( $_[0] ) }; |
e3c07b19 |
42 | }; |
43 | } |
44 | |
45 | sub unshift : method { |
046c8b5e |
46 | my ( $attr, $reader, $writer ) = @_; |
47 | if ( |
48 | $attr->has_type_constraint |
49 | && $attr->type_constraint->isa( |
50 | 'Moose::Meta::TypeConstraint::Parameterized') |
51 | ) { |
52 | my $container_type_constraint |
53 | = $attr->type_constraint->type_parameter; |
e3c07b19 |
54 | return sub { |
55 | my $instance = CORE::shift; |
56 | $container_type_constraint->check($_) |
046c8b5e |
57 | || confess "Value " |
58 | . ( $_ || 'undef' ) |
59 | . " did not pass container type constraint '$container_type_constraint'" |
60 | foreach @_; |
61 | CORE::unshift @{ $reader->($instance) } => @_; |
e3c07b19 |
62 | }; |
63 | } |
64 | else { |
65 | return sub { |
66 | my $instance = CORE::shift; |
046c8b5e |
67 | CORE::unshift @{ $reader->($instance) } => @_; |
e3c07b19 |
68 | }; |
69 | } |
70 | } |
71 | |
72 | sub shift : method { |
046c8b5e |
73 | my ( $attr, $reader, $writer ) = @_; |
e3c07b19 |
74 | return sub { |
046c8b5e |
75 | CORE::shift @{ $reader->( $_[0] ) }; |
e3c07b19 |
76 | }; |
77 | } |
78 | |
79 | sub get : method { |
046c8b5e |
80 | my ( $attr, $reader, $writer ) = @_; |
e3c07b19 |
81 | return sub { |
046c8b5e |
82 | $reader->( $_[0] )->[ $_[1] ]; |
e3c07b19 |
83 | }; |
84 | } |
85 | |
86 | sub set : method { |
046c8b5e |
87 | my ( $attr, $reader, $writer ) = @_; |
88 | if ( |
89 | $attr->has_type_constraint |
90 | && $attr->type_constraint->isa( |
91 | 'Moose::Meta::TypeConstraint::Parameterized') |
92 | ) { |
93 | my $container_type_constraint |
94 | = $attr->type_constraint->type_parameter; |
e3c07b19 |
95 | return sub { |
046c8b5e |
96 | ( $container_type_constraint->check( $_[2] ) ) |
97 | || confess "Value " |
98 | . ( $_[2] || 'undef' ) |
99 | . " did not pass container type constraint '$container_type_constraint'"; |
100 | $reader->( $_[0] )->[ $_[1] ] = $_[2]; |
e3c07b19 |
101 | }; |
102 | } |
103 | else { |
104 | return sub { |
046c8b5e |
105 | $reader->( $_[0] )->[ $_[1] ] = $_[2]; |
e3c07b19 |
106 | }; |
107 | } |
108 | } |
109 | |
110 | sub accessor : method { |
046c8b5e |
111 | my ( $attr, $reader, $writer ) = @_; |
112 | |
113 | if ( |
114 | $attr->has_type_constraint |
115 | && $attr->type_constraint->isa( |
116 | 'Moose::Meta::TypeConstraint::Parameterized') |
117 | ) { |
118 | my $container_type_constraint |
119 | = $attr->type_constraint->type_parameter; |
e3c07b19 |
120 | return sub { |
121 | my $self = shift; |
122 | |
046c8b5e |
123 | if ( @_ == 1 ) { # reader |
124 | return $reader->($self)->[ $_[0] ]; |
e3c07b19 |
125 | } |
046c8b5e |
126 | elsif ( @_ == 2 ) { # writer |
127 | ( $container_type_constraint->check( $_[1] ) ) |
128 | || confess "Value " |
129 | . ( $_[1] || 'undef' ) |
130 | . " did not pass container type constraint '$container_type_constraint'"; |
131 | $reader->($self)->[ $_[0] ] = $_[1]; |
e3c07b19 |
132 | } |
133 | else { |
134 | confess "One or two arguments expected, not " . @_; |
135 | } |
136 | }; |
137 | } |
138 | else { |
139 | return sub { |
140 | my $self = shift; |
141 | |
046c8b5e |
142 | if ( @_ == 1 ) { # reader |
143 | return $reader->($self)->[ $_[0] ]; |
e3c07b19 |
144 | } |
046c8b5e |
145 | elsif ( @_ == 2 ) { # writer |
146 | $reader->($self)->[ $_[0] ] = $_[1]; |
e3c07b19 |
147 | } |
148 | else { |
149 | confess "One or two arguments expected, not " . @_; |
150 | } |
151 | }; |
152 | } |
153 | } |
154 | |
155 | sub clear : method { |
046c8b5e |
156 | my ( $attr, $reader, $writer ) = @_; |
e3c07b19 |
157 | return sub { |
046c8b5e |
158 | @{ $reader->( $_[0] ) } = (); |
e3c07b19 |
159 | }; |
160 | } |
161 | |
162 | sub delete : method { |
046c8b5e |
163 | my ( $attr, $reader, $writer ) = @_; |
e3c07b19 |
164 | return sub { |
046c8b5e |
165 | CORE::splice @{ $reader->( $_[0] ) }, $_[1], 1; |
166 | } |
e3c07b19 |
167 | } |
168 | |
169 | sub insert : method { |
046c8b5e |
170 | my ( $attr, $reader, $writer ) = @_; |
171 | if ( |
172 | $attr->has_type_constraint |
173 | && $attr->type_constraint->isa( |
174 | 'Moose::Meta::TypeConstraint::Parameterized') |
175 | ) { |
176 | my $container_type_constraint |
177 | = $attr->type_constraint->type_parameter; |
e3c07b19 |
178 | return sub { |
046c8b5e |
179 | ( $container_type_constraint->check( $_[2] ) ) |
180 | || confess "Value " |
181 | . ( $_[2] || 'undef' ) |
182 | . " did not pass container type constraint '$container_type_constraint'"; |
183 | CORE::splice @{ $reader->( $_[0] ) }, $_[1], 0, $_[2]; |
e3c07b19 |
184 | }; |
185 | } |
186 | else { |
187 | return sub { |
046c8b5e |
188 | CORE::splice @{ $reader->( $_[0] ) }, $_[1], 0, $_[2]; |
e3c07b19 |
189 | }; |
190 | } |
191 | } |
192 | |
193 | sub splice : method { |
046c8b5e |
194 | my ( $attr, $reader, $writer ) = @_; |
195 | if ( |
196 | $attr->has_type_constraint |
197 | && $attr->type_constraint->isa( |
198 | 'Moose::Meta::TypeConstraint::Parameterized') |
199 | ) { |
200 | my $container_type_constraint |
201 | = $attr->type_constraint->type_parameter; |
e3c07b19 |
202 | return sub { |
203 | my ( $self, $i, $j, @elems ) = @_; |
046c8b5e |
204 | ( $container_type_constraint->check($_) ) |
205 | || confess "Value " |
206 | . ( defined($_) ? $_ : 'undef' ) |
207 | . " did not pass container type constraint '$container_type_constraint'" |
208 | for @elems; |
209 | CORE::splice @{ $reader->($self) }, $i, $j, @elems; |
e3c07b19 |
210 | }; |
211 | } |
212 | else { |
213 | return sub { |
214 | my ( $self, $i, $j, @elems ) = @_; |
046c8b5e |
215 | CORE::splice @{ $reader->($self) }, $i, $j, @elems; |
e3c07b19 |
216 | }; |
217 | } |
218 | } |
219 | |
220 | sub sort_in_place : method { |
046c8b5e |
221 | my ( $attr, $reader, $writer ) = @_; |
e3c07b19 |
222 | return sub { |
046c8b5e |
223 | my ( $instance, $predicate ) = @_; |
e3c07b19 |
224 | |
225 | die "Argument must be a code reference" |
226 | if $predicate && ref $predicate ne 'CODE'; |
227 | |
228 | my @sorted; |
229 | if ($predicate) { |
046c8b5e |
230 | @sorted = CORE::sort { $predicate->( $a, $b ) } |
231 | @{ $reader->($instance) }; |
e3c07b19 |
232 | } |
233 | else { |
046c8b5e |
234 | @sorted = CORE::sort @{ $reader->($instance) }; |
e3c07b19 |
235 | } |
236 | |
046c8b5e |
237 | $writer->( $instance, \@sorted ); |
e3c07b19 |
238 | }; |
239 | } |
240 | |
241 | 1; |
242 | |
243 | __END__ |
244 | |
245 | =pod |
246 | |
247 | =head1 NAME |
248 | |
249 | Moose::AttributeHelpers::MethodProvider::Array |
250 | |
251 | =head1 DESCRIPTION |
252 | |
253 | This is a role which provides the method generators for |
254 | L<Moose::AttributeHelpers::Collection::Array>. |
255 | |
256 | =head1 METHODS |
257 | |
258 | =over 4 |
259 | |
260 | =item B<meta> |
261 | |
262 | =back |
263 | |
264 | =head1 PROVIDED METHODS |
265 | |
266 | This module also consumes the B<List> method providers, to |
cd7ea7c9 |
267 | see those provided methods, refer to that documentation. |
e3c07b19 |
268 | |
269 | =over 4 |
270 | |
271 | =item B<get> |
272 | |
273 | =item B<pop> |
274 | |
275 | =item B<push> |
276 | |
277 | =item B<set> |
278 | |
279 | =item B<shift> |
280 | |
281 | =item B<unshift> |
282 | |
283 | =item B<clear> |
284 | |
285 | =item B<delete> |
286 | |
287 | =item B<insert> |
288 | |
289 | =item B<splice> |
290 | |
291 | =item B<sort_in_place> |
292 | |
293 | Sorts the array I<in place>, modifying the value of the attribute. |
294 | |
295 | You can provide an optional subroutine reference to sort with (as you |
296 | can with the core C<sort> function). However, instead of using C<$a> |
297 | and C<$b>, you will need to use C<$_[0]> and C<$_[1]> instead. |
298 | |
299 | =item B<accessor> |
300 | |
301 | If passed one argument, returns the value of the requested element. |
302 | If passed two arguments, sets the value of the requested element. |
303 | |
304 | =back |
305 | |
306 | =head1 BUGS |
307 | |
308 | All complex software has bugs lurking in it, and this module is no |
309 | exception. If you find a bug please either email me, or add the bug |
310 | to cpan-RT. |
311 | |
312 | =head1 AUTHOR |
313 | |
314 | Stevan Little E<lt>stevan@iinteractive.comE<gt> |
315 | |
316 | =head1 COPYRIGHT AND LICENSE |
317 | |
318 | Copyright 2007-2009 by Infinity Interactive, Inc. |
319 | |
320 | L<http://www.iinteractive.com> |
321 | |
322 | This library is free software; you can redistribute it and/or modify |
323 | it under the same terms as Perl itself. |
324 | |
325 | =cut |