Commit | Line | Data |
a40b446a |
1 | package Moose::Meta::Attribute::Trait::Native::MethodProvider::Hash; |
e3c07b19 |
2 | use Moose::Role; |
3 | |
96539d20 |
4 | our $VERSION = '0.87'; |
e3c07b19 |
5 | $VERSION = eval $VERSION; |
6 | our $AUTHORITY = 'cpan:STEVAN'; |
7 | |
a40b446a |
8 | with 'Moose::Meta::Attribute::Trait::Native::MethodProvider::ImmutableHash'; |
e3c07b19 |
9 | |
10 | sub set : method { |
046c8b5e |
11 | my ( $attr, $reader, $writer ) = @_; |
12 | if ( |
13 | $attr->has_type_constraint |
14 | && $attr->type_constraint->isa( |
15 | 'Moose::Meta::TypeConstraint::Parameterized') |
16 | ) { |
17 | my $container_type_constraint |
18 | = $attr->type_constraint->type_parameter; |
e3c07b19 |
19 | return sub { |
20 | my ( $self, @kvp ) = @_; |
21 | |
22 | my ( @keys, @values ); |
23 | |
046c8b5e |
24 | while (@kvp) { |
e3c07b19 |
25 | my ( $key, $value ) = ( shift(@kvp), shift(@kvp) ); |
046c8b5e |
26 | ( $container_type_constraint->check($value) ) |
27 | || confess "Value " |
28 | . ( $value || 'undef' ) |
29 | . " did not pass container type constraint '$container_type_constraint'"; |
30 | push @keys, $key; |
e3c07b19 |
31 | push @values, $value; |
32 | } |
33 | |
34 | if ( @values > 1 ) { |
35 | @{ $reader->($self) }{@keys} = @values; |
046c8b5e |
36 | } |
37 | else { |
38 | $reader->($self)->{ $keys[0] } = $values[0]; |
e3c07b19 |
39 | } |
40 | }; |
41 | } |
42 | else { |
43 | return sub { |
44 | if ( @_ == 3 ) { |
046c8b5e |
45 | $reader->( $_[0] )->{ $_[1] } = $_[2]; |
46 | } |
47 | else { |
e3c07b19 |
48 | my ( $self, @kvp ) = @_; |
49 | my ( @keys, @values ); |
50 | |
046c8b5e |
51 | while (@kvp) { |
52 | push @keys, shift @kvp; |
e3c07b19 |
53 | push @values, shift @kvp; |
54 | } |
55 | |
046c8b5e |
56 | @{ $reader->( $_[0] ) }{@keys} = @values; |
e3c07b19 |
57 | } |
58 | }; |
59 | } |
60 | } |
61 | |
62 | sub accessor : method { |
046c8b5e |
63 | my ( $attr, $reader, $writer ) = @_; |
64 | |
65 | if ( |
66 | $attr->has_type_constraint |
67 | && $attr->type_constraint->isa( |
68 | 'Moose::Meta::TypeConstraint::Parameterized') |
69 | ) { |
70 | my $container_type_constraint |
71 | = $attr->type_constraint->type_parameter; |
e3c07b19 |
72 | return sub { |
73 | my $self = shift; |
74 | |
046c8b5e |
75 | if ( @_ == 1 ) { # reader |
76 | return $reader->($self)->{ $_[0] }; |
e3c07b19 |
77 | } |
046c8b5e |
78 | elsif ( @_ == 2 ) { # writer |
79 | ( $container_type_constraint->check( $_[1] ) ) |
80 | || confess "Value " |
81 | . ( $_[1] || 'undef' ) |
82 | . " did not pass container type constraint '$container_type_constraint'"; |
83 | $reader->($self)->{ $_[0] } = $_[1]; |
e3c07b19 |
84 | } |
85 | else { |
86 | confess "One or two arguments expected, not " . @_; |
87 | } |
88 | }; |
89 | } |
90 | else { |
91 | return sub { |
92 | my $self = shift; |
93 | |
046c8b5e |
94 | if ( @_ == 1 ) { # reader |
95 | return $reader->($self)->{ $_[0] }; |
e3c07b19 |
96 | } |
046c8b5e |
97 | elsif ( @_ == 2 ) { # writer |
98 | $reader->($self)->{ $_[0] } = $_[1]; |
e3c07b19 |
99 | } |
100 | else { |
101 | confess "One or two arguments expected, not " . @_; |
102 | } |
103 | }; |
104 | } |
105 | } |
106 | |
107 | sub clear : method { |
046c8b5e |
108 | my ( $attr, $reader, $writer ) = @_; |
109 | return sub { %{ $reader->( $_[0] ) } = () }; |
e3c07b19 |
110 | } |
111 | |
112 | sub delete : method { |
046c8b5e |
113 | my ( $attr, $reader, $writer ) = @_; |
e3c07b19 |
114 | return sub { |
115 | my $hashref = $reader->(shift); |
116 | CORE::delete @{$hashref}{@_}; |
117 | }; |
118 | } |
119 | |
120 | 1; |
121 | |
122 | __END__ |
123 | |
124 | =pod |
125 | |
126 | =head1 NAME |
127 | |
a40b446a |
128 | Moose::Meta::Attribute::Trait::Native::MethodProvider::Hash |
e3c07b19 |
129 | |
130 | =head1 DESCRIPTION |
131 | |
132 | This is a role which provides the method generators for |
a40b446a |
133 | L<Moose::Meta::Attribute::Trait::Native::Hash>. |
e3c07b19 |
134 | |
135 | This role is composed from the |
a40b446a |
136 | L<Moose::Meta::Attribute::Trait::Native::ImmutableHash> role. |
e3c07b19 |
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 | Returns the number of elements in the hash. |
153 | |
154 | =item B<delete> |
155 | |
156 | Removes the element with the given key |
157 | |
158 | =item B<defined> |
159 | |
160 | Returns true if the value of a given key is defined |
161 | |
162 | =item B<empty> |
163 | |
164 | If the list is populated, returns true. Otherwise, returns false. |
165 | |
166 | =item B<clear> |
167 | |
168 | Unsets the hash entirely. |
169 | |
170 | =item B<exists> |
171 | |
172 | Returns true if the given key is present in the hash |
173 | |
174 | =item B<get> |
175 | |
176 | Returns an element of the hash by its key. |
177 | |
178 | =item B<keys> |
179 | |
180 | Returns the list of keys in the hash. |
181 | |
182 | =item B<set> |
183 | |
184 | Sets the element in the hash at the given key to the given value. |
185 | |
186 | =item B<values> |
187 | |
188 | Returns the list of values in the hash. |
189 | |
190 | =item B<kv> |
191 | |
192 | Returns the key, value pairs in the hash |
193 | |
194 | =item B<accessor> |
195 | |
196 | If passed one argument, returns the value of the requested key. If passed two |
197 | arguments, sets the value of the requested key. |
198 | |
199 | =back |
200 | |
201 | =head1 BUGS |
202 | |
203 | All complex software has bugs lurking in it, and this module is no |
204 | exception. If you find a bug please either email me, or add the bug |
205 | to cpan-RT. |
206 | |
207 | =head1 AUTHOR |
208 | |
209 | Stevan Little E<lt>stevan@iinteractive.comE<gt> |
210 | |
211 | =head1 COPYRIGHT AND LICENSE |
212 | |
213 | Copyright 2007-2009 by Infinity Interactive, Inc. |
214 | |
215 | L<http://www.iinteractive.com> |
216 | |
217 | This library is free software; you can redistribute it and/or modify |
218 | it under the same terms as Perl itself. |
219 | |
220 | =cut |
221 | |