Revision 683f1b3d
Von Sven Schöling vor mehr als 13 Jahren hinzugefügt
modules/fallback/List/MoreUtils.pm | ||
---|---|---|
2 | 2 |
|
3 | 3 |
use 5.00503; |
4 | 4 |
use strict; |
5 |
use Exporter (); |
|
6 |
use DynaLoader (); |
|
7 |
|
|
8 |
use vars qw{ $VERSION @ISA @EXPORT_OK %EXPORT_TAGS }; |
|
9 |
BEGIN { |
|
10 |
$VERSION = '0.30'; |
|
11 |
@ISA = qw{ Exporter DynaLoader }; |
|
12 |
@EXPORT_OK = qw{ |
|
13 |
any all none notall true false |
|
14 |
firstidx first_index lastidx last_index |
|
15 |
insert_after insert_after_string |
|
16 |
apply indexes |
|
17 |
after after_incl before before_incl |
|
18 |
firstval first_value lastval last_value |
|
19 |
each_array each_arrayref |
|
20 |
pairwise natatime |
|
21 |
mesh zip uniq distinct |
|
22 |
minmax part |
|
23 |
}; |
|
24 |
%EXPORT_TAGS = ( |
|
25 |
all => \@EXPORT_OK, |
|
26 |
); |
|
5 | 27 |
|
6 |
require Exporter; |
|
7 |
require DynaLoader; |
|
8 |
|
|
28 |
# Load the XS at compile-time so that redefinition warnings will be |
|
29 |
# thrown correctly if the XS versions of part or indexes loaded |
|
30 |
eval { |
|
31 |
# PERL_DL_NONLAZY must be false, or any errors in loading will just |
|
32 |
# cause the perl code to be tested |
|
33 |
local $ENV{PERL_DL_NONLAZY} = 0 if $ENV{PERL_DL_NONLAZY}; |
|
9 | 34 |
|
10 |
use vars qw($VERSION @ISA @EXPORT_OK %EXPORT_TAGS);
|
|
11 |
@ISA = qw(Exporter DynaLoader);
|
|
35 |
bootstrap List::MoreUtils $VERSION;
|
|
36 |
1;
|
|
12 | 37 |
|
13 |
%EXPORT_TAGS = ( |
|
14 |
all => [ qw(any all none notall true false firstidx first_index lastidx |
|
15 |
last_index insert_after insert_after_string apply after after_incl before |
|
16 |
before_incl indexes firstval first_value lastval last_value each_array |
|
17 |
each_arrayref pairwise natatime mesh zip uniq minmax part bsearch) ], |
|
18 |
); |
|
38 |
} unless $ENV{LIST_MOREUTILS_PP}; |
|
39 |
} |
|
19 | 40 |
|
20 |
@EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } ); |
|
41 |
# Always use Perl apply() until memory leaks are resolved. |
|
42 |
sub apply (&@) { |
|
43 |
my $action = shift; |
|
44 |
&$action foreach my @values = @_; |
|
45 |
wantarray ? @values : $values[-1]; |
|
46 |
} |
|
21 | 47 |
|
22 |
$VERSION = '0.25_02'; |
|
48 |
# Always use Perl part() until memory leaks are resolved. |
|
49 |
sub part (&@) { |
|
50 |
my ($code, @list) = @_; |
|
51 |
my @parts; |
|
52 |
push @{ $parts[ $code->($_) ] }, $_ foreach @list; |
|
53 |
return @parts; |
|
54 |
} |
|
23 | 55 |
|
24 |
eval { |
|
25 |
local $ENV{PERL_DL_NONLAZY} = 0 if $ENV{PERL_DL_NONLAZY}; |
|
26 |
bootstrap List::MoreUtils $VERSION; |
|
27 |
1; |
|
28 |
} if not $ENV{LIST_MOREUTILS_PP}; |
|
56 |
# Always use Perl indexes() until memory leaks are resolved. |
|
57 |
sub indexes (&@) { |
|
58 |
my $test = shift; |
|
59 |
grep { |
|
60 |
local *_ = \$_[$_]; |
|
61 |
$test->() |
|
62 |
} 0 .. $#_; |
|
63 |
} |
|
29 | 64 |
|
30 |
eval <<'EOP' if not defined &any; |
|
65 |
# Load the pure-Perl versions of the other functions if needed |
|
66 |
eval <<'END_PERL' unless defined &any; |
|
31 | 67 |
|
32 |
require POSIX; |
|
68 |
# Use pure scalar boolean return values for compatibility with XS |
|
69 |
use constant YES => ! 0; |
|
70 |
use constant NO => ! 1; |
|
33 | 71 |
|
34 | 72 |
sub any (&@) { |
35 | 73 |
my $f = shift; |
36 |
return if ! @_; |
|
37 |
for (@_) { |
|
38 |
return 1 if $f->(); |
|
74 |
foreach ( @_ ) { |
|
75 |
return YES if $f->(); |
|
39 | 76 |
} |
40 |
return 0;
|
|
77 |
return NO;
|
|
41 | 78 |
} |
42 |
|
|
79 |
|
|
43 | 80 |
sub all (&@) { |
44 | 81 |
my $f = shift; |
45 |
return if ! @_; |
|
46 |
for (@_) { |
|
47 |
return 0 if ! $f->(); |
|
82 |
foreach ( @_ ) { |
|
83 |
return NO unless $f->(); |
|
48 | 84 |
} |
49 |
return 1;
|
|
85 |
return YES;
|
|
50 | 86 |
} |
51 | 87 |
|
52 | 88 |
sub none (&@) { |
53 | 89 |
my $f = shift; |
54 |
return 1 if ! @_; |
|
55 |
for (@_) { |
|
56 |
return 0 if $f->(); |
|
90 |
foreach ( @_ ) { |
|
91 |
return NO if $f->(); |
|
57 | 92 |
} |
58 |
return 1;
|
|
93 |
return YES;
|
|
59 | 94 |
} |
60 | 95 |
|
61 | 96 |
sub notall (&@) { |
62 | 97 |
my $f = shift; |
63 |
return if ! @_; |
|
64 |
for (@_) { |
|
65 |
return 1 if ! $f->(); |
|
98 |
foreach ( @_ ) { |
|
99 |
return YES unless $f->(); |
|
66 | 100 |
} |
67 |
return 0;
|
|
101 |
return NO;
|
|
68 | 102 |
} |
69 | 103 |
|
70 | 104 |
sub true (&@) { |
71 |
my $f = shift; |
|
105 |
my $f = shift;
|
|
72 | 106 |
my $count = 0; |
73 |
for (@_) {
|
|
74 |
$count++ if $f->();
|
|
107 |
foreach ( @_ ) {
|
|
108 |
$count++ if $f->();
|
|
75 | 109 |
} |
76 | 110 |
return $count; |
77 | 111 |
} |
78 | 112 |
|
79 | 113 |
sub false (&@) { |
80 |
my $f = shift; |
|
114 |
my $f = shift;
|
|
81 | 115 |
my $count = 0; |
82 |
for (@_) {
|
|
83 |
$count++ if ! $f->();
|
|
116 |
foreach ( @_ ) {
|
|
117 |
$count++ unless $f->();
|
|
84 | 118 |
} |
85 | 119 |
return $count; |
86 | 120 |
} |
87 | 121 |
|
88 | 122 |
sub firstidx (&@) { |
89 | 123 |
my $f = shift; |
90 |
for my $i (0 .. $#_) {
|
|
91 |
local *_ = \$_[$i];
|
|
92 |
return $i if $f->();
|
|
124 |
foreach my $i ( 0 .. $#_ ) {
|
|
125 |
local *_ = \$_[$i];
|
|
126 |
return $i if $f->();
|
|
93 | 127 |
} |
94 | 128 |
return -1; |
95 | 129 |
} |
96 | 130 |
|
97 | 131 |
sub lastidx (&@) { |
98 | 132 |
my $f = shift; |
99 |
for my $i (reverse 0 .. $#_) {
|
|
100 |
local *_ = \$_[$i];
|
|
101 |
return $i if $f->();
|
|
133 |
foreach my $i ( reverse 0 .. $#_ ) {
|
|
134 |
local *_ = \$_[$i];
|
|
135 |
return $i if $f->();
|
|
102 | 136 |
} |
103 | 137 |
return -1; |
104 | 138 |
} |
105 | 139 |
|
106 | 140 |
sub insert_after (&$\@) { |
107 |
my ($code, $val, $list) = @_;
|
|
141 |
my ($f, $val, $list) = @_;
|
|
108 | 142 |
my $c = -1; |
109 | 143 |
local *_; |
110 |
for my $i (0 .. $#$list) {
|
|
111 |
$_ = $list->[$i];
|
|
112 |
$c = $i, last if $code->();
|
|
144 |
foreach my $i ( 0 .. $#$list ) {
|
|
145 |
$_ = $list->[$i];
|
|
146 |
$c = $i, last if $f->();
|
|
113 | 147 |
} |
114 |
@$list = (@{$list}[0..$c], $val, @{$list}[$c+1..$#$list]) and return 1 if $c != -1; |
|
148 |
@$list = ( |
|
149 |
@{$list}[ 0 .. $c ], |
|
150 |
$val, |
|
151 |
@{$list}[ $c + 1 .. $#$list ], |
|
152 |
) and return 1 if $c != -1; |
|
115 | 153 |
return 0; |
116 | 154 |
} |
117 | 155 |
|
118 | 156 |
sub insert_after_string ($$\@) { |
119 | 157 |
my ($string, $val, $list) = @_; |
120 | 158 |
my $c = -1; |
121 |
for my $i (0 .. $#$list) {
|
|
122 |
local $^W = 0;
|
|
123 |
$c = $i, last if $string eq $list->[$i];
|
|
159 |
foreach my $i ( 0 .. $#$list ) {
|
|
160 |
local $^W = 0;
|
|
161 |
$c = $i, last if $string eq $list->[$i];
|
|
124 | 162 |
} |
125 |
@$list = (@{$list}[0..$c], $val, @{$list}[$c+1..$#$list]) and return 1 if $c != -1; |
|
163 |
@$list = ( |
|
164 |
@{$list}[ 0 .. $c ], |
|
165 |
$val, |
|
166 |
@{$list}[ $c + 1 .. $#$list ], |
|
167 |
) and return 1 if $c != -1; |
|
126 | 168 |
return 0; |
127 | 169 |
} |
128 | 170 |
|
129 |
sub apply (&@) { |
|
130 |
my $action = shift; |
|
131 |
&$action for my @values = @_; |
|
132 |
wantarray ? @values : $values[-1]; |
|
133 |
} |
|
134 |
|
|
135 |
sub after (&@) |
|
136 |
{ |
|
171 |
sub after (&@) { |
|
137 | 172 |
my $test = shift; |
138 | 173 |
my $started; |
139 | 174 |
my $lag; |
140 |
grep $started ||= do { my $x=$lag; $lag=$test->(); $x}, @_; |
|
175 |
grep $started ||= do { |
|
176 |
my $x = $lag; |
|
177 |
$lag = $test->(); |
|
178 |
$x |
|
179 |
}, @_; |
|
141 | 180 |
} |
142 | 181 |
|
143 |
sub after_incl (&@) |
|
144 |
{ |
|
182 |
sub after_incl (&@) { |
|
145 | 183 |
my $test = shift; |
146 | 184 |
my $started; |
147 | 185 |
grep $started ||= $test->(), @_; |
148 | 186 |
} |
149 | 187 |
|
150 |
sub before (&@) |
|
151 |
{ |
|
188 |
sub before (&@) { |
|
152 | 189 |
my $test = shift; |
153 |
my $keepgoing=1;
|
|
154 |
grep $keepgoing &&= !$test->(), @_;
|
|
190 |
my $more = 1;
|
|
191 |
grep $more &&= ! $test->(), @_;
|
|
155 | 192 |
} |
156 | 193 |
|
157 |
sub before_incl (&@) |
|
158 |
{ |
|
194 |
sub before_incl (&@) { |
|
159 | 195 |
my $test = shift; |
160 |
my $keepgoing=1; |
|
161 |
my $lag=1; |
|
162 |
grep $keepgoing &&= do { my $x=$lag; $lag=!$test->(); $x}, @_; |
|
196 |
my $more = 1; |
|
197 |
my $lag = 1; |
|
198 |
grep $more &&= do { |
|
199 |
my $x = $lag; |
|
200 |
$lag = ! $test->(); |
|
201 |
$x |
|
202 |
}, @_; |
|
163 | 203 |
} |
164 | 204 |
|
165 |
sub indexes (&@) |
|
166 |
{ |
|
167 |
my $test = shift; |
|
168 |
grep {local *_=\$_[$_]; $test->()} 0..$#_; |
|
169 |
} |
|
170 |
|
|
171 |
sub lastval (&@) |
|
172 |
{ |
|
205 |
sub lastval (&@) { |
|
173 | 206 |
my $test = shift; |
174 | 207 |
my $ix; |
175 |
for ($ix=$#_; $ix>=0; $ix--) |
|
176 |
{ |
|
208 |
for ( $ix = $#_; $ix >= 0; $ix-- ) { |
|
177 | 209 |
local *_ = \$_[$ix]; |
178 | 210 |
my $testval = $test->(); |
179 |
$_[$ix] = $_; # simulate $_ as alias |
|
211 |
|
|
212 |
# Simulate $_ as alias |
|
213 |
$_[$ix] = $_; |
|
180 | 214 |
return $_ if $testval; |
181 | 215 |
} |
182 | 216 |
return undef; |
183 | 217 |
} |
184 | 218 |
|
185 |
sub firstval (&@) |
|
186 |
{ |
|
219 |
sub firstval (&@) { |
|
187 | 220 |
my $test = shift; |
188 |
foreach (@_) |
|
189 |
{ |
|
221 |
foreach ( @_ ) { |
|
190 | 222 |
return $_ if $test->(); |
191 | 223 |
} |
192 | 224 |
return undef; |
193 | 225 |
} |
194 | 226 |
|
195 |
sub pairwise(&\@\@) |
|
196 |
{ |
|
227 |
sub pairwise (&\@\@) { |
|
197 | 228 |
my $op = shift; |
198 |
use vars qw/@A @B/; |
|
199 |
local (*A, *B) = @_; # syms for caller's input arrays |
|
229 |
|
|
230 |
# Symbols for caller's input arrays |
|
231 |
use vars qw{ @A @B }; |
|
232 |
local ( *A, *B ) = @_; |
|
200 | 233 |
|
201 | 234 |
# Localise $a, $b |
202 |
my ($caller_a, $caller_b) = do |
|
203 |
{ |
|
235 |
my ( $caller_a, $caller_b ) = do { |
|
204 | 236 |
my $pkg = caller(); |
205 | 237 |
no strict 'refs'; |
206 | 238 |
\*{$pkg.'::a'}, \*{$pkg.'::b'}; |
207 | 239 |
}; |
208 | 240 |
|
209 |
my $limit = $#A > $#B? $#A : $#B; # loop iteration limit |
|
241 |
# Loop iteration limit |
|
242 |
my $limit = $#A > $#B? $#A : $#B; |
|
210 | 243 |
|
211 |
local(*$caller_a, *$caller_b); |
|
212 |
map # This map expression is also the return value. |
|
213 |
{ |
|
214 |
# assign to $a, $b as refs to caller's array elements |
|
215 |
(*$caller_a, *$caller_b) = \($A[$_], $B[$_]); |
|
216 |
$op->(); # perform the transformation |
|
244 |
# This map expression is also the return value |
|
245 |
local( *$caller_a, *$caller_b ); |
|
246 |
map { |
|
247 |
# Assign to $a, $b as refs to caller's array elements |
|
248 |
( *$caller_a, *$caller_b ) = \( $A[$_], $B[$_] ); |
|
249 |
|
|
250 |
# Perform the transformation |
|
251 |
$op->(); |
|
217 | 252 |
} 0 .. $limit; |
218 | 253 |
} |
219 | 254 |
|
220 |
sub each_array (\@;\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@) |
|
221 |
{ |
|
255 |
sub each_array (\@;\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@) { |
|
222 | 256 |
return each_arrayref(@_); |
223 | 257 |
} |
224 | 258 |
|
225 |
sub each_arrayref |
|
226 |
{ |
|
227 |
my @arr_list = @_; # The list of references to the arrays |
|
228 |
my $index = 0; # Which one the caller will get next |
|
229 |
my $max_num = 0; # Number of elements in longest array |
|
259 |
sub each_arrayref { |
|
260 |
my @list = @_; # The list of references to the arrays |
|
261 |
my $index = 0; # Which one the caller will get next |
|
262 |
my $max = 0; # Number of elements in longest array |
|
230 | 263 |
|
231 | 264 |
# Get the length of the longest input array |
232 |
foreach (@arr_list) |
|
233 |
{ |
|
234 |
unless (ref($_) eq 'ARRAY') |
|
235 |
{ |
|
265 |
foreach ( @list ) { |
|
266 |
unless ( ref $_ eq 'ARRAY' ) { |
|
236 | 267 |
require Carp; |
237 |
Carp::croak "each_arrayref: argument is not an array reference\n";
|
|
268 |
Carp::croak("each_arrayref: argument is not an array reference\n");
|
|
238 | 269 |
} |
239 |
$max_num = @$_ if @$_ > $max_num;
|
|
270 |
$max = @$_ if @$_ > $max;
|
|
240 | 271 |
} |
241 | 272 |
|
242 | 273 |
# Return the iterator as a closure wrt the above variables. |
243 |
return sub |
|
244 |
{ |
|
245 |
if (@_) |
|
246 |
{ |
|
274 |
return sub { |
|
275 |
if ( @_ ) { |
|
247 | 276 |
my $method = shift; |
248 |
if ($method eq 'index') |
|
249 |
{ |
|
250 |
# Return current (last fetched) index |
|
251 |
return undef if $index == 0 || $index > $max_num; |
|
252 |
return $index-1; |
|
253 |
} |
|
254 |
else |
|
255 |
{ |
|
277 |
unless ( $method eq 'index' ) { |
|
256 | 278 |
require Carp; |
257 |
Carp::croak "each_array: unknown argument '$method' passed to iterator.";
|
|
279 |
Carp::croak("each_array: unknown argument '$method' passed to iterator.");
|
|
258 | 280 |
} |
281 |
|
|
282 |
# Return current (last fetched) index |
|
283 |
return undef if $index == 0 || $index > $max; |
|
284 |
return $index - 1; |
|
259 | 285 |
} |
260 | 286 |
|
261 |
return if $index >= $max_num; # No more elements to return |
|
287 |
# No more elements to return |
|
288 |
return if $index >= $max; |
|
262 | 289 |
my $i = $index++; |
263 |
return map $_->[$i], @arr_list; # Return ith elements |
|
290 |
|
|
291 |
# Return ith elements |
|
292 |
return map $_->[$i], @list; |
|
264 | 293 |
} |
265 | 294 |
} |
266 | 295 |
|
267 |
sub natatime ($@) |
|
268 |
{ |
|
269 |
my $n = shift; |
|
296 |
sub natatime ($@) { |
|
297 |
my $n = shift; |
|
270 | 298 |
my @list = @_; |
271 |
|
|
272 |
return sub |
|
273 |
{ |
|
299 |
return sub { |
|
274 | 300 |
return splice @list, 0, $n; |
275 | 301 |
} |
276 | 302 |
} |
277 | 303 |
|
278 | 304 |
sub mesh (\@\@;\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@) { |
279 | 305 |
my $max = -1; |
280 |
$max < $#$_ && ($max = $#$_) for @_; |
|
281 |
|
|
282 |
map { my $ix = $_; map $_->[$ix], @_; } 0..$max; |
|
306 |
$max < $#$_ && ( $max = $#$_ ) foreach @_; |
|
307 |
map { |
|
308 |
my $ix = $_; |
|
309 |
map $_->[$ix], @_; |
|
310 |
} 0 .. $max; |
|
283 | 311 |
} |
284 | 312 |
|
285 | 313 |
sub uniq (@) { |
286 |
my %h; |
|
287 |
my $ref = \1; |
|
288 |
map { $h{defined $_ ? $_ : $ref}++ == 0 ? $_ : () } @_; |
|
314 |
my %seen = (); |
|
315 |
grep { not $seen{$_}++ } @_; |
|
289 | 316 |
} |
290 | 317 |
|
291 | 318 |
sub minmax (@) { |
292 |
return if ! @_;
|
|
319 |
return unless @_;
|
|
293 | 320 |
my $min = my $max = $_[0]; |
294 | 321 |
|
295 |
for (my $i = 1; $i < @_; $i += 2) { |
|
296 |
if ($_[$i-1] <= $_[$i]) { |
|
297 |
$min = $_[$i-1] if $min > $_[$i-1]; |
|
298 |
$max = $_[$i] if $max < $_[$i]; |
|
299 |
} else { |
|
300 |
$min = $_[$i] if $min > $_[$i]; |
|
301 |
$max = $_[$i-1] if $max < $_[$i-1]; |
|
302 |
} |
|
303 |
} |
|
304 |
|
|
305 |
if (@_ & 1) { |
|
306 |
my $i = $#_; |
|
307 |
if ($_[$i-1] <= $_[$i]) { |
|
308 |
$min = $_[$i-1] if $min > $_[$i-1]; |
|
309 |
$max = $_[$i] if $max < $_[$i]; |
|
310 |
} else { |
|
311 |
$min = $_[$i] if $min > $_[$i]; |
|
312 |
$max = $_[$i-1] if $max < $_[$i-1]; |
|
313 |
} |
|
322 |
for ( my $i = 1; $i < @_; $i += 2 ) { |
|
323 |
if ( $_[$i-1] <= $_[$i] ) { |
|
324 |
$min = $_[$i-1] if $min > $_[$i-1]; |
|
325 |
$max = $_[$i] if $max < $_[$i]; |
|
326 |
} else { |
|
327 |
$min = $_[$i] if $min > $_[$i]; |
|
328 |
$max = $_[$i-1] if $max < $_[$i-1]; |
|
329 |
} |
|
314 | 330 |
} |
315 | 331 |
|
316 |
return ($min, $max); |
|
317 |
} |
|
318 |
|
|
319 |
sub part(&@) { |
|
320 |
my ($code, @list) = @_; |
|
321 |
my @parts; |
|
322 |
push @{ $parts[$code->($_)] }, $_ for @list; |
|
323 |
return @parts; |
|
324 |
} |
|
325 |
|
|
326 |
sub bsearch(&@) { |
|
327 |
my $code = shift; |
|
328 |
|
|
329 |
my $rc; |
|
330 |
my $i = 0; |
|
331 |
my $j = @_; |
|
332 |
do { |
|
333 |
my $k = int(($i + $j) / 2); |
|
334 |
|
|
335 |
return if $k >= @_; |
|
336 |
|
|
337 |
local *_ = \$_[$k]; |
|
338 |
$rc = $code->(); |
|
339 |
|
|
340 |
$rc == 0 and |
|
341 |
return wantarray ? $_ : 1; |
|
342 |
|
|
343 |
if ($rc < 0) { |
|
344 |
$i = $k + 1; |
|
332 |
if ( @_ & 1 ) { |
|
333 |
my $i = $#_; |
|
334 |
if ($_[$i-1] <= $_[$i]) { |
|
335 |
$min = $_[$i-1] if $min > $_[$i-1]; |
|
336 |
$max = $_[$i] if $max < $_[$i]; |
|
345 | 337 |
} else { |
346 |
$j = $k - 1; |
|
338 |
$min = $_[$i] if $min > $_[$i]; |
|
339 |
$max = $_[$i-1] if $max < $_[$i-1]; |
|
347 | 340 |
} |
348 |
} until $i > $j;
|
|
341 |
} |
|
349 | 342 |
|
350 |
return; |
|
343 |
return ($min, $max);
|
|
351 | 344 |
} |
352 | 345 |
|
353 | 346 |
sub _XScompiled { |
354 | 347 |
return 0; |
355 | 348 |
} |
356 | 349 |
|
357 |
EOP
|
|
350 |
END_PERL
|
|
358 | 351 |
die $@ if $@; |
359 | 352 |
|
353 |
# Function aliases |
|
360 | 354 |
*first_index = \&firstidx; |
361 |
*last_index = \&lastidx; |
|
355 |
*last_index = \&lastidx;
|
|
362 | 356 |
*first_value = \&firstval; |
363 |
*last_value = \&lastval; |
|
364 |
*zip = \&mesh; |
|
357 |
*last_value = \&lastval; |
|
358 |
*zip = \&mesh; |
|
359 |
*distinct = \&uniq; |
|
365 | 360 |
|
366 | 361 |
1; |
362 |
|
|
367 | 363 |
__END__ |
368 | 364 |
|
365 |
=pod |
|
366 |
|
|
369 | 367 |
=head1 NAME |
370 | 368 |
|
371 | 369 |
List::MoreUtils - Provide the stuff missing in List::Util |
372 | 370 |
|
373 | 371 |
=head1 SYNOPSIS |
374 | 372 |
|
375 |
use List::MoreUtils qw(any all none notall true false firstidx first_index |
|
376 |
lastidx last_index insert_after insert_after_string |
|
377 |
apply after after_incl before before_incl indexes |
|
378 |
firstval first_value lastval last_value each_array |
|
379 |
each_arrayref pairwise natatime mesh zip uniq minmax); |
|
373 |
use List::MoreUtils qw{ |
|
374 |
any all none notall true false |
|
375 |
firstidx first_index lastidx last_index |
|
376 |
insert_after insert_after_string |
|
377 |
apply indexes |
|
378 |
after after_incl before before_incl |
|
379 |
firstval first_value lastval last_value |
|
380 |
each_array each_arrayref |
|
381 |
pairwise natatime |
|
382 |
mesh zip uniq distinct minmax part |
|
383 |
}; |
|
380 | 384 |
|
381 | 385 |
=head1 DESCRIPTION |
382 | 386 |
|
383 |
C<List::MoreUtils> provides some trivial but commonly needed functionality on lists
|
|
384 |
which is not going to go into C<List::Util>.
|
|
387 |
B<List::MoreUtils> provides some trivial but commonly needed functionality on
|
|
388 |
lists which is not going to go into L<List::Util>.
|
|
385 | 389 |
|
386 | 390 |
All of the below functions are implementable in only a couple of lines of Perl |
387 | 391 |
code. Using the functions from this module however should give slightly better |
... | ... | |
397 | 401 |
BLOCK. Sets C<$_> for each item in LIST in turn: |
398 | 402 |
|
399 | 403 |
print "At least one value undefined" |
400 |
if any { !defined($_) } @list; |
|
404 |
if any { ! defined($_) } @list;
|
|
401 | 405 |
|
402 |
Returns false otherwise, or C<undef> if LIST is empty.
|
|
406 |
Returns false otherwise, or if LIST is empty. |
|
403 | 407 |
|
404 | 408 |
=item all BLOCK LIST |
405 | 409 |
|
... | ... | |
409 | 413 |
print "All items defined" |
410 | 414 |
if all { defined($_) } @list; |
411 | 415 |
|
412 |
Returns false otherwise, or C<undef> if LIST is empty.
|
|
416 |
Returns false otherwise, or if LIST is empty. |
|
413 | 417 |
|
414 | 418 |
=item none BLOCK LIST |
415 | 419 |
|
416 |
Logically the negation of C<any>. Returns a true value if no item in LIST meets the
|
|
417 |
criterion given through BLOCK. Sets C<$_> for each item in LIST in turn: |
|
420 |
Logically the negation of C<any>. Returns a true value if no item in LIST meets |
|
421 |
the criterion given through BLOCK. Sets C<$_> for each item in LIST in turn:
|
|
418 | 422 |
|
419 | 423 |
print "No value defined" |
420 | 424 |
if none { defined($_) } @list; |
421 | 425 |
|
422 |
Returns false otherwise, or C<undef> if LIST is empty.
|
|
426 |
Returns false otherwise, or if LIST is empty. |
|
423 | 427 |
|
424 | 428 |
=item notall BLOCK LIST |
425 | 429 |
|
426 |
Logically the negation of C<all>. Returns a true value if not all items in LIST meet |
|
427 |
the criterion given through BLOCK. Sets C<$_> for each item in LIST in turn: |
|
430 |
Logically the negation of C<all>. Returns a true value if not all items in LIST |
|
431 |
meet the criterion given through BLOCK. Sets C<$_> for each item in LIST in |
|
432 |
turn: |
|
428 | 433 |
|
429 | 434 |
print "Not all values defined" |
430 | 435 |
if notall { defined($_) } @list; |
431 | 436 |
|
432 |
Returns false otherwise, or C<undef> if LIST is empty.
|
|
437 |
Returns false otherwise, or if LIST is empty. |
|
433 | 438 |
|
434 | 439 |
=item true BLOCK LIST |
435 | 440 |
|
436 |
Counts the number of elements in LIST for which the criterion in BLOCK is true. Sets C<$_> for
|
|
437 |
each item in LIST in turn: |
|
441 |
Counts the number of elements in LIST for which the criterion in BLOCK is true. |
|
442 |
Sets C<$_> for each item in LIST in turn:
|
|
438 | 443 |
|
439 | 444 |
printf "%i item(s) are defined", true { defined($_) } @list; |
440 | 445 |
|
441 | 446 |
=item false BLOCK LIST |
442 | 447 |
|
443 |
Counts the number of elements in LIST for which the criterion in BLOCK is false. Sets C<$_> for
|
|
444 |
each item in LIST in turn: |
|
448 |
Counts the number of elements in LIST for which the criterion in BLOCK is false. |
|
449 |
Sets C<$_> for each item in LIST in turn:
|
|
445 | 450 |
|
446 | 451 |
printf "%i item(s) are not defined", false { defined($_) } @list; |
447 | 452 |
|
... | ... | |
449 | 454 |
|
450 | 455 |
=item first_index BLOCK LIST |
451 | 456 |
|
452 |
Returns the index of the first element in LIST for which the criterion in BLOCK is true. Sets C<$_>
|
|
453 |
for each item in LIST in turn: |
|
457 |
Returns the index of the first element in LIST for which the criterion in BLOCK |
|
458 |
is true. Sets C<$_> for each item in LIST in turn:
|
|
454 | 459 |
|
455 | 460 |
my @list = (1, 4, 3, 2, 4, 6); |
456 | 461 |
printf "item with index %i in list is 4", firstidx { $_ == 4 } @list; |
... | ... | |
465 | 470 |
|
466 | 471 |
=item last_index BLOCK LIST |
467 | 472 |
|
468 |
Returns the index of the last element in LIST for which the criterion in BLOCK is true. Sets C<$_>
|
|
469 |
for each item in LIST in turn: |
|
473 |
Returns the index of the last element in LIST for which the criterion in BLOCK |
|
474 |
is true. Sets C<$_> for each item in LIST in turn:
|
|
470 | 475 |
|
471 | 476 |
my @list = (1, 4, 3, 2, 4, 6); |
472 | 477 |
printf "item with index %i in list is 4", lastidx { $_ == 4 } @list; |
... | ... | |
479 | 484 |
|
480 | 485 |
=item insert_after BLOCK VALUE LIST |
481 | 486 |
|
482 |
Inserts VALUE after the first item in LIST for which the criterion in BLOCK is true. Sets C<$_> for
|
|
483 |
each item in LIST in turn. |
|
487 |
Inserts VALUE after the first item in LIST for which the criterion in BLOCK is |
|
488 |
true. Sets C<$_> for each item in LIST in turn.
|
|
484 | 489 |
|
485 | 490 |
my @list = qw/This is a list/; |
486 | 491 |
insert_after { $_ eq "a" } "longer" => @list; |
... | ... | |
517 | 522 |
|
518 | 523 |
for (my @mult = @list) { $_ *= 2 } |
519 | 524 |
|
525 |
=item before BLOCK LIST |
|
526 |
|
|
527 |
Returns a list of values of LIST upto (and not including) the point where BLOCK |
|
528 |
returns a true value. Sets C<$_> for each element in LIST in turn. |
|
529 |
|
|
530 |
=item before_incl BLOCK LIST |
|
531 |
|
|
532 |
Same as C<before> but also includes the element for which BLOCK is true. |
|
533 |
|
|
520 | 534 |
=item after BLOCK LIST |
521 | 535 |
|
522 | 536 |
Returns a list of the values of LIST after (and not including) the point |
... | ... | |
528 | 542 |
|
529 | 543 |
Same as C<after> but also inclues the element for which BLOCK is true. |
530 | 544 |
|
531 |
=item before BLOCK LIST |
|
532 |
|
|
533 |
Returns a list of values of LIST upto (and not including) the point where BLOCK |
|
534 |
returns a true value. Sets C<$_> for each element in LIST in turn. |
|
535 |
|
|
536 |
=item before_incl BLOCK LIST |
|
537 |
|
|
538 |
Same as C<before> but also includes the element for which BLOCK is true. |
|
539 |
|
|
540 | 545 |
=item indexes BLOCK LIST |
541 | 546 |
|
542 | 547 |
Evaluates BLOCK for each element in LIST (assigned to C<$_>) and returns a list |
... | ... | |
646 | 651 |
|
647 | 652 |
=item uniq LIST |
648 | 653 |
|
654 |
=item distinct LIST |
|
655 |
|
|
649 | 656 |
Returns a new list by stripping duplicate values in LIST. The order of |
650 | 657 |
elements in the returned list is the same as in LIST. In scalar context, |
651 | 658 |
returns the number of unique elements in LIST. |
... | ... | |
656 | 663 |
=item minmax LIST |
657 | 664 |
|
658 | 665 |
Calculates the minimum and maximum of LIST and returns a two element list with |
659 |
the first element being the minimum and the second the maximum. Returns the empty
|
|
660 |
list if LIST was empty. |
|
666 |
the first element being the minimum and the second the maximum. Returns the |
|
667 |
empty list if LIST was empty.
|
|
661 | 668 |
|
662 |
The minmax algorithm differs from a naive iteration over the list where each element |
|
663 |
is compared to two values being the so far calculated min and max value in that it |
|
664 |
only requires 3n/2 - 2 comparisons. Thus it is the most efficient possible algorithm. |
|
669 |
The C<minmax> algorithm differs from a naive iteration over the list where each |
|
670 |
element is compared to two values being the so far calculated min and max value |
|
671 |
in that it only requires 3n/2 - 2 comparisons. Thus it is the most efficient |
|
672 |
possible algorithm. |
|
665 | 673 |
|
666 | 674 |
However, the Perl implementation of it has some overhead simply due to the fact |
667 | 675 |
that there are more lines of Perl code involved. Therefore, LIST needs to be |
668 |
fairly big in order for minmax to win over a naive implementation. This
|
|
676 |
fairly big in order for C<minmax> to win over a naive implementation. This
|
|
669 | 677 |
limitation does not apply to the XS version. |
670 | 678 |
|
671 | 679 |
=item part BLOCK LIST |
672 | 680 |
|
673 |
Partitions LIST based on the return value of BLOCK which denotes into which partition
|
|
674 |
the current value is put. |
|
681 |
Partitions LIST based on the return value of BLOCK which denotes into which |
|
682 |
partition the current value is put.
|
|
675 | 683 |
|
676 | 684 |
Returns a list of the partitions thusly created. Each partition created is a |
677 | 685 |
reference to an array. |
... | ... | |
692 | 700 |
|
693 | 701 |
Negative values are only ok when they refer to a partition previously created: |
694 | 702 |
|
695 |
my @idx = (0, 1, -1); |
|
696 |
my $i = 0; |
|
697 |
my @part = part { $idx[$++ % 3] } 1 .. 8; # [1, 4, 7], [2, 3, 5, 6, 8] |
|
698 |
|
|
699 |
=item bsearch BLOCK LIST |
|
700 |
|
|
701 |
Performs a binary search on LIST which must be a sorted list of values. BLOCK |
|
702 |
must return a negative value if the current element (stored in C<$_>) is smaller, |
|
703 |
a positive value if it is bigger and zero if it matches. |
|
704 |
|
|
705 |
Returns a boolean value in scalar context. In list context, it returns the element |
|
706 |
if it was found, otherwise the empty list. |
|
703 |
my @idx = ( 0, 1, -1 ); |
|
704 |
my $i = 0; |
|
705 |
my @part = part { $idx[$++ % 3] } 1 .. 8; # [1, 4, 7], [2, 3, 5, 6, 8] |
|
707 | 706 |
|
708 | 707 |
=back |
709 | 708 |
|
... | ... | |
711 | 710 |
|
712 | 711 |
Nothing by default. To import all of this module's symbols, do the conventional |
713 | 712 |
|
714 |
use List::MoreUtils qw/:all/;
|
|
713 |
use List::MoreUtils ':all';
|
|
715 | 714 |
|
716 |
It may make more sense though to only import the stuff your program actually needs: |
|
715 |
It may make more sense though to only import the stuff your program actually |
|
716 |
needs: |
|
717 | 717 |
|
718 |
use List::MoreUtils qw/any firstidx/;
|
|
718 |
use List::MoreUtils qw{ any firstidx };
|
|
719 | 719 |
|
720 | 720 |
=head1 ENVIRONMENT |
721 | 721 |
|
... | ... | |
725 | 725 |
for reporting of bugs. I don't see any reason to use it in a production |
726 | 726 |
environment. |
727 | 727 |
|
728 |
=head1 VERSION |
|
729 |
|
|
730 |
This is version 0.25_01. |
|
731 |
|
|
732 | 728 |
=head1 BUGS |
733 | 729 |
|
734 | 730 |
There is a problem with a bug in 5.6.x perls. It is a syntax error to write |
735 | 731 |
things like: |
736 | 732 |
|
737 |
my @x = apply { s/foo/bar/ } qw/foo bar baz/;
|
|
733 |
my @x = apply { s/foo/bar/ } qw{ foo bar baz };
|
|
738 | 734 |
|
739 | 735 |
It has to be written as either |
740 | 736 |
|
... | ... | |
744 | 740 |
|
745 | 741 |
my @x = apply { s/foo/bar/ } my @dummy = qw/foo bar baz/; |
746 | 742 |
|
747 |
Perl5.5.x and perl5.8.x don't suffer from this limitation.
|
|
743 |
Perl 5.5.x and Perl 5.8.x don't suffer from this limitation.
|
|
748 | 744 |
|
749 | 745 |
If you have a functionality that you could imagine being in this module, please |
750 |
drop me a line. This module's policy will be less strict than C<List::Util>'s when
|
|
751 |
it comes to additions as it isn't a core module. |
|
746 |
drop me a line. This module's policy will be less strict than L<List::Util>'s
|
|
747 |
when it comes to additions as it isn't a core module.
|
|
752 | 748 |
|
753 | 749 |
When you report bugs, it would be nice if you could additionally give me the |
754 | 750 |
output of your program with the environment variable C<LIST_MOREUTILS_PP> set |
755 | 751 |
to a true value. That way I know where to look for the problem (in XS, |
756 | 752 |
pure-Perl or possibly both). |
757 | 753 |
|
754 |
=head1 SUPPORT |
|
755 |
|
|
756 |
Bugs should always be submitted via the CPAN bug tracker. |
|
757 |
|
|
758 |
L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=List-MoreUtils> |
|
759 |
|
|
758 | 760 |
=head1 THANKS |
759 | 761 |
|
760 | 762 |
Credits go to a number of people: Steve Purkis for giving me namespace advice |
761 | 763 |
and James Keenan and Terrence Branno for their effort of keeping the CPAN |
762 |
tidier by making List::Utils obsolete.
|
|
764 |
tidier by making L<List::Utils> obsolete.
|
|
763 | 765 |
|
764 | 766 |
Brian McCauley suggested the inclusion of apply() and provided the pure-Perl |
765 | 767 |
implementation for it. |
... | ... | |
788 | 790 |
|
789 | 791 |
=head1 TODO |
790 | 792 |
|
791 |
A pile of requests from other people is still pending further processing in my
|
|
792 |
mailbox. This includes: |
|
793 |
A pile of requests from other people is still pending further processing in |
|
794 |
my mailbox. This includes:
|
|
793 | 795 |
|
794 | 796 |
=over 4 |
795 | 797 |
|
798 |
=item * List::Util export pass-through |
|
799 |
|
|
800 |
Allow B<List::MoreUtils> to pass-through the regular L<List::Util> |
|
801 |
functions to end users only need to C<use> the one module. |
|
802 |
|
|
796 | 803 |
=item * uniq_by(&@) |
797 | 804 |
|
798 | 805 |
Use code-reference to extract a key based on which the uniqueness is |
... | ... | |
816 | 823 |
|
817 | 824 |
=item * listify |
818 | 825 |
|
819 |
Always return a flat list when either a simple scalar value was passed or an array-reference.
|
|
820 |
Suggested by Mark Summersault. |
|
826 |
Always return a flat list when either a simple scalar value was passed or an |
|
827 |
array-reference. Suggested by Mark Summersault.
|
|
821 | 828 |
|
822 | 829 |
=back |
823 | 830 |
|
... | ... | |
827 | 834 |
|
828 | 835 |
=head1 AUTHOR |
829 | 836 |
|
830 |
Tassilo von Parseval, E<lt>vparseval@gmail.comE<gt>
|
|
837 |
Tassilo von Parseval E<lt>tassilo.von.parseval@rwth-aachen.deE<gt>
|
|
831 | 838 |
|
832 | 839 |
=head1 COPYRIGHT AND LICENSE |
833 | 840 |
|
834 |
Copyright (C) 2004-2009 by Tassilo von Parseval
|
|
841 |
Copyright 2004 - 2010 by Tassilo von Parseval
|
|
835 | 842 |
|
836 | 843 |
This library is free software; you can redistribute it and/or modify |
837 | 844 |
it under the same terms as Perl itself, either Perl version 5.8.4 or, |
Auch abrufbar als: Unified diff
Update auf List::MoreUtils v0.30