File Coverage

blib/lib/Sub/Fp.pm
Criterion Covered Total %
statement 115 115 100.0
branch 34 36 94.4
condition 16 19 84.2
subroutine 29 29 100.0
pod 3 3 100.0
total 197 202 97.5


line stmt bran cond sub pod time code
1             package Sub::Fp;
2 2     2   155828 use strict;
  2         12  
  2         58  
3 2     2   11 use warnings;
  2         4  
  2         49  
4 2     2   19 use Carp;
  2         20  
  2         149  
5 2     2   1007 use POSIX;
  2         12761  
  2         12  
6 2     2   5444 use List::Util;
  2         5  
  2         155  
7 2     2   1215 use Data::Dumper qw(Dumper);
  2         13182  
  2         135  
8 2     2   16 use Exporter qw(import);
  2         3  
  2         146  
9             our $VERSION = '0.46';
10             our @EXPORT_OK = qw(
11             incr reduces flatten
12             drop_right drop take_right take
13             assoc maps decr chain
14             first end subarray partial
15             __ find filter some
16             none uniq bool spread
17             len to_keys to_vals is_array
18             is_hash every noop identity
19             is_empty is_sub flow eql
20             to_pairs for_each apply get
21             second range pops pushes
22             shifts unshifts once
23             );
24 2     2   12 use constant ARG_PLACE_HOLDER => {};
  2         5  
  2         566  
