File Coverage

blib/lib/autobox/Transform.pm
Criterion Covered Total %
statement 375 381 98.4
branch 112 132 84.8
condition 43 48 89.5
subroutine 88 91 96.7
pod 0 1 0.0
total 618 653 94.6


line stmt bran cond sub pod time code
1             package autobox::Transform;
2              
3 18     18   1685282 use strict;
  18         190  
  18         453  
4 18     18   79 use warnings;
  18         27  
  18         370  
5 18     18   319 use 5.010;
  18         49  
6 18     18   6669 use parent qw/autobox/;
  18         4520  
  18         79  
7              
8             our $VERSION = "1.035";
9              
10             =head1 NAME
11              
12             autobox::Transform - Autobox methods to transform Arrays and Hashes
13              
14             =head1 CONTEXT
15              
16             L provides the ability to call methods on native types,
17             e.g. strings, arrays, and hashes as if they were objects.
18              
19             L provides the basic methods for Perl core functions
20             like C, C, and C.
21              
22             This module, C, provides higher level and more
23             specific methods to transform and manipulate arrays and hashes, in
24             particular when the values are hashrefs or objects.
25              
26              
27              
28             =head1 SYNOPSIS
29              
30             use autobox::Core; # map, uniq, sort, join, sum, etc.
31             use autobox::Transform;
32              
33             =head2 Arrays
34              
35             # use autobox::Core for ->map etc.
36              
37             # filter (like a more versatile grep)
38             $book_locations->filter(); # true values
39             $books->filter(sub { $_->is_in_library($library) });
40             $book_names->filter( qr/lord/i );
41             $book_genres->filter("scifi");
42             $book_genres->filter({ fantasy => 1, scifi => 1 }); # hash key exists
43              
44             # reject: the inverse of filter
45             $book_genres->reject("fantasy");
46              
47             # order (like a more succinct sort)
48             $book_genres->order;
49             $book_genres->order("desc");
50             $book_prices->order([ "num", "desc" ]);
51             $books->order([ sub { $_->{price} }, "desc", "num" ]);
52             $log_lines->order([ num => qr/pid: "(\d+)"/ ]);
53             $books->order(
54             [ sub { $_->{price} }, "desc", "num" ] # first price
55             sub { $_->{name} }, # then name
56             );
57              
58             # group (aggregate) array into hash
59             $book_genres->group; # "Sci-fi" => "Sci-fi"
60             $book_genres->group_count; # "Sci-fi" => 3
61             $book_genres->group_array; # "Sci-fi" => [ "Sci-fi", "Sci-fi", "Sci-fi"]
62              
63             # Flatten arrayrefs-of-arrayrefs
64             $authors->map_by("books") # ->books returns an arrayref
65             # [ [ $book1, $book2 ], [ $book3 ] ]
66             $authors->map_by("books")->flat;
67             # [ $book1, $book2, $book3 ]
68              
69             # Return reference, even in list context, e.g. in a parameter list
70             $book_locations->filter()->to_ref;
71              
72             # Return array, even in scalar context
73             @books->to_array;
74              
75             # Turn paired items into a hash
76             @titles_books->to_hash;
77              
78              
79             =head2 Arrays where the items are hashrefs/objects
80              
81             # $books and $authors below are arrayrefs with either objects or
82             # hashrefs (the call syntax is the same). These have methods/hash
83             # keys like C<$book->genre()>, C<$book->{is_in_stock}>,
84             # C<$book->is_in_library($library)>, etc.
85              
86             $books->map_by("genre");
87             $books->map_by([ price_with_tax => $tax_pct ]);
88              
89             $books->filter_by("is_in_stock");
90             $books->filter_by([ is_in_library => $library ]);
91             $books->filter_by([ price_with_tax => $rate ], sub { $_ > 56.00 });
92             $books->filter_by("price", sub { $_ > 56.00 });
93             $books->filter_by("author", "James A. Corey");
94             $books->filter_by("author", qr/corey/i);
95              
96             # grep_by is an alias for filter_by
97             $books->grep_by("is_in_stock");
98              
99             # reject_by: the inverse of filter_by
100             $books->reject_by("is_sold_out");
101              
102             $books->uniq_by("id");
103              
104             $books->order_by("name");
105             $books->order_by(name => "desc");
106             $books->order_by(price => "num");
107             $books->order_by(price => [ "num", "desc" ]);
108             $books->order_by(name => [ sub { uc($_) }, "desc" ]);
109             $books->order_by([ price_with_tax => $rate ] => "num");
110             $books->order_by(
111             author => "str", # first by author
112             price => [ "num", "desc" ], # then by price, most expensive first
113             );
114             $books->order_by(
115             author => [ "desc", sub { uc($_) } ],
116             [ price_with_tax => $rate ] => [ "num", "desc" ],
117             "name",
118             );
119              
120              
121             $books->group_by("title"),
122             # {
123             # "Leviathan Wakes" => $books->[0],
124             # "Caliban's War" => $books->[1],
125             # "The Tree-Body Problem" => $books->[2],
126             # "The Name of the Wind" => $books->[3],
127             # },
128              
129             $authors->group_by([ publisher_affiliation => "with" ]),
130             # {
131             # 'James A. Corey with Orbit' => $authors->[0],
132             # 'Cixin Liu with Head of Zeus' => $authors->[1],
133             # 'Patrick Rothfuss with Gollanz' => $authors->[2],
134             # },
135              
136             $books->group_by_count("genre"),
137             # {
138             # "Sci-fi" => 3,
139             # "Fantasy" => 1,
140             # },
141              
142             my $genre_books = $books->group_by_array("genre");
143             # {
144             # "Sci-fi" => [ $sf_book_1, $sf_book_2, $sf_book_3 ],
145             # "Fantasy" => [ $fantasy_book_1 ],
146             # },
147              
148              
149             =head2 Hashes
150              
151             # map over each pair
152             # e.g. Upper-case the genre name, and make the count say "n books"
153             # (return a key => value pair)
154             $genre_count->map_each(sub { uc( $_[0] ) => "$_ books" });
155             # {
156             # "FANTASY" => "1 books",
157             # "SCI-FI" => "3 books",
158             # },
159              
160             # map over each value
161             # e.g. Make the count say "n books"
162             # (return the new value)
163             $genre_count->map_each_value(sub { "$_ books" });
164             # {
165             # "Fantasy" => "1 books",
166             # "Sci-fi" => "3 books",
167             # },
168              
169             # map each pair into an array
170             # e.g. Transform each pair to the string "n: genre"
171             # (return list of items)
172             $genre_count->map_each_to_array(sub { "$_: $_[0]" });
173             # [ "1: Fantasy", "3: Sci-fi" ]
174              
175             # filter each pair
176             # Genres with more than five books
177             $genre_count->filter_each(sub { $_ > 5 });
178              
179             # filter out each pair
180             # Genres with more than five books
181             $genre_count->reject_each(sub { $_ <= 5 });
182              
183              
184             # Return reference, even in list context, e.g. in a parameter list
185             %genre_count->to_ref;
186              
187             # Return hash, even in scalar context
188             $author->book_count->to_hash;
189              
190             # Turn key-value pairs into an array
191             %isbn__book->to_array;
192              
193              
194             =head2 Combined examples
195              
196             my $order_authors = $order->books
197             ->filter_by("title", qr/^The/)
198             ->uniq_by("isbn")
199             ->map_by("author")
200             ->uniq_by("name")
201             ->order_by(publisher => "str", name => "str")
202             ->map_by("name")->uniq->join(", ");
203              
204             my $total_order_amount = $order->books
205             ->reject_by("is_sold_out")
206             ->filter_by([ covered_by_vouchers => $vouchers ], sub { ! $_ })
207             ->map_by([ price_with_tax => $tax_pct ])
208             ->sum;
209              
210             =cut
211              
212              
213              
214 18     18   10396 use Carp;
  18         31  
  18         9170  
