X-Git-Url: http://wagnertech.de/gitweb/gitweb.cgi/mfinanz.git/blobdiff_plain/deb4d2dbb676d7d6f69dfe7815d6e0cb09bd4a44..53593baa211863fbf66540cf1bcc36c8fb37257f:/modules/fallback/List/MoreUtils.pm diff --git a/modules/fallback/List/MoreUtils.pm b/modules/fallback/List/MoreUtils.pm deleted file mode 100644 index 1251b532d..000000000 --- a/modules/fallback/List/MoreUtils.pm +++ /dev/null @@ -1,847 +0,0 @@ -package List::MoreUtils; - -use 5.00503; -use strict; -use Exporter (); -use DynaLoader (); - -use vars qw{ $VERSION @ISA @EXPORT_OK %EXPORT_TAGS }; -BEGIN { - $VERSION = '0.30'; - @ISA = qw{ Exporter DynaLoader }; - @EXPORT_OK = qw{ - any all none notall true false - firstidx first_index lastidx last_index - insert_after insert_after_string - apply indexes - after after_incl before before_incl - firstval first_value lastval last_value - each_array each_arrayref - pairwise natatime - mesh zip uniq distinct - minmax part - }; - %EXPORT_TAGS = ( - all => \@EXPORT_OK, - ); - - # Load the XS at compile-time so that redefinition warnings will be - # thrown correctly if the XS versions of part or indexes loaded - eval { - # PERL_DL_NONLAZY must be false, or any errors in loading will just - # cause the perl code to be tested - local $ENV{PERL_DL_NONLAZY} = 0 if $ENV{PERL_DL_NONLAZY}; - - bootstrap List::MoreUtils $VERSION; - 1; - - } unless $ENV{LIST_MOREUTILS_PP}; -} - -# Always use Perl apply() until memory leaks are resolved. -sub apply (&@) { - my $action = shift; - &$action foreach my @values = @_; - wantarray ? @values : $values[-1]; -} - -# Always use Perl part() until memory leaks are resolved. -sub part (&@) { - my ($code, @list) = @_; - my @parts; - push @{ $parts[ $code->($_) ] }, $_ foreach @list; - return @parts; -} - -# Always use Perl indexes() until memory leaks are resolved. -sub indexes (&@) { - my $test = shift; - grep { - local *_ = \$_[$_]; - $test->() - } 0 .. $#_; -} - -# Load the pure-Perl versions of the other functions if needed -eval <<'END_PERL' unless defined &any; - -# Use pure scalar boolean return values for compatibility with XS -use constant YES => ! 0; -use constant NO => ! 1; - -sub any (&@) { - my $f = shift; - foreach ( @_ ) { - return YES if $f->(); - } - return NO; -} - -sub all (&@) { - my $f = shift; - foreach ( @_ ) { - return NO unless $f->(); - } - return YES; -} - -sub none (&@) { - my $f = shift; - foreach ( @_ ) { - return NO if $f->(); - } - return YES; -} - -sub notall (&@) { - my $f = shift; - foreach ( @_ ) { - return YES unless $f->(); - } - return NO; -} - -sub true (&@) { - my $f = shift; - my $count = 0; - foreach ( @_ ) { - $count++ if $f->(); - } - return $count; -} - -sub false (&@) { - my $f = shift; - my $count = 0; - foreach ( @_ ) { - $count++ unless $f->(); - } - return $count; -} - -sub firstidx (&@) { - my $f = shift; - foreach my $i ( 0 .. $#_ ) { - local *_ = \$_[$i]; - return $i if $f->(); - } - return -1; -} - -sub lastidx (&@) { - my $f = shift; - foreach my $i ( reverse 0 .. $#_ ) { - local *_ = \$_[$i]; - return $i if $f->(); - } - return -1; -} - -sub insert_after (&$\@) { - my ($f, $val, $list) = @_; - my $c = -1; - local *_; - foreach my $i ( 0 .. $#$list ) { - $_ = $list->[$i]; - $c = $i, last if $f->(); - } - @$list = ( - @{$list}[ 0 .. $c ], - $val, - @{$list}[ $c + 1 .. $#$list ], - ) and return 1 if $c != -1; - return 0; -} - -sub insert_after_string ($$\@) { - my ($string, $val, $list) = @_; - my $c = -1; - foreach my $i ( 0 .. $#$list ) { - local $^W = 0; - $c = $i, last if $string eq $list->[$i]; - } - @$list = ( - @{$list}[ 0 .. $c ], - $val, - @{$list}[ $c + 1 .. $#$list ], - ) and return 1 if $c != -1; - return 0; -} - -sub after (&@) { - my $test = shift; - my $started; - my $lag; - grep $started ||= do { - my $x = $lag; - $lag = $test->(); - $x - }, @_; -} - -sub after_incl (&@) { - my $test = shift; - my $started; - grep $started ||= $test->(), @_; -} - -sub before (&@) { - my $test = shift; - my $more = 1; - grep $more &&= ! $test->(), @_; -} - -sub before_incl (&@) { - my $test = shift; - my $more = 1; - my $lag = 1; - grep $more &&= do { - my $x = $lag; - $lag = ! $test->(); - $x - }, @_; -} - -sub lastval (&@) { - my $test = shift; - my $ix; - for ( $ix = $#_; $ix >= 0; $ix-- ) { - local *_ = \$_[$ix]; - my $testval = $test->(); - - # Simulate $_ as alias - $_[$ix] = $_; - return $_ if $testval; - } - return undef; -} - -sub firstval (&@) { - my $test = shift; - foreach ( @_ ) { - return $_ if $test->(); - } - return undef; -} - -sub pairwise (&\@\@) { - my $op = shift; - - # Symbols for caller's input arrays - use vars qw{ @A @B }; - local ( *A, *B ) = @_; - - # Localise $a, $b - my ( $caller_a, $caller_b ) = do { - my $pkg = caller(); - no strict 'refs'; - \*{$pkg.'::a'}, \*{$pkg.'::b'}; - }; - - # Loop iteration limit - my $limit = $#A > $#B? $#A : $#B; - - # This map expression is also the return value - local( *$caller_a, *$caller_b ); - map { - # Assign to $a, $b as refs to caller's array elements - ( *$caller_a, *$caller_b ) = \( $A[$_], $B[$_] ); - - # Perform the transformation - $op->(); - } 0 .. $limit; -} - -sub each_array (\@;\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@) { - return each_arrayref(@_); -} - -sub each_arrayref { - my @list = @_; # The list of references to the arrays - my $index = 0; # Which one the caller will get next - my $max = 0; # Number of elements in longest array - - # Get the length of the longest input array - foreach ( @list ) { - unless ( ref $_ eq 'ARRAY' ) { - require Carp; - Carp::croak("each_arrayref: argument is not an array reference\n"); - } - $max = @$_ if @$_ > $max; - } - - # Return the iterator as a closure wrt the above variables. - return sub { - if ( @_ ) { - my $method = shift; - unless ( $method eq 'index' ) { - require Carp; - Carp::croak("each_array: unknown argument '$method' passed to iterator."); - } - - # Return current (last fetched) index - return undef if $index == 0 || $index > $max; - return $index - 1; - } - - # No more elements to return - return if $index >= $max; - my $i = $index++; - - # Return ith elements - return map $_->[$i], @list; - } -} - -sub natatime ($@) { - my $n = shift; - my @list = @_; - return sub { - return splice @list, 0, $n; - } -} - -sub mesh (\@\@;\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@) { - my $max = -1; - $max < $#$_ && ( $max = $#$_ ) foreach @_; - map { - my $ix = $_; - map $_->[$ix], @_; - } 0 .. $max; -} - -sub uniq (@) { - my %seen = (); - grep { not $seen{$_}++ } @_; -} - -sub minmax (@) { - return unless @_; - my $min = my $max = $_[0]; - - for ( my $i = 1; $i < @_; $i += 2 ) { - if ( $_[$i-1] <= $_[$i] ) { - $min = $_[$i-1] if $min > $_[$i-1]; - $max = $_[$i] if $max < $_[$i]; - } else { - $min = $_[$i] if $min > $_[$i]; - $max = $_[$i-1] if $max < $_[$i-1]; - } - } - - if ( @_ & 1 ) { - my $i = $#_; - if ($_[$i-1] <= $_[$i]) { - $min = $_[$i-1] if $min > $_[$i-1]; - $max = $_[$i] if $max < $_[$i]; - } else { - $min = $_[$i] if $min > $_[$i]; - $max = $_[$i-1] if $max < $_[$i-1]; - } - } - - return ($min, $max); -} - -sub _XScompiled { - return 0; -} - -END_PERL -die $@ if $@; - -# Function aliases -*first_index = \&firstidx; -*last_index = \&lastidx; -*first_value = \&firstval; -*last_value = \&lastval; -*zip = \&mesh; -*distinct = \&uniq; - -1; - -__END__ - -=pod - -=head1 NAME - -List::MoreUtils - Provide the stuff missing in List::Util - -=head1 SYNOPSIS - - use List::MoreUtils qw{ - any all none notall true false - firstidx first_index lastidx last_index - insert_after insert_after_string - apply indexes - after after_incl before before_incl - firstval first_value lastval last_value - each_array each_arrayref - pairwise natatime - mesh zip uniq distinct minmax part - }; - -=head1 DESCRIPTION - -B provides some trivial but commonly needed functionality on -lists which is not going to go into L. - -All of the below functions are implementable in only a couple of lines of Perl -code. Using the functions from this module however should give slightly better -performance as everything is implemented in C. The pure-Perl implementation of -these functions only serves as a fallback in case the C portions of this module -couldn't be compiled on this machine. - -=over 4 - -=item any BLOCK LIST - -Returns a true value if any item in LIST meets the criterion given through -BLOCK. Sets C<$_> for each item in LIST in turn: - - print "At least one value undefined" - if any { ! defined($_) } @list; - -Returns false otherwise, or if LIST is empty. - -=item all BLOCK LIST - -Returns a true value if all items in LIST meet the criterion given through -BLOCK. Sets C<$_> for each item in LIST in turn: - - print "All items defined" - if all { defined($_) } @list; - -Returns false otherwise, or if LIST is empty. - -=item none BLOCK LIST - -Logically the negation of C. Returns a true value if no item in LIST meets -the criterion given through BLOCK. Sets C<$_> for each item in LIST in turn: - - print "No value defined" - if none { defined($_) } @list; - -Returns false otherwise, or if LIST is empty. - -=item notall BLOCK LIST - -Logically the negation of C. Returns a true value if not all items in LIST -meet the criterion given through BLOCK. Sets C<$_> for each item in LIST in -turn: - - print "Not all values defined" - if notall { defined($_) } @list; - -Returns false otherwise, or if LIST is empty. - -=item true BLOCK LIST - -Counts the number of elements in LIST for which the criterion in BLOCK is true. -Sets C<$_> for each item in LIST in turn: - - printf "%i item(s) are defined", true { defined($_) } @list; - -=item false BLOCK LIST - -Counts the number of elements in LIST for which the criterion in BLOCK is false. -Sets C<$_> for each item in LIST in turn: - - printf "%i item(s) are not defined", false { defined($_) } @list; - -=item firstidx BLOCK LIST - -=item first_index BLOCK LIST - -Returns the index of the first element in LIST for which the criterion in BLOCK -is true. Sets C<$_> for each item in LIST in turn: - - my @list = (1, 4, 3, 2, 4, 6); - printf "item with index %i in list is 4", firstidx { $_ == 4 } @list; - __END__ - item with index 1 in list is 4 - -Returns C<-1> if no such item could be found. - -C is an alias for C. - -=item lastidx BLOCK LIST - -=item last_index BLOCK LIST - -Returns the index of the last element in LIST for which the criterion in BLOCK -is true. Sets C<$_> for each item in LIST in turn: - - my @list = (1, 4, 3, 2, 4, 6); - printf "item with index %i in list is 4", lastidx { $_ == 4 } @list; - __END__ - item with index 4 in list is 4 - -Returns C<-1> if no such item could be found. - -C is an alias for C. - -=item insert_after BLOCK VALUE LIST - -Inserts VALUE after the first item in LIST for which the criterion in BLOCK is -true. Sets C<$_> for each item in LIST in turn. - - my @list = qw/This is a list/; - insert_after { $_ eq "a" } "longer" => @list; - print "@list"; - __END__ - This is a longer list - -=item insert_after_string STRING VALUE LIST - -Inserts VALUE after the first item in LIST which is equal to STRING. - - my @list = qw/This is a list/; - insert_after_string "a", "longer" => @list; - print "@list"; - __END__ - This is a longer list - -=item apply BLOCK LIST - -Applies BLOCK to each item in LIST and returns a list of the values after BLOCK -has been applied. In scalar context, the last element is returned. This -function is similar to C but will not modify the elements of the input -list: - - my @list = (1 .. 4); - my @mult = apply { $_ *= 2 } @list; - print "\@list = @list\n"; - print "\@mult = @mult\n"; - __END__ - @list = 1 2 3 4 - @mult = 2 4 6 8 - -Think of it as syntactic sugar for - - for (my @mult = @list) { $_ *= 2 } - -=item before BLOCK LIST - -Returns a list of values of LIST upto (and not including) the point where BLOCK -returns a true value. Sets C<$_> for each element in LIST in turn. - -=item before_incl BLOCK LIST - -Same as C but also includes the element for which BLOCK is true. - -=item after BLOCK LIST - -Returns a list of the values of LIST after (and not including) the point -where BLOCK returns a true value. Sets C<$_> for each element in LIST in turn. - - @x = after { $_ % 5 == 0 } (1..9); # returns 6, 7, 8, 9 - -=item after_incl BLOCK LIST - -Same as C but also inclues the element for which BLOCK is true. - -=item indexes BLOCK LIST - -Evaluates BLOCK for each element in LIST (assigned to C<$_>) and returns a list -of the indices of those elements for which BLOCK returned a true value. This is -just like C only that it returns indices instead of values: - - @x = indexes { $_ % 2 == 0 } (1..10); # returns 1, 3, 5, 7, 9 - -=item firstval BLOCK LIST - -=item first_value BLOCK LIST - -Returns the first element in LIST for which BLOCK evaluates to true. Each -element of LIST is set to C<$_> in turn. Returns C if no such element -has been found. - -C is an alias for C. - -=item lastval BLOCK LIST - -=item last_value BLOCK LIST - -Returns the last value in LIST for which BLOCK evaluates to true. Each element -of LIST is set to C<$_> in turn. Returns C if no such element has been -found. - -C is an alias for C. - -=item pairwise BLOCK ARRAY1 ARRAY2 - -Evaluates BLOCK for each pair of elements in ARRAY1 and ARRAY2 and returns a -new list consisting of BLOCK's return values. The two elements are set to C<$a> -and C<$b>. Note that those two are aliases to the original value so changing -them will modify the input arrays. - - @a = (1 .. 5); - @b = (11 .. 15); - @x = pairwise { $a + $b } @a, @b; # returns 12, 14, 16, 18, 20 - - # mesh with pairwise - @a = qw/a b c/; - @b = qw/1 2 3/; - @x = pairwise { ($a, $b) } @a, @b; # returns a, 1, b, 2, c, 3 - -=item each_array ARRAY1 ARRAY2 ... - -Creates an array iterator to return the elements of the list of arrays ARRAY1, -ARRAY2 throughout ARRAYn in turn. That is, the first time it is called, it -returns the first element of each array. The next time, it returns the second -elements. And so on, until all elements are exhausted. - -This is useful for looping over more than one array at once: - - my $ea = each_array(@a, @b, @c); - while ( my ($a, $b, $c) = $ea->() ) { .... } - -The iterator returns the empty list when it reached the end of all arrays. - -If the iterator is passed an argument of 'C', then it retuns -the index of the last fetched set of values, as a scalar. - -=item each_arrayref LIST - -Like each_array, but the arguments are references to arrays, not the -plain arrays. - -=item natatime BLOCK LIST - -Creates an array iterator, for looping over an array in chunks of -C<$n> items at a time. (n at a time, get it?). An example is -probably a better explanation than I could give in words. - -Example: - - my @x = ('a' .. 'g'); - my $it = natatime 3, @x; - while (my @vals = $it->()) - { - print "@vals\n"; - } - -This prints - - a b c - d e f - g - -=item mesh ARRAY1 ARRAY2 [ ARRAY3 ... ] - -=item zip ARRAY1 ARRAY2 [ ARRAY3 ... ] - -Returns a list consisting of the first elements of each array, then -the second, then the third, etc, until all arrays are exhausted. - -Examples: - - @x = qw/a b c d/; - @y = qw/1 2 3 4/; - @z = mesh @x, @y; # returns a, 1, b, 2, c, 3, d, 4 - - @a = ('x'); - @b = ('1', '2'); - @c = qw/zip zap zot/; - @d = mesh @a, @b, @c; # x, 1, zip, undef, 2, zap, undef, undef, zot - -C is an alias for C. - -=item uniq LIST - -=item distinct LIST - -Returns a new list by stripping duplicate values in LIST. The order of -elements in the returned list is the same as in LIST. In scalar context, -returns the number of unique elements in LIST. - - my @x = uniq 1, 1, 2, 2, 3, 5, 3, 4; # returns 1 2 3 5 4 - my $x = uniq 1, 1, 2, 2, 3, 5, 3, 4; # returns 5 - -=item minmax LIST - -Calculates the minimum and maximum of LIST and returns a two element list with -the first element being the minimum and the second the maximum. Returns the -empty list if LIST was empty. - -The C algorithm differs from a naive iteration over the list where each -element is compared to two values being the so far calculated min and max value -in that it only requires 3n/2 - 2 comparisons. Thus it is the most efficient -possible algorithm. - -However, the Perl implementation of it has some overhead simply due to the fact -that there are more lines of Perl code involved. Therefore, LIST needs to be -fairly big in order for C to win over a naive implementation. This -limitation does not apply to the XS version. - -=item part BLOCK LIST - -Partitions LIST based on the return value of BLOCK which denotes into which -partition the current value is put. - -Returns a list of the partitions thusly created. Each partition created is a -reference to an array. - - my $i = 0; - my @part = part { $i++ % 2 } 1 .. 8; # returns [1, 3, 5, 7], [2, 4, 6, 8] - -You can have a sparse list of partitions as well where non-set partitions will -be undef: - - my @part = part { 2 } 1 .. 10; # returns undef, undef, [ 1 .. 10 ] - -Be careful with negative values, though: - - my @part = part { -1 } 1 .. 10; - __END__ - Modification of non-creatable array value attempted, subscript -1 ... - -Negative values are only ok when they refer to a partition previously created: - - my @idx = ( 0, 1, -1 ); - my $i = 0; - my @part = part { $idx[$++ % 3] } 1 .. 8; # [1, 4, 7], [2, 3, 5, 6, 8] - -=back - -=head1 EXPORTS - -Nothing by default. To import all of this module's symbols, do the conventional - - use List::MoreUtils ':all'; - -It may make more sense though to only import the stuff your program actually -needs: - - use List::MoreUtils qw{ any firstidx }; - -=head1 ENVIRONMENT - -When C is set, the module will always use the pure-Perl -implementation and not the XS one. This environment variable is really just -there for the test-suite to force testing the Perl implementation, and possibly -for reporting of bugs. I don't see any reason to use it in a production -environment. - -=head1 BUGS - -There is a problem with a bug in 5.6.x perls. It is a syntax error to write -things like: - - my @x = apply { s/foo/bar/ } qw{ foo bar baz }; - -It has to be written as either - - my @x = apply { s/foo/bar/ } 'foo', 'bar', 'baz'; - -or - - my @x = apply { s/foo/bar/ } my @dummy = qw/foo bar baz/; - -Perl 5.5.x and Perl 5.8.x don't suffer from this limitation. - -If you have a functionality that you could imagine being in this module, please -drop me a line. This module's policy will be less strict than L's -when it comes to additions as it isn't a core module. - -When you report bugs, it would be nice if you could additionally give me the -output of your program with the environment variable C set -to a true value. That way I know where to look for the problem (in XS, -pure-Perl or possibly both). - -=head1 SUPPORT - -Bugs should always be submitted via the CPAN bug tracker. - -L - -=head1 THANKS - -Credits go to a number of people: Steve Purkis for giving me namespace advice -and James Keenan and Terrence Branno for their effort of keeping the CPAN -tidier by making L obsolete. - -Brian McCauley suggested the inclusion of apply() and provided the pure-Perl -implementation for it. - -Eric J. Roode asked me to add all functions from his module C -into this one. With minor modifications, the pure-Perl implementations of those -are by him. - -The bunch of people who almost immediately pointed out the many problems with -the glitchy 0.07 release (Slaven Rezic, Ron Savage, CPAN testers). - -A particularly nasty memory leak was spotted by Thomas A. Lowery. - -Lars Thegler made me aware of problems with older Perl versions. - -Anno Siegel de-orphaned each_arrayref(). - -David Filmer made me aware of a problem in each_arrayref that could ultimately -lead to a segfault. - -Ricardo Signes suggested the inclusion of part() and provided the -Perl-implementation. - -Robin Huston kindly fixed a bug in perl's MULTICALL API to make the -XS-implementation of part() work. - -=head1 TODO - -A pile of requests from other people is still pending further processing in -my mailbox. This includes: - -=over 4 - -=item * List::Util export pass-through - -Allow B to pass-through the regular L -functions to end users only need to C the one module. - -=item * uniq_by(&@) - -Use code-reference to extract a key based on which the uniqueness is -determined. Suggested by Aaron Crane. - -=item * delete_index - -=item * random_item - -=item * random_item_delete_index - -=item * list_diff_hash - -=item * list_diff_inboth - -=item * list_diff_infirst - -=item * list_diff_insecond - -These were all suggested by Dan Muey. - -=item * listify - -Always return a flat list when either a simple scalar value was passed or an -array-reference. Suggested by Mark Summersault. - -=back - -=head1 SEE ALSO - -L - -=head1 AUTHOR - -Tassilo von Parseval Etassilo.von.parseval@rwth-aachen.deE - -=head1 COPYRIGHT AND LICENSE - -Copyright 2004 - 2010 by Tassilo von Parseval - -This library is free software; you can redistribute it and/or modify -it under the same terms as Perl itself, either Perl version 5.8.4 or, -at your option, any later version of Perl 5 you may have available. - -=cut