File Coverage

blib/lib/Sub/HandlesVia/HandlerLibrary/Hash.pm
Criterion Covered Total %
statement 83 85 97.6
branch 6 10 60.0
condition 14 24 58.3
subroutine 43 44 97.7
pod 21 21 100.0
total 167 184 90.7


line stmt bran cond sub pod time code
1 12     12   854 use 5.008;
  12         47  
2 12     12   73 use strict;
  12         26  
  12         348  
3 12     12   66 use warnings;
  12         38  
  12         829  
4              
5             package Sub::HandlesVia::HandlerLibrary::Hash;
6              
7             our $AUTHORITY = 'cpan:TOBYINK';
8             our $VERSION = '0.046';
9              
10 12     12   4252 use Sub::HandlesVia::HandlerLibrary;
  12         35  
  12         635  
11             our @ISA = 'Sub::HandlesVia::HandlerLibrary';
12              
13 12     12   99 use Sub::HandlesVia::Handler qw( handler );
  12         28  
  12         105  
14 12     12   1128 use Types::Standard qw( HashRef ArrayRef Optional Str CodeRef Item Any Ref Defined RegexpRef );
  12         38  
  12         70  
15              
16             our @METHODS = qw( all accessor clear count defined delete elements exists get
17             is_empty keys kv set shallow_clone values sorted_keys reset delete_where
18             for_each_key for_each_value for_each_pair );
19              
20             sub _type_inspector {
21 194     194   496 my ($me, $type) = @_;
22 194 50 66     715 if ($type == HashRef or $type == Ref or $type == Ref['HASH']) {
      66        
23             return {
24 29         2441 trust_mutated => 'always',
25             };
26             }
27 165 50 66     575756 if ($type->is_parameterized and $type->parent->name eq 'HashRef' and $type->parent->library eq 'Types::Standard') {
      66        
28             return {
29 80         6039 trust_mutated => 'maybe',
30             value_type => $type->type_parameter,
31             key_type => Str,
32             };
33             }
34 85 0 33     5501 if ($type->is_parameterized and $type->parent->name eq 'Map' and $type->parent->library eq 'Types::Standard') {
      33        
35             return {
36 0         0 trust_mutated => 'maybe',
37             value_type => $type->parameters->[1],
38             key_type => $type->parameters->[0],
39             };
40             }
41 85         835 return $me->SUPER::_type_inspector($type);
42             }
43              
44             my $additional_validation_for_set_and_insert = sub {
45             my $self = CORE::shift;
46             my ($sig_was_checked, $gen) = @_;
47             my $ti = __PACKAGE__->_type_inspector($gen->isa);
48            
49             if ($ti and $ti->{trust_mutated} eq 'always') {
50             return { code => '1;', env => {} };
51             }
52             if ($ti and $ti->{trust_mutated} eq 'maybe') {
53             my ( $env, $code, $arg );
54             $env = {};
55             $arg = sub {
56             my $gen = shift;
57             return '$shv_key' if $_[0]=='1';
58             return '$shv_value' if $_[0]=='2';
59             $gen->generate_arg( @_ );
60             };
61             $code = sprintf(
62             'my($shv_key,$shv_value)=%s; if (%s>0) { %s }; if (%s>1) { %s };',
63             $gen->generate_args,
64             $gen->generate_argc,
65             $gen->generate_type_assertion( $env, $ti->{key_type} || Str, '$shv_key' ),
66             $gen->generate_argc,
67             $gen->generate_type_assertion( $env, $ti->{value_type}, '$shv_value' ),
68             );
69             return {
70             code => $code,
71             env => $env,
72             arg => $arg,
73             };
74             }
75             return;
76             };
77              
78              
79             sub count {
80             handler
81             name => 'Hash:count',
82             args => 0,
83             template => 'scalar keys %{$GET}',
84             documentation => 'Returns the number of keys in the hash.',
85             _examples => sub {
86 1     1   66 my ( $class, $attr, $method ) = @_;
87 1         7 return join "",
88             " my \$object = $class\->new( $attr => { foo => 0, bar => 1 } );\n",
89             " say \$object->$method; ## ==> 2\n",
90             "\n";
91             },
92 41     41 1 407 }
93              
94             sub is_empty {
95             handler
96             name => 'Hash:is_empty',
97             args => 0,
98             template => '!scalar keys %{$GET}',
99             documentation => 'Returns true iff there are no keys in the hash.',
100             _examples => sub {
101 1     1   63 my ( $class, $attr, $method ) = @_;
102 1         9 return join "",
103             " my \$object = $class\->new( $attr => { foo => 0, bar => 1 } );\n",
104             " say \$object->$method; ## ==> false\n",
105             " \$object->_set_$attr( {} );\n",
106             " say \$object->$method; ## ==> true\n",
107             "\n";
108             },
109 41     41 1 400 }
110              
111             sub keys {
112             handler
113             name => 'Hash:keys',
114             args => 0,
115             template => 'keys %{$GET}',
116             documentation => 'Returns the list of keys in the hash.',
117             _examples => sub {
118 1     1   64 my ( $class, $attr, $method ) = @_;
119 1         9 return join "",
120             " my \$object = $class\->new( $attr => { foo => 0, bar => 1 } );\n",
121             " # says 'foo' and 'bar' in an unpredictable order\n",
122             " say for \$object->$method;\n",
123             "\n";
124             },
125 41     41 1 387 }
126              
127             sub sorted_keys {
128             handler
129             name => 'Hash:sorted_keys',
130             args => 0,
131             template => 'sort(keys %{$GET})',
132             documentation => 'Returns an alphabetically sorted list of keys in the hash.',
133             _examples => sub {
134 1     1   65 my ( $class, $attr, $method ) = @_;
135 1         7 return join "",
136             " my \$object = $class\->new( $attr => { foo => 0, bar => 1 } );\n",
137             " # says 'bar' then 'foo'\n",
138             " say for \$object->$method;\n",
139             "\n";
140             },
141 3     3 1 41 }
142              
143             sub values {
144             handler
145             name => 'Hash:values',
146             args => 0,
147             template => 'values %{$GET}',
148             documentation => 'Returns the list of values in the hash.',
149             _examples => sub {
150 1     1   64 my ( $class, $attr, $method ) = @_;
151 1         9 return join "",
152             " my \$object = $class\->new( $attr => { foo => 0, bar => 1 } );\n",
153             " # says '0' and '1' in an unpredictable order\n",
154             " say for \$object->$method;\n",
155             "\n";
156             },
157 41     41 1 418 }
158              
159             sub all {
160             handler
161             name => 'Hash:all',
162             args => 0,
163             template => '%{$GET}',
164             documentation => 'Returns the hash in list context.',
165             _examples => sub {
166 1     1   87 my ( $class, $attr, $method ) = @_;
167 1         6 return join "",
168             " my \$object = $class\->new( $attr => { foo => 0, bar => 1 } );\n",
169             " my \%hash = \$object->$method;\n",
170             "\n";
171             },
172 4     4 1 94 }
173              
174             sub elements {
175             handler
176             name => 'Hash:elements',
177             args => 0,
178             template => '%{$GET}',
179             documentation => 'Returns the hash in list context.',
180             _examples => sub {
181 1     1   63 my ( $class, $attr, $method ) = @_;
182 1         8 return join "",
183             " my \$object = $class\->new( $attr => { foo => 0, bar => 1 } );\n",
184             " my \%hash = \$object->$method;\n",
185             "\n";
186             },
187 41     41 1 469 }
188              
189             sub kv {
190 41     41 1 272 handler
191             name => 'Hash:kv',
192             args => 0,
193             template => 'map [ $_ => ($GET)->{$_} ], keys %{$GET}',
194             documentation => 'Returns a list of arrayrefs, where each arrayref is a key-value pair.',
195             }
196              
197             sub get {
198             handler
199             name => 'Hash:get',
200             min_args => 1,
201             usage => '$key',
202             prefer_shift_self => 1,
203             template => '#ARG>1 ? @{$GET}{@ARG} : ($GET)->{$ARG}',
204             documentation => 'Returns a value from the hashref by its key.',
205             _examples => sub {
206 1     1   64 my ( $class, $attr, $method ) = @_;
207 1         8 return join "",
208             " my \$object = $class\->new( $attr => { foo => 0, bar => 1 } );\n",
209             " say \$object->$method( 'bar' ); ## ==> 1\n",
210             "\n";
211             },
212 44     44 1 416 }
213              
214             sub defined {
215             handler
216             name => 'Hash:defined',
217             args => 1,
218             signature => [Str],
219             usage => '$key',
220             template => 'defined(($GET)->{$ARG})',
221             documentation => 'Indicates whether a value exists and is defined in the hashref by its key.',
222             _examples => sub {
223 1     1   63 my ( $class, $attr, $method ) = @_;
224 1         8 return join "",
225             " my \$object = $class\->new( $attr => { foo => 0, bar => 1 } );\n",
226             " say \$object->$method( 'foo' ); ## ==> 1\n",
227             "\n";
228             },
229 41     41 1 242 }
230              
231             sub exists {
232             handler
233             name => 'Hash:exists',
234             args => 1,
235             signature => [Str],
236             usage => '$key',
237             template => 'defined(($GET)->{$ARG})',
238             documentation => 'Indicates whether a value exists in the hashref by its key.',
239             _examples => sub {
240 1     1   63 my ( $class, $attr, $method ) = @_;
241 1         9 return join "",
242             " my \$object = $class\->new( $attr => { foo => 0, bar => 1 } );\n",
243             " say \$object->$method( 'foo' ); ## ==> true\n",
244             " say \$object->$method( 'baz' ); ## ==> false\n",
245             "\n";
246             },
247 41     41 1 242 }
248              
249             sub delete {
250             handler
251             name => 'Hash:delete',
252             min_args => 1,
253             usage => '$key',
254             template => 'my %shv_tmp = %{$GET}; my @shv_return = delete @shv_tmp{@ARG}; «\%shv_tmp»; wantarray ? @shv_return : $shv_return[-1]',
255             lvalue_template => 'delete(@{$GET}{@ARG})',
256             prefer_shift_self => 1,
257             additional_validation => 'no incoming values',
258             documentation => 'Removes a value from the hashref by its key.',
259             _examples => sub {
260 1     1   63 my ( $class, $attr, $method ) = @_;
261 1         9 return join "",
262             " my \$object = $class\->new( $attr => { foo => 0, bar => 1 } );\n",
263             " \$object->$method( 'foo' );\n",
264             " say exists \$object->$attr\->{foo}; ## ==> false\n",
265             "\n";
266             },
267 41     41 1 470 }
268              
269             sub delete_where {
270             handler
271             name => 'Hash:delete_where',
272             min_args => 1,
273             usage => '$match',
274             signature => [ CodeRef | RegexpRef ],
275             template => 'my %shv_tmp = %{$GET}; my $shv_match = $ARG; my @shv_keys = ("CODE" eq ref $shv_match) ? grep($shv_match->($_), keys %shv_tmp) : grep(/$shv_match/, keys %shv_tmp); my @shv_return = delete @shv_tmp{@shv_keys}; «\%shv_tmp»; wantarray ? @shv_return : $shv_return[-1]',
276             prefer_shift_self => 1,
277             documentation => 'Removes values from the hashref by matching keys against a coderef or regexp.',
278             _examples => sub {
279 1     1   80 my ( $class, $attr, $method ) = @_;
280 1         15 return join "",
281             " my \$object = $class\->new( $attr => { foo => 0, bar => 1, baz => 2 } );\n",
282             " \$object->$method( sub { \$_ eq 'foo' or \$_ eq 'bar' } );\n",
283             " say Dumper( \$object->$attr ); ## ==> { baz => 2 }\n",
284             " \n",
285             " my \$object2 = $class\->new( $attr => { foo => 0, bar => 1, baz => 2 } );\n",
286             " \$object2->$method( qr/^b/ );\n",
287             " say Dumper( \$object2->$attr ); ## ==> { foo => 0 }\n",
288             "\n";
289             },
290 3     3 1 33 }
291              
292             sub clear {
293             handler
294             name => 'Hash:clear',
295             args => 0,
296             template => '«{}»',
297             lvalue_template => '%{$GET} = ()',
298             additional_validation => 'no incoming values',
299             documentation => 'Empties the hash.',
300             _examples => sub {
301 1     1   65 my ( $class, $attr, $method ) = @_;
302 1         9 return join "",
303             " my \$object = $class\->new( $attr => { foo => 0, bar => 1 } );\n",
304             " \$object->$method;\n",
305             " say exists \$object->$attr\->{foo}; ## ==> false\n",
306             " say exists \$object->$attr\->{bar}; ## ==> false\n",
307             "\n";
308             },
309 41     41 1 438 }
310              
311             sub shallow_clone {
312 3     3 1 24 handler
313             name => 'Hash:shallow_clone',
314             args => 0,
315             template => '+{%{$GET}}',
316             documentation => 'Creates a new hashref with the same keys and values as the original.',
317             }
318              
319             sub set {
320 42     42 1 134 my $me = CORE::shift;
321             handler
322             name => 'Hash:set',
323             min_args => 2,
324             usage => '$key, $value, ...',
325             prefer_shift_self => 1,
326             template => (
327             'my (@shv_params) = @ARG; ' .
328             'scalar(@shv_params) % 2 and ⸨"Wrong number of parameters; expected even-sized list of keys and values"⸩;' .
329             'my (@shv_keys_idx) = grep(!($_ % 2), 0..$#shv_params); ' .
330             'my (@shv_values_idx) = grep(($_ % 2), 0..$#shv_params); ' .
331             'grep(!defined, @shv_params[@shv_keys_idx]) and ⸨"Undef did not pass type constraint; keys must be defined"⸩;'.
332             '"____VALIDATION_HERE____"; '.
333             'my %shv_tmp = %{$GET}; @shv_tmp{@shv_params[@shv_keys_idx]} = @shv_params[@shv_values_idx]; «\\%shv_tmp»;' .
334             'wantarray ? @shv_tmp{@shv_params[@shv_keys_idx]} : $shv_tmp{$shv_params[$shv_keys_idx[0]]}' ),
335             lvalue_template => (
336             'my (@shv_params) = @ARG; ' .
337             'scalar(@shv_params) % 2 and ⸨"Wrong number of parameters; expected even-sized list of keys and values"⸩;' .
338             'my (@shv_keys_idx) = grep(!($_ % 2), 0..$#shv_params); ' .
339             'my (@shv_values_idx) = grep(($_ % 2), 0..$#shv_params); ' .
340             'grep(!defined, @shv_params[@shv_keys_idx]) and ⸨"Undef did not pass type constraint; keys must be defined"⸩;'.
341             '"____VALIDATION_HERE____"; '.
342             '@{$GET}{@shv_params[@shv_keys_idx]} = @shv_params[@shv_values_idx];' .
343             'wantarray ? @{$GET}{@shv_params[@shv_keys_idx]} : ($GET)->{$shv_params[$shv_keys_idx[0]]}' ),
344             additional_validation => sub {
345 39     39   118 my $self = CORE::shift;
346 39         158 my ($sig_was_checked, $gen) = @_;
347 39         187 my $ti = __PACKAGE__->_type_inspector($gen->isa);
348 39         349 my $env = {};
349 39 100 66     408 if ($ti and $ti->{trust_mutated} eq 'always') {
350             # still need to check keys are strings
351             return {
352 6         38 code => sprintf(
353             'for my $shv_tmp (@shv_keys_idx) { %s };',
354             $gen->generate_type_assertion( $env, Str, '$shv_params[$shv_tmp]' ),
355             ),
356             env => $env,
357             add_later => 1,
358             };
359             }
360 33 100 66     220 if ($ti and $ti->{trust_mutated} eq 'maybe') {
361             return {
362             code => sprintf(
363             'for my $shv_tmp (@shv_keys_idx) { %s }; for my $shv_tmp (@shv_values_idx) { %s };',
364             $gen->generate_type_assertion( $env, $ti->{key_type}, '$shv_params[$shv_tmp]' ),
365 16         88 $gen->generate_type_assertion( $env, $ti->{value_type}, '$shv_params[$shv_tmp]' ),
366             ),
367             env => $env,
368             add_later => 1,
369             };
370             }
371 17         82 return;
372             },
373             documentation => 'Given a key and value, adds the key to the hashref with the given value.',
374             _examples => sub {
375 1     1   65 my ( $class, $attr, $method ) = @_;
376 1         10 return join "",
377             " my \$object = $class\->new( $attr => { foo => 0, bar => 1 } );\n",
378             " \$object->$method( bar => 2, baz => 1 );\n",
379             " say \$object->$attr\->{foo}; ## ==> 0\n",
380             " say \$object->$attr\->{baz}; ## ==> 1\n",
381             " say \$object->$attr\->{bar}; ## ==> 2\n",
382             "\n";
383             },
384 42         635 }
385              
386             sub accessor {
387 79     79 1 410 handler
388             name => 'Hash:accessor',
389             min_args => 1,
390             max_args => 2,
391             signature => [Str, Optional[Any]],
392             usage => '$key, $value?',
393             template => 'if (#ARG == 1) { ($GET)->{ $ARG[1] } } else { my %shv_tmp = %{$GET}; $shv_tmp{$ARG[1]} = $ARG[2]; «\\%shv_tmp» }',
394             lvalue_template => '(#ARG == 1) ? ($GET)->{ $ARG[1] } : (($GET)->{ $ARG[1] } = $ARG[2])',
395             additional_validation => $additional_validation_for_set_and_insert,
396             documentation => 'Acts like C<get> if given just a key, or C<set> if given a key and a value.',
397             }
398              
399             sub for_each_pair {
400 4     4 1 25 handler
401             name => 'Hash:for_each_pair',
402             args => 1,
403             signature => [CodeRef],
404             usage => '$coderef',
405             template => 'while (my ($shv_key,$shv_value)=each %{$GET}) { &{$ARG}($shv_key,$shv_value) }; $SELF',
406             documentation => 'Chainable method which calls the coderef for each key in the hash, passing the key and value to the coderef.',
407             }
408              
409             sub for_each_key {
410 4     4 1 91 handler
411             name => 'Hash:for_each_key',
412             args => 1,
413             signature => [CodeRef],
414             usage => '$coderef',
415             template => 'for my $shv_key (keys %{$GET}) { &{$ARG}($shv_key) }; $SELF',
416             documentation => 'Chainable method which calls the coderef for each key in the hash, passing just the key to the coderef.',
417             }
418              
419             sub for_each_value {
420 4     4 1 27 handler
421             name => 'Hash:for_each_value',
422             args => 1,
423             signature => [CodeRef],
424             usage => '$coderef',
425             template => 'for my $shv_value (values %{$GET}) { &{$ARG}($shv_value) }; $SELF',
426             documentation => 'Chainable method which calls the coderef for each value in the hash, passing just the value to the coderef.',
427             }
428              
429             sub reset {
430             handler
431             name => 'Hash:reset',
432             args => 0,
433             template => '« $DEFAULT »',
434 0     0   0 default_for_reset => sub { '{}' },
435 3     3 1 27 documentation => 'Resets the attribute to its default value, or an empty hashref if it has no default.',
436             }
437              
438             1;