215              
216             sub import {
217 18     18   148 my $self = shift;
218 18         131 $self->SUPER::import( ARRAY => "autobox::Transform::Array" );
219 18         9572 $self->SUPER::import( HASH => "autobox::Transform::Hash" );
220             }
221              
222             sub throw {
223 2     2 0 5 my ($error) = @_;
224             ###JPL: remove lib
225 2         16 $error =~ s/ at [\\\/\w ]*?\bautobox.Transform\.pm line \d+\.\n?$//;
226 2         5 local $Carp::CarpLevel = 1;
227 2         18 croak($error);
228             }
229              
230             # Normalize the two method calling styles for accessor + args:
231             # $acessor, $args_arrayref
232             # or
233             # $acessor_and_args_arrayref
234             sub _normalized_accessor_args_subref {
235 88     88   147 my ($accessor, $args, $subref) = @_;
236              
237             # Note: unfortunately, this won't allow the $subref (modifier) to
238             # become an arrayref later on when we do many types of modifiers
239             # (string eq, qr regex match, sub call, arrayref in) for
240             # filtering.
241             #
242             # That has to happen after the deprecation has expired and the old
243             # syntax is removed.
244 88 100       192 if(ref($args) eq "CODE") {
245 1         2 $subref = $args; # Move down one step
246 1         2 $args = undef;
247             }
248 88 100       143 if(ref($accessor) eq "ARRAY") {
249 14         29 ($accessor, my @args) = @$accessor;
250 14         24 $args = \@args;
251             }
252              
253 88         201 return ($accessor, $args, $subref);
254             }
255              
256             ###JPL: rename subref to predicate
257             # Normalize the two method calling styles for accessor + args:
258             # $acessor, $args_arrayref, $modifier
259             # or
260             # $acessor_and_args_arrayref, $modifier
261             sub _normalized_accessor_args_predicate {
262 25     25   49 my ($accessor, $args, $subref) = @_;
263              
264             # Note: unfortunately, this won't allow the $subref (modifier) to
265             # be an arrayref, or undef for many types of modifiers (string eq,
266             # qr regex match, sub call, arrayref in) for filtering.
267             #
268             # That has to happen after the deprecation has expired and the old
269             # syntax is removed.
270 25 100 100     92 if(defined($args) && ref($args) ne "ARRAY") {
271 10         14 $subref = $args; # Move down one step
272 10         14 $args = undef;
273             }
274 25 100       42 if(ref($accessor) eq "ARRAY") {
275 4         8 ($accessor, my @args) = @$accessor;
276 4         8 $args = \@args;
277             }
278              
279 25         55 return ($accessor, $args, $subref);
280             }
281              
282              
283              
284             sub _predicate {
285 65     65   108 my ($name, $predicate, $default_predicate) = @_;
286              
287             # No predicate, use default is_true
288 65 100       123 defined($predicate) or return $default_predicate;
289              
290             # scalar, do string eq
291 51 100   30   127 my $type = ref($predicate) or return sub { $predicate eq $_ };
  30         147  
292              
293 41 100       89 $type eq "CODE" and return $predicate;
294 18 100   30   84 $type eq "Regexp" and return sub { $_ =~ $predicate };
  30         159  
295 8 100   18   33 $type eq "HASH" and return sub { exists $predicate->{ $_ } };
  18         84  
296              
297             # Invalid predicate
298 2         33 Carp::croak("->$name() \$predicate: ($predicate) is not one of: subref, string, regex");
299             }
300              
301              
302              
303             =head1 DESCRIPTION
304              
305             C provides high level autobox methods you can call
306             on arrays, arrayrefs, hashes and hashrefs.
307              
308              
309             =head2 Transforming lists of objects vs list of hashrefs
310              
311             C, C C etc. (all methods named C<*_by>)
312             work with sets of hashrefs or objects.
313              
314             These methods are called the same way regardless of whether the array
315             contains objects or hashrefs. The items in the list must be either all
316             objects or all hashrefs.
317              
318             If the array contains hashrefs, the hash key is looked up on each
319             item.
320              
321             If the array contains objects, a method is called on each object
322             (possibly with the arguments provided).
323              
324             =head3 Calling accessor methods with arguments
325              
326             For method calls, it's possible to provide arguments to the method.
327              
328             Consider C:
329              
330             $array->map_by($accessor)
331              
332             If the $accessor is a string, it's a simple method call.
333              
334             # method call without args
335             $books->map_by("price")
336             # becomes $_->price() or $_->{price}
337              
338             If the $accessor is an arrayref, the first item is the method name,
339             and the rest of the items are the arguments to the method.
340              
341             # method call with args
342             $books->map_by([ price_with_discount => 5.0 ])
343             # becomes $_->price_with_discount(5.0)
344              
345              
346              
347             =head2 Filter predicates
348              
349             There are several methods that filter items,
350             e.g. C<@array-Efilter> (duh), C<@array-Efilter_by>, and
351             C<%hash-Efilter_each>. These methods take a C<$predicate> argument
352             to determine which items to retain or filter out.
353              
354             The C family of methods do the opposite, and I
355             items that match the predicate, i.e. the opposite of the filter
356             methods.
357              
358             If $predicate is an I, it is compared to each value
359             with C.
360              
361             $books->filter_by("author", "James A. Corey");
362              
363             If $predicate is a I, it is compared to each value with C<=~>.
364              
365             $books->reject_by("author", qr/Corey/);
366              
367             If $predicate is a I, values in @array are retained if the
368             $predicate hash key C (the hash values are irrelevant).
369              
370             $books->filter_by(
371             "author", {
372             "James A. Corey" => undef,
373             "Cixin Liu" => 0,
374             "Patrick Rothfuss" => 1,
375             },
376             );
377              
378             If $predicate is a I, the subref is called for each value to
379             check whether this item should remain in the list.
380              
381             The $predicate subref should return a true value to remain. C<$_> is
382             set to the current $value.
383              
384             $authors->filter_by(publisher => sub { $_->name =~ /Orbit/ });
385              
386              
387             =head2 Sorting using order and order_by
388              
389             Let's first compare how sorting is done with Perl's C and
390             autobox::Transform's C/C.
391              
392              
393             =head3 Sorting with sort
394              
395             =over 4
396              
397             =item *
398              
399             provide a sub that returns the comparison outcome of two values: C<$a>
400             and C<$b>
401              
402             =item *
403              
404             in case of a tie, provide another comparison of $a and $b
405              
406             =back
407              
408             # If the name is the same, compare age (oldest first)
409             sort {
410             uc( $a->{name} ) cmp uc( $b->{name} ) # first comparison
411             ||
412             int( $b->{age} / 10 ) <=> int( $a->{age} / 10 ) # second comparison
413             } @users
414              
415             (note the opposite order of C<$a> and C<$b> for the age comparison,
416             something that's often difficult to discern at a glance)
417              
418             =head3 Sorting with order, order_by
419              
420             =over 4
421              
422             =item *
423              
424             Provide order options for how one value should be compared with the others:
425              
426             =over 8
427              
428             =item *
429              
430             how to compare (C or C<<=E>)
431              
432             =item *
433              
434             which direction to sort (Cending or Cending)
435              
436             =item *
437              
438             which value to compare, using a regex or subref, e.g. by C
439              
440             =back
441              
442             =item *
443              
444             In case of a tie, provide another comparison
445              
446             =back
447              
448             # If the name is the same, compare age (oldest first)
449              
450             # ->order
451             @users->order(
452             sub { uc( $_->{name} ) }, # first comparison
453             [ "num", sub { int( $_->{age} / 10 ) }, "desc" ], # second comparison
454             )
455              
456             # ->order_by
457             @users->order_by(
458             name => sub { uc }, # first comparison
459             age => [ num => desc => sub { int( $_ / 10 ) } ], # second comparison
460             )
461              
462             =head3 Comparison Options
463              
464             If there's only one option for a comparison (e.g. C), provide a
465             single option (string/regex/subref) value. If there are many options,
466             provide them in an arrayref in any order.
467              
468             =head3 Comparison operator
469              
470             =over 4
471              
472             =item *
473              
474             C<"str"> (cmp) - default
475              
476             =item *
477              
478             C<"num"> (<=>)
479              
480             =back
481              
482              
483             =head3 Sort order
484              
485             =over 4
486              
487             =item *
488              
489             C<"asc"> (ascending) - default
490              
491             =item *
492              
493             C<"desc"> (descending)
494              
495             =back
496              
497              
498             =head3 The value to compare
499              
500             =over 4
501              
502             =item *
503              
504             A subref - default is: C
505              
506             =over 8
507              
508             =item *
509              
510             The return value is used in the comparison
511              
512             =back
513              
514             =item *
515              
516             A regex, e.g. C
517              
518             =over 8
519              
520             =item *
521              
522             The value of C are used in the comparison (C<@captured_groups> are C<$1>, C<$2>, C<$3> etc.)
523              
524             =back
525              
526             =back
527              
528             =head3 Examples of a single comparison
529              
530             # order: the first arg is the comparison options (one or an
531             # arrayref with many options)
532             ->order() # Defaults to str, asc, $_, just like sort
533             ->order("num")
534             ->order(sub { uc($_) })
535             # compare captured matches, e.g. "John" and "Doe" as "JohnDoe"
536             ->order( qr/first_name: (\w+), last_name: (\w+)/ )
537             ->order([ num => qr/id: (\d+)/ ])
538             ->order([ sub { int($_) }, "num" ])
539              
540             # order_by: the first arg is the accessor, just like with
541             # map_by. Second arg is the comparison options (one or an arrayref
542             # with many options)
543             ->order_by("id")
544             ->order_by("id", "num")
545             ->order_by("id", [ "num", "desc" ])
546             ->order_by("name", sub { uc($_) })
547             ->order_by(log_line => qr/first_name: (\w+), last_name: (\w+)/ )
548             ->order_by("log_line", [ num => qr/id: (\d+)/ ])
549             ->order_by(age => [ sub { int($_) }, "num" ])
550              
551             # compare int( $a->age_by_interval(10) )
552             ->order_by([ age_by_interval => 10 ] => [ sub { int($_) }, "num" ])
553             # compare uc( $a->name_with_title($title) )
554             ->order_by([ name_with_title => $title ], sub { uc($_) })
555              
556              
557             =head3 Examples of fallback comparisons
558              
559             When the first comparison is a tie, the subsequent ones are used.
560              
561             # order: list of comparison options (one or an arrayref with many
562             # options, per comparison)
563             ->order(
564             [ sub { $_->{price} }, "num" ], # First a numeric comparison of price
565             [ sub { $_->{name} }, "desc" ], # or if same, a reverse comparison of the name
566             )
567             ->order(
568             [ sub { uc($_) }, "desc" ],
569             "str",
570             )
571             ->order(
572             qr/type: (\w+)/,
573             [ num => desc => qr/duration: (\d+)/ ]
574             [ num => sub { /id: (\d+)/ } ],
575             "str",
576             )
577              
578             # order_by: pairs of accessor-comparison options
579             ->order_by(
580             price => "num", # First a numeric comparison of price
581             name => "desc", # or if same, a reverse comparison of the name
582             )
583             ->order_by(
584             price => [ "num", "desc" ],
585             name => "str",
586             )
587             # accessor is a method call with arg: $_->price_with_discount($discount)
588             ->order_by(
589             [ price_with_discount => $discount ] => [ "num", "desc" ],
590             name => [ str => sub { uc($_) } ],
591             "id",
592             )
593              
594              
595              
596             =head2 List and Scalar Context
597              
598             Almost all of the methods are context sensitive, i.e. they return a
599             list in list context and an arrayref in scalar context, just like
600             L.
601              
602             B: I
603              
604             When in doubt, assume they work like C and C (i.e. return a
605             list), and convert the return value to references where you might have
606             an non-obvious list context. E.g.
607              
608             =head3 Incorrect
609              
610             $self->my_method(
611             # Wrong, this is list context and wouldn't return an array ref
612             books => $books->filter_by("is_published"),
613             );
614              
615             =head3 Correct
616              
617             $self->my_method(
618             # Correct, put the returned list in an anonymous array ref
619             books => [ $books->filter_by("is_published") ],
620             );
621             $self->my_method(
622             # Correct, ensure scalar context to get an array ref
623             books => scalar $books->filter_by("is_published"),
624             );
625              
626             # Probably the nicest, since ->to_ref goes at the end
627             $self->my_method(
628             # Correct, use ->to_ref to ensure an array ref is returned
629             books => $books->filter_by("is_published")->to_ref,
630             );
631              
632              
633              
634             =head1 METHODS ON ARRAYS
635              
636             =cut
637              
638             package # hide from PAUSE
639             autobox::Transform::Array;
640              
641 18     18   672 use autobox::Core;
  18         9205  
  18         85  
642 18     18   18932 use Sort::Maker ();
  18         68273  
  18         363  
643 18     18   8605 use List::MoreUtils ();
  18         194391  
  18         55996  
644              
645              
646              
647             =head2 @array->filter($predicate = *is_true_subref*) : @array | @$array
648              
649             Similar to Perl's C, return an C<@array> with values for which
650             $predicate yields a true value.
651              
652             $predicate can be a subref, string, undef, regex, or hashref. See
653             L.
654              
655             The default (no C<$predicate>) is a subref which retains true values
656             in the @array.
657              
658             =head3 Examples
659              
660             my @apples = $fruit->filter("apple");
661             my @any_apple = $fruit->filter( qr/apple/i );
662             my @publishers = $authors->filter(
663             sub { $_->publisher->name =~ /Orbit/ },
664             );
665              
666              
667             =head3 filter and grep
668              
669             L's C method takes a subref, just like this
670             method. C also supports the other predicate types, like
671             string, regex, etc.
672              
673              
674             =cut
675              
676             sub filter {
677 9     9   18357 my $array = shift;
678 9         13 my ($predicate) = @_;
679             my $subref = autobox::Transform::_predicate(
680             "filter",
681             $predicate,
682 8     8   15 sub { !! $_ },
683 9         31 );
684              
685 8 50       17 my $result = eval {
686 8         14 [ CORE::grep { $subref->( $_ ) } @$array ]
  29         139  
687             } or autobox::Transform::throw($@);
688              
689 8 100       80 return wantarray ? @$result : $result;
690             }
691              
692             =head2 @array->reject($predicate = *is_false_subref*) : @array | @$array
693              
694             Similar to the Unix command C, return an @array with values
695             for which C<$predicate> yields a I value.
696              
697             $predicate can be a subref, string, undef, regex, or hashref. See
698             L.
699              
700             The default (no $predicate) is a subref which I true
701             values in the C<@array>.
702              
703             Examples:
704              
705             my @apples = $fruit->reject("apple");
706             my @no_apples = $fruit->reject( qr/apple/i );
707             my @publishers = $authors->reject(
708             sub { $_->publisher->name =~ /Orbit/ },
709             );
710              
711             =cut
712              
713             sub reject {
714 9     9   22441 my $array = shift;
715 9         21 my ($predicate) = @_;
716             my $subref = autobox::Transform::_predicate(
717             "reject",
718             $predicate,
719 8     8   17 sub { !! $_ },
720 9         32 );
721              
722 8 50       23 my $result = eval {
723 8         13 [ CORE::grep { ! $subref->( $_ ) } @$array ]
  29         178  
724             } or autobox::Transform::throw($@);
725              
726 8 100       97 return wantarray ? @$result : $result;
727             }
728              
729              
730              
731             my $option__group = {
732             str => "operator",
733             num => "operator",
734             asc => "direction",
735             desc => "direction",
736             };
737             sub _group__value_from_order_options {
738 30     30   43 my ($method_name, $options) = @_;
739 30         32 my $group__value = {};
740 30         38 for my $option (grep { $_ } @$options) {
  38         67  
741 38         40 my $group;
742              
743 38         49 my $ref_option = ref($option);
744 38 100       58 ( $ref_option eq "CODE" ) and $group = "extract";
745 38 100       60 if ( $ref_option eq "Regexp" ) {
746 5         7 my $regex = $option;
747 5     23   14 $option = sub { join("", m/$regex/) };
  23         117  
748 5         9 $group = "extract";
749             }
750              
751 38 100 100     138 $group ||= $option__group->{ $option }
752             or Carp::croak("->$method_name(): Invalid comparison option ($option), did you mean ->order_by('$option')?");
753              
754 36 100       71 exists $group__value->{ $group }
755             and Carp::croak("->$method_name(): Conflicting comparison options: ($group__value->{ $group }) and ($option)");
756              
757 34         87 $group__value->{ $group } = $option;
758             }
759              
760 26         33 return $group__value;
761             }
762              
763             my $transform__sorter = {
764             str => "string",
765             num => "number",
766             asc => "ascending",
767             desc => "descending",
768             };
769             sub _sorter_from_comparisons {
770 28     28   36 my ($method_name, $comparisons) = @_;
771              
772 28         34 my @sorter_keys;
773             my @extracts;
774 28         50 for my $options (@$comparisons) {
775 30 100       65 ref($options) eq "ARRAY" or $options = [ $options ];
776              
777             # Check one comparison
778 30         47 my $group__value = _group__value_from_order_options(
779             $method_name,
780             $options,
781             );
782              
783 26   100     64 my $operator = $group__value->{operator} // "str";
784 26   100     61 my $direction = $group__value->{direction} // "asc";
785 26   100 68   80 my $extract = $group__value->{extract} // sub { $_ };
  68         132  
786              
787 26         39 my $sorter_operator = $transform__sorter->{$operator};
788 26         29 my $sorter_direction = $transform__sorter->{$direction};
789              
790 26         29 push(@extracts, $extract);
791 26         26 my $extract_index = @extracts;
792 26         92 push(
793             @sorter_keys,
794             $sorter_operator => [
795             $sorter_direction,
796             # Sort this one by the extracted value
797             code => "\$_->[ $extract_index ]",
798             ],
799             );
800             }
801              
802 24 50       63 my $sorter = Sort::Maker::make_sorter(
803             "plain", "ref_in", "ref_out",
804             @sorter_keys,
805             ) or Carp::croak(__PACKAGE__ . " internal error: $@");
806              
807 24         9648 return ($sorter, \@extracts);
808             }
809              
810             sub _item_values_array_from_array_item_extracts {
811 12     12   15 my ($array, $extracts) = @_;
812              
813             # Custom Schwartzian Transform where each array item is arrayref of:
814             # 0: $array item; rest 1..n : comparison values
815             # The sorter keys are simply indexed into the nth value
816             return [
817             map { ## no critic
818 12         20 my $item = $_;
  50         59  
819             [
820             $item, # array item to compare
821             map {
822 50         48 my $extract = $_; local $_ = $item;
  55         54  
  55         48  
823 55         61 $extract->();
824             } @$extracts, # comparison values for array item
825             ];
826             }
827             @$array
828             ];
829             }
830              
831             sub _item_values_array_from_map_by_extracts {
832 12     12   16 my ($array, $accessors, $extracts) = @_;
833              
834             # Custom Schwartzian Transform where each array item is arrayref of:
835             # 0: $array item; rest 1..n : comparison values
836             # The sorter keys are simply indexed into the nth value
837             my $accessor_values = $accessors->map(
838 13     13   69 sub { [ map_by($array, $_) ] }
839 12         61 );
840             return [
841             map { ## no critic
842 12         50 my $item = $_;
  49         51  
843 49         53 my $accessor_index = 0;
844             [
845             $item, # array item to compare
846             map {
847 49         45 my $extract = $_;
  54         49  
848 54         41 my $value = shift @{$accessor_values->[ $accessor_index++ ]};
  54         70  
849              
850 54         52 local $_ = $value;
851 54         56 $extract->();
852             } @$extracts, # comparison values for array item
853             ];
854             }
855             @$array
856             ];
857             }
858              
859             =head2 @array->order(@comparisons = ("str")) : @array | @$array
860              
861             Return C<@array> ordered according to the C<@comparisons>. The default
862             comparison is the same as the default sort, e.g. a normal string
863             comparison of the C<@array> values.
864              
865             If the first item in C<@comparison> ends in a tie, the next one is
866             used, etc.
867              
868             Each I consists of a single I
869             options>, e.g. C/C, C/C, or a subref/regex. See
870             L for details about how these work.
871              
872             Examples:
873              
874             @book_genres->order;
875             @book_genres->order("desc");
876             @book_prices->order([ "num", "desc" ]);
877             @books->order([ sub { $_->{price} }, "desc", "num" ]);
878             @log_lines->order([ num => qr/pid: "(\d+)"/ ]);
879             @books->order(
880             [ sub { $_->{price} }, "desc", "num" ] # first price
881             sub { $_->{name} }, # then name
882             );
883              
884             =cut
885              
886             sub order {
887 14     14   8348 my $array = shift;
888 14         24 my (@comparisons) = @_;
889 14 100       36 @comparisons or @comparisons = ("str");
890              
891 14         34 my ($sorter, $extracts) = _sorter_from_comparisons("order", \@comparisons);
892              
893 12         33 my $item_values_array = _item_values_array_from_array_item_extracts(
894             $array,
895             $extracts,
896             );
897 12         230 my $sorted_array = $sorter->($item_values_array);
898 12         410 my $result = [ map { $_->[0] } @$sorted_array ];
  50         57  
899              
900 12 100       124 return wantarray ? @$result : $result;
901             }
902              
903              
904              
905             =head2 @array->group($value_subref = item) : %key_value | %$key_value
906              
907             Group the C<@array> items into a hashref with the items as keys.
908              
909             The default C<$value_subref> puts each item in the list as the hash
910             value. If the key is repeated, the value is overwritten with the last
911             object.
912              
913             Example:
914              
915             my $title_book = $book_titles->group;
916             # {
917             # "Leviathan Wakes" => "Leviathan Wakes",
918             # "Caliban's War" => "Caliban's War",
919             # "The Tree-Body Problem" => "The Tree-Body Problem",
920             # "The Name of the Wind" => "The Name of the Wind",
921             # },
922              
923             =head3 The $value_subref
924              
925             For simple cases of just grouping a single key to a single value, the
926             C<$value_subref> is straightforward to use.
927              
928             The hash key is the array item. The hash value is whatever is returned
929             from
930              
931             my $new_value = $value_sub->($current_value, $object, $key);
932              
933             =over 4
934              
935             =item
936              
937             C<$current> value is the current hash value for this key (or undef if
938             the first one).
939              
940             =item
941              
942             C<$object> is the current item in the list. The current $_ is also set
943             to this.
944              
945             =item
946              
947             C<$key> is the array item.
948              
949             =back
950              
951             See also: C<-Egroup_by>.
952              
953             =cut
954              
955             sub __core_group {
956 5     5   8 my( $name, $array, $value_sub ) = @_;
957 5 0       12 @$array or return wantarray ? () : { };
    50          
958              
959 5         11 my %key_value;
960 5         11 for my $item (@$array) {
961 21         20 my $key = $item;
962              
963 21         30 my $current_value = $key_value{ $key };
964 21         18 local $_ = $item;
965 21         24 my $new_value = $value_sub->($current_value, $item, $key);
966              
967 21         37 $key_value{ $key } = $new_value;
968             }
969              
970 5 100       43 return wantarray ? %key_value : \%key_value;
971             }
972              
973             sub group {
974 3     3   1273 my $array = shift;
975 3         6 my ($value_sub) = _normalized_accessor_args_subref(@_);
976              
977 3   100 8   16 $value_sub //= sub { $_ };
  8         9  
978 3 50       6 ref($value_sub) eq "CODE"
979             or Carp::croak("group(\$value_sub): \$value_sub ($value_sub) is not a sub ref");
980              
981 3         7 return __core_group("group", $array, $value_sub);
982             }
983              
984              
985              
986             =head2 @array->group_count : %key_count | %$key_count
987              
988             Just like C, but the hash values are the the number of
989             instances each item occurs in the list.
990              
991             Example:
992              
993             $book_genres->group_count;
994             # {
995             # "Sci-fi" => 3,
996             # "Fantasy" => 1,
997             # },
998              
999             There are three books counted for the "Sci-fi" key.
1000              
1001             =cut
1002              
1003             sub group_count {
1004 1     1   2881 my $array = shift;
1005              
1006             my $value_sub = sub {
1007 5   100 5   10 my $count = shift // 0;
1008 5         6 return ++$count;
1009 1         3 };
1010              
1011 1         4 return __core_group("group_count", $array, $value_sub);
1012             }
1013              
1014              
1015              
1016              
1017             =head2 @array->group_array : %key_objects | %$key_objects
1018              
1019             Just like C, but the hash values are arrayrefs containing those
1020             same array items.
1021              
1022             Example:
1023              
1024             $book_genres->group_array;
1025             # {
1026             # "Sci-fi" => [ "Sci-fi", "Sci-fi", "Sci-fi" ],
1027             # "Fantasy" => [ "Fantasy" ],
1028             # },
1029              
1030             The three Sci-fi genres are collected under the Sci-fi key.
1031              
1032             =cut
1033              
1034             sub group_array {
1035 1     1   10 my $array = shift;
1036              
1037             my $value_sub = sub {
1038 4   100 4   11 my $value_array = shift // [];
1039 4         5 push( @$value_array, $_ );
1040 4         4 return $value_array;
1041 1         4 };
1042              
1043 1         4 return __core_group("group_array", $array, $value_sub);
1044             }
1045              
1046              
1047              
1048             =head2 @array->flat() : @array | @$array
1049              
1050             Return a (one level) flattened array, assuming the array items
1051             themselves are array refs. I.e.
1052              
1053             [
1054             [ 1, 2, 3 ],
1055             [ "a", "b" ],
1056             [ [ 1, 2 ], { 3 => 4 } ]
1057             ]->flat
1058              
1059             returns
1060              
1061             [ 1, 2, 3, "a", "b ", [ 1, 2 ], { 3 => 4 } ]
1062              
1063             This is useful if e.g. a C<-Emap_by("some_method")> returns
1064             arrayrefs of objects which you want to do further method calls
1065             on. Example:
1066              
1067             # ->books returns an arrayref of Book objects with a ->title
1068             $authors->map_by("books")->flat->map_by("title")
1069              
1070             Note: This is different from L's C<-Eflatten>,
1071             which reurns a list rather than an array and therefore can't be used
1072             in this way.
1073              
1074             =cut
1075              
1076             sub flat {
1077 2     2   5 my $array = shift;
1078             ###JPL: eval and report error from correct place
1079 2         5 my $result = [ map { @$_ } @$array ];
  3         7  
1080 2 50       10 return wantarray ? @$result : $result;
1081             }
1082              
1083             =head2 @array->to_ref() : $arrayref
1084              
1085             Return the reference to the C<@array>, regardless of context.
1086              
1087             Useful for ensuring the last array method return a reference while in
1088             scalar context. Typically:
1089              
1090             do_stuff(
1091             books => $author->map_by("books")->to_ref,
1092             );
1093              
1094             map_by is called in list context, so without C<-Eto_ref> it would
1095             have return an array, not an arrayref.
1096              
1097             =cut
1098              
1099             sub to_ref {
1100 43     43   1134 my $array = shift;
1101 43         163 return $array;
1102             }
1103              
1104             =head2 @array->to_array() : @array
1105              
1106             Return the C<@array>, regardless of context. This is mostly useful if
1107             called on a ArrayRef at the end of a chain of method calls.
1108              
1109             =cut
1110              
1111             sub to_array {
1112 2     2   2508 my $array = shift;
1113 2         8 return @$array;
1114             }
1115              
1116             =head2 @array->to_hash() : %hash | %$hash
1117              
1118             Return the item pairs in the C<@array> as the key-value pairs of a
1119             C<%hash> (context sensitive).
1120              
1121             Useful if you need to continue calling C<%hash> methods on it.
1122              
1123             Die if there aren't an even number of items in C<@array>.
1124              
1125             =cut
1126              
1127             sub to_hash {
1128 2     2   2326 my $array = shift;
1129 2         5 my $count = @$array;
1130              
1131 2 100       22 $count % 2 and Carp::croak(
1132             "\@array->to_hash on an array with an odd number of elements ($count)",
1133             );
1134              
1135 1         3 my %new_hash = @$array;
1136 1 50       5 return wantarray ? %new_hash : \%new_hash;
1137             }
1138              
1139              
1140              
1141             =head1 METHODS ON ARRAYS CONTAINING OBJECTS/HASHES
1142              
1143             =cut
1144              
1145             *_normalized_accessor_args_predicate
1146             = \&autobox::Transform::_normalized_accessor_args_predicate;
1147             *_normalized_accessor_args_subref
1148             = \&autobox::Transform::_normalized_accessor_args_subref;
1149              
1150             sub __invoke_by {
1151 90     90   105 my $invoke = shift;
1152 90         89 my $array = shift;
1153 90         125 my( $accessor, $args, $subref_name, $subref ) = @_;
1154 90 100       193 defined($accessor) or Carp::croak("->${invoke}_by() missing argument: \$accessor");
1155 89 50       149 @$array or return wantarray ? () : [ ];
    100          
1156              
1157 87   100     259 $args //= [];
1158 87 100       212 if ( ref($array->[0] ) eq "HASH" ) {
1159 8 100 66     47 ( defined($args) && (@$args) ) # defined and isn't empty
1160             and Carp::croak("${invoke}_by([ '$accessor', \@args ]): \@args ($args) only supported for method calls, not hash key access");
1161 6         8 $invoke .= "_key";
1162             }
1163              
1164             ###JPL: move up
1165 85 100       182 ref($args) eq "ARRAY"
1166             or Carp::croak("${invoke}_by([ '$accessor', \@args ]): \@args ($args) is not a list");
1167              
1168 84 100       152 if( $subref_name ) {
1169 25 50       38 ref($subref) eq "CODE"
1170             or Carp::croak("${invoke}_by([ '$accessor', \@args ], \$$subref_name): \$$subref_name ($subref) is not an sub ref");
1171             }
1172              
1173 84         94 my %seen;
1174             my $invoke_sub = {
1175 51     51   60 map => sub { [ CORE::map { $_->$accessor( @$args ) } @$array ] },
  184         3485  
1176 6     6   9 map_key => sub { [ CORE::map { $_->{$accessor} } @$array ] },
  24         40  
1177 13     13   16 filter => sub { [ CORE::grep { $subref->( local $_ = $_->$accessor( @$args ) ) } @$array ] },
  39         602  
1178 0     0   0 filter_key => sub { [ CORE::grep { $subref->( local $_ = $_->{$accessor} ) } @$array ] },
  0         0  
1179 12     12   18 reject => sub { [ CORE::grep { ! $subref->( local $_ = $_->$accessor( @$args ) ) } @$array ] },
  36         776  
1180 0     0   0 reject_key => sub { [ CORE::grep { ! $subref->( local $_ = $_->{$accessor} ) } @$array ] },
  0         0  
1181 2   50 2   5 uniq => sub { [ CORE::grep { ! $seen{ $_->$accessor( @$args ) // "" }++ } @$array ] },
  6         164  
1182 0   0 0   0 uniq_key => sub { [ CORE::grep { ! $seen{ $_->{$accessor} // "" }++ } @$array ] },
  0         0  
1183 84         1102 }->{$invoke};
1184              
1185 84 100       780 my $result = eval { $invoke_sub->() }
  84         130  
1186             or autobox::Transform::throw($@);
1187              
1188 83 100       1378 return wantarray ? @$result : $result;
1189             }
1190              
1191             =head2 @array->map_by($accessor) : @array | @$array
1192              
1193             C<$accessor> is either a string, or an arrayref where the first item
1194             is a string.
1195              
1196             Call the C<$accessor> on each object in C<@array>, or get the hash key
1197             value on each hashref in C<@array>. Like:
1198              
1199             map { $_->$accessor() } @array
1200             # or
1201             map { $_->{$accessor} } @array
1202              
1203             Examples:
1204              
1205             my @author_names = $authors->map_by("name");
1206             my $author_names = @publishers->map_by("authors")->flat->map_by("name");
1207              
1208             Or get the hash key value. Example:
1209              
1210             my @review_scores = $reviews->map_by("score");
1211              
1212             Alternatively for when C<@array> contains objects, the $accessor can
1213             be an arrayref. The first item is the method name, and the rest of the
1214             items are passed as args in the method call. This obviously won't work
1215             when the C<@array> contains hashrefs.
1216              
1217             Examples:
1218              
1219             my @prices_including_tax = $books->map_by([ "price_with_tax", $tax_pct ]);
1220             my $prices_including_tax = $books->map_by([ price_with_tax => $tax_pct ]);
1221              
1222             =cut
1223              
1224             sub map_by {
1225 63     63   64807 my $array = shift;
1226 63         115 my ($accessor, $args) = _normalized_accessor_args_subref(@_);
1227 63         130 return __invoke_by("map", $array, $accessor, $args);
1228             }
1229              
1230              
1231              
1232             =head2 @array->filter_by($accessor, $predicate = *is_true_subref*) : @array | @$array
1233              
1234             C<$accessor> is either a string, or an arrayref where the first item
1235             is a string.
1236              
1237             Call the C<$accessor> on each object in the list, or get the hash key
1238             value on each hashref in the list.
1239              
1240             Example:
1241              
1242             my @prolific_authors = $authors->filter_by("is_prolific");
1243              
1244             Alternatively the C<$accessor> is an arrayref. The first item is the
1245             accessor name, and the rest of the items are passed as args the method
1246             call. This only works when working with objects, not with hashrefs.
1247              
1248             Example:
1249              
1250             my @books_to_charge_for = $books->filter_by([ price_with_tax => $tax_pct ]);
1251              
1252             Use the C<$predicate> to determine whether the value should remain.
1253             C<$predicate> can be a subref, string, undef, regex, or hashref. See
1254             L.
1255              
1256             The default (no C<$predicate>) is a subref which retains true values
1257             in the result C<@array>.
1258              
1259             Examples:
1260              
1261             # Custom predicate subref
1262             my @authors = $authors->filter_by(
1263             "publisher",
1264             sub { $_->name =~ /Orbit/ },
1265             );
1266              
1267             # Call method with args and match a regex
1268             my @authors = $authors->filter_by(
1269             [ publisher_affiliation => "with" ],
1270             qr/Orbit/ },
1271             );
1272              
1273             Note: if you do something complicated with a $predicate subref, it
1274             might be easier and more readable to simply use
1275             C<$array-$filter()>.
1276              
1277              
1278             =head3 Alias
1279              
1280             C is an alias for C. Unlike C vs C,
1281             this one works exaclty the same way.
1282              
1283             =cut
1284              
1285             sub filter_by {
1286 13     13   25400 my $array = shift;
1287 13         25 my ($accessor, $args, $predicate) = _normalized_accessor_args_predicate(@_);
1288             my $subref = autobox::Transform::_predicate(
1289             "filter_by",
1290             $predicate,
1291 15     15   397 sub { !! $_ },
1292 13         42 );
1293             # filter_by $value, if passed the method value must match the value?
1294 13         36 return __invoke_by(
1295             "filter",
1296             $array,
1297             $accessor,
1298             $args,
1299             filter_subref => $subref,
1300             );
1301             }
1302              
1303             *grep_by = \&filter_by;
1304              
1305              
1306              
1307             =head2 @array->reject_by($accessor, $predicate = *is_false_subref*) : @array | @$array
1308              
1309             C is the same as L>, except it I
1310             items that matches the $predicate.
1311              
1312             Example:
1313              
1314             my @unproductive_authors = $authors->reject_by("is_prolific");
1315              
1316             The default (no $predicate) is a subref which I true
1317             values in the result C<@array>.
1318              
1319             =cut
1320              
1321             sub reject_by {
1322 12     12   29578 my $array = shift;
1323 12         29 my ($accessor, $args, $predicate) = _normalized_accessor_args_predicate(@_);
1324             my $subref = autobox::Transform::_predicate(
1325             "reject_by",
1326             $predicate,
1327 12     12   391 sub { !! $_ },
1328 12         47 );
1329             # filter_by $value, if passed the method value must match the value?
1330 12         37 return __invoke_by(
1331             "reject",
1332             $array,
1333             $accessor,
1334             $args,
1335             reject_subref => $subref,
1336             );
1337             }
1338              
1339              
1340              
1341             =head2 @array->uniq_by($accessor) : @array | @$array
1342              
1343             C<$accessor> is either a string, or an arrayref where the first item
1344             is a string.
1345              
1346             Call the $C on each object in the list, or get the hash key
1347             value on each hashref in the list. Return list of items which have a
1348             unique set of return values. The order is preserved. On duplicates,
1349             keep the first occurrence.
1350              
1351             Examples:
1352              
1353             # You have gathered multiple Author objects with duplicate ids
1354             my @authors = $authors->uniq_by("author_id");
1355              
1356             Alternatively the C<$accessor> is an arrayref. The first item is the
1357             accessor name, and the rest of the items are passed as args the method
1358             call. This only works when working with objects, not with hashrefs.
1359              
1360             Examples:
1361              
1362             my @example_book_at_price_point = $books->uniq_by(
1363             [ price_with_tax => $tax_pct ],
1364             );
1365              
1366             =cut
1367              
1368             sub uniq_by {
1369 2     2   7465 my $array = shift;
1370 2         7 my ($accessor, $args) = _normalized_accessor_args_subref(@_);
1371 2         7 return __invoke_by("uniq", $array, $accessor, $args);
1372             }
1373              
1374             =head2 @array->order_by(@accessor_comparison_pairs) : @array | @$array
1375              
1376             Return C<@array> ordered according to the
1377             C<@accessor_comparison_pairs>.
1378              
1379             The comparison value comes from an initial
1380             C<@array->map_by($accessor)> for each accessor-comparison pair. It is
1381             important that the $accessor call returns exactly a single scalar that
1382             can be compared with the other values.
1383              
1384             It then works just like with C<-Eorder>.
1385              
1386             $books->order_by("name"); # default order, i.e. "str"
1387             $books->order_by(price => "num");
1388             $books->order_by(price => [ "num", "desc" ]);
1389              
1390             As with C, if the $accessor is used on an object, the method
1391             call can include arguments.
1392              
1393             $books->order_by([ price_wih_tax => $tax_rate ] => "num");
1394              
1395             Just like with C, the value returned by the accessor can be
1396             transformed using a sub, or be matched against a regex.
1397              
1398             $books->order_by(price => [ num => sub { int($_) } ]);
1399              
1400             # Ignore leading "The" in book titles by optionally matching it
1401             # with a non-capturing group and the rest with a capturing group
1402             # paren
1403             $books->order_by( title => qr/^ (?: The \s+ )? (.+) /x );
1404              
1405             If a comparison is missing for the last pair, the default is a normal
1406             C comparison.
1407              
1408             $books->order_by("name"); # default "str"
1409              
1410             If the first comparison ends in a tie, the next pair is used,
1411             etc. Note that in order to provide accessor-comparison pairs, it's
1412             often necessary to provide a default "str" comparison just to make it
1413             a pair.
1414              
1415             $books->order_by(
1416             author => "str",
1417             price => [ "num", "desc" ],
1418             );
1419              
1420             =cut
1421              
1422             sub order_by {
1423 15     15   30224 my $array = shift;
1424 15         24 my (@accessors_and_comparisons) = @_;
1425              
1426 15         17 my $i = 0;
1427             my ($accessors, $comparisons) = List::MoreUtils::part
1428 27     27   62 { $i++ %2 }
1429 15         68 @accessors_and_comparisons;
1430 15   100     57 $accessors ||= [];
1431 15   100     30 $comparisons ||= [];
1432 15 100       37 @$accessors or Carp::croak("->order_by() missing argument: \$accessor");
1433             # Default comparison
1434 14 100       23 @$accessors == @$comparisons or push(@$comparisons, "str");
1435              
1436 14         22 my ($sorter, $extracts) = _sorter_from_comparisons("order_by", $comparisons);
1437              
1438 12         27 my $item_values_array = _item_values_array_from_map_by_extracts(
1439             $array,
1440             $accessors,
1441             $extracts,
1442             );
1443 12         181 my $sorted_array = $sorter->($item_values_array);
1444 12         390 my $result = [ map { $_->[0] } @$sorted_array ];
  49         52  
1445              
1446 12 50       111 return wantarray ? @$result : $result;
1447             }
1448              
1449             =head2 @array->group_by($accessor, $value_subref = object) : %key_value | %$key_value
1450              
1451             C<$accessor> is either a string, or an arrayref where the first item
1452             is a string.
1453              
1454             Call C<-E$accessor> on each object in the array, or get the hash
1455             key for each hashref in the array (just like C<-Emap_by>) and
1456             group the values as keys in a hashref.
1457              
1458             The default C<$value_subref> puts each object in the list as the hash
1459             value. If the key is repeated, the value is overwritten with the last
1460             object.
1461              
1462             Example:
1463              
1464             my $title_book = $books->group_by("title");
1465             # {
1466             # "Leviathan Wakes" => $books->[0],
1467             # "Caliban's War" => $books->[1],
1468             # "The Tree-Body Problem" => $books->[2],
1469             # "The Name of the Wind" => $books->[3],
1470             # },
1471              
1472             =head3 The $value_subref
1473              
1474             For simple cases of just grouping a single key to a single value, the
1475             C<$value_subref> is straightforward to use.
1476              
1477             The hash key is whatever is returned from C<$object-E$accessor>.
1478              
1479             The hash value is whatever is returned from
1480              
1481             my $new_value = $value_sub->($current_value, $object, $key);
1482              
1483             =over 4
1484              
1485             =item
1486              
1487             C<$current> value is the current hash value for this key (or undef if the first one).
1488              
1489             =item
1490              
1491             C<$object> is the current item in the list. The current $_ is also set to this.
1492              
1493             =item
1494              
1495             C<$key> is the key returned by $object->$accessor(@$args)
1496              
1497             =back
1498              
1499             A simple example would be to group by the accessor, but instead of the
1500             object used as the value you want to look up an attribute on each
1501             object:
1502              
1503             my $book_id__author = $books->group_by("id", sub { $_->author });
1504             # keys: book id; values: author
1505              
1506             If you want to create an aggregate value the C<$value_subref> can be a
1507             bit tricky to use, so the most common thing would probably be to use
1508             one of the more specific group_by-methods (see below). It should be
1509             capable enough to achieve what you need though.
1510              
1511             =cut
1512              
1513             sub __core_group_by {
1514 20     20   39 my( $name, $array, $accessor, $args, $value_sub ) = @_;
1515 20 100       50 $accessor or Carp::croak("->$name() missing argument: \$accessor");
1516 19 0       56 @$array or return wantarray ? () : { };
    50          
1517              
1518 19         50 my $invoke = do {
1519             # Hash key
1520 19 100       59 if ( ref($array->[0] ) eq "HASH" ) {
1521 2 100       23 defined($args)
1522             and Carp::croak("$name([ '$accessor', \@args ]): \@args ($args) only supported for method calls, not hash key access.");
1523 1         3 "key";
1524             }
1525             # Method
1526             else {
1527 17   100     58 $args //= [];
1528 17 100       49 ref($args) eq "ARRAY"
1529             or Carp::croak("$name([ '$accessor', \@args ], \$value_sub): \@args ($args) is not a list");
1530 15         25 "method";
1531             }
1532             };
1533              
1534             my $invoke_sub = {
1535 55     55   1089 method => sub { [ shift->$accessor(@$args) ] },
1536 3     3   8 key => sub { [ shift->{$accessor} ] },
1537 16         83 }->{$invoke};
1538              
1539 16         51 my %key_value;
1540 16         33 for my $object (@$array) {
1541 58 100       61 my $key_ref = eval { $invoke_sub->($object) }
  58         63  
1542             or autobox::Transform::throw($@);
1543 57         653 my $key = $key_ref->[0];
1544              
1545 57         61 my $current_value = $key_value{ $key };
1546 57         54 local $_ = $object;
1547 57         70 my $new_value = $value_sub->($current_value, $object, $key);
1548              
1549 57         118 $key_value{ $key } = $new_value;
1550             }
1551              
1552 15 100       127 return wantarray ? %key_value : \%key_value;
1553             }
1554              
1555             sub group_by {
1556 10     10   37235 my $array = shift;
1557 10         23 my ($accessor, $args, $value_sub) = _normalized_accessor_args_subref(@_);
1558              
1559 10   100 15   51 $value_sub //= sub { $_ };
  15         15  
1560 10 50       17 ref($value_sub) eq "CODE"
1561             or Carp::croak("group_by([ '$accessor', \@args ], \$value_sub): \$value_sub ($value_sub) is not a sub ref");
1562              
1563 10         20 return __core_group_by("group_by", $array, $accessor, $args, $value_sub);
1564             }
1565              
1566             =head2 @array->group_by_count($accessor) : %key_count | %$key_count
1567              
1568             C<$accessor> is either a string, or an arrayref where the first item
1569             is a string.
1570              
1571             Just like C, but the hash values are the the number of
1572             instances each $accessor value occurs in the list.
1573              
1574             Example:
1575              
1576             $books->group_by_count("genre"),
1577             # {
1578             # "Sci-fi" => 3,
1579             # "Fantasy" => 1,
1580             # },
1581              
1582             C<$book-Egenre()> returns the genre string. There are three books
1583             counted for the "Sci-fi" key.
1584              
1585             =cut
1586              
1587             sub group_by_count {
1588 8     8   15796 my $array = shift;
1589 8         24 my ($accessor, $args) = _normalized_accessor_args_subref(@_);
1590              
1591             my $value_sub = sub {
1592 26   100 26   54 my $count = shift // 0; return ++$count;
  26         29  
1593 8         28 };
1594              
1595 8         23 return __core_group_by("group_by_count", $array, $accessor, $args, $value_sub);
1596             }
1597              
1598             =head2 @array->group_by_array($accessor) : %key_objects | %$key_objects
1599              
1600             C<$accessor> is either a string, or an arrayref where the first item
1601             is a string.
1602              
1603             Just like C, but the hash values are arrayrefs containing
1604             the objects which has each $accessor value.
1605              
1606             Example:
1607              
1608             my $genre_books = $books->group_by_array("genre");
1609             # {
1610             # "Sci-fi" => [ $sf_book_1, $sf_book_2, $sf_book_3 ],
1611             # "Fantasy" => [ $fantasy_book_1 ],
1612             # },
1613              
1614             $book->genre() returns the genre string. The three Sci-fi book objects
1615             are collected under the Sci-fi key.
1616              
1617             =cut
1618              
1619             sub group_by_array {
1620 2     2   2388 my $array = shift;
1621 2         6 my ($accessor, $args) = _normalized_accessor_args_subref(@_);
1622              
1623             my $value_sub = sub {
1624 8   100 8   18 my $array = shift // [];
1625 8         12 push( @$array, $_ );
1626 8         7 return $array;
1627 2         9 };
1628              
1629 2         5 return __core_group_by("group_by_array", $array, $accessor, $args, $value_sub);
1630             }
1631              
1632              
1633              
1634             =head1 METHODS ON HASHES
1635              
1636             =cut
1637              
1638             package # hide from PAUSE
1639             autobox::Transform::Hash;
1640              
1641 18     18   153 use autobox::Core;
  18         44  
  18         142  
1642              
1643              
1644              
1645             sub key_value {
1646 11     11   1010 my $hash = shift;
1647 11         15 my( $original_key, $new_key ) = @_;
1648 11   66     37 $new_key //= $original_key;
1649 11         20 my %key_value = ( $new_key => $hash->{$original_key} );
1650 11 100       71 return wantarray ? %key_value : \%key_value;
1651             }
1652              
1653             sub __core_key_value_if {
1654 13     13   15 my $hash = shift;
1655 13         20 my( $comparison_sub, $original_key, $new_key ) = @_;
1656 13 50       17 $comparison_sub->($hash, $original_key) or return wantarray ? () : {};
    100          
1657 7         10 return key_value($hash, $original_key, $new_key)
1658             }
1659              
1660             sub key_value_if_exists {
1661 4     4   2626 my $hash = shift;
1662 4         6 my( $original_key, $new_key ) = @_;
1663             return __core_key_value_if(
1664             $hash,
1665 4     4   21 sub { !! exists shift->{ shift() } },
1666 4         18 $original_key,
1667             $new_key
1668             );
1669             }
1670              
1671             sub key_value_if_true {
1672 5     5   2314 my $hash = shift;
1673 5         7 my( $original_key, $new_key ) = @_;
1674             return __core_key_value_if(
1675             $hash,
1676 5     5   27 sub { !! shift->{ shift() } },
1677 5         19 $original_key,
1678             $new_key
1679             );
1680             }
1681              
1682             sub key_value_if_defined {
1683 4     4   2481 my $hash = shift;
1684 4         5 my( $original_key, $new_key ) = @_;
1685             return __core_key_value_if(
1686             $hash,
1687 4     4   20 sub { defined( shift->{ shift() } ) },
1688 4         15 $original_key,
1689             $new_key
1690             );
1691             }
1692              
1693              
1694              
1695             =head2 %hash->map_each($key_value_subref) : %new_hash | %$new_hash
1696              
1697             Map each key-value pair in the hash using the
1698             C<$key_value_subref>. Similar to how to how map transforms a list into
1699             another list, map_each transforms a hash into another hash.
1700              
1701             C<$key_value_subref-E($key, $value)> is called for each pair (with
1702             $_ set to the value).
1703              
1704             The subref should return an even-numbered list with zero or more
1705             key-value pairs which will make up the C<%new_hash>. Typically two
1706             items are returned in the list (the key and the value).
1707              
1708             =head3 Example
1709              
1710             { a => 1, b => 2 }->map_each(sub { "$_[0]$_[0]" => $_ * 2 });
1711             # Returns { aa => 2, bb => 4 }
1712              
1713             =cut
1714              
1715             sub map_each {
1716 7     7   10575 my $hash = shift;
1717 7         10 my ($key_value_subref) = @_;
1718 7   100     17 $key_value_subref //= "";
1719 7 100       37 ref($key_value_subref) eq "CODE"
1720             or Carp::croak("map_each(\$key_value_subref): \$key_value_subref ($key_value_subref) is not a sub ref");
1721             my $new_hash = {
1722             map { ## no critic
1723 5         12 my $key = $_;
  12         13  
1724 12         15 my $value = $hash->{$key};
1725             {
1726 12         8 local $_ = $value;
  12         11  
1727 12         18 my (@new_key_value) = $key_value_subref->($key, $value);
1728 12 100       74 (@new_key_value % 2) and Carp::croak("map_each \$key_value_subref returned odd number of keys/values");
1729 10         32 @new_key_value;
1730             }
1731             }
1732             keys %$hash,
1733             };
1734              
1735 3 100       28 return wantarray ? %$new_hash : $new_hash;
1736             }
1737              
1738             =head2 %hash->map_each_value($value_subref) : %new_hash | %$new_hash
1739              
1740             Map each value in the hash using the C<$value_subref>, but keep the
1741             keys the same.
1742              
1743             C<$value_subref-E($key, $value)> is called for each pair (with
1744             C<$_> set to the value).
1745              
1746             The subref should return a single value for each key which will make
1747             up the C<%new_hash> (with the same keys but with new mapped values).
1748              
1749             =head3 Example
1750              
1751             { a => 1, b => 2 }->map_each_value(sub { $_ * 2 });
1752             # Returns { a => 2, b => 4 }
1753              
1754             =cut
1755              
1756             sub map_each_value {
1757 5     5   10197 my $hash = shift;
1758 5         9 my ($value_subref) = @_;
1759 5   100     24 $value_subref //= "";
1760 5 100       34 ref($value_subref) eq "CODE"
1761             or Carp::croak("map_each_value(\$value_subref): \$value_subref ($value_subref) is not a sub ref");
1762             my $new_hash = {
1763             map { ## no critic
1764 3         9 my $key = $_;
  7         8  
1765 7         8 my $value = $hash->{$key};
1766             {
1767 7         4 local $_ = $value;
  7         15  
1768 7         24 my @new_values = $value_subref->($key, $value);
1769 7 100       39 @new_values > 1 and Carp::croak(
1770             "map_each_value \$value_subref returned multiple values. "
1771             . "You can not assign a list to the value of hash key ($key). "
1772             . "Did you mean to return an arrayref?",
1773             );
1774 6         16 $key => @new_values;
1775             }
1776             }
1777             keys %$hash,
1778             };
1779              
1780 2 100       18 return wantarray ? %$new_hash : $new_hash;
1781             }
1782              
1783             =head2 %hash->map_each_to_array($item_subref) : @new_array | @$new_array
1784              
1785             Map each key-value pair in the hash into a list using the
1786             C<$item_subref>.
1787              
1788             C<$item_subref-E($key, $value)> is called for each pair (with
1789             C<$_> set to the value) in key order.
1790              
1791             The subref should return zero or more list items which will make up
1792             the C<@new_array>. Typically one item is returned.
1793              
1794             =head3 Example
1795              
1796             { a => 1, b => 2 }->map_each_to_array(sub { "$_[0]-$_" });
1797             # Returns [ "a-1", "b-2" ]
1798              
1799             =cut
1800              
1801             sub map_each_to_array {
1802 6     6   10235 my $hash = shift;
1803 6         9 my ($array_item_subref) = @_;
1804 6   100     24 $array_item_subref //= "";
1805 6 100       40 ref($array_item_subref) eq "CODE"
1806             or Carp::croak("map_each_to_array(\$array_item_subref): \$array_item_subref ($array_item_subref) is not a sub ref");
1807             my $new_array = [
1808             map { ## no critic
1809 4         18 my $key = $_;
  13         35  
1810 13         13 my $value = $hash->{$key};
1811             {
1812 13         12 local $_ = $value;
  13         13  
1813 13         17 $array_item_subref->($key, $value);
1814             }
1815             }
1816             sort keys %$hash,
1817             ];
1818              
1819 4 100       35 return wantarray ? @$new_array : $new_array;
1820             }
1821              
1822              
1823             =head2 %hash->filter_each($predicate = *is_true_subref*) : @hash | @$hash
1824              
1825             Return a C<%hash> with values for which C<$predicate> yields a true
1826             value.
1827              
1828             C<$predicate> can be a subref, string, undef, regex, or hashref. See
1829             L.
1830              
1831             The default (no $predicate) is a subref which retains true values in
1832             the C<%hash>.
1833              
1834             If the $predicate is a subref, C<$predicate-E($key, $value)> is
1835             called for each pair (with C<$_> set to the value).
1836              
1837             The subref should return a true value to retain the key-value pair in
1838             the result C<%hash>.
1839              
1840             =head3 Examples
1841              
1842             { a => 1, b => 2 }->filter_each(sub { $_ == 2 });
1843             # Returns { b => 2 }
1844              
1845             $book_author->filter_each(sub { $_->name =~ /Corey/ });
1846              
1847             =cut
1848              
1849             sub filter_each {
1850 12     12   10557 my $hash = shift;
1851 12         15 my ($predicate) = @_;
1852             my $subref = autobox::Transform::_predicate(
1853             "filter_each",
1854             $predicate,
1855 7     7   18 sub { !! $_ }, # true?
1856 12         32 );
1857              
1858             my $new_hash = {
1859             map { ## no critic
1860 12         43 my $key = $_;
  41         66  
1861 41         42 my $value = $hash->{$key};
1862             {
1863 41         32 local $_ = $value;
  41         35  
1864 41 100       52 $subref->($key, $value)
1865             ? ( $key => $value )
1866             : ();
1867             }
1868             }
1869             keys %$hash,
1870             };
1871              
1872 12 50       78 return wantarray ? %$new_hash : $new_hash;
1873             }
1874             {
1875 18     18   25321 no warnings "once";
  18         34  
  18         1673  
1876             *grep_each = \&filter_each;
1877             }
1878              
1879             sub filter_each_defined {
1880 2     2   2293 my $hash = shift;
1881 2     6   7 return &filter_each($hash, sub { defined($_) });
  6         17  
1882             }
1883             {
1884 18     18   135 no warnings "once";
  18         44  
  18         6312  
1885             *grep_each_defined = \&filter_each_defined;
1886             }
1887              
1888              
1889              
1890             =head2 %hash->reject_each($predicate = *is_false_subref*) : @hash | @$hash
1891              
1892             C is the same as L>, except it I
1893             items that matches the $predicate.
1894              
1895             Examples:
1896              
1897             { a => 1, b => 2 }->reject_each(sub { $_ == 2 });
1898             # Returns { a => 1 }
1899              
1900             The default (no $predicate) is a subref which I true
1901             values in the C<%hash>.
1902              
1903             =cut
1904              
1905             sub reject_each {
1906 10     10   10234 my $hash = shift;
1907 10         16 my ($predicate) = @_;
1908             my $subref = autobox::Transform::_predicate(
1909             "reject_each",
1910             $predicate,
1911 4     4   12 sub { !! $_ }, # true?
1912 10         47 );
1913              
1914             my $new_hash = {
1915             map { ## no critic
1916 10         35 my $key = $_;
  35         66  
1917 35         36 my $value = $hash->{$key};
1918             {
1919 35         29 local $_ = $value;
  35         27  
1920 35 100       46 ( ! $subref->($key, $value) )
1921             ? ( $key => $value )
1922             : ();
1923             }
1924             }
1925             keys %$hash,
1926             };
1927              
1928 10 50       96 return wantarray ? %$new_hash : $new_hash;
1929             }
1930              
1931             sub reject_each_defined {
1932 1     1   2679 my $hash = shift;
1933 1     3   4 return &reject_each($hash, sub { defined($_) });
  3         6  
1934             }
1935              
1936              
1937              
1938             =head2 %hash->to_ref() : $hashref
1939              
1940             Return the reference to the C<%hash>, regardless of context.
1941              
1942             Useful for ensuring the last hash method return a reference while in
1943             scalar context. Typically:
1944              
1945             do_stuff(
1946             genre_count => $books->group_by_count("genre")->to_ref,
1947             );
1948              
1949             =cut
1950              
1951             sub to_ref {
1952 5     5   2573 my $hash = shift;
1953 5         20 return $hash;
1954             }
1955              
1956             =head2 %hash->to_hash() : %hash
1957              
1958             Return the C<%hash>, regardless of context. This is mostly useful if
1959             called on a HashRef at the end of a chain of method calls.
1960              
1961             =cut
1962              
1963             sub to_hash {
1964 2     2   2268 my $hash = shift;
1965 2         10 return %$hash;
1966             }
1967              
1968             =head2 %hash->to_array() : @array | @$array
1969              
1970             Return the key-value pairs of the C<%hash> as an C<@array>, ordered by
1971             the keys.
1972              
1973             Useful if you need to continue calling C<@array> methods on it.
1974              
1975             =cut
1976              
1977             sub to_array {
1978 1     1   2386 my $hash = shift;
1979 1     3   6 my @new_array = map_each_to_array($hash, sub { shift() => $_ });
  3         7  
1980 1 50       8 return wantarray ? @new_array : \@new_array;
1981             }
1982              
1983              
1984              
1985             =head1 AUTOBOX AND VANILLA PERL
1986              
1987              
1988             =head2 Raison d'etre
1989              
1990             L is awesome, for a variety of reasons.
1991              
1992             =over 4
1993              
1994             =item
1995              
1996             It cuts down on dereferencing punctuation clutter, both by using
1997             methods on references and by using ->elements to deref arrayrefs.
1998              
1999             =item
2000              
2001             It makes map and grep transforms read in the same direction it's
2002             executed.
2003              
2004             =item
2005              
2006             It makes it easier to write those things in a natural order. No need
2007             to move the cursor around a lot just to fix dereferencing, order of
2008             operations etc.
2009              
2010             =back
2011              
2012             On top of this, L provides a few higher level
2013             methods for mapping, filtering and sorting common cases which are easier
2014             to read and write.
2015              
2016             Since they are at a slightly higher semantic level, once you know them
2017             they also provide a more specific meaning than just C or C.
2018              
2019             (Compare the difference between seeing a C and seeing a
2020             C loop. Just seeing the word C hints at what type of
2021             thing is going on here: transforming a list into another list).
2022              
2023             The methods of C are not suitable for all cases,
2024             but when used appropriately they will lead to much more clear,
2025             succinct and direct code, especially in conjunction with
2026             C.
2027              
2028              
2029             =head2 Code Comparison
2030              
2031             These examples are only for when there's a straightforward and simple
2032             Perl equivalent.
2033              
2034             ### map_by - method call: $books are Book objects
2035             my @genres = map { $_->genre() } @$books;
2036             my @genres = $books->map_by("genre");
2037              
2038             my $genres = [ map { $_->genre() } @$books ];
2039             my $genres = $books->map_by("genre");
2040              
2041             # With sum from autobox::Core / List::AllUtils
2042             my $book_order_total = sum(
2043             map { $_->price_with_tax($tax_pct) } @{$order->books}
2044             );
2045             my $book_order_total = $order->books
2046             ->map_by([ price_with_tax => $tax_pct ])->sum;
2047              
2048             ### map_by - hash key: $books are book hashrefs
2049             my @genres = map { $_->{genre} } @$books;
2050             my @genres = $books->map_by("genre");
2051              
2052              
2053              
2054             ### filter_by - method call: $books are Book objects
2055             my $sold_out_books = [ grep { $_->is_in_stock } @$books ];
2056             my $sold_out_books = $books->filter_by("is_in_stock");
2057             my $sold_out_books = $books->grep_by("is_in_stock");
2058              
2059             my $books_in_library = [ grep { $_->is_in_library($library) } @$books ];
2060             my $books_in_library = $books->filter_by([ is_in_library => $library ]);
2061              
2062             ### reject_by - hash key: $books are book hashrefs
2063             my $sold_out_books = [ grep { ! $_->{is_in_stock} } @$books ];
2064             my $sold_out_books = $books->reject_by("is_in_stock");
2065              
2066              
2067              
2068             ### uniq_by - method call: $books are Book objects
2069             my %seen; my $distinct_books = [ grep { ! %seen{ $_->id // "" }++ } @$books ];
2070             my $distinct_books = $books->uniq_by("id");
2071              
2072             ### uniq_by - hash key: $books are book hashrefs
2073             my %seen; my $distinct_books = [ grep { ! %seen{ $_->{id} // "" }++ } @$books ];
2074             my $distinct_books = $books->uniq_by("id");
2075              
2076              
2077             #### flat - $author->books returns an arrayref of Books
2078             my $author_books = [ map { @{$_->books} } @$authors ];
2079             my $author_books = $authors->map_by("books")->flat;
2080              
2081              
2082              
2083             =head1 DEVELOPMENT
2084              
2085             =head2 Author
2086              
2087             Johan Lindstrom, C<< >>
2088              
2089              
2090             =head2 Source code
2091              
2092             L
2093              
2094              
2095             =head2 Bug reports
2096              
2097             Please report any bugs or feature requests on GitHub:
2098              
2099             L.
2100              
2101              
2102              
2103             =head1 COPYRIGHT & LICENSE
2104              
2105             Copyright 2016- Johan Lindstrom, All Rights Reserved.
2106              
2107             This program is free software; you can redistribute it and/or modify it
2108             under the same terms as Perl itself.
2109              
2110             =cut
2111              
2112             1;