line |
stmt |
bran |
cond |
sub |
code |
1
|
|
|
|
|
package List::Objects::WithUtils::Role::Hash; |
2
|
40
|
|
|
40
|
use strictures 1; |
|
40
|
|
|
|
|
|
40
|
|
|
|
|
3
|
|
|
|
|
|
4
|
40
|
|
|
40
|
use Module::Runtime (); |
|
40
|
|
|
|
|
|
40
|
|
|
|
|
5
|
40
|
|
|
40
|
use Scalar::Util (); |
|
40
|
|
|
|
|
|
40
|
|
|
|
|
6
|
|
|
|
|
|
7
|
|
|
|
|
=pod |
8
|
|
|
|
|
|
9
|
|
|
|
|
=for Pod::Coverage HASH_TYPE blessed_or_pkg |
10
|
|
|
|
|
|
11
|
|
|
|
|
=cut |
12
|
|
|
|
|
|
13
|
|
|
|
|
sub HASH_TYPE () { 'List::Objects::WithUtils::Hash' } |
14
|
|
|
|
|
sub blessed_or_pkg { |
15
|
23
|
|
|
23
|
my $pkg; |
16
|
23
|
100
|
|
|
($pkg = Scalar::Util::blessed $_[0]) ? |
17
|
|
|
|
|
$pkg : Module::Runtime::use_module(HASH_TYPE) |
18
|
|
|
|
|
} |
19
|
|
|
|
|
|
20
|
40
|
|
|
40
|
use Role::Tiny; |
|
40
|
|
|
|
|
|
40
|
|
|
|
|
21
|
|
|
|
|
|
22
|
48
|
|
|
48
|
sub array_type { 'List::Objects::WithUtils::Array' } |
23
|
4
|
|
|
4
|
sub inflated_type { 'List::Objects::WithUtils::Hash::Inflated' } |
24
|
2
|
|
|
2
|
sub inflated_rw_type { 'List::Objects::WithUtils::Hash::Inflated::RW' } |
25
|
|
|
|
|
|
26
|
|
|
|
|
=pod |
27
|
|
|
|
|
|
28
|
|
|
|
|
=for Pod::Coverage TO_JSON type |
29
|
|
|
|
|
|
30
|
|
|
|
|
=cut |
31
|
|
|
|
|
|
32
|
2
|
|
|
2
|
sub is_mutable { 1 } |
33
|
2
|
|
|
2
|
sub is_immutable { ! $_[0]->is_mutable } |
34
|
|
|
|
|
|
35
|
1
|
|
|
1
|
sub type { } |
36
|
|
|
|
|
|
37
|
|
|
|
|
sub new { |
38
|
32
|
|
|
32
|
Module::Runtime::require_module( $_[0]->array_type ); |
39
|
32
|
|
|
|
bless +{ @_[1 .. $#_] }, $_[0] |
40
|
|
|
|
|
} |
41
|
|
|
|
|
|
42
|
2
|
|
|
2
|
sub unbless { +{ %{ $_[0] } } } |
|
2
|
|
|
|
|
43
|
40
|
|
|
40
|
{ no warnings 'once'; *TO_JSON = *unbless; } |
|
40
|
|
|
|
|
|
40
|
|
|
|
|
44
|
|
|
|
|
|
45
|
2
|
|
|
2
|
sub clear { %{ $_[0] } = (); $_[0] } |
|
2
|
|
|
|
|
|
2
|
|
|
|
|
46
|
|
|
|
|
|
47
|
|
|
|
|
sub copy { |
48
|
2
|
|
|
2
|
bless +{ %{ $_[0] } }, blessed_or_pkg($_[0]) |
|
2
|
|
|
|
|
49
|
|
|
|
|
} |
50
|
|
|
|
|
|
51
|
|
|
|
|
sub inflate { |
52
|
3
|
|
|
3
|
my ($self, %params) = @_; |
53
|
3
|
100
|
|
|
my $type = $params{rw} ? 'inflated_rw_type' : 'inflated_type'; |
54
|
3
|
|
|
|
my $pkg = blessed_or_pkg($self); |
55
|
3
|
|
|
|
Module::Runtime::require_module( $pkg->$type ); |
56
|
3
|
|
|
|
$pkg->$type->new( %$self ) |
57
|
|
|
|
|
} |
58
|
|
|
|
|
|
59
|
3
|
|
|
3
|
sub defined { CORE::defined $_[0]->{ $_[1] } } |
60
|
4
|
|
|
4
|
sub exists { CORE::exists $_[0]->{ $_[1] } } |
61
|
|
|
|
|
|
62
|
5
|
100
|
|
5
|
sub is_empty { keys %{ $_[0] } ? 0 : 1 } |
|
5
|
|
|
|
|
63
|
|
|
|
|
|
64
|
|
|
|
|
sub get { |
65
|
20
|
100
|
|
20
|
if (@_ > 2) { |
66
|
1
|
|
|
|
return blessed_or_pkg($_[0])->array_type->new( |
67
|
1
|
|
|
|
@{ $_[0] }{ @_[1 .. $#_] } |
68
|
|
|
|
|
) |
69
|
|
|
|
|
} |
70
|
19
|
|
|
|
$_[0]->{ $_[1] } |
71
|
|
|
|
|
} |
72
|
|
|
|
|
|
73
|
|
|
|
|
sub sliced { |
74
|
|
|
|
|
blessed_or_pkg($_[0])->new( |
75
|
3
|
|
|
3
|
map {; |
76
|
7
|
100
|
|
|
exists $_[0]->{$_} ? |
77
|
|
|
|
|
( $_ => $_[0]->{$_} ) |
78
|
|
|
|
|
: () |
79
|
|
|
|
|
} @_[1 .. $#_] |
80
|
|
|
|
|
) |
81
|
|
|
|
|
} |
82
|
|
|
|
|
|
83
|
|
|
|
|
sub set { |
84
|
6
|
|
|
6
|
my $self = shift; |
85
|
6
|
|
|
|
my @keysidx = grep {; not $_ % 2 } 0 .. $#_ ; |
|
16
|
|
|
|
|
86
|
6
|
|
|
|
my @valsidx = grep {; $_ % 2 } 0 .. $#_ ; |
|
16
|
|
|
|
|
87
|
|
|
|
|
|
88
|
6
|
|
|
|
@{$self}{ @_[@keysidx] } = @_[@valsidx]; |
|
6
|
|
|
|
|
89
|
|
|
|
|
|
90
|
5
|
|
|
|
$self |
91
|
|
|
|
|
} |
92
|
|
|
|
|
|
93
|
|
|
|
|
sub delete { |
94
|
3
|
|
|
|
blessed_or_pkg($_[0])->array_type->new( |
95
|
3
|
|
|
3
|
CORE::delete @{ $_[0] }{ @_[1 .. $#_] } |
96
|
|
|
|
|
) |
97
|
|
|
|
|
} |
98
|
|
|
|
|
|
99
|
|
|
|
|
sub keys { |
100
|
5
|
|
|
|
blessed_or_pkg($_[0])->array_type->new( |
101
|
5
|
|
|
5
|
CORE::keys %{ $_[0] } |
102
|
|
|
|
|
) |
103
|
|
|
|
|
} |
104
|
|
|
|
|
|
105
|
|
|
|
|
sub values { |
106
|
2
|
|
|
|
blessed_or_pkg($_[0])->array_type->new( |
107
|
2
|
|
|
2
|
CORE::values %{ $_[0] } |
108
|
|
|
|
|
) |
109
|
|
|
|
|
} |
110
|
|
|
|
|
|
111
|
|
|
|
|
sub kv { |
112
|
|
|
|
|
blessed_or_pkg($_[0])->array_type->new( |
113
|
2
|
|
|
2
|
map {; [ $_, $_[0]->{ $_ } ] } CORE::keys %{ $_[0] } |
|
4
|
|
|
|
|
|
2
|
|
|
|
|
114
|
|
|
|
|
) |
115
|
|
|
|
|
} |
116
|
|
|
|
|
|
117
|
|
|
|
|
sub kv_sort { |
118
|
2
|
100
|
|
2
|
if (defined $_[1]) { |
119
|
|
|
|
|
return blessed_or_pkg($_[0])->array_type->new( |
120
|
4
|
|
|
|
map {; [ $_, $_[0]->{ $_ } ] } |
121
|
1
|
|
|
|
CORE::sort {; $_[1]->($a, $b) } CORE::keys %{ $_[0] } |
|
5
|
|
|
|
|
|
1
|
|
|
|
|
122
|
|
|
|
|
) |
123
|
|
|
|
|
} |
124
|
|
|
|
|
blessed_or_pkg($_[0])->array_type->new( |
125
|
1
|
|
|
|
map {; [ $_, $_[0]->{ $_ } ] } CORE::sort( CORE::keys %{ $_[0] } ) |
|
4
|
|
|
|
|
|
1
|
|
|
|
|
126
|
|
|
|
|
) |
127
|
|
|
|
|
} |
128
|
|
|
|
|
|
129
|
3
|
|
|
3
|
sub export { %{ $_[0] } } |
|
3
|
|
|
|
|
130
|
|
|
|
|
|
131
|
|
|
|
|
1; |
132
|
|
|
|
|
|
133
|
|
|
|
|
|
134
|
|
|
|
|
=pod |
135
|
|
|
|
|
|
136
|
|
|
|
|
=head1 NAME |
137
|
|
|
|
|
|
138
|
|
|
|
|
List::Objects::WithUtils::Role::Hash - Hash manipulation methods |
139
|
|
|
|
|
|
140
|
|
|
|
|
=head1 SYNOPSIS |
141
|
|
|
|
|
|
142
|
|
|
|
|
## Via List::Objects::WithUtils::Hash -> |
143
|
|
|
|
|
use List::Objects::WithUtils 'hash'; |
144
|
|
|
|
|
|
145
|
|
|
|
|
my $hash = hash(foo => 'bar'); |
146
|
|
|
|
|
|
147
|
|
|
|
|
$hash->set( |
148
|
|
|
|
|
foo => 'baz', |
149
|
|
|
|
|
pie => 'tasty', |
150
|
|
|
|
|
); |
151
|
|
|
|
|
|
152
|
|
|
|
|
my @matches = $hash->keys->grep(sub { |
153
|
|
|
|
|
$_[0] =~ /foo/ |
154
|
|
|
|
|
})->all; |
155
|
|
|
|
|
|
156
|
|
|
|
|
my $pie = $hash->get('pie') |
157
|
|
|
|
|
if $hash->exists('pie'); |
158
|
|
|
|
|
|
159
|
|
|
|
|
for my $pair ( $hash->kv->all ) { |
160
|
|
|
|
|
my ($key, $val) = @$pair; |
161
|
|
|
|
|
... |
162
|
|
|
|
|
} |
163
|
|
|
|
|
|
164
|
|
|
|
|
my $obj = $hash->inflate; |
165
|
|
|
|
|
my $foo = $obj->foo; |
166
|
|
|
|
|
|
167
|
|
|
|
|
## As a Role -> |
168
|
|
|
|
|
use Role::Tiny::With; |
169
|
|
|
|
|
with 'List::Objects::WithUtils::Role::Hash'; |
170
|
|
|
|
|
|
171
|
|
|
|
|
=head1 DESCRIPTION |
172
|
|
|
|
|
|
173
|
|
|
|
|
A L<Role::Tiny> role defining methods for creating and manipulating HASH-type |
174
|
|
|
|
|
objects. |
175
|
|
|
|
|
|
176
|
|
|
|
|
In addition to the methods documented below, these objects provide a |
177
|
|
|
|
|
C<TO_JSON> method exporting a plain HASH-type reference for convenience when |
178
|
|
|
|
|
feeding L<JSON::Tiny> or similar. |
179
|
|
|
|
|
|
180
|
|
|
|
|
=head2 new |
181
|
|
|
|
|
|
182
|
|
|
|
|
Constructs a new HASH-type object. |
183
|
|
|
|
|
|
184
|
|
|
|
|
=head2 export |
185
|
|
|
|
|
|
186
|
|
|
|
|
my %hash = $hash->export; |
187
|
|
|
|
|
|
188
|
|
|
|
|
Returns a raw key/value list. |
189
|
|
|
|
|
|
190
|
|
|
|
|
=head2 clear |
191
|
|
|
|
|
|
192
|
|
|
|
|
Clears the current hash entirely. |
193
|
|
|
|
|
|
194
|
|
|
|
|
Returns the hash object (as of version 1.013). |
195
|
|
|
|
|
|
196
|
|
|
|
|
=head2 copy |
197
|
|
|
|
|
|
198
|
|
|
|
|
Creates a shallow clone of the current object. |
199
|
|
|
|
|
|
200
|
|
|
|
|
=head2 unbless |
201
|
|
|
|
|
|
202
|
|
|
|
|
Returns a plain C</HASH> reference (shallow clone). |
203
|
|
|
|
|
|
204
|
|
|
|
|
=head2 defined |
205
|
|
|
|
|
|
206
|
|
|
|
|
if ( $hash->defined($key) ) { ... } |
207
|
|
|
|
|
|
208
|
|
|
|
|
Returns boolean true if the key has a defined value. |
209
|
|
|
|
|
|
210
|
|
|
|
|
=head2 delete |
211
|
|
|
|
|
|
212
|
|
|
|
|
$hash->delete( @keys ); |
213
|
|
|
|
|
|
214
|
|
|
|
|
Deletes keys from the hash. |
215
|
|
|
|
|
|
216
|
|
|
|
|
Returns an L</array_type> object containing the deleted values. |
217
|
|
|
|
|
|
218
|
|
|
|
|
=head2 exists |
219
|
|
|
|
|
|
220
|
|
|
|
|
if ( $hash->exists($key) ) { ... } |
221
|
|
|
|
|
|
222
|
|
|
|
|
Returns boolean true if the key exists. |
223
|
|
|
|
|
|
224
|
|
|
|
|
=head2 get |
225
|
|
|
|
|
|
226
|
|
|
|
|
my $val = $hash->get($key); |
227
|
|
|
|
|
my @vals = $hash->get(@keys)->all; |
228
|
|
|
|
|
|
229
|
|
|
|
|
Retrieves a key or list of keys from the hash. |
230
|
|
|
|
|
|
231
|
|
|
|
|
If we're taking a slice (multiple keys were specified), values are returned |
232
|
|
|
|
|
as an L</array_type> object. (See L</sliced> if you'd rather generate a new |
233
|
|
|
|
|
hash.) |
234
|
|
|
|
|
|
235
|
|
|
|
|
=head2 inflate |
236
|
|
|
|
|
|
237
|
|
|
|
|
my $obj = hash(foo => 'bar', baz => 'quux')->inflate; |
238
|
|
|
|
|
my $baz = $obj->baz; |
239
|
|
|
|
|
|
240
|
|
|
|
|
Inflates a simple object providing accessors for a hash. |
241
|
|
|
|
|
|
242
|
|
|
|
|
By default, accessors are read-only; specifying C<rw => 1> allows setting new |
243
|
|
|
|
|
values: |
244
|
|
|
|
|
|
245
|
|
|
|
|
my $obj = hash(foo => 'bar', baz => 'quux')->inflate(rw => 1); |
246
|
|
|
|
|
$obj->foo('frobulate'); |
247
|
|
|
|
|
|
248
|
|
|
|
|
Returns an L</inflated_type> (or L</inflated_rw_type>) object. |
249
|
|
|
|
|
|
250
|
|
|
|
|
The default objects provide a C<DEFLATE> method returning a |
251
|
|
|
|
|
plain hash; this makes it easy to turn inflated objects back into a C<hash()> |
252
|
|
|
|
|
for modification: |
253
|
|
|
|
|
|
254
|
|
|
|
|
my $first = hash( foo => 'bar', baz => 'quux' )->inflate; |
255
|
|
|
|
|
my $second = hash( $first->DEFLATE, frobulate => 1 )->inflate; |
256
|
|
|
|
|
|
257
|
|
|
|
|
=head2 is_empty |
258
|
|
|
|
|
|
259
|
|
|
|
|
Returns boolean true if the hash has no keys. |
260
|
|
|
|
|
|
261
|
|
|
|
|
=head2 is_mutable |
262
|
|
|
|
|
|
263
|
|
|
|
|
Returns boolean true if the hash is mutable; immutable subclasses can override |
264
|
|
|
|
|
to provide a negative value. |
265
|
|
|
|
|
|
266
|
|
|
|
|
=head2 is_immutable |
267
|
|
|
|
|
|
268
|
|
|
|
|
The opposite of L</is_mutable>. |
269
|
|
|
|
|
|
270
|
|
|
|
|
=head2 keys |
271
|
|
|
|
|
|
272
|
|
|
|
|
my @keys = $hash->keys->all; |
273
|
|
|
|
|
|
274
|
|
|
|
|
Returns the list of keys in the hash as an L</array_type> object. |
275
|
|
|
|
|
|
276
|
|
|
|
|
=head2 values |
277
|
|
|
|
|
|
278
|
|
|
|
|
my @vals = $hash->values->all; |
279
|
|
|
|
|
|
280
|
|
|
|
|
Returns the list of values in the hash as an L</array_type> object. |
281
|
|
|
|
|
|
282
|
|
|
|
|
=head2 kv |
283
|
|
|
|
|
|
284
|
|
|
|
|
for my $pair ($hash->kv->all) { |
285
|
|
|
|
|
my ($key, $val) = @$pair; |
286
|
|
|
|
|
} |
287
|
|
|
|
|
|
288
|
|
|
|
|
Returns an L</array_type> object containing the key/value pairs in the HASH, |
289
|
|
|
|
|
each of which is a two-element ARRAY. |
290
|
|
|
|
|
|
291
|
|
|
|
|
=head2 kv_sort |
292
|
|
|
|
|
|
293
|
|
|
|
|
my $kvs = hash(a => 1, b => 2, c => 3)->kv_sort; |
294
|
|
|
|
|
# $kvs = array( |
295
|
|
|
|
|
# [ a => 1 ], |
296
|
|
|
|
|
# [ b => 2 ], |
297
|
|
|
|
|
# [ c => 3 ] |
298
|
|
|
|
|
# ) |
299
|
|
|
|
|
|
300
|
|
|
|
|
my $reversed = hash(a => 1, b => 2, c => 3) |
301
|
|
|
|
|
->kv_sort(sub { $_[1] cmp $_[0] }); |
302
|
|
|
|
|
# Reverse result as above |
303
|
|
|
|
|
|
304
|
|
|
|
|
Like L</kv>, but sorted by key. A sort routine can be provided; C<$_[0]> and |
305
|
|
|
|
|
C<$_[1]> are equivalent to the usual sort variables C<$a> and C<$b>. |
306
|
|
|
|
|
|
307
|
|
|
|
|
=head2 set |
308
|
|
|
|
|
|
309
|
|
|
|
|
$hash->set( |
310
|
|
|
|
|
key1 => $val, |
311
|
|
|
|
|
key2 => $other, |
312
|
|
|
|
|
) |
313
|
|
|
|
|
|
314
|
|
|
|
|
Sets keys in the hash. |
315
|
|
|
|
|
|
316
|
|
|
|
|
As of version 1.007, returns the current hash object. |
317
|
|
|
|
|
The return value of prior versions is unreliable. |
318
|
|
|
|
|
|
319
|
|
|
|
|
=head2 sliced |
320
|
|
|
|
|
|
321
|
|
|
|
|
my $newhash = $hash->sliced(@keys); |
322
|
|
|
|
|
|
323
|
|
|
|
|
Returns a new hash object built from the specified set of keys. |
324
|
|
|
|
|
|
325
|
|
|
|
|
(See L</get> if you only need the values.) |
326
|
|
|
|
|
|
327
|
|
|
|
|
=head2 array_type |
328
|
|
|
|
|
|
329
|
|
|
|
|
The class name of array-type objects that will be used to contain the results |
330
|
|
|
|
|
of methods returning a list. |
331
|
|
|
|
|
|
332
|
|
|
|
|
Defaults to L<List::Objects::WithUtils::Array>. |
333
|
|
|
|
|
|
334
|
|
|
|
|
Subclasses can override C<array_type> to produce different types of array |
335
|
|
|
|
|
objects; the method can also be queried to find out what kind of array object |
336
|
|
|
|
|
will be returned: |
337
|
|
|
|
|
|
338
|
|
|
|
|
my $type = $hash->array_type; |
339
|
|
|
|
|
|
340
|
|
|
|
|
=head2 inflated_type |
341
|
|
|
|
|
|
342
|
|
|
|
|
The class name that objects are blessed into when calling L</inflate>. |
343
|
|
|
|
|
|
344
|
|
|
|
|
Defaults to L<List::Objects::WithUtils::Hash::Inflated>. |
345
|
|
|
|
|
|
346
|
|
|
|
|
=head2 inflated_rw_type |
347
|
|
|
|
|
|
348
|
|
|
|
|
The class name that objects are blessed into when calling L</inflate> with |
349
|
|
|
|
|
C<rw => 1>. |
350
|
|
|
|
|
|
351
|
|
|
|
|
Defaults to L<List::Objects::WithUtils::Hash::Inflated::RW>, a subclass of |
352
|
|
|
|
|
L<List::Objects::WithUtils::Hash::Inflated>. |
353
|
|
|
|
|
|
354
|
|
|
|
|
=head1 SEE ALSO |
355
|
|
|
|
|
|
356
|
|
|
|
|
L<List::Objects::WithUtils> |
357
|
|
|
|
|
|
358
|
|
|
|
|
L<Data::Perl> |
359
|
|
|
|
|
|
360
|
|
|
|
|
=head1 AUTHOR |
361
|
|
|
|
|
|
362
|
|
|
|
|
Jon Portnoy <avenj@cobaltirc.org> |
363
|
|
|
|
|
|
364
|
|
|
|
|
Portions of this code are derived from L<Data::Perl> by Matthew Phillips |
365
|
|
|
|
|
(CPAN: MATTP), haarg et al |
366
|
|
|
|
|
|
367
|
|
|
|
|
Licensed under the same terms as Perl. |
368
|
|
|
|
|
|
369
|
|
|
|
|
=cut |
370
|
|
|
|
|
|