merge List into Array and ImmutableHash into Hash
[gitmo/Moose.git] / lib / Moose / Meta / Attribute / Trait / Native / MethodProvider / Hash.pm
CommitLineData
a40b446a 1package Moose::Meta::Attribute::Trait::Native::MethodProvider::Hash;
e3c07b19 2use Moose::Role;
3
96539d20 4our $VERSION = '0.87';
e3c07b19 5$VERSION = eval $VERSION;
6our $AUTHORITY = 'cpan:STEVAN';
7
e11fb12c 8sub exists : method {
9 my ( $attr, $reader, $writer ) = @_;
10 return sub { CORE::exists $reader->( $_[0] )->{ $_[1] } ? 1 : 0 };
11}
12
13sub defined : method {
14 my ( $attr, $reader, $writer ) = @_;
15 return sub { CORE::defined $reader->( $_[0] )->{ $_[1] } ? 1 : 0 };
16}
17
18sub get : method {
19 my ( $attr, $reader, $writer ) = @_;
20 return sub {
21 if ( @_ == 2 ) {
22 $reader->( $_[0] )->{ $_[1] };
23 }
24 else {
25 my ( $self, @keys ) = @_;
26 @{ $reader->($self) }{@keys};
27 }
28 };
29}
30
31sub keys : method {
32 my ( $attr, $reader, $writer ) = @_;
33 return sub { CORE::keys %{ $reader->( $_[0] ) } };
34}
35
36sub values : method {
37 my ( $attr, $reader, $writer ) = @_;
38 return sub { CORE::values %{ $reader->( $_[0] ) } };
39}
40
41sub kv : method {
42 my ( $attr, $reader, $writer ) = @_;
43 return sub {
44 my $h = $reader->( $_[0] );
45 map { [ $_, $h->{$_} ] } CORE::keys %{$h};
46 };
47}
48
49sub elements : method {
50 my ( $attr, $reader, $writer ) = @_;
51 return sub {
52 my $h = $reader->( $_[0] );
53 map { $_, $h->{$_} } CORE::keys %{$h};
54 };
55}
56
57sub count : method {
58 my ( $attr, $reader, $writer ) = @_;
59 return sub { scalar CORE::keys %{ $reader->( $_[0] ) } };
60}
61
62sub empty : method {
63 my ( $attr, $reader, $writer ) = @_;
64 return sub { scalar CORE::keys %{ $reader->( $_[0] ) } ? 1 : 0 };
65}
66
e3c07b19 67
68sub set : method {
046c8b5e 69 my ( $attr, $reader, $writer ) = @_;
70 if (
71 $attr->has_type_constraint
72 && $attr->type_constraint->isa(
73 'Moose::Meta::TypeConstraint::Parameterized')
74 ) {
75 my $container_type_constraint
76 = $attr->type_constraint->type_parameter;
e3c07b19 77 return sub {
78 my ( $self, @kvp ) = @_;
79
80 my ( @keys, @values );
81
046c8b5e 82 while (@kvp) {
e3c07b19 83 my ( $key, $value ) = ( shift(@kvp), shift(@kvp) );
046c8b5e 84 ( $container_type_constraint->check($value) )
85 || confess "Value "
86 . ( $value || 'undef' )
87 . " did not pass container type constraint '$container_type_constraint'";
88 push @keys, $key;
e3c07b19 89 push @values, $value;
90 }
91
92 if ( @values > 1 ) {
93 @{ $reader->($self) }{@keys} = @values;
046c8b5e 94 }
95 else {
96 $reader->($self)->{ $keys[0] } = $values[0];
e3c07b19 97 }
98 };
99 }
100 else {
101 return sub {
102 if ( @_ == 3 ) {
046c8b5e 103 $reader->( $_[0] )->{ $_[1] } = $_[2];
104 }
105 else {
e3c07b19 106 my ( $self, @kvp ) = @_;
107 my ( @keys, @values );
108
046c8b5e 109 while (@kvp) {
110 push @keys, shift @kvp;
e3c07b19 111 push @values, shift @kvp;
112 }
113
046c8b5e 114 @{ $reader->( $_[0] ) }{@keys} = @values;
e3c07b19 115 }
116 };
117 }
118}
119
120sub accessor : method {
046c8b5e 121 my ( $attr, $reader, $writer ) = @_;
122
123 if (
124 $attr->has_type_constraint
125 && $attr->type_constraint->isa(
126 'Moose::Meta::TypeConstraint::Parameterized')
127 ) {
128 my $container_type_constraint
129 = $attr->type_constraint->type_parameter;
e3c07b19 130 return sub {
131 my $self = shift;
132
046c8b5e 133 if ( @_ == 1 ) { # reader
134 return $reader->($self)->{ $_[0] };
e3c07b19 135 }
046c8b5e 136 elsif ( @_ == 2 ) { # writer
137 ( $container_type_constraint->check( $_[1] ) )
138 || confess "Value "
139 . ( $_[1] || 'undef' )
140 . " did not pass container type constraint '$container_type_constraint'";
141 $reader->($self)->{ $_[0] } = $_[1];
e3c07b19 142 }
143 else {
144 confess "One or two arguments expected, not " . @_;
145 }
146 };
147 }
148 else {
149 return sub {
150 my $self = shift;
151
046c8b5e 152 if ( @_ == 1 ) { # reader
153 return $reader->($self)->{ $_[0] };
e3c07b19 154 }
046c8b5e 155 elsif ( @_ == 2 ) { # writer
156 $reader->($self)->{ $_[0] } = $_[1];
e3c07b19 157 }
158 else {
159 confess "One or two arguments expected, not " . @_;
160 }
161 };
162 }
163}
164
165sub clear : method {
046c8b5e 166 my ( $attr, $reader, $writer ) = @_;
167 return sub { %{ $reader->( $_[0] ) } = () };
e3c07b19 168}
169
170sub delete : method {
046c8b5e 171 my ( $attr, $reader, $writer ) = @_;
e3c07b19 172 return sub {
173 my $hashref = $reader->(shift);
174 CORE::delete @{$hashref}{@_};
175 };
176}
177
1781;
179
180__END__
181
182=pod
183
184=head1 NAME
185
a40b446a 186Moose::Meta::Attribute::Trait::Native::MethodProvider::Hash
e3c07b19 187
188=head1 DESCRIPTION
189
190This is a role which provides the method generators for
a40b446a 191L<Moose::Meta::Attribute::Trait::Native::Hash>.
e3c07b19 192
193This role is composed from the
a40b446a 194L<Moose::Meta::Attribute::Trait::Native::ImmutableHash> role.
e3c07b19 195
196=head1 METHODS
197
198=over 4
199
200=item B<meta>
201
202=back
203
204=head1 PROVIDED METHODS
205
206=over 4
207
208=item B<count>
209
e11fb12c 210Returns the number of elements in the list.
e3c07b19 211
212=item B<empty>
213
214If the list is populated, returns true. Otherwise, returns false.
215
e3c07b19 216=item B<exists>
217
218Returns true if the given key is present in the hash
219
e11fb12c 220=item B<defined>
221
222Returns true if the value of a given key is defined
223
e3c07b19 224=item B<get>
225
226Returns an element of the hash by its key.
227
228=item B<keys>
229
230Returns the list of keys in the hash.
231
e3c07b19 232=item B<values>
233
234Returns the list of values in the hash.
235
236=item B<kv>
237
e11fb12c 238Returns the key, value pairs in the hash as array references
239
240=item B<elements>
241
242Returns the key, value pairs in the hash as a flattened list
243
244=item B<delete>
245
246Removes the element with the given key
247
248=item B<clear>
249
250Unsets the hash entirely.
251
252=item B<set>
253
254Sets the element in the hash at the given key to the given value.
e3c07b19 255
256=item B<accessor>
257
258If passed one argument, returns the value of the requested key. If passed two
259arguments, sets the value of the requested key.
260
261=back
262
263=head1 BUGS
264
265All complex software has bugs lurking in it, and this module is no
266exception. If you find a bug please either email me, or add the bug
267to cpan-RT.
268
269=head1 AUTHOR
270
271Stevan Little E<lt>stevan@iinteractive.comE<gt>
272
273=head1 COPYRIGHT AND LICENSE
274
275Copyright 2007-2009 by Infinity Interactive, Inc.
276
277L<http://www.iinteractive.com>
278
279This library is free software; you can redistribute it and/or modify
280it under the same terms as Perl itself.
281
282=cut
283