bump version to 1.12
[gitmo/Moose.git] / lib / Moose / Meta / Attribute / Native / MethodProvider / Hash.pm
1 package Moose::Meta::Attribute::Native::MethodProvider::Hash;
2 use Moose::Role;
3
4 our $VERSION   = '1.12';
5 $VERSION = eval $VERSION;
6 our $AUTHORITY = 'cpan:STEVAN';
7
8 sub exists : method {
9     my ( $attr, $reader, $writer ) = @_;
10     return sub { CORE::exists $reader->( $_[0] )->{ $_[1] } ? 1 : 0 };
11 }
12
13 sub defined : method {
14     my ( $attr, $reader, $writer ) = @_;
15     return sub { CORE::defined $reader->( $_[0] )->{ $_[1] } ? 1 : 0 };
16 }
17
18 sub 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
31 sub keys : method {
32     my ( $attr, $reader, $writer ) = @_;
33     return sub { CORE::keys %{ $reader->( $_[0] ) } };
34 }
35
36 sub values : method {
37     my ( $attr, $reader, $writer ) = @_;
38     return sub { CORE::values %{ $reader->( $_[0] ) } };
39 }
40
41 sub kv : method {
42     my ( $attr, $reader, $writer ) = @_;
43     return sub {
44         my $h = $reader->( $_[0] );
45         map { [ $_, $h->{$_} ] } CORE::keys %{$h};
46     };
47 }
48
49 sub elements : method {
50     my ( $attr, $reader, $writer ) = @_;
51     return sub {
52         my $h = $reader->( $_[0] );
53         map { $_, $h->{$_} } CORE::keys %{$h};
54     };
55 }
56
57 sub count : method {
58     my ( $attr, $reader, $writer ) = @_;
59     return sub { scalar CORE::keys %{ $reader->( $_[0] ) } };
60 }
61
62 sub is_empty : method {
63     my ( $attr, $reader, $writer ) = @_;
64     return sub { scalar CORE::keys %{ $reader->( $_[0] ) } ? 0 : 1 };
65 }
66
67
68 sub set : method {
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;
77         return sub {
78             my ( $self, @kvp ) = @_;
79
80             my ( @keys, @values );
81
82             while (@kvp) {
83                 my ( $key, $value ) = ( shift(@kvp), shift(@kvp) );
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;
89                 push @values, $value;
90             }
91
92             if ( @values > 1 ) {
93                 @{ $reader->($self) }{@keys} = @values;
94             }
95             else {
96                 $reader->($self)->{ $keys[0] } = $values[0];
97             }
98         };
99     }
100     else {
101         return sub {
102             if ( @_ == 3 ) {
103                 $reader->( $_[0] )->{ $_[1] } = $_[2];
104             }
105             else {
106                 my ( $self, @kvp ) = @_;
107                 my ( @keys, @values );
108
109                 while (@kvp) {
110                     push @keys,   shift @kvp;
111                     push @values, shift @kvp;
112                 }
113
114                 @{ $reader->( $_[0] ) }{@keys} = @values;
115             }
116         };
117     }
118 }
119
120 sub accessor : method {
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;
130         return sub {
131             my $self = shift;
132
133             if ( @_ == 1 ) {    # reader
134                 return $reader->($self)->{ $_[0] };
135             }
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];
142             }
143             else {
144                 confess "One or two arguments expected, not " . @_;
145             }
146         };
147     }
148     else {
149         return sub {
150             my $self = shift;
151
152             if ( @_ == 1 ) {    # reader
153                 return $reader->($self)->{ $_[0] };
154             }
155             elsif ( @_ == 2 ) {    # writer
156                 $reader->($self)->{ $_[0] } = $_[1];
157             }
158             else {
159                 confess "One or two arguments expected, not " . @_;
160             }
161         };
162     }
163 }
164
165 sub clear : method {
166     my ( $attr, $reader, $writer ) = @_;
167     return sub { %{ $reader->( $_[0] ) } = () };
168 }
169
170 sub delete : method {
171     my ( $attr, $reader, $writer ) = @_;
172     return sub {
173         my $hashref = $reader->(shift);
174         CORE::delete @{$hashref}{@_};
175     };
176 }
177
178 1;
179
180 __END__
181
182 =pod
183
184 =head1 NAME
185
186 Moose::Meta::Attribute::Native::MethodProvider::Hash - role providing method generators for Hash trait
187
188 =head1 DESCRIPTION
189
190 This is a role which provides the method generators for
191 L<Moose::Meta::Attribute::Native::Trait::Hash>. Please check there for
192 documentation on what methods are provided.
193
194 =head1 METHODS
195
196 =over 4
197
198 =item B<meta>
199
200 =back
201
202 =head1 BUGS
203
204 See L<Moose/BUGS> for details on reporting bugs.
205
206 =head1 AUTHOR
207
208 Stevan Little E<lt>stevan@iinteractive.comE<gt>
209
210 =head1 COPYRIGHT AND LICENSE
211
212 Copyright 2007-2009 by Infinity Interactive, Inc.
213
214 L<http://www.iinteractive.com>
215
216 This library is free software; you can redistribute it and/or modify
217 it under the same terms as Perl itself.
218
219 =cut
220