File Coverage

blib/lib/Sub/HandlesVia/HandlerLibrary/Array.pm
Criterion Covered Total %
statement 198 202 98.0
branch 17 20 85.0
condition 19 30 63.3
subroutine 92 93 98.9
pod 61 61 100.0
total 387 406 95.3


line stmt bran cond sub pod time code
1 40     40   2209 use 5.008;
  40         163  
2 40     40   259 use strict;
  40         99  
  40         1100  
3 40     40   224 use warnings;
  40         122  
  40         2766  
4              
5              
6             our $AUTHORITY = 'cpan:TOBYINK';
7             our $VERSION = '0.045';
8              
9             use Sub::HandlesVia::HandlerLibrary;
10 40     40   16741 our @ISA = 'Sub::HandlesVia::HandlerLibrary';
  40         117  
  40         2065  
11              
12             use Sub::HandlesVia::Handler qw( handler );
13 40     40   1356 use Types::Standard qw( ArrayRef Optional Str CodeRef Int Item Any Ref Defined FileHandle );
  40         96  
  40         448  
14 40     40   3957  
  40         109  
  40         297  
15             our @METHODS = qw( count is_empty all elements flatten get pop push shift
16             unshift clear first first_index reduce set accessor natatime any
17             shallow_clone map grep sort reverse sort_in_place splice shuffle
18             shuffle_in_place uniq uniq_in_place delete insert flatten flatten_deep
19             join print head tail apply pick_random for_each for_each_pair
20             all_true not_all_true min minstr max maxstr sum product
21             reductions sample uniqnum uniqnum_in_place uniqstr uniqstr_in_place
22             pairs pairkeys pairvalues pairgrep pairfirst pairmap reset );
23              
24             my ($me, $type) = @_;
25             if ($type == ArrayRef or $type == Defined or $type == Ref) {
26 1018     1018   2256 return {
27 1018 50 66     3226 trust_mutated => 'always',
      66        
28             };
29 228         18936 }
30             if ($type->is_parameterized
31             and $type->parent->name eq 'ArrayRef'
32 790 50 66     996931 and $type->parent->library eq 'Types::Standard'
      66        
      33        
33             and 1==@{$type->parameters}) {
34             return {
35 387         6882 trust_mutated => 'maybe',
36             value_type => $type->type_parameter,
37 387         2259 };
38             }
39             return $me->SUPER::_type_inspector($type);
40             }
41 403         3732  
42             my $additional_validation_for_push_and_unshift = sub {
43             my $self = CORE::shift;
44             my ($sig_was_checked, $gen) = @_;
45             my $ti = __PACKAGE__->_type_inspector($gen->isa);
46            
47             if ($ti and $ti->{trust_mutated} eq 'always') {
48             return { code => '1;', env => {} };
49             }
50            
51             if ($ti and $ti->{trust_mutated} eq 'maybe') {
52             my $coercion = ( $gen->coerce and $ti->{value_type}->has_coercion );
53             if ( $coercion ) {
54             my $env = {};
55             my $code = sprintf(
56             'my @shv_values = map { my $shv_value = $_; %s } %s;',
57             $gen->generate_type_assertion( $env, $ti->{value_type}, '$shv_value' ),
58             $gen->generate_args,
59             );
60             return {
61             code => $code,
62             env => $env,
63             arg => sub { "\$shv_values[($_[0])-1]" },
64             args => sub { '@shv_values' },
65             argc => sub { 'scalar(@shv_values)' },
66             };
67             }
68             else {
69             my $env = {};
70             my $code = sprintf(
71             'for my $shv_value (%s) { %s }',
72             $gen->generate_args,
73             $gen->generate_type_assertion( $env, $ti->{value_type}, '$shv_value' ),
74             );
75             return {
76             code => $code,
77             env => $env,
78             };
79             }
80             }
81             return;
82             };
83              
84             my $additional_validation_for_set_and_insert = sub {
85             my $self = CORE::shift;
86             my ($sig_was_checked, $gen) = @_;
87             my $ti = __PACKAGE__->_type_inspector($gen->isa);
88            
89             if ($ti and $ti->{trust_mutated} eq 'always') {
90             return { code => '1;', env => {} };
91             }
92            
93             my ( $arg, $code, $env );
94             $env = {};
95             if ($ti and $ti->{trust_mutated} eq 'maybe') {
96             $arg = sub {
97             my $gen = CORE::shift;
98             return '$shv_index' if $_[0]=='1';
99             return '$shv_value' if $_[0]=='2';
100             $gen->generate_arg( @_ );
101             };
102             if ( $sig_was_checked ) {
103             $code = sprintf(
104             'my($shv_index,$shv_value)=%s; %s;',
105             $gen->generate_args,
106             $gen->generate_type_assertion( $env, $ti->{value_type}, '$shv_value' ),
107             );
108             }
109             else {
110             $code = sprintf(
111             'my($shv_index,$shv_value)=%s; %s; %s;',
112             $gen->generate_args,
113             $gen->generate_type_assertion( $env, Int, '$shv_index' ),
114             $gen->generate_type_assertion( $env, $ti->{value_type}, '$shv_value' ),
115             );
116             }
117             }
118             return {
119             code => $code,
120             env => $env,
121             arg => $arg,
122             };
123             };
124              
125             handler
126             name => 'Array:count',
127             args => 0,
128             template => 'scalar(@{$GET})',
129             documentation => 'The number of elements in the referenced array.',
130             _examples => sub {
131             my ( $class, $attr, $method ) = @_;
132             return CORE::join "",
133             " my \$object = $class\->new( $attr => [ 'foo', 'bar' ] );\n",
134 1     1   150 " say \$object->$method; ## ==> 2\n",
135 1         7 "\n";
136             },
137             }
138              
139             handler
140 45     45 1 423 name => 'Array:is_empty',
141             args => 0,
142             template => '!scalar(@{$GET})',
143             documentation => 'Boolean indicating if the referenced array is empty.',
144             _examples => sub {
145             my ( $class, $attr, $method ) = @_;
146             return CORE::join "",
147             " my \$object = $class\->new( $attr => [ 'foo', 'bar' ] );\n",
148             " say \$object->$method; ## ==> false\n",
149 1     1   66 " \$object->_set_$attr( [] );\n",
150 1         8 " say \$object->$method; ## ==> true\n",
151             "\n";
152             },
153             }
154              
155             handler
156             name => 'Array:all',
157 46     46 1 432 args => 0,
158             template => '@{$GET}',
159             documentation => 'All elements in the array, in list context.',
160             _examples => sub {
161             my ( $class, $attr, $method ) = @_;
162             return CORE::join "",
163             " my \$object = $class\->new( $attr => [ 'foo', 'bar' ] );\n",
164             " my \@list = \$object->$method;\n",
165             " say Dumper( \\\@list ); ## ==> [ 'foo', 'bar' ]\n",
166 1     1   64 "\n";
167 1         6 },
168             }
169              
170             handler
171             name => 'Array:elements',
172             args => 0,
173 7     7 1 51 template => '@{$GET}',
174             documentation => 'All elements in the array, in list context. (Essentially the same as C<all>.)',
175             _examples => sub {
176             my ( $class, $attr, $method ) = @_;
177             return CORE::join "",
178             " my \$object = $class\->new( $attr => [ 'foo', 'bar' ] );\n",
179             " my \@list = \$object->$method;\n",
180             " say Dumper( \\\@list ); ## ==> [ 'foo', 'bar' ]\n",
181             "\n";
182 1     1   63 },
183 1         6 }
184              
185             handler
186             name => 'Array:flatten',
187             args => 0,
188             template => '@{$GET}',
189 45     45 1 422 documentation => 'All elements in the array, in list context. (Essentially the same as C<all>.)',
190             _examples => sub {
191             my ( $class, $attr, $method ) = @_;
192             return CORE::join "",
193             " my \$object = $class\->new( $attr => [ 'foo', 'bar' ] );\n",
194             " my \@list = \$object->$method;\n",
195             " say Dumper( \\\@list ); ## ==> [ 'foo', 'bar' ]\n",
196             "\n";
197             },
198 2     2   123 }
199 2         13  
200             handler
201             name => 'Array:get',
202             args => 1,
203             signature => [Int],
204             usage => '$index',
205 4     4 1 35 template => '($GET)->[$ARG]',
206             documentation => 'Returns a single element from the array by index.',
207             _examples => sub {
208             my ( $class, $attr, $method ) = @_;
209             return CORE::join "",
210             " my \$object = $class\->new( $attr => [ 'foo', 'bar', 'baz' ] );\n",
211             " say \$object->$method( 0 ); ## ==> 'foo'\n",
212             " say \$object->$method( 1 ); ## ==> 'bar'\n",
213             " say \$object->$method( -1 ); ## ==> 'baz'\n",
214             "\n";
215             },
216 1     1   64 }
217 1         26  
218             my $me = CORE::shift;
219             handler
220             name => 'Array:pop',
221             args => 0,
222             template => 'my @shv_tmp = @{$GET}; my $shv_return = pop @shv_tmp; «\\@shv_tmp»; $shv_return',
223             lvalue_template => 'pop(@{$GET})',
224 100     100 1 484 additional_validation => 'no incoming values',
225             documentation => 'Removes the last element from the array and returns it.',
226             _examples => sub {
227 53     53 1 195 my ( $class, $attr, $method ) = @_;
228             return CORE::join "",
229             " my \$object = $class\->new( $attr => [ 'foo', 'bar', 'baz' ] );\n",
230             " say \$object->$method; ## ==> 'baz'\n",
231             " say \$object->$method; ## ==> 'bar'\n",
232             " say Dumper( \$object->$attr ); ## ==> [ 'foo' ]\n",
233             "\n";
234             },
235             }
236 1     1   64  
237 1         16 my $me = CORE::shift;
238             handler
239             name => 'Array:push',
240             usage => '@values',
241             template => 'my @shv_tmp = @{$GET}; my $shv_return = push(@shv_tmp, @ARG); «\\@shv_tmp»; $shv_return',
242             lvalue_template => 'push(@{$GET}, @ARG)',
243             prefer_shift_self => 1,
244 53         491 additional_validation => $additional_validation_for_push_and_unshift,
245             documentation => 'Adds elements to the end of the array.',
246             _examples => sub {
247 106     106 1 320 my ( $class, $attr, $method ) = @_;
248             return CORE::join "",
249             " my \$object = $class\->new( $attr => [ 'foo' ] );\n",
250             " \$object->$method( 'bar', 'baz' );\n",
251             " say Dumper( \$object->$attr ); ## ==> [ 'foo', 'bar', 'baz' ]\n",
252             "\n";
253             },
254             }
255              
256             my $me = CORE::shift;
257 1     1   62 handler
258 1         7 name => 'Array:shift',
259             args => 0,
260             template => 'my @shv_tmp = @{$GET}; my $shv_return = shift @shv_tmp; «\\@shv_tmp»; $shv_return',
261             lvalue_template => 'shift(@{$GET})',
262             additional_validation => 'no incoming values',
263             documentation => 'Removes an element from the start of the array and returns it.',
264 106         910 _examples => sub {
265             my ( $class, $attr, $method ) = @_;
266             return CORE::join "",
267 46     46 1 146 " my \$object = $class\->new( $attr => [ 'foo', 'bar', 'baz' ] );\n",
268             " say \$object->$method; ## ==> 'foo'\n",
269             " say \$object->$method; ## ==> 'bar'\n",
270             " say Dumper( \$object->$attr ); ## ==> [ 'baz' ]\n",
271             "\n";
272             },
273             }
274              
275             my $me = CORE::shift;
276 1     1   61 handler
277 1         8 name => 'Array:unshift',
278             usage => '@values',
279             template => 'my @shv_tmp = @{$GET}; my $shv_return = unshift(@shv_tmp, @ARG); «\\@shv_tmp»; $shv_return',
280             lvalue_template => 'unshift(@{$GET}, @ARG)',
281             prefer_shift_self => 1,
282             additional_validation => $additional_validation_for_push_and_unshift,
283             documentation => 'Adds an element to the start of the array.',
284 46         460 _examples => sub {
285             my ( $class, $attr, $method ) = @_;
286             return CORE::join "",
287 87     87 1 252 " my \$object = $class\->new( $attr => [ 'foo' ] );\n",
288             " \$object->$method( 'bar', 'baz' );\n",
289             " say Dumper( \$object->$attr ); ## ==> [ 'bar', 'baz', 'foo' ]\n",
290             "\n";
291             },
292             }
293              
294             my $me = CORE::shift;
295             handler
296             name => 'Array:clear',
297 1     1   62 args => 0,
298 1         7 template => '«[]»',
299             lvalue_template => '@{$GET} = ()',
300             additional_validation => 'no incoming values',
301             documentation => 'Empties the array.',
302             _examples => sub {
303             my ( $class, $attr, $method ) = @_;
304 87         702 return CORE::join "",
305             " my \$object = $class\->new( $attr => [ 'foo' ] );\n",
306             " \$object->$method;\n",
307 45     45 1 164 " say Dumper( \$object->$attr ); ## ==> []\n",
308             "\n";
309             },
310             }
311              
312             require List::Util;
313             handler
314             name => 'Array:first',
315             args => 1,
316 1     1   61 signature => [CodeRef],
317 1         7 usage => '$coderef',
318             template => '&List::Util::first($ARG, @{$GET})',
319             documentation => 'Like C<< List::Util::first() >>.',
320             _examples => sub {
321             my ( $class, $attr, $method ) = @_;
322             return CORE::join "",
323 45         395 " my \$object = $class\->new( $attr => [ 'foo', 'bar', 'baz' ] );\n",
324             " my \$found = \$object->$method( sub { /a/ } );\n",
325             " say \$found; ## ==> 'bar'\n",
326 87     87 1 436 "\n";
327             },
328             }
329              
330             require List::Util;
331             handler
332             name => 'Array:any',
333             args => 1,
334             signature => [CodeRef],
335 1     1   63 usage => '$coderef',
336 1         7 template => '&List::Util::any($ARG, @{$GET})',
337             documentation => 'Like C<< List::Util::any() >>.',
338             _examples => sub {
339             my ( $class, $attr, $method ) = @_;
340             return CORE::join "",
341             " my \$object = $class\->new( $attr => [ 'foo', 'bar', 'baz' ] );\n",
342 87         460 " my \$truth = \$object->$method( sub { /a/ } );\n",
343             " say \$truth; ## ==> true\n",
344             "\n";
345 4     4 1 25 },
346             }
347              
348             my $me = __PACKAGE__;
349             handler
350             name => 'Array:first_index',
351             args => 1,
352             signature => [CodeRef],
353             usage => '$coderef',
354 1     1   63 template => 'for my $i ( 0 .. $#{$GET} ) { local *_ = \$GET->[$i]; return $i if $ARG->($_) }; return -1;',
355 1         8 documentation => 'Like C<< List::MoreUtils::first_index() >>.',
356             _examples => sub {
357             my ( $class, $attr, $method ) = @_;
358             return CORE::join "",
359             " my \$object = $class\->new( $attr => [ 'foo', 'bar', 'baz' ] );\n",
360             " my \$found = \$object->$method( sub { /z\$/ } );\n",
361 4         22 " say \$found; ## ==> 2\n",
362             "\n";
363             },
364 87     87 1 253 }
365              
366             require List::Util;
367             handler
368             name => 'Array:reduce',
369             args => 1,
370             signature => [CodeRef],
371             usage => '$coderef',
372             template => 'my $shv_callback = $ARG; List::Util::reduce { $shv_callback->($a,$b) } @{$GET}',
373 1     1   60 documentation => 'Like C<< List::Util::reduce() >>.',
374 1         7 }
375              
376             my $me = CORE::shift;
377             handler
378             name => 'Array:set',
379             args => 2,
380 87         344 signature => [Int, Any],
381             usage => '$index, $value',
382             template => 'my @shv_tmp = @{$GET}; $shv_tmp[$ARG[1]] = $ARG[2]; «\\@shv_tmp»; $ARG[2]',
383 87     87 1 422 lvalue_template => '($GET)->[ $ARG[1] ] = $ARG[2]',
384 87         386 additional_validation => $additional_validation_for_set_and_insert,
385             documentation => 'Sets the element with the given index to the supplied value.',
386             _examples => sub {
387             my ( $class, $attr, $method ) = @_;
388             return CORE::join "",
389             " my \$object = $class\->new( $attr => [ 'foo', 'bar', 'baz' ] );\n",
390             " \$object->$method( 1, 'quux' );\n",
391             " say Dumper( \$object->$attr ); ## ==> [ 'foo', 'quux', 'baz' ]\n",
392             "\n";
393             },
394 129     129 1 329 }
395              
396             handler
397             name => 'Array:accessor',
398             min_args => 1,
399             max_args => 2,
400             signature => [Int, Optional[Any]],
401             usage => '$index, $value?',
402             template => 'if (#ARG == 1) { ($GET)->[ $ARG[1] ] } else { my @shv_tmp = @{$GET}; $shv_tmp[$ARG[1]] = $ARG[2]; «\\@shv_tmp»; $ARG[2] }',
403             lvalue_template => '(#ARG == 1) ? ($GET)->[ $ARG[1] ] : (($GET)->[ $ARG[1] ] = $ARG[2])',
404             additional_validation => sub {
405 1     1   62 my $self = CORE::shift;
406 1         6 my ($sig_was_checked, $gen) = @_;
407             my $ti = __PACKAGE__->_type_inspector($gen->isa);
408             if ($ti and $ti->{trust_mutated} eq 'always') {
409             return { code => '1;', env => {} };
410             }
411             my ( $code, $env, $arg );
412 129         489 $env = {};
413             if ($ti and $ti->{trust_mutated} eq 'maybe') {
414             $arg = sub {
415             my $gen = CORE::shift;
416             return '$shv_index' if $_[0]=='1';
417             return '$shv_value' if $_[0]=='2';
418             $gen->generate_arg( @_ );
419             };
420             if ( $sig_was_checked ) {
421             $code = sprintf(
422             'my($shv_index,$shv_value)=%s; if (%s>1) { %s };',
423             $gen->generate_args,
424 127     127   246 $gen->generate_argc,
425 127         314 $gen->generate_type_assertion( $env, $ti->{value_type}, '$shv_value' ),
426 127         541 );
427 127 100 66     1086 }
428 28         147 else {
429             $code = sprintf(
430 99         229 'my($shv_index,$shv_value)=%s; %s; if (%s>1) { %s };',
431 99         213 $gen->generate_args,
432 99 100 66     432 $gen->generate_type_assertion( $env, Int, '$shv_index' ),
433             $gen->generate_argc,
434 162         267 $gen->generate_type_assertion( $env, $ti->{value_type}, '$shv_value' ),
435 162 100       752 );
436 66 50       295 }
437 0         0 }
438 48         211 return {
439 48 100       141 code => $code,
440             env => $env,
441             arg => $arg,
442             };
443             },
444 32         157 documentation => 'Acts like C<get> if given just an index, or C<set> if given an index and value.',
445             _examples => sub {
446             my ( $class, $attr, $method ) = @_;
447             return CORE::join "",
448             " my \$object = $class\->new( $attr => [ 'foo', 'bar', 'baz' ] );\n",
449             " \$object->$method( 1, 'quux' );\n",
450             " say Dumper( \$object->$attr ); ## ==> [ 'foo', 'quux', 'baz' ]\n",
451             " say \$object->$method( 2 ); ## ==> 'baz'\n",
452             "\n";
453 16         72 },
454             }
455              
456             my $me = __PACKAGE__;
457             handler
458 99         5615 name => 'Array:natatime',
459             min_args => 1,
460             max_args => 2,
461             signature => [Int, Optional[CodeRef]],
462             usage => '$n, $callback?',
463             template => 'my @shv_remaining = @{$GET}; my $shv_n = $ARG[1]; my $shv_iterator = sub { CORE::splice @shv_remaining, 0, $shv_n }; if ($ARG[2]) { while (my @shv_values = $shv_iterator->()) { $ARG[2]->(@shv_values) } } else { $shv_iterator }',
464             documentation => 'Given just a number, returns an iterator which reads that many elements from the array at a time. If also given a callback, calls the callback repeatedly with those values.',
465 1     1   82 _examples => sub {
466 1         8 my ( $class, $attr, $method ) = @_;
467             return CORE::join "",
468             " my \$object = $class\->new( $attr => [ 'foo', 'bar', 'baz' ] );\n",
469             " my \$iter = \$object->$method( 2 );\n",
470             " say Dumper( [ \$iter->() ] ); ## ==> [ 'foo', 'bar' ]\n",
471             " say Dumper( [ \$iter->() ] ); ## ==> [ 'baz' ]\n",
472             "\n";
473 129     129 1 546 },
474             }
475              
476 87     87 1 276 handler
477             name => 'Array:shallow_clone',
478             args => 0,
479             template => '[@{$GET}]',
480             documentation => 'Creates a new arrayref with the same elements as the original.',
481             }
482              
483             handler
484             name => 'Array:map',
485             args => 1,
486 1     1   65 signature => [CodeRef],
487 1         10 usage => '$coderef',
488             template => 'map($ARG->($_), @{$GET})',
489             documentation => 'Like C<map> from L<perlfunc>.',
490             }
491              
492             handler
493             name => 'Array:grep',
494 87         359 args => 1,
495             signature => [CodeRef],
496             usage => '$coderef',
497 3     3 1 21 template => 'grep($ARG->($_), @{$GET})',
498             documentation => 'Like C<grep> from L<perlfunc>.',
499             }
500              
501             handler
502             name => 'Array:sort',
503             min_args => 0,
504             max_args => 1,
505 87     87 1 376 signature => [Optional[CodeRef]],
506             usage => '$coderef?',
507             template => 'my @shv_return = $ARG ? (sort {$ARG->($a,$b)} @{$GET}) : (sort @{$GET})',
508             documentation => 'Like C<sort> from L<perlfunc>.',
509             }
510              
511             handler
512             name => 'Array:reverse',
513             args => 0,
514             template => 'reverse @{$GET}',
515 87     87 1 395 documentation => 'Returns the reversed array in list context.',
516             }
517              
518             handler
519             name => 'Array:sort_in_place',
520             min_args => 0,
521             max_args => 1,
522             signature => [Optional[CodeRef]],
523             usage => '$coderef?',
524             template => 'my @shv_return = $ARG ? (sort {$ARG->($a,$b)} @{$GET}) : (sort @{$GET}); «\@shv_return»',
525 87     87 1 418 additional_validation => 'no incoming values',
526             documentation => 'Like C<sort> from L<perlfunc>, but changes the attribute to point to the newly sorted array.',
527             }
528              
529             require List::Util;
530             handler
531             name => 'Array:shuffle',
532             args => 0,
533             template => 'my @shv_return = List::Util::shuffle(@{$GET}); wantarray ? @shv_return : \@shv_return',
534             documentation => 'Returns the array in a random order; can be called in list context or scalar context and will return an arrayref in the latter case.',
535             }
536 3     3 1 15  
537             require List::Util;
538             handler
539             name => 'Array:shuffle_in_place',
540             args => 0,
541             template => 'my @shv_return = List::Util::shuffle(@{$GET}); «\@shv_return»',
542             additional_validation => 'no incoming values',
543             documentation => 'Rearranges the array in a random order, and changes the attribute to point to the new order.',
544 87     87 1 414 }
545              
546             require List::Util;
547             handler
548             name => 'Array:uniq',
549             args => 0,
550             template => 'my @shv_return = List::Util::uniq(@{$GET}); wantarray ? @shv_return : \@shv_return',
551             documentation => 'Returns the array filtered to remove duplicates; can be called in list context or scalar context and will return an arrayref in the latter case.',
552             }
553              
554             require List::Util;
555             handler
556 45     45 1 254 name => 'Array:uniq_in_place',
557 45         218 args => 0,
558             template => 'my @shv_return = List::Util::uniq(@{$GET}); «\@shv_return»',
559             additional_validation => 'no incoming values',
560             documentation => 'Filters the array to remove duplicates, and changes the attribute to point to the filtered array.',
561             }
562              
563             require List::Util;
564             handler
565 3     3 1 21 name => 'Array:uniqnum',
566 3         14 args => 0,
567             template => 'my @shv_return = List::Util::uniqnum(@{$GET}); wantarray ? @shv_return : \@shv_return',
568             documentation => 'Returns the array filtered to remove duplicates numerically; can be called in list context or scalar context and will return an arrayref in the latter case.',
569             }
570              
571             require List::Util;
572             handler
573             name => 'Array:uniqnum_in_place',
574             args => 0,
575 45     45 1 275 template => 'my @shv_return = List::Util::uniqnum(@{$GET}); «\@shv_return»',
576 45         225 additional_validation => 'no incoming values',
577             documentation => 'Filters the array to remove duplicates numerically, and changes the attribute to point to the filtered array.',
578             }
579              
580             require List::Util;
581             handler
582             name => 'Array:uniqstr',
583             args => 0,
584 3     3 1 23 template => 'my @shv_return = List::Util::uniqstr(@{$GET}); wantarray ? @shv_return : \@shv_return',
585 3         17 documentation => 'Returns the array filtered to remove duplicates stringwise; can be called in list context or scalar context and will return an arrayref in the latter case.',
586             }
587              
588             require List::Util;
589             handler
590             name => 'Array:uniqstr_in_place',
591             args => 0,
592             template => 'my @shv_return = List::Util::uniqstr(@{$GET}); «\@shv_return»',
593             additional_validation => 'no incoming values',
594 3     3 1 31 documentation => 'Filters the array to remove duplicates stringwise, and changes the attribute to point to the filtered array.',
595 3         13 }
596              
597             handler
598             name => 'Array:splice',
599             min_args => 1,
600             usage => '$index, $length, @values',
601             template => 'my @shv_tmp = @{$GET}; my ($shv_index, $shv_length, @shv_values) = @ARG;defined($shv_index) or $shv_index=0; defined($shv_length) or $shv_length=0; my @shv_return = splice(@shv_tmp, $shv_index, $shv_length, @shv_values); «\\@shv_tmp»; wantarray ? @shv_return : $shv_return[-1]',
602             lvalue_template => 'my ($shv_index, $shv_length, @shv_values) = @ARG;splice(@{$GET}, $shv_index, $shv_length, @shv_values)',
603 3     3 1 18 additional_validation => sub {
604 3         12 my $self = CORE::shift;
605             my ($sig_was_checked, $gen) = @_;
606             my $env = {};
607             my $code = sprintf 'if (%s >= 1) { %s }; if (%s >= 2) { %s };',
608             $gen->generate_argc,
609             $gen->generate_type_assertion( $env, Int, $gen->generate_arg( 1 ) ),
610             $gen->generate_argc,
611             $gen->generate_type_assertion( $env, Int, $gen->generate_arg( 2 ) );
612             my $ti = __PACKAGE__->_type_inspector($gen->isa);
613 3     3 1 22 if ($ti and $ti->{trust_mutated} eq 'always') {
614 3         15 return { code => $code, env => $env };
615             }
616             if ($ti and $ti->{trust_mutated} eq 'maybe') {
617             my $coercion = ( $gen->coerce and $ti->{value_type}->has_coercion );
618             if ( $coercion ) {
619             $code .= sprintf(
620             'my @shv_unprocessed=%s;my @shv_processed=splice(@shv_unprocessed,0,2); push @shv_processed, map { my $shv_value = $_; %s } @shv_unprocessed;',
621             $gen->generate_args,
622 3     3 1 18 $gen->generate_type_assertion( $env, $ti->{value_type}, '$shv_value' ),
623 3         14 );
624             }
625             else {
626             $code .= sprintf(
627             'my @shv_unprocessed=%s;my @shv_processed=splice(@shv_unprocessed,0,2);for my $shv_value (@shv_unprocessed) { %s };push @shv_processed, @shv_unprocessed;',
628             $gen->generate_args,
629             $gen->generate_type_assertion( $env, $ti->{value_type}, '$shv_value' ),
630             );
631             }
632             return {
633             code => $code,
634             env => $env,
635             arg => sub { "\$shv_processed[($_[0])-1]" },
636             args => sub { '@shv_processed' },
637             argc => sub { 'scalar(@shv_processed)' },
638             };
639 185     185   408 }
640 185         471 return { code => $code, env => $env, final_type_check_needed => !!1 };
641 185         386 },
642 185         570 documentation => 'Like C<splice> from L<perlfunc>.',
643             }
644              
645             handler
646             name => 'Array:delete',
647 185         18106 args => 1,
648 185 100 66     1587 signature => [Int],
649 37         193 usage => '$index',
650             template => 'my @shv_tmp = @{$GET}; my ($shv_return) = splice(@shv_tmp, $ARG, 1); «\\@shv_tmp»; $shv_return',
651 148 100 66     633 lvalue_template => 'splice(@{$GET}, $ARG, 1)',
652 72   66     325 additional_validation => 'no incoming values',
653 72 100       310 documentation => 'Removes the indexed element from the array and returns it. Elements after it will be "moved up".',
654             }
655              
656             my $me = CORE::shift;
657 8         43 handler
658             name => 'Array:insert',
659             args => 2,
660             signature => [Int, Any],
661             usage => '$index, $value',
662             template => 'my @shv_tmp = @{$GET}; my ($shv_return) = splice(@shv_tmp, $ARG[1], 0, $ARG[2]); «\\@shv_tmp»;',
663             lvalue_template => 'splice(@{$GET}, $ARG[1], 0, $ARG[2])',
664 64         196 additional_validation => $additional_validation_for_set_and_insert,
665             documentation => 'Inserts a value into the array with the given index. Elements after it will be "moved down".',
666             _examples => sub {
667             my ( $class, $attr, $method ) = @_;
668             return CORE::join "",
669             " my \$object = $class\->new( $attr => [ 'foo', 'bar', 'baz' ] );\n",
670 0         0 " \$object->$method( 1, 'quux' );\n",
671 72         314 " say Dumper( \$object->$attr ); ## ==> [ 'foo', 'quux', 'bar', 'baz' ]\n",
672 0         0 "\n";
673 72         10828 },
674             }
675 76         498  
676             my $me = __PACKAGE__;
677 193     193 1 1533 handler
678             name => 'Array:flatten_deep',
679             min_args => 0,
680             max_args => 1,
681 87     87 1 379 signature => [Optional[Int]],
682             usage => '$depth?',
683             template => 'my $shv_fd; $shv_fd = sub { my $d=pop; --$d if defined $d; map ref() eq "ARRAY" ? (defined $d && $d < 0) ? $_ : $shv_fd->(@$_, $d) : $_, @_ }; $shv_fd->(@{$GET}, $ARG)',
684             documentation => 'Flattens the arrayref into a list, including any nested arrayrefs. (Has the potential to loop infinitely.)',
685             _examples => sub {
686             my ( $class, $attr, $method ) = @_;
687             return CORE::join "",
688             " my \$object = $class\->new( $attr => [ 'foo', [ 'bar', [ 'baz' ] ] ] );\n",
689             " say Dumper( [ \$object->$method ] ); ## ==> [ 'foo', 'bar', 'baz' ]\n",
690             "\n",
691             " my \$object2 = $class\->new( $attr => [ 'foo', [ 'bar', [ 'baz' ] ] ] );\n",
692             " say Dumper( [ \$object->$method(1) ] ); ## ==> [ 'foo', 'bar', [ 'baz' ] ]\n",
693 87     87 1 246 "\n";
694             },
695             }
696              
697             handler
698             name => 'Array:join',
699             min_args => 0,
700             max_args => 1,
701             signature => [Optional[Str]],
702             usage => '$with?',
703             template => 'my $shv_param_with = #ARG ? $ARG : q[,]; join($shv_param_with, @{$GET})',
704 1     1   64 documentation => 'Returns a string joining all the elements in the array; if C<< $with >> is omitted, defaults to a comma.',
705 1         6 _examples => sub {
706             my ( $class, $attr, $method ) = @_;
707             return CORE::join "",
708             " my \$object = $class\->new( $attr => [ 'foo', 'bar', 'baz' ] );\n",
709             " say \$object->$method; ## ==> 'foo,bar,baz'\n",
710             " say \$object->$method( '|' ); ## ==> 'foo|bar|baz'\n",
711 87         357 "\n";
712             },
713             }
714 3     3 1 13  
715             handler
716             name => 'Array:print',
717             min_args => 0,
718             max_args => 2,
719             signature => [Optional[FileHandle], Optional[Str]],
720             usage => '$fh?, $with?',
721             template => 'my $shv_param_with = (#ARG>1) ? $ARG[2] : q[,]; print {$ARG[1]||*STDOUT} join($shv_param_with, @{$GET})',
722             documentation => 'Prints a string joining all the elements in the array; if C<< $fh >> is omitted, defaults to STDOUT; if C<< $with >> is omitted, defaults to a comma.',
723             }
724 1     1   77  
725 1         9 handler
726             name => 'Array:head',
727             args => 1,
728             signature => [Int],
729             usage => '$count',
730             template => 'my $shv_count=$ARG; $shv_count=@{$GET} if $shv_count>@{$GET}; $shv_count=@{$GET}+$shv_count if $shv_count<0; (@{$GET})[0..($shv_count-1)]',
731             documentation => 'Returns the first C<< $count >> elements of the array in list context.',
732             }
733 3         33  
734             handler
735             name => 'Array:tail',
736             args => 1,
737             signature => [Int],
738             usage => '$count',
739             template => 'my $shv_count=$ARG; $shv_count=@{$GET} if $shv_count>@{$GET}; $shv_count=@{$GET}+$shv_count if $shv_count<0; my $shv_start = scalar(@{$GET})-$shv_count; my $shv_end = scalar(@{$GET})-1; (@{$GET})[$shv_start..$shv_end]',
740             documentation => 'Returns the last C<< $count >> elements of the array in list context.',
741             }
742              
743             handler
744             name => 'Array:apply',
745 1     1   65 args => 1,
746 1         7 signature => [CodeRef],
747             usage => '$coderef',
748             template => 'my @shv_tmp = @{$GET}; &{$ARG} foreach @shv_tmp; wantarray ? @shv_tmp : $shv_tmp[-1]',
749             documentation => 'Executes the coderef (which should modify C<< $_ >>) against each element of the array; returns the resulting array in list context.',
750             }
751              
752 87     87 1 519 require List::Util;
753             handler
754             name => 'Array:pick_random',
755 3     3 1 26 min_args => 0,
756             max_args => 1,
757             signature => [Optional[Int]],
758             usage => '$count',
759             template => 'my @shv_tmp = List::Util::shuffle(@{$GET}); my $shv_count = $ARG; $shv_count=@{$GET} if $shv_count > @{$GET}; $shv_count=@{$GET}+$shv_count if $shv_count<0; if (wantarray and #ARG) { @shv_tmp[0..$shv_count-1] } elsif (#ARG) { [@shv_tmp[0..$shv_count-1]] } else { $shv_tmp[0] }',
760             documentation => 'If no C<< $count >> is given, returns one element of the array at random. If C<< $count >> is given, creates a new array with that many random elements from the original array (or fewer if the original array is not long enough) and returns that as an arrayref or list depending on context',
761             }
762              
763             handler
764             name => 'Array:for_each',
765             args => 1,
766 4     4 1 19 signature => [CodeRef],
767             usage => '$coderef',
768             template => 'foreach my $shv_index (0 .. $#{$GET}) { &{$ARG}(($GET)->[$shv_index], $shv_index) }; $SELF',
769             documentation => 'Chainable method which executes the coderef on each element of the array. The coderef will be passed two values: the element and its index.',
770             _examples => sub {
771             my ( $class, $attr, $method ) = @_;
772             return CORE::join "",
773             " my \$object = $class\->new( $attr => [ 'foo', 'bar', 'baz' ] );\n",
774             " \$object->$method( sub { say \"Item \$_[1] is \$_[0].\" } );\n",
775             "\n";
776 4     4 1 26 },
777             }
778              
779             handler
780             name => 'Array:for_each_pair',
781             args => 1,
782             signature => [CodeRef],
783             usage => '$coderef',
784             template => 'for (my $shv_index=0; $shv_index<@{$GET}; $shv_index+=2) { &{$ARG}(($GET)->[$shv_index], ($GET)->[$shv_index+1]) }; $SELF',
785             documentation => 'Chainable method which executes the coderef on each pair of elements in the array. The coderef will be passed the two elements.',
786 4     4 1 27 }
787              
788             require List::Util;
789             handler
790             name => 'Array:all_true',
791             args => 1,
792             signature => [CodeRef],
793             usage => '$coderef',
794             template => '&List::Util::all($ARG, @{$GET})',
795             documentation => 'Like C<< List::Util::all() >>.',
796 4     4 1 26 }
797 4         26  
798             require List::Util;
799             handler
800             name => 'Array:not_all_true',
801             args => 1,
802             signature => [CodeRef],
803             usage => '$coderef',
804             template => '&List::Util::notall($ARG, @{$GET})',
805             documentation => 'Like C<< List::Util::notall() >>.',
806             }
807              
808             require List::Util;
809             handler
810             name => 'Array:min',
811             args => 0,
812             template => '&List::Util::min(@{$GET})',
813             documentation => 'Like C<< List::Util::min() >>.',
814             }
815              
816 1     1   64 require List::Util;
817 1         6 handler
818             name => 'Array:max',
819             args => 0,
820             template => '&List::Util::max(@{$GET})',
821             documentation => 'Like C<< List::Util::max() >>.',
822 5     5 1 45 }
823              
824             require List::Util;
825 4     4 1 28 handler
826             name => 'Array:minstr',
827             args => 0,
828             template => '&List::Util::minstr(@{$GET})',
829             documentation => 'Like C<< List::Util::minstr() >>.',
830             }
831              
832             require List::Util;
833             handler
834             name => 'Array:maxstr',
835 3     3 1 20 args => 0,
836 3         23 template => '&List::Util::maxstr(@{$GET})',
837             documentation => 'Like C<< List::Util::maxstr() >>.',
838             }
839              
840             require List::Util;
841             handler
842             name => 'Array:sum',
843             args => 0,
844             template => '&List::Util::sum(0, @{$GET})',
845             documentation => 'Like C<< List::Util::sum0() >>.',
846 3     3 1 18 }
847 3         14  
848             require List::Util;
849             handler
850             name => 'Array:product',
851             args => 0,
852             template => '&List::Util::product(1, @{$GET})',
853             documentation => 'Like C<< List::Util::product() >>.',
854             }
855              
856             require List::Util;
857 3     3 1 25 handler
858 3         12 name => 'Array:sample',
859             args => 1,
860             signature => [Int],
861             usage => '$count',
862             template => '&List::Util::sample($ARG, @{$GET})',
863             documentation => 'Like C<< List::Util::sample() >>.',
864             }
865              
866 3     3 1 18 require List::Util;
867 3         13 handler
868             name => 'Array:reductions',
869             args => 1,
870             signature => [CodeRef],
871             usage => '$coderef',
872             template => 'my $shv_callback = $ARG; List::Util::reductions { $shv_callback->($a,$b) } @{$GET}',
873             documentation => 'Like C<< List::Util::reductions() >>.',
874             }
875 3     3 1 18  
876 3         11 require List::Util;
877             handler
878             name => 'Array:pairs',
879             args => 0,
880             template => '&List::Util::pairs(@{$GET})',
881             documentation => 'Like C<< List::Util::pairs() >>.',
882             }
883              
884 3     3 1 17 require List::Util;
885 3         12 handler
886             name => 'Array:pairkeys',
887             args => 0,
888             template => '&List::Util::pairkeys(@{$GET})',
889             documentation => 'Like C<< List::Util::pairkeys() >>.',
890             }
891              
892             require List::Util;
893 3     3 1 19 handler
894 3         14 name => 'Array:pairvalues',
895             args => 0,
896             template => '&List::Util::pairvalues(@{$GET})',
897             documentation => 'Like C<< List::Util::pairvalues() >>.',
898             }
899              
900             require List::Util;
901             handler
902 3     3 1 18 name => 'Array:pairgrep',
903 3         13 args => 1,
904             signature => [CodeRef],
905             usage => '$coderef',
906             template => 'List::Util::pairgrep { $ARG->($_) } @{$GET}',
907             documentation => 'Like C<< List::Util::pairgrep() >>.',
908             }
909              
910             require List::Util;
911 3     3 1 23 handler
912 3         17 name => 'Array:pairfirst',
913             args => 1,
914             signature => [CodeRef],
915             usage => '$coderef',
916             template => 'List::Util::pairfirst { $ARG->($_) } @{$GET}',
917             documentation => 'Like C<< List::Util::pairfirst() >>.',
918             }
919              
920             require List::Util;
921             handler
922 3     3 1 35 name => 'Array:pairmap',
923 3         16 args => 1,
924             signature => [CodeRef],
925             usage => '$coderef',
926             template => 'List::Util::pairmap { $ARG->($_) } @{$GET}',
927             documentation => 'Like C<< List::Util::pairmap() >>.',
928             }
929              
930             handler
931             name => 'Array:reset',
932             args => 0,
933 3     3 1 19 template => '« $DEFAULT »',
934 3         14 default_for_reset => sub { '[]' },
935             documentation => 'Resets the attribute to its default value, or an empty arrayref if it has no default.',
936             _examples => sub {
937             my ( $class, $attr, $method ) = @_;
938             return CORE::join "",
939             " my \$object = $class\->new( $attr => [ 'foo', 'bar', 'baz' ] );\n",
940             " \$object->$method;\n",
941             " say Dumper( \$object->$attr ); ## ==> []\n",
942 3     3 1 19 "\n";
943 3         14 },
944             }
945              
946             1;