25              
26             $SIG{__WARN__} = sub {
27             caller eq "Sub::Fp" ? carp $_[0] : warn $_[0];
28             };
29              
30             $SIG{__DIE__} = sub {
31             caller eq "Sub::Fp" ? croak $_[0] : die $_[0];
32             };
33              
34             _wrap_to_use_partials(
35             grep { $_ !~ /flow|flow_right|partial|chain/ } @EXPORT_OK
36             );
37              
38             # -----------------------------------------------------------------------------#
39              
40             sub __ { ARG_PLACE_HOLDER };
41              
42             sub _contains_placeholders {
43 4084     4084   5552 my $arguments = [@_];
44              
45 4084         4673 foreach my $arg (@{ $arguments }) {
  4084         5667  
46 1903 100 66     3790 if (ref($arg) and ref(__) and $arg == __) {
      100        
47 9         23 return 1;
48             }
49             }
50 4075         8622 return 0;
51             }
52              
53             sub _wrap {
54             ##no critic
55 2     2   17 no warnings 'redefine';
  2         4  
  2         97  
56 2     2   30 no strict 'refs';
  2         4  
  2         6423  
57              
58 86     86   143 my ($methodName, $decorator) = @_;
59 86         114 my $module = caller;
60 86         155 my $fullName = "$module"."::"."$methodName";
61 86         94 my $wrappedSub = *{"$fullName"}{CODE};
  86         173  
62              
63 86         338 *{"$fullName"} = List::Util::reduce {
64 86     86   143 my ($wrappedSub, $decor) = ($a, $b);
65 86         128 return $decor->($wrappedSub);
66 86         280 } ($wrappedSub, $decorator);
67             }
68              
69             sub _can_use_placeholders {
70 86     86   103 my $func = shift;
71              
72             return sub {
73 4053 50   4053   386987 return _contains_placeholders(@_) ? partial($func, @_) : $func->(@_);
74             }
75 86         337 }
76              
77             sub _wrap_to_use_partials {
78 2     2   5 foreach my $func_name (@_) {
79 86         154 _wrap($func_name, \&_can_use_placeholders);
80             }
81             }
82              
83             sub noop {
84             ## no critic;
85             return undef;
86             }
87              
88             sub identity {
89             my $args = shift // undef;
90              
91             return $args;
92             }
93              
94             sub once {
95             my $func = shift // \&noop;
96             my $was_called_once = 0;
97             my $result;
98              
99             return sub {
100             if ($was_called_once) {
101             return $result;
102             }
103              
104             $was_called_once++;
105             $result = $func->(@_);
106             return $result;
107             }
108             }
109              
110             # Forgive me below father, for I have sinned.
111             # Seriously, I can't figure a simpler way to do this...
112             # TODO: Please refactor this eventually...
113             sub range {
114             my ($start, $end, $step) = @_;
115              
116             if (!defined $start) {
117             return [];
118             }
119              
120             if (!defined $end) {
121             return range(0, $start, $start < 0 ? -1 : 1);
122             }
123              
124             if (!defined $step) {
125             return range($start, $end, $end < 0 ? -1 : 1);
126             }
127              
128             if (_is_nonsense_range($start, $end, $step)) {
129             return [];
130             }
131              
132             my $loop_count = ceil(abs(($end - $start) / ($step || 1)));
133             my $list = [];
134              
135             while ($loop_count) {
136             push(@{ $list }, $start);
137              
138             $start+=$step;
139             $loop_count-=1;
140             }
141              
142             return $list;
143             }
144              
145             sub _is_nonsense_range {
146 22     22   35 my ($start, $end, $step) = @_;
147              
148 22 100 100     54 if ($start == $end &&
149             $end == $step) {
150 1         4 return 1;
151             }
152              
153 21 100 100     68 if ($start > $end &&
154             $step >= 0 ) {
155 3         7 return 1;
156             }
157              
158 18 100 100     82 if ($start < $end &&
159             $step < 0) {
160 3         8 return 1;
161             }
162             }
163              
164              
165             sub _safe_get {
166 22   50 22   57 my $key = shift // 0;
167 22   50     39 my $coll = shift // [];
168 22         27 my $default = shift;
169              
170 22 100       32 if (is_array($coll)) {
171 12 100       103 return defined $coll->[$key] ? $coll->[$key] : $default;
172             }
173              
174 10 100       20 if (is_hash($coll)) {
175 9 100       64 return defined $coll->{$key} ? $coll->{$key} : $default;
176             }
177              
178 1         4 my $string_coll = [spread($coll)];
179              
180 1 50       17 return defined $string_coll->[$key] ? $string_coll->[$key] : $default;
181             }
182              
183             sub get {
184             my ($path, $coll, $default) = @_;
185              
186             if (!defined $path) {
187             return $default;
188             }
189              
190             my $accessors = [$path =~ /([\w\s-]+)/g];
191              
192             return reduces(sub {
193             my ($value, $accessor) = @_;
194             return _safe_get($accessor, $value, $default);
195             }, $coll, $accessors)
196             }
197              
198             sub apply {
199             my $fn = shift // sub {};
200             my $args = shift // [];
201              
202             return $fn->(@{$args});
203             }
204              
205             sub flow {
206 5     5 1 7005 my $funcs = [@_];
207              
208 5 100       19 if (ref $funcs->[0] ne 'CODE') {
209 1         5 return \&noop;
210             }
211              
212             return sub {
213 3     3   15 my $args = [@_];
214              
215             return chain(
216 3         6 sub { first($funcs)->(spread($args)) },
217 3         14 spread(drop($funcs)),
218             );
219             }
220 4         20 }
221              
222             sub is_sub {
223             my $sub = shift;
224              
225             return bool(eql(ref $sub, 'CODE'));
226             }
227              
228             sub is_array {
229             my $coll = shift;
230             my $extra_args = [@_];
231              
232             if (len($extra_args)) {
233             return 0;
234             }
235              
236             return bool(ref $coll eq 'ARRAY');
237             }
238              
239             sub is_hash {
240             my $coll = shift;
241              
242             return bool(ref $coll eq 'HASH');
243             }
244              
245             sub to_pairs {
246             my $coll = shift // [];
247              
248             if (is_array($coll)) {
249             return maps(sub {
250             my ($val, $idx) = @_;
251             return [$idx, $val]
252             }, $coll)
253             }
254              
255             if (is_hash($coll)) {
256             return maps(sub {
257             my $key = shift;
258             return [$key, $coll->{$key}]
259             }, to_keys($coll))
260             }
261              
262             return maps(sub {
263             my ($char, $idx) = @_;
264             return [$idx, $char];
265             }, to_vals($coll));
266             }
267              
268             sub to_vals {
269             my $coll = shift // [];
270              
271             if (is_array($coll)) {
272             return $coll;
273             }
274              
275             if (is_hash($coll)) {
276             return [values %{ $coll }];
277             }
278              
279             return [spread($coll)];
280             }
281              
282             sub to_keys {
283             my $coll = shift // [];
284              
285             #Backwards compatibility < v5.12
286             if (is_array($coll)) {
287             return maps(sub {
288             my (undef, $idx) = @_;
289             return $idx;
290             }, $coll);
291             }
292              
293             if (is_hash($coll)) {
294             return [keys %{ $coll }];
295             }
296              
297             return maps(sub {
298             my (undef, $idx) = @_;
299             return $idx;
300             }, [spread($coll)])
301             }
302              
303             sub len {
304             my $coll = shift || [];
305              
306             if (ref $coll eq 'ARRAY') {
307             return scalar spread($coll);
308             }
309              
310             if (ref $coll eq 'HASH') {
311             return scalar (keys %{ $coll });
312             }
313              
314             return length($coll);
315             }
316              
317             sub for_each {
318             my ($fn, $coll) = @_;
319             my $idx = 0;
320              
321             foreach my $val (@{ $coll }) {
322             $idx++;
323             $fn->($val, $idx - 1, $coll);
324             }
325              
326             ##no critic;
327             return undef;
328             }
329              
330             sub is_empty {
331             my $coll = shift;
332             return bool(len($coll) == 0);
333             }
334              
335             sub uniq {
336             my $coll = shift;
337              
338             my @vals = do {
339             my %seen;
340             grep { !$seen{$_}++ } @$coll;
341             };
342              
343             return [@vals];
344             }
345              
346             sub find {
347             my $pred = shift;
348             my $coll = shift // [];
349              
350             return List::Util::first {
351             $pred->($_)
352             } @$coll;
353             }
354              
355             sub filter {
356             my $pred = shift;
357             my $coll = shift // [];
358              
359             return [grep { $pred->($_) } @$coll];
360             }
361              
362             sub some {
363             my $pred = shift;
364             my $coll = shift // [];
365              
366             return bool(find($pred, $coll));
367             }
368              
369             sub every {
370             my $pred = shift;
371             my $coll = shift // [];
372              
373             my $bool = List::Util::all {
374             $pred->($_);
375             } @$coll;
376              
377             return bool($bool);
378             }
379              
380             sub none {
381             my $pred = shift;
382             my $coll = shift // [];
383              
384             return some($pred, $coll) ? 0 : 1;
385             }
386              
387             sub incr {
388             my $num = shift;
389             return $num + 1;
390             }
391              
392             sub decr {
393             my $num = shift;
394             return $num - 1;
395             }
396              
397             sub first {
398             my $coll = shift;
399             return @$coll[0];
400             }
401              
402             sub second {
403             my $coll = shift;
404             return @$coll[1];
405             }
406              
407             sub end {
408             my $coll = shift // [];
409             my $len = scalar @$coll;
410              
411             return @$coll[$len - 1 ];
412             }
413              
414             sub flatten {
415             my $coll = shift;
416              
417             return [
418             map {
419             ref $_ ? @{$_} : $_;
420             } @$coll
421             ];
422             }
423              
424             sub pops {
425             my ($array, $val) = @_;
426              
427             return pop @{$array};
428             }
429              
430             sub pushes {
431             my ($array, $val) = @_;
432              
433             return push @{$array}, $val;
434             }
435              
436             sub shifts {
437             my ($array, $val) = @_;
438              
439             return shift @{$array};
440             }
441              
442             sub unshifts {
443             my ($array, $val) = @_;
444              
445             return unshift @{$array}, $val;
446             }
447              
448             sub _prepare_args {
449 65     65   115 my $args = [@_];
450 65 100       113 my $count = len($args) > 1 ? $args->[0] : 1;
451 65 100       113 my $coll = len($args) > 1 ? $args->[1] : $args->[0];
452 65         115 my $coll_len = len($coll);
453              
454 65         174 return ($coll, $count, $coll_len)
455             }
456              
457             sub drop {
458             my ($coll, $count, $coll_len) = _prepare_args(@_);
459              
460             return [@$coll[$count .. $coll_len - 1]];
461             }
462              
463             sub drop_right {
464             my ($coll, $count, $coll_len) = _prepare_args(@_);
465              
466             return [@$coll[0 .. ($coll_len - ($count + 1))]];
467             }
468              
469             sub take {
470             my ($coll, $count, $coll_len) = _prepare_args(@_);
471              
472             if (!$coll_len) {
473             return [];
474             }
475              
476             if ($count >= $coll_len ) {
477             return $coll;
478             }
479              
480             return [@$coll[0 .. $count - 1]];
481             }
482              
483             sub take_right {
484             my ($coll, $count, $coll_len) = _prepare_args(@_);
485              
486             if (!$coll_len) {
487             return [];
488             }
489              
490             if ($count >= $coll_len ) {
491             return $coll;
492             }
493              
494             return [@$coll[($coll_len - $count) .. ($coll_len - 1)]];
495             }
496              
497             sub assoc {
498             my ($obj, $key, $item) = @_;
499              
500             if (!defined $key) {
501             return $obj;
502             }
503              
504             if (ref $obj eq 'ARRAY') {
505             return [
506             @{(take($key, $obj))},
507             $item,
508             @{(drop($key + 1, $obj))},
509             ];
510             }
511              
512             return {
513             %{ $obj },
514             $key => $item,
515             };
516             }
517              
518             sub maps {
519             my $func = shift;
520             my $coll = shift;
521              
522             my $idx = 0;
523              
524             if (!is_sub($func) && defined $coll) {
525             return maps(get($func, __), $coll);
526             }
527              
528             my @vals = map {
529              
530             $idx++;
531             $func->($_, $idx - 1, $coll);
532             } @$coll;
533              
534             return [@vals];
535             }
536              
537              
538             sub reduces {
539             my $func = shift;
540             my ($accum, $coll) = spread(_get_reduces_args([@_]));
541              
542             my $idx = 0;
543              
544             return List::Util::reduce {
545             my ($accum, $val) = ($a, $b);
546             $idx++;
547             $func->($accum, $val, $idx - 1, $coll);
548             } ($accum, @$coll);
549             }
550              
551             sub _get_reduces_args {
552 20     20   29 my $args = shift;
553              
554 20 100       56 if (eql(len($args), 1)) {
555             return chain(
556             $args,
557             \&flatten,
558             sub {
559 1     1   4 return [first($_[0]), drop($_[0])]
560             }
561             )
562 1         6 }
563              
564 19         38 return [first($args), flatten(drop($args))];
565             }
566              
567             sub partial {
568 13     13 1 12104 my $func = shift;
569 13         27 my $oldArgs = [@_];
570              
571 13 100       51 if (ref $func ne 'CODE') {
572 2         315 carp("Expected a function as first argument");
573             }
574              
575             return sub {
576 18     18   104 my $newArgs = [@_];
577 18         31 my $filled_args = _fill_holders([spread($oldArgs)], $newArgs);
578              
579 18         31 return $func->(spread($filled_args));
580             }
581 11         59 }
582              
583              
584             #Once again, forgive me for I have sinned...
585             sub _fill_holders {
586 18     18   31 my ($old_args, $new_args) = @_;
587              
588 18         24 my $filled_args = [];
589 18         36 my $old_args_len = len($old_args);
590              
591 18         41 for (my $idx = 0; $idx < $old_args_len; $idx++) {
592 31         32 my $arg = shift @{ $old_args };
  31         40  
593              
594 31 100       49 if(_contains_placeholders($arg)) {
595 9         13 push @{ $filled_args }, (shift @{ $new_args });
  9         12  
  9         12  
596             } else {
597 22         25 push @{ $filled_args }, $arg;
  22         36  
598             }
599              
600 31 100       69 if ($old_args_len == ($idx + 1)) {
601 18         21 push @{ $filled_args }, @{ $new_args };
  18         21  
  18         38  
602             }
603             }
604              
605 18         33 return $filled_args;
606             }
607              
608             sub subarray {
609             my $coll = shift || [];
610             my $start = shift;
611             my $end = shift // scalar @$coll;
612              
613             if (!$start) {
614             return $coll;
615             }
616              
617             if ($start == $end) {
618             return [];
619             }
620              
621             return [
622             @$coll[$start .. ($end - 1)],
623             ];
624             }
625              
626             sub chain {
627 2     2   17 no warnings 'once';
  2         4  
  2         879  
628 7     7 1 3951 my ($val, @funcs) = @_;
629              
630             return List::Util::reduce {
631 8     8   35 my ($accum, $func) = ($a, $b);
632 8         19 $func->($accum);
633 7 100       50 } (ref($val) eq 'CODE' ? $val->() : $val), @funcs;
634             }
635              
636             sub eql {
637             my $arg1 = shift // '';
638             my $arg2 = shift // '';
639              
640             if (ref $arg1 ne ref $arg2) {
641             return 0;
642             }
643              
644             if (is_array($arg1) && is_array($arg2) ||
645             is_hash($arg1) && is_hash($arg2)) {
646             return bool($arg1 == $arg2);
647             }
648              
649             return bool($arg1 eq $arg2);
650             }
651              
652             sub bool {
653             my ($val) = @_;
654              
655             return $val ? 1 : 0;
656             }
657              
658             sub spread {
659             my $coll = shift // [];
660              
661             if (ref $coll eq 'ARRAY') {
662             return @{ $coll };
663             }
664              
665             if (ref $coll eq 'HASH') {
666             return %{ $coll }
667             }
668              
669             return split('', $coll);
670             }
671              
672             # ------------------------------------------------------------------------------
673              
674             =head1 NAME
675              
676             Sub::Fp - A Clojure / Python Toolz / Lodash inspired Functional Utility Library
677              
678             =cut
679              
680             =head1 SYNOPSIS
681              
682             This library provides numerous functional programming utility methods,
683             as well as functional varients of native in-built methods, to allow for consistent,
684             concise code.
685              
686             =head1 SUBROUTINES/METHODS
687              
688             =head1 Self Partialing: The __ function
689              
690             Sub::Fp has a "special" function, the C<__> placeholder.
691             This function allows for "self partialing", which is similar to auto-currying in many functional languages.
692             This works for every single function in the Sub::Fp library, except for C
693              
694             # TLDR
695              
696             my $person = { name => "Sally" };
697              
698             my $get_name = get('{name}', __); # <---- Function uses placeholder to "self-partial", and return new sub
699              
700             print $get_name->($person); # <---- Invoke function with argument
701              
702             # "Sally"
703              
704             That's it! It also works with multiple placeholders, in different positions,
705             with different permutations of supplied arguments.
706              
707             my $range = range(__, __);
708              
709             print Dumper($range->(1, 10));
710              
711             # [1,2,3,4,5,6,7,8,9]
712              
713              
714             my $range = range(__, __, __);
715              
716             print Dumper($range->(1, 4, 0));
717              
718             # [1,1,1,1];
719              
720              
721              
722             my $range = range(__, 4, __);
723              
724             print Dumper($range->(1, 0));
725              
726             # [1,1,1,1];
727              
728             B: This is not a new concept by any means (I'm just stealing it),
729             and it's existed in functional languages for well over half a century.
730             Its a natural application of functional composition.
731             To get a better feel for what it looks like in other languages see:
732              
733             1. thread-as macro in Clojure
734              
735             2. Partialing in Lodash, PyToolz etc
736              
737             3. Auto Currying in Haskell, Lodash-Fp, Ramda, Elm
738              
739             4. The use of C<_> in languages as a placeholder. This library uses
740             double underscore instead to differentiate it from the native library,
741             which already uses a single underscore in some circumstances.
742              
743             =cut
744              
745             =head1 EXPORT
746              
747             incr reduces flatten
748             drop_right drop take_right take
749             assoc maps decr chain
750             first end subarray partial
751             __ find filter some
752             none uniq bool spread every
753             len is_array is_hash to_keys to_vals
754             noop identity is_empty flow eql
755             is_sub to_pairs for_each apply
756             get second
757              
758             =cut
759              
760             =head2 incr
761              
762             Increments the supplied number by 1
763              
764             incr(1)
765              
766             # 2
767              
768             =cut
769              
770             =head2 decr
771              
772             Decrements the supplied number by 1
773              
774             decr(2)
775              
776             # 1
777              
778             =cut
779              
780             =head2 once
781              
782             Creates a function that is restricted to invoking func once.
783             Repeat calls to the function return the value of the first invocation.
784              
785             my $times_called = 0;
786             my $sub = once(sub {
787             $times_called++;
788             return "I was only called $times_called time"
789             });
790              
791             $sub->(); # "I was only called 1 time"
792             $sub->(); # "I was only called 1 time"
793             $sub->(); # etc
794              
795             =cut
796              
797             =head2 apply
798              
799             Calls the supplied function with the array of arguments, spreading the
800             arguments into the function it invokes
801              
802             my $sum_all_nums = sub {
803             my $num = shift;
804             my $second_num = shift;
805              
806             return $num + $second_num;
807             };
808              
809             apply($sum_all_nums, [100, 200]);
810             # same as $sum_all_nums->(100, 200)
811              
812             # 300
813              
814             =cut
815              
816             =head2 range
817              
818             Creates an array of numbers (positive and/or negative) progressing from start up to, but not including, end.
819             A step of -1 is used if a negative start is specified without an end or step.
820             If end is not specified, it's set to start with start then set to 0.
821              
822             range(10);
823              
824             # [1,2,3,4,5,6,7,8,9]
825              
826              
827             range(1,10);
828              
829             # [1,2,3,4,5,6,7,8,9]
830              
831             range(-1, -10);
832              
833             # [-1, -2, -3, -4, -5, -6 ,-7, -8, -9]
834              
835             range(1, 4, 0);
836              
837             # [1, 1, 1]
838              
839              
840             #Ranges that "dont make sense" will return empty arrays
841              
842             range(-1, -4, 0);
843              
844             # []
845              
846             range(100, 1, 0)
847              
848             # []
849              
850             range(0,0,0)
851              
852             # []
853              
854             range(0, -100, 100)
855              
856             # []
857              
858             range(0, 100, -100)
859              
860             # []
861              
862             #etc...
863              
864             =cut
865              
866             =head2 for_each
867              
868             Iterates over elements of collection and invokes iteratee for each element. The iteratee is invoked with three arguments: (value, index|key, collection).
869              
870              
871             for_each(sub {
872             my $num = shift;
873             print $num;
874             }, [1,2,3]);
875              
876              
877             for_each(sub {
878             my ($num, $idx, $coll) = @_;
879             print $idx;
880             }, [1,2,3])
881              
882             # 0 1 2
883              
884             for_each(sub {
885             my ($num, $idx, $coll) = @_;
886             print Dumper $coll;
887             }, [1,2,3])
888              
889             # [1,2,3],
890             # [1,2,3],
891             # [1,2,3]
892              
893             =cut
894              
895             =head2 maps
896              
897             Creates an array of values by running each element in collection thru iteratee.
898             The iteratee is invoked with three arguments:
899             (value, index|key, collection).
900              
901             maps(sub {
902             my $num = shift;
903             return $num + 1;
904             }, [1,1,1]);
905              
906             # [2,2,2]
907              
908             =cut
909              
910             =head2 reduces
911              
912             Reduces collection to a value which is the accumulated result of running each element in collection thru iteratee,
913             where each successive invocation is supplied the return value of the previous.
914             If accumulator is not given, the first element of collection is used as the initial value.
915             The iteratee is invoked with four arguments:
916             (accumulator, value, index|key, collection).
917              
918             # Implicit Accumulator
919              
920             reduces(sub {
921             my ($sum, $num) = @_;
922              
923             return $sum + $num;
924             }, [1,1,1]);
925              
926             # 3
927              
928              
929             # Explict Accumulator
930              
931             reduces(sub {
932             my ($accum, $num) = @_;
933             return {
934             spread($accum),
935             key => $num,
936             }
937             }, {}, [1,2,3]);
938              
939             # {
940             # key => 1,
941             # key => 2,
942             # key => 3,
943             # }
944             =cut
945              
946             =head2 flatten
947              
948             Flattens array a single level deep.
949              
950             flatten([1,1,1, [2,2,2]]);
951              
952             # [1,1,1,2,2,2];
953              
954             =cut
955              
956             =head2 pop / pushes / shifts / unshifts
957              
958             Works the same as builtin pop / push etc etc, with mutations,
959             except it uses references instead of @ lists.
960              
961             my $array = [1,2,3];
962              
963             pops($array)
964              
965             # 3
966              
967             my $array = [1,2,3];
968              
969             pushes($array, 4);
970              
971             # [1,2,3,4]
972              
973             =cut
974              
975             =head2 drop
976              
977             Creates a slice of array with n elements dropped from the beginning.
978              
979             drop([1,2,3])
980              
981             # [2,3];
982              
983             drop(2, [1,2,3])
984              
985             # [3]
986              
987             drop(5, [1,2,3])
988              
989             # []
990              
991             drop(0, [1,2,3])
992              
993             # [1,2,3]
994             =cut
995              
996              
997              
998             =head2 drop_right
999              
1000             Creates a slice of array with n elements dropped from the end.
1001              
1002             drop_right([1,2,3]);
1003              
1004             # [1,2]
1005              
1006             drop_right(2, [1,2,3])
1007              
1008             # [1]
1009              
1010             drop_right(5, [1,2,3])
1011              
1012             # []
1013              
1014             drop_right(0, [1,2,3])
1015              
1016             #[1,2,3]
1017             =cut
1018              
1019             =head2 take
1020              
1021             Creates a slice of array with n elements taken from the beginning.
1022              
1023             take([1, 2, 3);
1024              
1025             # [1]
1026              
1027             take(2, [1, 2, 3]);
1028              
1029             # [1, 2]
1030              
1031             take(5, [1, 2, 3]);
1032              
1033             # [1, 2, 3]
1034              
1035             take(0, [1, 2, 3]);
1036              
1037             # []
1038              
1039             =cut
1040              
1041             =head2 take_right
1042              
1043             Creates a slice of array with n elements taken from the end.
1044              
1045             take_right([1, 2, 3]);
1046              
1047             # [3]
1048              
1049             take_right(2, [1, 2, 3]);
1050              
1051             # [2, 3]
1052              
1053             take_right(5, [1, 2, 3]);
1054              
1055             # [1, 2, 3]
1056              
1057             take_right(0, [1, 2, 3]);
1058              
1059             # []
1060              
1061             =cut
1062              
1063             =head2 second
1064              
1065             Returns the second item in an array
1066              
1067             second(["I", "am", "a", "string"])
1068              
1069             # "am"
1070              
1071             second([5,4,3,2,1])
1072              
1073             # 4
1074              
1075             =cut
1076              
1077             =head2 first
1078              
1079             Returns the first item in an array
1080              
1081             first(["I", "am", "a", "string"])
1082              
1083             # "I"
1084              
1085             first([5,4,3,2,1])
1086              
1087             # 5
1088              
1089             =cut
1090              
1091             =head2 end
1092              
1093             Returns the end, or last item in an array
1094              
1095             end(["I", "am", "a", "string"])
1096              
1097             # "string"
1098              
1099             end([5,4,3,2,1])
1100              
1101             # 1
1102              
1103             =cut
1104              
1105             =head2 len
1106              
1107             Returns the length of the collection.
1108             If an array, returns the number of items.
1109             If a hash, the number of key-val pairs.
1110             If a string, the number of chars (following built-in split)
1111              
1112             len([1,2,3,4])
1113              
1114             # 4
1115              
1116             len("Hello")
1117              
1118             # 5
1119              
1120             len({ key => 'val', key2 => 'val'})
1121              
1122             #2
1123              
1124             len([])
1125              
1126             # 0
1127              
1128             =cut
1129              
1130             =head2 noop
1131              
1132             A function that does nothing (like our government), and returns undef
1133              
1134             noop()
1135              
1136             # undef
1137              
1138             =cut
1139              
1140             =head2 identity
1141              
1142             A function that returns its first argument
1143              
1144             identity()
1145              
1146             # undef
1147              
1148             identity(1)
1149              
1150             # 1
1151              
1152             identity([1,2,3])
1153              
1154             # [1,2,3]
1155              
1156             =cut
1157              
1158             =head2 eql
1159              
1160             Returns 0 or 1 if the two values have == equality, with convience wrapping
1161             for different types (no need to use eq vs ==). Follows internal perl rules
1162             on equality following strings vs numbers in perl.
1163              
1164             eql([], [])
1165              
1166             # 1
1167              
1168             eql(1,1)
1169              
1170             # 1
1171              
1172              
1173             my $obj = {};
1174              
1175             eql($obj, $obj);
1176              
1177             # 1
1178              
1179              
1180             eql("123", 123)
1181              
1182             # 1 'Following perls internal rules on comparing scalars'
1183              
1184              
1185             eql({ key => 'val' }, {key => 'val'});
1186              
1187             # 0 'Only identity equality'
1188              
1189             =cut
1190              
1191             =head2 is_sub
1192              
1193             Returns 0 or 1 if the argument is a sub ref
1194              
1195             is_sub()
1196              
1197             # 0
1198              
1199             is_sub(sub {})
1200              
1201             # 1
1202              
1203             my $sub = sub {};
1204             is_sub($sub)
1205              
1206             # 1
1207              
1208             =cut
1209              
1210             =head2 is_array
1211              
1212             Returns 0 or 1 if the argument is an array
1213              
1214             is_array()
1215              
1216             # 0
1217              
1218             is_array([1,2,3])
1219              
1220             # 1
1221              
1222             =cut
1223              
1224             =head2 is_hash
1225              
1226             Returns 0 or 1 if the argument is a hash
1227              
1228             is_hash()
1229              
1230             # 0
1231              
1232             is_hash({ key => 'val' })
1233              
1234             # 1
1235              
1236             =cut
1237              
1238             =head2 is_empty
1239              
1240             Returns 1 if the argument is 'empty',
1241             0 if not empty. Used on strings, arrays, hashes.
1242              
1243             is_empty()
1244              
1245             # 1
1246              
1247             is_empty([])
1248              
1249             # 1
1250              
1251             is_empty([1,2,3])
1252              
1253             # 0
1254              
1255             is_empty({ key => 'val' })
1256              
1257             # 0
1258              
1259             is_empty("I am a string")
1260              
1261             # 0
1262              
1263             =cut
1264              
1265             =head2 get
1266              
1267             Returns value from hash, string, array based on key/idx provided.
1268             Returns default value if provided key/idx does not exist on collection.
1269             Only works one level deep;
1270              
1271             my $hash = {
1272             key1 => 'value1',
1273             };
1274              
1275             get('key1', $hash);
1276              
1277             # 'value1'
1278              
1279              
1280             my $array = [100, 200, 300]
1281              
1282             get(1, $array);
1283              
1284             # 200
1285              
1286              
1287             my $string = "Hello";
1288              
1289             get(1, $string);
1290              
1291             # e
1292              
1293              
1294             # Also has the ability to supply default-value when key/idx does not exist
1295              
1296             my $hash = {
1297             key1 => 'value1',
1298             };
1299              
1300             get('key2', $hash, "DEFAULT HERE");
1301              
1302             # 'DEFAULT HERE'
1303              
1304             =cut
1305              
1306             =head2 spread
1307              
1308             Destructures an array / hash into non-ref context.
1309             Destructures a string into an array of chars (following in-built split)
1310              
1311             spread([1,2,3,4])
1312              
1313             # 1,2,3,4
1314              
1315             spread({ key => 'val' })
1316              
1317             # key,'val'
1318              
1319             spread("Hello")
1320              
1321             # 'H','e','l','l','o'
1322              
1323             =cut
1324              
1325             =head2 bool
1326              
1327             Returns 0 or 1 based on truthiness of argument, following
1328             internal perl rules based on ternary coercion
1329              
1330             bool([])
1331              
1332             # 1
1333              
1334             bool("hello!")
1335              
1336             # 1
1337              
1338             bool()
1339              
1340             # 0
1341              
1342             bool(undef)
1343              
1344             # 0
1345              
1346             =cut
1347              
1348             =head2 to_keys
1349              
1350             Creates an array of the key names in a hash,
1351             indicies of an array, or chars in a string
1352              
1353             to_keys([1,2,3])
1354              
1355             # [0,1,2]
1356              
1357             to_keys({ key => 'val', key2 => 'val2' })
1358              
1359             # ['key', 'key2']
1360              
1361             to_keys("Hey")
1362              
1363             # [0, 1, 2];
1364              
1365             =cut
1366              
1367             =head2 to_vals
1368              
1369             Creates an array of the values in a hash, of an array, or string.
1370              
1371             to_vals([1,2,3])
1372              
1373             # [0,1,2]
1374              
1375             to_vals({ key => 'val', key2 => 'val2' })
1376              
1377             # ['val', 'val2']
1378              
1379             to_vals("Hey");
1380              
1381             # ['H','e','y'];
1382              
1383             =cut
1384              
1385             =head2 to_pairs
1386              
1387             Creates an array of key-value, or idx-value pairs from arrays, hashes, and strings.
1388             If used on a hash, key-pair order can not be guaranteed;
1389              
1390             to_pairs("I am a string");
1391              
1392             # [
1393             # [0, "I"],
1394             # [1, "am"],
1395             # [2, "a"],
1396             # [3, "string"]
1397             # ]
1398              
1399             to_pairs([100, 101, 102]);
1400              
1401             # [
1402             # [0, 100],
1403             # [1, 102],
1404             # [2, 103],
1405             # ]
1406              
1407             to_pairs({ key1 => 'value1', key2 => 'value2' });
1408              
1409             # [
1410             # [key1, 'value1'],
1411             # [key2, 'value2']
1412             # ]
1413              
1414             to_pairs({ key1 => 'value1', key2 => { nested => 'nestedValue' }});
1415              
1416             # [
1417             # [key1, 'value1'],
1418             # [key2, { nested => 'nestedValue' }]
1419             # ]
1420              
1421             =cut
1422              
1423             =head2 uniq
1424              
1425             Creates a duplicate-free version of an array,
1426             in which only the first occurrence of each element is kept.
1427             The order of result values is determined by the order they occur in the array.
1428              
1429             uniq([2,1,2])
1430              
1431             # [2,1]
1432              
1433             uniq(["Hi", "Howdy", "Hi"])
1434              
1435             # ["Hi", "Howdy"]
1436              
1437             =cut
1438              
1439             =head2 assoc
1440              
1441             Returns new hash, or array, with the updated value at index / key.
1442             Shallow updates only
1443              
1444             assoc([1,2,3,4,5,6,7], 0, "item")
1445              
1446             # ["item",2,3,4,5,6,7]
1447              
1448             assoc({ name => 'sally', age => 26}, 'name', 'jimmy')
1449              
1450             # { name => 'jimmy', age => 26}
1451              
1452             =cut
1453              
1454             =head2 subarray
1455              
1456             Returns a subset of the original array, based on
1457             start index (inclusive) and end idx (not-inclusive)
1458              
1459             subarray(["first", "second", "third", "fourth"], 0,2)
1460              
1461             # ["first", "second"]
1462              
1463             =cut
1464              
1465             =head2 find
1466              
1467             Iterates over elements of collection, returning the first element predicate returns truthy for.
1468              
1469             my $people = [
1470             {
1471             name => 'john',
1472             age => 25,
1473             },
1474             {
1475             name => 'Sally',
1476             age => 25,
1477             }
1478             ]
1479              
1480             find(sub {
1481             my $person = shift;
1482             return eql($person->{'name'}, 'sally')
1483             }, $people);
1484              
1485             # { name => 'sally', age => 25 }
1486              
1487             =cut
1488              
1489             =head2 filter
1490              
1491             Iterates over elements of collection, returning only elements the predicate returns truthy for.
1492              
1493             my $people = [
1494             {
1495             name => 'john',
1496             age => 25,
1497             },
1498             {
1499             name => 'Sally',
1500             age => 25,
1501             },
1502             {
1503             name => 'Old Greg',
1504             age => 100,
1505             }
1506             ]
1507              
1508             filter(sub {
1509             my $person = shift;
1510             return $person->{'age'} < 30;
1511             }, $people);
1512              
1513             # [
1514             # {
1515             # name => 'john',
1516             # age => 25,
1517             # },
1518             # {
1519             # name => 'Sally',
1520             # age => 25,
1521             # }
1522             # ]
1523              
1524             =cut
1525              
1526             =head2 none
1527              
1528             If one element is found to return truthy for the given predicate, none returns 0
1529              
1530              
1531             my $people = [
1532             {
1533             name => 'john',
1534             age => 25,
1535             },
1536             {
1537             name => 'Sally',
1538             age => 25,
1539             },
1540             {
1541             name => 'Old Greg',
1542             age => 100,
1543             }
1544             ]
1545              
1546             none(sub {
1547             my $person = shift;
1548             return $person->{'age'} > 99;
1549             }, $people);
1550              
1551             # 0
1552              
1553             none(sub {
1554             my $person = shift;
1555             return $person->{'age'} > 101;
1556             }, $people);
1557              
1558             # 1
1559              
1560             =cut
1561              
1562             =head2 every
1563              
1564             Itterates through each element in the collection, and checks if element makes predicate
1565             return truthy. If all elements cause predicate to return truthy, every returns 1;
1566              
1567             every(sub {
1568             my $num = shift;
1569             $num > 0;
1570             }, [1,2,3,4]);
1571              
1572             # 1
1573              
1574             every(sub {
1575             my $num = shift;
1576             $num > 2;
1577             }, [1,2,3,4]);
1578              
1579             # 0
1580              
1581             =cut
1582              
1583             =head2 some
1584              
1585             Checks if predicate returns truthy for any element of collection.
1586             Iteration is stopped once predicate returns truthy.
1587              
1588             some(sub {
1589             my $num = shift;
1590             $num > 0;
1591             }, [1,2,3,4]);
1592              
1593             # 1
1594              
1595             some(sub {
1596             my $num = shift;
1597             $num > 2;
1598             }, [1,2,3,4]);
1599              
1600             # 1
1601              
1602             =cut
1603              
1604             =head2 partial
1605              
1606             Creates a function that invokes func with partials prepended to the arguments it receives.
1607             (funcRef, args)
1608              
1609             my $add_three_nums = sub {
1610             my ($a, $b, $c) = @_;
1611              
1612             return $a + $b + $c;
1613             };
1614              
1615             my $add_two_nums = partial($add_three_nums, 1);
1616              
1617             $add_two_nums->(1,1)
1618              
1619             # 3
1620              
1621              
1622             # Can also use __ to act as a placeholder
1623              
1624             my $add_four_strings = sub {
1625             my ($a, $b, $c, $d) = @_;
1626              
1627             return $a . $b . $c . $d;
1628             };
1629              
1630             my $add_two_strings = partial($add_four_strings, "first ", __, "third ", __);
1631              
1632             $add_two_strings->("second ", "third ")
1633              
1634             # "first second third fourth"
1635              
1636             =cut
1637              
1638             =head2 chain
1639              
1640             Composes functions, left to right, and invokes them, returning
1641             the result. Accepts an expression as the first argument, to be passed
1642             as the first argument to the proceding function
1643              
1644             chain(
1645             [1,2,3, [4,5,6]],
1646             sub {
1647             my $array = shift;
1648             return [spread($array), 7]
1649             },
1650             \&flatten,
1651             );
1652              
1653             # [1,2,3,4,5,6,7]
1654              
1655              
1656             # Invokes first function, and uses that as start value for next func
1657             chain(
1658             sub { [1,2,3, [4,5,6]] },
1659             sub {
1660             my $array = shift;
1661             return [spread($array), 7]
1662             },
1663             \&flatten,
1664             )
1665              
1666             # [1,2,3,4,5,6,7]
1667              
1668             =cut
1669              
1670             =head2 flow
1671              
1672             Creates a function that returns the result of invoking the given functions,
1673             where each successive invocation is supplied the return value of the previous.
1674              
1675             my $addTwo = flow(\&incr, \&incr);
1676              
1677             $addTwo->(1);
1678              
1679             # 3
1680              
1681             =cut
1682              
1683             =head1 AUTHOR
1684              
1685             Kristopher C. Paulsen, C<< >>
1686              
1687             =head1 BUGS
1688              
1689             Please report any bugs or feature requests to C, or through
1690             the web interface at L. I will be notified, and then you'll
1691             automatically be notified of progress on your bug as I make changes.
1692              
1693             =head1 SUPPORT
1694              
1695             You can find documentation for this module with the perldoc command.
1696              
1697             perldoc Sub::Fp
1698              
1699              
1700             You can also look for information at:
1701              
1702             =over 4
1703              
1704             =item * RT: CPAN's request tracker (report bugs here)
1705              
1706             L
1707              
1708             =item * AnnoCPAN: Annotated CPAN documentation
1709              
1710             L
1711              
1712             =item * CPAN Ratings
1713              
1714             L
1715              
1716             =item * Search CPAN
1717              
1718             L
1719              
1720             =back
1721              
1722              
1723             =head1 ACKNOWLEDGEMENTS
1724              
1725              
1726             =head1 LICENSE AND COPYRIGHT
1727              
1728             MIT
1729              
1730             Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions:
1731              
1732             The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software.
1733              
1734             THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
1735              
1736              
1737             =cut
1738              
1739             1;