File Coverage

blib/lib/Sub/HandlesVia/HandlerLibrary/Array.pm
Criterion Covered Total %
statement 217 221 98.1
branch 21 24 87.5
condition 19 30 63.3
subroutine 94 95 98.9
pod 61 62 98.3
total 412 432 95.3


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