Commit | Line | Data |
b9dc8e2f |
1 | package MooseX::AttributeHelpers::MethodProvider::Array; |
2 | use Moose::Role; |
3 | |
4 | sub push : method { |
5 | my ($attr) = @_; |
6 | if ($attr->has_container_type) { |
7 | my $container_type_constraint = $attr->container_type_constraint; |
8 | return sub { |
9 | my $instance = CORE::shift; |
10 | $container_type_constraint->check($_) |
11 | || confess "Value " . ($_||'undef') . " did not pass container type constraint" |
12 | foreach @_; |
13 | CORE::push @{$attr->get_value($instance)} => @_; |
14 | }; |
15 | } |
16 | else { |
17 | return sub { |
18 | my $instance = CORE::shift; |
19 | CORE::push @{$attr->get_value($instance)} => @_; |
20 | }; |
21 | } |
22 | } |
23 | |
24 | sub pop : method { |
25 | my ($attr) = @_; |
26 | return sub { |
27 | CORE::pop @{$attr->get_value($_[0])} |
28 | }; |
29 | } |
30 | |
31 | sub unshift : method { |
32 | my ($attr) = @_; |
33 | if ($attr->has_container_type) { |
34 | my $container_type_constraint = $attr->container_type_constraint; |
35 | return sub { |
36 | my $instance = CORE::shift; |
37 | $container_type_constraint->check($_) |
38 | || confess "Value " . ($_||'undef') . " did not pass container type constraint" |
39 | foreach @_; |
40 | CORE::unshift @{$attr->get_value($instance)} => @_; |
41 | }; |
42 | } |
43 | else { |
44 | return sub { |
45 | my $instance = CORE::shift; |
46 | CORE::unshift @{$attr->get_value($instance)} => @_; |
47 | }; |
48 | } |
49 | } |
50 | |
51 | sub shift : method { |
52 | my ($attr) = @_; |
53 | return sub { |
54 | CORE::shift @{$attr->get_value($_[0])} |
55 | }; |
56 | } |
57 | |
58 | sub get : method { |
59 | my ($attr) = @_; |
60 | return sub { |
61 | $attr->get_value($_[0])->[$_[1]] |
62 | }; |
63 | } |
64 | |
65 | sub set : method { |
66 | my ($attr) = @_; |
67 | if ($attr->has_container_type) { |
68 | my $container_type_constraint = $attr->container_type_constraint; |
69 | return sub { |
70 | ($container_type_constraint->check($_[2])) |
71 | || confess "Value " . ($_[2]||'undef') . " did not pass container type constraint"; |
72 | $attr->get_value($_[0])->[$_[1]] = $_[2] |
73 | }; |
74 | } |
75 | else { |
76 | return sub { |
77 | $attr->get_value($_[0])->[$_[1]] = $_[2] |
78 | }; |
79 | } |
80 | } |
81 | |
82 | sub count : method { |
83 | my ($attr) = @_; |
84 | return sub { |
85 | scalar @{$attr->get_value($_[0])} |
86 | }; |
87 | } |
88 | |
89 | sub empty : method { |
90 | my ($attr) = @_; |
91 | return sub { |
92 | scalar @{$attr->get_value($_[0])} ? 1 : 0 |
93 | }; |
94 | } |
95 | |
96 | sub find : method { |
97 | my ($attr) = @_; |
98 | return sub { |
99 | my ($instance, $predicate) = @_; |
100 | foreach my $val (@{$attr->get_value($instance)}) { |
101 | return $val if $predicate->($val); |
102 | } |
103 | return; |
104 | }; |
105 | } |
106 | |
0e744400 |
107 | sub map : method { |
108 | my ($attr) = @_; |
109 | return sub { |
110 | my ($instance, $f) = @_; |
111 | CORE::map { $f->($_) } @{$attr->get_value($instance)} |
112 | }; |
113 | } |
114 | |
115 | sub grep : method { |
116 | my ($attr) = @_; |
117 | return sub { |
118 | my ($instance, $predicate) = @_; |
119 | CORE::grep { $predicate->($_) } @{$attr->get_value($instance)} |
120 | }; |
121 | } |
122 | |
b9dc8e2f |
123 | 1; |
124 | |
125 | __END__ |
126 | |
127 | =pod |
128 | |
5431dff2 |
129 | =head1 NAME |
130 | |
131 | MooseX::AttributeHelpers::MethodProvider::Array |
132 | |
133 | =head1 DESCRIPTION |
134 | |
135 | This is a role which provides the method generators for |
136 | L<MooseX::AttributeHelpers::Collection::Array>. |
137 | |
138 | =head1 METHODS |
139 | |
140 | =over 4 |
141 | |
142 | =item B<meta> |
143 | |
144 | =back |
145 | |
146 | =head1 PROVIDED METHODS |
147 | |
148 | =over 4 |
149 | |
150 | =item B<count> |
151 | |
152 | =item B<empty> |
153 | |
154 | =item B<find> |
155 | |
156 | =item B<get> |
157 | |
158 | =item B<grep> |
159 | |
160 | =item B<map> |
161 | |
162 | =item B<pop> |
163 | |
164 | =item B<push> |
165 | |
166 | =item B<set> |
167 | |
168 | =item B<shift> |
169 | |
170 | =item B<unshift> |
171 | |
172 | =back |
173 | |
174 | =head1 BUGS |
175 | |
176 | All complex software has bugs lurking in it, and this module is no |
177 | exception. If you find a bug please either email me, or add the bug |
178 | to cpan-RT. |
179 | |
180 | =head1 AUTHOR |
181 | |
182 | Stevan Little E<lt>stevan@iinteractive.comE<gt> |
183 | |
184 | =head1 COPYRIGHT AND LICENSE |
185 | |
186 | Copyright 2007 by Infinity Interactive, Inc. |
187 | |
188 | L<http://www.iinteractive.com> |
189 | |
190 | This library is free software; you can redistribute it and/or modify |
191 | it under the same terms as Perl itself. |
192 | |
b9dc8e2f |
193 | =cut |