1package autobox::Transform; 2 3use strict; 4use warnings; 5use 5.010; 6use parent qw/autobox/; 7 8our $VERSION = "1.035"; 9 10=head1 NAME 11 12autobox::Transform - Autobox methods to transform Arrays and Hashes 13 14=head1 CONTEXT 15 16L<autobox> provides the ability to call methods on native types, 17e.g. strings, arrays, and hashes as if they were objects. 18 19L<autobox::Core> provides the basic methods for Perl core functions 20like C<uc>, C<map>, and C<grep>. 21 22This module, C<autobox::Transform>, provides higher level and more 23specific methods to transform and manipulate arrays and hashes, in 24particular 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 214use Carp; 215 216sub import { 217 my $self = shift; 218 $self->SUPER::import( ARRAY => "autobox::Transform::Array" ); 219 $self->SUPER::import( HASH => "autobox::Transform::Hash" ); 220} 221 222sub throw { 223 my ($error) = @_; 224 ###JPL: remove lib 225 $error =~ s/ at [\\\/\w ]*?\bautobox.Transform\.pm line \d+\.\n?$//; 226 local $Carp::CarpLevel = 1; 227 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 234sub _normalized_accessor_args_subref { 235 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 if(ref($args) eq "CODE") { 245 $subref = $args; # Move down one step 246 $args = undef; 247 } 248 if(ref($accessor) eq "ARRAY") { 249 ($accessor, my @args) = @$accessor; 250 $args = \@args; 251 } 252 253 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 261sub _normalized_accessor_args_predicate { 262 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 if(defined($args) && ref($args) ne "ARRAY") { 271 $subref = $args; # Move down one step 272 $args = undef; 273 } 274 if(ref($accessor) eq "ARRAY") { 275 ($accessor, my @args) = @$accessor; 276 $args = \@args; 277 } 278 279 return ($accessor, $args, $subref); 280} 281 282 283 284sub _predicate { 285 my ($name, $predicate, $default_predicate) = @_; 286 287 # No predicate, use default is_true 288 defined($predicate) or return $default_predicate; 289 290 # scalar, do string eq 291 my $type = ref($predicate) or return sub { $predicate eq $_ }; 292 293 $type eq "CODE" and return $predicate; 294 $type eq "Regexp" and return sub { $_ =~ $predicate }; 295 $type eq "HASH" and return sub { exists $predicate->{ $_ } }; 296 297 # Invalid predicate 298 Carp::croak("->$name() \$predicate: ($predicate) is not one of: subref, string, regex"); 299} 300 301 302 303=head1 DESCRIPTION 304 305C<autobox::Transform> provides high level autobox methods you can call 306on arrays, arrayrefs, hashes and hashrefs. 307 308 309=head2 Transforming lists of objects vs list of hashrefs 310 311C<map_by>, C<filter_by> C<order_by> etc. (all methods named C<*_by>) 312work with sets of hashrefs or objects. 313 314These methods are called the same way regardless of whether the array 315contains objects or hashrefs. The items in the list must be either all 316objects or all hashrefs. 317 318If the array contains hashrefs, the hash key is looked up on each 319item. 320 321If 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 326For method calls, it's possible to provide arguments to the method. 327 328Consider C<map_by>: 329 330 $array->map_by($accessor) 331 332If 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 338If the $accessor is an arrayref, the first item is the method name, 339and 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 349There are several methods that filter items, 350e.g. C<@array-E<gt>filter> (duh), C<@array-E<gt>filter_by>, and 351C<%hash-E<gt>filter_each>. These methods take a C<$predicate> argument 352to determine which items to retain or filter out. 353 354The C<reject> family of methods do the opposite, and I<filter out> 355items that match the predicate, i.e. the opposite of the filter 356methods. 357 358If $predicate is an I<unblessed scalar>, it is compared to each value 359with C<string eq>. 360 361 $books->filter_by("author", "James A. Corey"); 362 363If $predicate is a I<regex>, it is compared to each value with C<=~>. 364 365 $books->reject_by("author", qr/Corey/); 366 367If $predicate is a I<hashref>, values in @array are retained if the 368$predicate hash key C<exists> (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 378If $predicate is a I<subref>, the subref is called for each value to 379check whether this item should remain in the list. 380 381The $predicate subref should return a true value to remain. C<$_> is 382set to the current $value. 383 384 $authors->filter_by(publisher => sub { $_->name =~ /Orbit/ }); 385 386 387=head2 Sorting using order and order_by 388 389Let's first compare how sorting is done with Perl's C<sort> and 390autobox::Transform's C<order>/C<order_by>. 391 392 393=head3 Sorting with sort 394 395=over 4 396 397=item * 398 399provide a sub that returns the comparison outcome of two values: C<$a> 400and C<$b> 401 402=item * 403 404in 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, 416something 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 424Provide order options for how one value should be compared with the others: 425 426=over 8 427 428=item * 429 430how to compare (C<cmp> or C<<=E<gt>>) 431 432=item * 433 434which direction to sort (C<asc>ending or C<desc>ending) 435 436=item * 437 438which value to compare, using a regex or subref, e.g. by C<uc($_)> 439 440=back 441 442=item * 443 444In 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 464If there's only one option for a comparison (e.g. C<num>), provide a 465single option (string/regex/subref) value. If there are many options, 466provide them in an arrayref in any order. 467 468=head3 Comparison operator 469 470=over 4 471 472=item * 473 474C<"str"> (cmp) - default 475 476=item * 477 478C<"num"> (<=>) 479 480=back 481 482 483=head3 Sort order 484 485=over 4 486 487=item * 488 489C<"asc"> (ascending) - default 490 491=item * 492 493C<"desc"> (descending) 494 495=back 496 497 498=head3 The value to compare 499 500=over 4 501 502=item * 503 504A subref - default is: C<sub { $_ }> 505 506=over 8 507 508=item * 509 510The return value is used in the comparison 511 512=back 513 514=item * 515 516A regex, e.g. C<qr/id: (\d+)/> 517 518=over 8 519 520=item * 521 522The value of C<join("", @captured_groups)> 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 559When 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 598Almost all of the methods are context sensitive, i.e. they return a 599list in list context and an arrayref in scalar context, just like 600L<autobox::Core>. 601 602B<Beware>: I<you might be in list context when you need an arrayref.> 603 604When in doubt, assume they work like C<map> and C<grep> (i.e. return a 605list), and convert the return value to references where you might have 606an 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 638package # hide from PAUSE 639 autobox::Transform::Array; 640 641use autobox::Core; 642use Sort::Maker (); 643use List::MoreUtils (); 644 645 646 647=head2 @array->filter($predicate = *is_true_subref*) : @array | @$array 648 649Similar to Perl's C<grep>, 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 653L</Filter predicates>. 654 655The default (no C<$predicate>) is a subref which retains true values 656in 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 669L<autobox::Core>'s C<grep> method takes a subref, just like this 670method. C<filter> also supports the other predicate types, like 671string, regex, etc. 672 673 674=cut 675 676sub filter { 677 my $array = shift; 678 my ($predicate) = @_; 679 my $subref = autobox::Transform::_predicate( 680 "filter", 681 $predicate, 682 sub { !! $_ }, 683 ); 684 685 my $result = eval { 686 [ CORE::grep { $subref->( $_ ) } @$array ] 687 } or autobox::Transform::throw($@); 688 689 return wantarray ? @$result : $result; 690} 691 692=head2 @array->reject($predicate = *is_false_subref*) : @array | @$array 693 694Similar to the Unix command C<grep -v>, return an @array with values 695for which C<$predicate> yields a I<false> value. 696 697$predicate can be a subref, string, undef, regex, or hashref. See 698L</Filter predicates>. 699 700The default (no $predicate) is a subref which I<filters out> true 701values in the C<@array>. 702 703Examples: 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 713sub reject { 714 my $array = shift; 715 my ($predicate) = @_; 716 my $subref = autobox::Transform::_predicate( 717 "reject", 718 $predicate, 719 sub { !! $_ }, 720 ); 721 722 my $result = eval { 723 [ CORE::grep { ! $subref->( $_ ) } @$array ] 724 } or autobox::Transform::throw($@); 725 726 return wantarray ? @$result : $result; 727} 728 729 730 731my $option__group = { 732 str => "operator", 733 num => "operator", 734 asc => "direction", 735 desc => "direction", 736}; 737sub _group__value_from_order_options { 738 my ($method_name, $options) = @_; 739 my $group__value = {}; 740 for my $option (grep { $_ } @$options) { 741 my $group; 742 743 my $ref_option = ref($option); 744 ( $ref_option eq "CODE" ) and $group = "extract"; 745 if ( $ref_option eq "Regexp" ) { 746 my $regex = $option; 747 $option = sub { join("", m/$regex/) }; 748 $group = "extract"; 749 } 750 751 $group ||= $option__group->{ $option } 752 or Carp::croak("->$method_name(): Invalid comparison option ($option), did you mean ->order_by('$option')?"); 753 754 exists $group__value->{ $group } 755 and Carp::croak("->$method_name(): Conflicting comparison options: ($group__value->{ $group }) and ($option)"); 756 757 $group__value->{ $group } = $option; 758 } 759 760 return $group__value; 761} 762 763my $transform__sorter = { 764 str => "string", 765 num => "number", 766 asc => "ascending", 767 desc => "descending", 768}; 769sub _sorter_from_comparisons { 770 my ($method_name, $comparisons) = @_; 771 772 my @sorter_keys; 773 my @extracts; 774 for my $options (@$comparisons) { 775 ref($options) eq "ARRAY" or $options = [ $options ]; 776 777 # Check one comparison 778 my $group__value = _group__value_from_order_options( 779 $method_name, 780 $options, 781 ); 782 783 my $operator = $group__value->{operator} // "str"; 784 my $direction = $group__value->{direction} // "asc"; 785 my $extract = $group__value->{extract} // sub { $_ }; 786 787 my $sorter_operator = $transform__sorter->{$operator}; 788 my $sorter_direction = $transform__sorter->{$direction}; 789 790 push(@extracts, $extract); 791 my $extract_index = @extracts; 792 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 my $sorter = Sort::Maker::make_sorter( 803 "plain", "ref_in", "ref_out", 804 @sorter_keys, 805 ) or Carp::croak(__PACKAGE__ . " internal error: $@"); 806 807 return ($sorter, \@extracts); 808} 809 810sub _item_values_array_from_array_item_extracts { 811 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 my $item = $_; 819 [ 820 $item, # array item to compare 821 map { 822 my $extract = $_; local $_ = $item; 823 $extract->(); 824 } @$extracts, # comparison values for array item 825 ]; 826 } 827 @$array 828 ]; 829} 830 831sub _item_values_array_from_map_by_extracts { 832 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 sub { [ map_by($array, $_) ] } 839 ); 840 return [ 841 map { ## no critic 842 my $item = $_; 843 my $accessor_index = 0; 844 [ 845 $item, # array item to compare 846 map { 847 my $extract = $_; 848 my $value = shift @{$accessor_values->[ $accessor_index++ ]}; 849 850 local $_ = $value; 851 $extract->(); 852 } @$extracts, # comparison values for array item 853 ]; 854 } 855 @$array 856 ]; 857} 858 859=head2 @array->order(@comparisons = ("str")) : @array | @$array 860 861Return C<@array> ordered according to the C<@comparisons>. The default 862comparison is the same as the default sort, e.g. a normal string 863comparison of the C<@array> values. 864 865If the first item in C<@comparison> ends in a tie, the next one is 866used, etc. 867 868Each I<comparison> consists of a single I<option> or an I<arrayref of 869options>, e.g. C<str>/C<num>, C<asc>/C<desc>, or a subref/regex. See 870L</Sorting using order and order_by> for details about how these work. 871 872Examples: 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 886sub order { 887 my $array = shift; 888 my (@comparisons) = @_; 889 @comparisons or @comparisons = ("str"); 890 891 my ($sorter, $extracts) = _sorter_from_comparisons("order", \@comparisons); 892 893 my $item_values_array = _item_values_array_from_array_item_extracts( 894 $array, 895 $extracts, 896 ); 897 my $sorted_array = $sorter->($item_values_array); 898 my $result = [ map { $_->[0] } @$sorted_array ]; 899 900 return wantarray ? @$result : $result; 901} 902 903 904 905=head2 @array->group($value_subref = item) : %key_value | %$key_value 906 907Group the C<@array> items into a hashref with the items as keys. 908 909The default C<$value_subref> puts each item in the list as the hash 910value. If the key is repeated, the value is overwritten with the last 911object. 912 913Example: 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 925For simple cases of just grouping a single key to a single value, the 926C<$value_subref> is straightforward to use. 927 928The hash key is the array item. The hash value is whatever is returned 929from 930 931 my $new_value = $value_sub->($current_value, $object, $key); 932 933=over 4 934 935=item 936 937C<$current> value is the current hash value for this key (or undef if 938the first one). 939 940=item 941 942C<$object> is the current item in the list. The current $_ is also set 943to this. 944 945=item 946 947C<$key> is the array item. 948 949=back 950 951See also: C<-E<gt>group_by>. 952 953=cut 954 955sub __core_group { 956 my( $name, $array, $value_sub ) = @_; 957 @$array or return wantarray ? () : { }; 958 959 my %key_value; 960 for my $item (@$array) { 961 my $key = $item; 962 963 my $current_value = $key_value{ $key }; 964 local $_ = $item; 965 my $new_value = $value_sub->($current_value, $item, $key); 966 967 $key_value{ $key } = $new_value; 968 } 969 970 return wantarray ? %key_value : \%key_value; 971} 972 973sub group { 974 my $array = shift; 975 my ($value_sub) = _normalized_accessor_args_subref(@_); 976 977 $value_sub //= sub { $_ }; 978 ref($value_sub) eq "CODE" 979 or Carp::croak("group(\$value_sub): \$value_sub ($value_sub) is not a sub ref"); 980 981 return __core_group("group", $array, $value_sub); 982} 983 984 985 986=head2 @array->group_count : %key_count | %$key_count 987 988Just like C<group>, but the hash values are the the number of 989instances each item occurs in the list. 990 991Example: 992 993 $book_genres->group_count; 994 # { 995 # "Sci-fi" => 3, 996 # "Fantasy" => 1, 997 # }, 998 999There are three books counted for the "Sci-fi" key. 1000 1001=cut 1002 1003sub group_count { 1004 my $array = shift; 1005 1006 my $value_sub = sub { 1007 my $count = shift // 0; 1008 return ++$count; 1009 }; 1010 1011 return __core_group("group_count", $array, $value_sub); 1012} 1013 1014 1015 1016 1017=head2 @array->group_array : %key_objects | %$key_objects 1018 1019Just like C<group>, but the hash values are arrayrefs containing those 1020same array items. 1021 1022Example: 1023 1024 $book_genres->group_array; 1025 # { 1026 # "Sci-fi" => [ "Sci-fi", "Sci-fi", "Sci-fi" ], 1027 # "Fantasy" => [ "Fantasy" ], 1028 # }, 1029 1030The three Sci-fi genres are collected under the Sci-fi key. 1031 1032=cut 1033 1034sub group_array { 1035 my $array = shift; 1036 1037 my $value_sub = sub { 1038 my $value_array = shift // []; 1039 push( @$value_array, $_ ); 1040 return $value_array; 1041 }; 1042 1043 return __core_group("group_array", $array, $value_sub); 1044} 1045 1046 1047 1048=head2 @array->flat() : @array | @$array 1049 1050Return a (one level) flattened array, assuming the array items 1051themselves are array refs. I.e. 1052 1053 [ 1054 [ 1, 2, 3 ], 1055 [ "a", "b" ], 1056 [ [ 1, 2 ], { 3 => 4 } ] 1057 ]->flat 1058 1059returns 1060 1061 [ 1, 2, 3, "a", "b ", [ 1, 2 ], { 3 => 4 } ] 1062 1063This is useful if e.g. a C<-E<gt>map_by("some_method")> returns 1064arrayrefs of objects which you want to do further method calls 1065on. Example: 1066 1067 # ->books returns an arrayref of Book objects with a ->title 1068 $authors->map_by("books")->flat->map_by("title") 1069 1070Note: This is different from L<autobox::Core>'s C<-E<gt>flatten>, 1071which reurns a list rather than an array and therefore can't be used 1072in this way. 1073 1074=cut 1075 1076sub flat { 1077 my $array = shift; 1078 ###JPL: eval and report error from correct place 1079 my $result = [ map { @$_ } @$array ]; 1080 return wantarray ? @$result : $result; 1081} 1082 1083=head2 @array->to_ref() : $arrayref 1084 1085Return the reference to the C<@array>, regardless of context. 1086 1087Useful for ensuring the last array method return a reference while in 1088scalar context. Typically: 1089 1090 do_stuff( 1091 books => $author->map_by("books")->to_ref, 1092 ); 1093 1094map_by is called in list context, so without C<-E<gt>to_ref> it would 1095have return an array, not an arrayref. 1096 1097=cut 1098 1099sub to_ref { 1100 my $array = shift; 1101 return $array; 1102} 1103 1104=head2 @array->to_array() : @array 1105 1106Return the C<@array>, regardless of context. This is mostly useful if 1107called on a ArrayRef at the end of a chain of method calls. 1108 1109=cut 1110 1111sub to_array { 1112 my $array = shift; 1113 return @$array; 1114} 1115 1116=head2 @array->to_hash() : %hash | %$hash 1117 1118Return the item pairs in the C<@array> as the key-value pairs of a 1119C<%hash> (context sensitive). 1120 1121Useful if you need to continue calling C<%hash> methods on it. 1122 1123Die if there aren't an even number of items in C<@array>. 1124 1125=cut 1126 1127sub to_hash { 1128 my $array = shift; 1129 my $count = @$array; 1130 1131 $count % 2 and Carp::croak( 1132 "\@array->to_hash on an array with an odd number of elements ($count)", 1133 ); 1134 1135 my %new_hash = @$array; 1136 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 1150sub __invoke_by { 1151 my $invoke = shift; 1152 my $array = shift; 1153 my( $accessor, $args, $subref_name, $subref ) = @_; 1154 defined($accessor) or Carp::croak("->${invoke}_by() missing argument: \$accessor"); 1155 @$array or return wantarray ? () : [ ]; 1156 1157 $args //= []; 1158 if ( ref($array->[0] ) eq "HASH" ) { 1159 ( 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 $invoke .= "_key"; 1162 } 1163 1164 ###JPL: move up 1165 ref($args) eq "ARRAY" 1166 or Carp::croak("${invoke}_by([ '$accessor', \@args ]): \@args ($args) is not a list"); 1167 1168 if( $subref_name ) { 1169 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 my %seen; 1174 my $invoke_sub = { 1175 map => sub { [ CORE::map { $_->$accessor( @$args ) } @$array ] }, 1176 map_key => sub { [ CORE::map { $_->{$accessor} } @$array ] }, 1177 filter => sub { [ CORE::grep { $subref->( local $_ = $_->$accessor( @$args ) ) } @$array ] }, 1178 filter_key => sub { [ CORE::grep { $subref->( local $_ = $_->{$accessor} ) } @$array ] }, 1179 reject => sub { [ CORE::grep { ! $subref->( local $_ = $_->$accessor( @$args ) ) } @$array ] }, 1180 reject_key => sub { [ CORE::grep { ! $subref->( local $_ = $_->{$accessor} ) } @$array ] }, 1181 uniq => sub { [ CORE::grep { ! $seen{ $_->$accessor( @$args ) // "" }++ } @$array ] }, 1182 uniq_key => sub { [ CORE::grep { ! $seen{ $_->{$accessor} // "" }++ } @$array ] }, 1183 }->{$invoke}; 1184 1185 my $result = eval { $invoke_sub->() } 1186 or autobox::Transform::throw($@); 1187 1188 return wantarray ? @$result : $result; 1189} 1190 1191=head2 @array->map_by($accessor) : @array | @$array 1192 1193C<$accessor> is either a string, or an arrayref where the first item 1194is a string. 1195 1196Call the C<$accessor> on each object in C<@array>, or get the hash key 1197value on each hashref in C<@array>. Like: 1198 1199 map { $_->$accessor() } @array 1200 # or 1201 map { $_->{$accessor} } @array 1202 1203Examples: 1204 1205 my @author_names = $authors->map_by("name"); 1206 my $author_names = @publishers->map_by("authors")->flat->map_by("name"); 1207 1208Or get the hash key value. Example: 1209 1210 my @review_scores = $reviews->map_by("score"); 1211 1212Alternatively for when C<@array> contains objects, the $accessor can 1213be an arrayref. The first item is the method name, and the rest of the 1214items are passed as args in the method call. This obviously won't work 1215when the C<@array> contains hashrefs. 1216 1217Examples: 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 1224sub map_by { 1225 my $array = shift; 1226 my ($accessor, $args) = _normalized_accessor_args_subref(@_); 1227 return __invoke_by("map", $array, $accessor, $args); 1228} 1229 1230 1231 1232=head2 @array->filter_by($accessor, $predicate = *is_true_subref*) : @array | @$array 1233 1234C<$accessor> is either a string, or an arrayref where the first item 1235is a string. 1236 1237Call the C<$accessor> on each object in the list, or get the hash key 1238value on each hashref in the list. 1239 1240Example: 1241 1242 my @prolific_authors = $authors->filter_by("is_prolific"); 1243 1244Alternatively the C<$accessor> is an arrayref. The first item is the 1245accessor name, and the rest of the items are passed as args the method 1246call. This only works when working with objects, not with hashrefs. 1247 1248Example: 1249 1250 my @books_to_charge_for = $books->filter_by([ price_with_tax => $tax_pct ]); 1251 1252Use the C<$predicate> to determine whether the value should remain. 1253C<$predicate> can be a subref, string, undef, regex, or hashref. See 1254L</Filter predicates>. 1255 1256The default (no C<$predicate>) is a subref which retains true values 1257in the result C<@array>. 1258 1259Examples: 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 1273Note: if you do something complicated with a $predicate subref, it 1274might be easier and more readable to simply use 1275C<$array-$<gt>filter()>. 1276 1277 1278=head3 Alias 1279 1280C<grep_by> is an alias for C<filter_by>. Unlike C<grep> vs C<filter>, 1281this one works exaclty the same way. 1282 1283=cut 1284 1285sub filter_by { 1286 my $array = shift; 1287 my ($accessor, $args, $predicate) = _normalized_accessor_args_predicate(@_); 1288 my $subref = autobox::Transform::_predicate( 1289 "filter_by", 1290 $predicate, 1291 sub { !! $_ }, 1292 ); 1293 # filter_by $value, if passed the method value must match the value? 1294 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 1309C<reject_by> is the same as L<C<filter_by>>, except it I<filters out> 1310items that matches the $predicate. 1311 1312Example: 1313 1314 my @unproductive_authors = $authors->reject_by("is_prolific"); 1315 1316The default (no $predicate) is a subref which I<filters out> true 1317values in the result C<@array>. 1318 1319=cut 1320 1321sub reject_by { 1322 my $array = shift; 1323 my ($accessor, $args, $predicate) = _normalized_accessor_args_predicate(@_); 1324 my $subref = autobox::Transform::_predicate( 1325 "reject_by", 1326 $predicate, 1327 sub { !! $_ }, 1328 ); 1329 # filter_by $value, if passed the method value must match the value? 1330 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 1343C<$accessor> is either a string, or an arrayref where the first item 1344is a string. 1345 1346Call the $C<accessor> on each object in the list, or get the hash key 1347value on each hashref in the list. Return list of items which have a 1348unique set of return values. The order is preserved. On duplicates, 1349keep the first occurrence. 1350 1351Examples: 1352 1353 # You have gathered multiple Author objects with duplicate ids 1354 my @authors = $authors->uniq_by("author_id"); 1355 1356Alternatively the C<$accessor> is an arrayref. The first item is the 1357accessor name, and the rest of the items are passed as args the method 1358call. This only works when working with objects, not with hashrefs. 1359 1360Examples: 1361 1362 my @example_book_at_price_point = $books->uniq_by( 1363 [ price_with_tax => $tax_pct ], 1364 ); 1365 1366=cut 1367 1368sub uniq_by { 1369 my $array = shift; 1370 my ($accessor, $args) = _normalized_accessor_args_subref(@_); 1371 return __invoke_by("uniq", $array, $accessor, $args); 1372} 1373 1374=head2 @array->order_by(@accessor_comparison_pairs) : @array | @$array 1375 1376Return C<@array> ordered according to the 1377C<@accessor_comparison_pairs>. 1378 1379The comparison value comes from an initial 1380C<@array->map_by($accessor)> for each accessor-comparison pair. It is 1381important that the $accessor call returns exactly a single scalar that 1382can be compared with the other values. 1383 1384It then works just like with C<-E<gt>order>. 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 1390As with C<map_by>, if the $accessor is used on an object, the method 1391call can include arguments. 1392 1393 $books->order_by([ price_wih_tax => $tax_rate ] => "num"); 1394 1395Just like with C<order>, the value returned by the accessor can be 1396transformed 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 1405If a comparison is missing for the last pair, the default is a normal 1406C<str> comparison. 1407 1408 $books->order_by("name"); # default "str" 1409 1410If the first comparison ends in a tie, the next pair is used, 1411etc. Note that in order to provide accessor-comparison pairs, it's 1412often necessary to provide a default "str" comparison just to make it 1413a pair. 1414 1415 $books->order_by( 1416 author => "str", 1417 price => [ "num", "desc" ], 1418 ); 1419 1420=cut 1421 1422sub order_by { 1423 my $array = shift; 1424 my (@accessors_and_comparisons) = @_; 1425 1426 my $i = 0; 1427 my ($accessors, $comparisons) = List::MoreUtils::part 1428 { $i++ %2 } 1429 @accessors_and_comparisons; 1430 $accessors ||= []; 1431 $comparisons ||= []; 1432 @$accessors or Carp::croak("->order_by() missing argument: \$accessor"); 1433 # Default comparison 1434 @$accessors == @$comparisons or push(@$comparisons, "str"); 1435 1436 my ($sorter, $extracts) = _sorter_from_comparisons("order_by", $comparisons); 1437 1438 my $item_values_array = _item_values_array_from_map_by_extracts( 1439 $array, 1440 $accessors, 1441 $extracts, 1442 ); 1443 my $sorted_array = $sorter->($item_values_array); 1444 my $result = [ map { $_->[0] } @$sorted_array ]; 1445 1446 return wantarray ? @$result : $result; 1447} 1448 1449=head2 @array->group_by($accessor, $value_subref = object) : %key_value | %$key_value 1450 1451C<$accessor> is either a string, or an arrayref where the first item 1452is a string. 1453 1454Call C<-E<gt>$accessor> on each object in the array, or get the hash 1455key for each hashref in the array (just like C<-E<gt>map_by>) and 1456group the values as keys in a hashref. 1457 1458The default C<$value_subref> puts each object in the list as the hash 1459value. If the key is repeated, the value is overwritten with the last 1460object. 1461 1462Example: 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 1474For simple cases of just grouping a single key to a single value, the 1475C<$value_subref> is straightforward to use. 1476 1477The hash key is whatever is returned from C<$object-E<gt>$accessor>. 1478 1479The 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 1487C<$current> value is the current hash value for this key (or undef if the first one). 1488 1489=item 1490 1491C<$object> is the current item in the list. The current $_ is also set to this. 1492 1493=item 1494 1495C<$key> is the key returned by $object->$accessor(@$args) 1496 1497=back 1498 1499A simple example would be to group by the accessor, but instead of the 1500object used as the value you want to look up an attribute on each 1501object: 1502 1503 my $book_id__author = $books->group_by("id", sub { $_->author }); 1504 # keys: book id; values: author 1505 1506If you want to create an aggregate value the C<$value_subref> can be a 1507bit tricky to use, so the most common thing would probably be to use 1508one of the more specific group_by-methods (see below). It should be 1509capable enough to achieve what you need though. 1510 1511=cut 1512 1513sub __core_group_by { 1514 my( $name, $array, $accessor, $args, $value_sub ) = @_; 1515 $accessor or Carp::croak("->$name() missing argument: \$accessor"); 1516 @$array or return wantarray ? () : { }; 1517 1518 my $invoke = do { 1519 # Hash key 1520 if ( ref($array->[0] ) eq "HASH" ) { 1521 defined($args) 1522 and Carp::croak("$name([ '$accessor', \@args ]): \@args ($args) only supported for method calls, not hash key access."); 1523 "key"; 1524 } 1525 # Method 1526 else { 1527 $args //= []; 1528 ref($args) eq "ARRAY" 1529 or Carp::croak("$name([ '$accessor', \@args ], \$value_sub): \@args ($args) is not a list"); 1530 "method"; 1531 } 1532 }; 1533 1534 my $invoke_sub = { 1535 method => sub { [ shift->$accessor(@$args) ] }, 1536 key => sub { [ shift->{$accessor} ] }, 1537 }->{$invoke}; 1538 1539 my %key_value; 1540 for my $object (@$array) { 1541 my $key_ref = eval { $invoke_sub->($object) } 1542 or autobox::Transform::throw($@); 1543 my $key = $key_ref->[0]; 1544 1545 my $current_value = $key_value{ $key }; 1546 local $_ = $object; 1547 my $new_value = $value_sub->($current_value, $object, $key); 1548 1549 $key_value{ $key } = $new_value; 1550 } 1551 1552 return wantarray ? %key_value : \%key_value; 1553} 1554 1555sub group_by { 1556 my $array = shift; 1557 my ($accessor, $args, $value_sub) = _normalized_accessor_args_subref(@_); 1558 1559 $value_sub //= sub { $_ }; 1560 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 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 1568C<$accessor> is either a string, or an arrayref where the first item 1569is a string. 1570 1571Just like C<group_by>, but the hash values are the the number of 1572instances each $accessor value occurs in the list. 1573 1574Example: 1575 1576 $books->group_by_count("genre"), 1577 # { 1578 # "Sci-fi" => 3, 1579 # "Fantasy" => 1, 1580 # }, 1581 1582C<$book-E<gt>genre()> returns the genre string. There are three books 1583counted for the "Sci-fi" key. 1584 1585=cut 1586 1587sub group_by_count { 1588 my $array = shift; 1589 my ($accessor, $args) = _normalized_accessor_args_subref(@_); 1590 1591 my $value_sub = sub { 1592 my $count = shift // 0; return ++$count; 1593 }; 1594 1595 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 1600C<$accessor> is either a string, or an arrayref where the first item 1601is a string. 1602 1603Just like C<group_by>, but the hash values are arrayrefs containing 1604the objects which has each $accessor value. 1605 1606Example: 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 1615are collected under the Sci-fi key. 1616 1617=cut 1618 1619sub group_by_array { 1620 my $array = shift; 1621 my ($accessor, $args) = _normalized_accessor_args_subref(@_); 1622 1623 my $value_sub = sub { 1624 my $array = shift // []; 1625 push( @$array, $_ ); 1626 return $array; 1627 }; 1628 1629 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 1638package # hide from PAUSE 1639 autobox::Transform::Hash; 1640 1641use autobox::Core; 1642 1643 1644 1645sub key_value { 1646 my $hash = shift; 1647 my( $original_key, $new_key ) = @_; 1648 $new_key //= $original_key; 1649 my %key_value = ( $new_key => $hash->{$original_key} ); 1650 return wantarray ? %key_value : \%key_value; 1651} 1652 1653sub __core_key_value_if { 1654 my $hash = shift; 1655 my( $comparison_sub, $original_key, $new_key ) = @_; 1656 $comparison_sub->($hash, $original_key) or return wantarray ? () : {}; 1657 return key_value($hash, $original_key, $new_key) 1658} 1659 1660sub key_value_if_exists { 1661 my $hash = shift; 1662 my( $original_key, $new_key ) = @_; 1663 return __core_key_value_if( 1664 $hash, 1665 sub { !! exists shift->{ shift() } }, 1666 $original_key, 1667 $new_key 1668 ); 1669} 1670 1671sub key_value_if_true { 1672 my $hash = shift; 1673 my( $original_key, $new_key ) = @_; 1674 return __core_key_value_if( 1675 $hash, 1676 sub { !! shift->{ shift() } }, 1677 $original_key, 1678 $new_key 1679 ); 1680} 1681 1682sub key_value_if_defined { 1683 my $hash = shift; 1684 my( $original_key, $new_key ) = @_; 1685 return __core_key_value_if( 1686 $hash, 1687 sub { defined( shift->{ shift() } ) }, 1688 $original_key, 1689 $new_key 1690 ); 1691} 1692 1693 1694 1695=head2 %hash->map_each($key_value_subref) : %new_hash | %$new_hash 1696 1697Map each key-value pair in the hash using the 1698C<$key_value_subref>. Similar to how to how map transforms a list into 1699another list, map_each transforms a hash into another hash. 1700 1701C<$key_value_subref-E<gt>($key, $value)> is called for each pair (with 1702$_ set to the value). 1703 1704The subref should return an even-numbered list with zero or more 1705key-value pairs which will make up the C<%new_hash>. Typically two 1706items 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 1715sub map_each { 1716 my $hash = shift; 1717 my ($key_value_subref) = @_; 1718 $key_value_subref //= ""; 1719 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 my $key = $_; 1724 my $value = $hash->{$key}; 1725 { 1726 local $_ = $value; 1727 my (@new_key_value) = $key_value_subref->($key, $value); 1728 (@new_key_value % 2) and Carp::croak("map_each \$key_value_subref returned odd number of keys/values"); 1729 @new_key_value; 1730 } 1731 } 1732 keys %$hash, 1733 }; 1734 1735 return wantarray ? %$new_hash : $new_hash; 1736} 1737 1738=head2 %hash->map_each_value($value_subref) : %new_hash | %$new_hash 1739 1740Map each value in the hash using the C<$value_subref>, but keep the 1741keys the same. 1742 1743C<$value_subref-E<gt>($key, $value)> is called for each pair (with 1744C<$_> set to the value). 1745 1746The subref should return a single value for each key which will make 1747up 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 1756sub map_each_value { 1757 my $hash = shift; 1758 my ($value_subref) = @_; 1759 $value_subref //= ""; 1760 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 my $key = $_; 1765 my $value = $hash->{$key}; 1766 { 1767 local $_ = $value; 1768 my @new_values = $value_subref->($key, $value); 1769 @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 $key => @new_values; 1775 } 1776 } 1777 keys %$hash, 1778 }; 1779 1780 return wantarray ? %$new_hash : $new_hash; 1781} 1782 1783=head2 %hash->map_each_to_array($item_subref) : @new_array | @$new_array 1784 1785Map each key-value pair in the hash into a list using the 1786C<$item_subref>. 1787 1788C<$item_subref-E<gt>($key, $value)> is called for each pair (with 1789C<$_> set to the value) in key order. 1790 1791The subref should return zero or more list items which will make up 1792the 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 1801sub map_each_to_array { 1802 my $hash = shift; 1803 my ($array_item_subref) = @_; 1804 $array_item_subref //= ""; 1805 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 my $key = $_; 1810 my $value = $hash->{$key}; 1811 { 1812 local $_ = $value; 1813 $array_item_subref->($key, $value); 1814 } 1815 } 1816 sort keys %$hash, 1817 ]; 1818 1819 return wantarray ? @$new_array : $new_array; 1820} 1821 1822 1823=head2 %hash->filter_each($predicate = *is_true_subref*) : @hash | @$hash 1824 1825Return a C<%hash> with values for which C<$predicate> yields a true 1826value. 1827 1828C<$predicate> can be a subref, string, undef, regex, or hashref. See 1829L</Filter predicates>. 1830 1831The default (no $predicate) is a subref which retains true values in 1832the C<%hash>. 1833 1834If the $predicate is a subref, C<$predicate-E<gt>($key, $value)> is 1835called for each pair (with C<$_> set to the value). 1836 1837The subref should return a true value to retain the key-value pair in 1838the 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 1849sub filter_each { 1850 my $hash = shift; 1851 my ($predicate) = @_; 1852 my $subref = autobox::Transform::_predicate( 1853 "filter_each", 1854 $predicate, 1855 sub { !! $_ }, # true? 1856 ); 1857 1858 my $new_hash = { 1859 map { ## no critic 1860 my $key = $_; 1861 my $value = $hash->{$key}; 1862 { 1863 local $_ = $value; 1864 $subref->($key, $value) 1865 ? ( $key => $value ) 1866 : (); 1867 } 1868 } 1869 keys %$hash, 1870 }; 1871 1872 return wantarray ? %$new_hash : $new_hash; 1873} 1874{ 1875 no warnings "once"; 1876 *grep_each = \&filter_each; 1877} 1878 1879sub filter_each_defined { 1880 my $hash = shift; 1881 return &filter_each($hash, sub { defined($_) }); 1882} 1883{ 1884 no warnings "once"; 1885 *grep_each_defined = \&filter_each_defined; 1886} 1887 1888 1889 1890=head2 %hash->reject_each($predicate = *is_false_subref*) : @hash | @$hash 1891 1892C<reject_each> is the same as L<C<filter_each>>, except it I<filters out> 1893items that matches the $predicate. 1894 1895Examples: 1896 1897 { a => 1, b => 2 }->reject_each(sub { $_ == 2 }); 1898 # Returns { a => 1 } 1899 1900The default (no $predicate) is a subref which I<filters out> true 1901values in the C<%hash>. 1902 1903=cut 1904 1905sub reject_each { 1906 my $hash = shift; 1907 my ($predicate) = @_; 1908 my $subref = autobox::Transform::_predicate( 1909 "reject_each", 1910 $predicate, 1911 sub { !! $_ }, # true? 1912 ); 1913 1914 my $new_hash = { 1915 map { ## no critic 1916 my $key = $_; 1917 my $value = $hash->{$key}; 1918 { 1919 local $_ = $value; 1920 ( ! $subref->($key, $value) ) 1921 ? ( $key => $value ) 1922 : (); 1923 } 1924 } 1925 keys %$hash, 1926 }; 1927 1928 return wantarray ? %$new_hash : $new_hash; 1929} 1930 1931sub reject_each_defined { 1932 my $hash = shift; 1933 return &reject_each($hash, sub { defined($_) }); 1934} 1935 1936 1937 1938=head2 %hash->to_ref() : $hashref 1939 1940Return the reference to the C<%hash>, regardless of context. 1941 1942Useful for ensuring the last hash method return a reference while in 1943scalar context. Typically: 1944 1945 do_stuff( 1946 genre_count => $books->group_by_count("genre")->to_ref, 1947 ); 1948 1949=cut 1950 1951sub to_ref { 1952 my $hash = shift; 1953 return $hash; 1954} 1955 1956=head2 %hash->to_hash() : %hash 1957 1958Return the C<%hash>, regardless of context. This is mostly useful if 1959called on a HashRef at the end of a chain of method calls. 1960 1961=cut 1962 1963sub to_hash { 1964 my $hash = shift; 1965 return %$hash; 1966} 1967 1968=head2 %hash->to_array() : @array | @$array 1969 1970Return the key-value pairs of the C<%hash> as an C<@array>, ordered by 1971the keys. 1972 1973Useful if you need to continue calling C<@array> methods on it. 1974 1975=cut 1976 1977sub to_array { 1978 my $hash = shift; 1979 my @new_array = map_each_to_array($hash, sub { shift() => $_ }); 1980 return wantarray ? @new_array : \@new_array; 1981} 1982 1983 1984 1985=head1 AUTOBOX AND VANILLA PERL 1986 1987 1988=head2 Raison d'etre 1989 1990L<autobox::Core> is awesome, for a variety of reasons. 1991 1992=over 4 1993 1994=item 1995 1996It cuts down on dereferencing punctuation clutter, both by using 1997methods on references and by using ->elements to deref arrayrefs. 1998 1999=item 2000 2001It makes map and grep transforms read in the same direction it's 2002executed. 2003 2004=item 2005 2006It makes it easier to write those things in a natural order. No need 2007to move the cursor around a lot just to fix dereferencing, order of 2008operations etc. 2009 2010=back 2011 2012On top of this, L<autobox::Transform> provides a few higher level 2013methods for mapping, filtering and sorting common cases which are easier 2014to read and write. 2015 2016Since they are at a slightly higher semantic level, once you know them 2017they also provide a more specific meaning than just C<map> or C<grep>. 2018 2019(Compare the difference between seeing a C<map> and seeing a 2020C<foreach> loop. Just seeing the word C<map> hints at what type of 2021thing is going on here: transforming a list into another list). 2022 2023The methods of C<autobox::Transform> are not suitable for all cases, 2024but when used appropriately they will lead to much more clear, 2025succinct and direct code, especially in conjunction with 2026C<autobox::Core>. 2027 2028 2029=head2 Code Comparison 2030 2031These examples are only for when there's a straightforward and simple 2032Perl 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 2087Johan Lindstrom, C<< <johanl [AT] cpan.org> >> 2088 2089 2090=head2 Source code 2091 2092L<https://github.com/jplindstrom/p5-autobox-Transform> 2093 2094 2095=head2 Bug reports 2096 2097Please report any bugs or feature requests on GitHub: 2098 2099L<https://github.com/jplindstrom/p5-autobox-Transform/issues>. 2100 2101 2102 2103=head1 COPYRIGHT & LICENSE 2104 2105Copyright 2016- Johan Lindstrom, All Rights Reserved. 2106 2107This program is free software; you can redistribute it and/or modify it 2108under the same terms as Perl itself. 2109 2110=cut 2111 21121; 2113