| 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 |
|
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 |
|
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 |
|
2018
|
|
|
|
|
|
|
|
|
2019
|
|
|
|
|
|
|
(Compare the difference between seeing a C |
|
2020
|
|
|
|
|
|
|
C loop. Just seeing the word C |
|
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; |