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; |