List-MoreUtils-0.430/0000755000175000017500000000000013744044757012553 5ustar snosnoList-MoreUtils-0.430/lib/0000755000175000017500000000000013744044757013321 5ustar snosnoList-MoreUtils-0.430/lib/List/0000755000175000017500000000000013744044757014234 5ustar snosnoList-MoreUtils-0.430/lib/List/MoreUtils.pm0000644000175000017500000011544413744035161016513 0ustar snosnopackage List::MoreUtils; use 5.008_001; use strict; use warnings; my $have_xs; our $VERSION = '0.430'; BEGIN { unless (defined($have_xs)) { ## no critic (ErrorHandling::RequireCheckingReturnValueOfEval) eval { require List::MoreUtils::XS; } unless $ENV{LIST_MOREUTILS_PP}; ## no critic (ErrorHandling::RequireCarping) die $@ if $@ && defined $ENV{LIST_MOREUTILS_PP} && $ENV{LIST_MOREUTILS_PP} == 0; $have_xs = 0 + defined($INC{'List/MoreUtils/XS.pm'}); } use List::MoreUtils::PP qw(); } use Exporter::Tiny qw(); my @junctions = qw(any all none notall); my @v0_22 = qw( true false firstidx lastidx insert_after insert_after_string apply indexes after after_incl before before_incl firstval lastval each_array each_arrayref pairwise natatime mesh uniq minmax part _XScompiled ); my @v0_24 = qw(bsearch); my @v0_33 = qw(sort_by nsort_by); my @v0_400 = qw(one any_u all_u none_u notall_u one_u firstres onlyidx onlyval onlyres lastres singleton bsearchidx ); my @v0_420 = qw(arrayify duplicates minmaxstr samples zip6 reduce_0 reduce_1 reduce_u listcmp frequency occurrences mode binsert bremove equal_range lower_bound upper_bound qsort slide slideatatime); my @all_functions = (@junctions, @v0_22, @v0_24, @v0_33, @v0_400, @v0_420); ## no critic (TestingAndDebugging::ProhibitNoStrict) no strict "refs"; if ($have_xs) { my $x; for (@all_functions) { List::MoreUtils->can($_) or *$_ = $x if ($x = List::MoreUtils::XS->can($_)); } } List::MoreUtils->can($_) or *$_ = List::MoreUtils::PP->can($_) for (@all_functions); use strict; ## use critic (TestingAndDebugging::ProhibitNoStrict) use parent qw(Exporter::Tiny); my %alias_list = ( v0_22 => { first_index => "firstidx", last_index => "lastidx", first_value => "firstval", last_value => "lastval", zip => "mesh", }, v0_33 => { distinct => "uniq", }, v0_400 => { first_result => "firstres", only_index => "onlyidx", only_value => "onlyval", only_result => "onlyres", last_result => "lastres", bsearch_index => "bsearchidx", }, v0_420 => { bsearch_insert => "binsert", bsearch_remove => "bremove", zip_unflatten => "zip6", }, ); our @EXPORT_OK = (@all_functions, map { keys %$_ } values %alias_list); our %EXPORT_TAGS = ( all => \@EXPORT_OK, 'like_0.22' => [ any_u => {-as => 'any'}, all_u => {-as => 'all'}, none_u => {-as => 'none'}, notall_u => {-as => 'notall'}, @v0_22, keys %{$alias_list{v0_22}}, ], 'like_0.24' => [ any_u => {-as => 'any'}, all_u => {-as => 'all'}, notall_u => {-as => 'notall'}, 'none', @v0_22, @v0_24, keys %{$alias_list{v0_22}}, ], 'like_0.33' => [ @junctions, @v0_22, # v0_24 functions were omitted @v0_33, keys %{$alias_list{v0_22}}, keys %{$alias_list{v0_33}}, ], ); for my $set (values %alias_list) { for my $alias (keys %$set) { ## no critic (TestingAndDebugging::ProhibitNoStrict) no strict qw(refs); *$alias = __PACKAGE__->can($set->{$alias}); ## use critic (TestingAndDebugging::ProhibitNoStrict) } } use strict; =pod =head1 NAME List::MoreUtils - Provide the stuff missing in List::Util =head1 SYNOPSIS # import specific functions use List::MoreUtils qw(any uniq); if ( any { /foo/ } uniq @has_duplicates ) { # do stuff } # import everything use List::MoreUtils ':all'; # import by API # has "original" any/all/none/notall behavior use List::MoreUtils ':like_0.22'; # 0.22 + bsearch use List::MoreUtils ':like_0.24'; # has "simplified" any/all/none/notall behavior + (n)sort_by use List::MoreUtils ':like_0.33'; =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. =head1 EXPORTS =head2 Default behavior Nothing by default. To import all of this module's symbols use the C<:all> tag. Otherwise functions can be imported by name as usual: use List::MoreUtils ':all'; use List::MoreUtils qw{ any firstidx }; Because historical changes to the API might make upgrading List::MoreUtils difficult for some projects, the legacy API is available via special import tags. =head2 Like version 0.22 (last release with original API) This API was available from 2006 to 2009, returning undef for empty lists on C/C/C/C: use List::MoreUtils ':like_0.22'; This import tag will import all functions available as of version 0.22. However, it will import C as C, C as C, C as C, and C as C. =head2 Like version 0.24 (first incompatible change) This API was available from 2010 to 2011. It changed the return value of C and added the C function. use List::MoreUtils ':like_0.24'; This import tag will import all functions available as of version 0.24. However it will import C as C, C as C, and C as C. It will import C as described in the documentation below (true for empty list). =head2 Like version 0.33 (second incompatible change) This API was available from 2011 to 2014. It is widely used in several CPAN modules and thus it's closest to the current API. It changed the return values of C, C, and C. It added the C and C functions and the C alias for C. It omitted C. use List::MoreUtils ':like_0.33'; This import tag will import all functions available as of version 0.33. Note: it will not import C for consistency with the 0.33 API. =head1 FUNCTIONS =head2 Junctions =head3 I There are two schools of thought for how to evaluate a junction on an empty list: =over =item * Reduction to an identity (boolean) =item * Result is undefined (three-valued) =back In the first case, the result of the junction applied to the empty list is determined by a mathematical reduction to an identity depending on whether the underlying comparison is "or" or "and". Conceptually: "any are true" "all are true" -------------- -------------- 2 elements: A || B || 0 A && B && 1 1 element: A || 0 A && 1 0 elements: 0 1 In the second case, three-value logic is desired, in which a junction applied to an empty list returns C rather than true or false Junctions with a C<_u> suffix implement three-valued logic. Those without are boolean. =head3 all BLOCK LIST =head3 all_u 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 values are non-negative" if all { $_ >= 0 } ($x, $y, $z); For an empty LIST, C returns true (i.e. no values failed the condition) and C returns C. Thus, C<< all_u(@list) >> is equivalent to C<< @list ? all(@list) : undef >>. B: because Perl treats C as false, you must check the return value of C with C or you will get the opposite result of what you expect. =head3 any BLOCK LIST =head3 any_u 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 non-negative value" if any { $_ >= 0 } ($x, $y, $z); For an empty LIST, C returns false and C returns C. Thus, C<< any_u(@list) >> is equivalent to C<< @list ? any(@list) : undef >>. =head3 none BLOCK LIST =head3 none_u 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 non-negative values" if none { $_ >= 0 } ($x, $y, $z); For an empty LIST, C returns true (i.e. no values failed the condition) and C returns C. Thus, C<< none_u(@list) >> is equivalent to C<< @list ? none(@list) : undef >>. B: because Perl treats C as false, you must check the return value of C with C or you will get the opposite result of what you expect. =head3 notall BLOCK LIST =head3 notall_u 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 are non-negative" if notall { $_ >= 0 } ($x, $y, $z); For an empty LIST, C returns false and C returns C. Thus, C<< notall_u(@list) >> is equivalent to C<< @list ? notall(@list) : undef >>. =head3 one BLOCK LIST =head3 one_u BLOCK LIST Returns a true value if precisely one item in LIST meets the criterion given through BLOCK. Sets C<$_> for each item in LIST in turn: print "Precisely one value defined" if one { defined($_) } @list; Returns false otherwise. For an empty LIST, C returns false and C returns C. The expression C is almost equivalent to C<1 == true BLOCK LIST>, except for short-cutting. Evaluation of BLOCK will immediately stop at the second true value. =head2 Transformation =head3 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 } =head3 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 =head3 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 =head3 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 =head3 mesh ARRAY1 ARRAY2 [ ARRAY3 ... ] =head3 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. =head3 zip6 =head3 zip_unflatten Returns a list of arrays consisting of the first elements of each array, then the second, then the third, etc, until all arrays are exhausted. @x = qw/a b c d/; @y = qw/1 2 3 4/; @z = zip6 @x, @y; # returns [a, 1], [b, 2], [c, 3], [d, 4] @a = ('x'); @b = ('1', '2'); @c = qw/zip zap zot/; @d = zip6 @a, @b, @c; # [x, 1, zip], [undef, 2, zap], [undef, undef, zot] C is an alias for C. =head3 listcmp ARRAY0 ARRAY1 [ ARRAY2 ... ] Returns an associative list of elements and every I of the list it was found in. Allows easy implementation of @a & @b, @a | @b, @a ^ @b and so on. Undefined entries in any given array are skipped. my @a = qw(one two three four five six seven eight nine ten eleven twelve thirteen); my @b = qw(two three five seven eleven thirteen seventeen); my @c = qw(one one two three five eight thirteen twentyone); my %cmp = listcmp @a, @b, @c; # returns (one => [0, 2], two => [0, 1, 2], three => [0, 1, 2], four => [0], ...) my @seq = (1, 2, 3); my @prim = (undef, 2, 3, 5); my @fib = (1, 1, 2); my %cmp = listcmp @seq, @prim, @fib; # returns ( 1 => [0, 2], 2 => [0, 1, 2], 3 => [0, 1], 5 => [1] ) =head3 arrayify LIST[,LIST[,LIST...]] Returns a list consisting of each element of given arrays. Recursive arrays are flattened, too. @a = (1, [[2], 3], 4, [5], 6, [7], 8, 9); @l = arrayify @a; # returns 1, 2, 3, 4, 5, 6, 7, 8, 9 =head3 uniq LIST =head3 distinct LIST Returns a new list by stripping duplicate values in LIST by comparing the values as hash keys, except that undef is considered separate from ''. 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 # returns "Mike", "Michael", "Richard", "Rick" my @n = distinct "Mike", "Michael", "Richard", "Rick", "Michael", "Rick" # returns "A8", "", undef, "A5", "S1" my @s = distinct "A8", "", undef, "A5", "S1", "A5", "A8" # returns "Giulia", "Giulietta", undef, "", 156, "GTA", "GTV", 159, "Brera", "4C" my @w = uniq "Giulia", "Giulietta", undef, "", 156, "GTA", "GTV", 159, "Brera", "4C", "Giulietta", "Giulia" C is an alias for C. B can be used to give feedback about this behavior. =head3 singleton LIST Returns a new list by stripping values in LIST occurring more than once by comparing the values as hash keys, except that undef is considered separate from ''. The order of elements in the returned list is the same as in LIST. In scalar context, returns the number of elements occurring only once in LIST. my @x = singleton 1,1,2,2,3,4,5 # returns 3 4 5 =head3 duplicates LIST Returns a new list by stripping values in LIST occurring less than twice by comparing the values as hash keys, except that undef is considered separate from ''. The order of elements in the returned list is the same as in LIST. In scalar context, returns the number of elements occurring more than once in LIST. my @y = duplicates 1,1,2,4,7,2,3,4,6,9; #returns 1,2,4 =head3 frequency LIST Returns an associative list of distinct values and the corresponding frequency. my @f = frequency values %radio_nrw; # returns ( # 'Deutschlandfunk (DLF)' => 9, 'WDR 3' => 10, # 'WDR 4' => 11, 'WDR 5' => 14, 'WDR Eins Live' => 14, # 'Deutschlandradio Kultur' => 8,...) =head3 occurrences LIST Returns a new list of frequencies and the corresponding values from LIST. my @o = occurrences ((1) x 3, (2) x 4, (3) x 2, (4) x 7, (5) x 2, (6) x 4); # @o = (undef, undef, [3, 5], [1], [2, 6], undef, undef, [4]); =head3 mode LIST Returns the modal value of LIST. In scalar context, just the modal value is returned, in list context all probes occurring I times are returned, too. my @m = mode ((1) x 3, (2) x 4, (3) x 2, (4) x 7, (5) x 2, (6) x 4, (7) x 3, (8) x 7); # @m = (7, 4, 8) - bimodal LIST =head3 slide BLOCK LIST The function C operates on pairs of list elements like: my @s = slide { "$a and $b" } (0..3); # @s = ("0 and 1", "1 and 2", "2 and 3") The idea behind this function is a kind of magnifying glass that is moved along a list and calls C every time the next list item is reached. =head2 Partitioning =head3 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 =head3 after_incl BLOCK LIST Same as C but also includes the element for which BLOCK is true. =head3 before BLOCK LIST Returns a list of values of LIST up to (and not including) the point where BLOCK returns a true value. Sets C<$_> for each element in LIST in turn. =head3 before_incl BLOCK LIST Same as C but also includes the element for which BLOCK is true. =head3 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[$i++ % 3] } 1 .. 8; # [1, 4, 7], [2, 3, 5, 6, 8] =head3 samples COUNT LIST Returns a new list containing COUNT random samples from LIST. Is similar to L, but stops after COUNT. @r = samples 10, 1..10; # same as shuffle @r2 = samples 5, 1..10; # gives 5 values from 1..10; =head2 Iteration =head3 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 returns the index of the last fetched set of values, as a scalar. =head3 each_arrayref LIST Like each_array, but the arguments are references to arrays, not the plain arrays. =head3 natatime EXPR, 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 =head3 slideatatime STEP, WINDOW, LIST Creates an array iterator, for looping over an array in chunks of C<$windows-size> items at a time. The idea behind this function is a kind of magnifying glass (finer controllable compared to L) that is moved along a list. Example: my @x = ('a' .. 'g'); my $it = slideatatime 2, 3, @x; while (my @vals = $it->()) { print "@vals\n"; } This prints a b c c d e e f g g =head2 Searching =head3 firstval BLOCK LIST =head3 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. =head3 onlyval BLOCK LIST =head3 only_value BLOCK LIST Returns the only element in LIST for which BLOCK evaluates to true. Sets C<$_> for each item in LIST in turn. Returns C if no such element has been found. C is an alias for C. =head3 lastval BLOCK LIST =head3 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. =head3 firstres BLOCK LIST =head3 first_result BLOCK LIST Returns the result of BLOCK for 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. =head3 onlyres BLOCK LIST =head3 only_result BLOCK LIST Returns the result of BLOCK for the first element in LIST for which BLOCK evaluates to true. Sets C<$_> for each item in LIST in turn. Returns C if no such element has been found. C is an alias for C. =head3 lastres BLOCK LIST =head3 last_result BLOCK LIST Returns the result of BLOCK for the last 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. =head3 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 =head3 firstidx BLOCK LIST =head3 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. =head3 onlyidx BLOCK LIST =head3 only_index BLOCK LIST Returns the index of the only element in LIST for which the criterion in BLOCK is true. Sets C<$_> for each item in LIST in turn: my @list = (1, 3, 4, 3, 2, 4); printf "uniqe index of item 2 in list is %i", onlyidx { $_ == 2 } @list; __END__ unique index of item 2 in list is 4 Returns C<-1> if either no such item or more than one of these has been found. C is an alias for C. =head3 lastidx BLOCK LIST =head3 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. =head2 Sorting =head3 sort_by BLOCK LIST Returns the list of values sorted according to the string values returned by the KEYFUNC block or function. A typical use of this may be to sort objects according to the string value of some accessor, such as sort_by { $_->name } @people The key function is called in scalar context, being passed each value in turn as both $_ and the only argument in the parameters, @_. The values are then sorted according to string comparisons on the values returned. This is equivalent to sort { $a->name cmp $b->name } @people except that it guarantees the name accessor will be executed only once per value. One interesting use-case is to sort strings which may have numbers embedded in them "naturally", rather than lexically. sort_by { s/(\d+)/sprintf "%09d", $1/eg; $_ } @strings This sorts strings by generating sort keys which zero-pad the embedded numbers to some level (9 digits in this case), helping to ensure the lexical sort puts them in the correct order. =head3 nsort_by BLOCK LIST Similar to sort_by but compares its key values numerically. =head3 qsort BLOCK ARRAY This sorts the given array B using the given compare code. Except for tiny compare code like C<< $a <=> $b >>, qsort is much faster than Perl's C depending on the version. Compared 5.8 and 5.26: my @rl; for(my $i = 0; $i < 1E6; ++$i) { push @rl, rand(1E5) } my $idx; sub ext_cmp { $_[0] <=> $_[1] } cmpthese( -60, { 'qsort' => sub { my @qrl = @rl; qsort { ext_cmp($a, $b) } @qrl; $idx = bsearchidx { ext_cmp($_, $rl[0]) } @qrl }, 'reverse qsort' => sub { my @qrl = @rl; qsort { ext_cmp($b, $a) } @qrl; $idx = bsearchidx { ext_cmp($rl[0], $_) } @qrl }, 'sort' => sub { my @srl = @rl; @srl = sort { ext_cmp($a, $b) } @srl; $idx = bsearchidx { ext_cmp($_, $rl[0]) } @srl }, 'reverse sort' => sub { my @srl = @rl; @srl = sort { ext_cmp($b, $a) } @srl; $idx = bsearchidx { ext_cmp($rl[0], $_) } @srl }, }); 5.8 results s/iter reverse sort sort reverse qsort qsort reverse sort 6.21 -- -0% -8% -10% sort 6.19 0% -- -7% -10% reverse qsort 5.73 8% 8% -- -2% qsort 5.60 11% 11% 2% -- 5.26 results s/iter reverse sort sort reverse qsort qsort reverse sort 4.54 -- -0% -96% -96% sort 4.52 0% -- -96% -96% reverse qsort 0.203 2139% 2131% -- -19% qsort 0.164 2666% 2656% 24% -- Use it where external data sources might have to be compared (think of L "tables"). C is available from List::MoreUtils::XS only. It's insane to maintain a wrapper around Perl's sort nor having a pure Perl implementation. One could create a flip-book in same speed as PP runs a qsort. =head2 Searching in sorted Lists =head3 bsearch BLOCK LIST Performs a binary search on LIST which must be a sorted list of values. BLOCK must return a negative value if the current element (stored in C<$_>) is smaller, a positive value if it is bigger and zero if it matches. Returns a boolean value in scalar context. In list context, it returns the element if it was found, otherwise the empty list. =head3 bsearchidx BLOCK LIST =head3 bsearch_index BLOCK LIST Performs a binary search on LIST which must be a sorted list of values. BLOCK must return a negative value if the current element (stored in C<$_>) is smaller, a positive value if it is bigger and zero if it matches. Returns the index of found element, otherwise C<-1>. C is an alias for C. =head3 lower_bound BLOCK LIST Returns the index of the first element in LIST which does not compare I. Technically it's the first element in LIST which does not return a value below zero when passed to BLOCK. @ids = (1, 1, 2, 2, 3, 3, 3, 3, 3, 3, 4, 4, 4, 4, 5, 5, 6, 7, 7, 7, 8, 8, 9, 9, 9, 9, 9, 11, 13, 13, 13, 17); $lb = lower_bound { $_ <=> 2 } @ids; # returns 2 $lb = lower_bound { $_ <=> 4 } @ids; # returns 10 lower_bound has a complexity of O(log n). =head3 upper_bound BLOCK LIST Returns the index of the first element in LIST which does not compare I. Technically it's the first element in LIST which does not return a value below or equal to zero when passed to BLOCK. @ids = (1, 1, 2, 2, 3, 3, 3, 3, 3, 3, 4, 4, 4, 4, 5, 5, 6, 7, 7, 7, 8, 8, 9, 9, 9, 9, 9, 11, 13, 13, 13, 17); $lb = upper_bound { $_ <=> 2 } @ids; # returns 4 $lb = upper_bound { $_ <=> 4 } @ids; # returns 14 upper_bound has a complexity of O(log n). =head3 equal_range BLOCK LIST Returns a pair of indices containing the lower_bound and the upper_bound. =head2 Operations on sorted Lists =head3 binsert BLOCK ITEM LIST =head3 bsearch_insert BLOCK ITEM LIST Performs a binary search on LIST which must be a sorted list of values. BLOCK must return a negative value if the current element (stored in C<$_>) is smaller, a positive value if it is bigger and zero if it matches. ITEM is inserted at the index where the ITEM should be placed (based on above search). That means, it's inserted before the next bigger element. @l = (2,3,5,7); binsert { $_ <=> 4 } 4, @l; # @l = (2,3,4,5,7) binsert { $_ <=> 6 } 42, @l; # @l = (2,3,4,42,7) You take care that the inserted element matches the compare result. =head3 bremove BLOCK LIST =head3 bsearch_remove BLOCK LIST Performs a binary search on LIST which must be a sorted list of values. BLOCK must return a negative value if the current element (stored in C<$_>) is smaller, a positive value if it is bigger and zero if it matches. The item at the found position is removed and returned. @l = (2,3,4,5,7); bremove { $_ <=> 4 }, @l; # @l = (2,3,5,7); =head2 Counting and calculation =head3 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; =head3 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; =head3 reduce_0 BLOCK LIST Reduce LIST by calling BLOCK in scalar context for each element of LIST. C<$a> contains the progressional result and is initialized with 0. C<$b> contains the current processed element of LIST and C<$_> contains the index of the element in C<$b>. The idea behind reduce_0 is B (addition of a sequence of numbers). =head3 reduce_1 BLOCK LIST Reduce LIST by calling BLOCK in scalar context for each element of LIST. C<$a> contains the progressional result and is initialized with 1. C<$b> contains the current processed element of LIST and C<$_> contains the index of the element in C<$b>. The idea behind reduce_1 is product of a sequence of numbers. =head3 reduce_u BLOCK LIST Reduce LIST by calling BLOCK in scalar context for each element of LIST. C<$a> contains the progressional result and is uninitialized. C<$b> contains the current processed element of LIST and C<$_> contains the index of the element in C<$b>. This function has been added if one might need the extra of the index value but need an individual initialization. B: In most cases L will do the job better. =head3 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. =head3 minmaxstr LIST Computes the minimum and maximum of LIST using string compare 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 implementation is similar to C. =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 MAINTENANCE The maintenance goal is to preserve the documented semantics of the API; bug fixes that bring actual behavior in line with semantics are allowed. New API functions may be added over time. If a backwards incompatible change is unavoidable, we will attempt to provide support for the legacy API using the same export tag mechanism currently in place. This module attempts to use few non-core dependencies. Non-core configuration and testing modules will be bundled when reasonable; run-time dependencies will be added only if they deliver substantial benefit. =head1 CONTRIBUTING While contributions are appreciated, a contribution should not cause more effort for the maintainer than the contribution itself saves (see L). To get more familiar where help could be needed - see L. =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. You can find documentation for this module with the perldoc command. perldoc List::MoreUtils You can also look for information at: =over 4 =item * RT: CPAN's request tracker L =item * AnnoCPAN: Annotated CPAN documentation L =item * CPAN Ratings L =item * MetaCPAN L =item * CPAN Search L =item * Git Repository L =back =head2 Where can I go for help? If you have a bug report, a patch or a suggestion, please open a new report ticket at CPAN (but please check previous reports first in case your issue has already been addressed) or open an issue on GitHub. Report tickets should contain a detailed description of the bug or enhancement request and at least an easily verifiable way of reproducing the issue or fix. Patches are always welcome, too - and it's cheap to send pull-requests on GitHub. Please keep in mind that code changes are more likely accepted when they're bundled with an approving test. If you think you've found a bug then please read "How to Report Bugs Effectively" by Simon Tatham: L. =head2 Where can I go for help with a concrete version? Bugs and feature requests are accepted against the latest version only. To get patches for earlier versions, you need to get an agreement with a developer of your choice - who may or not report the issue and a suggested fix upstream (depends on the license you have chosen). =head2 Business support and maintenance Generally, in volunteered projects, there is no right for support. While every maintainer is happy to improve the provided software, spare time is limited. For those who have a use case which requires guaranteed support, one of the maintainers should be hired or contracted. For business support you can contact Jens via his CPAN email address rehsackATcpan.org. Please keep in mind that business support is neither available for free nor are you eligible to receive any support based on the license distributed with this package. =head1 THANKS =head2 Tassilo von Parseval 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. =head2 Jens Rehsack Credits goes to all people contributing feedback during the v0.400 development releases. Special thanks goes to David Golden who spent a lot of effort to develop a design to support current state of CPAN as well as ancient software somewhere in the dark. He also contributed a lot of patches to refactor the API frontend to welcome any user of List::MoreUtils - from ancient past to recently last used. Toby Inkster provided a lot of useful feedback for sane importer code and was a nice sounding board for API discussions. Peter Rabbitson provided a sane git repository setup containing entire package history. =head1 TODO A pile of requests from other people is still pending further processing in my mailbox. This includes: =over 4 =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, L, L =head1 AUTHOR Jens Rehsack Erehsack AT cpan.orgE Adam Kennedy Eadamk@cpan.orgE Tassilo von Parseval Etassilo.von.parseval@rwth-aachen.deE =head1 COPYRIGHT AND LICENSE Some parts copyright 2011 Aaron Crane. Copyright 2004 - 2010 by Tassilo von Parseval Copyright 2013 - 2017 by Jens Rehsack All code added with 0.417 or later is licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in compliance with the License. You may obtain a copy of the License at http://www.apache.org/licenses/LICENSE-2.0 Unless required by applicable law or agreed to in writing, software distributed under the License is distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the License for the specific language governing permissions and limitations under the License. All code until 0.416 is licensed 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 1; List-MoreUtils-0.430/lib/List/MoreUtils/0000755000175000017500000000000013744044757016157 5ustar snosnoList-MoreUtils-0.430/lib/List/MoreUtils/PP.pm0000644000175000017500000004615713744035161017036 0ustar snosnopackage List::MoreUtils::PP; use 5.008_001; use strict; use warnings; our $VERSION = '0.430'; =pod =head1 NAME List::MoreUtils::PP - Provide List::MoreUtils pure Perl implementation =head1 SYNOPSIS BEGIN { $ENV{LIST_MOREUTILS_PP} = 1; } use List::MoreUtils qw(:all); =cut ## no critic (Subroutines::ProhibitSubroutinePrototypes, Subroutines::RequireArgUnpacking) ## no critic (Subroutines::ProhibitManyArgs) sub any (&@) { my $f = shift; foreach (@_) { return 1 if $f->(); } return 0; } sub all (&@) { my $f = shift; foreach (@_) { return 0 unless $f->(); } return 1; } sub none (&@) { my $f = shift; foreach (@_) { return 0 if $f->(); } return 1; } sub notall (&@) { my $f = shift; foreach (@_) { return 1 unless $f->(); } return 0; } sub one (&@) { my $f = shift; my $found = 0; foreach (@_) { $f->() and $found++ and return 0; } return $found; } sub any_u (&@) { my $f = shift; return if !@_; $f->() and return 1 foreach (@_); return 0; } sub all_u (&@) { my $f = shift; return if !@_; $f->() or return 0 foreach (@_); return 1; } sub none_u (&@) { my $f = shift; return if !@_; $f->() and return 0 foreach (@_); return 1; } sub notall_u (&@) { my $f = shift; return if !@_; $f->() or return 1 foreach (@_); return 0; } sub one_u (&@) { my $f = shift; return if !@_; my $found = 0; foreach (@_) { $f->() and $found++ and return 0; } return $found; } sub reduce_u(&@) { my $code = shift; # Localise $a, $b my ($caller_a, $caller_b) = do { my $pkg = caller(); ## no critic (TestingAndDebugging::ProhibitNoStrict, ValuesAndExpressions::ProhibitCommaSeparatedStatements) no strict 'refs'; \*{$pkg . '::a'}, \*{$pkg . '::b'}; }; ## no critic (Variables::RequireInitializationForLocalVars) local (*$caller_a, *$caller_b); *$caller_a = \(); for (0 .. $#_) { *$caller_b = \$_[$_]; *$caller_a = \($code->()); } return ${*$caller_a}; } sub reduce_0(&@) { my $code = shift; # Localise $a, $b my ($caller_a, $caller_b) = do { my $pkg = caller(); ## no critic (TestingAndDebugging::ProhibitNoStrict, ValuesAndExpressions::ProhibitCommaSeparatedStatements) no strict 'refs'; \*{$pkg . '::a'}, \*{$pkg . '::b'}; }; ## no critic (Variables::RequireInitializationForLocalVars) local (*$caller_a, *$caller_b); *$caller_a = \0; for (0 .. $#_) { *$caller_b = \$_[$_]; *$caller_a = \($code->()); } return ${*$caller_a}; } sub reduce_1(&@) { my $code = shift; # Localise $a, $b my ($caller_a, $caller_b) = do { my $pkg = caller(); ## no critic (TestingAndDebugging::ProhibitNoStrict, ValuesAndExpressions::ProhibitCommaSeparatedStatements) no strict 'refs'; \*{$pkg . '::a'}, \*{$pkg . '::b'}; }; ## no critic (Variables::RequireInitializationForLocalVars) local (*$caller_a, *$caller_b); *$caller_a = \1; for (0 .. $#_) { *$caller_b = \$_[$_]; *$caller_a = \($code->()); } return ${*$caller_a}; } sub true (&@) { my $f = shift; my $count = 0; $f->() and ++$count foreach (@_); return $count; } sub false (&@) { my $f = shift; my $count = 0; $f->() or ++$count foreach (@_); return $count; } sub firstidx (&@) { my $f = shift; foreach my $i (0 .. $#_) { local *_ = \$_[$i]; return $i if $f->(); } return -1; } sub firstval (&@) { my $test = shift; foreach (@_) { return $_ if $test->(); } ## no critic (Subroutines::ProhibitExplicitReturnUndef) return undef; } sub firstres (&@) { my $test = shift; foreach (@_) { my $testval = $test->(); $testval and return $testval; } ## no critic (Subroutines::ProhibitExplicitReturnUndef) return undef; } sub onlyidx (&@) { my $f = shift; my $found; foreach my $i (0 .. $#_) { local *_ = \$_[$i]; $f->() or next; defined $found and return -1; $found = $i; } return defined $found ? $found : -1; } sub onlyval (&@) { my $test = shift; my $result = undef; my $found = 0; foreach (@_) { $test->() or next; $result = $_; ## no critic (Subroutines::ProhibitExplicitReturnUndef) $found++ and return undef; } return $result; } sub onlyres (&@) { my $test = shift; my $result = undef; my $found = 0; foreach (@_) { my $rv = $test->() or next; $result = $rv; ## no critic (Subroutines::ProhibitExplicitReturnUndef) $found++ and return undef; } return $found ? $result : undef; } sub lastidx (&@) { my $f = shift; foreach my $i (reverse 0 .. $#_) { local *_ = \$_[$i]; return $i if $f->(); } return -1; } sub lastval (&@) { my $test = shift; my $ix; for ($ix = $#_; $ix >= 0; $ix--) { local *_ = \$_[$ix]; my $testval = $test->(); # Simulate $_ as alias $_[$ix] = $_; return $_ if $testval; } ## no critic (Subroutines::ProhibitExplicitReturnUndef) return undef; } sub lastres (&@) { my $test = shift; my $ix; for ($ix = $#_; $ix >= 0; $ix--) { local *_ = \$_[$ix]; my $testval = $test->(); # Simulate $_ as alias $_[$ix] = $_; return $testval if $testval; } ## no critic (Subroutines::ProhibitExplicitReturnUndef) return undef; } sub insert_after (&$\@) { my ($f, $val, $list) = @_; my $c = &firstidx($f, @$list); @$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 = firstidx { defined $_ and $string eq $_ } @$list; @$list = (@{$list}[0 .. $c], $val, @{$list}[$c + 1 .. $#$list],) and return 1 if $c != -1; return 0; } sub apply (&@) { my $action = shift; &$action foreach my @values = @_; return wantarray ? @values : $values[-1]; } sub after (&@) { my $test = shift; my $started; my $lag; ## no critic (BuiltinFunctions::RequireBlockGrep) return grep $started ||= do { my $x = $lag; $lag = $test->(); $x; }, @_; } sub after_incl (&@) { my $test = shift; my $started; return grep { $started ||= $test->() } @_; } sub before (&@) { my $test = shift; my $more = 1; return grep { $more &&= !$test->() } @_; } sub before_incl (&@) { my $test = shift; my $more = 1; my $lag = 1; ## no critic (BuiltinFunctions::RequireBlockGrep) return grep $more &&= do { my $x = $lag; $lag = !$test->(); $x; }, @_; } sub indexes (&@) { my $test = shift; return grep { local *_ = \$_[$_]; $test->() } 0 .. $#_; } 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 critic (TestingAndDebugging::ProhibitNoStrict, ValuesAndExpressions::ProhibitCommaSeparatedStatements) no strict 'refs'; \*{$pkg . '::a'}, \*{$pkg . '::b'}; }; # Loop iteration limit my $limit = $#A > $#B ? $#A : $#B; ## no critic (Variables::RequireInitializationForLocalVars) # This map expression is also the return value local (*$caller_a, *$caller_b); ## no critic (BuiltinFunctions::ProhibitComplexMappings) return map { # Assign to $a, $b as refs to caller's array elements (*$caller_a, *$caller_b) = \($#A < $_ ? undef : $A[$_], $#B < $_ ? undef : $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."); } ## no critic (Subroutines::ProhibitExplicitReturnUndef) return undef if $index == 0 || $index > $max; # Return current (last fetched) index return $index - 1; } # No more elements to return return if $index >= $max; my $i = $index++; # Return ith elements ## no critic (BuiltinFunctions::RequireBlockMap) return map $_->[$i], @list; } } sub natatime ($@) { my $n = shift; my @list = @_; return sub { return splice @list, 0, $n; } } # "leaks" when lexically hidden in arrayify my $flatten; $flatten = sub { return map { (ref $_ and ("ARRAY" eq ref $_ or overload::Method($_, '@{}'))) ? ($flatten->(@{$_})) : ($_) } @_; }; sub arrayify { return map { $flatten->($_) } @_; } sub mesh (\@\@;\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@) { my $max = -1; $max < $#$_ && ($max = $#$_) foreach @_; ## no critic (BuiltinFunctions::ProhibitComplexMappings) return map { my $ix = $_; ## no critic (BuiltinFunctions::RequireBlockMap) map $_->[$ix], @_; } 0 .. $max; } sub zip6 (\@\@;\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@) { my $max = -1; $max < $#$_ && ($max = $#$_) foreach @_; ## no critic (BuiltinFunctions::ProhibitComplexMappings) return map { my $ix = $_; ## no critic (BuiltinFunctions::RequireBlockMap) [map $_->[$ix], @_]; } 0 .. $max; } sub listcmp (\@\@;\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@) { my %ret; for (my $i = 0; $i < scalar @_; ++$i) { my %seen; my $k; foreach my $w (grep { defined $_ and not $seen{$k = $_}++ } @{$_[$i]}) { $ret{$w} ||= []; push @{$ret{$w}}, $i; } } return %ret; } sub uniq (@) { my %seen = (); my $k; my $seen_undef; return grep { defined $_ ? not $seen{$k = $_}++ : not $seen_undef++ } @_; } sub singleton (@) { my %seen = (); my $k; my $seen_undef; return grep { 1 == (defined $_ ? $seen{$k = $_} : $seen_undef) } grep { defined $_ ? not $seen{$k = $_}++ : not $seen_undef++ } @_; } sub duplicates (@) { my %seen = (); my $k; my $seen_undef; return grep { 1 < (defined $_ ? $seen{$k = $_} : $seen_undef) } grep { defined $_ ? not $seen{$k = $_}++ : not $seen_undef++ } @_; } sub frequency (@) { my %seen = (); my $k; my $seen_undef; my %h = map { defined $_ ? ($_ => $seen{$k = $_}) : () } grep { defined $_ ? not $seen{$k = $_}++ : not $seen_undef++ } @_; wantarray or return (scalar keys %h) + ($seen_undef ? 1 : 0); undef $k; return (%h, $seen_undef ? (\$k => $seen_undef) : ()); } sub occurrences (@) { my %seen = (); my $k; my $seen_undef; my @ret; foreach my $l (map { $_ } grep { defined $_ ? not $seen{$k = $_}++ : not $seen_undef++ } @_) { my $n = defined $l ? $seen{$l} : $seen_undef; defined $ret[$n] or $ret[$n] = []; push @{$ret[$n]}, $l; } return @ret; } sub mode (@) { my %seen = (); my ($max, $k, $seen_undef) = (1); foreach (@_) { defined $_ ? ($max < ++$seen{$k = $_} and ++$max) : ($max < ++$seen_undef and ++$max) } wantarray or return $max; my @ret = ($max); foreach my $l (grep { $seen{$_} == $max } keys %seen) { push @ret, $l; } $seen_undef and $seen_undef == $max and push @ret, undef; return @ret; } sub samples ($@) { my $n = shift; if ($n > @_) { require Carp; Carp::croak(sprintf("Cannot get %d samples from %d elements", $n, scalar @_)); } for (my $i = @_; @_ - $i > $n;) { my $idx = @_ - $i; my $swp = $idx + int(rand(--$i)); my $xchg = $_[$swp]; $_[$swp] = $_[$idx]; $_[$idx] = $xchg; } return splice @_, 0, $n; } 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 minmaxstr (@) { return unless @_; my $min = my $max = $_[0]; for (my $i = 1; $i < @_; $i += 2) { if ($_[$i - 1] le $_[$i]) { $min = $_[$i - 1] if $min gt $_[$i - 1]; $max = $_[$i] if $max lt $_[$i]; } else { $min = $_[$i] if $min gt $_[$i]; $max = $_[$i - 1] if $max lt $_[$i - 1]; } } if (@_ & 1) { my $i = $#_; if ($_[$i - 1] le $_[$i]) { $min = $_[$i - 1] if $min gt $_[$i - 1]; $max = $_[$i] if $max lt $_[$i]; } else { $min = $_[$i] if $min gt $_[$i]; $max = $_[$i - 1] if $max lt $_[$i - 1]; } } return ($min, $max); } sub part (&@) { my ($code, @list) = @_; my @parts; push @{$parts[$code->($_)]}, $_ foreach @list; return @parts; } sub bsearch(&@) { my $code = shift; my $rc; my $i = 0; my $j = @_; ## no critic (ControlStructures::ProhibitNegativeExpressionsInUnlessAndUntilConditions) do { my $k = int(($i + $j) / 2); $k >= @_ and return; local *_ = \$_[$k]; $rc = $code->(); $rc == 0 and return wantarray ? $_ : 1; if ($rc < 0) { $i = $k + 1; } else { $j = $k - 1; } } until $i > $j; return; } sub bsearchidx(&@) { my $code = shift; my $rc; my $i = 0; my $j = @_; ## no critic (ControlStructures::ProhibitNegativeExpressionsInUnlessAndUntilConditions) do { my $k = int(($i + $j) / 2); $k >= @_ and return -1; local *_ = \$_[$k]; $rc = $code->(); $rc == 0 and return $k; if ($rc < 0) { $i = $k + 1; } else { $j = $k - 1; } } until $i > $j; return -1; } sub lower_bound(&@) { my $code = shift; my $count = @_; my $first = 0; while ($count > 0) { my $step = $count >> 1; my $it = $first + $step; local *_ = \$_[$it]; if ($code->() < 0) { $first = ++$it; $count -= $step + 1; } else { $count = $step; } } return $first; } sub upper_bound(&@) { my $code = shift; my $count = @_; my $first = 0; while ($count > 0) { my $step = $count >> 1; my $it = $first + $step; local *_ = \$_[$it]; if ($code->() <= 0) { $first = ++$it; $count -= $step + 1; } else { $count = $step; } } return $first; } sub equal_range(&@) { my $lb = &lower_bound(@_); my $ub = &upper_bound(@_); return ($lb, $ub); } sub binsert (&$\@) { my $lb = &lower_bound($_[0], @{$_[2]}); splice @{$_[2]}, $lb, 0, $_[1]; return $lb; } sub bremove (&\@) { my $lb = &lower_bound($_[0], @{$_[1]}); return splice @{$_[1]}, $lb, 1; } sub qsort(&\@) { require Carp; Carp::croak("It's insane to use a pure-perl qsort"); } sub slide(&@) { my $op = shift; my @l = @_; ## no critic (TestingAndDebugging::ProhibitNoStrict, ValuesAndExpressions::ProhibitCommaSeparatedStatements) # Localise $a, $b my ($caller_a, $caller_b) = do { my $pkg = caller(); no strict 'refs'; \*{$pkg . '::a'}, \*{$pkg . '::b'}; }; ## no critic (Variables::RequireInitializationForLocalVars) # This map expression is also the return value local (*$caller_a, *$caller_b); ## no critic (BuiltinFunctions::ProhibitComplexMappings) return map { # Assign to $a, $b as refs to caller's array elements (*$caller_a, *$caller_b) = \($l[$_], $l[$_ + 1]); # Perform the transformation $op->(); } 0 .. ($#l - 1); } sub slideatatime ($$@) { my ($m, $w, @list) = @_; my $n = $w - $m - 1; return $n >= 0 ? sub { my @r = splice @list, 0, $m; $#list < $n and $n = $#list; @r and push @r, (@list ? @list[0 .. $n] : ()); return @r; } : sub { return splice @list, 0, $m; }; } sub sort_by(&@) { my ($code, @list) = @_; return map { $_->[0] } sort { $a->[1] cmp $b->[1] } map { [$_, scalar($code->())] } @list; } sub nsort_by(&@) { my ($code, @list) = @_; return map { $_->[0] } sort { $a->[1] <=> $b->[1] } map { [$_, scalar($code->())] } @list; } ## no critic (Subroutines::ProhibitUnusedPrivateSubroutines) sub _XScompiled { return 0 } =head1 SEE ALSO L =head1 AUTHOR Jens Rehsack Erehsack AT cpan.orgE Adam Kennedy Eadamk@cpan.orgE Tassilo von Parseval Etassilo.von.parseval@rwth-aachen.deE =head1 COPYRIGHT AND LICENSE Some parts copyright 2011 Aaron Crane. Copyright 2004 - 2010 by Tassilo von Parseval Copyright 2013 - 2017 by Jens Rehsack All code added with 0.417 or later is licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in compliance with the License. You may obtain a copy of the License at http://www.apache.org/licenses/LICENSE-2.0 Unless required by applicable law or agreed to in writing, software distributed under the License is distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the License for the specific language governing permissions and limitations under the License. All code until 0.416 is licensed 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 1; List-MoreUtils-0.430/lib/List/MoreUtils/Contributing.pod0000644000175000017500000001000413735543464021324 0ustar snosno=head1 NAME List::MoreUtils::Contributing - Gives rough introduction into contributing to List::MoreUtils =head1 DESCRIPTION List::Moreutils has a turbulent history and a strong approach. Before going further, please step to L and then come back. The current distribution is a balance between finishing the history and claiming for future requirements. Therefore some components will receive a rewrite on purpose - others won't. For the moment - it's not the primary goal to clean up the configuration stage, until the primary goals and prerequisites are done. To contribute to List::MoreUtils, one has to arrange with the current situation, dig into details and ask for clarifying when parts are incomprehensible. =head2 Primary Goals The very first primary goal is to clear the backlog. These are primarily the open issues, feature requests and missing infrastructure elements. As example see RT#93207 or RT#75672 for missing configure time checks, while RT#93207 radiates until test - but doesn't affect runtime nor installation (beside test failures). =head2 Secondary Goals Secondary goals are harmonizing the function names and calling convention (see RT#102673), tidying the infrastructure of the distribution and remove unnecessary complexity (while protecting the necessary). One example of removing unnecessary infrastructure could be to move L and L into authoring mode, when improved test for RT#93207 could be reasonably done by a module which is recommended for test. The recommendation of L in L a desirable one. =head2 Orientation Guide List::MoreUtils configuration stage heavily depends on L and L. A few prerequisites of both modules aren't available for Perl 5.6 - which leads to a tiny emulation layer t the begin of C. The reason for L is quite simple - the opportunities for checking the environment cover a much wider range than a simple test whether there is a working compiler. It requires a lot of improvements since its base L was never designed to support that kind of solutions - but there is I. To finally solve issues as RT#75672 even in cross-compile environments - there is no way around such a checking tool. The reason for L in combination with L are extensible tests with reasonable effort and easy figuring out which extra condition causes failures. Also - missing pre-conditions should result in failing tests i some cases - what is fully supported by the logic behind L in combination with L. Finally - L glues the stuff in a bundle together to allow people with older toolchains to use List::MoreUtils out of the box (maybe with reduced quantity but full quality). =head1 SEE ALSO L, L, L, L =head1 AUTHOR Jens Rehsack Erehsack AT cpan.orgE =head1 COPYRIGHT AND LICENSE Copyright 2015-2017 by Jens Rehsack All code added with 0.417 or later is licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in compliance with the License. You may obtain a copy of the License at http://www.apache.org/licenses/LICENSE-2.0 Unless required by applicable law or agreed to in writing, software distributed under the License is distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the License for the specific language governing permissions and limitations under the License. All code until 0.416 is licensed 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 List-MoreUtils-0.430/META.yml0000664000175000017500000000171613744044757014033 0ustar snosno--- abstract: 'Provide the stuff missing in List::Util' author: - 'Tassilo von Parseval ' - 'Adam Kennedy ' - 'Jens Rehsack ' build_requires: ExtUtils::MakeMaker: '0' Storable: '0' Test::LeakTrace: '0' Test::More: '0.96' configure_requires: ExtUtils::MakeMaker: '0' dynamic_config: 1 generated_by: 'ExtUtils::MakeMaker version 7.46, CPAN::Meta::Converter version 2.150010' license: apache meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: '1.4' name: List-MoreUtils no_index: directory: - t - inc requires: Exporter::Tiny: '0.038' List::MoreUtils::XS: '0.430' resources: bugtracker: https://rt.cpan.org/Dist/Display.html?Name=List-MoreUtils homepage: https://metacpan.org/release/List-MoreUtils repository: https://github.com/perl5-utils/List-MoreUtils.git version: '0.430' x_serialization_backend: 'CPAN::Meta::YAML version 0.018' List-MoreUtils-0.430/MANIFEST0000644000175000017500000000763613744044757013720 0ustar snosno.perltidyrc ARTISTIC-1.0 Changes GPL-1 inc/Config/AutoConf/LMU.pm inc/inc_Capture-Tiny/Capture/Tiny.pm inc/inc_Config-AutoConf/Config/AutoConf.pm inc/latest.pm inc/latest/private.pm lib/List/MoreUtils.pm lib/List/MoreUtils/Contributing.pod lib/List/MoreUtils/PP.pm LICENSE Makefile.PL MANIFEST This list of files MANIFEST.SKIP README.md t/.perltidyrc t/inline/after.pm t/inline/after_incl.pm t/inline/all.pm t/inline/all_u.pm t/inline/any.pm t/inline/any_u.pm t/inline/apply.pm t/inline/arrayify.pm t/inline/before.pm t/inline/before_incl.pm t/inline/binsert.pm t/inline/bremove.pm t/inline/bsearch.pm t/inline/bsearchidx.pm t/inline/duplicates.pm t/inline/each_array.pm t/inline/equal_range.pm t/inline/false.pm t/inline/firstidx.pm t/inline/firstres.pm t/inline/firstval.pm t/inline/frequency.pm t/inline/Import.pm t/inline/indexes.pm t/inline/insert_after.pm t/inline/insert_after_string.pm t/inline/lastidx.pm t/inline/lastres.pm t/inline/lastval.pm t/inline/listcmp.pm t/inline/lower_bound.pm t/inline/mesh.pm t/inline/minmax.pm t/inline/minmaxstr.pm t/inline/mode.pm t/inline/natatime.pm t/inline/none.pm t/inline/none_u.pm t/inline/notall.pm t/inline/notall_u.pm t/inline/occurrences.pm t/inline/one.pm t/inline/one_u.pm t/inline/onlyidx.pm t/inline/onlyres.pm t/inline/onlyval.pm t/inline/pairwise.pm t/inline/part.pm t/inline/qsort.pm t/inline/reduce_0.pm t/inline/reduce_1.pm t/inline/reduce_u.pm t/inline/samples.pm t/inline/singleton.pm t/inline/slide.pm t/inline/slideatatime.pm t/inline/true.pm t/inline/uniq.pm t/inline/upper_bound.pm t/inline/XS.pm t/inline/zip6.pm t/lib/Test/LMU.pm t/LICENSE t/pureperl/after.t t/pureperl/after_incl.t t/pureperl/all.t t/pureperl/all_u.t t/pureperl/any.t t/pureperl/any_u.t t/pureperl/apply.t t/pureperl/arrayify.t t/pureperl/before.t t/pureperl/before_incl.t t/pureperl/binsert.t t/pureperl/bremove.t t/pureperl/bsearch.t t/pureperl/bsearchidx.t t/pureperl/duplicates.t t/pureperl/each_array.t t/pureperl/equal_range.t t/pureperl/false.t t/pureperl/firstidx.t t/pureperl/firstres.t t/pureperl/firstval.t t/pureperl/frequency.t t/pureperl/Import.t t/pureperl/indexes.t t/pureperl/insert_after.t t/pureperl/insert_after_string.t t/pureperl/lastidx.t t/pureperl/lastres.t t/pureperl/lastval.t t/pureperl/listcmp.t t/pureperl/lower_bound.t t/pureperl/mesh.t t/pureperl/minmax.t t/pureperl/minmaxstr.t t/pureperl/mode.t t/pureperl/natatime.t t/pureperl/none.t t/pureperl/none_u.t t/pureperl/notall.t t/pureperl/notall_u.t t/pureperl/occurrences.t t/pureperl/one.t t/pureperl/one_u.t t/pureperl/onlyidx.t t/pureperl/onlyres.t t/pureperl/onlyval.t t/pureperl/pairwise.t t/pureperl/part.t t/pureperl/qsort.t t/pureperl/reduce_0.t t/pureperl/reduce_1.t t/pureperl/reduce_u.t t/pureperl/samples.t t/pureperl/singleton.t t/pureperl/slide.t t/pureperl/slideatatime.t t/pureperl/true.t t/pureperl/uniq.t t/pureperl/upper_bound.t t/pureperl/XS.t t/pureperl/zip6.t t/xs/after.t t/xs/after_incl.t t/xs/all.t t/xs/all_u.t t/xs/any.t t/xs/any_u.t t/xs/apply.t t/xs/arrayify.t t/xs/before.t t/xs/before_incl.t t/xs/binsert.t t/xs/bremove.t t/xs/bsearch.t t/xs/bsearchidx.t t/xs/duplicates.t t/xs/each_array.t t/xs/equal_range.t t/xs/false.t t/xs/firstidx.t t/xs/firstres.t t/xs/firstval.t t/xs/frequency.t t/xs/Import.t t/xs/indexes.t t/xs/insert_after.t t/xs/insert_after_string.t t/xs/lastidx.t t/xs/lastres.t t/xs/lastval.t t/xs/listcmp.t t/xs/lower_bound.t t/xs/mesh.t t/xs/minmax.t t/xs/minmaxstr.t t/xs/mode.t t/xs/natatime.t t/xs/none.t t/xs/none_u.t t/xs/notall.t t/xs/notall_u.t t/xs/occurrences.t t/xs/one.t t/xs/one_u.t t/xs/onlyidx.t t/xs/onlyres.t t/xs/onlyval.t t/xs/pairwise.t t/xs/part.t t/xs/qsort.t t/xs/reduce_0.t t/xs/reduce_1.t t/xs/reduce_u.t t/xs/samples.t t/xs/singleton.t t/xs/slide.t t/xs/slideatatime.t t/xs/true.t t/xs/uniq.t t/xs/upper_bound.t t/xs/XS.t t/xs/zip6.t META.yml Module YAML meta-data (added by MakeMaker) META.json Module JSON meta-data (added by MakeMaker) List-MoreUtils-0.430/inc/0000755000175000017500000000000013744044757013324 5ustar snosnoList-MoreUtils-0.430/inc/Config/0000755000175000017500000000000013744044757014531 5ustar snosnoList-MoreUtils-0.430/inc/Config/AutoConf/0000755000175000017500000000000013744044757016247 5ustar snosnoList-MoreUtils-0.430/inc/Config/AutoConf/LMU.pm0000644000175000017500000000134713736562167017250 0ustar snosnopackage inc::Config::AutoConf::LMU; use strict; use warnings; use Config::AutoConf '0.315'; use base qw(Config::AutoConf); sub _check_pureperl_required { my $self = shift->_get_instance; foreach (@{$self->{_argv}}) { /^-pm/ and warn "-pm is depreciated, please use PUREPERL_ONLY=1" and return 1; /^-xs/ and warn "-xs is depreciated, building XS is default anyway" and return !($self->{_force_xs} = 1); } return $self->SUPER::_check_pureperl_required(@_); } sub check_produce_xs_build { my $self = shift->_get_instance; my $xs = $self->SUPER::check_produce_xs_build(@_); $self->{_force_xs} and !$xs and $self->msg_error("XS forced but can't compile - giving up"); return $xs; } 1; List-MoreUtils-0.430/inc/latest.pm0000644000175000017500000000023613735543547015160 0ustar snosno# This stub created by inc::latest 0.500 package inc::latest; use strict; use vars '@ISA'; require inc::latest::private; @ISA = qw/inc::latest::private/; 1; List-MoreUtils-0.430/inc/inc_Capture-Tiny/0000755000175000017500000000000013744044757016501 5ustar snosnoList-MoreUtils-0.430/inc/inc_Capture-Tiny/Capture/0000755000175000017500000000000013744044757020104 5ustar snosnoList-MoreUtils-0.430/inc/inc_Capture-Tiny/Capture/Tiny.pm0000644000175000017500000007173013735543547021376 0ustar snosnouse 5.006; use strict; use warnings; package Capture::Tiny; # ABSTRACT: Capture STDOUT and STDERR from Perl, XS or external programs our $VERSION = '0.48'; use Carp (); use Exporter (); use IO::Handle (); use File::Spec (); use File::Temp qw/tempfile tmpnam/; use Scalar::Util qw/reftype blessed/; # Get PerlIO or fake it BEGIN { local $@; eval { require PerlIO; PerlIO->can('get_layers') } or *PerlIO::get_layers = sub { return () }; } #--------------------------------------------------------------------------# # create API subroutines and export them # [do STDOUT flag, do STDERR flag, do merge flag, do tee flag] #--------------------------------------------------------------------------# my %api = ( capture => [1,1,0,0], capture_stdout => [1,0,0,0], capture_stderr => [0,1,0,0], capture_merged => [1,1,1,0], tee => [1,1,0,1], tee_stdout => [1,0,0,1], tee_stderr => [0,1,0,1], tee_merged => [1,1,1,1], ); for my $sub ( keys %api ) { my $args = join q{, }, @{$api{$sub}}; eval "sub $sub(&;@) {unshift \@_, $args; goto \\&_capture_tee;}"; ## no critic } our @ISA = qw/Exporter/; our @EXPORT_OK = keys %api; our %EXPORT_TAGS = ( 'all' => \@EXPORT_OK ); #--------------------------------------------------------------------------# # constants and fixtures #--------------------------------------------------------------------------# my $IS_WIN32 = $^O eq 'MSWin32'; ##our $DEBUG = $ENV{PERL_CAPTURE_TINY_DEBUG}; ## ##my $DEBUGFH; ##open $DEBUGFH, "> DEBUG" if $DEBUG; ## ##*_debug = $DEBUG ? sub(@) { print {$DEBUGFH} @_ } : sub(){0}; our $TIMEOUT = 30; #--------------------------------------------------------------------------# # command to tee output -- the argument is a filename that must # be opened to signal that the process is ready to receive input. # This is annoying, but seems to be the best that can be done # as a simple, portable IPC technique #--------------------------------------------------------------------------# my @cmd = ($^X, '-C0', '-e', <<'HERE'); use Fcntl; $SIG{HUP}=sub{exit}; if ( my $fn=shift ) { sysopen(my $fh, qq{$fn}, O_WRONLY|O_CREAT|O_EXCL) or die $!; print {$fh} $$; close $fh; } my $buf; while (sysread(STDIN, $buf, 2048)) { syswrite(STDOUT, $buf); syswrite(STDERR, $buf); } HERE #--------------------------------------------------------------------------# # filehandle manipulation #--------------------------------------------------------------------------# sub _relayer { my ($fh, $apply_layers) = @_; # _debug("# requested layers (@{$layers}) for @{[fileno $fh]}\n"); # eliminate pseudo-layers binmode( $fh, ":raw" ); # strip off real layers until only :unix is left while ( 1 < ( my $layers =()= PerlIO::get_layers( $fh, output => 1 ) ) ) { binmode( $fh, ":pop" ); } # apply other layers my @to_apply = @$apply_layers; shift @to_apply; # eliminate initial :unix # _debug("# applying layers (unix @to_apply) to @{[fileno $fh]}\n"); binmode($fh, ":" . join(":",@to_apply)); } sub _name { my $glob = shift; no strict 'refs'; ## no critic return *{$glob}{NAME}; } sub _open { open $_[0], $_[1] or Carp::confess "Error from open(" . join(q{, }, @_) . "): $!"; # _debug( "# open " . join( ", " , map { defined $_ ? _name($_) : 'undef' } @_ ) . " as " . fileno( $_[0] ) . "\n" ); } sub _close { # _debug( "# closing " . ( defined $_[0] ? _name($_[0]) : 'undef' ) . " on " . fileno( $_[0] ) . "\n" ); close $_[0] or Carp::confess "Error from close(" . join(q{, }, @_) . "): $!"; } my %dup; # cache this so STDIN stays fd0 my %proxy_count; sub _proxy_std { my %proxies; if ( ! defined fileno STDIN ) { $proxy_count{stdin}++; if (defined $dup{stdin}) { _open \*STDIN, "<&=" . fileno($dup{stdin}); # _debug( "# restored proxy STDIN as " . (defined fileno STDIN ? fileno STDIN : 'undef' ) . "\n" ); } else { _open \*STDIN, "<" . File::Spec->devnull; # _debug( "# proxied STDIN as " . (defined fileno STDIN ? fileno STDIN : 'undef' ) . "\n" ); _open $dup{stdin} = IO::Handle->new, "<&=STDIN"; } $proxies{stdin} = \*STDIN; binmode(STDIN, ':utf8') if $] >= 5.008; ## no critic } if ( ! defined fileno STDOUT ) { $proxy_count{stdout}++; if (defined $dup{stdout}) { _open \*STDOUT, ">&=" . fileno($dup{stdout}); # _debug( "# restored proxy STDOUT as " . (defined fileno STDOUT ? fileno STDOUT : 'undef' ) . "\n" ); } else { _open \*STDOUT, ">" . File::Spec->devnull; # _debug( "# proxied STDOUT as " . (defined fileno STDOUT ? fileno STDOUT : 'undef' ) . "\n" ); _open $dup{stdout} = IO::Handle->new, ">&=STDOUT"; } $proxies{stdout} = \*STDOUT; binmode(STDOUT, ':utf8') if $] >= 5.008; ## no critic } if ( ! defined fileno STDERR ) { $proxy_count{stderr}++; if (defined $dup{stderr}) { _open \*STDERR, ">&=" . fileno($dup{stderr}); # _debug( "# restored proxy STDERR as " . (defined fileno STDERR ? fileno STDERR : 'undef' ) . "\n" ); } else { _open \*STDERR, ">" . File::Spec->devnull; # _debug( "# proxied STDERR as " . (defined fileno STDERR ? fileno STDERR : 'undef' ) . "\n" ); _open $dup{stderr} = IO::Handle->new, ">&=STDERR"; } $proxies{stderr} = \*STDERR; binmode(STDERR, ':utf8') if $] >= 5.008; ## no critic } return %proxies; } sub _unproxy { my (%proxies) = @_; # _debug( "# unproxying: " . join(" ", keys %proxies) . "\n" ); for my $p ( keys %proxies ) { $proxy_count{$p}--; # _debug( "# unproxied " . uc($p) . " ($proxy_count{$p} left)\n" ); if ( ! $proxy_count{$p} ) { _close $proxies{$p}; _close $dup{$p} unless $] < 5.008; # 5.6 will have already closed this as dup delete $dup{$p}; } } } sub _copy_std { my %handles; for my $h ( qw/stdout stderr stdin/ ) { next if $h eq 'stdin' && ! $IS_WIN32; # WIN32 hangs on tee without STDIN copied my $redir = $h eq 'stdin' ? "<&" : ">&"; _open $handles{$h} = IO::Handle->new(), $redir . uc($h); # ">&STDOUT" or "<&STDIN" } return \%handles; } # In some cases we open all (prior to forking) and in others we only open # the output handles (setting up redirection) sub _open_std { my ($handles) = @_; _open \*STDIN, "<&" . fileno $handles->{stdin} if defined $handles->{stdin}; _open \*STDOUT, ">&" . fileno $handles->{stdout} if defined $handles->{stdout}; _open \*STDERR, ">&" . fileno $handles->{stderr} if defined $handles->{stderr}; } #--------------------------------------------------------------------------# # private subs #--------------------------------------------------------------------------# sub _start_tee { my ($which, $stash) = @_; # $which is "stdout" or "stderr" # setup pipes $stash->{$_}{$which} = IO::Handle->new for qw/tee reader/; pipe $stash->{reader}{$which}, $stash->{tee}{$which}; # _debug( "# pipe for $which\: " . _name($stash->{tee}{$which}) . " " . fileno( $stash->{tee}{$which} ) . " => " . _name($stash->{reader}{$which}) . " " . fileno( $stash->{reader}{$which}) . "\n" ); select((select($stash->{tee}{$which}), $|=1)[0]); # autoflush # setup desired redirection for parent and child $stash->{new}{$which} = $stash->{tee}{$which}; $stash->{child}{$which} = { stdin => $stash->{reader}{$which}, stdout => $stash->{old}{$which}, stderr => $stash->{capture}{$which}, }; # flag file is used to signal the child is ready $stash->{flag_files}{$which} = scalar( tmpnam() ) . $$; # execute @cmd as a separate process if ( $IS_WIN32 ) { my $old_eval_err=$@; undef $@; eval "use Win32API::File qw/GetOsFHandle SetHandleInformation fileLastError HANDLE_FLAG_INHERIT INVALID_HANDLE_VALUE/ "; # _debug( "# Win32API::File loaded\n") unless $@; my $os_fhandle = GetOsFHandle( $stash->{tee}{$which} ); # _debug( "# Couldn't get OS handle: " . fileLastError() . "\n") if ! defined $os_fhandle || $os_fhandle == INVALID_HANDLE_VALUE(); my $result = SetHandleInformation( $os_fhandle, HANDLE_FLAG_INHERIT(), 0); # _debug( $result ? "# set no-inherit flag on $which tee\n" : ("# can't disable tee handle flag inherit: " . fileLastError() . "\n")); _open_std( $stash->{child}{$which} ); $stash->{pid}{$which} = system(1, @cmd, $stash->{flag_files}{$which}); # not restoring std here as it all gets redirected again shortly anyway $@=$old_eval_err; } else { # use fork _fork_exec( $which, $stash ); } } sub _fork_exec { my ($which, $stash) = @_; # $which is "stdout" or "stderr" my $pid = fork; if ( not defined $pid ) { Carp::confess "Couldn't fork(): $!"; } elsif ($pid == 0) { # child # _debug( "# in child process ...\n" ); untie *STDIN; untie *STDOUT; untie *STDERR; _close $stash->{tee}{$which}; # _debug( "# redirecting handles in child ...\n" ); _open_std( $stash->{child}{$which} ); # _debug( "# calling exec on command ...\n" ); exec @cmd, $stash->{flag_files}{$which}; } $stash->{pid}{$which} = $pid } my $have_usleep = eval "use Time::HiRes 'usleep'; 1"; sub _files_exist { return 1 if @_ == grep { -f } @_; Time::HiRes::usleep(1000) if $have_usleep; return 0; } sub _wait_for_tees { my ($stash) = @_; my $start = time; my @files = values %{$stash->{flag_files}}; my $timeout = defined $ENV{PERL_CAPTURE_TINY_TIMEOUT} ? $ENV{PERL_CAPTURE_TINY_TIMEOUT} : $TIMEOUT; 1 until _files_exist(@files) || ($timeout && (time - $start > $timeout)); Carp::confess "Timed out waiting for subprocesses to start" if ! _files_exist(@files); unlink $_ for @files; } sub _kill_tees { my ($stash) = @_; if ( $IS_WIN32 ) { # _debug( "# closing handles\n"); close($_) for values %{ $stash->{tee} }; # _debug( "# waiting for subprocesses to finish\n"); my $start = time; 1 until wait == -1 || (time - $start > 30); } else { _close $_ for values %{ $stash->{tee} }; waitpid $_, 0 for values %{ $stash->{pid} }; } } sub _slurp { my ($name, $stash) = @_; my ($fh, $pos) = map { $stash->{$_}{$name} } qw/capture pos/; # _debug( "# slurping captured $name from " . fileno($fh) . " at pos $pos with layers: @{[PerlIO::get_layers($fh)]}\n"); seek( $fh, $pos, 0 ) or die "Couldn't seek on capture handle for $name\n"; my $text = do { local $/; scalar readline $fh }; return defined($text) ? $text : ""; } #--------------------------------------------------------------------------# # _capture_tee() -- generic main sub for capturing or teeing #--------------------------------------------------------------------------# sub _capture_tee { # _debug( "# starting _capture_tee with (@_)...\n" ); my ($do_stdout, $do_stderr, $do_merge, $do_tee, $code, @opts) = @_; my %do = ($do_stdout ? (stdout => 1) : (), $do_stderr ? (stderr => 1) : ()); Carp::confess("Custom capture options must be given as key/value pairs\n") unless @opts % 2 == 0; my $stash = { capture => { @opts } }; for ( keys %{$stash->{capture}} ) { my $fh = $stash->{capture}{$_}; Carp::confess "Custom handle for $_ must be seekable\n" unless ref($fh) eq 'GLOB' || (blessed($fh) && $fh->isa("IO::Seekable")); } # save existing filehandles and setup captures local *CT_ORIG_STDIN = *STDIN ; local *CT_ORIG_STDOUT = *STDOUT; local *CT_ORIG_STDERR = *STDERR; # find initial layers my %layers = ( stdin => [PerlIO::get_layers(\*STDIN) ], stdout => [PerlIO::get_layers(\*STDOUT, output => 1)], stderr => [PerlIO::get_layers(\*STDERR, output => 1)], ); # _debug( "# existing layers for $_\: @{$layers{$_}}\n" ) for qw/stdin stdout stderr/; # get layers from underlying glob of tied filehandles if we can # (this only works for things that work like Tie::StdHandle) $layers{stdout} = [PerlIO::get_layers(tied *STDOUT)] if tied(*STDOUT) && (reftype tied *STDOUT eq 'GLOB'); $layers{stderr} = [PerlIO::get_layers(tied *STDERR)] if tied(*STDERR) && (reftype tied *STDERR eq 'GLOB'); # _debug( "# tied object corrected layers for $_\: @{$layers{$_}}\n" ) for qw/stdin stdout stderr/; # bypass scalar filehandles and tied handles # localize scalar STDIN to get a proxy to pick up FD0, then restore later to CT_ORIG_STDIN my %localize; $localize{stdin}++, local(*STDIN) if grep { $_ eq 'scalar' } @{$layers{stdin}}; $localize{stdout}++, local(*STDOUT) if $do_stdout && grep { $_ eq 'scalar' } @{$layers{stdout}}; $localize{stderr}++, local(*STDERR) if ($do_stderr || $do_merge) && grep { $_ eq 'scalar' } @{$layers{stderr}}; $localize{stdin}++, local(*STDIN), _open( \*STDIN, "<&=0") if tied *STDIN && $] >= 5.008; $localize{stdout}++, local(*STDOUT), _open( \*STDOUT, ">&=1") if $do_stdout && tied *STDOUT && $] >= 5.008; $localize{stderr}++, local(*STDERR), _open( \*STDERR, ">&=2") if ($do_stderr || $do_merge) && tied *STDERR && $] >= 5.008; # _debug( "# localized $_\n" ) for keys %localize; # proxy any closed/localized handles so we don't use fds 0, 1 or 2 my %proxy_std = _proxy_std(); # _debug( "# proxy std: @{ [%proxy_std] }\n" ); # update layers after any proxying $layers{stdout} = [PerlIO::get_layers(\*STDOUT, output => 1)] if $proxy_std{stdout}; $layers{stderr} = [PerlIO::get_layers(\*STDERR, output => 1)] if $proxy_std{stderr}; # _debug( "# post-proxy layers for $_\: @{$layers{$_}}\n" ) for qw/stdin stdout stderr/; # store old handles and setup handles for capture $stash->{old} = _copy_std(); $stash->{new} = { %{$stash->{old}} }; # default to originals for ( keys %do ) { $stash->{new}{$_} = ($stash->{capture}{$_} ||= File::Temp->new); seek( $stash->{capture}{$_}, 0, 2 ) or die "Could not seek on capture handle for $_\n"; $stash->{pos}{$_} = tell $stash->{capture}{$_}; # _debug("# will capture $_ on " . fileno($stash->{capture}{$_})."\n" ); _start_tee( $_ => $stash ) if $do_tee; # tees may change $stash->{new} } _wait_for_tees( $stash ) if $do_tee; # finalize redirection $stash->{new}{stderr} = $stash->{new}{stdout} if $do_merge; # _debug( "# redirecting in parent ...\n" ); _open_std( $stash->{new} ); # execute user provided code my ($exit_code, $inner_error, $outer_error, $orig_pid, @result); { $orig_pid = $$; local *STDIN = *CT_ORIG_STDIN if $localize{stdin}; # get original, not proxy STDIN # _debug( "# finalizing layers ...\n" ); _relayer(\*STDOUT, $layers{stdout}) if $do_stdout; _relayer(\*STDERR, $layers{stderr}) if $do_stderr; # _debug( "# running code $code ...\n" ); my $old_eval_err=$@; undef $@; eval { @result = $code->(); $inner_error = $@ }; $exit_code = $?; # save this for later $outer_error = $@; # save this for later STDOUT->flush if $do_stdout; STDERR->flush if $do_stderr; $@ = $old_eval_err; } # restore prior filehandles and shut down tees # _debug( "# restoring filehandles ...\n" ); _open_std( $stash->{old} ); _close( $_ ) for values %{$stash->{old}}; # don't leak fds # shouldn't need relayering originals, but see rt.perl.org #114404 _relayer(\*STDOUT, $layers{stdout}) if $do_stdout; _relayer(\*STDERR, $layers{stderr}) if $do_stderr; _unproxy( %proxy_std ); # _debug( "# killing tee subprocesses ...\n" ) if $do_tee; _kill_tees( $stash ) if $do_tee; # return captured output, but shortcut in void context # unless we have to echo output to tied/scalar handles; my %got; if ( $orig_pid == $$ and ( defined wantarray or ($do_tee && keys %localize) ) ) { for ( keys %do ) { _relayer($stash->{capture}{$_}, $layers{$_}); $got{$_} = _slurp($_, $stash); # _debug("# slurped " . length($got{$_}) . " bytes from $_\n"); } print CT_ORIG_STDOUT $got{stdout} if $do_stdout && $do_tee && $localize{stdout}; print CT_ORIG_STDERR $got{stderr} if $do_stderr && $do_tee && $localize{stderr}; } $? = $exit_code; $@ = $inner_error if $inner_error; die $outer_error if $outer_error; # _debug( "# ending _capture_tee with (@_)...\n" ); return unless defined wantarray; my @return; push @return, $got{stdout} if $do_stdout; push @return, $got{stderr} if $do_stderr && ! $do_merge; push @return, @result; return wantarray ? @return : $return[0]; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Capture::Tiny - Capture STDOUT and STDERR from Perl, XS or external programs =head1 VERSION version 0.48 =head1 SYNOPSIS use Capture::Tiny ':all'; # capture from external command ($stdout, $stderr, $exit) = capture { system( $cmd, @args ); }; # capture from arbitrary code (Perl or external) ($stdout, $stderr, @result) = capture { # your code here }; # capture partial or merged output $stdout = capture_stdout { ... }; $stderr = capture_stderr { ... }; $merged = capture_merged { ... }; # tee output ($stdout, $stderr) = tee { # your code here }; $stdout = tee_stdout { ... }; $stderr = tee_stderr { ... }; $merged = tee_merged { ... }; =head1 DESCRIPTION Capture::Tiny provides a simple, portable way to capture almost anything sent to STDOUT or STDERR, regardless of whether it comes from Perl, from XS code or from an external program. Optionally, output can be teed so that it is captured while being passed through to the original filehandles. Yes, it even works on Windows (usually). Stop guessing which of a dozen capturing modules to use in any particular situation and just use this one. =head1 USAGE The following functions are available. None are exported by default. =head2 capture ($stdout, $stderr, @result) = capture \&code; $stdout = capture \&code; The C function takes a code reference and returns what is sent to STDOUT and STDERR as well as any return values from the code reference. In scalar context, it returns only STDOUT. If no output was received for a filehandle, it returns an empty string for that filehandle. Regardless of calling context, all output is captured -- nothing is passed to the existing filehandles. It is prototyped to take a subroutine reference as an argument. Thus, it can be called in block form: ($stdout, $stderr) = capture { # your code here ... }; Note that the coderef is evaluated in list context. If you wish to force scalar context on the return value, you must use the C keyword. ($stdout, $stderr, $count) = capture { my @list = qw/one two three/; return scalar @list; # $count will be 3 }; Also note that within the coderef, the C<@_> variable will be empty. So don't use arguments from a surrounding subroutine without copying them to an array first: sub wont_work { my ($stdout, $stderr) = capture { do_stuff( @_ ) }; # WRONG ... } sub will_work { my @args = @_; my ($stdout, $stderr) = capture { do_stuff( @args ) }; # RIGHT ... } Captures are normally done to an anonymous temporary filehandle. To capture via a named file (e.g. to externally monitor a long-running capture), provide custom filehandles as a trailing list of option pairs: my $out_fh = IO::File->new("out.txt", "w+"); my $err_fh = IO::File->new("out.txt", "w+"); capture { ... } stdout => $out_fh, stderr => $err_fh; The filehandles must be read/write and seekable. Modifying the files or filehandles during a capture operation will give unpredictable results. Existing IO layers on them may be changed by the capture. When called in void context, C saves memory and time by not reading back from the capture handles. =head2 capture_stdout ($stdout, @result) = capture_stdout \&code; $stdout = capture_stdout \&code; The C function works just like C except only STDOUT is captured. STDERR is not captured. =head2 capture_stderr ($stderr, @result) = capture_stderr \&code; $stderr = capture_stderr \&code; The C function works just like C except only STDERR is captured. STDOUT is not captured. =head2 capture_merged ($merged, @result) = capture_merged \&code; $merged = capture_merged \&code; The C function works just like C except STDOUT and STDERR are merged. (Technically, STDERR is redirected to the same capturing handle as STDOUT before executing the function.) Caution: STDOUT and STDERR output in the merged result are not guaranteed to be properly ordered due to buffering. =head2 tee ($stdout, $stderr, @result) = tee \&code; $stdout = tee \&code; The C function works just like C, except that output is captured as well as passed on to the original STDOUT and STDERR. When called in void context, C saves memory and time by not reading back from the capture handles, except when the original STDOUT OR STDERR were tied or opened to a scalar handle. =head2 tee_stdout ($stdout, @result) = tee_stdout \&code; $stdout = tee_stdout \&code; The C function works just like C except only STDOUT is teed. STDERR is not teed (output goes to STDERR as usual). =head2 tee_stderr ($stderr, @result) = tee_stderr \&code; $stderr = tee_stderr \&code; The C function works just like C except only STDERR is teed. STDOUT is not teed (output goes to STDOUT as usual). =head2 tee_merged ($merged, @result) = tee_merged \&code; $merged = tee_merged \&code; The C function works just like C except that output is captured as well as passed on to STDOUT. Caution: STDOUT and STDERR output in the merged result are not guaranteed to be properly ordered due to buffering. =head1 LIMITATIONS =head2 Portability Portability is a goal, not a guarantee. C requires fork, except on Windows where C is used instead. Not tested on any particularly esoteric platforms yet. See the L for test result by platform. =head2 PerlIO layers Capture::Tiny does its best to preserve PerlIO layers such as ':utf8' or ':crlf' when capturing (only for Perl 5.8.1+) . Layers should be applied to STDOUT or STDERR I the call to C or C. This may not work for tied filehandles (see below). =head2 Modifying filehandles before capturing Generally speaking, you should do little or no manipulation of the standard IO filehandles prior to using Capture::Tiny. In particular, closing, reopening, localizing or tying standard filehandles prior to capture may cause a variety of unexpected, undesirable and/or unreliable behaviors, as described below. Capture::Tiny does its best to compensate for these situations, but the results may not be what you desire. =head3 Closed filehandles Capture::Tiny will work even if STDIN, STDOUT or STDERR have been previously closed. However, since they will be reopened to capture or tee output, any code within the captured block that depends on finding them closed will, of course, not find them to be closed. If they started closed, Capture::Tiny will close them again when the capture block finishes. Note that this reopening will happen even for STDIN or a filehandle not being captured to ensure that the filehandle used for capture is not opened to file descriptor 0, as this causes problems on various platforms. Prior to Perl 5.12, closed STDIN combined with PERL_UNICODE=D leaks filehandles and also breaks tee() for undiagnosed reasons. So don't do that. =head3 Localized filehandles If code localizes any of Perl's standard filehandles before capturing, the capture will affect the localized filehandles and not the original ones. External system calls are not affected by localizing a filehandle in Perl and will continue to send output to the original filehandles (which will thus not be captured). =head3 Scalar filehandles If STDOUT or STDERR are reopened to scalar filehandles prior to the call to C or C, then Capture::Tiny will override the output filehandle for the duration of the C or C call and then, for C, send captured output to the output filehandle after the capture is complete. (Requires Perl 5.8) Capture::Tiny attempts to preserve the semantics of STDIN opened to a scalar reference, but note that external processes will not be able to read from such a handle. Capture::Tiny tries to ensure that external processes will read from the null device instead, but this is not guaranteed. =head3 Tied output filehandles If STDOUT or STDERR are tied prior to the call to C or C, then Capture::Tiny will attempt to override the tie for the duration of the C or C call and then send captured output to the tied filehandle after the capture is complete. (Requires Perl 5.8) Capture::Tiny may not succeed resending UTF-8 encoded data to a tied STDOUT or STDERR filehandle. Characters may appear as bytes. If the tied filehandle is based on L, then Capture::Tiny will attempt to determine appropriate layers like C<:utf8> from the underlying filehandle and do the right thing. =head3 Tied input filehandle Capture::Tiny attempts to preserve the semantics of tied STDIN, but this requires Perl 5.8 and is not entirely predictable. External processes will not be able to read from such a handle. Unless having STDIN tied is crucial, it may be safest to localize STDIN when capturing: my ($out, $err) = do { local *STDIN; capture { ... } }; =head2 Modifying filehandles during a capture Attempting to modify STDIN, STDOUT or STDERR I C or C is almost certainly going to cause problems. Don't do that. =head3 Forking inside a capture Forks aren't portable. The behavior of filehandles during a fork is even less so. If Capture::Tiny detects that a fork has occurred within a capture, it will shortcut in the child process and return empty strings for captures. Other problems may occur in the child or parent, as well. Forking in a capture block is not recommended. =head3 Using threads Filehandles are global. Mixing up I/O and captures in different threads without coordination is going to cause problems. Besides, threads are officially discouraged. =head3 Dropping privileges during a capture If you drop privileges during a capture, temporary files created to facilitate the capture may not be cleaned up afterwards. =head2 No support for Perl 5.8.0 It's just too buggy when it comes to layers and UTF-8. Perl 5.8.1 or later is recommended. =head2 Limited support for Perl 5.6 Perl 5.6 predates PerlIO. UTF-8 data may not be captured correctly. =head1 ENVIRONMENT =head2 PERL_CAPTURE_TINY_TIMEOUT Capture::Tiny uses subprocesses internally for C. By default, Capture::Tiny will timeout with an error if such subprocesses are not ready to receive data within 30 seconds (or whatever is the value of C<$Capture::Tiny::TIMEOUT>). An alternate timeout may be specified by setting the C environment variable. Setting it to zero will disable timeouts. B, this does not timeout the code reference being captured -- this only prevents Capture::Tiny itself from hanging your process waiting for its child processes to be ready to proceed. =head1 SEE ALSO This module was inspired by L, which provides similar functionality without the ability to tee output and with more complicated code and API. L does not handle layers or most of the unusual cases described in the L section and I no longer recommend it. There are many other CPAN modules that provide some sort of output capture, albeit with various limitations that make them appropriate only in particular circumstances. I'm probably missing some. The long list is provided to show why I felt Capture::Tiny was necessary. =over 4 =item * L =item * L =item * L =item * L =item * L =item * L =item * L =item * L =item * L =item * L =item * L =item * L =item * L =item * L =item * L =item * L =item * L =item * L =item * L =item * L =item * L =back =for :stopwords cpan testmatrix url annocpan anno bugtracker rt cpants kwalitee diff irc mailto metadata placeholders metacpan =head1 SUPPORT =head2 Bugs / Feature Requests Please report any bugs or feature requests through the issue tracker at L. You will be notified automatically of any progress on your issue. =head2 Source Code This is open source software. The code repository is available for public review and contribution under the terms of the license. L git clone https://github.com/dagolden/Capture-Tiny.git =head1 AUTHOR David Golden =head1 CONTRIBUTORS =for stopwords Dagfinn Ilmari Mannsåker David E. Wheeler fecundf Graham Knop Peter Rabbitson =over 4 =item * Dagfinn Ilmari Mannsåker =item * David E. Wheeler =item * fecundf =item * Graham Knop =item * Peter Rabbitson =back =head1 COPYRIGHT AND LICENSE This software is Copyright (c) 2009 by David Golden. This is free software, licensed under: The Apache License, Version 2.0, January 2004 =cut List-MoreUtils-0.430/inc/inc_Config-AutoConf/0000755000175000017500000000000013744044757017076 5ustar snosnoList-MoreUtils-0.430/inc/inc_Config-AutoConf/Config/0000755000175000017500000000000013744044757020303 5ustar snosnoList-MoreUtils-0.430/inc/inc_Config-AutoConf/Config/AutoConf.pm0000644000175000017500000036324413735543550022366 0ustar snosnopackage Config::AutoConf; use warnings; use strict; use base 'Exporter'; our @EXPORT = ('$LIBEXT', '$EXEEXT'); use constant QUOTE => do { $^O eq "MSWin32" ? q["] : q['] }; use Config; use Carp qw/croak/; use File::Temp qw/tempfile/; use File::Basename; use File::Spec; use Text::ParseWords qw//; use Capture::Tiny qw/capture/; # in core since 5.7.3 eval "use Scalar::Util qw/looks_like_number/;"; __PACKAGE__->can("looks_like_number") or eval <<'EOP'; =begin private =head2 looks_like_number =end private =cut # from PP part of Params::Util sub looks_like_number { local $_ = shift; # checks from perlfaq4 return 0 if !defined($_); if (ref($_)) { return overload::Overloaded($_) ? defined(0 + $_) : 0; } return 1 if (/^[+-]?[0-9]+$/); # is a +/- integer return 1 if (/^([+-]?)(?=[0-9]|\.[0-9])[0-9]*(\.[0-9]*)?([Ee]([+-]?[0-9]+))?$/); # a C float return 1 if ($] >= 5.008 and /^(Inf(inity)?|NaN)$/i) or ($] >= 5.006001 and /^Inf$/i); 0; } EOP eval "use File::Slurper qw/read_binary/;"; __PACKAGE__->can("read_binary") or eval <<'EOP'; =begin private =head2 read_file =end private =cut sub read_binary { my $fn = shift; local $@ = ""; open( my $fh, "<", $fn ) or croak "Error opening $fn: $!"; my $fc = <$fh>; close($fh) or croak "I/O error closing $fn: $!"; return $fc; } EOP # PA-RISC1.1-thread-multi my %special_dlext = ( darwin => ".dylib", MSWin32 => ".dll", ($Config{archname} =~ m/PA-RISC/i ? ("hpux" => ".sl") : ()), ); our ($LIBEXT, $EXEEXT); defined $LIBEXT or $LIBEXT = defined $Config{so} ? "." . $Config{so} : defined $special_dlext{$^O} ? $special_dlext{$^O} : ".so"; defined $EXEEXT or $EXEEXT = ($^O eq "MSWin32") ? ".exe" : ""; =encoding UTF-8 =head1 NAME Config::AutoConf - A module to implement some of AutoConf macros in pure perl. =cut our $VERSION = '0.319'; $VERSION = eval $VERSION; =head1 ABSTRACT With this module I pretend to simulate some of the tasks AutoConf macros do. To detect a command, to detect a library, etc. =head1 SYNOPSIS use Config::AutoConf; Config::AutoConf->check_prog("agrep"); my $grep = Config::AutoConf->check_progs("agrep", "egrep", "grep"); Config::AutoConf->check_header("ncurses.h"); my $curses = Config::AutoConf->check_headers("ncurses.h","curses.h"); Config::AutoConf->check_prog_awk; Config::AutoConf->check_prog_egrep; Config::AutoConf->check_cc(); Config::AutoConf->check_lib("ncurses", "tgoto"); Config::AutoConf->check_file("/etc/passwd"); # -f && -r =head1 DESCRIPTION Config::AutoConf is intended to provide the same opportunities to Perl developers as L does for Shell developers. As Perl is the second most deployed language (mind: every Unix comes with Perl, several mini-computers have Perl and even lot's of Windows machines run Perl software - which requires deployed Perl there, too), this gives wider support than Shell based probes. The API is leaned against GNU Autoconf, but we try to make the API (especially optional arguments) more Perl'ish than m4 abilities allow to the original. =head1 CONSTRUCTOR =cut my $glob_instance; =head2 new This function instantiates a new instance of Config::AutoConf, e.g. to configure child components. The constructor adds also values set via environment variable C. =cut sub new { my $class = shift; ref $class and $class = ref $class; my %args = @_; my %flags = map { my ($k, $v) = split("=", $_, 2); defined $v or $v = 1; ($k, $v) } split(":", $ENV{PERL5_AC_OPTS}) if ($ENV{PERL5_AC_OPTS}); my %instance = ( msg_prefix => 'configure: ', lang => "C", lang_stack => [], lang_supported => { "C" => $class->can("check_prog_cc"), }, cache => {}, defines => {}, extra_libs => [], extra_lib_dirs => [], extra_include_dirs => [], extra_preprocess_flags => [], extra_compile_flags => { "C" => [], }, extra_link_flags => [], logfile => "config.log", c_ac_flags => {%flags}, %args ); bless(\%instance, $class); } =head1 METHODS =head2 check_file This function checks if a file exists in the system and is readable by the user. Returns a boolean. You can use '-f $file && -r $file' so you don't need to use a function call. =cut sub check_file { my $self = shift->_get_instance(); my $file = shift; my $cache_name = $self->_cache_name("file", $file); $self->check_cached( $cache_name, "for $file", sub { -f $file && -r $file; } ); } =head2 check_files This function checks if a set of files exist in the system and are readable by the user. Returns a boolean. =cut sub check_files { my $self = shift->_get_instance(); for (@_) { return 0 unless $self->check_file($_); } 1; } sub _quote_shell_arg { scalar Text::ParseWords::shellwords($_[0]) > 1 ? QUOTE . $_[0] . QUOTE : $_[0] } sub _sanitize_prog { shift; _quote_shell_arg shift } sub _append_prog_args { shift; join " ", map { _quote_shell_arg $_ } @_; } my @exe_exts = ($^O eq "MSWin32" ? qw(.exe .com .bat .cmd) : ("")); =head2 check_prog( $prog, \@dirlist?, \%options? ) This function checks for a program with the supplied name. In success returns the full path for the executable; An optional array reference containing a list of directories to be searched instead of $PATH is gracefully honored. If the very last parameter contains a hash reference, C references to I or I are executed, respectively. =cut sub check_prog { my $self = shift->_get_instance(); # sanitize ac_prog my $ac_prog = _sanitize(shift @_); my $options = {}; scalar @_ > 1 and ref $_[-1] eq "HASH" and $options = pop @_; my @dirlist; @_ and scalar @_ > 1 and @dirlist = @_; @_ and scalar @_ == 1 and ref $_[0] eq "ARRAY" and @dirlist = @{$_[0]}; @dirlist or @dirlist = split(/$Config{path_sep}/, $ENV{PATH}); for my $p (@dirlist) { for my $e (@exe_exts) { my $cmd = $self->_sanitize_prog(File::Spec->catfile($p, $ac_prog . $e)); my $is_executable = -x $cmd and -f $cmd; $is_executable and $options->{action_on_true} and ref $options->{action_on_true} eq "CODE" and $options->{action_on_true}->(); $is_executable and return $cmd; } } $options->{action_on_false} and ref $options->{action_on_false} eq "CODE" and $options->{action_on_false}->(); return; } =head2 check_progs(progs, [dirlist]) This function takes a list of program names. Returns the full path for the first found on the system. Returns undef if none was found. An optional array reference containing a list of directories to be searched instead of $PATH is gracefully honored. If the very last parameter contains a hash reference, C references to I or I are executed, respectively. The name of the I<$prog> to check and the found full path are passed as first and second argument to the I callback. =cut sub check_progs { my $self = shift->_get_instance(); my $options = {}; scalar @_ > 1 and ref $_[-1] eq "HASH" and $options = pop @_; my @dirlist; scalar @_ > 1 and ref $_[-1] eq "ARRAY" and @dirlist = @{pop @_}; @dirlist or @dirlist = split(/$Config{path_sep}/, $ENV{PATH}); my @progs = @_; foreach my $prog (@progs) { defined $prog or next; my $ans = $self->check_prog($prog, \@dirlist); $ans and $options->{action_on_true} and ref $options->{action_on_true} eq "CODE" and $options->{action_if_true}->($prog, $ans); $ans and return $ans; } $options->{action_on_false} and ref $options->{action_on_false} eq "CODE" and $options->{action_on_false}->(); return; } =head2 check_prog_yacc From the L documentation, If `bison' is found, set [...] `bison -y'. Otherwise, if `byacc' is found, set [...] `byacc'. Otherwise set [...] `yacc'. The result of this test can be influenced by setting the variable YACC or the cache variable ac_cv_prog_YACC. Returns the full path, if found. =cut sub check_prog_yacc { my $self = shift->_get_instance(); # my ($self, $cache_name, $message, $check_sub) = @_; my $cache_name = $self->_cache_name("prog", "YACC"); $self->check_cached( $cache_name, "for yacc", sub { defined $ENV{YACC} and return $ENV{YACC}; my $binary = $self->check_progs(qw/bison byacc yacc/); defined $binary and $binary =~ /bison(?:\.(?:exe|com|bat|cmd))?$/ and $binary = $self->_append_prog_args($binary, "-y"); return $binary; } ); } =head2 check_prog_awk From the L documentation, Check for `gawk', `mawk', `nawk', and `awk', in that order, and set output [...] to the first one that is found. It tries `gawk' first because that is reported to be the best implementation. The result can be overridden by setting the variable AWK or the cache variable ac_cv_prog_AWK. Note that it returns the full path, if found. =cut sub check_prog_awk { my $self = shift->_get_instance(); my $cache_name = $self->_cache_name("prog", "AWK"); $self->check_cached($cache_name, "for awk", sub { $ENV{AWK} || $self->check_progs(qw/gawk mawk nawk awk/) }); } =head2 check_prog_egrep From the L documentation, Check for `grep -E' and `egrep', in that order, and [...] output [...] the first one that is found. The result can be overridden by setting the EGREP variable and is cached in the ac_cv_path_EGREP variable. Note that it returns the full path, if found. =cut sub check_prog_egrep { my $self = shift->_get_instance(); my $cache_name = $self->_cache_name("prog", "EGREP"); $self->check_cached( $cache_name, "for egrep", sub { defined $ENV{EGREP} and return $ENV{EGREP}; my $grep; $grep = $self->check_progs("egrep") and return $grep; if ($grep = $self->check_prog("grep")) { # check_run - Capture::Tiny, Open3 ... ftw! my $ans = `echo a | ($grep -E '(a|b)') 2>/dev/null`; chomp $ans; $ans eq "a" and return $self->_append_prog_args($grep, "-E"); } } ); } =head2 check_prog_lex From the L documentation, If flex is found, set output [...] to ‘flex’ and [...] to -lfl, if that library is in a standard place. Otherwise set output [...] to ‘lex’ and [...] to -ll, if found. If [...] packages [...] ship the generated file.yy.c alongside the source file.l, this [...] allows users without a lexer generator to still build the package even if the timestamp for file.l is inadvertently changed. Note that it returns the full path, if found. The structure $self->{lex} is set with attributes prog => $LEX lib => $LEXLIB root => $lex_root =cut sub check_prog_lex { my $self = shift->_get_instance; my $cache_name = $self->_cache_name("prog", "LEX"); my $lex = $self->check_cached($cache_name, "for lex", sub { $ENV{LEX} || $self->check_progs(qw/flex lex/) }); if ($lex) { defined $self->{lex}->{prog} or $self->{lex}->{prog} = $lex; my $lex_root_var = $self->check_cached( "ac_cv_prog_lex_root", "for lex output file root", sub { my ($fh, $filename) = tempfile( "testXXXXXX", SUFFIX => '.l', UNLINK => 0 ); my $src = <<'EOLEX'; %% a { ECHO; } b { REJECT; } c { yymore (); } d { yyless (1); } e { /* IRIX 6.5 flex 2.5.4 underquotes its yyless argument. */ yyless ((input () != 0)); } f { unput (yytext[0]); } . { BEGIN INITIAL; } %% #ifdef YYTEXT_POINTER extern char *yytext; #endif int main (void) { return ! yylex () + ! yywrap (); } EOLEX print {$fh} $src; close $fh; my ($stdout, $stderr, $exit) = capture { system($lex, $filename); }; chomp $stdout; unlink $filename; -f "lex.yy.c" and return "lex.yy"; -f "lexyy.c" and return "lexyy"; $self->msg_error("cannot find output from $lex; giving up"); } ); defined $self->{lex}->{root} or $self->{lex}->{root} = $lex_root_var; my $conftest = read_binary($lex_root_var . ".c"); unlink $lex_root_var . ".c"; $cache_name = $self->_cache_name("lib", "lex"); my $check_sub = sub { my @save_libs = @{$self->{extra_libs}}; my $have_lib = 0; foreach my $libstest (undef, qw(-lfl -ll)) { # XXX would local work on array refs? can we omit @save_libs? $self->{extra_libs} = [@save_libs]; defined($libstest) and unshift(@{$self->{extra_libs}}, $libstest); $self->link_if_else($conftest) and ($have_lib = defined($libstest) ? $libstest : "none required") and last; } $self->{extra_libs} = [@save_libs]; if ($have_lib) { $self->define_var(_have_lib_define_name("lex"), $have_lib, "defined when lex library is available"); } else { $self->define_var(_have_lib_define_name("lex"), undef, "defined when lex library is available"); } return $have_lib; }; my $lex_lib = $self->check_cached($cache_name, "lex library", $check_sub); defined $self->{lex}->{lib} or $self->{lex}->{lib} = $lex_lib; } $lex; } =head2 check_prog_sed From the L documentation, Set output variable [...] to a Sed implementation that conforms to Posix and does not have arbitrary length limits. Report an error if no acceptable Sed is found. See Limitations of Usual Tools, for more information about portability problems with Sed. The result of this test can be overridden by setting the SED variable and is cached in the ac_cv_path_SED variable. Note that it returns the full path, if found. =cut sub check_prog_sed { my $self = shift->_get_instance(); my $cache_name = $self->_cache_name("prog", "SED"); $self->check_cached($cache_name, "for sed", sub { $ENV{SED} || $self->check_progs(qw/gsed sed/) }); } =head2 check_prog_pkg_config Checks for C program. No additional tests are made for it ... =cut sub check_prog_pkg_config { my $self = shift->_get_instance(); my $cache_name = $self->_cache_name("prog", "PKG_CONFIG"); $self->check_cached($cache_name, "for pkg-config", sub { $self->check_prog("pkg-config") }); } =head2 check_prog_cc Determine a C compiler to use. Currently the probe is delegated to L. =cut sub check_prog_cc { my $self = shift->_get_instance(); my $cache_name = $self->_cache_name("prog", "CC"); $self->check_cached( $cache_name, "for cc", sub { $self->{lang_supported}->{C} = undef; eval "use ExtUtils::CBuilder;"; $@ and return; my $cb = ExtUtils::CBuilder->new(quiet => 1); $cb->have_compiler or return; $self->{lang_supported}->{C} = "ExtUtils::CBuilder"; $cb->{config}->{cc}; } ); } =head2 check_cc (Deprecated) Old name of L. =cut sub check_cc { shift->check_prog_cc(@_) } =head2 check_valid_compiler This function checks for a valid compiler for the currently active language. At the very moment only C is understood (corresponding to your compiler default options, e.g. -std=gnu89). =cut sub check_valid_compiler { my $self = shift->_get_instance; my $lang = $self->{lang}; $lang eq "C" or $self->msg_error("Language $lang is not supported"); $self->check_prog_cc; } =head2 check_valid_compilers(;\@) Checks for valid compilers for each given language. When unspecified defaults to C<[ "C" ]>. =cut sub check_valid_compilers { my $self = shift; for my $lang (@{$_[0]}) { $self->push_lang($lang); my $supp = $self->check_valid_compiler; $self->pop_lang($lang); $supp or return 0; } 1; } =head2 msg_checking Prints "Checking @_ ..." =cut sub msg_checking { my $self = shift->_get_instance(); $self->{quiet} or print "Checking " . join(" ", @_) . "... "; $self->_add_log_entry("Checking " . join(" ", @_, "...")); return; } =head2 msg_result Prints result \n =cut my @_num_to_msg = qw/no yes/; sub _neat { defined $_[0] or return ""; looks_like_number($_[0]) and defined $_num_to_msg[$_[0]] and return $_num_to_msg[$_[0]]; $_[0]; } sub msg_result { my $self = shift->_get_instance(); $self->{quiet} or print join(" ", map { _neat $_ } @_), "\n"; $self->_add_log_entry(join(" ", map { _neat $_ } @_), "\n"); return; } =head2 msg_notice Prints "configure: " @_ to stdout =cut sub msg_notice { my $self = shift->_get_instance(); $self->{quiet} or print $self->{msg_prefix} . join(" ", @_) . "\n"; $self->_add_log_entry($self->{msg_prefix} . join(" ", @_) . "\n"); return; } =head2 msg_warn Prints "configure: " @_ to stderr =cut sub msg_warn { my $self = shift->_get_instance(); print STDERR $self->{msg_prefix} . join(" ", @_) . "\n"; $self->_add_log_entry("WARNING: " . $self->{msg_prefix} . join(" ", @_) . "\n"); return; } =head2 msg_error Prints "configure: " @_ to stderr and exits with exit code 0 (tells toolchain to stop here and report unsupported environment) =cut sub msg_error { my $self = shift->_get_instance(); print STDERR $self->{msg_prefix} . join(" ", @_) . "\n"; $self->_add_log_entry("ERROR: " . $self->{msg_prefix} . join(" ", @_) . "\n"); exit(0); # #toolchain agreement: prevents configure stage to finish } =head2 msg_failure Prints "configure: " @_ to stderr and exits with exit code 0 (tells toolchain to stop here and report unsupported environment). Additional details are provides in config.log (probably more information in a later stage). =cut sub msg_failure { my $self = shift->_get_instance(); print STDERR $self->{msg_prefix} . join(" ", @_) . "\n"; $self->_add_log_entry("FAILURE: " . $self->{msg_prefix} . join(" ", @_) . "\n"); exit(0); # #toolchain agreement: prevents configure stage to finish } =head2 define_var( $name, $value [, $comment ] ) Defines a check variable for later use in further checks or code to compile. Returns the value assigned value =cut sub define_var { my $self = shift->_get_instance(); my ($name, $value, $comment) = @_; defined($name) or croak("Need a name to add a define"); $self->{defines}->{$name} = [$value, $comment]; $value; } =head2 write_config_h( [$target] ) Writes the defined constants into given target: Config::AutoConf->write_config_h( "config.h" ); =cut sub write_config_h { my $self = shift->_get_instance(); my $tgt; defined($_[0]) ? ( ref($_[0]) ? $tgt = $_[0] : open($tgt, ">", $_[0]) ) : open($tgt, ">", "config.h"); my $conf_h = <<'EOC'; /** * Generated from Config::AutoConf * * Do not edit this file, all modifications will be lost, * modify Makefile.PL or Build.PL instead. * * Inspired by GNU AutoConf. * * (c) 2011 Alberto Simoes & Jens Rehsack */ #ifndef __CONFIG_H__ EOC while (my ($defname, $defcnt) = each(%{$self->{defines}})) { if ($defcnt->[0]) { defined $defcnt->[1] and $conf_h .= "/* " . $defcnt->[1] . " */\n"; $conf_h .= join(" ", "#define", $defname, $defcnt->[0]) . "\n"; } else { defined $defcnt->[1] and $conf_h .= "/* " . $defcnt->[1] . " */\n"; $conf_h .= "/* " . join(" ", "#undef", $defname) . " */\n\n"; } } $conf_h .= "#endif /* ?__CONFIG_H__ */\n"; print {$tgt} $conf_h; return; } =head2 push_lang(lang [, implementor ]) Puts the current used language on the stack and uses specified language for subsequent operations until ending pop_lang call. =cut sub push_lang { my $self = shift->_get_instance(); push @{$self->{lang_stack}}, [$self->{lang}]; $self->_set_language(@_); } =head2 pop_lang([ lang ]) Pops the currently used language from the stack and restores previously used language. If I specified, it's asserted that the current used language equals to specified language (helps finding control flow bugs). =cut sub pop_lang { my $self = shift->_get_instance(); scalar(@{$self->{lang_stack}}) > 0 or croak("Language stack empty"); defined($_[0]) and $self->{lang} ne $_[0] and croak("pop_lang( $_[0] ) doesn't match language in use (" . $self->{lang} . ")"); $self->_set_language(@{pop @{$self->{lang_stack}}}); } =head2 lang_build_program( prologue, body ) Builds program for current chosen language. If no prologue is given (I), the default headers are used. If body is missing, default body is used. Typical call of Config::AutoConf->lang_build_program( "const char hw[] = \"Hello, World\\n\";", "fputs (hw, stdout);" ) will create const char hw[] = "Hello, World\n"; /* Override any gcc2 internal prototype to avoid an error. */ #ifdef __cplusplus extern "C" { #endif int main (int argc, char **argv) { (void)argc; (void)argv; fputs (hw, stdout);; return 0; } #ifdef __cplusplus } #endif =cut sub lang_build_program { my ($self, $prologue, $body) = @_; ref $self or $self = $self->_get_instance(); defined($prologue) or $prologue = $self->_default_includes(); defined($body) or $body = ""; $body = $self->_build_main($body); $self->_fill_defines() . "\n$prologue\n\n$body\n"; } sub _lang_prologue_func { my ($self, $prologue, $function) = @_; ref $self or $self = $self->_get_instance(); defined($prologue) or $prologue = $self->_default_includes(); $prologue .= <<"_ACEOF"; /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" { #endif char $function (); #ifdef __cplusplus } #endif _ACEOF return $prologue; } sub _lang_body_func { my ($self, $function) = @_; ref $self or $self = $self->_get_instance(); my $func_call = "return $function ();"; return $func_call; } =head2 lang_call( [prologue], function ) Builds program which simply calls given function. When given, prologue is prepended otherwise, the default includes are used. =cut sub lang_call { my ($self, $prologue, $function) = @_; ref $self or $self = $self->_get_instance(); return $self->lang_build_program($self->_lang_prologue_func($prologue, $function), $self->_lang_body_func($function),); } sub _lang_prologue_builtin { my ($self, $prologue, $builtin) = @_; ref $self or $self = $self->_get_instance(); defined($prologue) or $prologue = $self->_default_includes(); $prologue .= <<"_ACEOF"; #if !defined(__has_builtin) #undef $builtin /* Declare this builtin with the same prototype as __builtin_$builtin. This removes a warning about conflicting types for built-in builtin $builtin */ __typeof__(__builtin_$builtin) $builtin; __typeof__(__builtin_$builtin) *f = $builtin; #endif _ACEOF } sub _lang_body_builtin { my ($self, $builtin) = @_; ref $self or $self = $self->_get_instance(); my $body = <<"_ACEOF"; #if !defined(__has_builtin) return f != $builtin; #else return __has_builtin($builtin); #endif _ACEOF return $body; } =head2 lang_builtin( [prologue], builtin ) Builds program which simply proves whether a builtin is known to language compiler. =cut sub lang_builtin { my ($self, $prologue, $builtin) = @_; ref $self or $self = $self->_get_instance(); return $self->lang_build_program($self->_lang_prologue_func($prologue, $builtin), $self->_lang_body_builtin($builtin),); } =head2 lang_build_bool_test (prologue, test, [@decls]) Builds a static test which will fail to compile when test evaluates to false. If C<@decls> is given, it's prepended before the test code at the variable definition place. =cut sub lang_build_bool_test { my ($self, $prologue, $test, @decls) = @_; ref $self or $self = $self->_get_instance(); defined($test) or $test = "1"; my $test_code = <lang_build_program($prologue, $test_code); } =head2 push_includes Adds given list of directories to preprocessor/compiler invocation. This is not proved to allow adding directories which might be created during the build. =cut sub push_includes { my ($self, @includes) = @_; ref $self or $self = $self->_get_instance(); push(@{$self->{extra_include_dirs}}, @includes); return; } =head2 push_preprocess_flags Adds given flags to the parameter list for preprocessor invocation. =cut sub push_preprocess_flags { my ($self, @cpp_flags) = @_; ref $self or $self = $self->_get_instance(); push(@{$self->{extra_preprocess_flags}}, @cpp_flags); return; } =head2 push_compiler_flags Adds given flags to the parameter list for compiler invocation. =cut sub push_compiler_flags { my ($self, @compiler_flags) = @_; ref $self or $self = $self->_get_instance(); my $lang = $self->{lang}; if (scalar(@compiler_flags) && (ref($compiler_flags[-1]) eq "HASH")) { my $lang_opt = pop(@compiler_flags); defined($lang_opt->{lang}) or croak("Missing lang attribute in language options"); $lang = $lang_opt->{lang}; defined($self->{lang_supported}->{$lang}) or croak("Unsupported language '$lang'"); } push(@{$self->{extra_compile_flags}->{$lang}}, @compiler_flags); return; } =head2 push_libraries Adds given list of libraries to the parameter list for linker invocation. =cut sub push_libraries { my ($self, @libs) = @_; ref $self or $self = $self->_get_instance(); push(@{$self->{extra_libs}}, @libs); return; } =head2 push_library_paths Adds given list of library paths to the parameter list for linker invocation. =cut sub push_library_paths { my ($self, @libdirs) = @_; ref $self or $self = $self->_get_instance(); push(@{$self->{extra_lib_dirs}}, @libdirs); return; } =head2 push_link_flags Adds given flags to the parameter list for linker invocation. =cut sub push_link_flags { my ($self, @link_flags) = @_; ref $self or $self = $self->_get_instance(); push(@{$self->{extra_link_flags}}, @link_flags); return; } =head2 compile_if_else( $src, \%options? ) This function tries to compile specified code and returns a boolean value containing check success state. If the very last parameter contains a hash reference, C references to I or I are executed, respectively. =cut sub compile_if_else { my ($self, $src) = @_; ref $self or $self = $self->_get_instance(); my $options = {}; scalar @_ > 2 and ref $_[-1] eq "HASH" and $options = pop @_; my $builder = $self->_get_builder(); my ($fh, $filename) = tempfile( "testXXXXXX", SUFFIX => '.c', UNLINK => 0 ); print {$fh} $src; close $fh; my ($obj_file, $outbuf, $errbuf, $exception); ($outbuf, $errbuf) = capture { eval { $obj_file = $builder->compile( source => $filename, include_dirs => $self->{extra_include_dirs}, extra_compiler_flags => $self->_get_extra_compiler_flags() ); }; $exception = $@; }; unlink $filename; $obj_file and !-f $obj_file and undef $obj_file; unlink $obj_file if $obj_file; if ($exception || !$obj_file) { $self->_add_log_lines("compile stage failed" . ($exception ? " - " . $exception : "")); $errbuf and $self->_add_log_lines($errbuf); $self->_add_log_lines("failing program is:\n" . $src); $outbuf and $self->_add_log_lines("stdout was :\n" . $outbuf); $options->{action_on_false} and ref $options->{action_on_false} eq "CODE" and $options->{action_on_false}->(); return 0; } $options->{action_on_true} and ref $options->{action_on_true} eq "CODE" and $options->{action_on_true}->(); 1; } =head2 link_if_else( $src, \%options? ) This function tries to compile and link specified code and returns a boolean value containing check success state. If the very last parameter contains a hash reference, C references to I or I are executed, respectively. =cut sub link_if_else { my ($self, $src) = @_; ref $self or $self = $self->_get_instance(); my $options = {}; scalar @_ > 2 and ref $_[-1] eq "HASH" and $options = pop @_; my $builder = $self->_get_builder(); my ($fh, $filename) = tempfile( "testXXXXXX", SUFFIX => '.c', UNLINK => 0 ); print {$fh} $src; close $fh; my ($obj_file, $outbuf, $errbuf, $exception); ($outbuf, $errbuf) = capture { eval { $obj_file = $builder->compile( source => $filename, include_dirs => $self->{extra_include_dirs}, extra_compiler_flags => $self->_get_extra_compiler_flags() ); }; $exception = $@; }; $obj_file and !-f $obj_file and undef $obj_file; if ($exception || !$obj_file) { $self->_add_log_lines("compile stage failed" . ($exception ? " - " . $exception : "")); $errbuf and $self->_add_log_lines($errbuf); $self->_add_log_lines("failing program is:\n" . $src); $outbuf and $self->_add_log_lines("stdout was :\n" . $outbuf); unlink $filename; unlink $obj_file if $obj_file; $options->{action_on_false} and ref $options->{action_on_false} eq "CODE" and $options->{action_on_false}->(); return 0; } my $exe_file; ($outbuf, $errbuf) = capture { eval { $exe_file = $builder->link_executable( objects => $obj_file, extra_linker_flags => $self->_get_extra_linker_flags() ); }; $exception = $@; }; $exe_file and !-f $exe_file and undef $exe_file; unlink $filename; unlink $obj_file if $obj_file; unlink $exe_file if $exe_file; if ($exception || !$exe_file) { $self->_add_log_lines("link stage failed" . ($exception ? " - " . $exception : "")); $errbuf and $self->_add_log_lines($errbuf); $self->_add_log_lines("failing program is:\n" . $src); $outbuf and $self->_add_log_lines("stdout was :\n" . $outbuf); $options->{action_on_false} and ref $options->{action_on_false} eq "CODE" and $options->{action_on_false}->(); return 0; } $options->{action_on_true} and ref $options->{action_on_true} eq "CODE" and $options->{action_on_true}->(); 1; } =head2 check_cached( $cache-key, $check-title, \&check-call, \%options? ) Retrieves the result of a previous L invocation from C, or (when called for the first time) populates the cache by invoking C<\&check_call>. If the very last parameter contains a hash reference, C references to I or I are executed on B call to check_cached (not just the first cache-populating invocation), respectively. =cut sub check_cached { my ($self, $cache_name, $message, $check_sub) = @_; ref $self or $self = $self->_get_instance(); my $options = {}; scalar @_ > 4 and ref $_[-1] eq "HASH" and $options = pop @_; $self->msg_checking($message); defined $ENV{$cache_name} and not defined $self->{cache}->{$cache_name} and $self->{cache}->{$cache_name} = $ENV{$cache_name}; my @cached_result; defined($self->{cache}->{$cache_name}) and push @cached_result, "(cached)"; defined($self->{cache}->{$cache_name}) or $self->{cache}->{$cache_name} = $check_sub->(); $self->msg_result(@cached_result, $self->{cache}->{$cache_name}); $options->{action_on_true} and ref $options->{action_on_true} eq "CODE" and $self->{cache}->{$cache_name} and $options->{action_on_true}->(); $options->{action_on_false} and ref $options->{action_on_false} eq "CODE" and !$self->{cache}->{$cache_name} and $options->{action_on_false}->(); $self->{cache}->{$cache_name}; } =head2 cache_val This function returns the value of a previously check_cached call. =cut sub cache_val { my ($self, $cache_name) = @_; ref $self or $self = $self->_get_instance(); defined $self->{cache}->{$cache_name} or return; $self->{cache}->{$cache_name}; } =head2 check_decl( $symbol, \%options? ) This method actually tests whether symbol is defined as a macro or can be used as an r-value, not whether it is really declared, because it is much safer to avoid introducing extra declarations when they are not needed. In order to facilitate use of C++ and overloaded function declarations, it is possible to specify function argument types in parentheses for types which can be zero-initialized: Config::AutoConf->check_decl("basename(char *)") This method caches its result in the Cset langE>_symbol variable. If the very last parameter contains a hash reference, C references to I or I are executed, respectively. When a I exists in the optional hash at end, it will be favored over C (represented by L). If any of I, I is defined, both callbacks are passed to L as I or I to C, respectively. =cut sub check_decl { my ($self, $symbol) = @_; $self = $self->_get_instance(); my $options = {}; scalar @_ > 2 and ref $_[-1] eq "HASH" and $options = pop @_; defined($symbol) or return croak("No symbol to check for"); ref($symbol) eq "" or return croak("No symbol to check for"); (my $sym_plain = $symbol) =~ s/ *\(.*//; my $sym_call = $symbol; $sym_call =~ s/\(/((/; $sym_call =~ s/\)/) 0)/; $sym_call =~ s/,/) 0, (/g; my $cache_name = $self->_cache_name("decl", $self->{lang}, $symbol); my $check_sub = sub { my $body = <lang_build_program($options->{prologue}, $body); my $have_decl = $self->compile_if_else( $conftest, { ($options->{action_on_true} ? (action_on_true => $options->{action_on_true}) : ()), ($options->{action_on_false} ? (action_on_false => $options->{action_on_false}) : ()) } ); $have_decl; }; $self->check_cached( $cache_name, "whether $symbol is declared", $check_sub, { ($options->{action_on_cache_true} ? (action_on_true => $options->{action_on_cache_true}) : ()), ($options->{action_on_cache_false} ? (action_on_false => $options->{action_on_cache_false}) : ()) } ); } =head2 check_decls( symbols, \%options? ) For each of the symbols (with optional function argument types for C++ overloads), run L. Contrary to B, this method does not declare C macros for the resulting C, because it differs as C between compiling languages. If the very last parameter contains a hash reference, C references to I or I are executed, respectively. When a I exists in the optional hash at end, it will be favored over C (represented by L). If any of I, I is defined, both callbacks are passed to L as I or I to C, respectively. Given callbacks for I or I are called for each symbol checked using L receiving the symbol as first argument. =cut sub check_decls { my ($self, $symbols) = @_; $self = $self->_get_instance(); my $options = {}; scalar @_ > 2 and ref $_[-1] eq "HASH" and $options = pop @_; my %pass_options; defined $options->{prologue} and $pass_options{prologue} = $options->{prologue}; defined $options->{action_on_cache_true} and $pass_options{action_on_cache_true} = $options->{action_on_cache_true}; defined $options->{action_on_cache_false} and $pass_options{action_on_cache_false} = $options->{action_on_cache_false}; my $have_syms = 1; foreach my $symbol (@$symbols) { $have_syms &= $self->check_decl( $symbol, { %pass_options, ( $options->{action_on_symbol_true} && "CODE" eq ref $options->{action_on_symbol_true} ? (action_on_true => sub { $options->{action_on_symbol_true}->($symbol) }) : () ), ( $options->{action_on_symbol_false} && "CODE" eq ref $options->{action_on_symbol_false} ? (action_on_false => sub { $options->{action_on_symbol_false}->($symbol) }) : () ), } ); } $have_syms and $options->{action_on_true} and ref $options->{action_on_true} eq "CODE" and $options->{action_on_true}->(); $options->{action_on_false} and ref $options->{action_on_false} eq "CODE" and !$have_syms and $options->{action_on_false}->(); $have_syms; } sub _have_func_define_name { my $func = $_[0]; my $have_name = "HAVE_" . uc($func); $have_name =~ tr/_A-Za-z0-9/_/c; $have_name; } =head2 check_func( $function, \%options? ) This method actually tests whether I<$funcion> can be linked into a program trying to call I<$function>. This method caches its result in the ac_cv_func_FUNCTION variable. If the very last parameter contains a hash reference, C references to I or I are executed, respectively. If any of I, I is defined, both callbacks are passed to L as I or I to C, respectively. Returns: True if the function was found, false otherwise =cut sub check_func { my ($self, $function) = @_; $self = $self->_get_instance(); my $options = {}; scalar @_ > 2 and ref $_[-1] eq "HASH" and $options = pop @_; # Build the name of the cache variable. my $cache_name = $self->_cache_name('func', $function); # Wrap the actual check in a closure so that we can use check_cached. my $check_sub = sub { my $have_func = $self->link_if_else( $self->lang_call(q{}, $function), { ($options->{action_on_true} ? (action_on_true => $options->{action_on_true}) : ()), ($options->{action_on_false} ? (action_on_false => $options->{action_on_false}) : ()) } ); $have_func; }; # Run the check and cache the results. return $self->check_cached( $cache_name, "for $function", $check_sub, { action_on_true => sub { $self->define_var( _have_func_define_name($function), $self->cache_val($cache_name), "Defined when $function is available" ); $options->{action_on_cache_true} and ref $options->{action_on_cache_true} eq "CODE" and $options->{action_on_cache_true}->(); }, action_on_false => sub { $self->define_var(_have_func_define_name($function), undef, "Defined when $function is available"); $options->{action_on_cache_false} and ref $options->{action_on_cache_false} eq "CODE" and $options->{action_on_cache_false}->(); }, } ); } =head2 check_funcs( \@functions-list, $action-if-true?, $action-if-false? ) The same as check_func, but takes a list of functions in I<\@functions-list> to look for and checks for each in turn. Define HAVE_FUNCTION for each function that was found. If the very last parameter contains a hash reference, C references to I or I are executed, respectively. If any of I, I is defined, both callbacks are passed to L as I or I to C, respectively. Given callbacks for I or I are called for each symbol checked using L receiving the symbol as first argument. =cut sub check_funcs { my ($self, $functions_ref) = @_; $self = $self->_get_instance(); my $options = {}; scalar @_ > 2 and ref $_[-1] eq "HASH" and $options = pop @_; my %pass_options; defined $options->{action_on_cache_true} and $pass_options{action_on_cache_true} = $options->{action_on_cache_true}; defined $options->{action_on_cache_false} and $pass_options{action_on_cache_false} = $options->{action_on_cache_false}; # Go through the list of functions and call check_func for each one. We # generate new closures for the found and not-found functions that pass in # the relevant function name. my $have_funcs = 1; for my $function (@{$functions_ref}) { # Build the code reference to run when a function was found. This defines # a HAVE_FUNCTION symbol, plus runs the current $action-if-true if there is # one. $pass_options{action_on_true} = sub { # Run the user-provided hook, if there is one. defined $options->{action_on_function_true} and ref $options->{action_on_function_true} eq "CODE" and $options->{action_on_function_true}->($function); }; defined $options->{action_on_function_false} and ref $options->{action_on_function_false} eq "CODE" and $pass_options{action_on_false} = sub { $options->{action_on_function_false}->($function); }; $have_funcs &= check_func($self, $function, \%pass_options); } $have_funcs and $options->{action_on_true} and ref $options->{action_on_true} eq "CODE" and $options->{action_on_true}->(); $options->{action_on_false} and ref $options->{action_on_false} eq "CODE" and !$have_funcs and $options->{action_on_false}->(); return $have_funcs; } =head2 check_builtin( $builtin, \%options? ) This method actually tests whether I<$builtin> is a supported built-in known by the compiler. Either, by giving us the type of the built-in or by taking the value from C<__has_builtin>. This method caches its result in the ac_cv_builtin_FUNCTION variable. If the very last parameter contains a hash reference, C references to I or I are executed, respectively. If any of I, I is defined, both callbacks are passed to L as I or I to C, respectively. Returns: True if the function was found, false otherwise =cut sub _have_builtin_define_name { my $builtin = $_[0]; my $have_name = "HAVE_BUILTIN_" . uc($builtin); $have_name =~ tr/_A-Za-z0-9/_/c; $have_name; } sub check_builtin { my ($self, $builtin) = @_; $self = $self->_get_instance(); my $options = {}; scalar @_ > 2 and ref $_[-1] eq "HASH" and $options = pop @_; # Build the name of the cache variable. my $cache_name = $self->_cache_name('builtin', $builtin); # Wrap the actual check in a closure so that we can use check_cached. my $check_sub = sub { my $have_builtin = $self->link_if_else( $self->lang_builtin(q{}, $builtin), { ($options->{action_on_true} ? (action_on_true => $options->{action_on_true}) : ()), ($options->{action_on_false} ? (action_on_false => $options->{action_on_false}) : ()) } ); $have_builtin; }; # Run the check and cache the results. return $self->check_cached( $cache_name, "for builtin $builtin", $check_sub, { action_on_true => sub { $self->define_var( _have_builtin_define_name($builtin), $self->cache_val($cache_name), "Defined when builtin $builtin is available" ); $options->{action_on_cache_true} and ref $options->{action_on_cache_true} eq "CODE" and $options->{action_on_cache_true}->(); }, action_on_false => sub { $self->define_var(_have_builtin_define_name($builtin), undef, "Defined when builtin $builtin is available"); $options->{action_on_cache_false} and ref $options->{action_on_cache_false} eq "CODE" and $options->{action_on_cache_false}->(); }, } ); } sub _have_type_define_name { my $type = $_[0]; my $have_name = "HAVE_" . uc($type); $have_name =~ tr/*/P/; $have_name =~ tr/_A-Za-z0-9/_/c; $have_name; } =head2 check_type( $symbol, \%options? ) Check whether type is defined. It may be a compiler builtin type or defined by the includes. In C, type must be a type-name, so that the expression C is valid (but C is not). If I type is defined, preprocessor macro HAVE_I (in all capitals, with "*" replaced by "P" and spaces and dots replaced by underscores) is defined. This method caches its result in the Ctype variable. If the very last parameter contains a hash reference, C references to I or I are executed, respectively. When a I exists in the optional hash at end, it will be favored over C (represented by L). If any of I, I is defined, both callbacks are passed to L as I or I to C, respectively. =cut sub check_type { my ($self, $type) = @_; $self = $self->_get_instance(); my $options = {}; scalar @_ > 2 and ref $_[-1] eq "HASH" and $options = pop @_; defined($type) or return croak("No type to check for"); ref($type) eq "" or return croak("No type to check for"); my $cache_name = $self->_cache_type_name("type", $type); my $check_sub = sub { my $body = <lang_build_program($options->{prologue}, $body); my $have_type = $self->compile_if_else( $conftest, { ($options->{action_on_true} ? (action_on_true => $options->{action_on_true}) : ()), ($options->{action_on_false} ? (action_on_false => $options->{action_on_false}) : ()) } ); $have_type; }; $self->check_cached( $cache_name, "for $type", $check_sub, { action_on_true => sub { $self->define_var(_have_type_define_name($type), $self->cache_val($cache_name), "defined when $type is available"); $options->{action_on_cache_true} and ref $options->{action_on_cache_true} eq "CODE" and $options->{action_on_cache_true}->(); }, action_on_false => sub { $self->define_var(_have_type_define_name($type), undef, "defined when $type is available"); $options->{action_on_cache_false} and ref $options->{action_on_cache_false} eq "CODE" and $options->{action_on_cache_false}->(); }, } ); } =head2 check_types( \@type-list, \%options? ) For each type in I<@type-list>, call L is called to check for type and return the accumulated result (accumulation op is binary and). If the very last parameter contains a hash reference, C references to I or I are executed, respectively. When a I exists in the optional hash at end, it will be favored over C (represented by L). If any of I, I is defined, both callbacks are passed to L as I or I to C, respectively. Given callbacks for I or I are called for each symbol checked using L receiving the symbol as first argument. =cut sub check_types { my ($self, $types) = @_; $self = $self->_get_instance(); my $options = {}; scalar @_ > 2 and ref $_[-1] eq "HASH" and $options = pop @_; my %pass_options; defined $options->{prologue} and $pass_options{prologue} = $options->{prologue}; defined $options->{action_on_cache_true} and $pass_options{action_on_cache_true} = $options->{action_on_cache_true}; defined $options->{action_on_cache_false} and $pass_options{action_on_cache_false} = $options->{action_on_cache_false}; my $have_types = 1; foreach my $type (@$types) { $have_types &= $self->check_type( $type, { %pass_options, ( $options->{action_on_type_true} && "CODE" eq ref $options->{action_on_type_true} ? (action_on_true => sub { $options->{action_on_type_true}->($type) }) : () ), ( $options->{action_on_type_false} && "CODE" eq ref $options->{action_on_type_false} ? (action_on_false => sub { $options->{action_on_type_false}->($type) }) : () ), } ); } $have_types and $options->{action_on_true} and ref $options->{action_on_true} eq "CODE" and $options->{action_on_true}->(); $options->{action_on_false} and ref $options->{action_on_false} eq "CODE" and !$have_types and $options->{action_on_false}->(); $have_types; } sub _compute_int_compile { my ($self, $expr, $prologue, @decls) = @_; $self = $self->_get_instance(); my ($body, $conftest, $compile_result); my ($low, $mid, $high) = (0, 0, 0); if ($self->compile_if_else($self->lang_build_bool_test($prologue, "((long int)($expr)) >= 0", @decls))) { $low = $mid = 0; while (1) { if ($self->compile_if_else($self->lang_build_bool_test($prologue, "((long int)($expr)) <= $mid", @decls))) { $high = $mid; last; } $low = $mid + 1; # avoid overflow if ($low <= $mid) { $low = 0; last; } $mid = $low * 2; } } elsif ($self->compile_if_else($self->lang_build_bool_test($prologue, "((long int)($expr)) < 0", @decls))) { $high = $mid = -1; while (1) { if ($self->compile_if_else($self->lang_build_bool_test($prologue, "((long int)($expr)) >= $mid", @decls))) { $low = $mid; last; } $high = $mid - 1; # avoid overflow if ($mid < $high) { $high = 0; last; } $mid = $high * 2; } } # perform binary search between $low and $high while ($low <= $high) { $mid = int(($high - $low) / 2 + $low); if ($self->compile_if_else($self->lang_build_bool_test($prologue, "((long int)($expr)) < $mid", @decls))) { $high = $mid - 1; } elsif ($self->compile_if_else($self->lang_build_bool_test($prologue, "((long int)($expr)) > $mid", @decls))) { $low = $mid + 1; } else { return $mid; } } return; } =head2 compute_int( $expression, @decls?, \%options ) Returns the value of the integer I. The value should fit in an initializer in a C variable of type signed long. It should be possible to evaluate the expression at compile-time. If no includes are specified, the default includes are used. If the very last parameter contains a hash reference, C references to I or I are executed, respectively. When a I exists in the optional hash at end, it will be favored over C (represented by L). If any of I, I is defined, both callbacks are passed to L as I or I to C, respectively. =cut sub _expr_value_define_name { my $expr = $_[0]; my $have_name = "EXPR_" . uc($expr); $have_name =~ tr/*/P/; $have_name =~ tr/_A-Za-z0-9/_/c; $have_name; } sub compute_int { my $options = {}; scalar @_ > 2 and ref $_[-1] eq "HASH" and $options = pop @_; my ($self, $expr, @decls) = @_; $self = $self->_get_instance(); my $cache_name = $self->_cache_type_name("compute_int", $self->{lang}, $expr); my $check_sub = sub { my $val = $self->_compute_int_compile($expr, $options->{prologue}, @decls); defined $val and $options->{action_on_true} and ref $options->{action_on_true} eq "CODE" and $options->{action_on_true}->(); $options->{action_on_false} and ref $options->{action_on_false} eq "CODE" and !defined $val and $options->{action_on_false}->(); $val; }; $self->check_cached( $cache_name, "for compute result of ($expr)", $check_sub, { action_on_true => sub { $self->define_var( _expr_value_define_name($expr), $self->cache_val($cache_name), "defined when ($expr) could computed" ); $options->{action_on_cache_true} and ref $options->{action_on_cache_true} eq "CODE" and $options->{action_on_cache_true}->(); }, action_on_false => sub { $self->define_var(_expr_value_define_name($expr), undef, "defined when ($expr) could computed"); $options->{action_on_cache_false} and ref $options->{action_on_cache_false} eq "CODE" and $options->{action_on_cache_false}->(); }, } ); } =head2 check_sizeof_type( $type, \%options? ) Checks for the size of the specified type by compiling and define C using the determined size. In opposition to GNU AutoConf, this method can determine size of structure members, e.g. $ac->check_sizeof_type( "SV.sv_refcnt", { prologue => $include_perl } ); # or $ac->check_sizeof_type( "struct utmpx.ut_id", { prologue => "#include " } ); This method caches its result in the Cset langE>_type variable. If the very last parameter contains a hash reference, C references to I or I are executed, respectively. When a I exists in the optional hash at end, it will be favored over C (represented by L). If any of I, I is defined, both callbacks are passed to L as I or I to C, respectively. =cut sub _sizeof_type_define_name { my $type = $_[0]; my $have_name = "SIZEOF_" . uc($type); $have_name =~ tr/*/P/; $have_name =~ tr/_A-Za-z0-9/_/c; $have_name; } sub check_sizeof_type { my $options = {}; scalar @_ > 2 and ref $_[-1] eq "HASH" and $options = pop @_; my ($self, $type) = @_; $self = $self->_get_instance(); defined($type) or return croak("No type to check for"); ref($type) eq "" or return croak("No type to check for"); my $cache_name = $self->_cache_type_name("sizeof", $self->{lang}, $type); my $check_sub = sub { my @decls; if ($type =~ m/^([^.]+)\.([^.]+)$/) { my $struct = $1; $type = "_ac_test_aggr.$2"; my $decl = "static $struct _ac_test_aggr;"; push(@decls, $decl); } my $typesize = $self->_compute_int_compile("sizeof($type)", $options->{prologue}, @decls); $typesize and $options->{action_on_true} and ref $options->{action_on_true} eq "CODE" and $options->{action_on_true}->(); $options->{action_on_false} and ref $options->{action_on_false} eq "CODE" and !$typesize and $options->{action_on_false}->(); $typesize; }; $self->check_cached( $cache_name, "for size of $type", $check_sub, { action_on_true => sub { $self->define_var( _sizeof_type_define_name($type), $self->cache_val($cache_name), "defined when sizeof($type) is available" ); $options->{action_on_cache_true} and ref $options->{action_on_cache_true} eq "CODE" and $options->{action_on_cache_true}->(); }, action_on_false => sub { $self->define_var(_sizeof_type_define_name($type), undef, "defined when sizeof($type) is available"); $options->{action_on_cache_false} and ref $options->{action_on_cache_false} eq "CODE" and $options->{action_on_cache_false}->(); }, } ); } =head2 check_sizeof_types( type, \%options? ) For each type L is called to check for size of type. If I is given, it is additionally executed when all of the sizes of the types could determined. If I is given, it is executed when one size of the types could not determined. If the very last parameter contains a hash reference, C references to I or I are executed, respectively. When a I exists in the optional hash at end, it will be favored over C (represented by L). If any of I, I is defined, both callbacks are passed to L as I or I to C, respectively. Given callbacks for I or I are called for each symbol checked using L receiving the symbol as first argument. =cut sub check_sizeof_types { my $options = {}; scalar @_ > 2 and ref $_[-1] eq "HASH" and $options = pop @_; my ($self, $types) = @_; $self = $self->_get_instance(); my %pass_options; defined $options->{prologue} and $pass_options{prologue} = $options->{prologue}; defined $options->{action_on_cache_true} and $pass_options{action_on_cache_true} = $options->{action_on_cache_true}; defined $options->{action_on_cache_false} and $pass_options{action_on_cache_false} = $options->{action_on_cache_false}; my $have_sizes = 1; foreach my $type (@$types) { $have_sizes &= !!( $self->check_sizeof_type( $type, { %pass_options, ( $options->{action_on_size_true} && "CODE" eq ref $options->{action_on_size_true} ? (action_on_true => sub { $options->{action_on_size_true}->($type) }) : () ), ( $options->{action_on_size_false} && "CODE" eq ref $options->{action_on_size_false} ? (action_on_false => sub { $options->{action_on_size_false}->($type) }) : () ), } ) ); } $have_sizes and $options->{action_on_true} and ref $options->{action_on_true} eq "CODE" and $options->{action_on_true}->(); $options->{action_on_false} and ref $options->{action_on_false} eq "CODE" and !$have_sizes and $options->{action_on_false}->(); $have_sizes; } sub _alignof_type_define_name { my $type = $_[0]; my $have_name = "ALIGNOF_" . uc($type); $have_name =~ tr/*/P/; $have_name =~ tr/_A-Za-z0-9/_/c; $have_name; } =head2 check_alignof_type( type, \%options? ) Define ALIGNOF_type to be the alignment in bytes of type. I must be valid as a structure member declaration or I must be a structure member itself. This method caches its result in the Cset langE>_type variable, with I<*> mapped to C

and other characters not suitable for a variable name mapped to underscores. If the very last parameter contains a hash reference, C references to I or I are executed, respectively. When a I exists in the optional hash at end, it will be favored over C (represented by L). If any of I, I is defined, both callbacks are passed to L as I or I to C, respectively. =cut sub check_alignof_type { my $options = {}; scalar @_ > 2 and ref $_[-1] eq "HASH" and $options = pop @_; my ($self, $type) = @_; $self = $self->_get_instance(); defined($type) or return croak("No type to check for"); ref($type) eq "" or return croak("No type to check for"); my $cache_name = $self->_cache_type_name("alignof", $self->{lang}, $type); my $check_sub = sub { my @decls = ( "#ifndef offsetof", "# ifdef __ICC", "# define offsetof(type,memb) ((size_t)(((char *)(&((type*)0)->memb)) - ((char *)0)))", "# else", "# define offsetof(type,memb) ((size_t)&((type*)0)->memb)", "# endif", "#endif" ); my ($struct, $memb); if ($type =~ m/^([^.]+)\.([^.]+)$/) { $struct = $1; $memb = $2; } else { push(@decls, "typedef struct { char x; $type y; } ac__type_alignof_;"); $struct = "ac__type_alignof_"; $memb = "y"; } my $typealign = $self->_compute_int_compile("offsetof($struct, $memb)", $options->{prologue}, @decls); $typealign and $options->{action_on_true} and ref $options->{action_on_true} eq "CODE" and $options->{action_on_true}->(); $options->{action_on_false} and ref $options->{action_on_false} eq "CODE" and !$typealign and $options->{action_on_false}->(); $typealign; }; $self->check_cached( $cache_name, "for align of $type", $check_sub, { action_on_true => sub { $self->define_var( _alignof_type_define_name($type), $self->cache_val($cache_name), "defined when alignof($type) is available" ); $options->{action_on_cache_true} and ref $options->{action_on_cache_true} eq "CODE" and $options->{action_on_cache_true}->(); }, action_on_false => sub { $self->define_var(_alignof_type_define_name($type), undef, "defined when alignof($type) is available"); $options->{action_on_cache_false} and ref $options->{action_on_cache_false} eq "CODE" and $options->{action_on_cache_false}->(); }, } ); } =head2 check_alignof_types (type, [action-if-found], [action-if-not-found], [prologue = default includes]) For each type L is called to check for align of type. If I is given, it is additionally executed when all of the aligns of the types could determined. If I is given, it is executed when one align of the types could not determined. If the very last parameter contains a hash reference, C references to I or I are executed, respectively. When a I exists in the optional hash at end, it will be favored over C (represented by L). If any of I, I is defined, both callbacks are passed to L as I or I to C, respectively. Given callbacks for I or I are called for each symbol checked using L receiving the symbol as first argument. =cut sub check_alignof_types { my $options = {}; scalar @_ > 2 and ref $_[-1] eq "HASH" and $options = pop @_; my ($self, $types) = @_; $self = $self->_get_instance(); my %pass_options; defined $options->{prologue} and $pass_options{prologue} = $options->{prologue}; defined $options->{action_on_cache_true} and $pass_options{action_on_cache_true} = $options->{action_on_cache_true}; defined $options->{action_on_cache_false} and $pass_options{action_on_cache_false} = $options->{action_on_cache_false}; my $have_aligns = 1; foreach my $type (@$types) { $have_aligns &= !!( $self->check_alignof_type( $type, { %pass_options, ( $options->{action_on_align_true} && "CODE" eq ref $options->{action_on_align_true} ? (action_on_true => sub { $options->{action_on_align_true}->($type) }) : () ), ( $options->{action_on_align_false} && "CODE" eq ref $options->{action_on_align_false} ? (action_on_false => sub { $options->{action_on_align_false}->($type) }) : () ), } ) ); } $have_aligns and $options->{action_on_true} and ref $options->{action_on_true} eq "CODE" and $options->{action_on_true}->(); $options->{action_on_false} and ref $options->{action_on_false} eq "CODE" and !$have_aligns and $options->{action_on_false}->(); $have_aligns; } sub _have_member_define_name { my $member = $_[0]; my $have_name = "HAVE_" . uc($member); $have_name =~ tr/_A-Za-z0-9/_/c; $have_name; } =head2 check_member( member, \%options? ) Check whether I is in form of I.I and I is a member of the I aggregate. which are used prior to the aggregate under test. Config::AutoConf->check_member( "struct STRUCT_SV.sv_refcnt", { action_on_false => sub { Config::AutoConf->msg_failure( "sv_refcnt member required for struct STRUCT_SV" ); }, prologue => "#include \n#include " } ); This function will return a true value (1) if the member is found. If I aggregate has I member, preprocessor macro HAVE_I_I (in all capitals, with spaces and dots replaced by underscores) is defined. This macro caches its result in the Caggr_member variable. If the very last parameter contains a hash reference, C references to I or I are executed, respectively. When a I exists in the optional hash at end, it will be favored over C (represented by L). If any of I, I is defined, both callbacks are passed to L as I or I to C, respectively. =cut sub check_member { my $options = {}; scalar @_ > 2 and ref $_[-1] eq "HASH" and $options = pop @_; my ($self, $member) = @_; $self = $self->_get_instance(); defined($member) or return croak("No type to check for"); ref($member) eq "" or return croak("No type to check for"); $member =~ m/^([^.]+)\.([^.]+)$/ or return croak("check_member(\"struct foo.member\", \%options)"); my $type = $1; $member = $2; my $cache_name = $self->_cache_type_name("$type.$member"); my $check_sub = sub { my $body = <lang_build_program($options->{prologue}, $body); my $have_member = $self->compile_if_else($conftest); unless ($have_member) { $body = <lang_build_program($options->{prologue}, $body); $have_member = $self->compile_if_else($conftest); } $have_member and $options->{action_on_true} and ref $options->{action_on_true} eq "CODE" and $options->{action_on_true}->(); $options->{action_on_false} and ref $options->{action_on_false} eq "CODE" and $options->{action_on_false}->() unless $have_member; $have_member; }; $self->check_cached( $cache_name, "for $type.$member", $check_sub, { action_on_true => sub { $self->define_var( _have_member_define_name("$type.$member"), $self->cache_val($cache_name), "defined when $type.$member is available" ); $options->{action_on_cache_true} and ref $options->{action_on_cache_true} eq "CODE" and $options->{action_on_cache_true}->(); }, action_on_false => sub { $self->define_var(_have_member_define_name("$type.$member"), undef, "defined when $type.$member is available"); $options->{action_on_cache_false} and ref $options->{action_on_cache_false} eq "CODE" and $options->{action_on_cache_false}->(); }, } ); } =head2 check_members( members, \%options? ) For each member L is called to check for member of aggregate. This function will return a true value (1) if at least one member is found. If the very last parameter contains a hash reference, C references to I or I are executed, respectively. When a I exists in the optional hash at end, it will be favored over C (represented by L). If any of I, I is defined, both callbacks are passed to L as I or I to C, respectively. Given callbacks for I or I are called for each symbol checked using L receiving the symbol as first argument. =cut sub check_members { my $options = {}; scalar @_ > 2 and ref $_[-1] eq "HASH" and $options = pop @_; my ($self, $members) = @_; $self = $self->_get_instance(); my %pass_options; defined $options->{prologue} and $pass_options{prologue} = $options->{prologue}; defined $options->{action_on_cache_true} and $pass_options{action_on_cache_true} = $options->{action_on_cache_true}; defined $options->{action_on_cache_false} and $pass_options{action_on_cache_false} = $options->{action_on_cache_false}; my $have_members = 0; foreach my $member (@$members) { $have_members |= ( $self->check_member( $member, { %pass_options, ( $options->{action_on_member_true} && "CODE" eq ref $options->{action_on_member_true} ? (action_on_true => sub { $options->{action_on_member_true}->($member) }) : () ), ( $options->{action_on_member_false} && "CODE" eq ref $options->{action_on_member_false} ? (action_on_false => sub { $options->{action_on_member_false}->($member) }) : () ), } ) ); } $have_members and $options->{action_on_true} and ref $options->{action_on_true} eq "CODE" and $options->{action_on_true}->(); $options->{action_on_false} and ref $options->{action_on_false} eq "CODE" and !$have_members and $options->{action_on_false}->(); $have_members; } sub _have_header_define_name { my $header = $_[0]; my $have_name = "HAVE_" . uc($header); $have_name =~ tr/_A-Za-z0-9/_/c; return $have_name; } sub _check_header { my $options = {}; scalar @_ > 4 and ref $_[-1] eq "HASH" and $options = pop @_; my ($self, $header, $prologue, $body) = @_; $prologue .= <<"_ACEOF"; #include <$header> _ACEOF my $conftest = $self->lang_build_program($prologue, $body); $self->compile_if_else($conftest, $options); } =head2 check_header( $header, \%options? ) This function is used to check if a specific header file is present in the system: if we detect it and if we can compile anything with that header included. Note that normally you want to check for a header first, and then check for the corresponding library (not all at once). The standard usage for this module is: Config::AutoConf->check_header("ncurses.h"); This function will return a true value (1) on success, and a false value if the header is not present or not available for common usage. If the very last parameter contains a hash reference, C references to I or I are executed, respectively. When a I exists in the optional hash at end, it will be prepended to the tested header. If any of I, I is defined, both callbacks are passed to L as I or I to C, respectively. =cut sub check_header { my $options = {}; scalar @_ > 2 and ref $_[-1] eq "HASH" and $options = pop @_; my ($self, $header) = @_; $self = $self->_get_instance(); defined($header) or return croak("No type to check for"); ref($header) eq "" or return croak("No type to check for"); return 0 unless $header; my $cache_name = $self->_cache_name($header); my $check_sub = sub { my $prologue = defined $options->{prologue} ? $options->{prologue} : ""; my $have_header = $self->_check_header( $header, $prologue, "", { ($options->{action_on_true} ? (action_on_true => $options->{action_on_true}) : ()), ($options->{action_on_false} ? (action_on_false => $options->{action_on_false}) : ()) } ); $have_header; }; $self->check_cached( $cache_name, "for $header", $check_sub, { action_on_true => sub { $self->define_var( _have_header_define_name($header), $self->cache_val($cache_name), "defined when $header is available" ); $options->{action_on_cache_true} and ref $options->{action_on_cache_true} eq "CODE" and $options->{action_on_cache_true}->(); }, action_on_false => sub { $self->define_var(_have_header_define_name($header), undef, "defined when $header is available"); $options->{action_on_cache_false} and ref $options->{action_on_cache_false} eq "CODE" and $options->{action_on_cache_false}->(); }, } ); } =head2 check_headers This function uses check_header to check if a set of include files exist in the system and can be included and compiled by the available compiler. Returns the name of the first header file found. Passes an optional \%options hash to each L call. =cut sub check_headers { my $options = {}; scalar @_ > 2 and ref $_[-1] eq "HASH" and $options = pop @_; my $self = shift->_get_instance(); $self->check_header($_, $options) and return $_ for (@_); return; } =head2 check_all_headers This function checks each given header for usability and returns true when each header can be used -- otherwise false. If the very last parameter contains a hash reference, C references to I or I are executed, respectively. Each of existing key/value pairs using I, I or I as key are passed-through to each call of L. Given callbacks for I or I are called for each symbol checked using L receiving the symbol as first argument. =cut sub check_all_headers { my $options = {}; scalar @_ > 2 and ref $_[-1] eq "HASH" and $options = pop @_; my $self = shift->_get_instance(); @_ or return; my %pass_options; defined $options->{prologue} and $pass_options{prologue} = $options->{prologue}; defined $options->{action_on_cache_true} and $pass_options{action_on_cache_true} = $options->{action_on_cache_true}; defined $options->{action_on_cache_false} and $pass_options{action_on_cache_false} = $options->{action_on_cache_false}; my $all_headers = 1; foreach my $header (@_) { $all_headers &= $self->check_header( $header, { %pass_options, ( $options->{action_on_header_true} && "CODE" eq ref $options->{action_on_header_true} ? (action_on_true => sub { $options->{action_on_header_true}->($header) }) : () ), ( $options->{action_on_header_false} && "CODE" eq ref $options->{action_on_header_false} ? (action_on_false => sub { $options->{action_on_header_false}->($header) }) : () ), } ); } $all_headers and $options->{action_on_true} and ref $options->{action_on_true} eq "CODE" and $options->{action_on_true}->(); $options->{action_on_false} and ref $options->{action_on_false} eq "CODE" and !$all_headers and $options->{action_on_false}->(); $all_headers; } =head2 check_stdc_headers Checks for standard C89 headers, namely stdlib.h, stdarg.h, string.h and float.h. If those are found, additional all remaining C89 headers are checked: assert.h, ctype.h, errno.h, limits.h, locale.h, math.h, setjmp.h, signal.h, stddef.h, stdio.h and time.h. Returns a false value if it fails. Passes an optional \%options hash to each L call. =cut my @ansi_c_headers = qw(stdlib stdarg string float assert ctype errno limits locale math setjmp signal stddef stdio time); sub check_stdc_headers { my $options = {}; scalar @_ > 1 and ref $_[-1] eq "HASH" and $options = pop @_; my $self = shift->_get_instance(); # XXX for C++ the map should look like "c${_}" ... my @c_ansi_c_headers = map { "${_}.h" } @ansi_c_headers; my $rc = $self->check_all_headers(@c_ansi_c_headers, $options); $rc and $self->define_var("STDC_HEADERS", 1, "Define to 1 if you have the ANSI C header files."); $rc; } =head2 check_default_headers This function checks for some default headers, the std c89 headers and sys/types.h, sys/stat.h, memory.h, strings.h, inttypes.h, stdint.h and unistd.h Passes an optional \%options hash to each L call. =cut sub check_default_headers { my $options = {}; scalar @_ > 1 and ref $_[-1] eq "HASH" and $options = pop @_; my $self = shift->_get_instance(); $self->check_stdc_headers($options) and $self->check_all_headers(qw(sys/types.h sys/stat.h memory.h strings.h inttypes.h stdint.h unistd.h), $options); } =head2 check_dirent_header Check for the following header files. For the first one that is found and defines 'DIR', define the listed C preprocessor macro: dirent.h HAVE_DIRENT_H sys/ndir.h HAVE_SYS_NDIR_H sys/dir.h HAVE_SYS_DIR_H ndir.h HAVE_NDIR_H The directory-library declarations in your source code should look something like the following: #include #ifdef HAVE_DIRENT_H # include # define NAMLEN(dirent) strlen ((dirent)->d_name) #else # define dirent direct # define NAMLEN(dirent) ((dirent)->d_namlen) # ifdef HAVE_SYS_NDIR_H # include # endif # ifdef HAVE_SYS_DIR_H # include # endif # ifdef HAVE_NDIR_H # include # endif #endif Using the above declarations, the program would declare variables to be of type C, not C, and would access the length of a directory entry name by passing a pointer to a C to the C macro. For the found header, the macro HAVE_DIRENT_IN_${header} is defined. This method might be obsolescent, as all current systems with directory libraries have C<< Edirent.hE >>. Programs supporting only newer OS might not need to use this method. If the very last parameter contains a hash reference, C references to I or I are executed, respectively. Each of existing key/value pairs using I, I (as I having the name of the tested header as first argument) or I (as I having the name of the tested header as first argument) as key are passed-through to each call of L. Given callbacks for I or I are passed to the call of L. =cut sub _have_dirent_header_define_name { my $header = $_[0]; my $have_name = "HAVE_DIRENT_IN_" . uc($header); $have_name =~ tr/_A-Za-z0-9/_/c; return $have_name; } sub check_dirent_header { my $options = {}; scalar @_ > 1 and ref $_[-1] eq "HASH" and $options = pop @_; my $self = shift->_get_instance(); my %pass_options; defined $options->{prologue} and $pass_options{prologue} = $options->{prologue}; my $have_dirent; foreach my $header (qw(dirent.h sys/ndir.h sys/dir.h ndir.h)) { if ($self->check_header($header)) { my $cache_name = $self->_cache_name("dirent", $header); my $check_sub = sub { my $have_dirent; $have_dirent = $self->_check_header( $header, "#include \n", "if ((DIR *) 0) { return 0; }", { %pass_options, ( $options->{action_on_header_true} && "CODE" eq ref $options->{action_on_header_true} ? (action_on_true => sub { $options->{action_on_header_true}->($header) }) : () ), ( $options->{action_on_header_false} && "CODE" eq ref $options->{action_on_header_false} ? (action_on_false => sub { $options->{action_on_header_false}->($header) }) : () ), } ); }; $have_dirent = $self->check_cached( $cache_name, "for header defining DIR *", $check_sub, { action_on_true => sub { $self->define_var( _have_dirent_header_define_name($header), $self->cache_val($cache_name), "defined when $header is available" ); $options->{action_on_cache_true} and ref $options->{action_on_cache_true} eq "CODE" and $options->{action_on_cache_true}->(); }, action_on_false => sub { $self->define_var(_have_dirent_header_define_name($header), undef, "defined when $header is available"); $options->{action_on_cache_false} and ref $options->{action_on_cache_false} eq "CODE" and $options->{action_on_cache_false}->(); }, } ); $have_dirent and $have_dirent = $header and last; } } $have_dirent and $options->{action_on_true} and ref $options->{action_on_true} eq "CODE" and $options->{action_on_true}->(); $options->{action_on_false} and ref $options->{action_on_false} eq "CODE" and !$have_dirent and $options->{action_on_false}->(); $have_dirent; } =head2 _check_perlapi_program This method provides the program source which is suitable to do basic compile/link tests to prove perl development environment. =cut sub _check_perlapi_program { my $self = shift; my $includes = $self->_default_includes_with_perl(); my $perl_check_body = <<'EOB'; I32 rc; SV *foo = newSVpv("Perl rocks", 11); rc = SvCUR(foo); EOB $self->lang_build_program($includes, $perl_check_body); } =head2 _check_compile_perlapi This method can be used from other checks to prove whether we have a perl development environment or not (perl.h, reasonable basic checks - types, etc.) =cut sub _check_compile_perlapi { my $self = shift; my $conftest = $self->_check_perlapi_program(); $self->compile_if_else($conftest); } =head2 check_compile_perlapi This method can be used from other checks to prove whether we have a perl development environment or not (perl.h, reasonable basic checks - types, etc.) =cut sub check_compile_perlapi { my $self = shift->_get_instance; my $cache_name = $self->_cache_name(qw(compile perlapi)); $self->check_cached($cache_name, "whether perlapi is accessible", sub { $self->_check_compile_perlapi }); } =head2 check_compile_perlapi_or_die Dies when not being able to compile using the Perl API =cut sub check_compile_perlapi_or_die { my $self = shift; $self->check_compile_perlapi(@_) or $self->msg_error("Cannot use Perl API - giving up"); } =head2 check_linkable_xs_so Checks whether a dynamic loadable object containing an XS module can be linked or not. Due the nature of the beast, this test currently always succeed. =cut sub check_linkable_xs_so { 1 } =head2 check_linkable_xs_so_or_die Dies when L fails. =cut sub check_linkable_xs_so_or_die { my $self = shift; $self->check_linkable_xs_so(@_) or $self->msg_error("Cannot link XS dynamic loadable - giving up"); } =head2 check_loadable_xs_so Checks whether a dynamic loadable object containing an XS module can be loaded or not. Due the nature of the beast, this test currently always succeed. =cut sub check_loadable_xs_so { 1 } =head2 check_loadable_xs_so_or_die Dies when L fails. =cut sub check_loadable_xs_so_or_die { my $self = shift; $self->check_loadable_xs_so(@_) or $self->msg_error("Cannot load XS dynamic loadable - giving up"); } =head2 _check_link_perlapi This method can be used from other checks to prove whether we have a perl development environment including a suitable libperl or not (perl.h, reasonable basic checks - types, etc.) Caller must ensure that the linker flags are set appropriate (C<-lperl> or similar). =cut sub _check_link_perlapi { my $self = shift; my $conftest = $self->_check_perlapi_program(); my @save_libs = @{$self->{extra_libs}}; my @save_extra_link_flags = @{$self->{extra_link_flags}}; my $libperl = $Config{libperl}; $libperl =~ s/^lib//; $libperl =~ s/\.[^\.]*$//; push @{$self->{extra_link_flags}}, "-L" . File::Spec->catdir($Config{installarchlib}, "CORE"); push @{$self->{extra_libs}}, "$libperl"; if ($Config{perllibs}) { foreach my $perllib (split(" ", $Config{perllibs})) { $perllib =~ m/^\-l(\w+)$/ and push @{$self->{extra_libs}}, "$1" and next; push @{$self->{extra_link_flags}}, $perllib; } } my $have_libperl = $self->link_if_else($conftest); $have_libperl or $self->{extra_libs} = [@save_libs]; $have_libperl or $self->{extra_link_flags} = [@save_extra_link_flags]; $have_libperl; } =head2 check_link_perlapi This method can be used from other checks to prove whether we have a perl development environment or not (perl.h, libperl.la, reasonable basic checks - types, etc.) =cut sub check_link_perlapi { my $self = shift->_get_instance; my $cache_name = $self->_cache_name(qw(link perlapi)); $self->check_cached($cache_name, "whether perlapi is linkable", sub { $self->_check_link_perlapi }); } sub _have_lib_define_name { my $lib = $_[0]; my $have_name = "HAVE_LIB" . uc($lib); $have_name =~ tr/_A-Za-z0-9/_/c; return $have_name; } =head2 check_lib( lib, func, @other-libs?, \%options? ) This function is used to check if a specific library includes some function. Call it with the library name (without the lib portion), and the name of the function you want to test: Config::AutoConf->check_lib("z", "gzopen"); It returns 1 if the function exist, 0 otherwise. In case of function found, the HAVE_LIBlibrary (all in capitals) preprocessor macro is defined with 1 and $lib together with @other_libs are added to the list of libraries to link with. If linking with library results in unresolved symbols that would be resolved by linking with additional libraries, give those libraries as the I argument: e.g., C<[qw(Xt X11)]>. Otherwise, this routine may fail to detect that library is present, because linking the test program can fail with unresolved symbols. The other-libraries argument should be limited to cases where it is desirable to test for one library in the presence of another that is not already in LIBS. This method caches its result in the Clib_func variable. If the very last parameter contains a hash reference, C references to I or I are executed, respectively. If any of I, I is defined, both callbacks are passed to L as I or I to C, respectively. It's recommended to use L instead of check_lib these days. =cut sub check_lib { my $options = {}; scalar @_ > 1 and ref $_[-1] eq "HASH" and $options = pop @_; my $self = shift->_get_instance(); my ($lib, $func, @other_libs) = @_; return 0 unless $lib and $func; scalar(@other_libs) == 1 and ref($other_libs[0]) eq "ARRAY" and @other_libs = @{$other_libs[0]}; my $cache_name = $self->_cache_name("lib", $lib, $func); my $check_sub = sub { my $conftest = $self->lang_call("", $func); my @save_libs = @{$self->{extra_libs}}; push(@{$self->{extra_libs}}, $lib, @other_libs); my $have_lib = $self->link_if_else( $conftest, { ($options->{action_on_true} ? (action_on_true => $options->{action_on_true}) : ()), ($options->{action_on_false} ? (action_on_false => $options->{action_on_false}) : ()) } ); $self->{extra_libs} = [@save_libs]; $have_lib; }; $self->check_cached( $cache_name, "for $func in -l$lib", $check_sub, { action_on_true => sub { $self->define_var( _have_lib_define_name($lib), $self->cache_val($cache_name), "defined when library $lib is available" ); push(@{$self->{extra_libs}}, $lib, @other_libs); $options->{action_on_cache_true} and ref $options->{action_on_cache_true} eq "CODE" and $options->{action_on_cache_true}->(); }, action_on_false => sub { $self->define_var(_have_lib_define_name($lib), undef, "defined when library $lib is available"); $options->{action_on_cache_false} and ref $options->{action_on_cache_false} eq "CODE" and $options->{action_on_cache_false}->(); }, } ); } =head2 search_libs( function, search-libs, @other-libs?, @extra_link_flags?, \%options? ) Config::AutoConf->search_libs("gethostent", "nsl", [qw(socket net)], { action_on_true => sub { ... } }); Config::AutoConf->search_libs("log4cplus_initialize", ["log4cplus"], [[qw(stdc++)], [qw(stdc++ unwind)]], [qw(-pthread -thread)] ); Search for a library defining function if it's not already available. This equates to calling Config::AutoConf->link_if_else( Config::AutoConf->lang_call( "", "$function" ) ); first with no libraries, then for each library listed in search-libs. I must be specified as an array reference to avoid confusion in argument order. Prepend -llibrary to LIBS for the first library found to contain function. If linking with library results in unresolved symbols that would be resolved by linking with additional libraries, give those libraries as the I argument: e.g., C<[qw(Xt X11)]> or C<[qw(intl), qw(intl iconv)]>. Otherwise, this method fails to detect that function is present, because linking the test program always fails with unresolved symbols. The result of this test is cached in the ac_cv_search_function variable as "none required" if function is already available, as C<0> if no library containing function was found, otherwise as the -llibrary option that needs to be prepended to LIBS. If the very last parameter contains a hash reference, C references to I or I are executed, respectively. If any of I, I is defined, both callbacks are passed to L as I or I to C, respectively. Given callbacks for I or I are called for each library checked using L receiving the library as first argument and all C<@other_libs> subsequently. =cut sub search_libs { my $options = {}; scalar @_ > 1 and ref $_[-1] eq "HASH" and $options = pop @_; my $self = shift->_get_instance(); my ($func, $libs, @other_libs, @other_link_flags) = @_; (defined($libs) and "ARRAY" eq ref($libs) and scalar(@{$libs}) > 0) or return 0; # XXX would prefer croak return 0 unless $func; scalar(@other_libs) == 1 and ref($other_libs[0]) eq "ARRAY" and @other_libs = @{$other_libs[0]}; scalar(@other_link_flags) == 1 and ref($other_link_flags[0]) eq "ARRAY" and @other_link_flags = @{$other_link_flags[0]}; my $cache_name = $self->_cache_name("search", $func); my $check_sub = sub { my $conftest = $self->lang_call("", $func); my @save_libs = @{$self->{extra_libs}}; my @save_extra = @{$self->{extra_link_flags}}; my $have_lib = 0; my $if_else_sub = sub { my ($libstest, @other) = @_; defined($libstest) and unshift(@{$self->{extra_libs}}, $libstest, @other); $self->link_if_else( $conftest, { ( $options->{action_on_lib_true} && "CODE" eq ref $options->{action_on_lib_true} ? (action_on_true => sub { $options->{action_on_lib_true}->($libstest, @other, @_) }) : () ), ( $options->{action_on_lib_false} && "CODE" eq ref $options->{action_on_lib_false} ? (action_on_false => sub { $options->{action_on_lib_false}->($libstest, @other, @_) }) : () ), } ) and ($have_lib = defined($libstest) ? $libstest : "none required"); }; LIBTEST: foreach my $libstest (undef, @$libs) { foreach my $linkextra (undef, @other_link_flags) { # XXX would local work on array refs? can we omit @save_libs? $self->{extra_libs} = [@save_libs]; $self->{extra_link_flags} = [@save_extra]; if (defined $libstest and scalar(@other_libs) > 1 and ref($other_libs[0]) eq "ARRAY") { foreach my $ol (@other_libs) { $if_else_sub->($libstest, @{$ol}) and last LIBTEST; } } else { $if_else_sub->($libstest, @other_libs) and last LIBTEST; } } } $self->{extra_libs} = [@save_libs]; $have_lib and $options->{action_on_true} and ref $options->{action_on_true} eq "CODE" and $options->{action_on_true}->(); $options->{action_on_false} and ref $options->{action_on_false} eq "CODE" and !$have_lib and $options->{action_on_false}->(); $have_lib; }; return $self->check_cached( $cache_name, "for library containing $func", $check_sub, { action_on_true => sub { $self->cache_val($cache_name) eq "none required" or unshift(@{$self->{extra_libs}}, $self->cache_val($cache_name)); $options->{action_on_cache_true} and ref $options->{action_on_cache_true} eq "CODE" and $options->{action_on_cache_true}->(); }, ($options->{action_on_cache_false} ? (action_on_false => $options->{action_on_cache_false}) : ()) } ); } sub _check_lm_funcs { qw(log2 pow log10 log exp sqrt) } =head2 check_lm( \%options? ) This method is used to check if some common C functions are available, and if C<-lm> is needed. Returns the empty string if no library is needed, or the "-lm" string if libm is needed. If the very last parameter contains a hash reference, C references to I or I are executed, respectively. Each of existing key/value pairs using I (as I having the name of the tested functions as first argument), I (as I having the name of the tested functions as first argument), I (as I having the name of the tested functions as first argument), I (as I having the name of the tested functions as first argument) as key are passed- through to each call of L. Given callbacks for I, I, I or I are passed to the call of L. B that I and I or I and I cannot be used at the same time, respectively. =cut sub check_lm { my $options = {}; scalar @_ > 1 and ref $_[-1] eq "HASH" and $options = pop @_; my $self = shift->_get_instance(); defined $options->{action_on_lib_true} and defined $options->{action_on_func_lib_true} and croak("action_on_lib_true and action_on_func_lib_true cannot be used together"); defined $options->{action_on_lib_false} and defined $options->{action_on_func_lib_false} and croak("action_on_lib_false and action_on_func_lib_false cannot be used together"); my %pass_options; defined $options->{action_on_cache_true} and $pass_options{action_on_cache_true} = $options->{action_on_cache_true}; defined $options->{action_on_cache_false} and $pass_options{action_on_cache_false} = $options->{action_on_cache_false}; defined $options->{action_on_lib_true} and $pass_options{action_on_lib_true} = $options->{action_on_lib_true}; defined $options->{action_on_lib_false} and $pass_options{action_on_lib_false} = $options->{action_on_lib_false}; my $fail = 0; my $required = ""; my @math_funcs = $self->_check_lm_funcs; for my $func (@math_funcs) { my $ans = $self->search_libs( $func, ['m'], { %pass_options, ( $options->{action_on_func_true} && "CODE" eq ref $options->{action_on_func_true} ? (action_on_true => sub { $options->{action_on_func_true}->($func, @_) }) : () ), ( $options->{action_on_func_false} && "CODE" eq ref $options->{action_on_func_false} ? (action_on_false => sub { $options->{action_on_func_false}->($func, @_) }) : () ), ( $options->{action_on_func_lib_true} && "CODE" eq ref $options->{action_on_func_lib_true} ? (action_on_lib_true => sub { $options->{action_on_func_lib_true}->($func, @_) }) : () ), ( $options->{action_on_func_lib_false} && "CODE" eq ref $options->{action_on_func_lib_false} ? (action_on_lib_false => sub { $options->{action_on_func_lib_false}->($func, @_) }) : () ), }, ); $ans or $fail = 1; $ans ne "none required" and $required = $ans; } !$fail and $options->{action_on_true} and ref $options->{action_on_true} eq "CODE" and $options->{action_on_true}->(); $fail and $options->{action_on_false} and ref $options->{action_on_false} eq "CODE" and $options->{action_on_false}->(); $required; } =head2 pkg_config_package_flags($package, \%options?) use Config::AutoConf my $c = Config::AutoConf->new; $c->pkg_config_package_flags('log4cplus'); WriteMakefile( ... INC => $c->_get_extra_compiler_flags, LIBS => $c->_get_extra_linker_flags, ); Search for C flags for package as specified. The flags which are extracted are C<--cflags> and C<--libs>. The extracted flags are appended to the global C, C or C, respectively. Distinguishing between C and C is essential to avoid conflicts with L and family. In case, no I matching given criteria could be found, return a C value (C<0>). The C flags are taken from I C<< ${package}_CFLAGS >> or C<< ${package}_LIBS >> when defined, respectively. It will be a nice touch to document the particular environment variables for your build procedure - as for above example it should be $ env log4cplus_CFLAGS="-I/opt/coolapp/include" \ log4cplus_LIBS="-L/opt/coolapp/lib -Wl,-R/opt/coolapp/lib -llog4cplus" \ perl Makefile.PL Call C with the package you're looking for and optional callback whether found or not. To support stage compiling properly (C vs. library file location), the internal representation is a moving target. Do not use the result directly - the getters L<_get_extra_compiler_flags|/_get_extra_compiler_flags> and L<_get_extra_linker_flags|/_get_extra_linker_flags> are strongly encouraged. In case this is not possible, please open a ticket to get informed on invasive changes. If the very last parameter contains a hash reference, C references to I or I are executed, respectively. If any of I, I is defined, both callbacks are passed to L as I or I to L, respectively. =cut my $_pkg_config_prog; sub _pkg_config_flag { defined $_pkg_config_prog or croak("pkg_config_prog required"); my @pkg_config_args = @_; my ($stdout, $stderr, $exit) = capture { system($_pkg_config_prog, @pkg_config_args); }; chomp $stdout; 0 == $exit and return $stdout; return $exit; } sub pkg_config_package_flags { my $options = {}; scalar @_ > 1 and ref $_[-1] eq "HASH" and $options = pop @_; my ($self, $package) = @_; $self = $self->_get_instance(); (my $pkgpfx = $package) =~ s/^(\w+).*?$/$1/; my $cache_name = $self->_cache_name("pkg", $pkgpfx); defined $_pkg_config_prog or $_pkg_config_prog = $self->{cache}->{$self->_cache_name("prog", "PKG_CONFIG")}; defined $_pkg_config_prog or $_pkg_config_prog = $self->check_prog_pkg_config; my $check_sub = sub { my (@pkg_cflags, @pkg_libs); (my $ENV_CFLAGS = $package) =~ s/^(\w+).*?$/$1_CFLAGS/; (my $ENV_LIBS = $package) =~ s/^(\w+).*?$/$1_LIBS/; my $pkg_exists = 0 + ( defined $ENV{$ENV_CFLAGS} or defined $ENV{$ENV_LIBS} or _pkg_config_flag($package, "--exists") eq "" ); looks_like_number($pkg_exists) and $pkg_exists == 0 and return 0; my $CFLAGS = defined $ENV{$ENV_CFLAGS} ? $ENV{$ENV_CFLAGS} : _pkg_config_flag($package, "--cflags"); $CFLAGS and not looks_like_number($CFLAGS) and @pkg_cflags = ( map { $_ =~ s/^\s+//; $_ =~ s/\s+$//; Text::ParseWords::shellwords $_; } split(m/\n/, $CFLAGS) ) and push @{$self->{extra_preprocess_flags}}, @pkg_cflags; # do not separate between libs and extra (for now) - they come with -l prepended my $LIBS = defined $ENV{$ENV_LIBS} ? $ENV{$ENV_LIBS} : _pkg_config_flag($package, "--libs"); $LIBS and not looks_like_number($LIBS) and @pkg_libs = ( map { $_ =~ s/^\s+//; $_ =~ s/\s+$//; Text::ParseWords::shellwords $_; } split(m/\n/, $LIBS) ); @pkg_libs and push @{$self->{extra_link_flags}}, grep { $_ !~ m/^-l/ } @pkg_libs; @pkg_libs and push @{$self->{extra_libs}}, map { (my $l = $_) =~ s/^-l//; $l } grep { $_ =~ m/^-l/ } @pkg_libs; my $pkg_config_flags = join(" ", @pkg_cflags, @pkg_libs); $pkg_config_flags and $options->{action_on_true} and ref $options->{action_on_true} eq "CODE" and $options->{action_on_true}->(); $options->{action_on_false} and ref $options->{action_on_false} eq "CODE" and !$pkg_config_flags and $options->{action_on_false}->(); $pkg_config_flags; }; $self->check_cached( $cache_name, "for pkg-config package of $package", $check_sub, { ($options->{action_on_cache_true} ? (action_on_true => $options->{action_on_cache_true}) : ()), ($options->{action_on_cache_false} ? (action_on_false => $options->{action_on_cache_false}) : ()) } ); } =head2 _check_mm_pureperl_build_wanted This method proves the C<_argv> attribute and (when set) the C whether they contain I or not. The attribute C<_force_xs> is set as appropriate, which allows a compile test to bail out when C is called with I. =cut sub _check_mm_pureperl_build_wanted { my $self = shift->_get_instance; defined $ENV{PERL_MM_OPT} and my @env_args = split " ", $ENV{PERL_MM_OPT}; foreach my $arg (@{$self->{_argv}}, @env_args) { $arg =~ m/^PUREPERL_ONLY=(.*)$/ and return int($1); } 0; } =head2 _check_mb_pureperl_build_wanted This method proves the C<_argv> attribute and (when set) the C whether they contain I<--pureperl-only> or not. =cut sub _check_mb_pureperl_build_wanted { my $self = shift->_get_instance; defined $ENV{PERL_MB_OPT} and my @env_args = split " ", $ENV{PERL_MB_OPT}; foreach my $arg (@{$self->{_argv}}, @env_args) { $arg eq "--pureperl-only" and return 1; } 0; } =head2 _check_pureperl_required This method calls C<_check_mm_pureperl_build_wanted> when running under L (C) or C<_check_mb_pureperl_build_wanted> when running under a C (L compatible) environment. When neither is found (C<$0> contains neither C nor C), simply 0 is returned. =cut sub _check_pureperl_required { my $self = shift; $0 =~ m/Makefile\.PL$/i and return $self->_check_mm_pureperl_build_wanted(@_); $0 =~ m/Build\.PL$/i and return $self->_check_mb_pureperl_build_wanted(@_); 0; } =head2 check_pureperl_required This check method proves whether a pure perl build is wanted or not by cached-checking C<< $self->_check_pureperl_required >>. =cut sub check_pureperl_required { my $self = shift->_get_instance; my $cache_name = $self->_cache_name(qw(pureperl required)); $self->check_cached($cache_name, "whether pureperl is required", sub { $self->_check_pureperl_required }); } =head2 check_produce_xs_build This routine checks whether XS can be produced. Therefore it does following checks in given order: =over 4 =item * check pure perl environment variables (L) or command line arguments and return false when pure perl is requested =item * check whether a compiler is available (L) and return false if none found =item * check whether a test program accessing Perl API can be compiled and die with error if not =back When all checks passed successfully, return a true value. If the very last parameter contains a hash reference, C references to I or I are executed, respectively. =cut sub check_produce_xs_build { my $options = {}; scalar @_ > 1 and ref $_[-1] eq "HASH" and $options = pop @_; my $self = shift->_get_instance; $self->check_pureperl_required() and return _on_return_callback_helper(0, $options, "action_on_false"); eval { $self->check_valid_compilers($_[0] || [qw(C)]) } or return _on_return_callback_helper(0, $options, "action_on_false"); # XXX necessary check for $Config{useshrlib}? (need to dicuss with e.g. TuX, 99% likely return 0) $self->check_compile_perlapi_or_die(); $options->{action_on_true} and ref $options->{action_on_true} eq "CODE" and $options->{action_on_true}->(); return 1; } =head2 check_produce_loadable_xs_build This routine proves whether XS should be built and it's possible to create a dynamic linked object which can be loaded using Perl's Dynaloader. The extension over L can be avoided by adding the C to C<$ENV{PERL5_AC_OPTS}>. If the very last parameter contains a hash reference, C references to I or I are executed, respectively. =cut sub check_produce_loadable_xs_build { my $self = shift->_get_instance; $self->check_produce_xs_build(@_) and !$self->{c_ac_flags}->{notest_loadable_xs} and $self->check_linkable_xs_so_or_die and $self->check_loadable_xs_so_or_die; } # # # Auxiliary funcs # =head2 _set_argv Intended to act as a helper for evaluating given command line arguments. Stores given arguments in instances C<_argv> attribute. Call once at very begin of C or C: Your::Pkg::Config::AutoConf->_set_args(@ARGV); =cut sub _set_argv { my ($self, @argv) = @_; $self = $self->_get_instance; $self->{_argv} = \@argv; return; } sub _sanitize { # This is hard coded, and maybe a little stupid... my $x = shift; $x =~ s/ //g; $x =~ s/\///g; $x =~ s/\\//g; $x; } sub _get_instance { ref $_[0] and return $_[0]; defined $glob_instance or $glob_instance = $_[0]->new(); $glob_instance; } sub _get_builder { my $self = $_[0]->_get_instance(); ref $self->{lang_supported}->{$self->{lang}} eq "CODE" and $self->{lang_supported}->{$self->{lang}}->($self); defined($self->{lang_supported}->{$self->{lang}}) or croak("Unsupported compile language \"" . $self->{lang} . "\""); $self->{lang_supported}->{$self->{lang}}->new(); } sub _set_language { my $self = shift->_get_instance(); my ($lang, $impl) = @_; defined($lang) or croak("Missing language"); defined($impl) and defined($self->{lang_supported}->{$lang}) and $impl ne $self->{lang_supported}->{$lang} and croak("Language implementor ($impl) doesn't match exisiting one (" . $self->{lang_supported}->{$lang} . ")"); defined($impl) and !defined($self->{lang_supported}->{$lang}) and $self->{lang_supported}->{$lang} = $impl; ref $self->{lang_supported}->{$lang} eq "CODE" and $self->{lang_supported}->{$lang}->($self); defined($self->{lang_supported}->{$lang}) or croak("Unsupported language \"$lang\""); defined($self->{extra_compile_flags}->{$lang}) or $self->{extra_compile_flags}->{$lang} = []; $self->{lang} = $lang; return; } sub _on_return_callback_helper { my $callback = pop @_; my $options = pop @_; $options->{$callback} and ref $options->{$callback} eq "CODE" and $options->{$callback}->(); @_ and wantarray and return @_; 1 == scalar @_ and return $_[0]; return; } sub _fill_defines { my ($self, $src, $action_if_true, $action_if_false) = @_; ref $self or $self = $self->_get_instance(); my $conftest = ""; while (my ($defname, $defcnt) = each(%{$self->{defines}})) { $defcnt->[0] or next; defined $defcnt->[1] and $conftest .= "/* " . $defcnt->[1] . " */\n"; $conftest .= join(" ", "#define", $defname, $defcnt->[0]) . "\n"; } $conftest .= "/* end of conftest.h */\n"; $conftest; } # # default includes taken from autoconf/headers.m4 # =head2 _default_includes returns a string containing default includes for program prologue taken from C: #include #ifdef HAVE_SYS_TYPES_H # include #endif #ifdef HAVE_SYS_STAT_H # include #endif #ifdef STDC_HEADERS # include # include #else # ifdef HAVE_STDLIB_H # include # endif #endif #ifdef HAVE_STRING_H # if !defined STDC_HEADERS && defined HAVE_MEMORY_H # include # endif # include #endif #ifdef HAVE_STRINGS_H # include #endif #ifdef HAVE_INTTYPES_H # include #endif #ifdef HAVE_STDINT_H # include #endif #ifdef HAVE_UNISTD_H # include #endif =cut my $_default_includes = <<"_ACEOF"; #include #ifdef HAVE_SYS_TYPES_H # include #endif #ifdef HAVE_SYS_STAT_H # include #endif #ifdef STDC_HEADERS # include # include #else # ifdef HAVE_STDLIB_H # include # endif #endif #ifdef HAVE_STRING_H # if !defined STDC_HEADERS && defined HAVE_MEMORY_H # include # endif # include #endif #ifdef HAVE_STRINGS_H # include #endif #ifdef HAVE_INTTYPES_H # include #endif #ifdef HAVE_STDINT_H # include #endif #ifdef HAVE_UNISTD_H # include #endif _ACEOF sub _default_includes { $_default_includes } sub _default_main { $_[0]->_build_main("") } my $_main_tpl = <<"_ACEOF"; int main () { %s; return 0; } _ACEOF sub _build_main { my $self = shift->_get_instance(); my $body = shift || ""; sprintf($_main_tpl, $body); } =head2 _default_includes_with_perl returns a string containing default includes for program prologue containing I<_default_includes> plus #include #include =cut my $_include_perl = <<"_ACEOF"; #include #include #include /* for perl context in threaded perls */ _ACEOF sub _default_includes_with_perl { join("\n", $_[0]->_default_includes, $_include_perl); } sub _cache_prefix { "ac" } sub _cache_name { my ($self, @names) = @_; my $cache_name = join("_", $self->_cache_prefix(), "cv", @names); $cache_name =~ tr/_A-Za-z0-9/_/c; $cache_name; } sub _get_log_fh { my $self = $_[0]->_get_instance(); unless (defined($self->{logfh})) { my $open_mode = defined $self->{logfile_mode} ? $self->{logfile_mode} : ">"; open(my $fh, $open_mode, $self->{logfile}) or croak "Could not open file $self->{logfile}: $!"; $self->{logfh} = [$fh]; } $self->{logfh}; } sub _add_log_entry { my ($self, @logentries) = @_; ref($self) or $self = $self->_get_instance(); $self->_get_log_fh(); foreach my $logentry (@logentries) { foreach my $fh (@{$self->{logfh}}) { print {$fh} "$logentry"; } } return; } sub _add_log_lines { my ($self, @logentries) = @_; ref($self) or $self = $self->_get_instance(); $self->_get_log_fh(); my $logmsg = join("\n", @logentries) . "\n"; foreach my $fh (@{$self->{logfh}}) { print {$fh} $logmsg; } return; } =head2 add_log_fh Push new file handles at end of log-handles to allow tee'ing log-output =cut sub add_log_fh { my ($self, @newh) = @_; $self->_get_log_fh(); SKIP_DUP: foreach my $fh (@newh) { foreach my $eh (@{$self->{logfh}}) { $fh == $eh and next SKIP_DUP; } push @{$self->{logfh}}, $fh; } return; } =head2 delete_log_fh Removes specified log file handles. This method allows you to shoot yourself in the foot - it doesn't prove whether the primary nor the last handle is removed. Use with caution. =cut sub delete_log_fh { my ($self, @xh) = @_; $self->_get_log_fh(); SKIP_DUP: foreach my $fh (@xh) { foreach my $ih (0 .. $#{$self->{logfh}}) { $fh == $self->{logfh}->[$ih] or next; splice @{$self->{logfh}}, $ih, 1; last; } } return; } sub _cache_type_name { my ($self, @names) = @_; $self->_cache_name(map { $_ =~ tr/*/p/; $_ } @names); } =head2 _get_extra_compiler_flags Returns the determined flags required to run the compile stage as string =cut sub _get_extra_compiler_flags { my $self = shift->_get_instance(); my @ppflags = @{$self->{extra_preprocess_flags}}; my @cflags = @{$self->{extra_compile_flags}->{$self->{lang}}}; join(" ", map { _quote_shell_arg $_ } (@ppflags, @cflags)); } =head2 _get_extra_linker_flags Returns the determined flags required to run the link stage as string =cut sub _get_extra_linker_flags { my $self = shift->_get_instance(); my @libs = @{$self->{extra_libs}}; my @lib_dirs = @{$self->{extra_lib_dirs}}; my @ldflags = @{$self->{extra_link_flags}}; join(" ", map { _quote_shell_arg $_ } (@ldflags, map("-L" . $self->_sanitize_prog($_), @lib_dirs), map("-l$_", @libs))); } =head1 AUTHOR Alberto Simões, C<< >> Jens Rehsack, C<< >> =head1 NEXT STEPS Although a lot of work needs to be done, these are the next steps I intend to take. - detect flex/lex - detect yacc/bison/byacc - detect ranlib (not sure about its importance) These are the ones I think not too much important, and will be addressed later, or by request. - detect an 'install' command - detect a 'ln -s' command -- there should be a module doing this kind of task. =head1 BUGS A lot. Portability is a pain. B<>. Please report any bugs or feature requests to C, or through the web interface at L. We will be notified, and then you'll automatically be notified of progress on your bug as we make changes. =head1 SUPPORT You can find documentation for this module with the perldoc command. perldoc Config::AutoConf You can also look for information at: =over 4 =item * AnnoCPAN: Annotated CPAN documentation L =item * CPAN Ratings L =item * MetaCPAN L =item * Git Repository L =back =head1 ACKNOWLEDGEMENTS Michael Schwern for kind MacOS X help. Ken Williams for ExtUtils::CBuilder Peter Rabbitson for help on refactoring and making the API more Perl'ish =head1 COPYRIGHT & LICENSE Copyright 2004-2020 by the Authors This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 SEE ALSO ExtUtils::CBuilder(3) =cut 1; # End of Config::AutoConf List-MoreUtils-0.430/inc/latest/0000755000175000017500000000000013744044757014620 5ustar snosnoList-MoreUtils-0.430/inc/latest/private.pm0000644000175000017500000000601613735543547016634 0ustar snosnouse strict; use warnings; package inc::latest::private; # ABSTRACT: private implementation for inc::latest our $VERSION = '0.500'; use File::Spec; use IO::File; # must ultimately "goto" the import routine of the module to be loaded # so that the calling package is correct when $mod->import() runs. sub import { my ( $package, $mod, @args ) = @_; my $file = $package->_mod2path($mod); if ( $INC{$file} ) { # Already loaded, but let _load_module handle import args goto \&_load_module; } # A bundled copy must be present my ( $bundled, $bundled_dir ) = $package->_search_bundled($file) or die "No bundled copy of $mod found"; my $from_inc = $package->_search_INC($file); unless ($from_inc) { # Only bundled is available unshift( @INC, $bundled_dir ); goto \&_load_module; } if ( _version($from_inc) >= _version($bundled) ) { # Ignore the bundled copy goto \&_load_module; } # Load the bundled copy unshift( @INC, $bundled_dir ); goto \&_load_module; } sub _version { require ExtUtils::MakeMaker; return ExtUtils::MM->parse_version(shift); } # use "goto" for import to preserve caller sub _load_module { my $package = shift; # remaining @_ is ready for goto my ( $mod, @args ) = @_; eval "require $mod; 1" or die $@; if ( my $import = $mod->can('import') ) { goto $import; } return 1; } sub _search_bundled { my ( $self, $file ) = @_; my $mypath = 'inc'; local *DH; # Maintain 5.005 compatibility opendir DH, $mypath or die "Can't open directory $mypath: $!"; while ( defined( my $e = readdir DH ) ) { next unless $e =~ /^inc_/; my $try = File::Spec->catfile( $mypath, $e, $file ); return ( $try, File::Spec->catdir( $mypath, $e ) ) if -e $try; } return; } # Look for the given path in @INC. sub _search_INC { # TODO: doesn't handle coderefs or arrayrefs or objects in @INC, but # it probably should my ( $self, $file ) = @_; foreach my $dir (@INC) { next if ref $dir; my $try = File::Spec->catfile( $dir, $file ); return $try if -e $try; } return; } # Translate a module name into a directory/file.pm to search for in @INC sub _mod2path { my ( $self, $mod ) = @_; my @parts = split /::/, $mod; $parts[-1] .= '.pm'; return $parts[0] if @parts == 1; return File::Spec->catfile(@parts); } 1; # vim: ts=4 sts=4 sw=4 tw=75 et: __END__ =pod =encoding UTF-8 =head1 NAME inc::latest::private - private implementation for inc::latest =head1 VERSION version 0.500 =head1 DESCRIPTION This module has the private methods used to find and load bundled modules. It should not be used directly. =head1 AUTHORS =over 4 =item * David Golden =item * Eric Wilhelm =back =head1 COPYRIGHT AND LICENSE This software is Copyright (c) 2009 by David Golden. This is free software, licensed under: The Apache License, Version 2.0, January 2004 =cut List-MoreUtils-0.430/META.json0000664000175000017500000000452313744044757014202 0ustar snosno{ "abstract" : "Provide the stuff missing in List::Util", "author" : [ "Tassilo von Parseval ", "Adam Kennedy ", "Jens Rehsack " ], "dynamic_config" : 1, "generated_by" : "ExtUtils::MakeMaker version 7.46, CPAN::Meta::Converter version 2.150010", "license" : [ "apache_2_0" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : 2 }, "name" : "List-MoreUtils", "no_index" : { "directory" : [ "t", "inc" ] }, "prereqs" : { "build" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "configure" : { "recommends" : { "Config::AutoConf" : "0.315" }, "requires" : { "ExtUtils::MakeMaker" : "0" } }, "develop" : { "requires" : { "Config::AutoConf" : "0.315", "Module::CPANTS::Analyse" : "0.96", "Test::CPAN::Changes" : "0", "Test::CheckManifest" : "0", "Test::Kwalitee" : "0", "Test::Perl::Critic" : "0", "Test::PerlTidy" : "0", "Test::Pod" : "0", "Test::Pod::Coverage" : "0", "Test::Pod::Spelling::CommonMistakes" : "0", "Test::Spelling" : "0", "Test::WriteVariants" : "0.014", "inc::latest" : "0.500" } }, "runtime" : { "requires" : { "Exporter::Tiny" : "0.038", "List::MoreUtils::XS" : "0.430" } }, "test" : { "requires" : { "Storable" : "0", "Test::LeakTrace" : "0", "Test::More" : "0.96" } } }, "release_status" : "stable", "resources" : { "bugtracker" : { "mailto" : "bug-List-MoreUtils@rt.cpan.org", "web" : "https://rt.cpan.org/Dist/Display.html?Name=List-MoreUtils" }, "homepage" : "https://metacpan.org/release/List-MoreUtils", "repository" : { "type" : "git", "url" : "https://github.com/perl5-utils/List-MoreUtils.git", "web" : "https://github.com/perl5-utils/List-MoreUtils" } }, "version" : "0.430", "x_serialization_backend" : "JSON::PP version 4.05" } List-MoreUtils-0.430/LICENSE0000644000175000017500000002613513735543464013566 0ustar snosno Apache License Version 2.0, January 2004 http://www.apache.org/licenses/ TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION 1. Definitions. "License" shall mean the terms and conditions for use, reproduction, and distribution as defined by Sections 1 through 9 of this document. "Licensor" shall mean the copyright owner or entity authorized by the copyright owner that is granting the License. "Legal Entity" shall mean the union of the acting entity and all other entities that control, are controlled by, or are under common control with that entity. For the purposes of this definition, "control" means (i) the power, direct or indirect, to cause the direction or management of such entity, whether by contract or otherwise, or (ii) ownership of fifty percent (50%) or more of the outstanding shares, or (iii) beneficial ownership of such entity. "You" (or "Your") shall mean an individual or Legal Entity exercising permissions granted by this License. "Source" form shall mean the preferred form for making modifications, including but not limited to software source code, documentation source, and configuration files. "Object" form shall mean any form resulting from mechanical transformation or translation of a Source form, including but not limited to compiled object code, generated documentation, and conversions to other media types. "Work" shall mean the work of authorship, whether in Source or Object form, made available under the License, as indicated by a copyright notice that is included in or attached to the work (an example is provided in the Appendix below). "Derivative Works" shall mean any work, whether in Source or Object form, that is based on (or derived from) the Work and for which the editorial revisions, annotations, elaborations, or other modifications represent, as a whole, an original work of authorship. For the purposes of this License, Derivative Works shall not include works that remain separable from, or merely link (or bind by name) to the interfaces of, the Work and Derivative Works thereof. "Contribution" shall mean any work of authorship, including the original version of the Work and any modifications or additions to that Work or Derivative Works thereof, that is intentionally submitted to Licensor for inclusion in the Work by the copyright owner or by an individual or Legal Entity authorized to submit on behalf of the copyright owner. For the purposes of this definition, "submitted" means any form of electronic, verbal, or written communication sent to the Licensor or its representatives, including but not limited to communication on electronic mailing lists, source code control systems, and issue tracking systems that are managed by, or on behalf of, the Licensor for the purpose of discussing and improving the Work, but excluding communication that is conspicuously marked or otherwise designated in writing by the copyright owner as "Not a Contribution." "Contributor" shall mean Licensor and any individual or Legal Entity on behalf of whom a Contribution has been received by Licensor and subsequently incorporated within the Work. 2. Grant of Copyright License. Subject to the terms and conditions of this License, each Contributor hereby grants to You a perpetual, worldwide, non-exclusive, no-charge, royalty-free, irrevocable copyright license to reproduce, prepare Derivative Works of, publicly display, publicly perform, sublicense, and distribute the Work and such Derivative Works in Source or Object form. 3. Grant of Patent License. Subject to the terms and conditions of this License, each Contributor hereby grants to You a perpetual, worldwide, non-exclusive, no-charge, royalty-free, irrevocable (except as stated in this section) patent license to make, have made, use, offer to sell, sell, import, and otherwise transfer the Work, where such license applies only to those patent claims licensable by such Contributor that are necessarily infringed by their Contribution(s) alone or by combination of their Contribution(s) with the Work to which such Contribution(s) was submitted. If You institute patent litigation against any entity (including a cross-claim or counterclaim in a lawsuit) alleging that the Work or a Contribution incorporated within the Work constitutes direct or contributory patent infringement, then any patent licenses granted to You under this License for that Work shall terminate as of the date such litigation is filed. 4. Redistribution. You may reproduce and distribute copies of the Work or Derivative Works thereof in any medium, with or without modifications, and in Source or Object form, provided that You meet the following conditions: (a) You must give any other recipients of the Work or Derivative Works a copy of this License; and (b) You must cause any modified files to carry prominent notices stating that You changed the files; and (c) You must retain, in the Source form of any Derivative Works that You distribute, all copyright, patent, trademark, and attribution notices from the Source form of the Work, excluding those notices that do not pertain to any part of the Derivative Works; and (d) If the Work includes a "NOTICE" text file as part of its distribution, then any Derivative Works that You distribute must include a readable copy of the attribution notices contained within such NOTICE file, excluding those notices that do not pertain to any part of the Derivative Works, in at least one of the following places: within a NOTICE text file distributed as part of the Derivative Works; within the Source form or documentation, if provided along with the Derivative Works; or, within a display generated by the Derivative Works, if and wherever such third-party notices normally appear. The contents of the NOTICE file are for informational purposes only and do not modify the License. You may add Your own attribution notices within Derivative Works that You distribute, alongside or as an addendum to the NOTICE text from the Work, provided that such additional attribution notices cannot be construed as modifying the License. You may add Your own copyright statement to Your modifications and may provide additional or different license terms and conditions for use, reproduction, or distribution of Your modifications, or for any such Derivative Works as a whole, provided Your use, reproduction, and distribution of the Work otherwise complies with the conditions stated in this License. 5. Submission of Contributions. Unless You explicitly state otherwise, any Contribution intentionally submitted for inclusion in the Work by You to the Licensor shall be under the terms and conditions of this License, without any additional terms or conditions. Notwithstanding the above, nothing herein shall supersede or modify the terms of any separate license agreement you may have executed with Licensor regarding such Contributions. 6. Trademarks. This License does not grant permission to use the trade names, trademarks, service marks, or product names of the Licensor, except as required for reasonable and customary use in describing the origin of the Work and reproducing the content of the NOTICE file. 7. Disclaimer of Warranty. Unless required by applicable law or agreed to in writing, Licensor provides the Work (and each Contributor provides its Contributions) on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied, including, without limitation, any warranties or conditions of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A PARTICULAR PURPOSE. You are solely responsible for determining the appropriateness of using or redistributing the Work and assume any risks associated with Your exercise of permissions under this License. 8. Limitation of Liability. In no event and under no legal theory, whether in tort (including negligence), contract, or otherwise, unless required by applicable law (such as deliberate and grossly negligent acts) or agreed to in writing, shall any Contributor be liable to You for damages, including any direct, indirect, special, incidental, or consequential damages of any character arising as a result of this License or out of the use or inability to use the Work (including but not limited to damages for loss of goodwill, work stoppage, computer failure or malfunction, or any and all other commercial damages or losses), even if such Contributor has been advised of the possibility of such damages. 9. Accepting Warranty or Additional Liability. While redistributing the Work or Derivative Works thereof, You may choose to offer, and charge a fee for, acceptance of support, warranty, indemnity, or other liability obligations and/or rights consistent with this License. However, in accepting such obligations, You may act only on Your own behalf and on Your sole responsibility, not on behalf of any other Contributor, and only if You agree to indemnify, defend, and hold each Contributor harmless for any liability incurred by, or claims asserted against, such Contributor by reason of your accepting any such warranty or additional liability. END OF TERMS AND CONDITIONS APPENDIX: How to apply the Apache License to your work. To apply the Apache License to your work, attach the following boilerplate notice, with the fields enclosed by brackets "{}" replaced with your own identifying information. (Don't include the brackets!) The text should be enclosed in the appropriate comment syntax for the file format. We also recommend that a file or class name and description of purpose be included on the same "printed page" as the copyright notice for easier identification within third-party archives. Copyright {yyyy} {name of copyright owner} Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in compliance with the License. You may obtain a copy of the License at http://www.apache.org/licenses/LICENSE-2.0 Unless required by applicable law or agreed to in writing, software distributed under the License is distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the License for the specific language governing permissions and limitations under the License. List-MoreUtils-0.430/MANIFEST.SKIP0000644000175000017500000000063013736564245014450 0ustar snosno\B\.svn\b \B\.git\b \.gitignore$ \.[Bb][Aa][Kk]$ \.orig$ \.old$ \.tdy$ \.tmp$ \.log$ \..*sw. ^Makefile$ ^Build$ ^Build\.bat$ cover_db/ \.Inline/.* _Inline/.* \.bak$ \.tar$ \.tgz$ \.tar\.gz$ ^mess/ ^tmp/ ^testdata/ ^blib/ ^sandbox/ ^pm_to_blib$ ^cover_db/ nytprof*/ nytprof.out ^_build/.* ~$ .*\.planner .*\.lock LMUconfig\.h \.travis\.yml \.gitmodules ^List-MoreUtils-.* \bxt \.[icos] \.bs ^MYMETA.* Sandbox List-MoreUtils-0.430/ARTISTIC-1.00000644000175000017500000001426013735543464014216 0ustar snosno The "Artistic License" Preamble The intent of this document is to state the conditions under which a Package may be copied, such that the Copyright Holder maintains some semblance of artistic control over the development of the package, while giving the users of the package the right to use and distribute the Package in a more-or-less customary fashion, plus the right to make reasonable modifications. Definitions: "Package" refers to the collection of files distributed by the Copyright Holder, and derivatives of that collection of files created through textual modification. "Standard Version" refers to such a Package if it has not been modified, or has been modified in accordance with the wishes of the Copyright Holder as specified below. "Copyright Holder" is whoever is named in the copyright or copyrights for the package. "You" is you, if you're thinking about copying or distributing this Package. "Reasonable copying fee" is whatever you can justify on the basis of media cost, duplication charges, time of people involved, and so on. (You will not be required to justify it to the Copyright Holder, but only to the computing community at large as a market that must bear the fee.) "Freely Available" means that no fee is charged for the item itself, though there may be fees involved in handling the item. It also means that recipients of the item may redistribute it under the same conditions they received it. 1. You may make and give away verbatim copies of the source form of the Standard Version of this Package without restriction, provided that you duplicate all of the original copyright notices and associated disclaimers. 2. You may apply bug fixes, portability fixes and other modifications derived from the Public Domain or from the Copyright Holder. A Package modified in such a way shall still be considered the Standard Version. 3. You may otherwise modify your copy of this Package in any way, provided that you insert a prominent notice in each changed file stating how and when you changed that file, and provided that you do at least ONE of the following: a) place your modifications in the Public Domain or otherwise make them Freely Available, such as by posting said modifications to Usenet or an equivalent medium, or placing the modifications on a major archive site such as uunet.uu.net, or by allowing the Copyright Holder to include your modifications in the Standard Version of the Package. b) use the modified Package only within your corporation or organization. c) rename any non-standard executables so the names do not conflict with standard executables, which must also be provided, and provide a separate manual page for each non-standard executable that clearly documents how it differs from the Standard Version. d) make other distribution arrangements with the Copyright Holder. 4. You may distribute the programs of this Package in object code or executable form, provided that you do at least ONE of the following: a) distribute a Standard Version of the executables and library files, together with instructions (in the manual page or equivalent) on where to get the Standard Version. b) accompany the distribution with the machine-readable source of the Package with your modifications. c) give non-standard executables non-standard names, and clearly document the differences in manual pages (or equivalent), together with instructions on where to get the Standard Version. d) make other distribution arrangements with the Copyright Holder. 5. You may charge a reasonable copying fee for any distribution of this Package. You may charge any fee you choose for support of this Package. You may not charge a fee for this Package itself. However, you may distribute this Package in aggregate with other (possibly commercial) programs as part of a larger (possibly commercial) software distribution provided that you do not advertise this Package as a product of your own. You may embed this Package's interpreter within an executable of yours (by linking); this shall be construed as a mere form of aggregation, provided that the complete Standard Version of the interpreter is so embedded. 6. The scripts and library files supplied as input to or produced as output from the programs of this Package do not automatically fall under the copyright of this Package, but belong to whoever generated them, and may be sold commercially, and may be aggregated with this Package. If such scripts or library files are aggregated with this Package via the so-called "undump" or "unexec" methods of producing a binary executable image, then distribution of such an image shall neither be construed as a distribution of this Package nor shall it fall under the restrictions of Paragraphs 3 and 4, provided that you do not represent such an executable image as a Standard Version of this Package. 7. C subroutines (or comparably compiled subroutines in other languages) supplied by you and linked into this Package in order to emulate subroutines and variables of the language defined by this Package shall not be considered part of this Package, but are the equivalent of input as in Paragraph 6, provided these subroutines do not change the language in any way that would cause it to fail the regression tests for the language. 8. Aggregation of this Package with a commercial distribution is always permitted provided that the use of this Package is embedded; that is, when no overt attempt is made to make this Package's interfaces visible to the end user of the commercial distribution. Such use shall not be construed as a distribution of this Package. 9. The name of the Copyright Holder may not be used to endorse or promote products derived from this software without specific prior written permission. 10. THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. The End List-MoreUtils-0.430/.perltidyrc0000644000175000017500000000017413736531377014737 0ustar snosno-b -bl -noll -pt=2 -bt=2 -sbt=2 -vt=0 -vtc=0 -dws -aws -nsfs -asc -bbt=0 -cab=0 -l=130 -ole=unix --noblanks-before-comments List-MoreUtils-0.430/README.md0000644000175000017500000010632013735543464014033 0ustar snosno# NAME List::MoreUtils - Provide the stuff missing in List::Util # SYNOPSIS # import specific functions use List::MoreUtils qw(any uniq); if ( any { /foo/ } uniq @has_duplicates ) { # do stuff } # import everything use List::MoreUtils ':all'; # import by API # has "original" any/all/none/notall behavior use List::MoreUtils ':like_0.22'; # 0.22 + bsearch use List::MoreUtils ':like_0.24'; # has "simplified" any/all/none/notall behavior + (n)sort_by use List::MoreUtils ':like_0.33'; # DESCRIPTION **List::MoreUtils** provides some trivial but commonly needed functionality on lists which is not going to go into [List::Util](https://metacpan.org/pod/List::Util). 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. # EXPORTS ## Default behavior Nothing by default. To import all of this module's symbols use the `:all` tag. Otherwise functions can be imported by name as usual: use List::MoreUtils ':all'; use List::MoreUtils qw{ any firstidx }; Because historical changes to the API might make upgrading List::MoreUtils difficult for some projects, the legacy API is available via special import tags. ## Like version 0.22 (last release with original API) This API was available from 2006 to 2009, returning undef for empty lists on `all`/`any`/`none`/`notall`: use List::MoreUtils ':like_0.22'; This import tag will import all functions available as of version 0.22. However, it will import `any_u` as `any`, `all_u` as `all`, `none_u` as `none`, and `notall_u` as `notall`. ## Like version 0.24 (first incompatible change) This API was available from 2010 to 2011. It changed the return value of `none` and added the `bsearch` function. use List::MoreUtils ':like_0.24'; This import tag will import all functions available as of version 0.24. However it will import `any_u` as `any`, `all_u` as `all`, and `notall_u` as `notall`. It will import `none` as described in the documentation below (true for empty list). ## Like version 0.33 (second incompatible change) This API was available from 2011 to 2014. It is widely used in several CPAN modules and thus it's closest to the current API. It changed the return values of `any`, `all`, and `notall`. It added the `sort_by` and `nsort_by` functions and the `distinct` alias for `uniq`. It omitted `bsearch`. use List::MoreUtils ':like_0.33'; This import tag will import all functions available as of version 0.33. Note: it will not import `bsearch` for consistency with the 0.33 API. # FUNCTIONS ## Junctions ### _Treatment of an empty list_ There are two schools of thought for how to evaluate a junction on an empty list: - Reduction to an identity (boolean) - Result is undefined (three-valued) In the first case, the result of the junction applied to the empty list is determined by a mathematical reduction to an identity depending on whether the underlying comparison is "or" or "and". Conceptually: "any are true" "all are true" -------------- -------------- 2 elements: A || B || 0 A && B && 1 1 element: A || 0 A && 1 0 elements: 0 1 In the second case, three-value logic is desired, in which a junction applied to an empty list returns `undef` rather than true or false Junctions with a `_u` suffix implement three-valued logic. Those without are boolean. ### all BLOCK LIST ### all\_u BLOCK LIST Returns a true value if all items in LIST meet the criterion given through BLOCK. Sets `$_` for each item in LIST in turn: print "All values are non-negative" if all { $_ >= 0 } ($x, $y, $z); For an empty LIST, `all` returns true (i.e. no values failed the condition) and `all_u` returns `undef`. Thus, `all_u(@list)` is equivalent to `@list ? all(@list) : undef`. **Note**: because Perl treats `undef` as false, you must check the return value of `all_u` with `defined` or you will get the opposite result of what you expect. ### any BLOCK LIST ### any\_u BLOCK LIST Returns a true value if any item in LIST meets the criterion given through BLOCK. Sets `$_` for each item in LIST in turn: print "At least one non-negative value" if any { $_ >= 0 } ($x, $y, $z); For an empty LIST, `any` returns false and `any_u` returns `undef`. Thus, `any_u(@list)` is equivalent to `@list ? any(@list) : undef`. ### none BLOCK LIST ### none\_u BLOCK LIST Logically the negation of `any`. Returns a true value if no item in LIST meets the criterion given through BLOCK. Sets `$_` for each item in LIST in turn: print "No non-negative values" if none { $_ >= 0 } ($x, $y, $z); For an empty LIST, `none` returns true (i.e. no values failed the condition) and `none_u` returns `undef`. Thus, `none_u(@list)` is equivalent to `@list ? none(@list) : undef`. **Note**: because Perl treats `undef` as false, you must check the return value of `none_u` with `defined` or you will get the opposite result of what you expect. ### notall BLOCK LIST ### notall\_u BLOCK LIST Logically the negation of `all`. Returns a true value if not all items in LIST meet the criterion given through BLOCK. Sets `$_` for each item in LIST in turn: print "Not all values are non-negative" if notall { $_ >= 0 } ($x, $y, $z); For an empty LIST, `notall` returns false and `notall_u` returns `undef`. Thus, `notall_u(@list)` is equivalent to `@list ? notall(@list) : undef`. ### one BLOCK LIST ### one\_u BLOCK LIST Returns a true value if precisely one item in LIST meets the criterion given through BLOCK. Sets `$_` for each item in LIST in turn: print "Precisely one value defined" if one { defined($_) } @list; Returns false otherwise. For an empty LIST, `one` returns false and `one_u` returns `undef`. The expression `one BLOCK LIST` is almost equivalent to `1 == true BLOCK LIST`, except for short-cutting. Evaluation of BLOCK will immediately stop at the second true value. ## Transformation ### 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 `map` 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 } ### insert\_after BLOCK VALUE LIST Inserts VALUE after the first item in LIST for which the criterion in BLOCK is true. Sets `$_` 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 ### 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 ### 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 `$a` and `$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 ### mesh ARRAY1 ARRAY2 \[ ARRAY3 ... \] ### 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 `zip` is an alias for `mesh`. ### zip6 ### zip\_unflatten Returns a list of arrays consisting of the first elements of each array, then the second, then the third, etc, until all arrays are exhausted. @x = qw/a b c d/; @y = qw/1 2 3 4/; @z = zip6 @x, @y; # returns [a, 1], [b, 2], [c, 3], [d, 4] @a = ('x'); @b = ('1', '2'); @c = qw/zip zap zot/; @d = zip6 @a, @b, @c; # [x, 1, zip], [undef, 2, zap], [undef, undef, zot] `zip_unflatten` is an alias for `zip6`. ### listcmp ARRAY0 ARRAY1 \[ ARRAY2 ... \] Returns an associative list of elements and every _id_ of the list it was found in. Allowes easy implementation of @a & @b, @a | @b, @a ^ @b and so on. Undefined entries in any given array are skipped. my @a = qw(one two three four five six seven eight nine ten eleven twelve thirteen); my @b = qw(two three five seven eleven thirteen seventeen); my @c = qw(one one two three five eight thirteen twentyone); my %cmp = listcmp @a, @b, @c; # returns (one => [0, 2], two => [0, 1, 2], three => [0, 1, 2], four => [0], ...) my @seq = (1, 2, 3); my @prim = (undef, 2, 3, 5); my @fib = (1, 1, 2); my $cmp = listcmp @seq, @prim, @fib; # returns { 1 => [0, 2], 2 => [0, 1, 2], 3 => [0, 1], 5 => [1] } ### arrayify LIST\[,LIST\[,LIST...\]\] Returns a list costisting of each element of given arrays. Recursive arrays are flattened, too. @a = (1, [[2], 3], 4, [5], 6, [7], 8, 9); @l = arrayify @a; # returns 1, 2, 3, 4, 5, 6, 7, 8, 9 ### uniq LIST ### distinct LIST Returns a new list by stripping duplicate values in LIST by comparing the values as hash keys, except that undef is considered separate from ''. 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 # returns "Mike", "Michael", "Richard", "Rick" my @n = distinct "Mike", "Michael", "Richard", "Rick", "Michael", "Rick" # returns "A8", "", undef, "A5", "S1" my @s = distinct "A8", "", undef, "A5", "S1", "A5", "A8" # returns "Giulia", "Giulietta", undef, "", 156, "GTA", "GTV", 159, "Brera", "4C" my @w = uniq "Giulia", "Giulietta", undef, "", 156, "GTA", "GTV", 159, "Brera", "4C", "Giulietta", "Giulia" `distinct` is an alias for `uniq`. **RT#49800** can be used to give feedback about this behavior. ### singleton LIST Returns a new list by stripping values in LIST occurring more than once by comparing the values as hash keys, except that undef is considered separate from ''. The order of elements in the returned list is the same as in LIST. In scalar context, returns the number of elements occurring only once in LIST. my @x = singleton 1,1,2,2,3,4,5 # returns 3 4 5 ### duplicates LIST Returns a new list by stripping values in LIST occuring less than twice by comparing the values as hash keys, except that undef is considered separate from ''. The order of elements in the returned list is the same as in LIST. In scalar context, returns the number of elements occurring only once in LIST. my @y = duplicates 1,1,2,4,7,2,3,4,6,9; #returns 1,2,4 ### frequency LIST Returns an associative list of distinct values and the corresponding frequency. my @f = frequency values %radio_nrw; # returns ( # 'Deutschlandfunk (DLF)' => 9, 'WDR 3' => 10, # 'WDR 4' => 11, 'WDR 5' => 14, 'WDR Eins Live' => 14, # 'Deutschlandradio Kultur' => 8,...) ### occurrences LIST Returns a new list of frequencies and the corresponding values from LIST. my @o = occurrences ((1) x 3, (2) x 4, (3) x 2, (4) x 7, (5) x 2, (6) x 4); # @o = (undef, undef, [3, 5], [1], [2, 6], undef, undef, [4]); ### mode LIST Returns the modal value of LIST. In scalar context, just the modal value is returned, in list context all probes occuring _modal_ times are returned, too. my @m = mode ((1) x 3, (2) x 4, (3) x 2, (4) x 7, (5) x 2, (6) x 4, (7) x 3, (8) x 7); # @m = (7, 4, 8) - bimodal LIST ## Partitioning ### after BLOCK LIST Returns a list of the values of LIST after (and not including) the point where BLOCK returns a true value. Sets `$_` for each element in LIST in turn. @x = after { $_ % 5 == 0 } (1..9); # returns 6, 7, 8, 9 ### after\_incl BLOCK LIST Same as `after` but also includes the element for which BLOCK is true. ### before BLOCK LIST Returns a list of values of LIST up to (and not including) the point where BLOCK returns a true value. Sets `$_` for each element in LIST in turn. ### before\_incl BLOCK LIST Same as `before` but also includes the element for which BLOCK is true. ### 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] ### samples COUNT LIST Returns a new list containing COUNT random samples from LIST. Is similar to ["shuffle" in List::Util](https://metacpan.org/pod/List::Util#shuffle), but stops after COUNT. @r = samples 10, 1..10; # same as shuffle @r2 = samples 5, 1..10; # gives 5 values from 1..10; ## Iteration ### 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 '`index`', then it returns the index of the last fetched set of values, as a scalar. ### each\_arrayref LIST Like each\_array, but the arguments are references to arrays, not the plain arrays. ### natatime EXPR, LIST Creates an array iterator, for looping over an array in chunks of `$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 ## Searching ### firstval BLOCK LIST ### first\_value BLOCK LIST Returns the first element in LIST for which BLOCK evaluates to true. Each element of LIST is set to `$_` in turn. Returns `undef` if no such element has been found. `first_value` is an alias for `firstval`. ### onlyval BLOCK LIST ### only\_value BLOCK LIST Returns the only element in LIST for which BLOCK evaluates to true. Sets `$_` for each item in LIST in turn. Returns `undef` if no such element has been found. `only_value` is an alias for `onlyval`. ### lastval BLOCK LIST ### last\_value BLOCK LIST Returns the last value in LIST for which BLOCK evaluates to true. Each element of LIST is set to `$_` in turn. Returns `undef` if no such element has been found. `last_value` is an alias for `lastval`. ### firstres BLOCK LIST ### first\_result BLOCK LIST Returns the result of BLOCK for the first element in LIST for which BLOCK evaluates to true. Each element of LIST is set to `$_` in turn. Returns `undef` if no such element has been found. `first_result` is an alias for `firstres`. ### onlyres BLOCK LIST ### only\_result BLOCK LIST Returns the result of BLOCK for the first element in LIST for which BLOCK evaluates to true. Sets `$_` for each item in LIST in turn. Returns `undef` if no such element has been found. `only_result` is an alias for `onlyres`. ### lastres BLOCK LIST ### last\_result BLOCK LIST Returns the result of BLOCK for the last element in LIST for which BLOCK evaluates to true. Each element of LIST is set to `$_` in turn. Returns `undef` if no such element has been found. `last_result` is an alias for `lastres`. ### indexes BLOCK LIST Evaluates BLOCK for each element in LIST (assigned to `$_`) and returns a list of the indices of those elements for which BLOCK returned a true value. This is just like `grep` only that it returns indices instead of values: @x = indexes { $_ % 2 == 0 } (1..10); # returns 1, 3, 5, 7, 9 ### firstidx BLOCK LIST ### first\_index BLOCK LIST Returns the index of the first element in LIST for which the criterion in BLOCK is true. Sets `$_` 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 `-1` if no such item could be found. `first_index` is an alias for `firstidx`. ### onlyidx BLOCK LIST ### only\_index BLOCK LIST Returns the index of the only element in LIST for which the criterion in BLOCK is true. Sets `$_` for each item in LIST in turn: my @list = (1, 3, 4, 3, 2, 4); printf "uniqe index of item 2 in list is %i", onlyidx { $_ == 2 } @list; __END__ unique index of item 2 in list is 4 Returns `-1` if either no such item or more than one of these has been found. `only_index` is an alias for `onlyidx`. ### lastidx BLOCK LIST ### last\_index BLOCK LIST Returns the index of the last element in LIST for which the criterion in BLOCK is true. Sets `$_` 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 `-1` if no such item could be found. `last_index` is an alias for `lastidx`. ## Sorting ### sort\_by BLOCK LIST Returns the list of values sorted according to the string values returned by the KEYFUNC block or function. A typical use of this may be to sort objects according to the string value of some accessor, such as sort_by { $_->name } @people The key function is called in scalar context, being passed each value in turn as both $\_ and the only argument in the parameters, @\_. The values are then sorted according to string comparisons on the values returned. This is equivalent to sort { $a->name cmp $b->name } @people except that it guarantees the name accessor will be executed only once per value. One interesting use-case is to sort strings which may have numbers embedded in them "naturally", rather than lexically. sort_by { s/(\d+)/sprintf "%09d", $1/eg; $_ } @strings This sorts strings by generating sort keys which zero-pad the embedded numbers to some level (9 digits in this case), helping to ensure the lexical sort puts them in the correct order. ### nsort\_by BLOCK LIST Similar to sort\_by but compares its key values numerically. ### qsort BLOCK ARRAY This sorts the given array **in place** using the given compare code. Except for tiny compare code like `$a <=> $b`, qsort is much faster than Perl's `sort` depending on the version. Compared 5.8 and 5.26: my @rl; for(my $i = 0; $i < 1E6; ++$i) { push @rl, rand(1E5) } my $idx; sub ext_cmp { $_[0] <=> $_[1] } cmpthese( -60, { 'qsort' => sub { my @qrl = @rl; qsort { ext_cmp($a, $b) } @qrl; $idx = bsearchidx { ext_cmp($_, $rl[0]) } @qrl }, 'reverse qsort' => sub { my @qrl = @rl; qsort { ext_cmp($b, $a) } @qrl; $idx = bsearchidx { ext_cmp($rl[0], $_) } @qrl }, 'sort' => sub { my @srl = @rl; @srl = sort { ext_cmp($a, $b) } @srl; $idx = bsearchidx { ext_cmp($_, $rl[0]) } @srl }, 'reverse sort' => sub { my @srl = @rl; @srl = sort { ext_cmp($b, $a) } @srl; $idx = bsearchidx { ext_cmp($rl[0], $_) } @srl }, }); 5.8 results s/iter reverse sort sort reverse qsort qsort reverse sort 6.21 -- -0% -8% -10% sort 6.19 0% -- -7% -10% reverse qsort 5.73 8% 8% -- -2% qsort 5.60 11% 11% 2% -- 5.26 results s/iter reverse sort sort reverse qsort qsort reverse sort 4.54 -- -0% -96% -96% sort 4.52 0% -- -96% -96% reverse qsort 0.203 2139% 2131% -- -19% qsort 0.164 2666% 2656% 24% -- Use it where external data sources might have to be compared (think of [Unix::Statgrab](https://metacpan.org/pod/Unix::Statgrab) "tables"). `qsort` is available from List::MoreUtils::XS only. It's insane to maintain a wrapper around Perl's sort nor having a pure Perl implementation. One could create a flip-book in same speed as PP runs a qsort. ## Searching in sorted Lists ### bsearch BLOCK LIST Performs a binary search on LIST which must be a sorted list of values. BLOCK must return a negative value if the current element (stored in `$_`) is smaller, a positive value if it is bigger and zero if it matches. Returns a boolean value in scalar context. In list context, it returns the element if it was found, otherwise the empty list. ### bsearchidx BLOCK LIST ### bsearch\_index BLOCK LIST Performs a binary search on LIST which must be a sorted list of values. BLOCK must return a negative value if the current element (stored in `$_`) is smaller, a positive value if it is bigger and zero if it matches. Returns the index of found element, otherwise `-1`. `bsearch_index` is an alias for `bsearchidx`. ### lower\_bound BLOCK LIST Returns the index of the first element in LIST which does not compare _less than val_. Technically it's the first element in LIST which does not return a value below zero when passed to BLOCK. @ids = (1, 1, 2, 2, 3, 3, 3, 3, 3, 3, 4, 4, 4, 4, 5, 5, 6, 7, 7, 7, 8, 8, 9, 9, 9, 9, 9, 11, 13, 13, 13, 17); $lb = lower_bound { $_ <=> 2 } @ids; # returns 2 $lb = lower_bound { $_ <=> 4 } @ids; # returns 10 lower\_bound has a complexity of O(log n). ### upper\_bound BLOCK LIST Returns the index of the first element in LIST which does not compare _greater than val_. Technically it's the first element in LIST which does not return a value below or equal to zero when passed to BLOCK. @ids = (1, 1, 2, 2, 3, 3, 3, 3, 3, 3, 4, 4, 4, 4, 5, 5, 6, 7, 7, 7, 8, 8, 9, 9, 9, 9, 9, 11, 13, 13, 13, 17); $lb = upper_bound { $_ <=> 2 } @ids; # returns 4 $lb = upper_bound { $_ <=> 4 } @ids; # returns 14 upper\_bound has a complexity of O(log n). ### equal\_range BLOCK LIST Returns a pair of indices containing the lower\_bound and the upper\_bound. ## Operations on sorted Lists ### binsert BLOCK ITEM LIST ### bsearch\_insert BLOCK ITEM LIST Performs a binary search on LIST which must be a sorted list of values. BLOCK must return a negative value if the current element (stored in `$_`) is smaller, a positive value if it is bigger and zero if it matches. ITEM is inserted at the index where the ITEM should be placed (based on above search). That means, it's inserted before the next bigger element. @l = (2,3,5,7); binsert { $_ <=> 4 } 4, @l; # @l = (2,3,4,5,7) binsert { $_ <=> 6 } 42, @l; # @l = (2,3,4,42,7) You take care that the inserted element matches the compare result. ### bremove BLOCK LIST ### bsearch\_remove BLOCK LIST Performs a binary search on LIST which must be a sorted list of values. BLOCK must return a negative value if the current element (stored in `$_`) is smaller, a positive value if it is bigger and zero if it matches. The item at the found position is removed and returned. @l = (2,3,4,5,7); bremove { $_ <=> 4 }, @l; # @l = (2,3,5,7); ## Counting and calculation ### true BLOCK LIST Counts the number of elements in LIST for which the criterion in BLOCK is true. Sets `$_` for each item in LIST in turn: printf "%i item(s) are defined", true { defined($_) } @list; ### false BLOCK LIST Counts the number of elements in LIST for which the criterion in BLOCK is false. Sets `$_` for each item in LIST in turn: printf "%i item(s) are not defined", false { defined($_) } @list; ### reduce\_0 BLOCK LIST Reduce LIST by calling BLOCK in scalar context for each element of LIST. `$a` contains the progressional result and is initialized with 0. `$b` contains the current processed element of LIST and `$_` contains the index of the element in `$b`. The idea behind reduce\_0 is **summation** (addition of a sequence of numbers). ### reduce\_1 BLOCK LIST Reduce LIST by calling BLOCK in scalar context for each element of LIST. `$a` contains the progressional result and is initialized with 1. `$b` contains the current processed element of LIST and `$_` contains the index of the element in `$b`. The idea behind reduce\_1 is product of a sequence of numbers. ### reduce\_u BLOCK LIST Reduce LIST by calling BLOCK in scalar context for each element of LIST. `$a` contains the progressional result and is initialized with 1. `$b` contains the current processed element of LIST and `$_` contains the index of the element in `$b`. This function has been added if one might need the extra of the index value but need an individual initialization. **Use with caution**: In most cases ["reduce" in List::Util](https://metacpan.org/pod/List::Util#reduce) will do the job better. ### 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 `minmax` 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 `minmax` to win over a naive implementation. This limitation does not apply to the XS version. ### minmaxstr LIST Computes the minimum and maximum of LIST using string compare 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 implementation is similar to `minmax`. # ENVIRONMENT When `LIST_MOREUTILS_PP` 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. # MAINTENANCE The maintenance goal is to preserve the documented semantics of the API; bug fixes that bring actual behavior in line with semantics are allowed. New API functions may be added over time. If a backwards incompatible change is unavoidable, we will attempt to provide support for the legacy API using the same export tag mechanism currently in place. This module attempts to use few non-core dependencies. Non-core configuration and testing modules will be bundled when reasonable; run-time dependencies will be added only if they deliver substantial benefit. # CONTRIBUTING While contributions are appreciated, a contribution should not cause more effort for the maintainer than the contribution itself saves (see [Open Source Contribution Etiquette](http://tirania.org/blog/archive/2010/Dec-31.html)). To get more familiar where help could be needed - see [List::MoreUtils::Contributing](https://metacpan.org/pod/List::MoreUtils::Contributing). # 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 [List::Util](https://metacpan.org/pod/List::Util)'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 `LIST_MOREUTILS_PP` set to a true value. That way I know where to look for the problem (in XS, pure-Perl or possibly both). # SUPPORT Bugs should always be submitted via the CPAN bug tracker. You can find documentation for this module with the perldoc command. perldoc List::MoreUtils You can also look for information at: - RT: CPAN's request tracker [https://rt.cpan.org/Dist/Display.html?Name=List-MoreUtils](https://rt.cpan.org/Dist/Display.html?Name=List-MoreUtils) - AnnoCPAN: Annotated CPAN documentation [http://annocpan.org/dist/List-MoreUtils](http://annocpan.org/dist/List-MoreUtils) - CPAN Ratings [http://cpanratings.perl.org/dist/List-MoreUtils](http://cpanratings.perl.org/dist/List-MoreUtils) - MetaCPAN [https://metacpan.org/release/List-MoreUtils](https://metacpan.org/release/List-MoreUtils) - CPAN Search [http://search.cpan.org/dist/List-MoreUtils/](http://search.cpan.org/dist/List-MoreUtils/) - Git Repository [https://github.com/perl5-utils/List-MoreUtils](https://github.com/perl5-utils/List-MoreUtils) ## Where can I go for help? If you have a bug report, a patch or a suggestion, please open a new report ticket at CPAN (but please check previous reports first in case your issue has already been addressed) or open an issue on GitHub. Report tickets should contain a detailed description of the bug or enhancement request and at least an easily verifiable way of reproducing the issue or fix. Patches are always welcome, too - and it's cheap to send pull-requests on GitHub. Please keep in mind that code changes are more likely accepted when they're bundled with an approving test. If you think you've found a bug then please read "How to Report Bugs Effectively" by Simon Tatham: [http://www.chiark.greenend.org.uk/~sgtatham/bugs.html](http://www.chiark.greenend.org.uk/~sgtatham/bugs.html). ## Where can I go for help with a concrete version? Bugs and feature requests are accepted against the latest version only. To get patches for earlier versions, you need to get an agreement with a developer of your choice - who may or not report the issue and a suggested fix upstream (depends on the license you have chosen). ## Business support and maintenance Generally, in volunteered projects, there is no right for support. While every maintainer is happy to improve the provided software, spare time is limited. For those who have a use case which requires guaranteed support, one of the maintainers should be hired or contracted. For business support you can contact Jens via his CPAN email address rehsackATcpan.org. Please keep in mind that business support is neither available for free nor are you eligible to receive any support based on the license distributed with this package. # THANKS ## Tassilo von Parseval 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 [List::Utils](https://metacpan.org/pod/List::Utils) 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 `List::MoreUtil` 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. ## Jens Rehsack Credits goes to all people contributing feedback during the v0.400 development releases. Special thanks goes to David Golden who spent a lot of effort to develop a design to support current state of CPAN as well as ancient software somewhere in the dark. He also contributed a lot of patches to refactor the API frontend to welcome any user of List::MoreUtils - from ancient past to recently last used. Toby Inkster provided a lot of useful feedback for sane importer code and was a nice sounding board for API discussions. Peter Rabbitson provided a sane git repository setup containing entire package history. # TODO A pile of requests from other people is still pending further processing in my mailbox. This includes: - delete\_index - random\_item - random\_item\_delete\_index - list\_diff\_hash - list\_diff\_inboth - list\_diff\_infirst - list\_diff\_insecond These were all suggested by Dan Muey. - listify Always return a flat list when either a simple scalar value was passed or an array-reference. Suggested by Mark Summersault. # SEE ALSO [List::Util](https://metacpan.org/pod/List::Util), [List::AllUtils](https://metacpan.org/pod/List::AllUtils), [List::UtilsBy](https://metacpan.org/pod/List::UtilsBy) # AUTHOR Jens Rehsack <rehsack AT cpan.org> Adam Kennedy <adamk@cpan.org> Tassilo von Parseval <tassilo.von.parseval@rwth-aachen.de> # COPYRIGHT AND LICENSE Some parts copyright 2011 Aaron Crane. Copyright 2004 - 2010 by Tassilo von Parseval Copyright 2013 - 2017 by Jens Rehsack All code added with 0.417 or later is licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in compliance with the License. You may obtain a copy of the License at http://www.apache.org/licenses/LICENSE-2.0 Unless required by applicable law or agreed to in writing, software distributed under the License is distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the License for the specific language governing permissions and limitations under the License. All code until 0.416 is licensed 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. List-MoreUtils-0.430/t/0000755000175000017500000000000013744044757013016 5ustar snosnoList-MoreUtils-0.430/t/lib/0000755000175000017500000000000013744044757013564 5ustar snosnoList-MoreUtils-0.430/t/lib/Test/0000755000175000017500000000000013744044757014503 5ustar snosnoList-MoreUtils-0.430/t/lib/Test/LMU.pm0000644000175000017500000000677713736561312015507 0ustar snosnopackage Test::LMU; use strict; require Exporter; use Test::More import => ['!pass']; use Carp qw/croak/; use base qw(Test::Builder::Module Exporter); our @EXPORT = qw(freeze is_true is_false is_defined is_undef is_dying not_dying grow_stack leak_free_ok); our @EXPORT_OK = qw(freeze is_true is_false is_defined is_undef is_dying not_dying grow_stack leak_free_ok); my $CLASS = __PACKAGE__; eval "use Storable qw();"; $@ or Storable->import(qw(freeze)); __PACKAGE__->can("freeze") or eval <<'EOFR'; use inc::latest 'JSON::PP'; use JSON::PP qw(); sub freeze { my $json = JSON::PP->new(); $json->encode($_[0]); } EOFR ###################################################################### # Support Functions sub is_true { @_ == 1 or croak "Expected 1 param"; my $tb = $CLASS->builder(); $tb->ok($_[0], "is_true ()"); } sub is_false { @_ == 1 or croak "Expected 1 param"; my $tb = $CLASS->builder(); $tb->ok(!$_[0], "is_false()"); } sub is_defined { @_ < 1 or croak "Expected 0..1 param"; my $tb = $CLASS->builder(); $tb->ok(defined($_[0]), "is_defined ()"); } sub is_undef { @_ <= 1 or croak "Expected 0..1 param"; my $tb = $CLASS->builder(); $tb->ok(!defined($_[0]), "is_undef()"); } sub is_dying { @_ == 1 or @_ == 2 or croak "is_dying(name => code)"; my ($name, $code); $name = shift if @_ == 2; $code = shift; ref $code eq "CODE" or croak "is_dying(name => code)"; my $tb = $CLASS->builder(); eval { $code->(); }; my $except = $@; chomp $except; $tb->ok($except, "$name is_dying()") and note($except); } sub not_dying { @_ == 1 or @_ == 2 or croak "not_dying(name => code)"; my ($name, $code); $name = shift if @_ == 2; $code = shift; ref $code eq "CODE" or croak "not_dying(name => code)"; my $tb = $CLASS->builder(); eval { $code->(); }; my $except = $@; chomp $except; $tb->ok(!$except, "$name not_dying()") or diag($except); } my @bigary = (1) x 500; sub func { } sub grow_stack { func(@bigary); } my $have_test_leak_trace = eval { require Test::LeakTrace; 1 }; sub leak_free_ok { while (@_) { my $name = shift; my $code = shift; SKIP: { skip 'Test::LeakTrace not installed', 1 unless $have_test_leak_trace; local $Test::Builder::Level = $Test::Builder::Level + 1; &Test::LeakTrace::no_leaks_ok($code, "No memory leaks in $name"); } } } { package DieOnStringify; use overload '""' => \&stringify; sub new { bless {}, shift } sub stringify { die 'DieOnStringify exception' } } 1; =head1 AUTHOR Jens Rehsack Erehsack AT cpan.orgE Adam Kennedy Eadamk@cpan.orgE =head1 COPYRIGHT AND LICENSE Copyright 2013 - 2017 by Jens Rehsack All code added with 0.417 or later is licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in compliance with the License. You may obtain a copy of the License at http://www.apache.org/licenses/LICENSE-2.0 Unless required by applicable law or agreed to in writing, software distributed under the License is distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the License for the specific language governing permissions and limitations under the License. All code until 0.416 is licensed 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 List-MoreUtils-0.430/t/LICENSE0000644000175000017500000002613513735543465014032 0ustar snosno Apache License Version 2.0, January 2004 http://www.apache.org/licenses/ TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION 1. Definitions. "License" shall mean the terms and conditions for use, reproduction, and distribution as defined by Sections 1 through 9 of this document. "Licensor" shall mean the copyright owner or entity authorized by the copyright owner that is granting the License. "Legal Entity" shall mean the union of the acting entity and all other entities that control, are controlled by, or are under common control with that entity. For the purposes of this definition, "control" means (i) the power, direct or indirect, to cause the direction or management of such entity, whether by contract or otherwise, or (ii) ownership of fifty percent (50%) or more of the outstanding shares, or (iii) beneficial ownership of such entity. "You" (or "Your") shall mean an individual or Legal Entity exercising permissions granted by this License. "Source" form shall mean the preferred form for making modifications, including but not limited to software source code, documentation source, and configuration files. "Object" form shall mean any form resulting from mechanical transformation or translation of a Source form, including but not limited to compiled object code, generated documentation, and conversions to other media types. "Work" shall mean the work of authorship, whether in Source or Object form, made available under the License, as indicated by a copyright notice that is included in or attached to the work (an example is provided in the Appendix below). "Derivative Works" shall mean any work, whether in Source or Object form, that is based on (or derived from) the Work and for which the editorial revisions, annotations, elaborations, or other modifications represent, as a whole, an original work of authorship. For the purposes of this License, Derivative Works shall not include works that remain separable from, or merely link (or bind by name) to the interfaces of, the Work and Derivative Works thereof. "Contribution" shall mean any work of authorship, including the original version of the Work and any modifications or additions to that Work or Derivative Works thereof, that is intentionally submitted to Licensor for inclusion in the Work by the copyright owner or by an individual or Legal Entity authorized to submit on behalf of the copyright owner. For the purposes of this definition, "submitted" means any form of electronic, verbal, or written communication sent to the Licensor or its representatives, including but not limited to communication on electronic mailing lists, source code control systems, and issue tracking systems that are managed by, or on behalf of, the Licensor for the purpose of discussing and improving the Work, but excluding communication that is conspicuously marked or otherwise designated in writing by the copyright owner as "Not a Contribution." "Contributor" shall mean Licensor and any individual or Legal Entity on behalf of whom a Contribution has been received by Licensor and subsequently incorporated within the Work. 2. Grant of Copyright License. Subject to the terms and conditions of this License, each Contributor hereby grants to You a perpetual, worldwide, non-exclusive, no-charge, royalty-free, irrevocable copyright license to reproduce, prepare Derivative Works of, publicly display, publicly perform, sublicense, and distribute the Work and such Derivative Works in Source or Object form. 3. Grant of Patent License. Subject to the terms and conditions of this License, each Contributor hereby grants to You a perpetual, worldwide, non-exclusive, no-charge, royalty-free, irrevocable (except as stated in this section) patent license to make, have made, use, offer to sell, sell, import, and otherwise transfer the Work, where such license applies only to those patent claims licensable by such Contributor that are necessarily infringed by their Contribution(s) alone or by combination of their Contribution(s) with the Work to which such Contribution(s) was submitted. If You institute patent litigation against any entity (including a cross-claim or counterclaim in a lawsuit) alleging that the Work or a Contribution incorporated within the Work constitutes direct or contributory patent infringement, then any patent licenses granted to You under this License for that Work shall terminate as of the date such litigation is filed. 4. Redistribution. You may reproduce and distribute copies of the Work or Derivative Works thereof in any medium, with or without modifications, and in Source or Object form, provided that You meet the following conditions: (a) You must give any other recipients of the Work or Derivative Works a copy of this License; and (b) You must cause any modified files to carry prominent notices stating that You changed the files; and (c) You must retain, in the Source form of any Derivative Works that You distribute, all copyright, patent, trademark, and attribution notices from the Source form of the Work, excluding those notices that do not pertain to any part of the Derivative Works; and (d) If the Work includes a "NOTICE" text file as part of its distribution, then any Derivative Works that You distribute must include a readable copy of the attribution notices contained within such NOTICE file, excluding those notices that do not pertain to any part of the Derivative Works, in at least one of the following places: within a NOTICE text file distributed as part of the Derivative Works; within the Source form or documentation, if provided along with the Derivative Works; or, within a display generated by the Derivative Works, if and wherever such third-party notices normally appear. The contents of the NOTICE file are for informational purposes only and do not modify the License. You may add Your own attribution notices within Derivative Works that You distribute, alongside or as an addendum to the NOTICE text from the Work, provided that such additional attribution notices cannot be construed as modifying the License. You may add Your own copyright statement to Your modifications and may provide additional or different license terms and conditions for use, reproduction, or distribution of Your modifications, or for any such Derivative Works as a whole, provided Your use, reproduction, and distribution of the Work otherwise complies with the conditions stated in this License. 5. Submission of Contributions. Unless You explicitly state otherwise, any Contribution intentionally submitted for inclusion in the Work by You to the Licensor shall be under the terms and conditions of this License, without any additional terms or conditions. Notwithstanding the above, nothing herein shall supersede or modify the terms of any separate license agreement you may have executed with Licensor regarding such Contributions. 6. Trademarks. This License does not grant permission to use the trade names, trademarks, service marks, or product names of the Licensor, except as required for reasonable and customary use in describing the origin of the Work and reproducing the content of the NOTICE file. 7. Disclaimer of Warranty. Unless required by applicable law or agreed to in writing, Licensor provides the Work (and each Contributor provides its Contributions) on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied, including, without limitation, any warranties or conditions of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A PARTICULAR PURPOSE. You are solely responsible for determining the appropriateness of using or redistributing the Work and assume any risks associated with Your exercise of permissions under this License. 8. Limitation of Liability. In no event and under no legal theory, whether in tort (including negligence), contract, or otherwise, unless required by applicable law (such as deliberate and grossly negligent acts) or agreed to in writing, shall any Contributor be liable to You for damages, including any direct, indirect, special, incidental, or consequential damages of any character arising as a result of this License or out of the use or inability to use the Work (including but not limited to damages for loss of goodwill, work stoppage, computer failure or malfunction, or any and all other commercial damages or losses), even if such Contributor has been advised of the possibility of such damages. 9. Accepting Warranty or Additional Liability. While redistributing the Work or Derivative Works thereof, You may choose to offer, and charge a fee for, acceptance of support, warranty, indemnity, or other liability obligations and/or rights consistent with this License. However, in accepting such obligations, You may act only on Your own behalf and on Your sole responsibility, not on behalf of any other Contributor, and only if You agree to indemnify, defend, and hold each Contributor harmless for any liability incurred by, or claims asserted against, such Contributor by reason of your accepting any such warranty or additional liability. END OF TERMS AND CONDITIONS APPENDIX: How to apply the Apache License to your work. To apply the Apache License to your work, attach the following boilerplate notice, with the fields enclosed by brackets "{}" replaced with your own identifying information. (Don't include the brackets!) The text should be enclosed in the appropriate comment syntax for the file format. We also recommend that a file or class name and description of purpose be included on the same "printed page" as the copyright notice for easier identification within third-party archives. Copyright {yyyy} {name of copyright owner} Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in compliance with the License. You may obtain a copy of the License at http://www.apache.org/licenses/LICENSE-2.0 Unless required by applicable law or agreed to in writing, software distributed under the License is distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the License for the specific language governing permissions and limitations under the License. List-MoreUtils-0.430/t/inline/0000755000175000017500000000000013744044757014274 5ustar snosnoList-MoreUtils-0.430/t/inline/zip6.pm0000644000175000017500000000204613735543465015524 0ustar snosno use Test::More; use Test::LMU; SCOPE: { my @x = qw/a b c d/; my @y = qw/1 2 3 4/; my @z = zip6 @x, @y; is_deeply(\@z, [['a', 1], ['b', 2], ['c', 3], ['d', 4]], "zip6 two lists with same count of elements"); } SCOPE: { my @a = ('x'); my @b = ('1', '2'); my @c = qw/zip zap zot/; my @z = zip6 @a, @b, @c; is_deeply( \@z, [['x', 1, 'zip'], [undef, 2, 'zap'], [undef, undef, 'zot']], "zip6 three list with increasing count of elements" ); } # Make array with holes SCOPE: { my @a = (1 .. 10); my @d; $#d = 9; my @z = zip6 @a, @d; is_deeply( \@z, [[1, undef], [2, undef], [3, undef], [4, undef], [5, undef], [6, undef], [7, undef], [8, undef], [9, undef], [10, undef]], "zip6 one list with 9 elements with an empty list" ); } leak_free_ok( zip6 => sub { my @x = qw/a b c d e/; my @y = qw/1 2 3 4/; my @z = zip6 @x, @y; } ); is_dying('zip6 with a list, not at least two arrays' => sub { &zip6(1, 2); }); done_testing; List-MoreUtils-0.430/t/inline/insert_after.pm0000644000175000017500000000221213736561312017304 0ustar snosno use Test::More; use Test::LMU; my @list = qw{This is a list}; insert_after { $_ eq "a" } "longer" => @list; is(join(' ', @list), "This is a longer list"); insert_after { 0 } "bla" => @list; is(join(' ', @list), "This is a longer list"); insert_after { $_ eq "list" } "!" => @list; is(join(' ', @list), "This is a longer list !"); @list = (qw{This is}, undef, qw{list}); insert_after { not defined($_) } "longer" => @list; $list[2] = "a"; is(join(' ', @list), "This is a longer list"); leak_free_ok( insert_after => sub { @list = qw{This is a list}; insert_after { $_ eq 'a' } "longer" => @list; } ); leak_free_ok( 'insert_after with exception' => sub { eval { my @list = (qw{This is}, DieOnStringify->new, qw{a list}); insert_after { $_ eq 'a' } "longer" => @list; }; } ); is_dying('insert_after without sub' => sub { &insert_after(42, 4711, [qw(die bart die)]); }); is_dying('insert_after without sub and array' => sub { &insert_after(42, 4711, "13"); }); is_dying( 'insert_after without array' => sub { &insert_after(sub { }, 4711, "13"); } ); done_testing; List-MoreUtils-0.430/t/inline/reduce_1.pm0000644000175000017500000000200613736561312016307 0ustar snosno use Test::More; use Test::LMU; use Scalar::Util qw(looks_like_number); # (this code shamelessly stolen from Math::Complex's t/Trig.t, with some mods to near) from BBYRD in RT#72638 and taken from SQL-Statement now use Math::Trig; my $eps = 1e-11; if ($^O eq 'unicos') { # See lib/Math/Complex.pm and t/lib/complex.t. $eps = 1e-10; } sub near ($$$;$) { my $d = $_[1] ? abs($_[0] / $_[1] - 1) : abs($_[0]); local $Test::Builder::Level = $Test::Builder::Level + 1; looks_like_number($_[0]) or return cmp_ok($_[0], "eq", $_[1], "near? $_[0] ~= $_[1]"); $_[0] =~ m/nan/i and return cmp_ok($_[0], "eq", $_[1], "near? $_[0] ~= $_[1]"); $_[0] =~ m/inf/i and return cmp_ok($_[0], "eq", $_[1], "near? $_[0] ~= $_[1]"); my $e = defined $_[3] ? $_[3] : $eps; cmp_ok($d, '<', $e, "$_[2] => near? $_[0] ~= $_[1]") or diag("near? $_[0] ~= $_[1]"); } my $half_pi = reduce_1 { $a * ((4 * $b * $b) / ((2 * $b - 1) * (2 * $b + 1))) } 1 .. 750; near($half_pi, pi / 2, "Wallis product", 1e-2); done_testing; List-MoreUtils-0.430/t/inline/false.pm0000644000175000017500000000112413736561312015712 0ustar snosno use Test::More; use Test::LMU; # The null set should return zero my $null_scalar = false {}; my @null_list = false {}; is($null_scalar, 0, 'false(null) returns undef'); is_deeply(\@null_list, [0], 'false(null) returns undef'); # Normal cases my @list = (1 .. 10000); is(10000, false { not defined } @list); is(0, false { defined } @list); is(1, false { $_ > 1 } @list); leak_free_ok( false => sub { my $n = false { $_ == 5000 } @list; my $n2 = false { $_ == 5000 } 1 .. 10000; } ); is_dying('false without sub' => sub { &false(42, 4711); }); done_testing; List-MoreUtils-0.430/t/inline/bremove.pm0000644000175000017500000000565113736561312016270 0ustar snosno use Test::More; use Test::LMU; my @even = map { $_ * 2 } 1 .. 100; my @odd = map { $_ * 2 - 1 } 1 .. 100; my (@expected, @in); @expected = @even; @in = mesh @odd, @even; foreach my $v (@odd) { is($v, (bremove { $_ <=> $v } @in), "$v in order removed"); } is_deeply(\@in, \@expected, "bremove all odd elements succeeded"); @in = mesh @odd, @even; foreach my $v (reverse @odd) { is($v, (bremove { $_ <=> $v } @in), "$v reverse ordered removed"); } is_deeply(\@in, \@expected, "bremove all odd elements reversely succeeded"); @expected = @odd; @in = mesh @odd, @even; foreach my $v (@even) { is($v, (bremove { $_ <=> $v } @in), "$v in order removed"); } is_deeply(\@in, \@expected, "bremove all even elements succeeded"); @in = mesh @odd, @even; foreach my $v (reverse @even) { is($v, (bremove { $_ <=> $v } @in), "$v reverse ordered removed"); } is_deeply(\@in, \@expected, "bremove all even elements reversely succeeded"); # test from shawnlaffan from GH issue #2 of List-MoreUtils-XS SCOPE: { my @list = ('somestring'); my $target = $list[0]; is($target, (bremove { $_ cmp $target } @list), 'removed from single item list'); } leak_free_ok( 'bremove first' => sub { my @list = (1 .. 100); my $v = $list[0]; bremove { $_ <=> $v } @list; }, 'bremove last' => sub { my @list = (1 .. 100); my $v = $list[-1]; bremove { $_ <=> $v } @list; }, 'bremove middle' => sub { my @list = (1 .. 100); my $v = $list[int($#list / 2)]; bremove { $_ <=> $v } @list; }, ); leak_free_ok( 'bremove first with stack-growing' => sub { my @list = mesh @odd, @even; my $v = $list[0]; bremove { grow_stack(); $_ <=> $v } @list; }, 'bremove last with stack-growing' => sub { my @list = mesh @odd, @even; my $v = $list[-1]; bremove { grow_stack(); $_ <=> $v } @list; }, 'bremove middle with stack-growing' => sub { my @list = mesh @odd, @even; my $v = $list[int($#list / 2)]; bremove { grow_stack(); $_ <=> $v } @list; }, ); leak_free_ok( 'bremove first with stack-growing and exception' => sub { my @list = mesh @odd, @even; my $v = $list[0]; eval { bremove { grow_stack(); $_ <=> $v or die "Goal!"; $_ <=> $v } @list; }; }, 'bremove last with stack-growing and exception' => sub { my @list = mesh @odd, @even; my $v = $list[-1]; eval { bremove { grow_stack(); $_ <=> $v or die "Goal!"; $_ <=> $v } @list; }; }, 'bremove middle with stack-growing and exception' => sub { my @list = mesh @odd, @even; my $v = $list[int($#list / 2)]; eval { bremove { grow_stack(); $_ <=> $v or die "Goal!"; $_ <=> $v } @list; }; }, ); is_dying('bremove without sub' => sub { &bremove(42, @even); }); done_testing; List-MoreUtils-0.430/t/inline/arrayify.pm0000644000175000017500000000617713736561312016463 0ustar snosno use Test::More; use Test::LMU; use Tie::Array (); SCOPE: { my @in = (1 .. 4, [5 .. 7], 8 .. 11, [[12 .. 17]], 18); my @out = arrayify @in; is_deeply(\@out, [1 .. 18], "linear flattened int mix i"); } SCOPE: { my @in = (1 .. 4, [[5 .. 11]], 12, [[13 .. 17]]); my @out = arrayify @in; is_deeply(\@out, [1 .. 17], "linear flattened int mix ii"); } SCOPE: { # typical structure when parsing XML using XML::Hash::XS my %src = ( root => { foo_list => {foo_elem => {attr => 42}}, bar_list => {bar_elem => [{hummel => 2}, {hummel => 3}, {hummel => 5}]} } ); my @foo_elems = arrayify $src{root}->{foo_list}->{foo_elem}; is_deeply(\@foo_elems, [{attr => 42}], "arrayified struct with one element"); my @bar_elems = arrayify $src{root}->{bar_list}->{bar_elem}; is_deeply(\@bar_elems, [{hummel => 2}, {hummel => 3}, {hummel => 5}], "arrayified struct with three elements"); } SCOPE: { my @in; tie @in, "Tie::StdArray"; @in = (1 .. 4, [5 .. 7], 8 .. 11, [[12 .. 17]]); my @out = arrayify @in; is_deeply(\@out, [1 .. 17], "linear flattened magic int mix"); } SCOPE: { my (@in, @inner, @innest); tie @in, "Tie::StdArray"; tie @inner, "Tie::StdArray"; tie @innest, "Tie::StdArray"; @inner = (5 .. 7); @innest = ([12 .. 17]); @in = (1 .. 4, \@inner, 8 .. 11, [@innest]); my @out = arrayify @in; is_deeply(\@out, [1 .. 17], "linear flattened magic int mixture"); } SCOPE: { my @in = (qw(av_make av_undef av_clear), [qw(av_push av_pop)], qw(av_fetch av_store), [['av_shift'], ['av_unshift']]); my @out = arrayify @in; is_deeply( \@out, [qw(av_make av_undef av_clear av_push av_pop av_fetch av_store av_shift av_unshift)], "linear flattened string mix i" ); } leak_free_ok( arrayify => sub { my @in = (1 .. 4, [5 .. 7], 8 .. 11, [[12 .. 17]]); my @out = arrayify @in; }, 'arrayify magic' => sub { my (@in, @inner, @innest); tie @in, "Tie::StdArray"; tie @inner, "Tie::StdArray"; tie @innest, "Tie::StdArray"; @inner = (5 .. 7); @innest = ([12 .. 17]); @in = (1 .. 4, \@inner, 8 .. 11, [@innest]); my @out = arrayify @in; } ); SKIP: { leak_free_ok( 'arrayify with exception in overloading stringify at begin' => sub { my @in = ( DieOnStringify->new, qw(av_make av_undef av_clear), [qw(av_push av_pop)], qw(av_fetch av_store), [['av_shift'], ['av_unshift']] ); eval { my @out = arrayify @in; }; diag($@) if ($@); }, ); leak_free_ok( 'arrayify with exception in overloading stringify at end' => sub { my @in = ( qw(av_make av_undef av_clear), [qw(av_push av_pop)], qw(av_fetch av_store), [['av_shift'], ['av_unshift']], DieOnStringify->new ); eval { my @out = arrayify @in; }; diag($@) if ($@); } ); } done_testing; List-MoreUtils-0.430/t/inline/bsearchidx.pm0000644000175000017500000000153413736561312016741 0ustar snosno use Test::More; use Test::LMU; my @list = my @in = 1 .. 1000; for my $i (0 .. $#in) { is($i, bsearchidx { $_ - $in[$i] } @list); } my @out = (-10 .. 0, 1001 .. 1011); for my $elem (@out) { my $r = bsearchidx { $_ - $elem } @list; is(-1, $r); } leak_free_ok( bsearch => sub { my $elem = int(rand(1000)) + 1; bsearchidx { $_ - $elem } @list; } ); leak_free_ok( 'bsearch with stack-growing' => sub { my $elem = int(rand(1000)); bsearchidx { grow_stack(); $_ - $elem } @list; } ); leak_free_ok( 'bsearch with stack-growing and exception' => sub { my $elem = int(rand(1000)); eval { bsearchidx { grow_stack(); $_ - $elem or die "Goal!"; $_ - $elem } @list; }; } ); is_dying('bsearchidx without sub' => sub { &bsearchidx(42, (1 .. 100)); }); done_testing; List-MoreUtils-0.430/t/inline/bsearch.pm0000644000175000017500000000166713736561312016243 0ustar snosno use Test::More; use Test::LMU; my @list = my @in = 1 .. 1000; for my $elem (@in) { ok(scalar bsearch { $_ - $elem } @list); } for my $elem (@in) { my ($e) = bsearch { $_ - $elem } @list; ok($e == $elem); } my @out = (-10 .. 0, 1001 .. 1011); for my $elem (@out) { my $r = bsearch { $_ - $elem } @list; ok(!defined $r); } leak_free_ok( bsearch => sub { my $elem = int(rand(1000)) + 1; scalar bsearch { $_ - $elem } @list; } ); leak_free_ok( 'bsearch with stack-growing' => sub { my $elem = int(rand(1000)); scalar bsearch { grow_stack(); $_ - $elem } @list; } ); leak_free_ok( 'bsearch with stack-growing and exception' => sub { my $elem = int(rand(1000)); eval { scalar bsearch { grow_stack(); $_ - $elem or die "Goal!"; $_ - $elem } @list; }; } ); is_dying('bsearch without sub' => sub { &bsearch(42, (1 .. 100)); }); done_testing; List-MoreUtils-0.430/t/inline/qsort.pm0000644000175000017500000000064113736561312015773 0ustar snosno use Test::More; use Test::LMU; plan skip_all => "It's insane to use a pure-perl qsort" unless $INC{'List/MoreUtils/XS.pm'}; my @ltn_asc = qw(2 3 5 7 11 13 17 19 23 29 31 37); my @ltn_des = reverse @ltn_asc; my @l; @l = @ltn_des; qsort sub { $a <=> $b }, @l; is_deeply(\@l, \@ltn_asc, "sorted ascending"); @l = @ltn_asc; qsort sub { $b <=> $a }, @l; is_deeply(\@l, \@ltn_des, "sorted descending"); done_testing; List-MoreUtils-0.430/t/inline/notall_u.pm0000644000175000017500000000067613736561312016450 0ustar snosno use Test::More; use Test::LMU; # Normal cases my @list = (1 .. 10000); is_true(notall_u { !defined } @list); is_true(notall_u { $_ < 10000 } @list); is_false(notall_u { $_ <= 10000 } @list); is_undef(notall_u {}); leak_free_ok( notall_u => sub { my $ok = notall_u { $_ == 5000 } @list; my $ok2 = notall_u { $_ == 5000 } 1 .. 10000; } ); is_dying('notall_u without sub' => sub { ¬all_u(42, 4711); }); done_testing; List-MoreUtils-0.430/t/inline/samples.pm0000644000175000017500000000170213735543525016273 0ustar snosno use Test::More; use Test::LMU; SCOPE: { my @l = (1 .. 100); my @s = samples 10, @l; is(scalar @s, 10, "samples stops correctly after 10 integer probes"); my @u = uniq @s; is(scalar @u, 10, "samples doesn't add any integer twice"); } SCOPE: { my @l = (1 .. 10); my @s = samples 10, @l; is(scalar @s, 10, "samples delivers 10 out of 10 when used as shuffle"); my @u = uniq grep { defined $_ } @s; is(scalar @u, 10, "samples doesn't add any integer twice"); } SCOPE: { my @l = ('AA' .. 'ZZ'); my @s = samples 10, @l; is(scalar @s, 10, "samples stops correctly after 10 strings probes"); my @u = uniq @s; is(scalar @u, 10, "samples doesn't add any string twice"); } is_dying('to much samples' => sub { my @l = (1 .. 3); samples 5, @l }); SKIP: { $INC{'List/MoreUtils/XS.pm'} or skip "PurePerl will not fail here ...", 1; is_dying('samples without list' => sub { samples 5 }); } done_testing; List-MoreUtils-0.430/t/inline/reduce_0.pm0000644000175000017500000000165213736561312016314 0ustar snosno use Test::More; use Test::LMU; use List::Util qw(sum); SCOPE: { my @exam_results = (2, 4, 6, 5, 3, 0); my $pupil = sum @exam_results; my $wa = reduce_0 { $a + ($_ + 1) * $b / $pupil } @exam_results; $wa = sprintf("%0.2f", $wa); is($wa, 3.15, "weighted average of exam"); } leak_free_ok( 'reduce_0' => sub { my @exam_results = (2, 4, 6, 5, 3, 0); my $pupil = 20; my $wa = reduce_0 { $a + ($_ + 1) * $b / $pupil } @exam_results; }, 'reduce_0 X' => sub { my @w = map { int(rand(5)) + 1; } 1 .. 100; my $c1 = reduce_0 { $a + $w[$_] * $b } 1 .. 100; } ); leak_free_ok( 'reduce_0 with a coderef that dies' => sub { # This test is from Kevin Ryde; see RT#48669 eval { my $ok = reduce_0 { die } 1; }; } ); is_dying('reduce_0 without sub' => sub { &reduce_0(42, 4711); }); done_testing List-MoreUtils-0.430/t/inline/duplicates.pm0000644000175000017500000000670613736561312016770 0ustar snosno use Test::More; use Test::LMU; use Tie::Array (); SCOPE: { my @s = (1001 .. 1200); my @d = (1 .. 1000); my @a = (@d, @s, @d); my $fa = freeze(\@a); my @u = duplicates @a; is($fa, freeze(\@a), "duplicates:G_ARRAY leaves numbers untouched"); is_deeply(\@u, [@d], "duplicates of numbers"); my $u = duplicates @a; is($fa, freeze(\@a), "duplicates:G_SCALAR leaves numbers untouched"); is(scalar @d, $u, "scalar result of duplicates of numbers"); } # Test strings SCOPE: { my @s = ("AA" .. "ZZ"); my @d = ("aa" .. "zz"); my @a = (@d, @s, @d); my $fa = freeze(\@a); my @u = duplicates @a; is($fa, freeze(\@a), "duplicates:G_ARRAY leaves numbers untouched"); is_deeply(\@u, [@d], "duplicates of numbers"); my $u = duplicates @a; is($fa, freeze(\@a), "duplicates:G_SCALAR leaves numbers untouched"); is(scalar @d, $u, "scalar result of duplicates of numbers"); } # Test mixing strings and numbers SCOPE: { my @s = (1001 .. 1200, "AA" .. "ZZ"); my @d = (1 .. 1000, "aa" .. "zz"); my $fd = freeze(\@d); my @a = (@d, @s, @d); my $fa = freeze(\@a); my @u = duplicates map { $_ } @a; my $fu = freeze(\@u); is_deeply(\@u, [@d], "duplicates of numbers/strings mixture"); is($fd, freeze(\@d), "frozen duplicates of numbers/strings mixture"); is($fa, freeze(\@a), "duplicates:G_ARRAY leaves mixture untouched"); is($fu, $fd); my $u = duplicates @a; is($fa, freeze(\@a), "duplicates:G_SCALAR leaves mixture untouched"); is(scalar @d, $u, "scalar result of duplicates of numbers/strings mixture"); } SCOPE: { my @a; tie @a, "Tie::StdArray"; my @s = (1001 .. 1200, "AA" .. "ZZ"); my @d = (1 .. 1000, "aa" .. "zz"); @a = (@d, @s, @d); my $fa = freeze(\@a); my @u = duplicates @a; is_deeply(\@u, [@d], "duplicates of tied array of numbers/strings mixture"); is($fa, freeze(\@a), "duplicates:G_ARRAY leaves mixture untouched"); @a = (@u, @d); $fa = freeze(\@a); my $u = duplicates @a; is($fa, freeze(\@a), "duplicates:G_SCALAR leaves mixture untouched"); is(scalar @d, $u, "scalar result of duplicates of tied array of numbers/strings mixture"); } SCOPE: { my @foo = ('a', 'b', '', undef, 'b', 'c', '', undef); my @dfoo = ('b', '', undef); is_deeply([duplicates @foo], \@dfoo, "two undef's are supported correctly by duplicates"); @foo = ('a', undef, 'b', '', 'b', 'c', ''); @dfoo = ('b', ''); is_deeply([duplicates @foo], \@dfoo, 'one undef is ignored correctly by duplicates'); is((scalar duplicates @foo), scalar @dfoo, 'scalar one undef is ignored correctly by duplicates'); } leak_free_ok( duplicates => sub { my @s = (1001 .. 1200, "AA" .. "ZZ"); my @d = map { (1 .. 1000, "aa" .. "zz") } 0 .. 1; my @a = (@d, @s); my @u = duplicates @a; scalar duplicates @a; } ); # This test (and the associated fix) are from Kevin Ryde; see RT#49796 leak_free_ok( 'duplicates with exception in overloading stringify', sub { eval { my $obj = DieOnStringify->new; my @foo = ('a', 'b', '', undef, $obj, 'b', 'c', '', undef, $obj); my @u = duplicates @foo; }; eval { my $obj = DieOnStringify->new; my $u = duplicates 'a', 'b', '', undef, $obj, 'b', 'c', '', undef, $obj; }; } ); done_testing; List-MoreUtils-0.430/t/inline/mode.pm0000644000175000017500000003770613736561312015563 0ustar snosno use Test::More; use Test::LMU; use Tie::Array (); SCOPE: { my $lorem = "Lorem ipsum dolor sit amet, consetetur sadipscing elitr, sed diam nonumy eirmod tempor invidunt ut labore et dolore magna aliquyam erat, sed diam voluptua. At vero eos et accusam et justo duo dolores et ea rebum. Stet clita kasd gubergren, no sea takimata sanctus est Lorem ipsum dolor sit amet. Lorem ipsum dolor sit amet, consetetur sadipscing elitr, sed diam nonumy eirmod tempor invidunt ut labore et dolore magna aliquyam erat, sed diam voluptua. At vero eos et accusam et justo duo dolores et ea rebum. Stet clita kasd gubergren, no sea takimata sanctus est Lorem ipsum dolor sit amet. Lorem ipsum dolor sit amet, consetetur sadipscing elitr, sed diam nonumy eirmod tempor invidunt ut labore et dolore magna aliquyam erat, sed diam voluptua."; my @lorem = grep { $_ } split /(?:\b|\s)/, $lorem; my $fl = freeze(\@lorem); my $n_comma = scalar(split /,/, $lorem) - 1; my @m = mode @lorem; is($fl, freeze(\@lorem), "mode:G_ARRAY lorem untouched"); is_deeply([$n_comma, ','], \@m, "lorem mode as list"); my $m = mode @lorem; is($fl, freeze(\@lorem), "mode:G_SCALAR lorem untouched"); is($n_comma, $m, "lorem mode as scalar"); } SCOPE: { my @probes = ((1) x 3, (2) x 4, (3) x 2, (4) x 7, (5) x 2, (6) x 4); my $fp = freeze(\@probes); my @m = mode @probes; is($fp, freeze(\@probes), "mode:G_ARRAY probes untouched"); is_deeply([7, 4], \@m, "unimodal result in list context"); my $m = mode @probes; is($fp, freeze(\@probes), "mode:G_SCALAR probes untouched"); is(7, $m, "unimodal result in scalar context"); } SCOPE: { my @probes = ((1) x 3, (2) x 4, (3) x 2, (4) x 7, (5) x 2, (6) x 4, (7) x 3, (8) x 7); my $fp = freeze(\@probes); my @m = mode @probes; is($fp, freeze(\@probes), "bimodal mode:G_ARRAY probes untouched"); my $m = shift @m; @m = sort @m; unshift @m, $m; is_deeply([7, 4, 8], \@m, "bimodal result in list context"); $m = mode @probes; is($fp, freeze(\@probes), "bimodal mode:G_SCALAR probes untouched"); is(7, $m, "bimodal result in scalar context"); } SCOPE: { my %radio_ukw_nrw = ( "87,6" => "WDR Eins Live", "87,7" => "WDR 5", "87,7" => "Welle Niederrhein", "87,7" => "WDR 5", "87,8" => "Welle West", "87,8" => "WDR 4", "87,8" => "WDR 2 Dortmund", "87,9" => "Radio HERTZ", "88,0" => "WDR 5", "88,1" => "Radio Hochstift", "88,2" => "Radio Kiepenkerl", "88,2" => "Radio Siegen", "88,3" => "WDR 5", "88,3" => "Radio MK", "88,4" => "WDR 2 Köln", "88,4" => "Radio WMW", "88,4" => "WDR 5", "88,5" => "WDR 5", "88,5" => "Werrepark Radio", "88,5" => "WDR 5", "88,6" => "WDR 5", "88,7" => "WDR 3", "88,8" => "WDR 5", "88,9" => "Deutschlandradio Kultur", "89,0" => "Lokalradio Olpe", "89,1" => "Deutschlandfunk (DLF)", "89,1" => "Radio Sauerland", "89,2" => "WDR (Test)", "89,3" => "Antenne Unna", "89,4" => "NE-WS 89,4", "89,4" => "L`UniCo FM", "89,6" => "WDR 5", "89,7" => "WDR 3", "90,0" => "CT das radio", "90,0" => "WDR 5", "90,1" => "WDR 4", "90,1" => "Deutschlandradio Kultur", "90,1" => "Radio 90,1", "90,3" => "WDR 5", "90,6" => "WDR 5", "90,7" => "WDR 4", "90,8" => "Radio Herne", "90,8" => "Radio MK", "90,9" => "Radio Q", "91,0" => "Deutschlandradio Kultur", "91,0" => "Deutschlandfunk (DLF)", "91,2" => "WDR (Test)", "91,2" => "Radio 91,2", "91,2" => "Radio Bonn/Rhein-Sieg", "91,3" => "Radio Lippe (geplant)", "91,3" => "Deutschlandfunk (DLF)", "91,3" => "BFBS Radio 1", "91,4" => "Radio Erft", "91,5" => "Radio MK", "91,5" => "Deutschlandfunk (DLF)", "91,5" => "Radio Ennepe Ruhr", "91,7" => "WDR 4", "91,7" => "BFBS Radio 2", "91,7" => "WDR 3", "91,7" => "Radio K.W.", "91,7" => "Radio Herford", "91,8" => "WDR 2 Wuppertal", "91,8" => "WDR 2 Bielefeld", "91,9" => "WDR 4", "92,0" => "WDR 5", "92,0" => "domradio", "92,1" => "Radius 92,1", "92,2" => "Radio Duisburg", "92,2" => "Deutschlandfunk (DLF)", "92,2" => "Radio RSG", "92,3" => "WDR 2 Siegen", "92,5" => "BFBS Radio 1", "92,5" => "Radio MK", "92,6" => "Radio WAF", "92,7" => "WDR 3", "92,7" => "Radio Rur", "92,7" => "Radio Ennepe Ruhr", "92,9" => "Radio Mülheim", "93,0" => "Radio WMW", "93,0" => "elDOradio", "93,1" => "WDR 3", "93,2" => "WDR 2 Bielefeld", "93,3" => "WDR 2 Rhein-Ruhr", "93,5" => "WDR 2 Siegen", "93,6" => "WDR Eins Live", "93,7" => "Radio Hochstift", "93,8" => "WDR 2 Siegen", "93,9" => "WDR 4", "93,9" => "Deutschlandfunk (DLF)", "93,9" => "WDR 5", "94,1" => "WDR 2 Münster", "94,2" => "Radio Bonn/Rhein-Sieg", "94,2" => "WDR 2 Aachen", "94,2" => "Deutschlandfunk (DLF)", "94,3" => "Antenne Bethel", "94,3" => "Radio RSG", "94,3" => "WDR 3", "94,5" => "Deutschlandfunk (DLF)", "94,6" => "Radio MK", "94,6" => "Test FM", "94,6" => "Deutschlandradio Kultur", "94,6" => "Radio Vest", "94,7" => "Radio FH", "94,7" => "Radio WAF", "94,8" => "WDR (Test)", "94,8" => "Radio Sauerland", "94,9" => "Radio Herford", "95,1" => "WDR 3", "95,1" => "Radio Westfalica", "95,2" => "WDR 3", "95,4" => "Antenne Münster", "95,5" => "Deutschlandfunk (DLF)", "95,6" => "Radio Vest", "95,7" => "Radio WAF", "95,7" => "Radio Westfalica", "95,7" => "WDR 2 Wuppertal", "95,8" => "WDR 5", "95,9" => "WDR 3", "95,9" => "Triquency", "95,9" => "Radio Gütersloh", "96,0" => "WDR Eins Live", "96,0" => "WDR 2 Münster", "96,0" => "WDR 2 Bielefeld", "96,1" => "Radio Emscher Lippe", "96,1" => "WDR 4", "96,1" => "Triquency", "96,2" => "Radio Sauerland", "96,3" => "WDR 3", "96,3" => "Radio WAF", "96,3" => "Deutschlandradio Kultur", "96,4" => "Radio Siegen (geplant)", "96,4" => "WDR 2 Bielefeld", "96,5" => "Deutschlandradio Kultur", "96,8" => "bonn FM", "96,9" => "Deutschlandradio Kultur", "96,9" => "Radio Berg", "97,0" => "WDR 3", "97,1" => "Antenne GL", "97,1" => "Hochschulradio Düsseldorf", "97,1" => "WDR 2 Siegen", "97,2" => "107.8 Antenne AC", "97,2" => "Radio MK", "97,3" => "Radio Siegen", "97,3" => "WDR 3", "97,3" => "WDR 3", "97,4" => "Antenne Unna", "97,5" => "WDR 3", "97,5" => "Deutschlandradio Kultur", "97,6" => "Radio WMW", "97,6" => "WDR (Test)", "97,6" => "Radio Bielefeld", "97,6" => "Radio Neandertal", "97,6" => "WDR 5", "97,7" => "Deutschlandradio Kultur", "97,8" => "Radio Bonn/Rhein-Sieg", "97,8" => "WDR 3", "98,0" => "Antenne Niederrhein", "98,1" => "WDR 3", "98,2" => "WDR 3", "98,2" => "WDR Eins Live", "98,3" => "Radio Bielefeld", "98,4" => "WDR 3", "98,5" => "Radio Bochum", "98,6" => "WDR 2 + Messeradio Köln", "98,6" => "WDR 5", "98,7" => "Radio Emscher Lippe", "98,9" => "Deutschlandradio Kultur", "98,9" => "Lokalradio Olpe", "98,9" => "Radio Siegen", "99,1" => "Hochschulradio Aachen", "99,1" => "WDR 2 Bielefeld", "99,2" => "WDR 2 Rhein-Ruhr", "99,4" => "WDR 2 Siegen", "99,4" => "Triquency", "99,5" => "WDR 4", "99,5" => "Radio MK", "99,6" => "WDR 4", "99,7" => "Radio Euskirchen", "99,7" => "WDR 5", "99,7" => "Radio Berg", "99,7" => "WDR Eins Live", "99,8" => "WDR 2 Wuppertal", "99,9" => "Radio Bonn/Rhein-Sieg", "100,0" => "Kölncampus", "100,0" => "WDR 4", "100,1" => "107.8 Antenne AC", "100,1" => "WDR Eins Live", "100,2" => "Radio MK", "100,2" => "Deutschlandradio Kultur", "100,4" => "WDR 2 Köln", "100,5" => "WDR 4", "100,6" => "Welle Niederrhein", "100,7" => "WDR 4", "100,8" => "WDR 2 Aachen", "100,9" => "Hellweg Radio", "101,0" => "WDR 2 Aachen", "101,0" => "Radio Lippe", "101,1" => "WDR 4", "101,1" => "Deutschlandradio Kultur", "101,2" => "WDR 4", "101,3" => "WDR 4", "101,6" => "BFBS Radio 2", "101,7" => "WDR 4", "101,7" => "domradio", "101,8" => "WDR 2 Siegen", "101,9" => "WDR 5", "101,9" => "BFBS Radio 1", "102,1" => "NE-WS 89,4", "102,1" => "WDR 2 Siegen", "102,2" => "Radio Essen", "102,2" => "BFBS Radio 2", "102,3" => "Antenne Unna", "102,4" => "WDR Eins Live", "102,5" => "WDR Eins Live", "102,7" => "Deutschlandfunk (DLF)", "102,7" => "Deutschlandfunk (DLF)", "102,8" => "Deutschlandfunk (DLF)", "103,0" => "BFBS Radio 1", "103,3" => "Funkhaus Europa", "103,6" => "Radio WMW", "103,6" => "Hellweg Radio", "103,7" => "WDR Eins Live", "103,8" => "WDR 4", "103,9" => "Radio Q", "104,0" => "BFBS Radio 1", "104,0" => "Radio RST", "104,1" => "WDR 4", "104,2" => "Radio Bonn/Rhein-Sieg", "104,2" => "Antenne Düsseldorf", "104,2" => "Radio Ennepe Ruhr", "104,3" => "BFBS Radio 2", "104,4" => "WDR 4", "104,4" => "Deutschlandfunk (DLF)", "104,5" => "CampusFM", "104,5" => "Deutschlandfunk (DLF)", "104,5" => "WDR 4", "104,7" => "WDR Eins Live", "104,8" => "Radio Hochstift", "104,8" => "Radio Hochstift", "104,9" => "Radio Sauerland", "105,0" => "Radio Essen", "105,0" => "Radio Lippe Welle Hamm", "105,0" => "107.8 Antenne AC", "105,0" => "BFBS Radio 2", "105,1" => "BFBS Radio 1", "105,2" => "Radio Vest", "105,2" => "Radio Berg", "105,2" => "Radio RST", "105,4" => "Radio Siegen", "105,5" => "WDR Eins Live", "105,5" => "WDR Eins Live", "105,6" => "CampusFM", "105,7" => "Antenne Niederrhein", "105,7" => "Radio Ennepe Ruhr", "105,7" => "WDR Eins Live", "105,7" => "Radio Berg", "105,8" => "Radio Erft", "106,0" => "BFBS Radio 1", "106,1" => "Deutschlandradio Kultur", "106,1" => "Deutschlandradio Kultur", "106,2" => "Deutschlandradio Kultur", "106,2" => "106.2 Radio Oberhausen", "106,3" => "Radio Kiepenkerl", "106,4" => "WDR Eins Live", "106,5" => "Radio Sauerland", "106,5" => "Radio Sauerland", "106,5" => "Radio St. Laurentius", "106,6" => "Radio Lippe", "106,6" => "Radio Westfalica", "106,6" => "Deutschlandfunk (DLF)", "106,7" => "WDR Eins Live", "106,8" => "Radio Gütersloh", "106,9" => "Radio Euskirchen", "107,0" => "WDR Eins Live", "107,1" => "Radio Köln", "107,2" => "WDR Eins Live", "107,2" => "Deutschlandfunk (DLF)", "107,3" => "WDR Eins Live", "107,3" => "Hellweg Radio", "107,4" => "Radio Euskirchen", "107,4" => "Radio Kiepenkerl", "107,4" => "Radio Lippe", "107,4" => "Radio Wuppertal", "107,5" => "Radio Rur", "107,5" => "Radio Gütersloh", "107,5" => "WDR Eins Live", "107,6" => "Radio Leverkusen", "107,6" => "Radio Sauerland", "107,6" => "Radio K.W.", "107,7" => "WDR Eins Live", "107,7" => "Hellweg Radio", "107,7" => "107.7 Radio Hagen", "107,8" => "107.8 Antenne AC", "107,8" => "Lokalradio Olpe", "107,9" => "Radio Bonn/Rhein-Sieg", "107,9" => "WDR Eins Live", "107,9" => "Radio RSG", ); my @m = mode values %radio_ukw_nrw; my $m = shift @m; @m = sort @m; unshift @m, $m; is_deeply([14, 'WDR 5', 'WDR Eins Live'], \@m, "multimodal result in list context"); $m = mode values %radio_ukw_nrw; is(14, $m, "multimodal result in scalar context"); } leak_free_ok( 'mode (unimodal)' => sub { my @probes = ((1) x 3, (2) x 4, (3) x 2, (4) x 7, (5) x 2, (6) x 4); my @m = mode @probes; }, 'scalar mode (unimodal)' => sub { my @probes = ((1) x 3, (2) x 4, (3) x 2, (4) x 7, (5) x 2, (6) x 4); my $m = mode @probes; }, 'mode (bimodal)' => sub { my @probes = ((1) x 3, (2) x 4, (3) x 2, (4) x 7, (5) x 2, (6) x 4, (7) x 3, (8) x 7); my @m = mode @probes; }, 'scalar mode (bimodal)' => sub { my @probes = ((1) x 3, (2) x 4, (3) x 2, (4) x 7, (5) x 2, (6) x 4, (7) x 3, (8) x 7); my $m = mode @probes; }, 'mode (multimodal)' => sub { my @probes = ((1) x 3, (2) x 4, (3) x 2, (4) x 7, (5) x 2, (6) x 4, (7) x 3, (8) x 7, (9) x 4, (10) x 3, (11) x 7); my @m = mode @probes; }, 'scalar mode (multimodal)' => sub { my @probes = ((1) x 3, (2) x 4, (3) x 2, (4) x 7, (5) x 2, (6) x 4, (7) x 3, (8) x 7, (9) x 4, (10) x 3, (11) x 7); my $m = mode @probes; }, ); leak_free_ok( 'mode (unimodal) with exception in overloading stringify' => sub { eval { my $obj = DieOnStringify->new; my @probes = ((1) x 3, $obj, (2) x 4, $obj, (3) x 2, $obj, (4) x 7, $obj, (5) x 2, $obj, (6) x 4); my @m = mode @probes; }; }, 'scalar mode (unimodal) with exception in overloading stringify' => sub { eval { my $obj = DieOnStringify->new; my @probes = ((1) x 3, $obj, (2) x 4, $obj, (3) x 2, $obj, (4) x 7, $obj, (5) x 2, $obj, (6) x 4); my $m = mode @probes; }; }, 'mode (bimodal) with exception in overloading stringify' => sub { eval { my $obj = DieOnStringify->new; my @probes = ((1) x 3, $obj, (2) x 4, $obj, (3) x 2, $obj, (4) x 7, $obj, (5) x 2, $obj, (6) x 4, $obj, (7) x 3, $obj, (8) x 7); my @m = mode @probes; }; }, 'scalar mode (bimodal) with exception in overloading stringify' => sub { eval { my $obj = DieOnStringify->new; my @probes = ((1) x 3, $obj, (2) x 4, $obj, (3) x 2, $obj, (4) x 7, $obj, (5) x 2, $obj, (6) x 4, $obj, (7) x 3, $obj, (8) x 7); my $m = mode @probes; }; }, 'mode (multimodal) with exception in overloading stringify' => sub { eval { my $obj = DieOnStringify->new; my @probes = ( (1) x 3, $obj, (2) x 4, $obj, (3) x 2, $obj, (4) x 7, $obj, (5) x 2, $obj, (6) x 4, $obj, (7) x 3, $obj, (8) x 7, $obj, (9) x 4, $obj, (10) x 3, $obj, (11) x 7 ); my @m = mode @probes; }; }, 'scalar mode (multimodal) with exception in overloading stringify' => sub { eval { my $obj = DieOnStringify->new; my @probes = ( (1) x 3, $obj, (2) x 4, $obj, (3) x 2, $obj, (4) x 7, $obj, (5) x 2, $obj, (6) x 4, $obj, (7) x 3, $obj, (8) x 7, $obj, (9) x 4, $obj, (10) x 3, $obj, (11) x 7 ); my $m = mode @probes; }; }, ); done_testing; List-MoreUtils-0.430/t/inline/notall.pm0000644000175000017500000000065413736561312016120 0ustar snosno use Test::More; use Test::LMU; # Normal cases my @list = (1 .. 10000); is_true(notall { !defined } @list); is_true(notall { $_ < 10000 } @list); is_false(notall { $_ <= 10000 } @list); is_false(notall {}); leak_free_ok( notall => sub { my $ok = notall { $_ == 5000 } @list; my $ok2 = notall { $_ == 5000 } 1 .. 10000; } ); is_dying('notall without sub' => sub { ¬all(42, 4711); }); done_testing; List-MoreUtils-0.430/t/inline/lastres.pm0000644000175000017500000000076113736561312016303 0ustar snosnoBEGIN { $INC{'List/MoreUtils.pm'} or *last_result = __PACKAGE__->can("lastres"); } use Test::More; use Test::LMU; my $x = lastres { 2 * ($_ > 5) } 4 .. 9; is($x, 2); $x = lastres { $_ > 5 } 1 .. 4; is($x, undef); # Test aliases $x = last_result { $_ > 5 } 4 .. 9; is($x, 1); $x = last_result { $_ > 5 } 1 .. 4; is($x, undef); leak_free_ok( lastres => sub { $x = lastres { $_ > 5 } 4 .. 9; } ); is_dying('lastres without sub' => sub { &lastres(42, 4711); }); done_testing; List-MoreUtils-0.430/t/inline/pairwise.pm0000644000175000017500000000622613736561312016453 0ustar snosno use Test::More; use Test::LMU; my @a = (1, 2, 3, 4, 5); my @b = (2, 4, 6, 8, 10); my @c = pairwise { $a + $b } @a, @b; is_deeply(\@c, [3, 6, 9, 12, 15], "pw1"); @c = pairwise { $a * $b } @a, @b; # returns (2, 8, 18) is_deeply(\@c, [2, 8, 18, 32, 50], "pw2"); # Did we modify the input arrays? is_deeply(\@a, [1, 2, 3, 4, 5], "pw3"); is_deeply(\@b, [2, 4, 6, 8, 10], "pw4"); # $a and $b should be aliases: test @b = @a = (1, 2, 3); @c = pairwise { $a++; $b *= 2 } @a, @b; is_deeply(\@a, [2, 3, 4], "pw5"); is_deeply(\@b, [2, 4, 6], "pw6"); is_deeply(\@c, [2, 4, 6], "pw7"); # sub returns more than two items @a = (1, 1, 2, 3, 5); @b = (2, 3, 5, 7, 11, 13); @c = pairwise { ($a) x $b } @a, @b; is_deeply(\@c, [(1) x 2, (1) x 3, (2) x 5, (3) x 7, (5) x 11, (undef) x 13], "pw8"); is_deeply(\@a, [1, 1, 2, 3, 5], "pw9"); is_deeply(\@b, [2, 3, 5, 7, 11, 13], "pwX"); (@a, @b) = (); push @a, int rand(1000) for 0 .. rand(1000); push @b, int rand(1000) for 0 .. rand(1000); SCOPE: { local $SIG{__WARN__} = sub { }; # XXX my @res1 = pairwise { $a + $b } @a, @b; # Test this one more thoroughly: the XS code looks flakey # correctness of pairwise_perl proved by human auditing. :-) my $limit = $#a > $#b ? $#a : $#b; my @res2 = map { $a[$_] + $b[$_] } 0 .. $limit; is_deeply(\@res1, \@res2); } @a = qw/a b c/; @b = qw/1 2 3/; @c = pairwise { ($a, $b) } @a, @b; is_deeply(\@c, [qw/a 1 b 2 c 3/], "pw map"); SKIP: { $ENV{PERL5OPT} and skip 'A defined PERL5OPT may inject extra deps crashing this test', 1; # Test that a die inside the code-reference will not be trapped eval { pairwise { die "I died\n" } @a, @b; }; is($@, "I died\n"); } leak_free_ok( pairwise => sub { @a = (1); @b = (2); @c = pairwise { $a + $b } @a, @b; } ); leak_free_ok( 'exceptional block' => sub { @a = qw/a b c/; @b = qw/1 2 3/; eval { @c = pairwise { $b == 3 and die "Primes suck!"; "$a:$b" } @a, @b; }; } ); SKIP: { $INC{'List/MoreUtils/XS.pm'} or skip "PurePerl will warn here ...", 1; my ($a, $b, @t); eval { my @l1 = (1 .. 10); @t = pairwise { $a + $b } @l1, @l1; }; my $err = $@; like($err, qr/Can't use lexical \$a or \$b in pairwise code block/, "pairwise die's on broken caller"); } SKIP: { $INC{'List/MoreUtils/XS.pm'} and skip "XS will die on purpose here ...", 1; my @warns = (); local $SIG{__WARN__} = sub { push @warns, @_ }; my ($a, $b, @t); my @l1 = (1 .. 10); @t = pairwise { $a + $b } @l1, @l1; like(join("", @warns[0, 1]), qr/Use of uninitialized value.*? in addition/, "warning on broken caller"); } is_dying('pairwise without sub' => sub { &pairwise(42, \@a, \@b); }); SKIP: { $INC{'List/MoreUtils/XS.pm'} or skip "PurePerl will not core here ...", 2; is_dying( 'pairwise without first ARRAY' => sub { @c = &pairwise(sub { }, 1, \@b); } ); is_dying( 'pairwise without second ARRAY' => sub { @c = &pairwise(sub { }, \@a, 2); } ); } done_testing; List-MoreUtils-0.430/t/inline/insert_after_string.pm0000644000175000017500000000163013735543465020705 0ustar snosno use Test::More; use Test::LMU; my @list = qw{This is a list}; insert_after_string "a", "longer" => @list; is(join(' ', @list), "This is a longer list"); @list = (undef, qw{This is a list}); insert_after_string "a", "longer", @list; shift @list; is(join(' ', @list), "This is a longer list"); @list = ("This\0", "is\0", "a\0", "list\0"); insert_after_string "a\0", "longer\0", @list; is(join(' ', @list), "This\0 is\0 a\0 longer\0 list\0"); leak_free_ok( insert_after_string => sub { @list = qw{This is a list}; insert_after_string "a", "longer", @list; } ); leak_free_ok( 'insert_after_string with exception' => sub { eval { my @list = (qw{This is}, DieOnStringify->new, qw{a list}); insert_after_string "a", "longer", @list; }; } ); is_dying('insert_after_string without array' => sub { &insert_after_string(42, 4711, "13"); }); done_testing; List-MoreUtils-0.430/t/inline/lastidx.pm0000644000175000017500000000124313736561312016272 0ustar snosnoBEGIN { $INC{'List/MoreUtils.pm'} or *last_index = __PACKAGE__->can("lastidx"); } use Test::More; use Test::LMU; my @list = (1 .. 10000); is(9999, lastidx { $_ >= 5000 } @list); is(-1, lastidx { not defined } @list); is(9999, lastidx { defined } @list); is(-1, lastidx {}); # Test aliases is(9999, last_index { $_ >= 5000 } @list); is(-1, last_index { not defined } @list); is(9999, last_index { defined } @list); is(-1, last_index {}); leak_free_ok( lastidx => sub { my $i = lastidx { $_ >= 5000 } @list; my $i2 = lastidx { $_ >= 5000 } 1 .. 10000; } ); is_dying('lastidx without sub' => sub { &lastidx(42, 4711); }); done_testing; List-MoreUtils-0.430/t/inline/reduce_u.pm0000644000175000017500000000172013736561312016415 0ustar snosno use Test::More; use Test::LMU; use List::Util qw(sum); SCOPE: { my @exam_results = (0, 2, 4, 6, 5, 3, 0); my $pupil = sum @exam_results; my $wa = reduce_u { defined $a ? $a + $_ * $b / $pupil : 0 } @exam_results; $wa = sprintf("%0.2f", $wa); is($wa, 3.15, "weighted average of exam"); } leak_free_ok( 'reduce_u' => sub { my @exam_results = (undef, 2, 4, 6, 5, 3, 0); my $pupil = 20; my $wa = reduce_u { defined $a ? $a + $_ * $b / $pupil : 0 } @exam_results; }, 'reduce_u X' => sub { my @w = map { int(rand(5)) + 1; } 1 .. 100; my $c1 = reduce_u { ($a || 0) + $w[$_] * $b } 1 .. 100; } ); leak_free_ok( 'reduce_u with a coderef that dies' => sub { # This test is from Kevin Ryde; see RT#48669 eval { my $ok = reduce_u { die } 1; }; } ); is_dying('reduce_u without sub' => sub { &reduce_u(42, 4711); }); done_testing List-MoreUtils-0.430/t/inline/any.pm0000644000175000017500000000122213736561312015406 0ustar snosno use Test::More; use Test::LMU; # Normal cases my @list = (1 .. 10000); is_true(any { $_ == 5000 } @list); is_true(any { $_ == 5000 } 1 .. 10000); is_true(any { defined } @list); is_false(any { not defined } @list); is_true(any { not defined } undef); is_false(any {}); leak_free_ok( any => sub { my $ok = any { $_ == 5000 } @list; my $ok2 = any { $_ == 5000 } 1 .. 10000; } ); leak_free_ok( 'any with a coderef that dies' => sub { # This test is from Kevin Ryde; see RT#48669 eval { my $ok = any { die } 1; }; } ); is_dying('any without sub' => sub { &any(42, 4711); }); done_testing; List-MoreUtils-0.430/t/inline/XS.pm0000644000175000017500000000215313735543465015165 0ustar snosno use Test::More; $INC{'List/MoreUtils.pm'} or plan skip_all => "Unreasonable unless loaded via List::MoreUtils"; is(List::MoreUtils::_XScompiled(), 0 + defined($INC{'List/MoreUtils/XS.pm'}), "_XScompiled"); done_testing(); 1; =head1 AUTHOR Jens Rehsack Erehsack AT cpan.orgE Adam Kennedy Eadamk@cpan.orgE =head1 COPYRIGHT AND LICENSE Copyright 2013 - 2017 by Jens Rehsack All code added with 0.417 or later is licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in compliance with the License. You may obtain a copy of the License at http://www.apache.org/licenses/LICENSE-2.0 Unless required by applicable law or agreed to in writing, software distributed under the License is distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the License for the specific language governing permissions and limitations under the License. All code until 0.416 is licensed 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 List-MoreUtils-0.430/t/inline/lastval.pm0000644000175000017500000000100613736561312016265 0ustar snosnoBEGIN { $INC{'List/MoreUtils.pm'} or *last_value = __PACKAGE__->can("lastval"); } use Test::More; use Test::LMU; my $x = lastval { $_ > 5 } 4 .. 9; is($x, 9); $x = lastval { $_ > 5 } 1 .. 4; is($x, undef); is_undef(lastval { $_ > 5 }); # Test aliases $x = last_value { $_ > 5 } 4 .. 9; is($x, 9); $x = last_value { $_ > 5 } 1 .. 4; is($x, undef); leak_free_ok( lastval => sub { $x = lastval { $_ > 5 } 4 .. 9; } ); is_dying('lastval without sub' => sub { &lastval(42, 4711); }); done_testing; List-MoreUtils-0.430/t/inline/before.pm0000644000175000017500000000067013736561312016067 0ustar snosno use Test::More; use Test::LMU; my @x = before { $_ % 5 == 0 } 1 .. 9; is_deeply(\@x, [1, 2, 3, 4], "before 5"); @x = before { /b/ } qw{bar baz}; is_deeply(\@x, [], 'Got the null list'); @x = before { /f/ } qw{bar baz foo}; is_deeply(\@x, [qw{bar baz}], "before /f/"); leak_free_ok( before => sub { @x = before { /f/ } qw{ bar baz foo }; } ); is_dying('before without sub' => sub { &before(42, 4711); }); done_testing; List-MoreUtils-0.430/t/inline/Import.pm0000644000175000017500000000407613735543465016113 0ustar snosno use Test::More; use Test::LMU; my @pure_funcs = qw(any all none notall one any_u all_u none_u notall_u one_u true false insert_after insert_after_string apply indexes after after_incl before before_incl firstidx lastidx onlyidx firstval lastval onlyval firstres lastres onlyres singleton each_array each_arrayref pairwise natatime mesh uniq minmax part bsearch bsearchidx); my @v0_33 = qw(sort_by nsort_by); my %alias_list = ( v0_22 => { first_index => "firstidx", last_index => "lastidx", first_value => "firstval", last_value => "lastval", zip => "mesh", }, v0_33 => { distinct => "uniq", }, v0_400 => { first_result => "firstres", only_index => "onlyidx", only_value => "onlyval", only_result => "onlyres", last_result => "lastres", bsearch_index => "bsearchidx", }, ); can_ok(__PACKAGE__, $_) for @pure_funcs; SKIP: { $INC{'List/MoreUtils.pm'} or skip "List::MoreUtils::XS doesn't alias", 1; can_ok(__PACKAGE__, $_) for @v0_33; can_ok(__PACKAGE__, $_) for map { keys %$_ } values %alias_list; } done_testing; 1; =head1 AUTHOR Jens Rehsack Erehsack AT cpan.orgE Adam Kennedy Eadamk@cpan.orgE =head1 COPYRIGHT AND LICENSE Copyright 2013 - 2017 by Jens Rehsack All code added with 0.417 or later is licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in compliance with the License. You may obtain a copy of the License at http://www.apache.org/licenses/LICENSE-2.0 Unless required by applicable law or agreed to in writing, software distributed under the License is distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the License for the specific language governing permissions and limitations under the License. All code until 0.416 is licensed 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 List-MoreUtils-0.430/t/inline/firstidx.pm0000644000175000017500000000146513736561312016464 0ustar snosnoBEGIN { $INC{'List/MoreUtils.pm'} or *first_index = __PACKAGE__->can("firstidx"); } use Test::More; use Test::LMU; my @list = (1 .. 10000); is(4999, (firstidx { $_ >= 5000 } @list), "firstidx"); is(-1, (firstidx { not defined } @list), "invalid firstidx"); is(0, (firstidx { defined } @list), "real firstidx"); is(-1, (firstidx {}), "empty firstidx"); SKIP: { # Test the alias is(4999, first_index { $_ >= 5000 } @list); is(-1, first_index { not defined } @list); is(0, first_index { defined } @list); is(-1, first_index {}); } leak_free_ok( firstidx => sub { my $i = firstidx { $_ >= 5000 } @list; my $i2 = firstidx { $_ >= 5000 } 1 .. 10000; } ); is_dying('firstidx without sub' => sub { &firstidx(42, 4711); }); done_testing; List-MoreUtils-0.430/t/inline/frequency.pm0000644000175000017500000000731113736561312016625 0ustar snosno use Test::More; use Test::LMU; use Tie::Array (); SCOPE: { my @s = (1001 .. 1200); my @d = (1 .. 1000); my @a = (@d, @s, @d); my %e = ((map { $_ => 2 } @d), map { $_ => 1 } @s); my $fa = freeze(\@a); my %f = frequency @a; is($fa, freeze(\@a), "frequency:G_ARRAY leaves numbers untouched"); is_deeply(\%f, {%e}, "frequency of numbers"); my $f = frequency @a; is($fa, freeze(\@a), "frequency:G:SCALAR leaves numbers untouched"); is(scalar keys %e, $f, "scalar result of frequency of numbers"); } # Test strings SCOPE: { my @s = ("AA" .. "ZZ"); my @d = ("aa" .. "zz"); my @a = (@d, @s, @d); my $fa = freeze(\@a); my %e = ((map { $_ => 2 } @d), map { $_ => 1 } @s); my %f = frequency @a; is($fa, freeze(\@a), "frequency:G_ARRAY leaves strings untouched"); is_deeply(\%f, {%e}, "frequency of strings"); my $f = frequency @a; is($fa, freeze(\@a), "frequency:G_SCALAR leaves strings untouched"); is(scalar keys %e, $f, "scalar result of frequency of strings"); } # Test mixing strings and numbers SCOPE: { my @s = (1001 .. 1200, "AA" .. "ZZ"); my @d = (1 .. 1000, "aa" .. "zz"); my @a = (@d, @s, @d); my %e = ((map { $_ => 2 } @d), map { $_ => 1 } @s); my $fa = freeze(\@a); my %f = frequency @a; is($fa, freeze(\@a), "frequency:G_ARRAY leaves number/strings mixture untouched"); is_deeply(\%f, {%e}, "frequency of number/strings mixture"); my $f = frequency @a; is($fa, freeze(\@a), "frequency:G_SCALAR leaves number/strings mixture untouched"); is(scalar keys %e, $f, "scalar result of frequency of number/strings mixture"); } SCOPE: { my @a; tie @a, "Tie::StdArray"; my @s = (1001 .. 1200, "AA" .. "ZZ"); my @d = (1 .. 1000, "aa" .. "zz"); @a = (@d, @s, @d); my $fa = freeze(\@a); my %e = ((map { $_ => 2 } @d), map { $_ => 1 } @s); my %f = frequency @a; is($fa, freeze(\@a), "frequency:G_ARRAY leaves tied array of number/strings mixture untouched"); is_deeply(\%f, {%e}, "frequency of tied array of number/strings mixture"); my $f = frequency @a; is($fa, freeze(\@a), "frequency:G_SCALAR leaves tied array of number/strings mixture untouched"); is(scalar keys %e, $f, "scalar result of frequency of tied array of number/strings mixture"); } SCOPE: { my @foo = ('a', 'b', '', undef, 'b', 'c', '', undef); my %e = ( a => 1, b => 2, '' => 2, c => 1 ); my @f = frequency @foo; my $seen_undef; ref $f[-2] and ref $f[-2] eq "SCALAR" and not defined ${$f[-2]} and (undef, $seen_undef) = splice @f, -2, 2, (); my %f = @f; is_deeply(\%f, \%e, "stuff around undef's is supported correctly by frequency"); is($seen_undef, 2, "two undef's are supported correctly by frequency"); } leak_free_ok( frequency => sub { my @s = (1001 .. 1200, "AA" .. "ZZ"); my @d = map { (1 .. 1000, "aa" .. "zz") } 0 .. 1; my @a = (@d, @s); my %f = frequency @a; }, 'scalar frequency' => sub { my @s = (1001 .. 1200, "AA" .. "ZZ"); my @d = map { (1 .. 1000, "aa" .. "zz") } 0 .. 1; my @a = (@d, @s); my $f = frequency @a; } ); leak_free_ok( 'frequency with exception in overloading stringify', sub { eval { my $obj = DieOnStringify->new; my @foo = ('a', 'b', '', undef, $obj, 'b', 'c', '', undef, $obj); my %f = frequency @foo; }; eval { my $obj = DieOnStringify->new; my $f = frequency 'a', 'b', '', undef, $obj, 'b', 'c', '', undef, $obj; }; } ); done_testing; List-MoreUtils-0.430/t/inline/singleton.pm0000644000175000017500000000437613736561312016636 0ustar snosno use Test::More; use Test::LMU; use Tie::Array (); SCOPE: { my @s = (1001 .. 1200); my @d = map { (1 .. 1000) } 0 .. 1; my @a = (@d, @s); my @u = singleton @a; is_deeply(\@u, [@s]); my $u = singleton @a; is(200, $u); } # Test strings SCOPE: { my @s = ("AA" .. "ZZ"); my @d = map { ("aa" .. "zz") } 0 .. 1; my @a = (@d, @s); my @u = singleton @a; is_deeply(\@u, [@s]); my $u = singleton @a; is(scalar @s, $u); } # Test mixing strings and numbers SCOPE: { my @s = (1001 .. 1200, "AA" .. "ZZ"); my $fs = freeze(\@s); my @d = map { (1 .. 1000, "aa" .. "zz") } 0 .. 1; my @a = (@d, @s); my $fa = freeze(\@a); my @u = singleton map { $_ } @a; my $fu = freeze(\@u); is_deeply(\@u, [@s]); is($fs, freeze(\@s)); is($fa, freeze(\@a)); is($fu, $fs); my $u = singleton @a; is(scalar @s, $u); } SCOPE: { my @a; tie @a, "Tie::StdArray"; my @s = (1001 .. 1200, "AA" .. "ZZ"); my @d = map { (1 .. 1000, "aa" .. "zz") } 0 .. 1; @a = (@d, @s); my @u = singleton map { $_ } @a; is_deeply(\@u, [@s]); @a = (@d, @s); my $u = singleton @a; is(scalar @s, $u); } SCOPE: { my @foo = ('a', 'b', '', undef, 'b', 'c', ''); my @sfoo = ('a', undef, 'c'); is_deeply([singleton @foo], \@sfoo, 'one undef is supported correctly by singleton'); @foo = ('a', 'b', '', undef, 'b', 'c', undef); @sfoo = ('a', '', 'c'); is_deeply([singleton @foo], \@sfoo, 'twice undef is supported correctly by singleton'); is((scalar singleton @foo), scalar @sfoo, 'scalar twice undef is supported correctly by singleton'); } leak_free_ok( singleton => sub { my @s = (1001 .. 1200, "AA" .. "ZZ"); my @d = map { (1 .. 1000, "aa" .. "zz") } 0 .. 1; my @a = (@d, @s); my @u = singleton @a; scalar singleton @a; } ); # This test (and the associated fix) are from Kevin Ryde; see RT#49796 leak_free_ok( 'singleton with exception in overloading stringify', sub { eval { my $obj = DieOnStringify->new; my @u = singleton $obj, $obj; }; eval { my $obj = DieOnStringify->new; my $u = singleton $obj, $obj; }; } ); done_testing; List-MoreUtils-0.430/t/inline/indexes.pm0000644000175000017500000000363013736561312016263 0ustar snosno use Test::More; use Test::LMU; my @x = indexes { $_ > 5 } (4 .. 9); is_deeply(\@x, [2 .. 5], "indexes > 5 ..."); @x = indexes { $_ > 5 } (1 .. 4); is_deeply(\@x, [], 'Got the null list'); my ($lr, @s, @n, @o, @e); leak_free_ok( indexes => sub { $lr = 1; @s = indexes { $_ > 5 } (4 .. 9); @n = indexes { $_ > 5 } (1 .. 5); @o = indexes { $_ & 1 } (10 .. 15); @e = indexes { !($_ & 1) } (10 .. 15); } ); $lr and is_deeply(\@s, [2 .. 5], "indexes/leak: some"); $lr and is_deeply(\@n, [], "indexes/leak: none"); $lr and is_deeply(\@o, [1, 3, 5], "indexes/leak: odd"); $lr and is_deeply(\@e, [0, 2, 4], "indexes/leak: even"); @n = map { $_ + 1 } @o = (0 .. 9); @x = indexes { ++$_ > 7 } @o; is_deeply(\@o, \@n, "indexes behaves like grep on modified \$_"); is_deeply(\@x, [7 .. 9], "indexes/modify"); not_dying( 'indexes_on_set' => sub { @x = indexes { ++$_ > 7 } (0 .. 9); } ); is_deeply(\@x, [7 .. 9], "indexes/modify set"); leak_free_ok( indexes => sub { @s = indexes { grow_stack; $_ > 5 } (4 .. 9); @n = indexes { grow_stack; $_ > 5 } (1 .. 4); @o = indexes { grow_stack; $_ & 1 } (10 .. 15); @e = indexes { grow_stack; !($_ & 1) } (10 .. 15); }, 'indexes interrupted by exception' => sub { eval { @s = indexes { $_ > 10 and die "range exceeded"; $_ > 5 } (1 .. 15); }; }, ); $lr and is_deeply(\@s, [2 .. 5], "indexes/leak: some"); $lr and is_deeply(\@n, [], "indexes/leak: none"); $lr and is_deeply(\@o, [1, 3, 5], "indexes/leak: odd"); $lr and is_deeply(\@e, [0, 2, 4], "indexes/leak: even"); my $have_scalar_util = eval { require Scalar::Util; 1 }; if ($have_scalar_util) { my $ref = \(indexes(sub { 1 }, 123)); Scalar::Util::weaken($ref); is($ref, undef, "weakened away"); } is_dying('indexes without sub' => sub { &indexes(42, 4711); }); done_testing; List-MoreUtils-0.430/t/inline/part.pm0000644000175000017500000000420113736561312015565 0ustar snosno use Test::More; use Test::LMU; my @list = 1 .. 12; my $i = 0; my @part = part { $i++ % 3 } @list; is_deeply($part[0], [1, 4, 7, 10], " i: part % 3"); is_deeply($part[1], [2, 5, 8, 11], " ii: part % 3"); is_deeply($part[2], [3, 6, 9, 12], "iii: part % 3"); $list[2] = 0; is($part[2][0], 3, 'Values are not aliases'); @list = 1 .. 12; @part = part { 3 } @list; is($part[0], undef, " i: part 3"); is($part[1], undef, " ii: part 3"); is($part[2], undef, "iii: part 3"); is_deeply($part[3], [1 .. 12], " iv: part 3"); eval { @part = part { -1 } @list; }; like($@, qr/^Modification of non-creatable array value attempted, subscript -1/); $i = 0; @part = part { $i++ == 0 ? 0 : -1 } @list; is_deeply($part[0], [1 .. 12], "part with negative indices"); SKIP: { $INC{'List/MoreUtils/XS.pm'} and skip "Only PurePerl will warn here ...", 1; my @warns = (); local $SIG{__WARN__} = sub { push @warns, [@_] }; @part = part { undef } @list; is_deeply($part[0], [1 .. 12], "part with undef"); like(join("\n", @{$warns[0]}), qr/Use of uninitialized value in array element.*line\s+\d+\.$/, "warning of undef"); is_deeply(\@warns, [($warns[0]) x 12], "amount of similar undef warnings"); } @part = part { 10000 } @list; is_deeply($part[10000], [@list], " i: part 10_000"); is($part[0], undef, " ii: part 10_000"); is($part[@part / 2], undef, "iii: part 10_000"); is($part[9999], undef, " iv: part 10_000"); # Changing the list in place used to destroy # its elements due to a wrong refcnt @list = 1 .. 10; @list = part { $_ } @list; foreach (1 .. 10) { is_deeply($list[$_], [$_], "part \$_: $_"); } leak_free_ok( part => sub { my @list = 1 .. 12; my $i = 0; my @part = part { $i++ % 3 } @list; } ); leak_free_ok( 'part with stack-growing' => sub { # This test is from Kevin Ryde; see RT#38699 my @part = part { grow_stack(); 1024 } 'one', 'two'; } ); leak_free_ok( 'part with exception' => sub { my @long_list = int rand(1000) for 0 .. 1E7; my @part = part { $_ == 1E7 and die "Too much!"; ($_ % 10) * 2 } @long_list; } ); done_testing; List-MoreUtils-0.430/t/inline/slide.pm0000644000175000017500000000041513735543525015727 0ustar snosno use Test::More; use Test::LMU; # use case provided my Michael Schwern my @ol = (0 .. 3); is(join(", ", slide { "$a and $b" } @ol), "0 and 1, 1 and 2, 2 and 3", "M. Schwern requested example"); is_dying('slide without sub' => sub { &slide(0 .. 3); }); done_testing; List-MoreUtils-0.430/t/inline/binsert.pm0000644000175000017500000000664413736561312016302 0ustar snosno use Test::More; use Test::LMU; SCOPE: { my @list = (); is(0, (binsert { $_ cmp "Hello" } "Hello", @list), "Inserting into empty list"); is(1, (binsert { $_ cmp "world" } "world", @list), "Inserting into one-item list"); } my @even = map { $_ * 2 } 1 .. 100; my @odd = map { $_ * 2 - 1 } 1 .. 100; my (@expected, @in); @in = @even; @expected = mesh @odd, @even; foreach my $v (@odd) { binsert { $_ <=> $v } $v, @in; } is_deeply(\@in, \@expected, "binsert odd elements into even list succeeded"); @in = @even; @expected = mesh @odd, @even; foreach my $v (reverse @odd) { binsert { $_ <=> $v } $v, @in; } is_deeply(\@in, \@expected, "binsert odd elements reversely into even list succeeded"); @in = @odd; foreach my $v (@even) { binsert { $_ <=> $v } $v, @in; } is_deeply(\@in, \@expected, "binsert even elements into odd list succeeded"); @in = @odd; foreach my $v (reverse @even) { binsert { $_ <=> $v } $v, @in; } is_deeply(\@in, \@expected, "binsert even elements reversely into odd list succeeded"); @in = @even; @expected = map { $_, $_ } @in; foreach my $v (@even) { binsert { $_ <=> $v } $v, @in; } is_deeply(\@in, \@expected, "binsert existing even elements into even list succeeded"); @in = @even; @expected = map { $_, $_ } @in; foreach my $v (reverse @even) { binsert { $_ <=> $v } $v, @in; } is_deeply(\@in, \@expected, "binsert existing even elements reversely into even list succeeded"); leak_free_ok( 'binsert random' => sub { my @list = map { $_ * 2 } 1 .. 100; my $elem = int(rand(100)) + 1; binsert { $_ <=> $elem } $elem, @list; }, 'binsert existing random' => sub { my @list = map { $_ * 2 } 1 .. 100; my $elem = 2 * (int(rand(100)) + 1); binsert { $_ <=> $elem } $elem, @list; }, 'binsert odd into even' => sub { my @list = @even; foreach my $elem (@odd) { binsert { $_ <=> $elem } $elem, @list; } }, 'binsert even into odd' => sub { my @list = @odd; foreach my $elem (@even) { binsert { $_ <=> $elem } $elem, @list; } }, 'binsert odd into odd' => sub { my @list = @odd; foreach my $elem (@odd) { binsert { $_ <=> $elem } $elem, @list; } }, 'binsert even into even' => sub { my @list = @even; foreach my $elem (@even) { binsert { $_ <=> $elem } $elem, @list; } }, ); leak_free_ok( 'binsert random with stack-growing' => sub { my @list = map { $_ * 2 } 1 .. 100; my $elem = int(rand(100)) + 1; binsert { grow_stack(); $_ <=> $elem } $elem, @list; }, 'binsert odd with stack-growing' => sub { my @list = @even; foreach my $elem (@odd) { binsert { grow_stack(); $_ <=> $elem } $elem, @list; } }, 'binsert even with stack-growing' => sub { my @list = @odd; foreach my $elem (@even) { binsert { grow_stack(); $_ <=> $elem } $elem, @list; } }, ); leak_free_ok( 'binsert with stack-growing and exception' => sub { my @list = map { $_ * 2 } 1 .. 100; my $elem = int(rand(100)) + 1; eval { binsert { grow_stack(); $_ <=> $elem or die "Goal!"; $_ <=> $elem } $elem, @list; }; } ); is_dying('binsert without sub' => sub { &binsert(42, @even); }); done_testing; List-MoreUtils-0.430/t/inline/onlyval.pm0000644000175000017500000000154513736561312016313 0ustar snosnoBEGIN { $INC{'List/MoreUtils.pm'} or *only_value = __PACKAGE__->can("onlyval"); } use Test::More; use Test::LMU; my @list = (1 .. 300); is(1, onlyval { 1 == $_ } @list); is(150, onlyval { 150 == $_ } @list); is(300, onlyval { 300 == $_ } @list); is(undef, onlyval { 0 == $_ } @list); is(undef, onlyval { 1 <= $_ } @list); is(undef, onlyval { !(127 & $_) } @list); # Test aliases is(1, only_value { 1 == $_ } @list); is(150, only_value { 150 == $_ } @list); is(300, only_value { 300 == $_ } @list); is(undef, only_value { 0 == $_ } @list); is(undef, only_value { 1 <= $_ } @list); is(undef, only_value { !(127 & $_) } @list); leak_free_ok( onlyval => sub { my $ok = onlyval { 150 <= $_ } @list; my $ok2 = onlyval { 150 <= $_ } 1 .. 300; } ); is_dying('onlyval without sub' => sub { &onlyval(42, 4711); }); done_testing; List-MoreUtils-0.430/t/inline/equal_range.pm0000644000175000017500000000221413736561312017104 0ustar snosno use Test::More; use Test::LMU; my @list = (1, 1, 2, 2, 3, 3, 3, 3, 3, 3, 4, 4, 4, 4, 5, 5, 6, 7, 7, 7, 8, 8, 9, 9, 9, 9, 9, 11, 13, 13, 13, 17); is_deeply([0, 0], [equal_range { $_ <=> 0 } @list], "equal range 0"); is_deeply([0, 2], [equal_range { $_ <=> 1 } @list], "equal range 1"); is_deeply([2, 4], [equal_range { $_ <=> 2 } @list], "equal range 2"); is_deeply([10, 14], [equal_range { $_ <=> 4 } @list], "equal range 4"); is_deeply([(scalar @list) x 2], [equal_range { $_ <=> 19 } @list], "equal range 19"); my @in = @list = 1 .. 100; leak_free_ok( equal_range => sub { my $elem = int(rand(101)) + 1; equal_range { $_ - $elem } @list; } ); leak_free_ok( 'equal_range with stack-growing' => sub { my $elem = int(rand(101)); equal_range { grow_stack(); $_ - $elem } @list; } ); leak_free_ok( 'equal_range with stack-growing and exception' => sub { my $elem = int(rand(101)); eval { equal_range { grow_stack(); $_ - $elem or die "Goal!"; $_ - $elem } @list; }; } ); is_dying('equal_range without sub' => sub { &equal_range(42, (1 .. 100)); }); done_testing; List-MoreUtils-0.430/t/inline/onlyidx.pm0000644000175000017500000000151513736561312016312 0ustar snosnoBEGIN { $INC{'List/MoreUtils.pm'} or *only_index = __PACKAGE__->can("onlyidx"); } use Test::More; use Test::LMU; my @list = (1 .. 300); is(0, onlyidx { 1 == $_ } @list); is(149, onlyidx { 150 == $_ } @list); is(299, onlyidx { 300 == $_ } @list); is(-1, onlyidx { 0 == $_ } @list); is(-1, onlyidx { 1 <= $_ } @list); is(-1, onlyidx { !(127 & $_) } @list); # Test aliases is(0, only_index { 1 == $_ } @list); is(149, only_index { 150 == $_ } @list); is(299, only_index { 300 == $_ } @list); is(-1, only_index { 0 == $_ } @list); is(-1, only_index { 1 <= $_ } @list); is(-1, only_index { !(127 & $_) } @list); leak_free_ok( onlyidx => sub { my $ok = onlyidx { 150 <= $_ } @list; my $ok2 = onlyidx { 150 <= $_ } 1 .. 300; } ); is_dying('onlyidx without sub' => sub { &onlyidx(42, 4711); }); done_testing; List-MoreUtils-0.430/t/inline/mesh.pm0000644000175000017500000000277513735543465015601 0ustar snosnoBEGIN { $INC{'List/MoreUtils.pm'} or *zip = __PACKAGE__->can("mesh"); } use Test::More; use Test::LMU; SCOPE: { my @x = qw/a b c d/; my @y = qw/1 2 3 4/; my @z = mesh @x, @y; is_deeply(\@z, ['a', 1, 'b', 2, 'c', 3, 'd', 4], "mesh two list with same count of elements"); } SCOPE: { # alias check my @x = qw/a b c d/; my @y = qw/1 2 3 4/; my @z = zip @x, @y; is_deeply(\@z, ['a', 1, 'b', 2, 'c', 3, 'd', 4], "zip two list with same count of elements"); } SCOPE: { my @a = ('x'); my @b = ('1', '2'); my @c = qw/zip zap zot/; my @z = mesh @a, @b, @c; is_deeply(\@z, ['x', 1, 'zip', undef, 2, 'zap', undef, undef, 'zot'], "mesh three list with increasing count of elements"); } SCOPE: { # alias check my @a = ('x'); my @b = ('1', '2'); my @c = qw/zip zap zot/; my @z = zip @a, @b, @c; is_deeply(\@z, ['x', 1, 'zip', undef, 2, 'zap', undef, undef, 'zot'], "zip three list with increasing count of elements"); } # Make array with holes SCOPE: { my @a = (1 .. 10); my @d; $#d = 9; my @z = mesh @a, @d; is_deeply( \@z, [1, undef, 2, undef, 3, undef, 4, undef, 5, undef, 6, undef, 7, undef, 8, undef, 9, undef, 10, undef,], "mesh one list with 9 elements with an empty list" ); } leak_free_ok( mesh => sub { my @x = qw/a b c d e/; my @y = qw/1 2 3 4/; my @z = mesh @x, @y; } ); is_dying('mesh with a list, not at least two arrays' => sub { &mesh(1, 2); }); done_testing; List-MoreUtils-0.430/t/inline/firstres.pm0000644000175000017500000000077313736561312016472 0ustar snosnoBEGIN { $INC{'List/MoreUtils.pm'} or *first_result = __PACKAGE__->can("firstres"); } use Test::More; use Test::LMU; my $x = firstres { 2 * ($_ > 5) } 4 .. 9; is($x, 2); $x = firstres { $_ > 5 } 1 .. 4; is($x, undef); # Test aliases $x = first_result { $_ > 5 } 4 .. 9; is($x, 1); $x = first_result { $_ > 5 } 1 .. 4; is($x, undef); leak_free_ok( firstres => sub { $x = firstres { $_ > 5 } 4 .. 9; } ); is_dying('firstres without sub' => sub { &firstres(42, 4711); }); done_testing; List-MoreUtils-0.430/t/inline/before_incl.pm0000644000175000017500000000075613736561312017101 0ustar snosno use Test::More; use Test::LMU; my @x = before_incl { $_ % 5 == 0 } 1 .. 9; is_deeply(\@x, [1, 2, 3, 4, 5], "before 5, included"); @x = before_incl { /foo/ } qw{bar baz}; is_deeply(\@x, [qw{bar baz}]); @x = before_incl { /f/ } qw{bar baz foo}; is_deeply(\@x, [qw{bar baz foo}], "before /f/, included"); leak_free_ok( before_incl => sub { @x = before_incl { /z/ } qw{ bar baz foo }; } ); is_dying('before_incl without sub' => sub { &before_incl(42, 4711); }); done_testing; List-MoreUtils-0.430/t/inline/onlyres.pm0000644000175000017500000000160413736561312016316 0ustar snosnoBEGIN { $INC{'List/MoreUtils.pm'} or *only_result = __PACKAGE__->can("onlyres"); } use Test::More; use Test::LMU; my @list = (1 .. 300); is("Hallelujah", onlyres { 150 == $_ and "Hallelujah" } @list); is(1, onlyres { 300 == $_ } @list); is(undef, onlyres { 0 == $_ } @list); is(undef, onlyres { 1 <= $_ } @list); is(undef, onlyres { !(127 & $_) } @list); # Test aliases is(1, only_result { 150 == $_ } @list); is("Hallelujah", only_result { 300 == $_ and "Hallelujah" } @list); is(undef, only_result { 0 == $_ } @list); is(undef, only_result { 1 <= $_ } @list); is(undef, only_result { !(127 & $_) } @list); leak_free_ok( onlyres => sub { my $ok = onlyres { 150 <= $_ } @list; my $ok2 = onlyres { 150 <= $_ } 1 .. 300; } ); is_dying('onlyres without sub' => sub { &onlyres(42, 4711); }); done_testing; List-MoreUtils-0.430/t/inline/lower_bound.pm0000644000175000017500000000313513736561312017143 0ustar snosno use Test::More; use Test::LMU; my @list = (1, 1, 2, 2, 3, 3, 3, 3, 3, 3, 4, 4, 4, 4, 5, 5, 6, 7, 7, 7, 8, 8, 9, 9, 9, 9, 9, 11, 13, 13, 13, 17); is(0, (lower_bound { $_ <=> 0 } @list), "lower bound 0"); is(0, (lower_bound { $_ <=> 1 } @list), "lower bound 1"); is(2, (lower_bound { $_ <=> 2 } @list), "lower bound 2"); is(10, (lower_bound { $_ <=> 4 } @list), "lower bound 4"); is(scalar @list, (lower_bound { $_ <=> 19 } @list), "lower bound 19"); my @in = @list = 1 .. 100; for my $i (0 .. $#in) { my $j = $in[$i] - 1; is($i ? $i - 1 : 0, (lower_bound { $_ - $j } @list), "placed $j"); is($i, (lower_bound { $_ - $in[$i] } @list), "found $in[$i]"); } my @lout = ($in[0] - 11 .. $in[0] - 1); for my $elem (@lout) { is(0, (lower_bound { $_ - $elem } @list), "put smaller $elem in front"); } my @uout = ($in[-1] + 1 .. $in[-1] + 11); for my $elem (@uout) { is(scalar @list, (lower_bound { $_ - $elem } @list),, "put bigger $elem at end"); } leak_free_ok( lower_bound => sub { my $elem = int(rand(1000)) + 1; lower_bound { $_ - $elem } @list; } ); leak_free_ok( 'lower_bound with stack-growing' => sub { my $elem = int(rand(1000)); lower_bound { grow_stack(); $_ - $elem } @list; } ); leak_free_ok( 'lower_bound with stack-growing and exception' => sub { my $elem = int(rand(1000)); eval { lower_bound { grow_stack(); $_ - $elem or die "Goal!"; $_ - $elem } @list; }; } ); is_dying('lower_bound without sub' => sub { &lower_bound(42, (1 .. 100)); }); done_testing; List-MoreUtils-0.430/t/inline/uniq.pm0000644000175000017500000000350213736561312015576 0ustar snosnoBEGIN { $INC{'List/MoreUtils.pm'} or *distinct = __PACKAGE__->can("uniq"); } use Test::More; use Test::LMU; use Tie::Array (); SCOPE: { my @a = map { (1 .. 10) } 0 .. 1; my @u = uniq @a; is_deeply(\@u, [1 .. 10]); my $u = uniq @a; is(10, $u); } # Test aliases SCOPE: { my @a = map { (1 .. 10) } 0 .. 1; my @u = distinct @a; is_deeply(\@u, [1 .. 10]); my $u = distinct @a; is(10, $u); } # Test strings SCOPE: { my @a = map { ("a" .. "z") } 0 .. 1; my @u = uniq @a; is_deeply(\@u, ["a" .. "z"]); my $u = uniq @a; is(26, $u); } # Test mixing strings and numbers SCOPE: { my @a = ((map { (1 .. 10) } 0 .. 1), (map { ("a" .. "z") } 0 .. 1)); my $fa = freeze(\@a); my @u = uniq map { $_ } @a; my $fu = freeze(\@u); is_deeply(\@u, [1 .. 10, "a" .. "z"]); is($fa, freeze(\@a)); is($fu, freeze([1 .. 10, "a" .. "z"])); my $u = uniq @a; is(10 + 26, $u); } SCOPE: { my @a; tie @a, "Tie::StdArray"; @a = ((map { (1 .. 10) } 0 .. 1), (map { ("a" .. "z") } 0 .. 1)); my @u = uniq @a; is_deeply(\@u, [1 .. 10, "a" .. "z"]); @a = ((map { (1 .. 10) } 0 .. 1), (map { ("a" .. "z") } 0 .. 1)); my $u = uniq @a; is(10 + 26, $u); } SCOPE: { my @foo = ('a', 'b', '', undef, 'b', 'c', ''); my @ufoo = ('a', 'b', '', undef, 'c'); is_deeply([uniq @foo], \@ufoo, 'undef is supported correctly'); } leak_free_ok( uniq => sub { my @a = map { (1 .. 1000) } 0 .. 1; my @u = uniq @a; uniq @a[1 .. 100]; } ); # This test (and the associated fix) are from Kevin Ryde; see RT#49796 leak_free_ok( 'uniq with exception in overloading stringify', sub { eval { my $obj = DieOnStringify->new; my @u = uniq "foo", $obj, "bar", $obj; }; } ); done_testing; List-MoreUtils-0.430/t/inline/true.pm0000644000175000017500000000111413736561312015576 0ustar snosno use Test::More; use Test::LMU; # The null set should return zero my $null_scalar = true {}; my @null_list = true {}; is($null_scalar, 0, 'true(null) returns undef'); is_deeply(\@null_list, [0], 'true(null) returns undef'); # Normal cases my @list = (1 .. 10000); is(10000, true { defined } @list); is(0, true { not defined } @list); is(1, true { $_ == 5000 } @list); leak_free_ok( true => sub { my $n = true { $_ == 5000 } @list; my $n2 = true { $_ == 5000 } 1 .. 10000; } ); is_dying('true without sub' => sub { &true(42, 4711); }); done_testing; List-MoreUtils-0.430/t/inline/upper_bound.pm0000644000175000017500000000313513736561312017146 0ustar snosno use Test::More; use Test::LMU; my @list = (1, 1, 2, 2, 3, 3, 3, 3, 3, 3, 4, 4, 4, 4, 5, 5, 6, 7, 7, 7, 8, 8, 9, 9, 9, 9, 9, 11, 13, 13, 13, 17); is(0, (upper_bound { $_ <=> 0 } @list), "upper bound 0"); is(2, (upper_bound { $_ <=> 1 } @list), "upper bound 1"); is(4, (upper_bound { $_ <=> 2 } @list), "upper bound 2"); is(14, (upper_bound { $_ <=> 4 } @list), "upper bound 4"); is(scalar @list, (upper_bound { $_ <=> 19 } @list), "upper bound 19"); my @in = @list = 1 .. 100; for my $i (0 .. $#in) { my $j = $in[$i] - 1; is($i, (upper_bound { $_ - $j } @list), "placed $j"); is($i + 1, (upper_bound { $_ - $in[$i] } @list), "found $in[$i]"); } my @lout = ($in[0] - 11 .. $in[0] - 1); for my $elem (@lout) { is(0, (upper_bound { $_ - $elem } @list), "put smaller $elem in front"); } my @uout = ($in[-1] + 1 .. $in[-1] + 11); for my $elem (@uout) { is(scalar @list, (upper_bound { $_ - $elem } @list),, "put bigger $elem at end"); } leak_free_ok( upper_bound => sub { my $elem = int(rand(1000)) + 1; upper_bound { $_ - $elem } @list; } ); leak_free_ok( 'upper_bound with stack-growing' => sub { my $elem = int(rand(1000)); upper_bound { grow_stack(); $_ - $elem } @list; } ); leak_free_ok( 'upper_bound with stack-growing and exception' => sub { my $elem = int(rand(1000)); eval { upper_bound { grow_stack(); $_ - $elem or die "Goal!"; $_ - $elem } @list; }; } ); is_dying('upper_bound without sub' => sub { &upper_bound(42, (1 .. 100)); }); done_testing; List-MoreUtils-0.430/t/inline/natatime.pm0000644000175000017500000000111013736561312016415 0ustar snosno use Test::More; use Test::LMU; my @x = ('a' .. 'g'); my $it = natatime 3, @x; my @r; local $" = " "; while (my @vals = $it->()) { push @r, "@vals"; } is(is_deeply(\@r, ['a b c', 'd e f', 'g']), 1, "natatime with 3 elements"); my @a = (1 .. 1000); $it = natatime 1, @a; @r = (); while (my @vals = &$it) { push @r, @vals; } is(is_deeply(\@r, \@a), 1, "natatime with 1 element"); leak_free_ok( natatime => sub { my @y = 1; my $it = natatime 2, @y; while (my @vals = $it->()) { # do nothing } } ); done_testing; List-MoreUtils-0.430/t/inline/listcmp.pm0000644000175000017500000000632713736561312016305 0ustar snosno use Test::More; use Test::LMU; use Tie::Array (); SCOPE: { my @a = qw(one two three four five six seven eight nine ten eleven twelve thirteen); my @b = qw(two three five seven eleven thirteen seventeen); my @c = qw(one one two three five eight thirteen twentyone); my %expected = ( one => [0, 2], two => [0, 1, 2], three => [0, 1, 2], four => [0], five => [0, 1, 2], six => [0], seven => [0, 1], eight => [0, 2], nine => [0], ten => [0], eleven => [0, 1], twelve => [0], thirteen => [0, 1, 2], seventeen => [1], twentyone => [2], ); my %cmped = listcmp @a, @b, @c; is_deeply(\%cmped, \%expected, "Sequence vs. Prime vs. Fibonacci sorted out correctly"); } SCOPE: { my @a = ("one", "two", "three", "four", "five", "six", "seven", "eight", "nine", "ten", "eleven", "twelve", "thirteen"); my @b = (undef, "two", "three", undef, "five", undef, "seven", undef, undef, undef, "eleven", undef, "thirteen"); my %expected = ( one => [0], two => [0, 1], three => [0, 1], four => [0], five => [0, 1], six => [0], seven => [0, 1], eight => [0], nine => [0], ten => [0], eleven => [0, 1], twelve => [0], thirteen => [0, 1], ); my %cmped = listcmp @a, @b; is_deeply(\%cmped, \%expected, "Sequence vs. Prime filled with undef sorted out correctly"); } leak_free_ok( listcmp => sub { my @a = ("one", "two", "three", "four", "five", "six", "seven", "eight", "nine", "ten", "eleven", "twelve", "thirteen"); my @b = (undef, "two", "three", undef, "five", undef, "seven", undef, undef, undef, "eleven", undef, "thirteen"); my %expected = ( one => [0], two => [0, 1], three => [0, 1], four => [0], five => [0, 1], six => [0], seven => [0, 1], eight => [0], nine => [0], ten => [0], eleven => [0, 1], twelve => [0], thirteen => [0, 1], ); my %cmped = listcmp @a, @b; } ); # This test (and the associated fix) are from Kevin Ryde; see RT#49796 leak_free_ok( 'listcmp with exception in overloading stringify at begin' => sub { eval { my @a = ("one", "two", "three"); my @b = (DieOnStringify->new, "two", "three"); my %expected = ( one => [0], two => [0, 1], three => [0, 1], ); my %cmped = listcmp @a, @b; }; }, 'listcmp with exception in overloading stringify at end' => sub { eval { my @a = ("one", "two", "three"); my @b = ("two", "three", DieOnStringify->new); my %expected = ( one => [0], two => [0, 1], three => [0, 1], ); my %cmped = listcmp @a, @b; }; } ); done_testing; List-MoreUtils-0.430/t/inline/one.pm0000644000175000017500000000076313736561312015411 0ustar snosno use Test::More; use Test::LMU; # Normal cases my @list = (1 .. 300); is_true(one { 1 == $_ } @list); is_true(one { 150 == $_ } @list); is_true(one { 300 == $_ } @list); is_false(one { 0 == $_ } @list); is_false(one { 1 <= $_ } @list); is_false(one { !(127 & $_) } @list); is_false(one { 0 } ()); leak_free_ok( one => sub { my $ok = one { 150 <= $_ } @list; my $ok2 = one { 150 <= $_ } 1 .. 300; } ); is_dying('one without sub' => sub { &one(42, 4711); }); done_testing; List-MoreUtils-0.430/t/inline/slideatatime.pm0000644000175000017500000000247213736561312017274 0ustar snosno use Test::More; use Test::LMU; local $" = " "; my $it; my @r; my @x = ('a' .. 'g'); $it = slideatatime 3, 3, @x; while (my @vals = $it->()) { push @r, "@vals"; } is(is_deeply(\@r, ['a b c', 'd e f', 'g']), 1, "slideatatime as natatime with 3 elements"); $it = slideatatime 2, 3, @x; @r = (); while (my @vals = $it->()) { push @r, "@vals"; } is(is_deeply(\@r, ['a b c', 'c d e', 'e f g', 'g']), 1, "slideatatime moving 3 elements by 2 items"); $it = slideatatime 1, 3, @x; @r = (); while (my @vals = $it->()) { push @r, "@vals"; } is(is_deeply(\@r, ['a b c', 'b c d', 'c d e', 'd e f', 'e f g', 'f g', 'g']), 1, "slideatatime moving 3 elements by 1 item"); my @a = (1 .. 1000); $it = slideatatime 1, 1, @a; @r = (); while (my @vals = &$it) { push @r, @vals; } is(is_deeply(\@r, \@a), 1, "slideatatime as natatime with 1 element"); leak_free_ok( slideatatime => sub { my @y = 1; my $it = slideatatime 2, 2, @y; while (my @vals = $it->()) { # do nothing } }, 'slideatatime with exception' => sub { my @r; eval { my $it = slideatatime 1, 3, @x; while (my @vals = $it->()) { scalar @vals == 3 or die; push @r, "@vals"; } }; } ); done_testing; List-MoreUtils-0.430/t/inline/occurrences.pm0000644000175000017500000000650713736561312017145 0ustar snosno use Test::More; use Test::LMU; use Tie::Array (); SCOPE: { my $lorem = "Lorem ipsum dolor sit amet, consetetur sadipscing elitr, sed diam nonumy eirmod tempor invidunt ut labore et dolore magna aliquyam erat, sed diam voluptua. At vero eos et accusam et justo duo dolores et ea rebum. Stet clita kasd gubergren, no sea takimata sanctus est Lorem ipsum dolor sit amet. Lorem ipsum dolor sit amet, consetetur sadipscing elitr, sed diam nonumy eirmod tempor invidunt ut labore et dolore magna aliquyam erat, sed diam voluptua. At vero eos et accusam et justo duo dolores et ea rebum. Stet clita kasd gubergren, no sea takimata sanctus est Lorem ipsum dolor sit amet. Lorem ipsum dolor sit amet, consetetur sadipscing elitr, sed diam nonumy eirmod tempor invidunt ut labore et dolore magna aliquyam erat, sed diam voluptua."; my @lorem = grep { $_ } split /(?:\b|\s)/, $lorem; my $n_comma = scalar(split /,/, $lorem) - 1; my $n_dot = scalar(split /\./, $lorem); # there is one at end ... mind the gap my $n_et = scalar(split /\bet\b/, $lorem) - 1; my @l = @lorem; my @o = occurrences @l; is(undef, $o[0], "Each word is counted"); is(undef, $o[1], "Text to long, each word is there at least twice"); is_deeply([','], $o[$n_comma], "$n_comma comma"); is_deeply(['.'], $o[$n_dot], "$n_dot dots"); is_deeply(['et'], $o[$n_et], "$n_et words 'et'"); @o = occurrences grep { /\w+/ } @lorem; my $wc = reduce_0 { defined $b ? $a + $_ * scalar @$b : $a } @o; is($wc, 124, "Words are as many as requested at www.loremipsum.de"); } SCOPE: { my @probes = ((1) x 3, (2) x 4, (3) x 2, (4) x 7, (5) x 2, (6) x 4); my $fp = freeze(\@probes); my @o = map { ref $_ ? [sort @$_] : $_ } occurrences @probes; is($fp, freeze(\@probes), "probes untouched"); my @expectation = (undef, undef, [3, 5], [1], [2, 6], undef, undef, [4]); is_deeply(\@expectation, \@o, "occurrences of integer probes"); } SCOPE: { my @probes = ((1) x 3, undef, (2) x 4, undef, (3) x 2, undef, (4) x 7, undef, (5) x 2, undef, (6) x 4); my $fp = freeze(\@probes); my @o = map { ref $_ ? [sort { (defined $a <=> defined $b) or $a <=> $b } @$_] : $_ } occurrences @probes; is($fp, freeze(\@probes), "probes untouched"); my @expectation = (undef, undef, [3, 5], [1], [2, 6], [undef], undef, [4]); is_deeply(\@expectation, \@o, "occurrences of integer probes"); } leak_free_ok( occurrences => sub { my @probes = ((1) x 3, (2) x 4, (3) x 2, (4) x 7, (5) x 2, (6) x 4); my @o = occurrences @probes; }, 'scalar occurrences' => sub { my @probes = ((1) x 3, (2) x 4, (3) x 2, (4) x 7, (5) x 2, (6) x 4); my $o = occurrences @probes; } ); leak_free_ok( 'occurrences with exception in overloading stringify', sub { eval { my $obj = DieOnStringify->new; my @probes = ((1) x 3, $obj, (2) x 4, $obj, (3) x 2, $obj, (4) x 7, $obj, (5) x 2, $obj, (6) x 4); my @o = occurrences @probes; }; eval { my $obj = DieOnStringify->new; my @probes = ((1) x 3, $obj, (2) x 4, $obj, (3) x 2, $obj, (4) x 7, $obj, (5) x 2, $obj, (6) x 4); my $o = occurrences @probes; }; } ); done_testing; List-MoreUtils-0.430/t/inline/minmaxstr.pm0000644000175000017500000000166413736561312016653 0ustar snosnouse Test::More; use Test::LMU; use POSIX qw(setlocale LC_COLLATE); setlocale(LC_COLLATE, "C"); my @list = reverse 'AA' .. 'ZZ'; my ($min, $max) = minmaxstr @list; is($min, 'AA'); is($max, 'ZZ'); # Odd number of elements push @list, 'ZZ Top'; ($min, $max) = minmaxstr @list; is($min, 'AA'); is($max, 'ZZ Top'); # COW causes missing max when optimization for 1 argument is applied @list = grep { defined $_ } map { my ($min, $max) = minmaxstr(sprintf("%s", rand)); ($min, $max) } (0 .. 19); is(scalar @list, 40, "minmaxstr swallows max on COW"); # Test with a single list value my $input = 'foo'; ($min, $max) = minmaxstr $input; is($min, 'foo'); is($max, 'foo'); # Confirm output are independant copies of input $input = 'bar'; is($min, 'foo'); is($max, 'foo'); $min = 'bar'; is($max, 'foo'); leak_free_ok( minmaxstr => sub { @list = reverse 'AA' .. 'ZZ', 'ZZ Top'; ($min, $max) = minmaxstr @list; } ); done_testing; List-MoreUtils-0.430/t/inline/none.pm0000644000175000017500000000063013736561312015560 0ustar snosno use Test::More; use Test::LMU; # Normal cases my @list = (1 .. 10000); is_true(none { not defined } @list); is_true(none { $_ > 10000 } @list); is_false(none { defined } @list); is_true(none {}); leak_free_ok( none => sub { my $ok = none { $_ == 5000 } @list; my $ok2 = none { $_ == 5000 } 1 .. 10000; } ); is_dying('none without sub' => sub { &none(42, 4711); }); done_testing; List-MoreUtils-0.430/t/inline/minmax.pm0000644000175000017500000000400113736561312016106 0ustar snosno use Test::More; use Test::LMU; my @list = reverse 0 .. 10000; my ($min, $max) = minmax @list; is($min, 0); is($max, 10000); # Even number of elements push @list, 10001; ($min, $max) = minmax @list; is($min, 0); is($max, 10001); $list[0] = 17; # Some floats @list = (0, -1.1, 3.14, 1 / 7, 10000, -10 / 3); ($min, $max) = minmax @list; # Floating-point comparison cunningly avoided is(sprintf("%.2f", $min), "-3.33"); is($max, 10000); # Test with a single negative list value my $input = -1; ($min, $max) = minmax $input; is($min, -1); is($max, -1); # COW causes missing max when optimization for 1 argument is applied @list = grep { defined $_ } map { my ($min, $max) = minmax(sprintf("%.3g", rand)); ($min, $max) } (0 .. 19); is(scalar @list, 40, "minmax swallows max on COW"); # Confirm output are independant copies of input $input = 1; is($min, -1); is($max, -1); $min = 2; is($max, -1); # prove overrun my $uvmax = ~0; my $ivmax = $uvmax >> 1; my $ivmin = (0 - $ivmax) - 1; my @low_ints = map { $ivmin + $_ } (0 .. 10); ($min, $max) = minmax @low_ints; is($min, $ivmin, "minmax finds ivmin"); is($max, $ivmin + 10, "minmax finds ivmin + 10"); my @high_ints = map { $ivmax - $_ } (0 .. 10); ($min, $max) = minmax @high_ints; is($min, $ivmax - 10, "minmax finds ivmax-10"); is($max, $ivmax, "minmax finds ivmax"); my @mixed_ints = map { ($ivmin + $_, $ivmax - $_) } (0 .. 10); ($min, $max) = minmax @mixed_ints; is($min, $ivmin, "minmax finds ivmin"); is($max, $ivmax, "minmax finds ivmax"); my @high_uints = map { $uvmax - $_ } (0 .. 10); ($min, $max) = minmax @high_uints; is($min, $uvmax - 10, "minmax finds uvmax-10"); is($max, $uvmax, "minmax finds uvmax"); my @mixed_nums = map { ($ivmin + $_, $uvmax - $_) } (0 .. 10); ($min, $max) = minmax @mixed_nums; is($min, $ivmin, "minmax finds ivmin"); is($max, $uvmax, "minmax finds uvmax"); leak_free_ok( minmax => sub { @list = (0, -1.1, 3.14, 1 / 7, 10000, -10 / 3); ($min, $max) = minmax @list; } ); done_testing; List-MoreUtils-0.430/t/inline/none_u.pm0000644000175000017500000000065313736561312016111 0ustar snosno use Test::More; use Test::LMU; # Normal cases my @list = (1 .. 10000); is_true(none_u { not defined } @list); is_true(none_u { $_ > 10000 } @list); is_false(none_u { defined } @list); is_undef(none_u {}); leak_free_ok( none_u => sub { my $ok = none_u { $_ == 5000 } @list; my $ok2 = none_u { $_ == 5000 } 1 .. 10000; } ); is_dying('none_u without sub' => sub { &none_u(42, 4711); }); done_testing; List-MoreUtils-0.430/t/inline/firstval.pm0000644000175000017500000000102113736561312016446 0ustar snosnoBEGIN { $INC{'List/MoreUtils.pm'} or *first_value = __PACKAGE__->can("firstval"); } use Test::More; use Test::LMU; my $x = firstval { $_ > 5 } 4 .. 9; is($x, 6); $x = firstval { $_ > 5 } 1 .. 4; is($x, undef); is_undef(firstval { $_ > 5 }); # Test aliases $x = first_value { $_ > 5 } 4 .. 9; is($x, 6); $x = first_value { $_ > 5 } 1 .. 4; is($x, undef); leak_free_ok( firstval => sub { $x = firstval { $_ > 5 } 4 .. 9; } ); is_dying('firstval without sub' => sub { &firstval(42, 4711); }); done_testing; List-MoreUtils-0.430/t/inline/any_u.pm0000644000175000017500000000125413736561312015737 0ustar snosno use Test::More; use Test::LMU; # Normal cases my @list = (1 .. 10000); is_true(any_u { $_ == 5000 } @list); is_true(any_u { $_ == 5000 } 1 .. 10000); is_true(any_u { defined } @list); is_false(any_u { not defined } @list); is_true(any_u { not defined } undef); is_undef(any_u {}); leak_free_ok( any_u => sub { my $ok = any_u { $_ == 5000 } @list; my $ok2 = any_u { $_ == 5000 } 1 .. 10000; } ); leak_free_ok( 'any_u with a coderef that dies' => sub { # This test is from Kevin Ryde; see RT#48669 eval { my $ok = any_u { die } 1; }; } ); is_dying('any_u without sub' => sub { &any_u(42, 4711); }); done_testing; List-MoreUtils-0.430/t/inline/one_u.pm0000644000175000017500000000100513736561312015723 0ustar snosno use Test::More; use Test::LMU; # Normal cases my @list = (1 .. 300); is_true(one_u { 1 == $_ } @list); is_true(one_u { 150 == $_ } @list); is_true(one_u { 300 == $_ } @list); is_false(one_u { 0 == $_ } @list); is_false(one_u { 1 <= $_ } @list); is_false(one_u { !(127 & $_) } @list); is_undef(one_u {}); leak_free_ok( one_u => sub { my $ok = one_u { 150 <= $_ } @list; my $ok2 = one_u { 150 <= $_ } 1 .. 300; } ); is_dying('one_u without sub' => sub { &one_u(42, 4711); }); done_testing; List-MoreUtils-0.430/t/inline/all.pm0000644000175000017500000000061113736561312015370 0ustar snosno use Test::More; use Test::LMU; # Normal cases my @list = (1 .. 10000); is_true(all { defined } @list); is_true(all { $_ > 0 } @list); is_false(all { $_ < 5000 } @list); is_true(all {}); leak_free_ok( all => sub { my $ok = all { $_ == 5000 } @list; my $ok2 = all { $_ == 5000 } 1 .. 10000; } ); is_dying('all without sub' => sub { &all(42, 4711); }); done_testing; List-MoreUtils-0.430/t/inline/after_incl.pm0000644000175000017500000000075513736561312016737 0ustar snosno use Test::More; use Test::LMU; my @x = after_incl { $_ % 5 == 0 } 1 .. 9; is_deeply(\@x, [5, 6, 7, 8, 9], "after 5, included"); @x = after_incl { /foo/ } qw{bar baz}; is_deeply(\@x, [], 'Got the null list'); @x = after_incl { /b/ } qw{bar baz foo}; is_deeply(\@x, [qw{bar baz foo}], "after /b/, included"); leak_free_ok( after_incl => sub { @x = after_incl { /z/ } qw{bar baz foo}; } ); is_dying('after_incl without sub' => sub { &after_incl(42, 4711); }); done_testing; List-MoreUtils-0.430/t/inline/all_u.pm0000644000175000017500000000063413736561312015721 0ustar snosno use Test::More; use Test::LMU; # Normal cases my @list = (1 .. 10000); is_true(all_u { defined } @list); is_true(all_u { $_ > 0 } @list); is_false(all_u { $_ < 5000 } @list); is_undef(all_u {}); leak_free_ok( all_u => sub { my $ok = all_u { $_ == 5000 } @list; my $ok2 = all_u { $_ == 5000 } 1 .. 10000; } ); is_dying('all_u without sub' => sub { &all_u(42, 4711); }); done_testing; List-MoreUtils-0.430/t/inline/each_array.pm0000644000175000017500000000614713736561312016730 0ustar snosno use Test::More; use Test::LMU; SCOPE: { my @a = (7, 3, 'a', undef, 'r'); my @b = qw{ a 2 -1 x }; my $it = each_array @a, @b; my (@r, @idx); while (my ($a, $b) = $it->()) { push @r, $a, $b; push @idx, $it->('index'); } # Do I segfault? I shouldn't. $it->(); is_deeply(\@r, [7, 'a', 3, 2, 'a', -1, undef, 'x', 'r', undef]); is_deeply(\@idx, [0 .. 4]); # Testing two iterators on the same arrays in parallel @a = (1, 3, 5); @b = (2, 4, 6); my $i1 = each_array @a, @b; my $i2 = each_array @a, @b; @r = (); while (my ($a, $b) = $i1->() and my ($c, $d) = $i2->()) { push @r, $a, $b, $c, $d; } is_deeply(\@r, [1, 2, 1, 2, 3, 4, 3, 4, 5, 6, 5, 6]); # Input arrays must not be modified is_deeply(\@a, [1, 3, 5]); is_deeply(\@b, [2, 4, 6]); # This used to give "semi-panic: attempt to dup freed string" # See: my $ea = each_arrayref([1 .. 26], ['A' .. 'Z']); (@a, @b) = (); while (my ($a, $b) = $ea->()) { push @a, $a; push @b, $b; } is_deeply(\@a, [1 .. 26]); is_deeply(\@b, ['A' .. 'Z']); # And this even used to dump core my @nums = 1 .. 26; $ea = each_arrayref(\@nums, ['A' .. 'Z']); (@a, @b) = (); while (my ($a, $b) = $ea->()) { push @a, $a; push @b, $b; } is_deeply(\@a, [1 .. 26]); is_deeply(\@a, \@nums); is_deeply(\@b, ['A' .. 'Z']); } SCOPE: { my @a = (7, 3, 'a', undef, 'r'); my @b = qw/a 2 -1 x/; my $it = each_arrayref \@a, \@b; my (@r, @idx); while (my ($a, $b) = $it->()) { push @r, $a, $b; push @idx, $it->('index'); } # Do I segfault? I shouldn't. $it->(); is_deeply(\@r, [7, 'a', 3, 2, 'a', -1, undef, 'x', 'r', undef]); is_deeply(\@idx, [0 .. 4]); # Testing two iterators on the same arrays in parallel @a = (1, 3, 5); @b = (2, 4, 6); my $i1 = each_array @a, @b; my $i2 = each_array @a, @b; @r = (); while (my ($a, $b) = $i1->() and my ($c, $d) = $i2->()) { push @r, $a, $b, $c, $d; } is_deeply(\@r, [1, 2, 1, 2, 3, 4, 3, 4, 5, 6, 5, 6]); # Input arrays must not be modified is_deeply(\@a, [1, 3, 5]); is_deeply(\@b, [2, 4, 6]); } # Note that the leak_free_ok tests for each_array and each_arrayref # should not be run until either of them has been called at least once # in the current perl. That's because calling them the first time # causes the runtime to allocate some memory used for the OO structures # that their implementation uses internally. leak_free_ok( each_array => sub { my @a = (1); my $it = each_array @a; while (my ($a) = $it->()) { } } ); leak_free_ok( each_arrayref => sub { my @a = (1); my $it = each_arrayref \@a; while (my ($a) = $it->()) { } } ); is_dying('each_array without sub' => sub { &each_array(42, 4711); }); is_dying('each_arrayref without sub' => sub { &each_arrayref(42, 4711); }); done_testing; List-MoreUtils-0.430/t/inline/apply.pm0000644000175000017500000000322713736561312015753 0ustar snosno use Test::More; use Test::LMU; # Test the null case my $null_scalar = apply {}; is($null_scalar, undef, 'apply(null) returns undef'); my @null_list = apply {}; is_deeply(\@null_list, [], 'apply(null) returns null list'); # Normal cases my @list = (0 .. 9); my @list1 = apply { $_++ } @list; is_deeply(\@list, [0 .. 9], "original numbers untouched"); is_deeply(\@list1, [1 .. 10], "returned numbers increased"); @list = (" foo ", " bar ", " ", "foobar"); @list1 = apply { s/^\s+|\s+$//g } @list; is_deeply(\@list, [" foo ", " bar ", " ", "foobar"], "original strings untouched"); is_deeply(\@list1, ["foo", "bar", "", "foobar"], "returned strings stripped"); my $item = apply { s/^\s+|\s+$//g } @list; is($item, "foobar"); # RT 96596 SKIP: { $INC{'List/MoreUtils/XS.pm'} or skip "PurePerl will not fail here ...", 1; eval { my @a = \&apply(1, 2); }; my $err = $@; like($err, qr/\QList::MoreUtils::XS::apply(code, ...)\E/, "apply must be reasonable invoked"); } # RT 38630 SCOPE: { # wrong results from apply() [XS] @list = (1 .. 4); @list1 = apply { grow_stack(); $_ = 5; } @list; is_deeply(\@list, [1 .. 4]); is_deeply(\@list1, [(5) x 4]); } leak_free_ok( apply => sub { @list = (1 .. 4); @list1 = apply { grow_stack(); $_ = 5; } @list; } ); SCOPE: { leak_free_ok( 'dying callback during apply' => sub { my @l = (1 .. 4); eval { my @l1 = apply { $_ % 2 or die "Even!"; $_ %= 2; } @l; }; } ); } is_dying('apply without sub' => sub { &apply(42, 4711); }); done_testing; List-MoreUtils-0.430/t/inline/after.pm0000644000175000017500000000103713736561312015724 0ustar snosno use Test::More; use Test::LMU; my @x = after { $_ % 5 == 0 } 1 .. 9; is_deeply(\@x, [6, 7, 8, 9], "after 5"); @x = after { /foo/ } qw{bar baz}; is_deeply(\@x, [], 'Got the null list'); @x = after { /b/ } qw{bar baz foo }; is_deeply(\@x, [qw{baz foo }], "after /b/"); leak_free_ok( after => sub { @x = after { /z/ } qw{bar baz foo}; } ); is_dying('after without sub' => sub { &after(42, 4711); }); @x = (1, after { /foo/ } qw(abc def)); is_deeply(\@x, [1], "check XS implementation doesn't mess up stack"); done_testing; List-MoreUtils-0.430/t/.perltidyrc0000644000175000017500000000017413735543525015177 0ustar snosno-b -bl -noll -pt=2 -bt=2 -sbt=2 -vt=0 -vtc=0 -dws -aws -nsfs -asc -bbt=0 -cab=0 -l=130 -ole=unix --noblanks-before-comments List-MoreUtils-0.430/t/pureperl/0000755000175000017500000000000013744044757014654 5ustar snosnoList-MoreUtils-0.430/t/pureperl/slide.t0000644000175000017500000000073413744044755016143 0ustar snosno#!perl use strict ("subs", "vars", "refs"); use warnings ("all"); BEGIN { $ENV{LIST_MOREUTILS_PP} = 1; } END { delete $ENV{LIST_MOREUTILS_PP} } # for VMS use lib ("t/lib"); use List::MoreUtils (":all"); use Test::More; use Test::LMU; # use case provided my Michael Schwern my @ol = (0 .. 3); is(join(", ", slide { "$a and $b" } @ol), "0 and 1, 1 and 2, 2 and 3", "M. Schwern requested example"); is_dying('slide without sub' => sub { &slide(0 .. 3); }); done_testing; List-MoreUtils-0.430/t/pureperl/zip6.t0000644000175000017500000000236513744044755015735 0ustar snosno#!perl use strict ("subs", "vars", "refs"); use warnings ("all"); BEGIN { $ENV{LIST_MOREUTILS_PP} = 1; } END { delete $ENV{LIST_MOREUTILS_PP} } # for VMS use lib ("t/lib"); use List::MoreUtils (":all"); use Test::More; use Test::LMU; SCOPE: { my @x = qw/a b c d/; my @y = qw/1 2 3 4/; my @z = zip6 @x, @y; is_deeply(\@z, [['a', 1], ['b', 2], ['c', 3], ['d', 4]], "zip6 two lists with same count of elements"); } SCOPE: { my @a = ('x'); my @b = ('1', '2'); my @c = qw/zip zap zot/; my @z = zip6 @a, @b, @c; is_deeply( \@z, [['x', 1, 'zip'], [undef, 2, 'zap'], [undef, undef, 'zot']], "zip6 three list with increasing count of elements" ); } # Make array with holes SCOPE: { my @a = (1 .. 10); my @d; $#d = 9; my @z = zip6 @a, @d; is_deeply( \@z, [[1, undef], [2, undef], [3, undef], [4, undef], [5, undef], [6, undef], [7, undef], [8, undef], [9, undef], [10, undef]], "zip6 one list with 9 elements with an empty list" ); } leak_free_ok( zip6 => sub { my @x = qw/a b c d e/; my @y = qw/1 2 3 4/; my @z = zip6 @x, @y; } ); is_dying('zip6 with a list, not at least two arrays' => sub { &zip6(1, 2); }); done_testing; List-MoreUtils-0.430/t/pureperl/reduce_u.t0000644000175000017500000000223713744044755016636 0ustar snosno#!perl use strict ("subs", "vars", "refs"); use warnings ("all"); BEGIN { $ENV{LIST_MOREUTILS_PP} = 1; } END { delete $ENV{LIST_MOREUTILS_PP} } # for VMS use lib ("t/lib"); use List::MoreUtils (":all"); use Test::More; use Test::LMU; use List::Util qw(sum); SCOPE: { my @exam_results = (0, 2, 4, 6, 5, 3, 0); my $pupil = sum @exam_results; my $wa = reduce_u { defined $a ? $a + $_ * $b / $pupil : 0 } @exam_results; $wa = sprintf("%0.2f", $wa); is($wa, 3.15, "weighted average of exam"); } leak_free_ok( 'reduce_u' => sub { my @exam_results = (undef, 2, 4, 6, 5, 3, 0); my $pupil = 20; my $wa = reduce_u { defined $a ? $a + $_ * $b / $pupil : 0 } @exam_results; }, 'reduce_u X' => sub { my @w = map { int(rand(5)) + 1; } 1 .. 100; my $c1 = reduce_u { ($a || 0) + $w[$_] * $b } 1 .. 100; } ); leak_free_ok( 'reduce_u with a coderef that dies' => sub { # This test is from Kevin Ryde; see RT#48669 eval { my $ok = reduce_u { die } 1; }; } ); is_dying('reduce_u without sub' => sub { &reduce_u(42, 4711); }); done_testing List-MoreUtils-0.430/t/pureperl/equal_range.t0000644000175000017500000000253313744044755017325 0ustar snosno#!perl use strict ("subs", "vars", "refs"); use warnings ("all"); BEGIN { $ENV{LIST_MOREUTILS_PP} = 1; } END { delete $ENV{LIST_MOREUTILS_PP} } # for VMS use lib ("t/lib"); use List::MoreUtils (":all"); use Test::More; use Test::LMU; my @list = (1, 1, 2, 2, 3, 3, 3, 3, 3, 3, 4, 4, 4, 4, 5, 5, 6, 7, 7, 7, 8, 8, 9, 9, 9, 9, 9, 11, 13, 13, 13, 17); is_deeply([0, 0], [equal_range { $_ <=> 0 } @list], "equal range 0"); is_deeply([0, 2], [equal_range { $_ <=> 1 } @list], "equal range 1"); is_deeply([2, 4], [equal_range { $_ <=> 2 } @list], "equal range 2"); is_deeply([10, 14], [equal_range { $_ <=> 4 } @list], "equal range 4"); is_deeply([(scalar @list) x 2], [equal_range { $_ <=> 19 } @list], "equal range 19"); my @in = @list = 1 .. 100; leak_free_ok( equal_range => sub { my $elem = int(rand(101)) + 1; equal_range { $_ - $elem } @list; } ); leak_free_ok( 'equal_range with stack-growing' => sub { my $elem = int(rand(101)); equal_range { grow_stack(); $_ - $elem } @list; } ); leak_free_ok( 'equal_range with stack-growing and exception' => sub { my $elem = int(rand(101)); eval { equal_range { grow_stack(); $_ - $elem or die "Goal!"; $_ - $elem } @list; }; } ); is_dying('equal_range without sub' => sub { &equal_range(42, (1 .. 100)); }); done_testing; List-MoreUtils-0.430/t/pureperl/none_u.t0000644000175000017500000000117213744044755016323 0ustar snosno#!perl use strict ("subs", "vars", "refs"); use warnings ("all"); BEGIN { $ENV{LIST_MOREUTILS_PP} = 1; } END { delete $ENV{LIST_MOREUTILS_PP} } # for VMS use lib ("t/lib"); use List::MoreUtils (":all"); use Test::More; use Test::LMU; # Normal cases my @list = (1 .. 10000); is_true(none_u { not defined } @list); is_true(none_u { $_ > 10000 } @list); is_false(none_u { defined } @list); is_undef(none_u {}); leak_free_ok( none_u => sub { my $ok = none_u { $_ == 5000 } @list; my $ok2 = none_u { $_ == 5000 } 1 .. 10000; } ); is_dying('none_u without sub' => sub { &none_u(42, 4711); }); done_testing; List-MoreUtils-0.430/t/pureperl/samples.t0000644000175000017500000000222113744044755016500 0ustar snosno#!perl use strict ("subs", "vars", "refs"); use warnings ("all"); BEGIN { $ENV{LIST_MOREUTILS_PP} = 1; } END { delete $ENV{LIST_MOREUTILS_PP} } # for VMS use lib ("t/lib"); use List::MoreUtils (":all"); use Test::More; use Test::LMU; SCOPE: { my @l = (1 .. 100); my @s = samples 10, @l; is(scalar @s, 10, "samples stops correctly after 10 integer probes"); my @u = uniq @s; is(scalar @u, 10, "samples doesn't add any integer twice"); } SCOPE: { my @l = (1 .. 10); my @s = samples 10, @l; is(scalar @s, 10, "samples delivers 10 out of 10 when used as shuffle"); my @u = uniq grep { defined $_ } @s; is(scalar @u, 10, "samples doesn't add any integer twice"); } SCOPE: { my @l = ('AA' .. 'ZZ'); my @s = samples 10, @l; is(scalar @s, 10, "samples stops correctly after 10 strings probes"); my @u = uniq @s; is(scalar @u, 10, "samples doesn't add any string twice"); } is_dying('to much samples' => sub { my @l = (1 .. 3); samples 5, @l }); SKIP: { $INC{'List/MoreUtils/XS.pm'} or skip "PurePerl will not fail here ...", 1; is_dying('samples without list' => sub { samples 5 }); } done_testing; List-MoreUtils-0.430/t/pureperl/mode.t0000644000175000017500000004022513744044755015766 0ustar snosno#!perl use strict ("subs", "vars", "refs"); use warnings ("all"); BEGIN { $ENV{LIST_MOREUTILS_PP} = 1; } END { delete $ENV{LIST_MOREUTILS_PP} } # for VMS use lib ("t/lib"); use List::MoreUtils (":all"); use Test::More; use Test::LMU; use Tie::Array (); SCOPE: { my $lorem = "Lorem ipsum dolor sit amet, consetetur sadipscing elitr, sed diam nonumy eirmod tempor invidunt ut labore et dolore magna aliquyam erat, sed diam voluptua. At vero eos et accusam et justo duo dolores et ea rebum. Stet clita kasd gubergren, no sea takimata sanctus est Lorem ipsum dolor sit amet. Lorem ipsum dolor sit amet, consetetur sadipscing elitr, sed diam nonumy eirmod tempor invidunt ut labore et dolore magna aliquyam erat, sed diam voluptua. At vero eos et accusam et justo duo dolores et ea rebum. Stet clita kasd gubergren, no sea takimata sanctus est Lorem ipsum dolor sit amet. Lorem ipsum dolor sit amet, consetetur sadipscing elitr, sed diam nonumy eirmod tempor invidunt ut labore et dolore magna aliquyam erat, sed diam voluptua."; my @lorem = grep { $_ } split /(?:\b|\s)/, $lorem; my $fl = freeze(\@lorem); my $n_comma = scalar(split /,/, $lorem) - 1; my @m = mode @lorem; is($fl, freeze(\@lorem), "mode:G_ARRAY lorem untouched"); is_deeply([$n_comma, ','], \@m, "lorem mode as list"); my $m = mode @lorem; is($fl, freeze(\@lorem), "mode:G_SCALAR lorem untouched"); is($n_comma, $m, "lorem mode as scalar"); } SCOPE: { my @probes = ((1) x 3, (2) x 4, (3) x 2, (4) x 7, (5) x 2, (6) x 4); my $fp = freeze(\@probes); my @m = mode @probes; is($fp, freeze(\@probes), "mode:G_ARRAY probes untouched"); is_deeply([7, 4], \@m, "unimodal result in list context"); my $m = mode @probes; is($fp, freeze(\@probes), "mode:G_SCALAR probes untouched"); is(7, $m, "unimodal result in scalar context"); } SCOPE: { my @probes = ((1) x 3, (2) x 4, (3) x 2, (4) x 7, (5) x 2, (6) x 4, (7) x 3, (8) x 7); my $fp = freeze(\@probes); my @m = mode @probes; is($fp, freeze(\@probes), "bimodal mode:G_ARRAY probes untouched"); my $m = shift @m; @m = sort @m; unshift @m, $m; is_deeply([7, 4, 8], \@m, "bimodal result in list context"); $m = mode @probes; is($fp, freeze(\@probes), "bimodal mode:G_SCALAR probes untouched"); is(7, $m, "bimodal result in scalar context"); } SCOPE: { my %radio_ukw_nrw = ( "87,6" => "WDR Eins Live", "87,7" => "WDR 5", "87,7" => "Welle Niederrhein", "87,7" => "WDR 5", "87,8" => "Welle West", "87,8" => "WDR 4", "87,8" => "WDR 2 Dortmund", "87,9" => "Radio HERTZ", "88,0" => "WDR 5", "88,1" => "Radio Hochstift", "88,2" => "Radio Kiepenkerl", "88,2" => "Radio Siegen", "88,3" => "WDR 5", "88,3" => "Radio MK", "88,4" => "WDR 2 Köln", "88,4" => "Radio WMW", "88,4" => "WDR 5", "88,5" => "WDR 5", "88,5" => "Werrepark Radio", "88,5" => "WDR 5", "88,6" => "WDR 5", "88,7" => "WDR 3", "88,8" => "WDR 5", "88,9" => "Deutschlandradio Kultur", "89,0" => "Lokalradio Olpe", "89,1" => "Deutschlandfunk (DLF)", "89,1" => "Radio Sauerland", "89,2" => "WDR (Test)", "89,3" => "Antenne Unna", "89,4" => "NE-WS 89,4", "89,4" => "L`UniCo FM", "89,6" => "WDR 5", "89,7" => "WDR 3", "90,0" => "CT das radio", "90,0" => "WDR 5", "90,1" => "WDR 4", "90,1" => "Deutschlandradio Kultur", "90,1" => "Radio 90,1", "90,3" => "WDR 5", "90,6" => "WDR 5", "90,7" => "WDR 4", "90,8" => "Radio Herne", "90,8" => "Radio MK", "90,9" => "Radio Q", "91,0" => "Deutschlandradio Kultur", "91,0" => "Deutschlandfunk (DLF)", "91,2" => "WDR (Test)", "91,2" => "Radio 91,2", "91,2" => "Radio Bonn/Rhein-Sieg", "91,3" => "Radio Lippe (geplant)", "91,3" => "Deutschlandfunk (DLF)", "91,3" => "BFBS Radio 1", "91,4" => "Radio Erft", "91,5" => "Radio MK", "91,5" => "Deutschlandfunk (DLF)", "91,5" => "Radio Ennepe Ruhr", "91,7" => "WDR 4", "91,7" => "BFBS Radio 2", "91,7" => "WDR 3", "91,7" => "Radio K.W.", "91,7" => "Radio Herford", "91,8" => "WDR 2 Wuppertal", "91,8" => "WDR 2 Bielefeld", "91,9" => "WDR 4", "92,0" => "WDR 5", "92,0" => "domradio", "92,1" => "Radius 92,1", "92,2" => "Radio Duisburg", "92,2" => "Deutschlandfunk (DLF)", "92,2" => "Radio RSG", "92,3" => "WDR 2 Siegen", "92,5" => "BFBS Radio 1", "92,5" => "Radio MK", "92,6" => "Radio WAF", "92,7" => "WDR 3", "92,7" => "Radio Rur", "92,7" => "Radio Ennepe Ruhr", "92,9" => "Radio Mülheim", "93,0" => "Radio WMW", "93,0" => "elDOradio", "93,1" => "WDR 3", "93,2" => "WDR 2 Bielefeld", "93,3" => "WDR 2 Rhein-Ruhr", "93,5" => "WDR 2 Siegen", "93,6" => "WDR Eins Live", "93,7" => "Radio Hochstift", "93,8" => "WDR 2 Siegen", "93,9" => "WDR 4", "93,9" => "Deutschlandfunk (DLF)", "93,9" => "WDR 5", "94,1" => "WDR 2 Münster", "94,2" => "Radio Bonn/Rhein-Sieg", "94,2" => "WDR 2 Aachen", "94,2" => "Deutschlandfunk (DLF)", "94,3" => "Antenne Bethel", "94,3" => "Radio RSG", "94,3" => "WDR 3", "94,5" => "Deutschlandfunk (DLF)", "94,6" => "Radio MK", "94,6" => "Test FM", "94,6" => "Deutschlandradio Kultur", "94,6" => "Radio Vest", "94,7" => "Radio FH", "94,7" => "Radio WAF", "94,8" => "WDR (Test)", "94,8" => "Radio Sauerland", "94,9" => "Radio Herford", "95,1" => "WDR 3", "95,1" => "Radio Westfalica", "95,2" => "WDR 3", "95,4" => "Antenne Münster", "95,5" => "Deutschlandfunk (DLF)", "95,6" => "Radio Vest", "95,7" => "Radio WAF", "95,7" => "Radio Westfalica", "95,7" => "WDR 2 Wuppertal", "95,8" => "WDR 5", "95,9" => "WDR 3", "95,9" => "Triquency", "95,9" => "Radio Gütersloh", "96,0" => "WDR Eins Live", "96,0" => "WDR 2 Münster", "96,0" => "WDR 2 Bielefeld", "96,1" => "Radio Emscher Lippe", "96,1" => "WDR 4", "96,1" => "Triquency", "96,2" => "Radio Sauerland", "96,3" => "WDR 3", "96,3" => "Radio WAF", "96,3" => "Deutschlandradio Kultur", "96,4" => "Radio Siegen (geplant)", "96,4" => "WDR 2 Bielefeld", "96,5" => "Deutschlandradio Kultur", "96,8" => "bonn FM", "96,9" => "Deutschlandradio Kultur", "96,9" => "Radio Berg", "97,0" => "WDR 3", "97,1" => "Antenne GL", "97,1" => "Hochschulradio Düsseldorf", "97,1" => "WDR 2 Siegen", "97,2" => "107.8 Antenne AC", "97,2" => "Radio MK", "97,3" => "Radio Siegen", "97,3" => "WDR 3", "97,3" => "WDR 3", "97,4" => "Antenne Unna", "97,5" => "WDR 3", "97,5" => "Deutschlandradio Kultur", "97,6" => "Radio WMW", "97,6" => "WDR (Test)", "97,6" => "Radio Bielefeld", "97,6" => "Radio Neandertal", "97,6" => "WDR 5", "97,7" => "Deutschlandradio Kultur", "97,8" => "Radio Bonn/Rhein-Sieg", "97,8" => "WDR 3", "98,0" => "Antenne Niederrhein", "98,1" => "WDR 3", "98,2" => "WDR 3", "98,2" => "WDR Eins Live", "98,3" => "Radio Bielefeld", "98,4" => "WDR 3", "98,5" => "Radio Bochum", "98,6" => "WDR 2 + Messeradio Köln", "98,6" => "WDR 5", "98,7" => "Radio Emscher Lippe", "98,9" => "Deutschlandradio Kultur", "98,9" => "Lokalradio Olpe", "98,9" => "Radio Siegen", "99,1" => "Hochschulradio Aachen", "99,1" => "WDR 2 Bielefeld", "99,2" => "WDR 2 Rhein-Ruhr", "99,4" => "WDR 2 Siegen", "99,4" => "Triquency", "99,5" => "WDR 4", "99,5" => "Radio MK", "99,6" => "WDR 4", "99,7" => "Radio Euskirchen", "99,7" => "WDR 5", "99,7" => "Radio Berg", "99,7" => "WDR Eins Live", "99,8" => "WDR 2 Wuppertal", "99,9" => "Radio Bonn/Rhein-Sieg", "100,0" => "Kölncampus", "100,0" => "WDR 4", "100,1" => "107.8 Antenne AC", "100,1" => "WDR Eins Live", "100,2" => "Radio MK", "100,2" => "Deutschlandradio Kultur", "100,4" => "WDR 2 Köln", "100,5" => "WDR 4", "100,6" => "Welle Niederrhein", "100,7" => "WDR 4", "100,8" => "WDR 2 Aachen", "100,9" => "Hellweg Radio", "101,0" => "WDR 2 Aachen", "101,0" => "Radio Lippe", "101,1" => "WDR 4", "101,1" => "Deutschlandradio Kultur", "101,2" => "WDR 4", "101,3" => "WDR 4", "101,6" => "BFBS Radio 2", "101,7" => "WDR 4", "101,7" => "domradio", "101,8" => "WDR 2 Siegen", "101,9" => "WDR 5", "101,9" => "BFBS Radio 1", "102,1" => "NE-WS 89,4", "102,1" => "WDR 2 Siegen", "102,2" => "Radio Essen", "102,2" => "BFBS Radio 2", "102,3" => "Antenne Unna", "102,4" => "WDR Eins Live", "102,5" => "WDR Eins Live", "102,7" => "Deutschlandfunk (DLF)", "102,7" => "Deutschlandfunk (DLF)", "102,8" => "Deutschlandfunk (DLF)", "103,0" => "BFBS Radio 1", "103,3" => "Funkhaus Europa", "103,6" => "Radio WMW", "103,6" => "Hellweg Radio", "103,7" => "WDR Eins Live", "103,8" => "WDR 4", "103,9" => "Radio Q", "104,0" => "BFBS Radio 1", "104,0" => "Radio RST", "104,1" => "WDR 4", "104,2" => "Radio Bonn/Rhein-Sieg", "104,2" => "Antenne Düsseldorf", "104,2" => "Radio Ennepe Ruhr", "104,3" => "BFBS Radio 2", "104,4" => "WDR 4", "104,4" => "Deutschlandfunk (DLF)", "104,5" => "CampusFM", "104,5" => "Deutschlandfunk (DLF)", "104,5" => "WDR 4", "104,7" => "WDR Eins Live", "104,8" => "Radio Hochstift", "104,8" => "Radio Hochstift", "104,9" => "Radio Sauerland", "105,0" => "Radio Essen", "105,0" => "Radio Lippe Welle Hamm", "105,0" => "107.8 Antenne AC", "105,0" => "BFBS Radio 2", "105,1" => "BFBS Radio 1", "105,2" => "Radio Vest", "105,2" => "Radio Berg", "105,2" => "Radio RST", "105,4" => "Radio Siegen", "105,5" => "WDR Eins Live", "105,5" => "WDR Eins Live", "105,6" => "CampusFM", "105,7" => "Antenne Niederrhein", "105,7" => "Radio Ennepe Ruhr", "105,7" => "WDR Eins Live", "105,7" => "Radio Berg", "105,8" => "Radio Erft", "106,0" => "BFBS Radio 1", "106,1" => "Deutschlandradio Kultur", "106,1" => "Deutschlandradio Kultur", "106,2" => "Deutschlandradio Kultur", "106,2" => "106.2 Radio Oberhausen", "106,3" => "Radio Kiepenkerl", "106,4" => "WDR Eins Live", "106,5" => "Radio Sauerland", "106,5" => "Radio Sauerland", "106,5" => "Radio St. Laurentius", "106,6" => "Radio Lippe", "106,6" => "Radio Westfalica", "106,6" => "Deutschlandfunk (DLF)", "106,7" => "WDR Eins Live", "106,8" => "Radio Gütersloh", "106,9" => "Radio Euskirchen", "107,0" => "WDR Eins Live", "107,1" => "Radio Köln", "107,2" => "WDR Eins Live", "107,2" => "Deutschlandfunk (DLF)", "107,3" => "WDR Eins Live", "107,3" => "Hellweg Radio", "107,4" => "Radio Euskirchen", "107,4" => "Radio Kiepenkerl", "107,4" => "Radio Lippe", "107,4" => "Radio Wuppertal", "107,5" => "Radio Rur", "107,5" => "Radio Gütersloh", "107,5" => "WDR Eins Live", "107,6" => "Radio Leverkusen", "107,6" => "Radio Sauerland", "107,6" => "Radio K.W.", "107,7" => "WDR Eins Live", "107,7" => "Hellweg Radio", "107,7" => "107.7 Radio Hagen", "107,8" => "107.8 Antenne AC", "107,8" => "Lokalradio Olpe", "107,9" => "Radio Bonn/Rhein-Sieg", "107,9" => "WDR Eins Live", "107,9" => "Radio RSG", ); my @m = mode values %radio_ukw_nrw; my $m = shift @m; @m = sort @m; unshift @m, $m; is_deeply([14, 'WDR 5', 'WDR Eins Live'], \@m, "multimodal result in list context"); $m = mode values %radio_ukw_nrw; is(14, $m, "multimodal result in scalar context"); } leak_free_ok( 'mode (unimodal)' => sub { my @probes = ((1) x 3, (2) x 4, (3) x 2, (4) x 7, (5) x 2, (6) x 4); my @m = mode @probes; }, 'scalar mode (unimodal)' => sub { my @probes = ((1) x 3, (2) x 4, (3) x 2, (4) x 7, (5) x 2, (6) x 4); my $m = mode @probes; }, 'mode (bimodal)' => sub { my @probes = ((1) x 3, (2) x 4, (3) x 2, (4) x 7, (5) x 2, (6) x 4, (7) x 3, (8) x 7); my @m = mode @probes; }, 'scalar mode (bimodal)' => sub { my @probes = ((1) x 3, (2) x 4, (3) x 2, (4) x 7, (5) x 2, (6) x 4, (7) x 3, (8) x 7); my $m = mode @probes; }, 'mode (multimodal)' => sub { my @probes = ((1) x 3, (2) x 4, (3) x 2, (4) x 7, (5) x 2, (6) x 4, (7) x 3, (8) x 7, (9) x 4, (10) x 3, (11) x 7); my @m = mode @probes; }, 'scalar mode (multimodal)' => sub { my @probes = ((1) x 3, (2) x 4, (3) x 2, (4) x 7, (5) x 2, (6) x 4, (7) x 3, (8) x 7, (9) x 4, (10) x 3, (11) x 7); my $m = mode @probes; }, ); leak_free_ok( 'mode (unimodal) with exception in overloading stringify' => sub { eval { my $obj = DieOnStringify->new; my @probes = ((1) x 3, $obj, (2) x 4, $obj, (3) x 2, $obj, (4) x 7, $obj, (5) x 2, $obj, (6) x 4); my @m = mode @probes; }; }, 'scalar mode (unimodal) with exception in overloading stringify' => sub { eval { my $obj = DieOnStringify->new; my @probes = ((1) x 3, $obj, (2) x 4, $obj, (3) x 2, $obj, (4) x 7, $obj, (5) x 2, $obj, (6) x 4); my $m = mode @probes; }; }, 'mode (bimodal) with exception in overloading stringify' => sub { eval { my $obj = DieOnStringify->new; my @probes = ((1) x 3, $obj, (2) x 4, $obj, (3) x 2, $obj, (4) x 7, $obj, (5) x 2, $obj, (6) x 4, $obj, (7) x 3, $obj, (8) x 7); my @m = mode @probes; }; }, 'scalar mode (bimodal) with exception in overloading stringify' => sub { eval { my $obj = DieOnStringify->new; my @probes = ((1) x 3, $obj, (2) x 4, $obj, (3) x 2, $obj, (4) x 7, $obj, (5) x 2, $obj, (6) x 4, $obj, (7) x 3, $obj, (8) x 7); my $m = mode @probes; }; }, 'mode (multimodal) with exception in overloading stringify' => sub { eval { my $obj = DieOnStringify->new; my @probes = ( (1) x 3, $obj, (2) x 4, $obj, (3) x 2, $obj, (4) x 7, $obj, (5) x 2, $obj, (6) x 4, $obj, (7) x 3, $obj, (8) x 7, $obj, (9) x 4, $obj, (10) x 3, $obj, (11) x 7 ); my @m = mode @probes; }; }, 'scalar mode (multimodal) with exception in overloading stringify' => sub { eval { my $obj = DieOnStringify->new; my @probes = ( (1) x 3, $obj, (2) x 4, $obj, (3) x 2, $obj, (4) x 7, $obj, (5) x 2, $obj, (6) x 4, $obj, (7) x 3, $obj, (8) x 7, $obj, (9) x 4, $obj, (10) x 3, $obj, (11) x 7 ); my $m = mode @probes; }; }, ); done_testing; List-MoreUtils-0.430/t/pureperl/all_u.t0000644000175000017500000000115313744044755016133 0ustar snosno#!perl use strict ("subs", "vars", "refs"); use warnings ("all"); BEGIN { $ENV{LIST_MOREUTILS_PP} = 1; } END { delete $ENV{LIST_MOREUTILS_PP} } # for VMS use lib ("t/lib"); use List::MoreUtils (":all"); use Test::More; use Test::LMU; # Normal cases my @list = (1 .. 10000); is_true(all_u { defined } @list); is_true(all_u { $_ > 0 } @list); is_false(all_u { $_ < 5000 } @list); is_undef(all_u {}); leak_free_ok( all_u => sub { my $ok = all_u { $_ == 5000 } @list; my $ok2 = all_u { $_ == 5000 } 1 .. 10000; } ); is_dying('all_u without sub' => sub { &all_u(42, 4711); }); done_testing; List-MoreUtils-0.430/t/pureperl/true.t0000644000175000017500000000143313744044755016017 0ustar snosno#!perl use strict ("subs", "vars", "refs"); use warnings ("all"); BEGIN { $ENV{LIST_MOREUTILS_PP} = 1; } END { delete $ENV{LIST_MOREUTILS_PP} } # for VMS use lib ("t/lib"); use List::MoreUtils (":all"); use Test::More; use Test::LMU; # The null set should return zero my $null_scalar = true {}; my @null_list = true {}; is($null_scalar, 0, 'true(null) returns undef'); is_deeply(\@null_list, [0], 'true(null) returns undef'); # Normal cases my @list = (1 .. 10000); is(10000, true { defined } @list); is(0, true { not defined } @list); is(1, true { $_ == 5000 } @list); leak_free_ok( true => sub { my $n = true { $_ == 5000 } @list; my $n2 = true { $_ == 5000 } 1 .. 10000; } ); is_dying('true without sub' => sub { &true(42, 4711); }); done_testing; List-MoreUtils-0.430/t/pureperl/reduce_0.t0000644000175000017500000000217113744044755016526 0ustar snosno#!perl use strict ("subs", "vars", "refs"); use warnings ("all"); BEGIN { $ENV{LIST_MOREUTILS_PP} = 1; } END { delete $ENV{LIST_MOREUTILS_PP} } # for VMS use lib ("t/lib"); use List::MoreUtils (":all"); use Test::More; use Test::LMU; use List::Util qw(sum); SCOPE: { my @exam_results = (2, 4, 6, 5, 3, 0); my $pupil = sum @exam_results; my $wa = reduce_0 { $a + ($_ + 1) * $b / $pupil } @exam_results; $wa = sprintf("%0.2f", $wa); is($wa, 3.15, "weighted average of exam"); } leak_free_ok( 'reduce_0' => sub { my @exam_results = (2, 4, 6, 5, 3, 0); my $pupil = 20; my $wa = reduce_0 { $a + ($_ + 1) * $b / $pupil } @exam_results; }, 'reduce_0 X' => sub { my @w = map { int(rand(5)) + 1; } 1 .. 100; my $c1 = reduce_0 { $a + $w[$_] * $b } 1 .. 100; } ); leak_free_ok( 'reduce_0 with a coderef that dies' => sub { # This test is from Kevin Ryde; see RT#48669 eval { my $ok = reduce_0 { die } 1; }; } ); is_dying('reduce_0 without sub' => sub { &reduce_0(42, 4711); }); done_testing List-MoreUtils-0.430/t/pureperl/notall.t0000644000175000017500000000117313744044755016332 0ustar snosno#!perl use strict ("subs", "vars", "refs"); use warnings ("all"); BEGIN { $ENV{LIST_MOREUTILS_PP} = 1; } END { delete $ENV{LIST_MOREUTILS_PP} } # for VMS use lib ("t/lib"); use List::MoreUtils (":all"); use Test::More; use Test::LMU; # Normal cases my @list = (1 .. 10000); is_true(notall { !defined } @list); is_true(notall { $_ < 10000 } @list); is_false(notall { $_ <= 10000 } @list); is_false(notall {}); leak_free_ok( notall => sub { my $ok = notall { $_ == 5000 } @list; my $ok2 = notall { $_ == 5000 } 1 .. 10000; } ); is_dying('notall without sub' => sub { ¬all(42, 4711); }); done_testing; List-MoreUtils-0.430/t/pureperl/apply.t0000644000175000017500000000354613744044755016174 0ustar snosno#!perl use strict ("subs", "vars", "refs"); use warnings ("all"); BEGIN { $ENV{LIST_MOREUTILS_PP} = 1; } END { delete $ENV{LIST_MOREUTILS_PP} } # for VMS use lib ("t/lib"); use List::MoreUtils (":all"); use Test::More; use Test::LMU; # Test the null case my $null_scalar = apply {}; is($null_scalar, undef, 'apply(null) returns undef'); my @null_list = apply {}; is_deeply(\@null_list, [], 'apply(null) returns null list'); # Normal cases my @list = (0 .. 9); my @list1 = apply { $_++ } @list; is_deeply(\@list, [0 .. 9], "original numbers untouched"); is_deeply(\@list1, [1 .. 10], "returned numbers increased"); @list = (" foo ", " bar ", " ", "foobar"); @list1 = apply { s/^\s+|\s+$//g } @list; is_deeply(\@list, [" foo ", " bar ", " ", "foobar"], "original strings untouched"); is_deeply(\@list1, ["foo", "bar", "", "foobar"], "returned strings stripped"); my $item = apply { s/^\s+|\s+$//g } @list; is($item, "foobar"); # RT 96596 SKIP: { $INC{'List/MoreUtils/XS.pm'} or skip "PurePerl will not fail here ...", 1; eval { my @a = \&apply(1, 2); }; my $err = $@; like($err, qr/\QList::MoreUtils::XS::apply(code, ...)\E/, "apply must be reasonable invoked"); } # RT 38630 SCOPE: { # wrong results from apply() [XS] @list = (1 .. 4); @list1 = apply { grow_stack(); $_ = 5; } @list; is_deeply(\@list, [1 .. 4]); is_deeply(\@list1, [(5) x 4]); } leak_free_ok( apply => sub { @list = (1 .. 4); @list1 = apply { grow_stack(); $_ = 5; } @list; } ); SCOPE: { leak_free_ok( 'dying callback during apply' => sub { my @l = (1 .. 4); eval { my @l1 = apply { $_ % 2 or die "Even!"; $_ %= 2; } @l; }; } ); } is_dying('apply without sub' => sub { &apply(42, 4711); }); done_testing; List-MoreUtils-0.430/t/pureperl/occurrences.t0000644000175000017500000000702613744044755017357 0ustar snosno#!perl use strict ("subs", "vars", "refs"); use warnings ("all"); BEGIN { $ENV{LIST_MOREUTILS_PP} = 1; } END { delete $ENV{LIST_MOREUTILS_PP} } # for VMS use lib ("t/lib"); use List::MoreUtils (":all"); use Test::More; use Test::LMU; use Tie::Array (); SCOPE: { my $lorem = "Lorem ipsum dolor sit amet, consetetur sadipscing elitr, sed diam nonumy eirmod tempor invidunt ut labore et dolore magna aliquyam erat, sed diam voluptua. At vero eos et accusam et justo duo dolores et ea rebum. Stet clita kasd gubergren, no sea takimata sanctus est Lorem ipsum dolor sit amet. Lorem ipsum dolor sit amet, consetetur sadipscing elitr, sed diam nonumy eirmod tempor invidunt ut labore et dolore magna aliquyam erat, sed diam voluptua. At vero eos et accusam et justo duo dolores et ea rebum. Stet clita kasd gubergren, no sea takimata sanctus est Lorem ipsum dolor sit amet. Lorem ipsum dolor sit amet, consetetur sadipscing elitr, sed diam nonumy eirmod tempor invidunt ut labore et dolore magna aliquyam erat, sed diam voluptua."; my @lorem = grep { $_ } split /(?:\b|\s)/, $lorem; my $n_comma = scalar(split /,/, $lorem) - 1; my $n_dot = scalar(split /\./, $lorem); # there is one at end ... mind the gap my $n_et = scalar(split /\bet\b/, $lorem) - 1; my @l = @lorem; my @o = occurrences @l; is(undef, $o[0], "Each word is counted"); is(undef, $o[1], "Text to long, each word is there at least twice"); is_deeply([','], $o[$n_comma], "$n_comma comma"); is_deeply(['.'], $o[$n_dot], "$n_dot dots"); is_deeply(['et'], $o[$n_et], "$n_et words 'et'"); @o = occurrences grep { /\w+/ } @lorem; my $wc = reduce_0 { defined $b ? $a + $_ * scalar @$b : $a } @o; is($wc, 124, "Words are as many as requested at www.loremipsum.de"); } SCOPE: { my @probes = ((1) x 3, (2) x 4, (3) x 2, (4) x 7, (5) x 2, (6) x 4); my $fp = freeze(\@probes); my @o = map { ref $_ ? [sort @$_] : $_ } occurrences @probes; is($fp, freeze(\@probes), "probes untouched"); my @expectation = (undef, undef, [3, 5], [1], [2, 6], undef, undef, [4]); is_deeply(\@expectation, \@o, "occurrences of integer probes"); } SCOPE: { my @probes = ((1) x 3, undef, (2) x 4, undef, (3) x 2, undef, (4) x 7, undef, (5) x 2, undef, (6) x 4); my $fp = freeze(\@probes); my @o = map { ref $_ ? [sort { (defined $a <=> defined $b) or $a <=> $b } @$_] : $_ } occurrences @probes; is($fp, freeze(\@probes), "probes untouched"); my @expectation = (undef, undef, [3, 5], [1], [2, 6], [undef], undef, [4]); is_deeply(\@expectation, \@o, "occurrences of integer probes"); } leak_free_ok( occurrences => sub { my @probes = ((1) x 3, (2) x 4, (3) x 2, (4) x 7, (5) x 2, (6) x 4); my @o = occurrences @probes; }, 'scalar occurrences' => sub { my @probes = ((1) x 3, (2) x 4, (3) x 2, (4) x 7, (5) x 2, (6) x 4); my $o = occurrences @probes; } ); leak_free_ok( 'occurrences with exception in overloading stringify', sub { eval { my $obj = DieOnStringify->new; my @probes = ((1) x 3, $obj, (2) x 4, $obj, (3) x 2, $obj, (4) x 7, $obj, (5) x 2, $obj, (6) x 4); my @o = occurrences @probes; }; eval { my $obj = DieOnStringify->new; my @probes = ((1) x 3, $obj, (2) x 4, $obj, (3) x 2, $obj, (4) x 7, $obj, (5) x 2, $obj, (6) x 4); my $o = occurrences @probes; }; } ); done_testing; List-MoreUtils-0.430/t/pureperl/lower_bound.t0000644000175000017500000000345413744044755017364 0ustar snosno#!perl use strict ("subs", "vars", "refs"); use warnings ("all"); BEGIN { $ENV{LIST_MOREUTILS_PP} = 1; } END { delete $ENV{LIST_MOREUTILS_PP} } # for VMS use lib ("t/lib"); use List::MoreUtils (":all"); use Test::More; use Test::LMU; my @list = (1, 1, 2, 2, 3, 3, 3, 3, 3, 3, 4, 4, 4, 4, 5, 5, 6, 7, 7, 7, 8, 8, 9, 9, 9, 9, 9, 11, 13, 13, 13, 17); is(0, (lower_bound { $_ <=> 0 } @list), "lower bound 0"); is(0, (lower_bound { $_ <=> 1 } @list), "lower bound 1"); is(2, (lower_bound { $_ <=> 2 } @list), "lower bound 2"); is(10, (lower_bound { $_ <=> 4 } @list), "lower bound 4"); is(scalar @list, (lower_bound { $_ <=> 19 } @list), "lower bound 19"); my @in = @list = 1 .. 100; for my $i (0 .. $#in) { my $j = $in[$i] - 1; is($i ? $i - 1 : 0, (lower_bound { $_ - $j } @list), "placed $j"); is($i, (lower_bound { $_ - $in[$i] } @list), "found $in[$i]"); } my @lout = ($in[0] - 11 .. $in[0] - 1); for my $elem (@lout) { is(0, (lower_bound { $_ - $elem } @list), "put smaller $elem in front"); } my @uout = ($in[-1] + 1 .. $in[-1] + 11); for my $elem (@uout) { is(scalar @list, (lower_bound { $_ - $elem } @list),, "put bigger $elem at end"); } leak_free_ok( lower_bound => sub { my $elem = int(rand(1000)) + 1; lower_bound { $_ - $elem } @list; } ); leak_free_ok( 'lower_bound with stack-growing' => sub { my $elem = int(rand(1000)); lower_bound { grow_stack(); $_ - $elem } @list; } ); leak_free_ok( 'lower_bound with stack-growing and exception' => sub { my $elem = int(rand(1000)); eval { lower_bound { grow_stack(); $_ - $elem or die "Goal!"; $_ - $elem } @list; }; } ); is_dying('lower_bound without sub' => sub { &lower_bound(42, (1 .. 100)); }); done_testing; List-MoreUtils-0.430/t/pureperl/one.t0000644000175000017500000000130213744044755015614 0ustar snosno#!perl use strict ("subs", "vars", "refs"); use warnings ("all"); BEGIN { $ENV{LIST_MOREUTILS_PP} = 1; } END { delete $ENV{LIST_MOREUTILS_PP} } # for VMS use lib ("t/lib"); use List::MoreUtils (":all"); use Test::More; use Test::LMU; # Normal cases my @list = (1 .. 300); is_true(one { 1 == $_ } @list); is_true(one { 150 == $_ } @list); is_true(one { 300 == $_ } @list); is_false(one { 0 == $_ } @list); is_false(one { 1 <= $_ } @list); is_false(one { !(127 & $_) } @list); is_false(one { 0 } ()); leak_free_ok( one => sub { my $ok = one { 150 <= $_ } @list; my $ok2 = one { 150 <= $_ } 1 .. 300; } ); is_dying('one without sub' => sub { &one(42, 4711); }); done_testing; List-MoreUtils-0.430/t/pureperl/onlyidx.t0000644000175000017500000000203413744044755016524 0ustar snosno#!perl use strict ("subs", "vars", "refs"); use warnings ("all"); BEGIN { $ENV{LIST_MOREUTILS_PP} = 1; } END { delete $ENV{LIST_MOREUTILS_PP} } # for VMS use lib ("t/lib"); use List::MoreUtils (":all"); BEGIN { $INC{'List/MoreUtils.pm'} or *only_index = __PACKAGE__->can("onlyidx"); } use Test::More; use Test::LMU; my @list = (1 .. 300); is(0, onlyidx { 1 == $_ } @list); is(149, onlyidx { 150 == $_ } @list); is(299, onlyidx { 300 == $_ } @list); is(-1, onlyidx { 0 == $_ } @list); is(-1, onlyidx { 1 <= $_ } @list); is(-1, onlyidx { !(127 & $_) } @list); # Test aliases is(0, only_index { 1 == $_ } @list); is(149, only_index { 150 == $_ } @list); is(299, only_index { 300 == $_ } @list); is(-1, only_index { 0 == $_ } @list); is(-1, only_index { 1 <= $_ } @list); is(-1, only_index { !(127 & $_) } @list); leak_free_ok( onlyidx => sub { my $ok = onlyidx { 150 <= $_ } @list; my $ok2 = onlyidx { 150 <= $_ } 1 .. 300; } ); is_dying('onlyidx without sub' => sub { &onlyidx(42, 4711); }); done_testing; List-MoreUtils-0.430/t/pureperl/firstres.t0000644000175000017500000000131213744044755016675 0ustar snosno#!perl use strict ("subs", "vars", "refs"); use warnings ("all"); BEGIN { $ENV{LIST_MOREUTILS_PP} = 1; } END { delete $ENV{LIST_MOREUTILS_PP} } # for VMS use lib ("t/lib"); use List::MoreUtils (":all"); BEGIN { $INC{'List/MoreUtils.pm'} or *first_result = __PACKAGE__->can("firstres"); } use Test::More; use Test::LMU; my $x = firstres { 2 * ($_ > 5) } 4 .. 9; is($x, 2); $x = firstres { $_ > 5 } 1 .. 4; is($x, undef); # Test aliases $x = first_result { $_ > 5 } 4 .. 9; is($x, 1); $x = first_result { $_ > 5 } 1 .. 4; is($x, undef); leak_free_ok( firstres => sub { $x = firstres { $_ > 5 } 4 .. 9; } ); is_dying('firstres without sub' => sub { &firstres(42, 4711); }); done_testing; List-MoreUtils-0.430/t/pureperl/arrayify.t0000644000175000017500000000651613744044755016675 0ustar snosno#!perl use strict ("subs", "vars", "refs"); use warnings ("all"); BEGIN { $ENV{LIST_MOREUTILS_PP} = 1; } END { delete $ENV{LIST_MOREUTILS_PP} } # for VMS use lib ("t/lib"); use List::MoreUtils (":all"); use Test::More; use Test::LMU; use Tie::Array (); SCOPE: { my @in = (1 .. 4, [5 .. 7], 8 .. 11, [[12 .. 17]], 18); my @out = arrayify @in; is_deeply(\@out, [1 .. 18], "linear flattened int mix i"); } SCOPE: { my @in = (1 .. 4, [[5 .. 11]], 12, [[13 .. 17]]); my @out = arrayify @in; is_deeply(\@out, [1 .. 17], "linear flattened int mix ii"); } SCOPE: { # typical structure when parsing XML using XML::Hash::XS my %src = ( root => { foo_list => {foo_elem => {attr => 42}}, bar_list => {bar_elem => [{hummel => 2}, {hummel => 3}, {hummel => 5}]} } ); my @foo_elems = arrayify $src{root}->{foo_list}->{foo_elem}; is_deeply(\@foo_elems, [{attr => 42}], "arrayified struct with one element"); my @bar_elems = arrayify $src{root}->{bar_list}->{bar_elem}; is_deeply(\@bar_elems, [{hummel => 2}, {hummel => 3}, {hummel => 5}], "arrayified struct with three elements"); } SCOPE: { my @in; tie @in, "Tie::StdArray"; @in = (1 .. 4, [5 .. 7], 8 .. 11, [[12 .. 17]]); my @out = arrayify @in; is_deeply(\@out, [1 .. 17], "linear flattened magic int mix"); } SCOPE: { my (@in, @inner, @innest); tie @in, "Tie::StdArray"; tie @inner, "Tie::StdArray"; tie @innest, "Tie::StdArray"; @inner = (5 .. 7); @innest = ([12 .. 17]); @in = (1 .. 4, \@inner, 8 .. 11, [@innest]); my @out = arrayify @in; is_deeply(\@out, [1 .. 17], "linear flattened magic int mixture"); } SCOPE: { my @in = (qw(av_make av_undef av_clear), [qw(av_push av_pop)], qw(av_fetch av_store), [['av_shift'], ['av_unshift']]); my @out = arrayify @in; is_deeply( \@out, [qw(av_make av_undef av_clear av_push av_pop av_fetch av_store av_shift av_unshift)], "linear flattened string mix i" ); } leak_free_ok( arrayify => sub { my @in = (1 .. 4, [5 .. 7], 8 .. 11, [[12 .. 17]]); my @out = arrayify @in; }, 'arrayify magic' => sub { my (@in, @inner, @innest); tie @in, "Tie::StdArray"; tie @inner, "Tie::StdArray"; tie @innest, "Tie::StdArray"; @inner = (5 .. 7); @innest = ([12 .. 17]); @in = (1 .. 4, \@inner, 8 .. 11, [@innest]); my @out = arrayify @in; } ); SKIP: { leak_free_ok( 'arrayify with exception in overloading stringify at begin' => sub { my @in = ( DieOnStringify->new, qw(av_make av_undef av_clear), [qw(av_push av_pop)], qw(av_fetch av_store), [['av_shift'], ['av_unshift']] ); eval { my @out = arrayify @in; }; diag($@) if ($@); }, ); leak_free_ok( 'arrayify with exception in overloading stringify at end' => sub { my @in = ( qw(av_make av_undef av_clear), [qw(av_push av_pop)], qw(av_fetch av_store), [['av_shift'], ['av_unshift']], DieOnStringify->new ); eval { my @out = arrayify @in; }; diag($@) if ($@); } ); } done_testing; List-MoreUtils-0.430/t/pureperl/mesh.t0000644000175000017500000000331413744044755015774 0ustar snosno#!perl use strict ("subs", "vars", "refs"); use warnings ("all"); BEGIN { $ENV{LIST_MOREUTILS_PP} = 1; } END { delete $ENV{LIST_MOREUTILS_PP} } # for VMS use lib ("t/lib"); use List::MoreUtils (":all"); BEGIN { $INC{'List/MoreUtils.pm'} or *zip = __PACKAGE__->can("mesh"); } use Test::More; use Test::LMU; SCOPE: { my @x = qw/a b c d/; my @y = qw/1 2 3 4/; my @z = mesh @x, @y; is_deeply(\@z, ['a', 1, 'b', 2, 'c', 3, 'd', 4], "mesh two list with same count of elements"); } SCOPE: { # alias check my @x = qw/a b c d/; my @y = qw/1 2 3 4/; my @z = zip @x, @y; is_deeply(\@z, ['a', 1, 'b', 2, 'c', 3, 'd', 4], "zip two list with same count of elements"); } SCOPE: { my @a = ('x'); my @b = ('1', '2'); my @c = qw/zip zap zot/; my @z = mesh @a, @b, @c; is_deeply(\@z, ['x', 1, 'zip', undef, 2, 'zap', undef, undef, 'zot'], "mesh three list with increasing count of elements"); } SCOPE: { # alias check my @a = ('x'); my @b = ('1', '2'); my @c = qw/zip zap zot/; my @z = zip @a, @b, @c; is_deeply(\@z, ['x', 1, 'zip', undef, 2, 'zap', undef, undef, 'zot'], "zip three list with increasing count of elements"); } # Make array with holes SCOPE: { my @a = (1 .. 10); my @d; $#d = 9; my @z = mesh @a, @d; is_deeply( \@z, [1, undef, 2, undef, 3, undef, 4, undef, 5, undef, 6, undef, 7, undef, 8, undef, 9, undef, 10, undef,], "mesh one list with 9 elements with an empty list" ); } leak_free_ok( mesh => sub { my @x = qw/a b c d e/; my @y = qw/1 2 3 4/; my @z = mesh @x, @y; } ); is_dying('mesh with a list, not at least two arrays' => sub { &mesh(1, 2); }); done_testing; List-MoreUtils-0.430/t/pureperl/lastres.t0000644000175000017500000000130013744044755016506 0ustar snosno#!perl use strict ("subs", "vars", "refs"); use warnings ("all"); BEGIN { $ENV{LIST_MOREUTILS_PP} = 1; } END { delete $ENV{LIST_MOREUTILS_PP} } # for VMS use lib ("t/lib"); use List::MoreUtils (":all"); BEGIN { $INC{'List/MoreUtils.pm'} or *last_result = __PACKAGE__->can("lastres"); } use Test::More; use Test::LMU; my $x = lastres { 2 * ($_ > 5) } 4 .. 9; is($x, 2); $x = lastres { $_ > 5 } 1 .. 4; is($x, undef); # Test aliases $x = last_result { $_ > 5 } 4 .. 9; is($x, 1); $x = last_result { $_ > 5 } 1 .. 4; is($x, undef); leak_free_ok( lastres => sub { $x = lastres { $_ > 5 } 4 .. 9; } ); is_dying('lastres without sub' => sub { &lastres(42, 4711); }); done_testing; List-MoreUtils-0.430/t/pureperl/before_incl.t0000644000175000017500000000127513744044755017313 0ustar snosno#!perl use strict ("subs", "vars", "refs"); use warnings ("all"); BEGIN { $ENV{LIST_MOREUTILS_PP} = 1; } END { delete $ENV{LIST_MOREUTILS_PP} } # for VMS use lib ("t/lib"); use List::MoreUtils (":all"); use Test::More; use Test::LMU; my @x = before_incl { $_ % 5 == 0 } 1 .. 9; is_deeply(\@x, [1, 2, 3, 4, 5], "before 5, included"); @x = before_incl { /foo/ } qw{bar baz}; is_deeply(\@x, [qw{bar baz}]); @x = before_incl { /f/ } qw{bar baz foo}; is_deeply(\@x, [qw{bar baz foo}], "before /f/, included"); leak_free_ok( before_incl => sub { @x = before_incl { /z/ } qw{ bar baz foo }; } ); is_dying('before_incl without sub' => sub { &before_incl(42, 4711); }); done_testing; List-MoreUtils-0.430/t/pureperl/indexes.t0000644000175000017500000000414713744044755016504 0ustar snosno#!perl use strict ("subs", "vars", "refs"); use warnings ("all"); BEGIN { $ENV{LIST_MOREUTILS_PP} = 1; } END { delete $ENV{LIST_MOREUTILS_PP} } # for VMS use lib ("t/lib"); use List::MoreUtils (":all"); use Test::More; use Test::LMU; my @x = indexes { $_ > 5 } (4 .. 9); is_deeply(\@x, [2 .. 5], "indexes > 5 ..."); @x = indexes { $_ > 5 } (1 .. 4); is_deeply(\@x, [], 'Got the null list'); my ($lr, @s, @n, @o, @e); leak_free_ok( indexes => sub { $lr = 1; @s = indexes { $_ > 5 } (4 .. 9); @n = indexes { $_ > 5 } (1 .. 5); @o = indexes { $_ & 1 } (10 .. 15); @e = indexes { !($_ & 1) } (10 .. 15); } ); $lr and is_deeply(\@s, [2 .. 5], "indexes/leak: some"); $lr and is_deeply(\@n, [], "indexes/leak: none"); $lr and is_deeply(\@o, [1, 3, 5], "indexes/leak: odd"); $lr and is_deeply(\@e, [0, 2, 4], "indexes/leak: even"); @n = map { $_ + 1 } @o = (0 .. 9); @x = indexes { ++$_ > 7 } @o; is_deeply(\@o, \@n, "indexes behaves like grep on modified \$_"); is_deeply(\@x, [7 .. 9], "indexes/modify"); not_dying( 'indexes_on_set' => sub { @x = indexes { ++$_ > 7 } (0 .. 9); } ); is_deeply(\@x, [7 .. 9], "indexes/modify set"); leak_free_ok( indexes => sub { @s = indexes { grow_stack; $_ > 5 } (4 .. 9); @n = indexes { grow_stack; $_ > 5 } (1 .. 4); @o = indexes { grow_stack; $_ & 1 } (10 .. 15); @e = indexes { grow_stack; !($_ & 1) } (10 .. 15); }, 'indexes interrupted by exception' => sub { eval { @s = indexes { $_ > 10 and die "range exceeded"; $_ > 5 } (1 .. 15); }; }, ); $lr and is_deeply(\@s, [2 .. 5], "indexes/leak: some"); $lr and is_deeply(\@n, [], "indexes/leak: none"); $lr and is_deeply(\@o, [1, 3, 5], "indexes/leak: odd"); $lr and is_deeply(\@e, [0, 2, 4], "indexes/leak: even"); my $have_scalar_util = eval { require Scalar::Util; 1 }; if ($have_scalar_util) { my $ref = \(indexes(sub { 1 }, 123)); Scalar::Util::weaken($ref); is($ref, undef, "weakened away"); } is_dying('indexes without sub' => sub { &indexes(42, 4711); }); done_testing; List-MoreUtils-0.430/t/pureperl/onlyval.t0000644000175000017500000000206413744044755016525 0ustar snosno#!perl use strict ("subs", "vars", "refs"); use warnings ("all"); BEGIN { $ENV{LIST_MOREUTILS_PP} = 1; } END { delete $ENV{LIST_MOREUTILS_PP} } # for VMS use lib ("t/lib"); use List::MoreUtils (":all"); BEGIN { $INC{'List/MoreUtils.pm'} or *only_value = __PACKAGE__->can("onlyval"); } use Test::More; use Test::LMU; my @list = (1 .. 300); is(1, onlyval { 1 == $_ } @list); is(150, onlyval { 150 == $_ } @list); is(300, onlyval { 300 == $_ } @list); is(undef, onlyval { 0 == $_ } @list); is(undef, onlyval { 1 <= $_ } @list); is(undef, onlyval { !(127 & $_) } @list); # Test aliases is(1, only_value { 1 == $_ } @list); is(150, only_value { 150 == $_ } @list); is(300, only_value { 300 == $_ } @list); is(undef, only_value { 0 == $_ } @list); is(undef, only_value { 1 <= $_ } @list); is(undef, only_value { !(127 & $_) } @list); leak_free_ok( onlyval => sub { my $ok = onlyval { 150 <= $_ } @list; my $ok2 = onlyval { 150 <= $_ } 1 .. 300; } ); is_dying('onlyval without sub' => sub { &onlyval(42, 4711); }); done_testing; List-MoreUtils-0.430/t/pureperl/minmax.t0000644000175000017500000000432013744044755016327 0ustar snosno#!perl use strict ("subs", "vars", "refs"); use warnings ("all"); BEGIN { $ENV{LIST_MOREUTILS_PP} = 1; } END { delete $ENV{LIST_MOREUTILS_PP} } # for VMS use lib ("t/lib"); use List::MoreUtils (":all"); use Test::More; use Test::LMU; my @list = reverse 0 .. 10000; my ($min, $max) = minmax @list; is($min, 0); is($max, 10000); # Even number of elements push @list, 10001; ($min, $max) = minmax @list; is($min, 0); is($max, 10001); $list[0] = 17; # Some floats @list = (0, -1.1, 3.14, 1 / 7, 10000, -10 / 3); ($min, $max) = minmax @list; # Floating-point comparison cunningly avoided is(sprintf("%.2f", $min), "-3.33"); is($max, 10000); # Test with a single negative list value my $input = -1; ($min, $max) = minmax $input; is($min, -1); is($max, -1); # COW causes missing max when optimization for 1 argument is applied @list = grep { defined $_ } map { my ($min, $max) = minmax(sprintf("%.3g", rand)); ($min, $max) } (0 .. 19); is(scalar @list, 40, "minmax swallows max on COW"); # Confirm output are independant copies of input $input = 1; is($min, -1); is($max, -1); $min = 2; is($max, -1); # prove overrun my $uvmax = ~0; my $ivmax = $uvmax >> 1; my $ivmin = (0 - $ivmax) - 1; my @low_ints = map { $ivmin + $_ } (0 .. 10); ($min, $max) = minmax @low_ints; is($min, $ivmin, "minmax finds ivmin"); is($max, $ivmin + 10, "minmax finds ivmin + 10"); my @high_ints = map { $ivmax - $_ } (0 .. 10); ($min, $max) = minmax @high_ints; is($min, $ivmax - 10, "minmax finds ivmax-10"); is($max, $ivmax, "minmax finds ivmax"); my @mixed_ints = map { ($ivmin + $_, $ivmax - $_) } (0 .. 10); ($min, $max) = minmax @mixed_ints; is($min, $ivmin, "minmax finds ivmin"); is($max, $ivmax, "minmax finds ivmax"); my @high_uints = map { $uvmax - $_ } (0 .. 10); ($min, $max) = minmax @high_uints; is($min, $uvmax - 10, "minmax finds uvmax-10"); is($max, $uvmax, "minmax finds uvmax"); my @mixed_nums = map { ($ivmin + $_, $uvmax - $_) } (0 .. 10); ($min, $max) = minmax @mixed_nums; is($min, $ivmin, "minmax finds ivmin"); is($max, $uvmax, "minmax finds uvmax"); leak_free_ok( minmax => sub { @list = (0, -1.1, 3.14, 1 / 7, 10000, -10 / 3); ($min, $max) = minmax @list; } ); done_testing; List-MoreUtils-0.430/t/pureperl/upper_bound.t0000644000175000017500000000345413744044755017367 0ustar snosno#!perl use strict ("subs", "vars", "refs"); use warnings ("all"); BEGIN { $ENV{LIST_MOREUTILS_PP} = 1; } END { delete $ENV{LIST_MOREUTILS_PP} } # for VMS use lib ("t/lib"); use List::MoreUtils (":all"); use Test::More; use Test::LMU; my @list = (1, 1, 2, 2, 3, 3, 3, 3, 3, 3, 4, 4, 4, 4, 5, 5, 6, 7, 7, 7, 8, 8, 9, 9, 9, 9, 9, 11, 13, 13, 13, 17); is(0, (upper_bound { $_ <=> 0 } @list), "upper bound 0"); is(2, (upper_bound { $_ <=> 1 } @list), "upper bound 1"); is(4, (upper_bound { $_ <=> 2 } @list), "upper bound 2"); is(14, (upper_bound { $_ <=> 4 } @list), "upper bound 4"); is(scalar @list, (upper_bound { $_ <=> 19 } @list), "upper bound 19"); my @in = @list = 1 .. 100; for my $i (0 .. $#in) { my $j = $in[$i] - 1; is($i, (upper_bound { $_ - $j } @list), "placed $j"); is($i + 1, (upper_bound { $_ - $in[$i] } @list), "found $in[$i]"); } my @lout = ($in[0] - 11 .. $in[0] - 1); for my $elem (@lout) { is(0, (upper_bound { $_ - $elem } @list), "put smaller $elem in front"); } my @uout = ($in[-1] + 1 .. $in[-1] + 11); for my $elem (@uout) { is(scalar @list, (upper_bound { $_ - $elem } @list),, "put bigger $elem at end"); } leak_free_ok( upper_bound => sub { my $elem = int(rand(1000)) + 1; upper_bound { $_ - $elem } @list; } ); leak_free_ok( 'upper_bound with stack-growing' => sub { my $elem = int(rand(1000)); upper_bound { grow_stack(); $_ - $elem } @list; } ); leak_free_ok( 'upper_bound with stack-growing and exception' => sub { my $elem = int(rand(1000)); eval { upper_bound { grow_stack(); $_ - $elem or die "Goal!"; $_ - $elem } @list; }; } ); is_dying('upper_bound without sub' => sub { &upper_bound(42, (1 .. 100)); }); done_testing; List-MoreUtils-0.430/t/pureperl/reduce_1.t0000644000175000017500000000232513744044755016530 0ustar snosno#!perl use strict ("subs", "vars", "refs"); use warnings ("all"); BEGIN { $ENV{LIST_MOREUTILS_PP} = 1; } END { delete $ENV{LIST_MOREUTILS_PP} } # for VMS use lib ("t/lib"); use List::MoreUtils (":all"); use Test::More; use Test::LMU; use Scalar::Util qw(looks_like_number); # (this code shamelessly stolen from Math::Complex's t/Trig.t, with some mods to near) from BBYRD in RT#72638 and taken from SQL-Statement now use Math::Trig; my $eps = 1e-11; if ($^O eq 'unicos') { # See lib/Math/Complex.pm and t/lib/complex.t. $eps = 1e-10; } sub near ($$$;$) { my $d = $_[1] ? abs($_[0] / $_[1] - 1) : abs($_[0]); local $Test::Builder::Level = $Test::Builder::Level + 1; looks_like_number($_[0]) or return cmp_ok($_[0], "eq", $_[1], "near? $_[0] ~= $_[1]"); $_[0] =~ m/nan/i and return cmp_ok($_[0], "eq", $_[1], "near? $_[0] ~= $_[1]"); $_[0] =~ m/inf/i and return cmp_ok($_[0], "eq", $_[1], "near? $_[0] ~= $_[1]"); my $e = defined $_[3] ? $_[3] : $eps; cmp_ok($d, '<', $e, "$_[2] => near? $_[0] ~= $_[1]") or diag("near? $_[0] ~= $_[1]"); } my $half_pi = reduce_1 { $a * ((4 * $b * $b) / ((2 * $b - 1) * (2 * $b + 1))) } 1 .. 750; near($half_pi, pi / 2, "Wallis product", 1e-2); done_testing; List-MoreUtils-0.430/t/pureperl/singleton.t0000644000175000017500000000471513744044755017050 0ustar snosno#!perl use strict ("subs", "vars", "refs"); use warnings ("all"); BEGIN { $ENV{LIST_MOREUTILS_PP} = 1; } END { delete $ENV{LIST_MOREUTILS_PP} } # for VMS use lib ("t/lib"); use List::MoreUtils (":all"); use Test::More; use Test::LMU; use Tie::Array (); SCOPE: { my @s = (1001 .. 1200); my @d = map { (1 .. 1000) } 0 .. 1; my @a = (@d, @s); my @u = singleton @a; is_deeply(\@u, [@s]); my $u = singleton @a; is(200, $u); } # Test strings SCOPE: { my @s = ("AA" .. "ZZ"); my @d = map { ("aa" .. "zz") } 0 .. 1; my @a = (@d, @s); my @u = singleton @a; is_deeply(\@u, [@s]); my $u = singleton @a; is(scalar @s, $u); } # Test mixing strings and numbers SCOPE: { my @s = (1001 .. 1200, "AA" .. "ZZ"); my $fs = freeze(\@s); my @d = map { (1 .. 1000, "aa" .. "zz") } 0 .. 1; my @a = (@d, @s); my $fa = freeze(\@a); my @u = singleton map { $_ } @a; my $fu = freeze(\@u); is_deeply(\@u, [@s]); is($fs, freeze(\@s)); is($fa, freeze(\@a)); is($fu, $fs); my $u = singleton @a; is(scalar @s, $u); } SCOPE: { my @a; tie @a, "Tie::StdArray"; my @s = (1001 .. 1200, "AA" .. "ZZ"); my @d = map { (1 .. 1000, "aa" .. "zz") } 0 .. 1; @a = (@d, @s); my @u = singleton map { $_ } @a; is_deeply(\@u, [@s]); @a = (@d, @s); my $u = singleton @a; is(scalar @s, $u); } SCOPE: { my @foo = ('a', 'b', '', undef, 'b', 'c', ''); my @sfoo = ('a', undef, 'c'); is_deeply([singleton @foo], \@sfoo, 'one undef is supported correctly by singleton'); @foo = ('a', 'b', '', undef, 'b', 'c', undef); @sfoo = ('a', '', 'c'); is_deeply([singleton @foo], \@sfoo, 'twice undef is supported correctly by singleton'); is((scalar singleton @foo), scalar @sfoo, 'scalar twice undef is supported correctly by singleton'); } leak_free_ok( singleton => sub { my @s = (1001 .. 1200, "AA" .. "ZZ"); my @d = map { (1 .. 1000, "aa" .. "zz") } 0 .. 1; my @a = (@d, @s); my @u = singleton @a; scalar singleton @a; } ); # This test (and the associated fix) are from Kevin Ryde; see RT#49796 leak_free_ok( 'singleton with exception in overloading stringify', sub { eval { my $obj = DieOnStringify->new; my @u = singleton $obj, $obj; }; eval { my $obj = DieOnStringify->new; my $u = singleton $obj, $obj; }; } ); done_testing; List-MoreUtils-0.430/t/pureperl/one_u.t0000644000175000017500000000132413744044755016144 0ustar snosno#!perl use strict ("subs", "vars", "refs"); use warnings ("all"); BEGIN { $ENV{LIST_MOREUTILS_PP} = 1; } END { delete $ENV{LIST_MOREUTILS_PP} } # for VMS use lib ("t/lib"); use List::MoreUtils (":all"); use Test::More; use Test::LMU; # Normal cases my @list = (1 .. 300); is_true(one_u { 1 == $_ } @list); is_true(one_u { 150 == $_ } @list); is_true(one_u { 300 == $_ } @list); is_false(one_u { 0 == $_ } @list); is_false(one_u { 1 <= $_ } @list); is_false(one_u { !(127 & $_) } @list); is_undef(one_u {}); leak_free_ok( one_u => sub { my $ok = one_u { 150 <= $_ } @list; my $ok2 = one_u { 150 <= $_ } 1 .. 300; } ); is_dying('one_u without sub' => sub { &one_u(42, 4711); }); done_testing; List-MoreUtils-0.430/t/pureperl/each_array.t0000644000175000017500000000646613744044755017151 0ustar snosno#!perl use strict ("subs", "vars", "refs"); use warnings ("all"); BEGIN { $ENV{LIST_MOREUTILS_PP} = 1; } END { delete $ENV{LIST_MOREUTILS_PP} } # for VMS use lib ("t/lib"); use List::MoreUtils (":all"); use Test::More; use Test::LMU; SCOPE: { my @a = (7, 3, 'a', undef, 'r'); my @b = qw{ a 2 -1 x }; my $it = each_array @a, @b; my (@r, @idx); while (my ($a, $b) = $it->()) { push @r, $a, $b; push @idx, $it->('index'); } # Do I segfault? I shouldn't. $it->(); is_deeply(\@r, [7, 'a', 3, 2, 'a', -1, undef, 'x', 'r', undef]); is_deeply(\@idx, [0 .. 4]); # Testing two iterators on the same arrays in parallel @a = (1, 3, 5); @b = (2, 4, 6); my $i1 = each_array @a, @b; my $i2 = each_array @a, @b; @r = (); while (my ($a, $b) = $i1->() and my ($c, $d) = $i2->()) { push @r, $a, $b, $c, $d; } is_deeply(\@r, [1, 2, 1, 2, 3, 4, 3, 4, 5, 6, 5, 6]); # Input arrays must not be modified is_deeply(\@a, [1, 3, 5]); is_deeply(\@b, [2, 4, 6]); # This used to give "semi-panic: attempt to dup freed string" # See: my $ea = each_arrayref([1 .. 26], ['A' .. 'Z']); (@a, @b) = (); while (my ($a, $b) = $ea->()) { push @a, $a; push @b, $b; } is_deeply(\@a, [1 .. 26]); is_deeply(\@b, ['A' .. 'Z']); # And this even used to dump core my @nums = 1 .. 26; $ea = each_arrayref(\@nums, ['A' .. 'Z']); (@a, @b) = (); while (my ($a, $b) = $ea->()) { push @a, $a; push @b, $b; } is_deeply(\@a, [1 .. 26]); is_deeply(\@a, \@nums); is_deeply(\@b, ['A' .. 'Z']); } SCOPE: { my @a = (7, 3, 'a', undef, 'r'); my @b = qw/a 2 -1 x/; my $it = each_arrayref \@a, \@b; my (@r, @idx); while (my ($a, $b) = $it->()) { push @r, $a, $b; push @idx, $it->('index'); } # Do I segfault? I shouldn't. $it->(); is_deeply(\@r, [7, 'a', 3, 2, 'a', -1, undef, 'x', 'r', undef]); is_deeply(\@idx, [0 .. 4]); # Testing two iterators on the same arrays in parallel @a = (1, 3, 5); @b = (2, 4, 6); my $i1 = each_array @a, @b; my $i2 = each_array @a, @b; @r = (); while (my ($a, $b) = $i1->() and my ($c, $d) = $i2->()) { push @r, $a, $b, $c, $d; } is_deeply(\@r, [1, 2, 1, 2, 3, 4, 3, 4, 5, 6, 5, 6]); # Input arrays must not be modified is_deeply(\@a, [1, 3, 5]); is_deeply(\@b, [2, 4, 6]); } # Note that the leak_free_ok tests for each_array and each_arrayref # should not be run until either of them has been called at least once # in the current perl. That's because calling them the first time # causes the runtime to allocate some memory used for the OO structures # that their implementation uses internally. leak_free_ok( each_array => sub { my @a = (1); my $it = each_array @a; while (my ($a) = $it->()) { } } ); leak_free_ok( each_arrayref => sub { my @a = (1); my $it = each_arrayref \@a; while (my ($a) = $it->()) { } } ); is_dying('each_array without sub' => sub { &each_array(42, 4711); }); is_dying('each_arrayref without sub' => sub { &each_arrayref(42, 4711); }); done_testing; List-MoreUtils-0.430/t/pureperl/XS.t0000644000175000017500000000247213744044755015376 0ustar snosno#!perl use strict ("subs", "vars", "refs"); use warnings ("all"); BEGIN { $ENV{LIST_MOREUTILS_PP} = 1; } END { delete $ENV{LIST_MOREUTILS_PP} } # for VMS use lib ("t/lib"); use List::MoreUtils (":all"); use Test::More; $INC{'List/MoreUtils.pm'} or plan skip_all => "Unreasonable unless loaded via List::MoreUtils"; is(List::MoreUtils::_XScompiled(), 0 + defined($INC{'List/MoreUtils/XS.pm'}), "_XScompiled"); done_testing(); 1; =head1 AUTHOR Jens Rehsack Erehsack AT cpan.orgE Adam Kennedy Eadamk@cpan.orgE =head1 COPYRIGHT AND LICENSE Copyright 2013 - 2017 by Jens Rehsack All code added with 0.417 or later is licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in compliance with the License. You may obtain a copy of the License at http://www.apache.org/licenses/LICENSE-2.0 Unless required by applicable law or agreed to in writing, software distributed under the License is distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the License for the specific language governing permissions and limitations under the License. All code until 0.416 is licensed 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 List-MoreUtils-0.430/t/pureperl/bsearchidx.t0000644000175000017500000000205313744044755017153 0ustar snosno#!perl use strict ("subs", "vars", "refs"); use warnings ("all"); BEGIN { $ENV{LIST_MOREUTILS_PP} = 1; } END { delete $ENV{LIST_MOREUTILS_PP} } # for VMS use lib ("t/lib"); use List::MoreUtils (":all"); use Test::More; use Test::LMU; my @list = my @in = 1 .. 1000; for my $i (0 .. $#in) { is($i, bsearchidx { $_ - $in[$i] } @list); } my @out = (-10 .. 0, 1001 .. 1011); for my $elem (@out) { my $r = bsearchidx { $_ - $elem } @list; is(-1, $r); } leak_free_ok( bsearch => sub { my $elem = int(rand(1000)) + 1; bsearchidx { $_ - $elem } @list; } ); leak_free_ok( 'bsearch with stack-growing' => sub { my $elem = int(rand(1000)); bsearchidx { grow_stack(); $_ - $elem } @list; } ); leak_free_ok( 'bsearch with stack-growing and exception' => sub { my $elem = int(rand(1000)); eval { bsearchidx { grow_stack(); $_ - $elem or die "Goal!"; $_ - $elem } @list; }; } ); is_dying('bsearchidx without sub' => sub { &bsearchidx(42, (1 .. 100)); }); done_testing; List-MoreUtils-0.430/t/pureperl/minmaxstr.t0000644000175000017500000000220313744044755017056 0ustar snosno#!perl use strict ("subs", "vars", "refs"); use warnings ("all"); BEGIN { $ENV{LIST_MOREUTILS_PP} = 1; } END { delete $ENV{LIST_MOREUTILS_PP} } # for VMS use lib ("t/lib"); use List::MoreUtils (":all"); use Test::More; use Test::LMU; use POSIX qw(setlocale LC_COLLATE); setlocale(LC_COLLATE, "C"); my @list = reverse 'AA' .. 'ZZ'; my ($min, $max) = minmaxstr @list; is($min, 'AA'); is($max, 'ZZ'); # Odd number of elements push @list, 'ZZ Top'; ($min, $max) = minmaxstr @list; is($min, 'AA'); is($max, 'ZZ Top'); # COW causes missing max when optimization for 1 argument is applied @list = grep { defined $_ } map { my ($min, $max) = minmaxstr(sprintf("%s", rand)); ($min, $max) } (0 .. 19); is(scalar @list, 40, "minmaxstr swallows max on COW"); # Test with a single list value my $input = 'foo'; ($min, $max) = minmaxstr $input; is($min, 'foo'); is($max, 'foo'); # Confirm output are independant copies of input $input = 'bar'; is($min, 'foo'); is($max, 'foo'); $min = 'bar'; is($max, 'foo'); leak_free_ok( minmaxstr => sub { @list = reverse 'AA' .. 'ZZ', 'ZZ Top'; ($min, $max) = minmaxstr @list; } ); done_testing; List-MoreUtils-0.430/t/pureperl/uniq.t0000644000175000017500000000402113744044755016010 0ustar snosno#!perl use strict ("subs", "vars", "refs"); use warnings ("all"); BEGIN { $ENV{LIST_MOREUTILS_PP} = 1; } END { delete $ENV{LIST_MOREUTILS_PP} } # for VMS use lib ("t/lib"); use List::MoreUtils (":all"); BEGIN { $INC{'List/MoreUtils.pm'} or *distinct = __PACKAGE__->can("uniq"); } use Test::More; use Test::LMU; use Tie::Array (); SCOPE: { my @a = map { (1 .. 10) } 0 .. 1; my @u = uniq @a; is_deeply(\@u, [1 .. 10]); my $u = uniq @a; is(10, $u); } # Test aliases SCOPE: { my @a = map { (1 .. 10) } 0 .. 1; my @u = distinct @a; is_deeply(\@u, [1 .. 10]); my $u = distinct @a; is(10, $u); } # Test strings SCOPE: { my @a = map { ("a" .. "z") } 0 .. 1; my @u = uniq @a; is_deeply(\@u, ["a" .. "z"]); my $u = uniq @a; is(26, $u); } # Test mixing strings and numbers SCOPE: { my @a = ((map { (1 .. 10) } 0 .. 1), (map { ("a" .. "z") } 0 .. 1)); my $fa = freeze(\@a); my @u = uniq map { $_ } @a; my $fu = freeze(\@u); is_deeply(\@u, [1 .. 10, "a" .. "z"]); is($fa, freeze(\@a)); is($fu, freeze([1 .. 10, "a" .. "z"])); my $u = uniq @a; is(10 + 26, $u); } SCOPE: { my @a; tie @a, "Tie::StdArray"; @a = ((map { (1 .. 10) } 0 .. 1), (map { ("a" .. "z") } 0 .. 1)); my @u = uniq @a; is_deeply(\@u, [1 .. 10, "a" .. "z"]); @a = ((map { (1 .. 10) } 0 .. 1), (map { ("a" .. "z") } 0 .. 1)); my $u = uniq @a; is(10 + 26, $u); } SCOPE: { my @foo = ('a', 'b', '', undef, 'b', 'c', ''); my @ufoo = ('a', 'b', '', undef, 'c'); is_deeply([uniq @foo], \@ufoo, 'undef is supported correctly'); } leak_free_ok( uniq => sub { my @a = map { (1 .. 1000) } 0 .. 1; my @u = uniq @a; uniq @a[1 .. 100]; } ); # This test (and the associated fix) are from Kevin Ryde; see RT#49796 leak_free_ok( 'uniq with exception in overloading stringify', sub { eval { my $obj = DieOnStringify->new; my @u = uniq "foo", $obj, "bar", $obj; }; } ); done_testing; List-MoreUtils-0.430/t/pureperl/duplicates.t0000644000175000017500000000722513744044755017202 0ustar snosno#!perl use strict ("subs", "vars", "refs"); use warnings ("all"); BEGIN { $ENV{LIST_MOREUTILS_PP} = 1; } END { delete $ENV{LIST_MOREUTILS_PP} } # for VMS use lib ("t/lib"); use List::MoreUtils (":all"); use Test::More; use Test::LMU; use Tie::Array (); SCOPE: { my @s = (1001 .. 1200); my @d = (1 .. 1000); my @a = (@d, @s, @d); my $fa = freeze(\@a); my @u = duplicates @a; is($fa, freeze(\@a), "duplicates:G_ARRAY leaves numbers untouched"); is_deeply(\@u, [@d], "duplicates of numbers"); my $u = duplicates @a; is($fa, freeze(\@a), "duplicates:G_SCALAR leaves numbers untouched"); is(scalar @d, $u, "scalar result of duplicates of numbers"); } # Test strings SCOPE: { my @s = ("AA" .. "ZZ"); my @d = ("aa" .. "zz"); my @a = (@d, @s, @d); my $fa = freeze(\@a); my @u = duplicates @a; is($fa, freeze(\@a), "duplicates:G_ARRAY leaves numbers untouched"); is_deeply(\@u, [@d], "duplicates of numbers"); my $u = duplicates @a; is($fa, freeze(\@a), "duplicates:G_SCALAR leaves numbers untouched"); is(scalar @d, $u, "scalar result of duplicates of numbers"); } # Test mixing strings and numbers SCOPE: { my @s = (1001 .. 1200, "AA" .. "ZZ"); my @d = (1 .. 1000, "aa" .. "zz"); my $fd = freeze(\@d); my @a = (@d, @s, @d); my $fa = freeze(\@a); my @u = duplicates map { $_ } @a; my $fu = freeze(\@u); is_deeply(\@u, [@d], "duplicates of numbers/strings mixture"); is($fd, freeze(\@d), "frozen duplicates of numbers/strings mixture"); is($fa, freeze(\@a), "duplicates:G_ARRAY leaves mixture untouched"); is($fu, $fd); my $u = duplicates @a; is($fa, freeze(\@a), "duplicates:G_SCALAR leaves mixture untouched"); is(scalar @d, $u, "scalar result of duplicates of numbers/strings mixture"); } SCOPE: { my @a; tie @a, "Tie::StdArray"; my @s = (1001 .. 1200, "AA" .. "ZZ"); my @d = (1 .. 1000, "aa" .. "zz"); @a = (@d, @s, @d); my $fa = freeze(\@a); my @u = duplicates @a; is_deeply(\@u, [@d], "duplicates of tied array of numbers/strings mixture"); is($fa, freeze(\@a), "duplicates:G_ARRAY leaves mixture untouched"); @a = (@u, @d); $fa = freeze(\@a); my $u = duplicates @a; is($fa, freeze(\@a), "duplicates:G_SCALAR leaves mixture untouched"); is(scalar @d, $u, "scalar result of duplicates of tied array of numbers/strings mixture"); } SCOPE: { my @foo = ('a', 'b', '', undef, 'b', 'c', '', undef); my @dfoo = ('b', '', undef); is_deeply([duplicates @foo], \@dfoo, "two undef's are supported correctly by duplicates"); @foo = ('a', undef, 'b', '', 'b', 'c', ''); @dfoo = ('b', ''); is_deeply([duplicates @foo], \@dfoo, 'one undef is ignored correctly by duplicates'); is((scalar duplicates @foo), scalar @dfoo, 'scalar one undef is ignored correctly by duplicates'); } leak_free_ok( duplicates => sub { my @s = (1001 .. 1200, "AA" .. "ZZ"); my @d = map { (1 .. 1000, "aa" .. "zz") } 0 .. 1; my @a = (@d, @s); my @u = duplicates @a; scalar duplicates @a; } ); # This test (and the associated fix) are from Kevin Ryde; see RT#49796 leak_free_ok( 'duplicates with exception in overloading stringify', sub { eval { my $obj = DieOnStringify->new; my @foo = ('a', 'b', '', undef, $obj, 'b', 'c', '', undef, $obj); my @u = duplicates @foo; }; eval { my $obj = DieOnStringify->new; my $u = duplicates 'a', 'b', '', undef, $obj, 'b', 'c', '', undef, $obj; }; } ); done_testing; List-MoreUtils-0.430/t/pureperl/any.t0000644000175000017500000000154113744044755015627 0ustar snosno#!perl use strict ("subs", "vars", "refs"); use warnings ("all"); BEGIN { $ENV{LIST_MOREUTILS_PP} = 1; } END { delete $ENV{LIST_MOREUTILS_PP} } # for VMS use lib ("t/lib"); use List::MoreUtils (":all"); use Test::More; use Test::LMU; # Normal cases my @list = (1 .. 10000); is_true(any { $_ == 5000 } @list); is_true(any { $_ == 5000 } 1 .. 10000); is_true(any { defined } @list); is_false(any { not defined } @list); is_true(any { not defined } undef); is_false(any {}); leak_free_ok( any => sub { my $ok = any { $_ == 5000 } @list; my $ok2 = any { $_ == 5000 } 1 .. 10000; } ); leak_free_ok( 'any with a coderef that dies' => sub { # This test is from Kevin Ryde; see RT#48669 eval { my $ok = any { die } 1; }; } ); is_dying('any without sub' => sub { &any(42, 4711); }); done_testing; List-MoreUtils-0.430/t/pureperl/firstidx.t0000644000175000017500000000200413744044755016667 0ustar snosno#!perl use strict ("subs", "vars", "refs"); use warnings ("all"); BEGIN { $ENV{LIST_MOREUTILS_PP} = 1; } END { delete $ENV{LIST_MOREUTILS_PP} } # for VMS use lib ("t/lib"); use List::MoreUtils (":all"); BEGIN { $INC{'List/MoreUtils.pm'} or *first_index = __PACKAGE__->can("firstidx"); } use Test::More; use Test::LMU; my @list = (1 .. 10000); is(4999, (firstidx { $_ >= 5000 } @list), "firstidx"); is(-1, (firstidx { not defined } @list), "invalid firstidx"); is(0, (firstidx { defined } @list), "real firstidx"); is(-1, (firstidx {}), "empty firstidx"); SKIP: { # Test the alias is(4999, first_index { $_ >= 5000 } @list); is(-1, first_index { not defined } @list); is(0, first_index { defined } @list); is(-1, first_index {}); } leak_free_ok( firstidx => sub { my $i = firstidx { $_ >= 5000 } @list; my $i2 = firstidx { $_ >= 5000 } 1 .. 10000; } ); is_dying('firstidx without sub' => sub { &firstidx(42, 4711); }); done_testing; List-MoreUtils-0.430/t/pureperl/notall_u.t0000644000175000017500000000121513744044755016653 0ustar snosno#!perl use strict ("subs", "vars", "refs"); use warnings ("all"); BEGIN { $ENV{LIST_MOREUTILS_PP} = 1; } END { delete $ENV{LIST_MOREUTILS_PP} } # for VMS use lib ("t/lib"); use List::MoreUtils (":all"); use Test::More; use Test::LMU; # Normal cases my @list = (1 .. 10000); is_true(notall_u { !defined } @list); is_true(notall_u { $_ < 10000 } @list); is_false(notall_u { $_ <= 10000 } @list); is_undef(notall_u {}); leak_free_ok( notall_u => sub { my $ok = notall_u { $_ == 5000 } @list; my $ok2 = notall_u { $_ == 5000 } 1 .. 10000; } ); is_dying('notall_u without sub' => sub { ¬all_u(42, 4711); }); done_testing; List-MoreUtils-0.430/t/pureperl/bsearch.t0000644000175000017500000000220613744044755016446 0ustar snosno#!perl use strict ("subs", "vars", "refs"); use warnings ("all"); BEGIN { $ENV{LIST_MOREUTILS_PP} = 1; } END { delete $ENV{LIST_MOREUTILS_PP} } # for VMS use lib ("t/lib"); use List::MoreUtils (":all"); use Test::More; use Test::LMU; my @list = my @in = 1 .. 1000; for my $elem (@in) { ok(scalar bsearch { $_ - $elem } @list); } for my $elem (@in) { my ($e) = bsearch { $_ - $elem } @list; ok($e == $elem); } my @out = (-10 .. 0, 1001 .. 1011); for my $elem (@out) { my $r = bsearch { $_ - $elem } @list; ok(!defined $r); } leak_free_ok( bsearch => sub { my $elem = int(rand(1000)) + 1; scalar bsearch { $_ - $elem } @list; } ); leak_free_ok( 'bsearch with stack-growing' => sub { my $elem = int(rand(1000)); scalar bsearch { grow_stack(); $_ - $elem } @list; } ); leak_free_ok( 'bsearch with stack-growing and exception' => sub { my $elem = int(rand(1000)); eval { scalar bsearch { grow_stack(); $_ - $elem or die "Goal!"; $_ - $elem } @list; }; } ); is_dying('bsearch without sub' => sub { &bsearch(42, (1 .. 100)); }); done_testing; List-MoreUtils-0.430/t/pureperl/false.t0000644000175000017500000000144313744044755016133 0ustar snosno#!perl use strict ("subs", "vars", "refs"); use warnings ("all"); BEGIN { $ENV{LIST_MOREUTILS_PP} = 1; } END { delete $ENV{LIST_MOREUTILS_PP} } # for VMS use lib ("t/lib"); use List::MoreUtils (":all"); use Test::More; use Test::LMU; # The null set should return zero my $null_scalar = false {}; my @null_list = false {}; is($null_scalar, 0, 'false(null) returns undef'); is_deeply(\@null_list, [0], 'false(null) returns undef'); # Normal cases my @list = (1 .. 10000); is(10000, false { not defined } @list); is(0, false { defined } @list); is(1, false { $_ > 1 } @list); leak_free_ok( false => sub { my $n = false { $_ == 5000 } @list; my $n2 = false { $_ == 5000 } 1 .. 10000; } ); is_dying('false without sub' => sub { &false(42, 4711); }); done_testing; List-MoreUtils-0.430/t/pureperl/onlyres.t0000644000175000017500000000212313744044755016530 0ustar snosno#!perl use strict ("subs", "vars", "refs"); use warnings ("all"); BEGIN { $ENV{LIST_MOREUTILS_PP} = 1; } END { delete $ENV{LIST_MOREUTILS_PP} } # for VMS use lib ("t/lib"); use List::MoreUtils (":all"); BEGIN { $INC{'List/MoreUtils.pm'} or *only_result = __PACKAGE__->can("onlyres"); } use Test::More; use Test::LMU; my @list = (1 .. 300); is("Hallelujah", onlyres { 150 == $_ and "Hallelujah" } @list); is(1, onlyres { 300 == $_ } @list); is(undef, onlyres { 0 == $_ } @list); is(undef, onlyres { 1 <= $_ } @list); is(undef, onlyres { !(127 & $_) } @list); # Test aliases is(1, only_result { 150 == $_ } @list); is("Hallelujah", only_result { 300 == $_ and "Hallelujah" } @list); is(undef, only_result { 0 == $_ } @list); is(undef, only_result { 1 <= $_ } @list); is(undef, only_result { !(127 & $_) } @list); leak_free_ok( onlyres => sub { my $ok = onlyres { 150 <= $_ } @list; my $ok2 = onlyres { 150 <= $_ } 1 .. 300; } ); is_dying('onlyres without sub' => sub { &onlyres(42, 4711); }); done_testing; List-MoreUtils-0.430/t/pureperl/part.t0000644000175000017500000000452013744044755016006 0ustar snosno#!perl use strict ("subs", "vars", "refs"); use warnings ("all"); BEGIN { $ENV{LIST_MOREUTILS_PP} = 1; } END { delete $ENV{LIST_MOREUTILS_PP} } # for VMS use lib ("t/lib"); use List::MoreUtils (":all"); use Test::More; use Test::LMU; my @list = 1 .. 12; my $i = 0; my @part = part { $i++ % 3 } @list; is_deeply($part[0], [1, 4, 7, 10], " i: part % 3"); is_deeply($part[1], [2, 5, 8, 11], " ii: part % 3"); is_deeply($part[2], [3, 6, 9, 12], "iii: part % 3"); $list[2] = 0; is($part[2][0], 3, 'Values are not aliases'); @list = 1 .. 12; @part = part { 3 } @list; is($part[0], undef, " i: part 3"); is($part[1], undef, " ii: part 3"); is($part[2], undef, "iii: part 3"); is_deeply($part[3], [1 .. 12], " iv: part 3"); eval { @part = part { -1 } @list; }; like($@, qr/^Modification of non-creatable array value attempted, subscript -1/); $i = 0; @part = part { $i++ == 0 ? 0 : -1 } @list; is_deeply($part[0], [1 .. 12], "part with negative indices"); SKIP: { $INC{'List/MoreUtils/XS.pm'} and skip "Only PurePerl will warn here ...", 1; my @warns = (); local $SIG{__WARN__} = sub { push @warns, [@_] }; @part = part { undef } @list; is_deeply($part[0], [1 .. 12], "part with undef"); like(join("\n", @{$warns[0]}), qr/Use of uninitialized value in array element.*line\s+\d+\.$/, "warning of undef"); is_deeply(\@warns, [($warns[0]) x 12], "amount of similar undef warnings"); } @part = part { 10000 } @list; is_deeply($part[10000], [@list], " i: part 10_000"); is($part[0], undef, " ii: part 10_000"); is($part[@part / 2], undef, "iii: part 10_000"); is($part[9999], undef, " iv: part 10_000"); # Changing the list in place used to destroy # its elements due to a wrong refcnt @list = 1 .. 10; @list = part { $_ } @list; foreach (1 .. 10) { is_deeply($list[$_], [$_], "part \$_: $_"); } leak_free_ok( part => sub { my @list = 1 .. 12; my $i = 0; my @part = part { $i++ % 3 } @list; } ); leak_free_ok( 'part with stack-growing' => sub { # This test is from Kevin Ryde; see RT#38699 my @part = part { grow_stack(); 1024 } 'one', 'two'; } ); leak_free_ok( 'part with exception' => sub { my @long_list = int rand(1000) for 0 .. 1E7; my @part = part { $_ == 1E7 and die "Too much!"; ($_ % 10) * 2 } @long_list; } ); done_testing; List-MoreUtils-0.430/t/pureperl/lastval.t0000644000175000017500000000132513744044755016506 0ustar snosno#!perl use strict ("subs", "vars", "refs"); use warnings ("all"); BEGIN { $ENV{LIST_MOREUTILS_PP} = 1; } END { delete $ENV{LIST_MOREUTILS_PP} } # for VMS use lib ("t/lib"); use List::MoreUtils (":all"); BEGIN { $INC{'List/MoreUtils.pm'} or *last_value = __PACKAGE__->can("lastval"); } use Test::More; use Test::LMU; my $x = lastval { $_ > 5 } 4 .. 9; is($x, 9); $x = lastval { $_ > 5 } 1 .. 4; is($x, undef); is_undef(lastval { $_ > 5 }); # Test aliases $x = last_value { $_ > 5 } 4 .. 9; is($x, 9); $x = last_value { $_ > 5 } 1 .. 4; is($x, undef); leak_free_ok( lastval => sub { $x = lastval { $_ > 5 } 4 .. 9; } ); is_dying('lastval without sub' => sub { &lastval(42, 4711); }); done_testing; List-MoreUtils-0.430/t/pureperl/lastidx.t0000644000175000017500000000156213744044755016513 0ustar snosno#!perl use strict ("subs", "vars", "refs"); use warnings ("all"); BEGIN { $ENV{LIST_MOREUTILS_PP} = 1; } END { delete $ENV{LIST_MOREUTILS_PP} } # for VMS use lib ("t/lib"); use List::MoreUtils (":all"); BEGIN { $INC{'List/MoreUtils.pm'} or *last_index = __PACKAGE__->can("lastidx"); } use Test::More; use Test::LMU; my @list = (1 .. 10000); is(9999, lastidx { $_ >= 5000 } @list); is(-1, lastidx { not defined } @list); is(9999, lastidx { defined } @list); is(-1, lastidx {}); # Test aliases is(9999, last_index { $_ >= 5000 } @list); is(-1, last_index { not defined } @list); is(9999, last_index { defined } @list); is(-1, last_index {}); leak_free_ok( lastidx => sub { my $i = lastidx { $_ >= 5000 } @list; my $i2 = lastidx { $_ >= 5000 } 1 .. 10000; } ); is_dying('lastidx without sub' => sub { &lastidx(42, 4711); }); done_testing; List-MoreUtils-0.430/t/pureperl/insert_after.t0000644000175000017500000000253113744044755017525 0ustar snosno#!perl use strict ("subs", "vars", "refs"); use warnings ("all"); BEGIN { $ENV{LIST_MOREUTILS_PP} = 1; } END { delete $ENV{LIST_MOREUTILS_PP} } # for VMS use lib ("t/lib"); use List::MoreUtils (":all"); use Test::More; use Test::LMU; my @list = qw{This is a list}; insert_after { $_ eq "a" } "longer" => @list; is(join(' ', @list), "This is a longer list"); insert_after { 0 } "bla" => @list; is(join(' ', @list), "This is a longer list"); insert_after { $_ eq "list" } "!" => @list; is(join(' ', @list), "This is a longer list !"); @list = (qw{This is}, undef, qw{list}); insert_after { not defined($_) } "longer" => @list; $list[2] = "a"; is(join(' ', @list), "This is a longer list"); leak_free_ok( insert_after => sub { @list = qw{This is a list}; insert_after { $_ eq 'a' } "longer" => @list; } ); leak_free_ok( 'insert_after with exception' => sub { eval { my @list = (qw{This is}, DieOnStringify->new, qw{a list}); insert_after { $_ eq 'a' } "longer" => @list; }; } ); is_dying('insert_after without sub' => sub { &insert_after(42, 4711, [qw(die bart die)]); }); is_dying('insert_after without sub and array' => sub { &insert_after(42, 4711, "13"); }); is_dying( 'insert_after without array' => sub { &insert_after(sub { }, 4711, "13"); } ); done_testing; List-MoreUtils-0.430/t/pureperl/all.t0000644000175000017500000000113013744044755015602 0ustar snosno#!perl use strict ("subs", "vars", "refs"); use warnings ("all"); BEGIN { $ENV{LIST_MOREUTILS_PP} = 1; } END { delete $ENV{LIST_MOREUTILS_PP} } # for VMS use lib ("t/lib"); use List::MoreUtils (":all"); use Test::More; use Test::LMU; # Normal cases my @list = (1 .. 10000); is_true(all { defined } @list); is_true(all { $_ > 0 } @list); is_false(all { $_ < 5000 } @list); is_true(all {}); leak_free_ok( all => sub { my $ok = all { $_ == 5000 } @list; my $ok2 = all { $_ == 5000 } 1 .. 10000; } ); is_dying('all without sub' => sub { &all(42, 4711); }); done_testing; List-MoreUtils-0.430/t/pureperl/pairwise.t0000644000175000017500000000654513744044755016674 0ustar snosno#!perl use strict ("subs", "vars", "refs"); use warnings ("all"); BEGIN { $ENV{LIST_MOREUTILS_PP} = 1; } END { delete $ENV{LIST_MOREUTILS_PP} } # for VMS use lib ("t/lib"); use List::MoreUtils (":all"); use Test::More; use Test::LMU; my @a = (1, 2, 3, 4, 5); my @b = (2, 4, 6, 8, 10); my @c = pairwise { $a + $b } @a, @b; is_deeply(\@c, [3, 6, 9, 12, 15], "pw1"); @c = pairwise { $a * $b } @a, @b; # returns (2, 8, 18) is_deeply(\@c, [2, 8, 18, 32, 50], "pw2"); # Did we modify the input arrays? is_deeply(\@a, [1, 2, 3, 4, 5], "pw3"); is_deeply(\@b, [2, 4, 6, 8, 10], "pw4"); # $a and $b should be aliases: test @b = @a = (1, 2, 3); @c = pairwise { $a++; $b *= 2 } @a, @b; is_deeply(\@a, [2, 3, 4], "pw5"); is_deeply(\@b, [2, 4, 6], "pw6"); is_deeply(\@c, [2, 4, 6], "pw7"); # sub returns more than two items @a = (1, 1, 2, 3, 5); @b = (2, 3, 5, 7, 11, 13); @c = pairwise { ($a) x $b } @a, @b; is_deeply(\@c, [(1) x 2, (1) x 3, (2) x 5, (3) x 7, (5) x 11, (undef) x 13], "pw8"); is_deeply(\@a, [1, 1, 2, 3, 5], "pw9"); is_deeply(\@b, [2, 3, 5, 7, 11, 13], "pwX"); (@a, @b) = (); push @a, int rand(1000) for 0 .. rand(1000); push @b, int rand(1000) for 0 .. rand(1000); SCOPE: { local $SIG{__WARN__} = sub { }; # XXX my @res1 = pairwise { $a + $b } @a, @b; # Test this one more thoroughly: the XS code looks flakey # correctness of pairwise_perl proved by human auditing. :-) my $limit = $#a > $#b ? $#a : $#b; my @res2 = map { $a[$_] + $b[$_] } 0 .. $limit; is_deeply(\@res1, \@res2); } @a = qw/a b c/; @b = qw/1 2 3/; @c = pairwise { ($a, $b) } @a, @b; is_deeply(\@c, [qw/a 1 b 2 c 3/], "pw map"); SKIP: { $ENV{PERL5OPT} and skip 'A defined PERL5OPT may inject extra deps crashing this test', 1; # Test that a die inside the code-reference will not be trapped eval { pairwise { die "I died\n" } @a, @b; }; is($@, "I died\n"); } leak_free_ok( pairwise => sub { @a = (1); @b = (2); @c = pairwise { $a + $b } @a, @b; } ); leak_free_ok( 'exceptional block' => sub { @a = qw/a b c/; @b = qw/1 2 3/; eval { @c = pairwise { $b == 3 and die "Primes suck!"; "$a:$b" } @a, @b; }; } ); SKIP: { $INC{'List/MoreUtils/XS.pm'} or skip "PurePerl will warn here ...", 1; my ($a, $b, @t); eval { my @l1 = (1 .. 10); @t = pairwise { $a + $b } @l1, @l1; }; my $err = $@; like($err, qr/Can't use lexical \$a or \$b in pairwise code block/, "pairwise die's on broken caller"); } SKIP: { $INC{'List/MoreUtils/XS.pm'} and skip "XS will die on purpose here ...", 1; my @warns = (); local $SIG{__WARN__} = sub { push @warns, @_ }; my ($a, $b, @t); my @l1 = (1 .. 10); @t = pairwise { $a + $b } @l1, @l1; like(join("", @warns[0, 1]), qr/Use of uninitialized value.*? in addition/, "warning on broken caller"); } is_dying('pairwise without sub' => sub { &pairwise(42, \@a, \@b); }); SKIP: { $INC{'List/MoreUtils/XS.pm'} or skip "PurePerl will not core here ...", 2; is_dying( 'pairwise without first ARRAY' => sub { @c = &pairwise(sub { }, 1, \@b); } ); is_dying( 'pairwise without second ARRAY' => sub { @c = &pairwise(sub { }, \@a, 2); } ); } done_testing; List-MoreUtils-0.430/t/pureperl/any_u.t0000644000175000017500000000157313744044755016160 0ustar snosno#!perl use strict ("subs", "vars", "refs"); use warnings ("all"); BEGIN { $ENV{LIST_MOREUTILS_PP} = 1; } END { delete $ENV{LIST_MOREUTILS_PP} } # for VMS use lib ("t/lib"); use List::MoreUtils (":all"); use Test::More; use Test::LMU; # Normal cases my @list = (1 .. 10000); is_true(any_u { $_ == 5000 } @list); is_true(any_u { $_ == 5000 } 1 .. 10000); is_true(any_u { defined } @list); is_false(any_u { not defined } @list); is_true(any_u { not defined } undef); is_undef(any_u {}); leak_free_ok( any_u => sub { my $ok = any_u { $_ == 5000 } @list; my $ok2 = any_u { $_ == 5000 } 1 .. 10000; } ); leak_free_ok( 'any_u with a coderef that dies' => sub { # This test is from Kevin Ryde; see RT#48669 eval { my $ok = any_u { die } 1; }; } ); is_dying('any_u without sub' => sub { &any_u(42, 4711); }); done_testing; List-MoreUtils-0.430/t/pureperl/frequency.t0000644000175000017500000000763013744044755017046 0ustar snosno#!perl use strict ("subs", "vars", "refs"); use warnings ("all"); BEGIN { $ENV{LIST_MOREUTILS_PP} = 1; } END { delete $ENV{LIST_MOREUTILS_PP} } # for VMS use lib ("t/lib"); use List::MoreUtils (":all"); use Test::More; use Test::LMU; use Tie::Array (); SCOPE: { my @s = (1001 .. 1200); my @d = (1 .. 1000); my @a = (@d, @s, @d); my %e = ((map { $_ => 2 } @d), map { $_ => 1 } @s); my $fa = freeze(\@a); my %f = frequency @a; is($fa, freeze(\@a), "frequency:G_ARRAY leaves numbers untouched"); is_deeply(\%f, {%e}, "frequency of numbers"); my $f = frequency @a; is($fa, freeze(\@a), "frequency:G:SCALAR leaves numbers untouched"); is(scalar keys %e, $f, "scalar result of frequency of numbers"); } # Test strings SCOPE: { my @s = ("AA" .. "ZZ"); my @d = ("aa" .. "zz"); my @a = (@d, @s, @d); my $fa = freeze(\@a); my %e = ((map { $_ => 2 } @d), map { $_ => 1 } @s); my %f = frequency @a; is($fa, freeze(\@a), "frequency:G_ARRAY leaves strings untouched"); is_deeply(\%f, {%e}, "frequency of strings"); my $f = frequency @a; is($fa, freeze(\@a), "frequency:G_SCALAR leaves strings untouched"); is(scalar keys %e, $f, "scalar result of frequency of strings"); } # Test mixing strings and numbers SCOPE: { my @s = (1001 .. 1200, "AA" .. "ZZ"); my @d = (1 .. 1000, "aa" .. "zz"); my @a = (@d, @s, @d); my %e = ((map { $_ => 2 } @d), map { $_ => 1 } @s); my $fa = freeze(\@a); my %f = frequency @a; is($fa, freeze(\@a), "frequency:G_ARRAY leaves number/strings mixture untouched"); is_deeply(\%f, {%e}, "frequency of number/strings mixture"); my $f = frequency @a; is($fa, freeze(\@a), "frequency:G_SCALAR leaves number/strings mixture untouched"); is(scalar keys %e, $f, "scalar result of frequency of number/strings mixture"); } SCOPE: { my @a; tie @a, "Tie::StdArray"; my @s = (1001 .. 1200, "AA" .. "ZZ"); my @d = (1 .. 1000, "aa" .. "zz"); @a = (@d, @s, @d); my $fa = freeze(\@a); my %e = ((map { $_ => 2 } @d), map { $_ => 1 } @s); my %f = frequency @a; is($fa, freeze(\@a), "frequency:G_ARRAY leaves tied array of number/strings mixture untouched"); is_deeply(\%f, {%e}, "frequency of tied array of number/strings mixture"); my $f = frequency @a; is($fa, freeze(\@a), "frequency:G_SCALAR leaves tied array of number/strings mixture untouched"); is(scalar keys %e, $f, "scalar result of frequency of tied array of number/strings mixture"); } SCOPE: { my @foo = ('a', 'b', '', undef, 'b', 'c', '', undef); my %e = ( a => 1, b => 2, '' => 2, c => 1 ); my @f = frequency @foo; my $seen_undef; ref $f[-2] and ref $f[-2] eq "SCALAR" and not defined ${$f[-2]} and (undef, $seen_undef) = splice @f, -2, 2, (); my %f = @f; is_deeply(\%f, \%e, "stuff around undef's is supported correctly by frequency"); is($seen_undef, 2, "two undef's are supported correctly by frequency"); } leak_free_ok( frequency => sub { my @s = (1001 .. 1200, "AA" .. "ZZ"); my @d = map { (1 .. 1000, "aa" .. "zz") } 0 .. 1; my @a = (@d, @s); my %f = frequency @a; }, 'scalar frequency' => sub { my @s = (1001 .. 1200, "AA" .. "ZZ"); my @d = map { (1 .. 1000, "aa" .. "zz") } 0 .. 1; my @a = (@d, @s); my $f = frequency @a; } ); leak_free_ok( 'frequency with exception in overloading stringify', sub { eval { my $obj = DieOnStringify->new; my @foo = ('a', 'b', '', undef, $obj, 'b', 'c', '', undef, $obj); my %f = frequency @foo; }; eval { my $obj = DieOnStringify->new; my $f = frequency 'a', 'b', '', undef, $obj, 'b', 'c', '', undef, $obj; }; } ); done_testing; List-MoreUtils-0.430/t/pureperl/listcmp.t0000644000175000017500000000664613744044755016526 0ustar snosno#!perl use strict ("subs", "vars", "refs"); use warnings ("all"); BEGIN { $ENV{LIST_MOREUTILS_PP} = 1; } END { delete $ENV{LIST_MOREUTILS_PP} } # for VMS use lib ("t/lib"); use List::MoreUtils (":all"); use Test::More; use Test::LMU; use Tie::Array (); SCOPE: { my @a = qw(one two three four five six seven eight nine ten eleven twelve thirteen); my @b = qw(two three five seven eleven thirteen seventeen); my @c = qw(one one two three five eight thirteen twentyone); my %expected = ( one => [0, 2], two => [0, 1, 2], three => [0, 1, 2], four => [0], five => [0, 1, 2], six => [0], seven => [0, 1], eight => [0, 2], nine => [0], ten => [0], eleven => [0, 1], twelve => [0], thirteen => [0, 1, 2], seventeen => [1], twentyone => [2], ); my %cmped = listcmp @a, @b, @c; is_deeply(\%cmped, \%expected, "Sequence vs. Prime vs. Fibonacci sorted out correctly"); } SCOPE: { my @a = ("one", "two", "three", "four", "five", "six", "seven", "eight", "nine", "ten", "eleven", "twelve", "thirteen"); my @b = (undef, "two", "three", undef, "five", undef, "seven", undef, undef, undef, "eleven", undef, "thirteen"); my %expected = ( one => [0], two => [0, 1], three => [0, 1], four => [0], five => [0, 1], six => [0], seven => [0, 1], eight => [0], nine => [0], ten => [0], eleven => [0, 1], twelve => [0], thirteen => [0, 1], ); my %cmped = listcmp @a, @b; is_deeply(\%cmped, \%expected, "Sequence vs. Prime filled with undef sorted out correctly"); } leak_free_ok( listcmp => sub { my @a = ("one", "two", "three", "four", "five", "six", "seven", "eight", "nine", "ten", "eleven", "twelve", "thirteen"); my @b = (undef, "two", "three", undef, "five", undef, "seven", undef, undef, undef, "eleven", undef, "thirteen"); my %expected = ( one => [0], two => [0, 1], three => [0, 1], four => [0], five => [0, 1], six => [0], seven => [0, 1], eight => [0], nine => [0], ten => [0], eleven => [0, 1], twelve => [0], thirteen => [0, 1], ); my %cmped = listcmp @a, @b; } ); # This test (and the associated fix) are from Kevin Ryde; see RT#49796 leak_free_ok( 'listcmp with exception in overloading stringify at begin' => sub { eval { my @a = ("one", "two", "three"); my @b = (DieOnStringify->new, "two", "three"); my %expected = ( one => [0], two => [0, 1], three => [0, 1], ); my %cmped = listcmp @a, @b; }; }, 'listcmp with exception in overloading stringify at end' => sub { eval { my @a = ("one", "two", "three"); my @b = ("two", "three", DieOnStringify->new); my %expected = ( one => [0], two => [0, 1], three => [0, 1], ); my %cmped = listcmp @a, @b; }; } ); done_testing; List-MoreUtils-0.430/t/pureperl/binsert.t0000644000175000017500000000716313744044755016514 0ustar snosno#!perl use strict ("subs", "vars", "refs"); use warnings ("all"); BEGIN { $ENV{LIST_MOREUTILS_PP} = 1; } END { delete $ENV{LIST_MOREUTILS_PP} } # for VMS use lib ("t/lib"); use List::MoreUtils (":all"); use Test::More; use Test::LMU; SCOPE: { my @list = (); is(0, (binsert { $_ cmp "Hello" } "Hello", @list), "Inserting into empty list"); is(1, (binsert { $_ cmp "world" } "world", @list), "Inserting into one-item list"); } my @even = map { $_ * 2 } 1 .. 100; my @odd = map { $_ * 2 - 1 } 1 .. 100; my (@expected, @in); @in = @even; @expected = mesh @odd, @even; foreach my $v (@odd) { binsert { $_ <=> $v } $v, @in; } is_deeply(\@in, \@expected, "binsert odd elements into even list succeeded"); @in = @even; @expected = mesh @odd, @even; foreach my $v (reverse @odd) { binsert { $_ <=> $v } $v, @in; } is_deeply(\@in, \@expected, "binsert odd elements reversely into even list succeeded"); @in = @odd; foreach my $v (@even) { binsert { $_ <=> $v } $v, @in; } is_deeply(\@in, \@expected, "binsert even elements into odd list succeeded"); @in = @odd; foreach my $v (reverse @even) { binsert { $_ <=> $v } $v, @in; } is_deeply(\@in, \@expected, "binsert even elements reversely into odd list succeeded"); @in = @even; @expected = map { $_, $_ } @in; foreach my $v (@even) { binsert { $_ <=> $v } $v, @in; } is_deeply(\@in, \@expected, "binsert existing even elements into even list succeeded"); @in = @even; @expected = map { $_, $_ } @in; foreach my $v (reverse @even) { binsert { $_ <=> $v } $v, @in; } is_deeply(\@in, \@expected, "binsert existing even elements reversely into even list succeeded"); leak_free_ok( 'binsert random' => sub { my @list = map { $_ * 2 } 1 .. 100; my $elem = int(rand(100)) + 1; binsert { $_ <=> $elem } $elem, @list; }, 'binsert existing random' => sub { my @list = map { $_ * 2 } 1 .. 100; my $elem = 2 * (int(rand(100)) + 1); binsert { $_ <=> $elem } $elem, @list; }, 'binsert odd into even' => sub { my @list = @even; foreach my $elem (@odd) { binsert { $_ <=> $elem } $elem, @list; } }, 'binsert even into odd' => sub { my @list = @odd; foreach my $elem (@even) { binsert { $_ <=> $elem } $elem, @list; } }, 'binsert odd into odd' => sub { my @list = @odd; foreach my $elem (@odd) { binsert { $_ <=> $elem } $elem, @list; } }, 'binsert even into even' => sub { my @list = @even; foreach my $elem (@even) { binsert { $_ <=> $elem } $elem, @list; } }, ); leak_free_ok( 'binsert random with stack-growing' => sub { my @list = map { $_ * 2 } 1 .. 100; my $elem = int(rand(100)) + 1; binsert { grow_stack(); $_ <=> $elem } $elem, @list; }, 'binsert odd with stack-growing' => sub { my @list = @even; foreach my $elem (@odd) { binsert { grow_stack(); $_ <=> $elem } $elem, @list; } }, 'binsert even with stack-growing' => sub { my @list = @odd; foreach my $elem (@even) { binsert { grow_stack(); $_ <=> $elem } $elem, @list; } }, ); leak_free_ok( 'binsert with stack-growing and exception' => sub { my @list = map { $_ * 2 } 1 .. 100; my $elem = int(rand(100)) + 1; eval { binsert { grow_stack(); $_ <=> $elem or die "Goal!"; $_ <=> $elem } $elem, @list; }; } ); is_dying('binsert without sub' => sub { &binsert(42, @even); }); done_testing; List-MoreUtils-0.430/t/pureperl/insert_after_string.t0000644000175000017500000000214713744044755021116 0ustar snosno#!perl use strict ("subs", "vars", "refs"); use warnings ("all"); BEGIN { $ENV{LIST_MOREUTILS_PP} = 1; } END { delete $ENV{LIST_MOREUTILS_PP} } # for VMS use lib ("t/lib"); use List::MoreUtils (":all"); use Test::More; use Test::LMU; my @list = qw{This is a list}; insert_after_string "a", "longer" => @list; is(join(' ', @list), "This is a longer list"); @list = (undef, qw{This is a list}); insert_after_string "a", "longer", @list; shift @list; is(join(' ', @list), "This is a longer list"); @list = ("This\0", "is\0", "a\0", "list\0"); insert_after_string "a\0", "longer\0", @list; is(join(' ', @list), "This\0 is\0 a\0 longer\0 list\0"); leak_free_ok( insert_after_string => sub { @list = qw{This is a list}; insert_after_string "a", "longer", @list; } ); leak_free_ok( 'insert_after_string with exception' => sub { eval { my @list = (qw{This is}, DieOnStringify->new, qw{a list}); insert_after_string "a", "longer", @list; }; } ); is_dying('insert_after_string without array' => sub { &insert_after_string(42, 4711, "13"); }); done_testing; List-MoreUtils-0.430/t/pureperl/slideatatime.t0000644000175000017500000000301113744044755017477 0ustar snosno#!perl use strict ("subs", "vars", "refs"); use warnings ("all"); BEGIN { $ENV{LIST_MOREUTILS_PP} = 1; } END { delete $ENV{LIST_MOREUTILS_PP} } # for VMS use lib ("t/lib"); use List::MoreUtils (":all"); use Test::More; use Test::LMU; local $" = " "; my $it; my @r; my @x = ('a' .. 'g'); $it = slideatatime 3, 3, @x; while (my @vals = $it->()) { push @r, "@vals"; } is(is_deeply(\@r, ['a b c', 'd e f', 'g']), 1, "slideatatime as natatime with 3 elements"); $it = slideatatime 2, 3, @x; @r = (); while (my @vals = $it->()) { push @r, "@vals"; } is(is_deeply(\@r, ['a b c', 'c d e', 'e f g', 'g']), 1, "slideatatime moving 3 elements by 2 items"); $it = slideatatime 1, 3, @x; @r = (); while (my @vals = $it->()) { push @r, "@vals"; } is(is_deeply(\@r, ['a b c', 'b c d', 'c d e', 'd e f', 'e f g', 'f g', 'g']), 1, "slideatatime moving 3 elements by 1 item"); my @a = (1 .. 1000); $it = slideatatime 1, 1, @a; @r = (); while (my @vals = &$it) { push @r, @vals; } is(is_deeply(\@r, \@a), 1, "slideatatime as natatime with 1 element"); leak_free_ok( slideatatime => sub { my @y = 1; my $it = slideatatime 2, 2, @y; while (my @vals = $it->()) { # do nothing } }, 'slideatatime with exception' => sub { my @r; eval { my $it = slideatatime 1, 3, @x; while (my @vals = $it->()) { scalar @vals == 3 or die; push @r, "@vals"; } }; } ); done_testing; List-MoreUtils-0.430/t/pureperl/Import.t0000644000175000017500000000441513744044755016315 0ustar snosno#!perl use strict ("subs", "vars", "refs"); use warnings ("all"); BEGIN { $ENV{LIST_MOREUTILS_PP} = 1; } END { delete $ENV{LIST_MOREUTILS_PP} } # for VMS use lib ("t/lib"); use List::MoreUtils (":all"); use Test::More; use Test::LMU; my @pure_funcs = qw(any all none notall one any_u all_u none_u notall_u one_u true false insert_after insert_after_string apply indexes after after_incl before before_incl firstidx lastidx onlyidx firstval lastval onlyval firstres lastres onlyres singleton each_array each_arrayref pairwise natatime mesh uniq minmax part bsearch bsearchidx); my @v0_33 = qw(sort_by nsort_by); my %alias_list = ( v0_22 => { first_index => "firstidx", last_index => "lastidx", first_value => "firstval", last_value => "lastval", zip => "mesh", }, v0_33 => { distinct => "uniq", }, v0_400 => { first_result => "firstres", only_index => "onlyidx", only_value => "onlyval", only_result => "onlyres", last_result => "lastres", bsearch_index => "bsearchidx", }, ); can_ok(__PACKAGE__, $_) for @pure_funcs; SKIP: { $INC{'List/MoreUtils.pm'} or skip "List::MoreUtils::XS doesn't alias", 1; can_ok(__PACKAGE__, $_) for @v0_33; can_ok(__PACKAGE__, $_) for map { keys %$_ } values %alias_list; } done_testing; 1; =head1 AUTHOR Jens Rehsack Erehsack AT cpan.orgE Adam Kennedy Eadamk@cpan.orgE =head1 COPYRIGHT AND LICENSE Copyright 2013 - 2017 by Jens Rehsack All code added with 0.417 or later is licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in compliance with the License. You may obtain a copy of the License at http://www.apache.org/licenses/LICENSE-2.0 Unless required by applicable law or agreed to in writing, software distributed under the License is distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the License for the specific language governing permissions and limitations under the License. All code until 0.416 is licensed 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 List-MoreUtils-0.430/t/pureperl/natatime.t0000644000175000017500000000142713744044755016645 0ustar snosno#!perl use strict ("subs", "vars", "refs"); use warnings ("all"); BEGIN { $ENV{LIST_MOREUTILS_PP} = 1; } END { delete $ENV{LIST_MOREUTILS_PP} } # for VMS use lib ("t/lib"); use List::MoreUtils (":all"); use Test::More; use Test::LMU; my @x = ('a' .. 'g'); my $it = natatime 3, @x; my @r; local $" = " "; while (my @vals = $it->()) { push @r, "@vals"; } is(is_deeply(\@r, ['a b c', 'd e f', 'g']), 1, "natatime with 3 elements"); my @a = (1 .. 1000); $it = natatime 1, @a; @r = (); while (my @vals = &$it) { push @r, @vals; } is(is_deeply(\@r, \@a), 1, "natatime with 1 element"); leak_free_ok( natatime => sub { my @y = 1; my $it = natatime 2, @y; while (my @vals = $it->()) { # do nothing } } ); done_testing; List-MoreUtils-0.430/t/pureperl/after.t0000644000175000017500000000135613744044755016145 0ustar snosno#!perl use strict ("subs", "vars", "refs"); use warnings ("all"); BEGIN { $ENV{LIST_MOREUTILS_PP} = 1; } END { delete $ENV{LIST_MOREUTILS_PP} } # for VMS use lib ("t/lib"); use List::MoreUtils (":all"); use Test::More; use Test::LMU; my @x = after { $_ % 5 == 0 } 1 .. 9; is_deeply(\@x, [6, 7, 8, 9], "after 5"); @x = after { /foo/ } qw{bar baz}; is_deeply(\@x, [], 'Got the null list'); @x = after { /b/ } qw{bar baz foo }; is_deeply(\@x, [qw{baz foo }], "after /b/"); leak_free_ok( after => sub { @x = after { /z/ } qw{bar baz foo}; } ); is_dying('after without sub' => sub { &after(42, 4711); }); @x = (1, after { /foo/ } qw(abc def)); is_deeply(\@x, [1], "check XS implementation doesn't mess up stack"); done_testing; List-MoreUtils-0.430/t/pureperl/after_incl.t0000644000175000017500000000127413744044755017151 0ustar snosno#!perl use strict ("subs", "vars", "refs"); use warnings ("all"); BEGIN { $ENV{LIST_MOREUTILS_PP} = 1; } END { delete $ENV{LIST_MOREUTILS_PP} } # for VMS use lib ("t/lib"); use List::MoreUtils (":all"); use Test::More; use Test::LMU; my @x = after_incl { $_ % 5 == 0 } 1 .. 9; is_deeply(\@x, [5, 6, 7, 8, 9], "after 5, included"); @x = after_incl { /foo/ } qw{bar baz}; is_deeply(\@x, [], 'Got the null list'); @x = after_incl { /b/ } qw{bar baz foo}; is_deeply(\@x, [qw{bar baz foo}], "after /b/, included"); leak_free_ok( after_incl => sub { @x = after_incl { /z/ } qw{bar baz foo}; } ); is_dying('after_incl without sub' => sub { &after_incl(42, 4711); }); done_testing; List-MoreUtils-0.430/t/pureperl/firstval.t0000644000175000017500000000134013744044755016667 0ustar snosno#!perl use strict ("subs", "vars", "refs"); use warnings ("all"); BEGIN { $ENV{LIST_MOREUTILS_PP} = 1; } END { delete $ENV{LIST_MOREUTILS_PP} } # for VMS use lib ("t/lib"); use List::MoreUtils (":all"); BEGIN { $INC{'List/MoreUtils.pm'} or *first_value = __PACKAGE__->can("firstval"); } use Test::More; use Test::LMU; my $x = firstval { $_ > 5 } 4 .. 9; is($x, 6); $x = firstval { $_ > 5 } 1 .. 4; is($x, undef); is_undef(firstval { $_ > 5 }); # Test aliases $x = first_value { $_ > 5 } 4 .. 9; is($x, 6); $x = first_value { $_ > 5 } 1 .. 4; is($x, undef); leak_free_ok( firstval => sub { $x = firstval { $_ > 5 } 4 .. 9; } ); is_dying('firstval without sub' => sub { &firstval(42, 4711); }); done_testing; List-MoreUtils-0.430/t/pureperl/before.t0000644000175000017500000000120713744044755016301 0ustar snosno#!perl use strict ("subs", "vars", "refs"); use warnings ("all"); BEGIN { $ENV{LIST_MOREUTILS_PP} = 1; } END { delete $ENV{LIST_MOREUTILS_PP} } # for VMS use lib ("t/lib"); use List::MoreUtils (":all"); use Test::More; use Test::LMU; my @x = before { $_ % 5 == 0 } 1 .. 9; is_deeply(\@x, [1, 2, 3, 4], "before 5"); @x = before { /b/ } qw{bar baz}; is_deeply(\@x, [], 'Got the null list'); @x = before { /f/ } qw{bar baz foo}; is_deeply(\@x, [qw{bar baz}], "before /f/"); leak_free_ok( before => sub { @x = before { /f/ } qw{ bar baz foo }; } ); is_dying('before without sub' => sub { &before(42, 4711); }); done_testing; List-MoreUtils-0.430/t/pureperl/none.t0000644000175000017500000000114713744044755016001 0ustar snosno#!perl use strict ("subs", "vars", "refs"); use warnings ("all"); BEGIN { $ENV{LIST_MOREUTILS_PP} = 1; } END { delete $ENV{LIST_MOREUTILS_PP} } # for VMS use lib ("t/lib"); use List::MoreUtils (":all"); use Test::More; use Test::LMU; # Normal cases my @list = (1 .. 10000); is_true(none { not defined } @list); is_true(none { $_ > 10000 } @list); is_false(none { defined } @list); is_true(none {}); leak_free_ok( none => sub { my $ok = none { $_ == 5000 } @list; my $ok2 = none { $_ == 5000 } 1 .. 10000; } ); is_dying('none without sub' => sub { &none(42, 4711); }); done_testing; List-MoreUtils-0.430/t/pureperl/bremove.t0000644000175000017500000000617013744044755016502 0ustar snosno#!perl use strict ("subs", "vars", "refs"); use warnings ("all"); BEGIN { $ENV{LIST_MOREUTILS_PP} = 1; } END { delete $ENV{LIST_MOREUTILS_PP} } # for VMS use lib ("t/lib"); use List::MoreUtils (":all"); use Test::More; use Test::LMU; my @even = map { $_ * 2 } 1 .. 100; my @odd = map { $_ * 2 - 1 } 1 .. 100; my (@expected, @in); @expected = @even; @in = mesh @odd, @even; foreach my $v (@odd) { is($v, (bremove { $_ <=> $v } @in), "$v in order removed"); } is_deeply(\@in, \@expected, "bremove all odd elements succeeded"); @in = mesh @odd, @even; foreach my $v (reverse @odd) { is($v, (bremove { $_ <=> $v } @in), "$v reverse ordered removed"); } is_deeply(\@in, \@expected, "bremove all odd elements reversely succeeded"); @expected = @odd; @in = mesh @odd, @even; foreach my $v (@even) { is($v, (bremove { $_ <=> $v } @in), "$v in order removed"); } is_deeply(\@in, \@expected, "bremove all even elements succeeded"); @in = mesh @odd, @even; foreach my $v (reverse @even) { is($v, (bremove { $_ <=> $v } @in), "$v reverse ordered removed"); } is_deeply(\@in, \@expected, "bremove all even elements reversely succeeded"); # test from shawnlaffan from GH issue #2 of List-MoreUtils-XS SCOPE: { my @list = ('somestring'); my $target = $list[0]; is($target, (bremove { $_ cmp $target } @list), 'removed from single item list'); } leak_free_ok( 'bremove first' => sub { my @list = (1 .. 100); my $v = $list[0]; bremove { $_ <=> $v } @list; }, 'bremove last' => sub { my @list = (1 .. 100); my $v = $list[-1]; bremove { $_ <=> $v } @list; }, 'bremove middle' => sub { my @list = (1 .. 100); my $v = $list[int($#list / 2)]; bremove { $_ <=> $v } @list; }, ); leak_free_ok( 'bremove first with stack-growing' => sub { my @list = mesh @odd, @even; my $v = $list[0]; bremove { grow_stack(); $_ <=> $v } @list; }, 'bremove last with stack-growing' => sub { my @list = mesh @odd, @even; my $v = $list[-1]; bremove { grow_stack(); $_ <=> $v } @list; }, 'bremove middle with stack-growing' => sub { my @list = mesh @odd, @even; my $v = $list[int($#list / 2)]; bremove { grow_stack(); $_ <=> $v } @list; }, ); leak_free_ok( 'bremove first with stack-growing and exception' => sub { my @list = mesh @odd, @even; my $v = $list[0]; eval { bremove { grow_stack(); $_ <=> $v or die "Goal!"; $_ <=> $v } @list; }; }, 'bremove last with stack-growing and exception' => sub { my @list = mesh @odd, @even; my $v = $list[-1]; eval { bremove { grow_stack(); $_ <=> $v or die "Goal!"; $_ <=> $v } @list; }; }, 'bremove middle with stack-growing and exception' => sub { my @list = mesh @odd, @even; my $v = $list[int($#list / 2)]; eval { bremove { grow_stack(); $_ <=> $v or die "Goal!"; $_ <=> $v } @list; }; }, ); is_dying('bremove without sub' => sub { &bremove(42, @even); }); done_testing; List-MoreUtils-0.430/t/pureperl/qsort.t0000644000175000017500000000116013744044755016205 0ustar snosno#!perl use strict ("subs", "vars", "refs"); use warnings ("all"); BEGIN { $ENV{LIST_MOREUTILS_PP} = 1; } END { delete $ENV{LIST_MOREUTILS_PP} } # for VMS use lib ("t/lib"); use List::MoreUtils (":all"); use Test::More; use Test::LMU; plan skip_all => "It's insane to use a pure-perl qsort" unless $INC{'List/MoreUtils/XS.pm'}; my @ltn_asc = qw(2 3 5 7 11 13 17 19 23 29 31 37); my @ltn_des = reverse @ltn_asc; my @l; @l = @ltn_des; qsort sub { $a <=> $b }, @l; is_deeply(\@l, \@ltn_asc, "sorted ascending"); @l = @ltn_asc; qsort sub { $b <=> $a }, @l; is_deeply(\@l, \@ltn_des, "sorted descending"); done_testing; List-MoreUtils-0.430/t/xs/0000755000175000017500000000000013744044757013450 5ustar snosnoList-MoreUtils-0.430/t/xs/slide.t0000644000175000017500000000073413744044755014737 0ustar snosno#!perl use strict ("subs", "vars", "refs"); use warnings ("all"); BEGIN { $ENV{LIST_MOREUTILS_PP} = 0; } END { delete $ENV{LIST_MOREUTILS_PP} } # for VMS use List::MoreUtils (":all"); use lib ("t/lib"); use Test::More; use Test::LMU; # use case provided my Michael Schwern my @ol = (0 .. 3); is(join(", ", slide { "$a and $b" } @ol), "0 and 1, 1 and 2, 2 and 3", "M. Schwern requested example"); is_dying('slide without sub' => sub { &slide(0 .. 3); }); done_testing; List-MoreUtils-0.430/t/xs/zip6.t0000644000175000017500000000236513744044755014531 0ustar snosno#!perl use strict ("subs", "vars", "refs"); use warnings ("all"); BEGIN { $ENV{LIST_MOREUTILS_PP} = 0; } END { delete $ENV{LIST_MOREUTILS_PP} } # for VMS use List::MoreUtils (":all"); use lib ("t/lib"); use Test::More; use Test::LMU; SCOPE: { my @x = qw/a b c d/; my @y = qw/1 2 3 4/; my @z = zip6 @x, @y; is_deeply(\@z, [['a', 1], ['b', 2], ['c', 3], ['d', 4]], "zip6 two lists with same count of elements"); } SCOPE: { my @a = ('x'); my @b = ('1', '2'); my @c = qw/zip zap zot/; my @z = zip6 @a, @b, @c; is_deeply( \@z, [['x', 1, 'zip'], [undef, 2, 'zap'], [undef, undef, 'zot']], "zip6 three list with increasing count of elements" ); } # Make array with holes SCOPE: { my @a = (1 .. 10); my @d; $#d = 9; my @z = zip6 @a, @d; is_deeply( \@z, [[1, undef], [2, undef], [3, undef], [4, undef], [5, undef], [6, undef], [7, undef], [8, undef], [9, undef], [10, undef]], "zip6 one list with 9 elements with an empty list" ); } leak_free_ok( zip6 => sub { my @x = qw/a b c d e/; my @y = qw/1 2 3 4/; my @z = zip6 @x, @y; } ); is_dying('zip6 with a list, not at least two arrays' => sub { &zip6(1, 2); }); done_testing; List-MoreUtils-0.430/t/xs/reduce_u.t0000644000175000017500000000223713744044755015432 0ustar snosno#!perl use strict ("subs", "vars", "refs"); use warnings ("all"); BEGIN { $ENV{LIST_MOREUTILS_PP} = 0; } END { delete $ENV{LIST_MOREUTILS_PP} } # for VMS use List::MoreUtils (":all"); use lib ("t/lib"); use Test::More; use Test::LMU; use List::Util qw(sum); SCOPE: { my @exam_results = (0, 2, 4, 6, 5, 3, 0); my $pupil = sum @exam_results; my $wa = reduce_u { defined $a ? $a + $_ * $b / $pupil : 0 } @exam_results; $wa = sprintf("%0.2f", $wa); is($wa, 3.15, "weighted average of exam"); } leak_free_ok( 'reduce_u' => sub { my @exam_results = (undef, 2, 4, 6, 5, 3, 0); my $pupil = 20; my $wa = reduce_u { defined $a ? $a + $_ * $b / $pupil : 0 } @exam_results; }, 'reduce_u X' => sub { my @w = map { int(rand(5)) + 1; } 1 .. 100; my $c1 = reduce_u { ($a || 0) + $w[$_] * $b } 1 .. 100; } ); leak_free_ok( 'reduce_u with a coderef that dies' => sub { # This test is from Kevin Ryde; see RT#48669 eval { my $ok = reduce_u { die } 1; }; } ); is_dying('reduce_u without sub' => sub { &reduce_u(42, 4711); }); done_testing List-MoreUtils-0.430/t/xs/equal_range.t0000644000175000017500000000253313744044755016121 0ustar snosno#!perl use strict ("subs", "vars", "refs"); use warnings ("all"); BEGIN { $ENV{LIST_MOREUTILS_PP} = 0; } END { delete $ENV{LIST_MOREUTILS_PP} } # for VMS use List::MoreUtils (":all"); use lib ("t/lib"); use Test::More; use Test::LMU; my @list = (1, 1, 2, 2, 3, 3, 3, 3, 3, 3, 4, 4, 4, 4, 5, 5, 6, 7, 7, 7, 8, 8, 9, 9, 9, 9, 9, 11, 13, 13, 13, 17); is_deeply([0, 0], [equal_range { $_ <=> 0 } @list], "equal range 0"); is_deeply([0, 2], [equal_range { $_ <=> 1 } @list], "equal range 1"); is_deeply([2, 4], [equal_range { $_ <=> 2 } @list], "equal range 2"); is_deeply([10, 14], [equal_range { $_ <=> 4 } @list], "equal range 4"); is_deeply([(scalar @list) x 2], [equal_range { $_ <=> 19 } @list], "equal range 19"); my @in = @list = 1 .. 100; leak_free_ok( equal_range => sub { my $elem = int(rand(101)) + 1; equal_range { $_ - $elem } @list; } ); leak_free_ok( 'equal_range with stack-growing' => sub { my $elem = int(rand(101)); equal_range { grow_stack(); $_ - $elem } @list; } ); leak_free_ok( 'equal_range with stack-growing and exception' => sub { my $elem = int(rand(101)); eval { equal_range { grow_stack(); $_ - $elem or die "Goal!"; $_ - $elem } @list; }; } ); is_dying('equal_range without sub' => sub { &equal_range(42, (1 .. 100)); }); done_testing; List-MoreUtils-0.430/t/xs/none_u.t0000644000175000017500000000117213744044755015117 0ustar snosno#!perl use strict ("subs", "vars", "refs"); use warnings ("all"); BEGIN { $ENV{LIST_MOREUTILS_PP} = 0; } END { delete $ENV{LIST_MOREUTILS_PP} } # for VMS use List::MoreUtils (":all"); use lib ("t/lib"); use Test::More; use Test::LMU; # Normal cases my @list = (1 .. 10000); is_true(none_u { not defined } @list); is_true(none_u { $_ > 10000 } @list); is_false(none_u { defined } @list); is_undef(none_u {}); leak_free_ok( none_u => sub { my $ok = none_u { $_ == 5000 } @list; my $ok2 = none_u { $_ == 5000 } 1 .. 10000; } ); is_dying('none_u without sub' => sub { &none_u(42, 4711); }); done_testing; List-MoreUtils-0.430/t/xs/samples.t0000644000175000017500000000222113744044755015274 0ustar snosno#!perl use strict ("subs", "vars", "refs"); use warnings ("all"); BEGIN { $ENV{LIST_MOREUTILS_PP} = 0; } END { delete $ENV{LIST_MOREUTILS_PP} } # for VMS use List::MoreUtils (":all"); use lib ("t/lib"); use Test::More; use Test::LMU; SCOPE: { my @l = (1 .. 100); my @s = samples 10, @l; is(scalar @s, 10, "samples stops correctly after 10 integer probes"); my @u = uniq @s; is(scalar @u, 10, "samples doesn't add any integer twice"); } SCOPE: { my @l = (1 .. 10); my @s = samples 10, @l; is(scalar @s, 10, "samples delivers 10 out of 10 when used as shuffle"); my @u = uniq grep { defined $_ } @s; is(scalar @u, 10, "samples doesn't add any integer twice"); } SCOPE: { my @l = ('AA' .. 'ZZ'); my @s = samples 10, @l; is(scalar @s, 10, "samples stops correctly after 10 strings probes"); my @u = uniq @s; is(scalar @u, 10, "samples doesn't add any string twice"); } is_dying('to much samples' => sub { my @l = (1 .. 3); samples 5, @l }); SKIP: { $INC{'List/MoreUtils/XS.pm'} or skip "PurePerl will not fail here ...", 1; is_dying('samples without list' => sub { samples 5 }); } done_testing; List-MoreUtils-0.430/t/xs/mode.t0000644000175000017500000004022513744044755014562 0ustar snosno#!perl use strict ("subs", "vars", "refs"); use warnings ("all"); BEGIN { $ENV{LIST_MOREUTILS_PP} = 0; } END { delete $ENV{LIST_MOREUTILS_PP} } # for VMS use List::MoreUtils (":all"); use lib ("t/lib"); use Test::More; use Test::LMU; use Tie::Array (); SCOPE: { my $lorem = "Lorem ipsum dolor sit amet, consetetur sadipscing elitr, sed diam nonumy eirmod tempor invidunt ut labore et dolore magna aliquyam erat, sed diam voluptua. At vero eos et accusam et justo duo dolores et ea rebum. Stet clita kasd gubergren, no sea takimata sanctus est Lorem ipsum dolor sit amet. Lorem ipsum dolor sit amet, consetetur sadipscing elitr, sed diam nonumy eirmod tempor invidunt ut labore et dolore magna aliquyam erat, sed diam voluptua. At vero eos et accusam et justo duo dolores et ea rebum. Stet clita kasd gubergren, no sea takimata sanctus est Lorem ipsum dolor sit amet. Lorem ipsum dolor sit amet, consetetur sadipscing elitr, sed diam nonumy eirmod tempor invidunt ut labore et dolore magna aliquyam erat, sed diam voluptua."; my @lorem = grep { $_ } split /(?:\b|\s)/, $lorem; my $fl = freeze(\@lorem); my $n_comma = scalar(split /,/, $lorem) - 1; my @m = mode @lorem; is($fl, freeze(\@lorem), "mode:G_ARRAY lorem untouched"); is_deeply([$n_comma, ','], \@m, "lorem mode as list"); my $m = mode @lorem; is($fl, freeze(\@lorem), "mode:G_SCALAR lorem untouched"); is($n_comma, $m, "lorem mode as scalar"); } SCOPE: { my @probes = ((1) x 3, (2) x 4, (3) x 2, (4) x 7, (5) x 2, (6) x 4); my $fp = freeze(\@probes); my @m = mode @probes; is($fp, freeze(\@probes), "mode:G_ARRAY probes untouched"); is_deeply([7, 4], \@m, "unimodal result in list context"); my $m = mode @probes; is($fp, freeze(\@probes), "mode:G_SCALAR probes untouched"); is(7, $m, "unimodal result in scalar context"); } SCOPE: { my @probes = ((1) x 3, (2) x 4, (3) x 2, (4) x 7, (5) x 2, (6) x 4, (7) x 3, (8) x 7); my $fp = freeze(\@probes); my @m = mode @probes; is($fp, freeze(\@probes), "bimodal mode:G_ARRAY probes untouched"); my $m = shift @m; @m = sort @m; unshift @m, $m; is_deeply([7, 4, 8], \@m, "bimodal result in list context"); $m = mode @probes; is($fp, freeze(\@probes), "bimodal mode:G_SCALAR probes untouched"); is(7, $m, "bimodal result in scalar context"); } SCOPE: { my %radio_ukw_nrw = ( "87,6" => "WDR Eins Live", "87,7" => "WDR 5", "87,7" => "Welle Niederrhein", "87,7" => "WDR 5", "87,8" => "Welle West", "87,8" => "WDR 4", "87,8" => "WDR 2 Dortmund", "87,9" => "Radio HERTZ", "88,0" => "WDR 5", "88,1" => "Radio Hochstift", "88,2" => "Radio Kiepenkerl", "88,2" => "Radio Siegen", "88,3" => "WDR 5", "88,3" => "Radio MK", "88,4" => "WDR 2 Köln", "88,4" => "Radio WMW", "88,4" => "WDR 5", "88,5" => "WDR 5", "88,5" => "Werrepark Radio", "88,5" => "WDR 5", "88,6" => "WDR 5", "88,7" => "WDR 3", "88,8" => "WDR 5", "88,9" => "Deutschlandradio Kultur", "89,0" => "Lokalradio Olpe", "89,1" => "Deutschlandfunk (DLF)", "89,1" => "Radio Sauerland", "89,2" => "WDR (Test)", "89,3" => "Antenne Unna", "89,4" => "NE-WS 89,4", "89,4" => "L`UniCo FM", "89,6" => "WDR 5", "89,7" => "WDR 3", "90,0" => "CT das radio", "90,0" => "WDR 5", "90,1" => "WDR 4", "90,1" => "Deutschlandradio Kultur", "90,1" => "Radio 90,1", "90,3" => "WDR 5", "90,6" => "WDR 5", "90,7" => "WDR 4", "90,8" => "Radio Herne", "90,8" => "Radio MK", "90,9" => "Radio Q", "91,0" => "Deutschlandradio Kultur", "91,0" => "Deutschlandfunk (DLF)", "91,2" => "WDR (Test)", "91,2" => "Radio 91,2", "91,2" => "Radio Bonn/Rhein-Sieg", "91,3" => "Radio Lippe (geplant)", "91,3" => "Deutschlandfunk (DLF)", "91,3" => "BFBS Radio 1", "91,4" => "Radio Erft", "91,5" => "Radio MK", "91,5" => "Deutschlandfunk (DLF)", "91,5" => "Radio Ennepe Ruhr", "91,7" => "WDR 4", "91,7" => "BFBS Radio 2", "91,7" => "WDR 3", "91,7" => "Radio K.W.", "91,7" => "Radio Herford", "91,8" => "WDR 2 Wuppertal", "91,8" => "WDR 2 Bielefeld", "91,9" => "WDR 4", "92,0" => "WDR 5", "92,0" => "domradio", "92,1" => "Radius 92,1", "92,2" => "Radio Duisburg", "92,2" => "Deutschlandfunk (DLF)", "92,2" => "Radio RSG", "92,3" => "WDR 2 Siegen", "92,5" => "BFBS Radio 1", "92,5" => "Radio MK", "92,6" => "Radio WAF", "92,7" => "WDR 3", "92,7" => "Radio Rur", "92,7" => "Radio Ennepe Ruhr", "92,9" => "Radio Mülheim", "93,0" => "Radio WMW", "93,0" => "elDOradio", "93,1" => "WDR 3", "93,2" => "WDR 2 Bielefeld", "93,3" => "WDR 2 Rhein-Ruhr", "93,5" => "WDR 2 Siegen", "93,6" => "WDR Eins Live", "93,7" => "Radio Hochstift", "93,8" => "WDR 2 Siegen", "93,9" => "WDR 4", "93,9" => "Deutschlandfunk (DLF)", "93,9" => "WDR 5", "94,1" => "WDR 2 Münster", "94,2" => "Radio Bonn/Rhein-Sieg", "94,2" => "WDR 2 Aachen", "94,2" => "Deutschlandfunk (DLF)", "94,3" => "Antenne Bethel", "94,3" => "Radio RSG", "94,3" => "WDR 3", "94,5" => "Deutschlandfunk (DLF)", "94,6" => "Radio MK", "94,6" => "Test FM", "94,6" => "Deutschlandradio Kultur", "94,6" => "Radio Vest", "94,7" => "Radio FH", "94,7" => "Radio WAF", "94,8" => "WDR (Test)", "94,8" => "Radio Sauerland", "94,9" => "Radio Herford", "95,1" => "WDR 3", "95,1" => "Radio Westfalica", "95,2" => "WDR 3", "95,4" => "Antenne Münster", "95,5" => "Deutschlandfunk (DLF)", "95,6" => "Radio Vest", "95,7" => "Radio WAF", "95,7" => "Radio Westfalica", "95,7" => "WDR 2 Wuppertal", "95,8" => "WDR 5", "95,9" => "WDR 3", "95,9" => "Triquency", "95,9" => "Radio Gütersloh", "96,0" => "WDR Eins Live", "96,0" => "WDR 2 Münster", "96,0" => "WDR 2 Bielefeld", "96,1" => "Radio Emscher Lippe", "96,1" => "WDR 4", "96,1" => "Triquency", "96,2" => "Radio Sauerland", "96,3" => "WDR 3", "96,3" => "Radio WAF", "96,3" => "Deutschlandradio Kultur", "96,4" => "Radio Siegen (geplant)", "96,4" => "WDR 2 Bielefeld", "96,5" => "Deutschlandradio Kultur", "96,8" => "bonn FM", "96,9" => "Deutschlandradio Kultur", "96,9" => "Radio Berg", "97,0" => "WDR 3", "97,1" => "Antenne GL", "97,1" => "Hochschulradio Düsseldorf", "97,1" => "WDR 2 Siegen", "97,2" => "107.8 Antenne AC", "97,2" => "Radio MK", "97,3" => "Radio Siegen", "97,3" => "WDR 3", "97,3" => "WDR 3", "97,4" => "Antenne Unna", "97,5" => "WDR 3", "97,5" => "Deutschlandradio Kultur", "97,6" => "Radio WMW", "97,6" => "WDR (Test)", "97,6" => "Radio Bielefeld", "97,6" => "Radio Neandertal", "97,6" => "WDR 5", "97,7" => "Deutschlandradio Kultur", "97,8" => "Radio Bonn/Rhein-Sieg", "97,8" => "WDR 3", "98,0" => "Antenne Niederrhein", "98,1" => "WDR 3", "98,2" => "WDR 3", "98,2" => "WDR Eins Live", "98,3" => "Radio Bielefeld", "98,4" => "WDR 3", "98,5" => "Radio Bochum", "98,6" => "WDR 2 + Messeradio Köln", "98,6" => "WDR 5", "98,7" => "Radio Emscher Lippe", "98,9" => "Deutschlandradio Kultur", "98,9" => "Lokalradio Olpe", "98,9" => "Radio Siegen", "99,1" => "Hochschulradio Aachen", "99,1" => "WDR 2 Bielefeld", "99,2" => "WDR 2 Rhein-Ruhr", "99,4" => "WDR 2 Siegen", "99,4" => "Triquency", "99,5" => "WDR 4", "99,5" => "Radio MK", "99,6" => "WDR 4", "99,7" => "Radio Euskirchen", "99,7" => "WDR 5", "99,7" => "Radio Berg", "99,7" => "WDR Eins Live", "99,8" => "WDR 2 Wuppertal", "99,9" => "Radio Bonn/Rhein-Sieg", "100,0" => "Kölncampus", "100,0" => "WDR 4", "100,1" => "107.8 Antenne AC", "100,1" => "WDR Eins Live", "100,2" => "Radio MK", "100,2" => "Deutschlandradio Kultur", "100,4" => "WDR 2 Köln", "100,5" => "WDR 4", "100,6" => "Welle Niederrhein", "100,7" => "WDR 4", "100,8" => "WDR 2 Aachen", "100,9" => "Hellweg Radio", "101,0" => "WDR 2 Aachen", "101,0" => "Radio Lippe", "101,1" => "WDR 4", "101,1" => "Deutschlandradio Kultur", "101,2" => "WDR 4", "101,3" => "WDR 4", "101,6" => "BFBS Radio 2", "101,7" => "WDR 4", "101,7" => "domradio", "101,8" => "WDR 2 Siegen", "101,9" => "WDR 5", "101,9" => "BFBS Radio 1", "102,1" => "NE-WS 89,4", "102,1" => "WDR 2 Siegen", "102,2" => "Radio Essen", "102,2" => "BFBS Radio 2", "102,3" => "Antenne Unna", "102,4" => "WDR Eins Live", "102,5" => "WDR Eins Live", "102,7" => "Deutschlandfunk (DLF)", "102,7" => "Deutschlandfunk (DLF)", "102,8" => "Deutschlandfunk (DLF)", "103,0" => "BFBS Radio 1", "103,3" => "Funkhaus Europa", "103,6" => "Radio WMW", "103,6" => "Hellweg Radio", "103,7" => "WDR Eins Live", "103,8" => "WDR 4", "103,9" => "Radio Q", "104,0" => "BFBS Radio 1", "104,0" => "Radio RST", "104,1" => "WDR 4", "104,2" => "Radio Bonn/Rhein-Sieg", "104,2" => "Antenne Düsseldorf", "104,2" => "Radio Ennepe Ruhr", "104,3" => "BFBS Radio 2", "104,4" => "WDR 4", "104,4" => "Deutschlandfunk (DLF)", "104,5" => "CampusFM", "104,5" => "Deutschlandfunk (DLF)", "104,5" => "WDR 4", "104,7" => "WDR Eins Live", "104,8" => "Radio Hochstift", "104,8" => "Radio Hochstift", "104,9" => "Radio Sauerland", "105,0" => "Radio Essen", "105,0" => "Radio Lippe Welle Hamm", "105,0" => "107.8 Antenne AC", "105,0" => "BFBS Radio 2", "105,1" => "BFBS Radio 1", "105,2" => "Radio Vest", "105,2" => "Radio Berg", "105,2" => "Radio RST", "105,4" => "Radio Siegen", "105,5" => "WDR Eins Live", "105,5" => "WDR Eins Live", "105,6" => "CampusFM", "105,7" => "Antenne Niederrhein", "105,7" => "Radio Ennepe Ruhr", "105,7" => "WDR Eins Live", "105,7" => "Radio Berg", "105,8" => "Radio Erft", "106,0" => "BFBS Radio 1", "106,1" => "Deutschlandradio Kultur", "106,1" => "Deutschlandradio Kultur", "106,2" => "Deutschlandradio Kultur", "106,2" => "106.2 Radio Oberhausen", "106,3" => "Radio Kiepenkerl", "106,4" => "WDR Eins Live", "106,5" => "Radio Sauerland", "106,5" => "Radio Sauerland", "106,5" => "Radio St. Laurentius", "106,6" => "Radio Lippe", "106,6" => "Radio Westfalica", "106,6" => "Deutschlandfunk (DLF)", "106,7" => "WDR Eins Live", "106,8" => "Radio Gütersloh", "106,9" => "Radio Euskirchen", "107,0" => "WDR Eins Live", "107,1" => "Radio Köln", "107,2" => "WDR Eins Live", "107,2" => "Deutschlandfunk (DLF)", "107,3" => "WDR Eins Live", "107,3" => "Hellweg Radio", "107,4" => "Radio Euskirchen", "107,4" => "Radio Kiepenkerl", "107,4" => "Radio Lippe", "107,4" => "Radio Wuppertal", "107,5" => "Radio Rur", "107,5" => "Radio Gütersloh", "107,5" => "WDR Eins Live", "107,6" => "Radio Leverkusen", "107,6" => "Radio Sauerland", "107,6" => "Radio K.W.", "107,7" => "WDR Eins Live", "107,7" => "Hellweg Radio", "107,7" => "107.7 Radio Hagen", "107,8" => "107.8 Antenne AC", "107,8" => "Lokalradio Olpe", "107,9" => "Radio Bonn/Rhein-Sieg", "107,9" => "WDR Eins Live", "107,9" => "Radio RSG", ); my @m = mode values %radio_ukw_nrw; my $m = shift @m; @m = sort @m; unshift @m, $m; is_deeply([14, 'WDR 5', 'WDR Eins Live'], \@m, "multimodal result in list context"); $m = mode values %radio_ukw_nrw; is(14, $m, "multimodal result in scalar context"); } leak_free_ok( 'mode (unimodal)' => sub { my @probes = ((1) x 3, (2) x 4, (3) x 2, (4) x 7, (5) x 2, (6) x 4); my @m = mode @probes; }, 'scalar mode (unimodal)' => sub { my @probes = ((1) x 3, (2) x 4, (3) x 2, (4) x 7, (5) x 2, (6) x 4); my $m = mode @probes; }, 'mode (bimodal)' => sub { my @probes = ((1) x 3, (2) x 4, (3) x 2, (4) x 7, (5) x 2, (6) x 4, (7) x 3, (8) x 7); my @m = mode @probes; }, 'scalar mode (bimodal)' => sub { my @probes = ((1) x 3, (2) x 4, (3) x 2, (4) x 7, (5) x 2, (6) x 4, (7) x 3, (8) x 7); my $m = mode @probes; }, 'mode (multimodal)' => sub { my @probes = ((1) x 3, (2) x 4, (3) x 2, (4) x 7, (5) x 2, (6) x 4, (7) x 3, (8) x 7, (9) x 4, (10) x 3, (11) x 7); my @m = mode @probes; }, 'scalar mode (multimodal)' => sub { my @probes = ((1) x 3, (2) x 4, (3) x 2, (4) x 7, (5) x 2, (6) x 4, (7) x 3, (8) x 7, (9) x 4, (10) x 3, (11) x 7); my $m = mode @probes; }, ); leak_free_ok( 'mode (unimodal) with exception in overloading stringify' => sub { eval { my $obj = DieOnStringify->new; my @probes = ((1) x 3, $obj, (2) x 4, $obj, (3) x 2, $obj, (4) x 7, $obj, (5) x 2, $obj, (6) x 4); my @m = mode @probes; }; }, 'scalar mode (unimodal) with exception in overloading stringify' => sub { eval { my $obj = DieOnStringify->new; my @probes = ((1) x 3, $obj, (2) x 4, $obj, (3) x 2, $obj, (4) x 7, $obj, (5) x 2, $obj, (6) x 4); my $m = mode @probes; }; }, 'mode (bimodal) with exception in overloading stringify' => sub { eval { my $obj = DieOnStringify->new; my @probes = ((1) x 3, $obj, (2) x 4, $obj, (3) x 2, $obj, (4) x 7, $obj, (5) x 2, $obj, (6) x 4, $obj, (7) x 3, $obj, (8) x 7); my @m = mode @probes; }; }, 'scalar mode (bimodal) with exception in overloading stringify' => sub { eval { my $obj = DieOnStringify->new; my @probes = ((1) x 3, $obj, (2) x 4, $obj, (3) x 2, $obj, (4) x 7, $obj, (5) x 2, $obj, (6) x 4, $obj, (7) x 3, $obj, (8) x 7); my $m = mode @probes; }; }, 'mode (multimodal) with exception in overloading stringify' => sub { eval { my $obj = DieOnStringify->new; my @probes = ( (1) x 3, $obj, (2) x 4, $obj, (3) x 2, $obj, (4) x 7, $obj, (5) x 2, $obj, (6) x 4, $obj, (7) x 3, $obj, (8) x 7, $obj, (9) x 4, $obj, (10) x 3, $obj, (11) x 7 ); my @m = mode @probes; }; }, 'scalar mode (multimodal) with exception in overloading stringify' => sub { eval { my $obj = DieOnStringify->new; my @probes = ( (1) x 3, $obj, (2) x 4, $obj, (3) x 2, $obj, (4) x 7, $obj, (5) x 2, $obj, (6) x 4, $obj, (7) x 3, $obj, (8) x 7, $obj, (9) x 4, $obj, (10) x 3, $obj, (11) x 7 ); my $m = mode @probes; }; }, ); done_testing; List-MoreUtils-0.430/t/xs/all_u.t0000644000175000017500000000115313744044755014727 0ustar snosno#!perl use strict ("subs", "vars", "refs"); use warnings ("all"); BEGIN { $ENV{LIST_MOREUTILS_PP} = 0; } END { delete $ENV{LIST_MOREUTILS_PP} } # for VMS use List::MoreUtils (":all"); use lib ("t/lib"); use Test::More; use Test::LMU; # Normal cases my @list = (1 .. 10000); is_true(all_u { defined } @list); is_true(all_u { $_ > 0 } @list); is_false(all_u { $_ < 5000 } @list); is_undef(all_u {}); leak_free_ok( all_u => sub { my $ok = all_u { $_ == 5000 } @list; my $ok2 = all_u { $_ == 5000 } 1 .. 10000; } ); is_dying('all_u without sub' => sub { &all_u(42, 4711); }); done_testing; List-MoreUtils-0.430/t/xs/true.t0000644000175000017500000000143313744044755014613 0ustar snosno#!perl use strict ("subs", "vars", "refs"); use warnings ("all"); BEGIN { $ENV{LIST_MOREUTILS_PP} = 0; } END { delete $ENV{LIST_MOREUTILS_PP} } # for VMS use List::MoreUtils (":all"); use lib ("t/lib"); use Test::More; use Test::LMU; # The null set should return zero my $null_scalar = true {}; my @null_list = true {}; is($null_scalar, 0, 'true(null) returns undef'); is_deeply(\@null_list, [0], 'true(null) returns undef'); # Normal cases my @list = (1 .. 10000); is(10000, true { defined } @list); is(0, true { not defined } @list); is(1, true { $_ == 5000 } @list); leak_free_ok( true => sub { my $n = true { $_ == 5000 } @list; my $n2 = true { $_ == 5000 } 1 .. 10000; } ); is_dying('true without sub' => sub { &true(42, 4711); }); done_testing; List-MoreUtils-0.430/t/xs/reduce_0.t0000644000175000017500000000217113744044755015322 0ustar snosno#!perl use strict ("subs", "vars", "refs"); use warnings ("all"); BEGIN { $ENV{LIST_MOREUTILS_PP} = 0; } END { delete $ENV{LIST_MOREUTILS_PP} } # for VMS use List::MoreUtils (":all"); use lib ("t/lib"); use Test::More; use Test::LMU; use List::Util qw(sum); SCOPE: { my @exam_results = (2, 4, 6, 5, 3, 0); my $pupil = sum @exam_results; my $wa = reduce_0 { $a + ($_ + 1) * $b / $pupil } @exam_results; $wa = sprintf("%0.2f", $wa); is($wa, 3.15, "weighted average of exam"); } leak_free_ok( 'reduce_0' => sub { my @exam_results = (2, 4, 6, 5, 3, 0); my $pupil = 20; my $wa = reduce_0 { $a + ($_ + 1) * $b / $pupil } @exam_results; }, 'reduce_0 X' => sub { my @w = map { int(rand(5)) + 1; } 1 .. 100; my $c1 = reduce_0 { $a + $w[$_] * $b } 1 .. 100; } ); leak_free_ok( 'reduce_0 with a coderef that dies' => sub { # This test is from Kevin Ryde; see RT#48669 eval { my $ok = reduce_0 { die } 1; }; } ); is_dying('reduce_0 without sub' => sub { &reduce_0(42, 4711); }); done_testing List-MoreUtils-0.430/t/xs/notall.t0000644000175000017500000000117313744044755015126 0ustar snosno#!perl use strict ("subs", "vars", "refs"); use warnings ("all"); BEGIN { $ENV{LIST_MOREUTILS_PP} = 0; } END { delete $ENV{LIST_MOREUTILS_PP} } # for VMS use List::MoreUtils (":all"); use lib ("t/lib"); use Test::More; use Test::LMU; # Normal cases my @list = (1 .. 10000); is_true(notall { !defined } @list); is_true(notall { $_ < 10000 } @list); is_false(notall { $_ <= 10000 } @list); is_false(notall {}); leak_free_ok( notall => sub { my $ok = notall { $_ == 5000 } @list; my $ok2 = notall { $_ == 5000 } 1 .. 10000; } ); is_dying('notall without sub' => sub { ¬all(42, 4711); }); done_testing; List-MoreUtils-0.430/t/xs/apply.t0000644000175000017500000000354613744044755014770 0ustar snosno#!perl use strict ("subs", "vars", "refs"); use warnings ("all"); BEGIN { $ENV{LIST_MOREUTILS_PP} = 0; } END { delete $ENV{LIST_MOREUTILS_PP} } # for VMS use List::MoreUtils (":all"); use lib ("t/lib"); use Test::More; use Test::LMU; # Test the null case my $null_scalar = apply {}; is($null_scalar, undef, 'apply(null) returns undef'); my @null_list = apply {}; is_deeply(\@null_list, [], 'apply(null) returns null list'); # Normal cases my @list = (0 .. 9); my @list1 = apply { $_++ } @list; is_deeply(\@list, [0 .. 9], "original numbers untouched"); is_deeply(\@list1, [1 .. 10], "returned numbers increased"); @list = (" foo ", " bar ", " ", "foobar"); @list1 = apply { s/^\s+|\s+$//g } @list; is_deeply(\@list, [" foo ", " bar ", " ", "foobar"], "original strings untouched"); is_deeply(\@list1, ["foo", "bar", "", "foobar"], "returned strings stripped"); my $item = apply { s/^\s+|\s+$//g } @list; is($item, "foobar"); # RT 96596 SKIP: { $INC{'List/MoreUtils/XS.pm'} or skip "PurePerl will not fail here ...", 1; eval { my @a = \&apply(1, 2); }; my $err = $@; like($err, qr/\QList::MoreUtils::XS::apply(code, ...)\E/, "apply must be reasonable invoked"); } # RT 38630 SCOPE: { # wrong results from apply() [XS] @list = (1 .. 4); @list1 = apply { grow_stack(); $_ = 5; } @list; is_deeply(\@list, [1 .. 4]); is_deeply(\@list1, [(5) x 4]); } leak_free_ok( apply => sub { @list = (1 .. 4); @list1 = apply { grow_stack(); $_ = 5; } @list; } ); SCOPE: { leak_free_ok( 'dying callback during apply' => sub { my @l = (1 .. 4); eval { my @l1 = apply { $_ % 2 or die "Even!"; $_ %= 2; } @l; }; } ); } is_dying('apply without sub' => sub { &apply(42, 4711); }); done_testing; List-MoreUtils-0.430/t/xs/occurrences.t0000644000175000017500000000702613744044755016153 0ustar snosno#!perl use strict ("subs", "vars", "refs"); use warnings ("all"); BEGIN { $ENV{LIST_MOREUTILS_PP} = 0; } END { delete $ENV{LIST_MOREUTILS_PP} } # for VMS use List::MoreUtils (":all"); use lib ("t/lib"); use Test::More; use Test::LMU; use Tie::Array (); SCOPE: { my $lorem = "Lorem ipsum dolor sit amet, consetetur sadipscing elitr, sed diam nonumy eirmod tempor invidunt ut labore et dolore magna aliquyam erat, sed diam voluptua. At vero eos et accusam et justo duo dolores et ea rebum. Stet clita kasd gubergren, no sea takimata sanctus est Lorem ipsum dolor sit amet. Lorem ipsum dolor sit amet, consetetur sadipscing elitr, sed diam nonumy eirmod tempor invidunt ut labore et dolore magna aliquyam erat, sed diam voluptua. At vero eos et accusam et justo duo dolores et ea rebum. Stet clita kasd gubergren, no sea takimata sanctus est Lorem ipsum dolor sit amet. Lorem ipsum dolor sit amet, consetetur sadipscing elitr, sed diam nonumy eirmod tempor invidunt ut labore et dolore magna aliquyam erat, sed diam voluptua."; my @lorem = grep { $_ } split /(?:\b|\s)/, $lorem; my $n_comma = scalar(split /,/, $lorem) - 1; my $n_dot = scalar(split /\./, $lorem); # there is one at end ... mind the gap my $n_et = scalar(split /\bet\b/, $lorem) - 1; my @l = @lorem; my @o = occurrences @l; is(undef, $o[0], "Each word is counted"); is(undef, $o[1], "Text to long, each word is there at least twice"); is_deeply([','], $o[$n_comma], "$n_comma comma"); is_deeply(['.'], $o[$n_dot], "$n_dot dots"); is_deeply(['et'], $o[$n_et], "$n_et words 'et'"); @o = occurrences grep { /\w+/ } @lorem; my $wc = reduce_0 { defined $b ? $a + $_ * scalar @$b : $a } @o; is($wc, 124, "Words are as many as requested at www.loremipsum.de"); } SCOPE: { my @probes = ((1) x 3, (2) x 4, (3) x 2, (4) x 7, (5) x 2, (6) x 4); my $fp = freeze(\@probes); my @o = map { ref $_ ? [sort @$_] : $_ } occurrences @probes; is($fp, freeze(\@probes), "probes untouched"); my @expectation = (undef, undef, [3, 5], [1], [2, 6], undef, undef, [4]); is_deeply(\@expectation, \@o, "occurrences of integer probes"); } SCOPE: { my @probes = ((1) x 3, undef, (2) x 4, undef, (3) x 2, undef, (4) x 7, undef, (5) x 2, undef, (6) x 4); my $fp = freeze(\@probes); my @o = map { ref $_ ? [sort { (defined $a <=> defined $b) or $a <=> $b } @$_] : $_ } occurrences @probes; is($fp, freeze(\@probes), "probes untouched"); my @expectation = (undef, undef, [3, 5], [1], [2, 6], [undef], undef, [4]); is_deeply(\@expectation, \@o, "occurrences of integer probes"); } leak_free_ok( occurrences => sub { my @probes = ((1) x 3, (2) x 4, (3) x 2, (4) x 7, (5) x 2, (6) x 4); my @o = occurrences @probes; }, 'scalar occurrences' => sub { my @probes = ((1) x 3, (2) x 4, (3) x 2, (4) x 7, (5) x 2, (6) x 4); my $o = occurrences @probes; } ); leak_free_ok( 'occurrences with exception in overloading stringify', sub { eval { my $obj = DieOnStringify->new; my @probes = ((1) x 3, $obj, (2) x 4, $obj, (3) x 2, $obj, (4) x 7, $obj, (5) x 2, $obj, (6) x 4); my @o = occurrences @probes; }; eval { my $obj = DieOnStringify->new; my @probes = ((1) x 3, $obj, (2) x 4, $obj, (3) x 2, $obj, (4) x 7, $obj, (5) x 2, $obj, (6) x 4); my $o = occurrences @probes; }; } ); done_testing; List-MoreUtils-0.430/t/xs/lower_bound.t0000644000175000017500000000345413744044755016160 0ustar snosno#!perl use strict ("subs", "vars", "refs"); use warnings ("all"); BEGIN { $ENV{LIST_MOREUTILS_PP} = 0; } END { delete $ENV{LIST_MOREUTILS_PP} } # for VMS use List::MoreUtils (":all"); use lib ("t/lib"); use Test::More; use Test::LMU; my @list = (1, 1, 2, 2, 3, 3, 3, 3, 3, 3, 4, 4, 4, 4, 5, 5, 6, 7, 7, 7, 8, 8, 9, 9, 9, 9, 9, 11, 13, 13, 13, 17); is(0, (lower_bound { $_ <=> 0 } @list), "lower bound 0"); is(0, (lower_bound { $_ <=> 1 } @list), "lower bound 1"); is(2, (lower_bound { $_ <=> 2 } @list), "lower bound 2"); is(10, (lower_bound { $_ <=> 4 } @list), "lower bound 4"); is(scalar @list, (lower_bound { $_ <=> 19 } @list), "lower bound 19"); my @in = @list = 1 .. 100; for my $i (0 .. $#in) { my $j = $in[$i] - 1; is($i ? $i - 1 : 0, (lower_bound { $_ - $j } @list), "placed $j"); is($i, (lower_bound { $_ - $in[$i] } @list), "found $in[$i]"); } my @lout = ($in[0] - 11 .. $in[0] - 1); for my $elem (@lout) { is(0, (lower_bound { $_ - $elem } @list), "put smaller $elem in front"); } my @uout = ($in[-1] + 1 .. $in[-1] + 11); for my $elem (@uout) { is(scalar @list, (lower_bound { $_ - $elem } @list),, "put bigger $elem at end"); } leak_free_ok( lower_bound => sub { my $elem = int(rand(1000)) + 1; lower_bound { $_ - $elem } @list; } ); leak_free_ok( 'lower_bound with stack-growing' => sub { my $elem = int(rand(1000)); lower_bound { grow_stack(); $_ - $elem } @list; } ); leak_free_ok( 'lower_bound with stack-growing and exception' => sub { my $elem = int(rand(1000)); eval { lower_bound { grow_stack(); $_ - $elem or die "Goal!"; $_ - $elem } @list; }; } ); is_dying('lower_bound without sub' => sub { &lower_bound(42, (1 .. 100)); }); done_testing; List-MoreUtils-0.430/t/xs/one.t0000644000175000017500000000130213744044755014410 0ustar snosno#!perl use strict ("subs", "vars", "refs"); use warnings ("all"); BEGIN { $ENV{LIST_MOREUTILS_PP} = 0; } END { delete $ENV{LIST_MOREUTILS_PP} } # for VMS use List::MoreUtils (":all"); use lib ("t/lib"); use Test::More; use Test::LMU; # Normal cases my @list = (1 .. 300); is_true(one { 1 == $_ } @list); is_true(one { 150 == $_ } @list); is_true(one { 300 == $_ } @list); is_false(one { 0 == $_ } @list); is_false(one { 1 <= $_ } @list); is_false(one { !(127 & $_) } @list); is_false(one { 0 } ()); leak_free_ok( one => sub { my $ok = one { 150 <= $_ } @list; my $ok2 = one { 150 <= $_ } 1 .. 300; } ); is_dying('one without sub' => sub { &one(42, 4711); }); done_testing; List-MoreUtils-0.430/t/xs/onlyidx.t0000644000175000017500000000203413744044755015320 0ustar snosno#!perl use strict ("subs", "vars", "refs"); use warnings ("all"); BEGIN { $ENV{LIST_MOREUTILS_PP} = 0; } END { delete $ENV{LIST_MOREUTILS_PP} } # for VMS use List::MoreUtils (":all"); use lib ("t/lib"); BEGIN { $INC{'List/MoreUtils.pm'} or *only_index = __PACKAGE__->can("onlyidx"); } use Test::More; use Test::LMU; my @list = (1 .. 300); is(0, onlyidx { 1 == $_ } @list); is(149, onlyidx { 150 == $_ } @list); is(299, onlyidx { 300 == $_ } @list); is(-1, onlyidx { 0 == $_ } @list); is(-1, onlyidx { 1 <= $_ } @list); is(-1, onlyidx { !(127 & $_) } @list); # Test aliases is(0, only_index { 1 == $_ } @list); is(149, only_index { 150 == $_ } @list); is(299, only_index { 300 == $_ } @list); is(-1, only_index { 0 == $_ } @list); is(-1, only_index { 1 <= $_ } @list); is(-1, only_index { !(127 & $_) } @list); leak_free_ok( onlyidx => sub { my $ok = onlyidx { 150 <= $_ } @list; my $ok2 = onlyidx { 150 <= $_ } 1 .. 300; } ); is_dying('onlyidx without sub' => sub { &onlyidx(42, 4711); }); done_testing; List-MoreUtils-0.430/t/xs/firstres.t0000644000175000017500000000131213744044755015471 0ustar snosno#!perl use strict ("subs", "vars", "refs"); use warnings ("all"); BEGIN { $ENV{LIST_MOREUTILS_PP} = 0; } END { delete $ENV{LIST_MOREUTILS_PP} } # for VMS use List::MoreUtils (":all"); use lib ("t/lib"); BEGIN { $INC{'List/MoreUtils.pm'} or *first_result = __PACKAGE__->can("firstres"); } use Test::More; use Test::LMU; my $x = firstres { 2 * ($_ > 5) } 4 .. 9; is($x, 2); $x = firstres { $_ > 5 } 1 .. 4; is($x, undef); # Test aliases $x = first_result { $_ > 5 } 4 .. 9; is($x, 1); $x = first_result { $_ > 5 } 1 .. 4; is($x, undef); leak_free_ok( firstres => sub { $x = firstres { $_ > 5 } 4 .. 9; } ); is_dying('firstres without sub' => sub { &firstres(42, 4711); }); done_testing; List-MoreUtils-0.430/t/xs/arrayify.t0000644000175000017500000000651613744044755015471 0ustar snosno#!perl use strict ("subs", "vars", "refs"); use warnings ("all"); BEGIN { $ENV{LIST_MOREUTILS_PP} = 0; } END { delete $ENV{LIST_MOREUTILS_PP} } # for VMS use List::MoreUtils (":all"); use lib ("t/lib"); use Test::More; use Test::LMU; use Tie::Array (); SCOPE: { my @in = (1 .. 4, [5 .. 7], 8 .. 11, [[12 .. 17]], 18); my @out = arrayify @in; is_deeply(\@out, [1 .. 18], "linear flattened int mix i"); } SCOPE: { my @in = (1 .. 4, [[5 .. 11]], 12, [[13 .. 17]]); my @out = arrayify @in; is_deeply(\@out, [1 .. 17], "linear flattened int mix ii"); } SCOPE: { # typical structure when parsing XML using XML::Hash::XS my %src = ( root => { foo_list => {foo_elem => {attr => 42}}, bar_list => {bar_elem => [{hummel => 2}, {hummel => 3}, {hummel => 5}]} } ); my @foo_elems = arrayify $src{root}->{foo_list}->{foo_elem}; is_deeply(\@foo_elems, [{attr => 42}], "arrayified struct with one element"); my @bar_elems = arrayify $src{root}->{bar_list}->{bar_elem}; is_deeply(\@bar_elems, [{hummel => 2}, {hummel => 3}, {hummel => 5}], "arrayified struct with three elements"); } SCOPE: { my @in; tie @in, "Tie::StdArray"; @in = (1 .. 4, [5 .. 7], 8 .. 11, [[12 .. 17]]); my @out = arrayify @in; is_deeply(\@out, [1 .. 17], "linear flattened magic int mix"); } SCOPE: { my (@in, @inner, @innest); tie @in, "Tie::StdArray"; tie @inner, "Tie::StdArray"; tie @innest, "Tie::StdArray"; @inner = (5 .. 7); @innest = ([12 .. 17]); @in = (1 .. 4, \@inner, 8 .. 11, [@innest]); my @out = arrayify @in; is_deeply(\@out, [1 .. 17], "linear flattened magic int mixture"); } SCOPE: { my @in = (qw(av_make av_undef av_clear), [qw(av_push av_pop)], qw(av_fetch av_store), [['av_shift'], ['av_unshift']]); my @out = arrayify @in; is_deeply( \@out, [qw(av_make av_undef av_clear av_push av_pop av_fetch av_store av_shift av_unshift)], "linear flattened string mix i" ); } leak_free_ok( arrayify => sub { my @in = (1 .. 4, [5 .. 7], 8 .. 11, [[12 .. 17]]); my @out = arrayify @in; }, 'arrayify magic' => sub { my (@in, @inner, @innest); tie @in, "Tie::StdArray"; tie @inner, "Tie::StdArray"; tie @innest, "Tie::StdArray"; @inner = (5 .. 7); @innest = ([12 .. 17]); @in = (1 .. 4, \@inner, 8 .. 11, [@innest]); my @out = arrayify @in; } ); SKIP: { leak_free_ok( 'arrayify with exception in overloading stringify at begin' => sub { my @in = ( DieOnStringify->new, qw(av_make av_undef av_clear), [qw(av_push av_pop)], qw(av_fetch av_store), [['av_shift'], ['av_unshift']] ); eval { my @out = arrayify @in; }; diag($@) if ($@); }, ); leak_free_ok( 'arrayify with exception in overloading stringify at end' => sub { my @in = ( qw(av_make av_undef av_clear), [qw(av_push av_pop)], qw(av_fetch av_store), [['av_shift'], ['av_unshift']], DieOnStringify->new ); eval { my @out = arrayify @in; }; diag($@) if ($@); } ); } done_testing; List-MoreUtils-0.430/t/xs/mesh.t0000644000175000017500000000331413744044755014570 0ustar snosno#!perl use strict ("subs", "vars", "refs"); use warnings ("all"); BEGIN { $ENV{LIST_MOREUTILS_PP} = 0; } END { delete $ENV{LIST_MOREUTILS_PP} } # for VMS use List::MoreUtils (":all"); use lib ("t/lib"); BEGIN { $INC{'List/MoreUtils.pm'} or *zip = __PACKAGE__->can("mesh"); } use Test::More; use Test::LMU; SCOPE: { my @x = qw/a b c d/; my @y = qw/1 2 3 4/; my @z = mesh @x, @y; is_deeply(\@z, ['a', 1, 'b', 2, 'c', 3, 'd', 4], "mesh two list with same count of elements"); } SCOPE: { # alias check my @x = qw/a b c d/; my @y = qw/1 2 3 4/; my @z = zip @x, @y; is_deeply(\@z, ['a', 1, 'b', 2, 'c', 3, 'd', 4], "zip two list with same count of elements"); } SCOPE: { my @a = ('x'); my @b = ('1', '2'); my @c = qw/zip zap zot/; my @z = mesh @a, @b, @c; is_deeply(\@z, ['x', 1, 'zip', undef, 2, 'zap', undef, undef, 'zot'], "mesh three list with increasing count of elements"); } SCOPE: { # alias check my @a = ('x'); my @b = ('1', '2'); my @c = qw/zip zap zot/; my @z = zip @a, @b, @c; is_deeply(\@z, ['x', 1, 'zip', undef, 2, 'zap', undef, undef, 'zot'], "zip three list with increasing count of elements"); } # Make array with holes SCOPE: { my @a = (1 .. 10); my @d; $#d = 9; my @z = mesh @a, @d; is_deeply( \@z, [1, undef, 2, undef, 3, undef, 4, undef, 5, undef, 6, undef, 7, undef, 8, undef, 9, undef, 10, undef,], "mesh one list with 9 elements with an empty list" ); } leak_free_ok( mesh => sub { my @x = qw/a b c d e/; my @y = qw/1 2 3 4/; my @z = mesh @x, @y; } ); is_dying('mesh with a list, not at least two arrays' => sub { &mesh(1, 2); }); done_testing; List-MoreUtils-0.430/t/xs/lastres.t0000644000175000017500000000130013744044755015302 0ustar snosno#!perl use strict ("subs", "vars", "refs"); use warnings ("all"); BEGIN { $ENV{LIST_MOREUTILS_PP} = 0; } END { delete $ENV{LIST_MOREUTILS_PP} } # for VMS use List::MoreUtils (":all"); use lib ("t/lib"); BEGIN { $INC{'List/MoreUtils.pm'} or *last_result = __PACKAGE__->can("lastres"); } use Test::More; use Test::LMU; my $x = lastres { 2 * ($_ > 5) } 4 .. 9; is($x, 2); $x = lastres { $_ > 5 } 1 .. 4; is($x, undef); # Test aliases $x = last_result { $_ > 5 } 4 .. 9; is($x, 1); $x = last_result { $_ > 5 } 1 .. 4; is($x, undef); leak_free_ok( lastres => sub { $x = lastres { $_ > 5 } 4 .. 9; } ); is_dying('lastres without sub' => sub { &lastres(42, 4711); }); done_testing; List-MoreUtils-0.430/t/xs/before_incl.t0000644000175000017500000000127513744044755016107 0ustar snosno#!perl use strict ("subs", "vars", "refs"); use warnings ("all"); BEGIN { $ENV{LIST_MOREUTILS_PP} = 0; } END { delete $ENV{LIST_MOREUTILS_PP} } # for VMS use List::MoreUtils (":all"); use lib ("t/lib"); use Test::More; use Test::LMU; my @x = before_incl { $_ % 5 == 0 } 1 .. 9; is_deeply(\@x, [1, 2, 3, 4, 5], "before 5, included"); @x = before_incl { /foo/ } qw{bar baz}; is_deeply(\@x, [qw{bar baz}]); @x = before_incl { /f/ } qw{bar baz foo}; is_deeply(\@x, [qw{bar baz foo}], "before /f/, included"); leak_free_ok( before_incl => sub { @x = before_incl { /z/ } qw{ bar baz foo }; } ); is_dying('before_incl without sub' => sub { &before_incl(42, 4711); }); done_testing; List-MoreUtils-0.430/t/xs/indexes.t0000644000175000017500000000414713744044755015300 0ustar snosno#!perl use strict ("subs", "vars", "refs"); use warnings ("all"); BEGIN { $ENV{LIST_MOREUTILS_PP} = 0; } END { delete $ENV{LIST_MOREUTILS_PP} } # for VMS use List::MoreUtils (":all"); use lib ("t/lib"); use Test::More; use Test::LMU; my @x = indexes { $_ > 5 } (4 .. 9); is_deeply(\@x, [2 .. 5], "indexes > 5 ..."); @x = indexes { $_ > 5 } (1 .. 4); is_deeply(\@x, [], 'Got the null list'); my ($lr, @s, @n, @o, @e); leak_free_ok( indexes => sub { $lr = 1; @s = indexes { $_ > 5 } (4 .. 9); @n = indexes { $_ > 5 } (1 .. 5); @o = indexes { $_ & 1 } (10 .. 15); @e = indexes { !($_ & 1) } (10 .. 15); } ); $lr and is_deeply(\@s, [2 .. 5], "indexes/leak: some"); $lr and is_deeply(\@n, [], "indexes/leak: none"); $lr and is_deeply(\@o, [1, 3, 5], "indexes/leak: odd"); $lr and is_deeply(\@e, [0, 2, 4], "indexes/leak: even"); @n = map { $_ + 1 } @o = (0 .. 9); @x = indexes { ++$_ > 7 } @o; is_deeply(\@o, \@n, "indexes behaves like grep on modified \$_"); is_deeply(\@x, [7 .. 9], "indexes/modify"); not_dying( 'indexes_on_set' => sub { @x = indexes { ++$_ > 7 } (0 .. 9); } ); is_deeply(\@x, [7 .. 9], "indexes/modify set"); leak_free_ok( indexes => sub { @s = indexes { grow_stack; $_ > 5 } (4 .. 9); @n = indexes { grow_stack; $_ > 5 } (1 .. 4); @o = indexes { grow_stack; $_ & 1 } (10 .. 15); @e = indexes { grow_stack; !($_ & 1) } (10 .. 15); }, 'indexes interrupted by exception' => sub { eval { @s = indexes { $_ > 10 and die "range exceeded"; $_ > 5 } (1 .. 15); }; }, ); $lr and is_deeply(\@s, [2 .. 5], "indexes/leak: some"); $lr and is_deeply(\@n, [], "indexes/leak: none"); $lr and is_deeply(\@o, [1, 3, 5], "indexes/leak: odd"); $lr and is_deeply(\@e, [0, 2, 4], "indexes/leak: even"); my $have_scalar_util = eval { require Scalar::Util; 1 }; if ($have_scalar_util) { my $ref = \(indexes(sub { 1 }, 123)); Scalar::Util::weaken($ref); is($ref, undef, "weakened away"); } is_dying('indexes without sub' => sub { &indexes(42, 4711); }); done_testing; List-MoreUtils-0.430/t/xs/onlyval.t0000644000175000017500000000206413744044755015321 0ustar snosno#!perl use strict ("subs", "vars", "refs"); use warnings ("all"); BEGIN { $ENV{LIST_MOREUTILS_PP} = 0; } END { delete $ENV{LIST_MOREUTILS_PP} } # for VMS use List::MoreUtils (":all"); use lib ("t/lib"); BEGIN { $INC{'List/MoreUtils.pm'} or *only_value = __PACKAGE__->can("onlyval"); } use Test::More; use Test::LMU; my @list = (1 .. 300); is(1, onlyval { 1 == $_ } @list); is(150, onlyval { 150 == $_ } @list); is(300, onlyval { 300 == $_ } @list); is(undef, onlyval { 0 == $_ } @list); is(undef, onlyval { 1 <= $_ } @list); is(undef, onlyval { !(127 & $_) } @list); # Test aliases is(1, only_value { 1 == $_ } @list); is(150, only_value { 150 == $_ } @list); is(300, only_value { 300 == $_ } @list); is(undef, only_value { 0 == $_ } @list); is(undef, only_value { 1 <= $_ } @list); is(undef, only_value { !(127 & $_) } @list); leak_free_ok( onlyval => sub { my $ok = onlyval { 150 <= $_ } @list; my $ok2 = onlyval { 150 <= $_ } 1 .. 300; } ); is_dying('onlyval without sub' => sub { &onlyval(42, 4711); }); done_testing; List-MoreUtils-0.430/t/xs/minmax.t0000644000175000017500000000432013744044755015123 0ustar snosno#!perl use strict ("subs", "vars", "refs"); use warnings ("all"); BEGIN { $ENV{LIST_MOREUTILS_PP} = 0; } END { delete $ENV{LIST_MOREUTILS_PP} } # for VMS use List::MoreUtils (":all"); use lib ("t/lib"); use Test::More; use Test::LMU; my @list = reverse 0 .. 10000; my ($min, $max) = minmax @list; is($min, 0); is($max, 10000); # Even number of elements push @list, 10001; ($min, $max) = minmax @list; is($min, 0); is($max, 10001); $list[0] = 17; # Some floats @list = (0, -1.1, 3.14, 1 / 7, 10000, -10 / 3); ($min, $max) = minmax @list; # Floating-point comparison cunningly avoided is(sprintf("%.2f", $min), "-3.33"); is($max, 10000); # Test with a single negative list value my $input = -1; ($min, $max) = minmax $input; is($min, -1); is($max, -1); # COW causes missing max when optimization for 1 argument is applied @list = grep { defined $_ } map { my ($min, $max) = minmax(sprintf("%.3g", rand)); ($min, $max) } (0 .. 19); is(scalar @list, 40, "minmax swallows max on COW"); # Confirm output are independant copies of input $input = 1; is($min, -1); is($max, -1); $min = 2; is($max, -1); # prove overrun my $uvmax = ~0; my $ivmax = $uvmax >> 1; my $ivmin = (0 - $ivmax) - 1; my @low_ints = map { $ivmin + $_ } (0 .. 10); ($min, $max) = minmax @low_ints; is($min, $ivmin, "minmax finds ivmin"); is($max, $ivmin + 10, "minmax finds ivmin + 10"); my @high_ints = map { $ivmax - $_ } (0 .. 10); ($min, $max) = minmax @high_ints; is($min, $ivmax - 10, "minmax finds ivmax-10"); is($max, $ivmax, "minmax finds ivmax"); my @mixed_ints = map { ($ivmin + $_, $ivmax - $_) } (0 .. 10); ($min, $max) = minmax @mixed_ints; is($min, $ivmin, "minmax finds ivmin"); is($max, $ivmax, "minmax finds ivmax"); my @high_uints = map { $uvmax - $_ } (0 .. 10); ($min, $max) = minmax @high_uints; is($min, $uvmax - 10, "minmax finds uvmax-10"); is($max, $uvmax, "minmax finds uvmax"); my @mixed_nums = map { ($ivmin + $_, $uvmax - $_) } (0 .. 10); ($min, $max) = minmax @mixed_nums; is($min, $ivmin, "minmax finds ivmin"); is($max, $uvmax, "minmax finds uvmax"); leak_free_ok( minmax => sub { @list = (0, -1.1, 3.14, 1 / 7, 10000, -10 / 3); ($min, $max) = minmax @list; } ); done_testing; List-MoreUtils-0.430/t/xs/upper_bound.t0000644000175000017500000000345413744044755016163 0ustar snosno#!perl use strict ("subs", "vars", "refs"); use warnings ("all"); BEGIN { $ENV{LIST_MOREUTILS_PP} = 0; } END { delete $ENV{LIST_MOREUTILS_PP} } # for VMS use List::MoreUtils (":all"); use lib ("t/lib"); use Test::More; use Test::LMU; my @list = (1, 1, 2, 2, 3, 3, 3, 3, 3, 3, 4, 4, 4, 4, 5, 5, 6, 7, 7, 7, 8, 8, 9, 9, 9, 9, 9, 11, 13, 13, 13, 17); is(0, (upper_bound { $_ <=> 0 } @list), "upper bound 0"); is(2, (upper_bound { $_ <=> 1 } @list), "upper bound 1"); is(4, (upper_bound { $_ <=> 2 } @list), "upper bound 2"); is(14, (upper_bound { $_ <=> 4 } @list), "upper bound 4"); is(scalar @list, (upper_bound { $_ <=> 19 } @list), "upper bound 19"); my @in = @list = 1 .. 100; for my $i (0 .. $#in) { my $j = $in[$i] - 1; is($i, (upper_bound { $_ - $j } @list), "placed $j"); is($i + 1, (upper_bound { $_ - $in[$i] } @list), "found $in[$i]"); } my @lout = ($in[0] - 11 .. $in[0] - 1); for my $elem (@lout) { is(0, (upper_bound { $_ - $elem } @list), "put smaller $elem in front"); } my @uout = ($in[-1] + 1 .. $in[-1] + 11); for my $elem (@uout) { is(scalar @list, (upper_bound { $_ - $elem } @list),, "put bigger $elem at end"); } leak_free_ok( upper_bound => sub { my $elem = int(rand(1000)) + 1; upper_bound { $_ - $elem } @list; } ); leak_free_ok( 'upper_bound with stack-growing' => sub { my $elem = int(rand(1000)); upper_bound { grow_stack(); $_ - $elem } @list; } ); leak_free_ok( 'upper_bound with stack-growing and exception' => sub { my $elem = int(rand(1000)); eval { upper_bound { grow_stack(); $_ - $elem or die "Goal!"; $_ - $elem } @list; }; } ); is_dying('upper_bound without sub' => sub { &upper_bound(42, (1 .. 100)); }); done_testing; List-MoreUtils-0.430/t/xs/reduce_1.t0000644000175000017500000000232513744044755015324 0ustar snosno#!perl use strict ("subs", "vars", "refs"); use warnings ("all"); BEGIN { $ENV{LIST_MOREUTILS_PP} = 0; } END { delete $ENV{LIST_MOREUTILS_PP} } # for VMS use List::MoreUtils (":all"); use lib ("t/lib"); use Test::More; use Test::LMU; use Scalar::Util qw(looks_like_number); # (this code shamelessly stolen from Math::Complex's t/Trig.t, with some mods to near) from BBYRD in RT#72638 and taken from SQL-Statement now use Math::Trig; my $eps = 1e-11; if ($^O eq 'unicos') { # See lib/Math/Complex.pm and t/lib/complex.t. $eps = 1e-10; } sub near ($$$;$) { my $d = $_[1] ? abs($_[0] / $_[1] - 1) : abs($_[0]); local $Test::Builder::Level = $Test::Builder::Level + 1; looks_like_number($_[0]) or return cmp_ok($_[0], "eq", $_[1], "near? $_[0] ~= $_[1]"); $_[0] =~ m/nan/i and return cmp_ok($_[0], "eq", $_[1], "near? $_[0] ~= $_[1]"); $_[0] =~ m/inf/i and return cmp_ok($_[0], "eq", $_[1], "near? $_[0] ~= $_[1]"); my $e = defined $_[3] ? $_[3] : $eps; cmp_ok($d, '<', $e, "$_[2] => near? $_[0] ~= $_[1]") or diag("near? $_[0] ~= $_[1]"); } my $half_pi = reduce_1 { $a * ((4 * $b * $b) / ((2 * $b - 1) * (2 * $b + 1))) } 1 .. 750; near($half_pi, pi / 2, "Wallis product", 1e-2); done_testing; List-MoreUtils-0.430/t/xs/singleton.t0000644000175000017500000000471513744044755015644 0ustar snosno#!perl use strict ("subs", "vars", "refs"); use warnings ("all"); BEGIN { $ENV{LIST_MOREUTILS_PP} = 0; } END { delete $ENV{LIST_MOREUTILS_PP} } # for VMS use List::MoreUtils (":all"); use lib ("t/lib"); use Test::More; use Test::LMU; use Tie::Array (); SCOPE: { my @s = (1001 .. 1200); my @d = map { (1 .. 1000) } 0 .. 1; my @a = (@d, @s); my @u = singleton @a; is_deeply(\@u, [@s]); my $u = singleton @a; is(200, $u); } # Test strings SCOPE: { my @s = ("AA" .. "ZZ"); my @d = map { ("aa" .. "zz") } 0 .. 1; my @a = (@d, @s); my @u = singleton @a; is_deeply(\@u, [@s]); my $u = singleton @a; is(scalar @s, $u); } # Test mixing strings and numbers SCOPE: { my @s = (1001 .. 1200, "AA" .. "ZZ"); my $fs = freeze(\@s); my @d = map { (1 .. 1000, "aa" .. "zz") } 0 .. 1; my @a = (@d, @s); my $fa = freeze(\@a); my @u = singleton map { $_ } @a; my $fu = freeze(\@u); is_deeply(\@u, [@s]); is($fs, freeze(\@s)); is($fa, freeze(\@a)); is($fu, $fs); my $u = singleton @a; is(scalar @s, $u); } SCOPE: { my @a; tie @a, "Tie::StdArray"; my @s = (1001 .. 1200, "AA" .. "ZZ"); my @d = map { (1 .. 1000, "aa" .. "zz") } 0 .. 1; @a = (@d, @s); my @u = singleton map { $_ } @a; is_deeply(\@u, [@s]); @a = (@d, @s); my $u = singleton @a; is(scalar @s, $u); } SCOPE: { my @foo = ('a', 'b', '', undef, 'b', 'c', ''); my @sfoo = ('a', undef, 'c'); is_deeply([singleton @foo], \@sfoo, 'one undef is supported correctly by singleton'); @foo = ('a', 'b', '', undef, 'b', 'c', undef); @sfoo = ('a', '', 'c'); is_deeply([singleton @foo], \@sfoo, 'twice undef is supported correctly by singleton'); is((scalar singleton @foo), scalar @sfoo, 'scalar twice undef is supported correctly by singleton'); } leak_free_ok( singleton => sub { my @s = (1001 .. 1200, "AA" .. "ZZ"); my @d = map { (1 .. 1000, "aa" .. "zz") } 0 .. 1; my @a = (@d, @s); my @u = singleton @a; scalar singleton @a; } ); # This test (and the associated fix) are from Kevin Ryde; see RT#49796 leak_free_ok( 'singleton with exception in overloading stringify', sub { eval { my $obj = DieOnStringify->new; my @u = singleton $obj, $obj; }; eval { my $obj = DieOnStringify->new; my $u = singleton $obj, $obj; }; } ); done_testing; List-MoreUtils-0.430/t/xs/one_u.t0000644000175000017500000000132413744044755014740 0ustar snosno#!perl use strict ("subs", "vars", "refs"); use warnings ("all"); BEGIN { $ENV{LIST_MOREUTILS_PP} = 0; } END { delete $ENV{LIST_MOREUTILS_PP} } # for VMS use List::MoreUtils (":all"); use lib ("t/lib"); use Test::More; use Test::LMU; # Normal cases my @list = (1 .. 300); is_true(one_u { 1 == $_ } @list); is_true(one_u { 150 == $_ } @list); is_true(one_u { 300 == $_ } @list); is_false(one_u { 0 == $_ } @list); is_false(one_u { 1 <= $_ } @list); is_false(one_u { !(127 & $_) } @list); is_undef(one_u {}); leak_free_ok( one_u => sub { my $ok = one_u { 150 <= $_ } @list; my $ok2 = one_u { 150 <= $_ } 1 .. 300; } ); is_dying('one_u without sub' => sub { &one_u(42, 4711); }); done_testing; List-MoreUtils-0.430/t/xs/each_array.t0000644000175000017500000000646613744044755015745 0ustar snosno#!perl use strict ("subs", "vars", "refs"); use warnings ("all"); BEGIN { $ENV{LIST_MOREUTILS_PP} = 0; } END { delete $ENV{LIST_MOREUTILS_PP} } # for VMS use List::MoreUtils (":all"); use lib ("t/lib"); use Test::More; use Test::LMU; SCOPE: { my @a = (7, 3, 'a', undef, 'r'); my @b = qw{ a 2 -1 x }; my $it = each_array @a, @b; my (@r, @idx); while (my ($a, $b) = $it->()) { push @r, $a, $b; push @idx, $it->('index'); } # Do I segfault? I shouldn't. $it->(); is_deeply(\@r, [7, 'a', 3, 2, 'a', -1, undef, 'x', 'r', undef]); is_deeply(\@idx, [0 .. 4]); # Testing two iterators on the same arrays in parallel @a = (1, 3, 5); @b = (2, 4, 6); my $i1 = each_array @a, @b; my $i2 = each_array @a, @b; @r = (); while (my ($a, $b) = $i1->() and my ($c, $d) = $i2->()) { push @r, $a, $b, $c, $d; } is_deeply(\@r, [1, 2, 1, 2, 3, 4, 3, 4, 5, 6, 5, 6]); # Input arrays must not be modified is_deeply(\@a, [1, 3, 5]); is_deeply(\@b, [2, 4, 6]); # This used to give "semi-panic: attempt to dup freed string" # See: my $ea = each_arrayref([1 .. 26], ['A' .. 'Z']); (@a, @b) = (); while (my ($a, $b) = $ea->()) { push @a, $a; push @b, $b; } is_deeply(\@a, [1 .. 26]); is_deeply(\@b, ['A' .. 'Z']); # And this even used to dump core my @nums = 1 .. 26; $ea = each_arrayref(\@nums, ['A' .. 'Z']); (@a, @b) = (); while (my ($a, $b) = $ea->()) { push @a, $a; push @b, $b; } is_deeply(\@a, [1 .. 26]); is_deeply(\@a, \@nums); is_deeply(\@b, ['A' .. 'Z']); } SCOPE: { my @a = (7, 3, 'a', undef, 'r'); my @b = qw/a 2 -1 x/; my $it = each_arrayref \@a, \@b; my (@r, @idx); while (my ($a, $b) = $it->()) { push @r, $a, $b; push @idx, $it->('index'); } # Do I segfault? I shouldn't. $it->(); is_deeply(\@r, [7, 'a', 3, 2, 'a', -1, undef, 'x', 'r', undef]); is_deeply(\@idx, [0 .. 4]); # Testing two iterators on the same arrays in parallel @a = (1, 3, 5); @b = (2, 4, 6); my $i1 = each_array @a, @b; my $i2 = each_array @a, @b; @r = (); while (my ($a, $b) = $i1->() and my ($c, $d) = $i2->()) { push @r, $a, $b, $c, $d; } is_deeply(\@r, [1, 2, 1, 2, 3, 4, 3, 4, 5, 6, 5, 6]); # Input arrays must not be modified is_deeply(\@a, [1, 3, 5]); is_deeply(\@b, [2, 4, 6]); } # Note that the leak_free_ok tests for each_array and each_arrayref # should not be run until either of them has been called at least once # in the current perl. That's because calling them the first time # causes the runtime to allocate some memory used for the OO structures # that their implementation uses internally. leak_free_ok( each_array => sub { my @a = (1); my $it = each_array @a; while (my ($a) = $it->()) { } } ); leak_free_ok( each_arrayref => sub { my @a = (1); my $it = each_arrayref \@a; while (my ($a) = $it->()) { } } ); is_dying('each_array without sub' => sub { &each_array(42, 4711); }); is_dying('each_arrayref without sub' => sub { &each_arrayref(42, 4711); }); done_testing; List-MoreUtils-0.430/t/xs/XS.t0000644000175000017500000000247213744044755014172 0ustar snosno#!perl use strict ("subs", "vars", "refs"); use warnings ("all"); BEGIN { $ENV{LIST_MOREUTILS_PP} = 0; } END { delete $ENV{LIST_MOREUTILS_PP} } # for VMS use List::MoreUtils (":all"); use lib ("t/lib"); use Test::More; $INC{'List/MoreUtils.pm'} or plan skip_all => "Unreasonable unless loaded via List::MoreUtils"; is(List::MoreUtils::_XScompiled(), 0 + defined($INC{'List/MoreUtils/XS.pm'}), "_XScompiled"); done_testing(); 1; =head1 AUTHOR Jens Rehsack Erehsack AT cpan.orgE Adam Kennedy Eadamk@cpan.orgE =head1 COPYRIGHT AND LICENSE Copyright 2013 - 2017 by Jens Rehsack All code added with 0.417 or later is licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in compliance with the License. You may obtain a copy of the License at http://www.apache.org/licenses/LICENSE-2.0 Unless required by applicable law or agreed to in writing, software distributed under the License is distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the License for the specific language governing permissions and limitations under the License. All code until 0.416 is licensed 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 List-MoreUtils-0.430/t/xs/bsearchidx.t0000644000175000017500000000205313744044755015747 0ustar snosno#!perl use strict ("subs", "vars", "refs"); use warnings ("all"); BEGIN { $ENV{LIST_MOREUTILS_PP} = 0; } END { delete $ENV{LIST_MOREUTILS_PP} } # for VMS use List::MoreUtils (":all"); use lib ("t/lib"); use Test::More; use Test::LMU; my @list = my @in = 1 .. 1000; for my $i (0 .. $#in) { is($i, bsearchidx { $_ - $in[$i] } @list); } my @out = (-10 .. 0, 1001 .. 1011); for my $elem (@out) { my $r = bsearchidx { $_ - $elem } @list; is(-1, $r); } leak_free_ok( bsearch => sub { my $elem = int(rand(1000)) + 1; bsearchidx { $_ - $elem } @list; } ); leak_free_ok( 'bsearch with stack-growing' => sub { my $elem = int(rand(1000)); bsearchidx { grow_stack(); $_ - $elem } @list; } ); leak_free_ok( 'bsearch with stack-growing and exception' => sub { my $elem = int(rand(1000)); eval { bsearchidx { grow_stack(); $_ - $elem or die "Goal!"; $_ - $elem } @list; }; } ); is_dying('bsearchidx without sub' => sub { &bsearchidx(42, (1 .. 100)); }); done_testing; List-MoreUtils-0.430/t/xs/minmaxstr.t0000644000175000017500000000220313744044755015652 0ustar snosno#!perl use strict ("subs", "vars", "refs"); use warnings ("all"); BEGIN { $ENV{LIST_MOREUTILS_PP} = 0; } END { delete $ENV{LIST_MOREUTILS_PP} } # for VMS use List::MoreUtils (":all"); use lib ("t/lib"); use Test::More; use Test::LMU; use POSIX qw(setlocale LC_COLLATE); setlocale(LC_COLLATE, "C"); my @list = reverse 'AA' .. 'ZZ'; my ($min, $max) = minmaxstr @list; is($min, 'AA'); is($max, 'ZZ'); # Odd number of elements push @list, 'ZZ Top'; ($min, $max) = minmaxstr @list; is($min, 'AA'); is($max, 'ZZ Top'); # COW causes missing max when optimization for 1 argument is applied @list = grep { defined $_ } map { my ($min, $max) = minmaxstr(sprintf("%s", rand)); ($min, $max) } (0 .. 19); is(scalar @list, 40, "minmaxstr swallows max on COW"); # Test with a single list value my $input = 'foo'; ($min, $max) = minmaxstr $input; is($min, 'foo'); is($max, 'foo'); # Confirm output are independant copies of input $input = 'bar'; is($min, 'foo'); is($max, 'foo'); $min = 'bar'; is($max, 'foo'); leak_free_ok( minmaxstr => sub { @list = reverse 'AA' .. 'ZZ', 'ZZ Top'; ($min, $max) = minmaxstr @list; } ); done_testing; List-MoreUtils-0.430/t/xs/uniq.t0000644000175000017500000000402113744044755014604 0ustar snosno#!perl use strict ("subs", "vars", "refs"); use warnings ("all"); BEGIN { $ENV{LIST_MOREUTILS_PP} = 0; } END { delete $ENV{LIST_MOREUTILS_PP} } # for VMS use List::MoreUtils (":all"); use lib ("t/lib"); BEGIN { $INC{'List/MoreUtils.pm'} or *distinct = __PACKAGE__->can("uniq"); } use Test::More; use Test::LMU; use Tie::Array (); SCOPE: { my @a = map { (1 .. 10) } 0 .. 1; my @u = uniq @a; is_deeply(\@u, [1 .. 10]); my $u = uniq @a; is(10, $u); } # Test aliases SCOPE: { my @a = map { (1 .. 10) } 0 .. 1; my @u = distinct @a; is_deeply(\@u, [1 .. 10]); my $u = distinct @a; is(10, $u); } # Test strings SCOPE: { my @a = map { ("a" .. "z") } 0 .. 1; my @u = uniq @a; is_deeply(\@u, ["a" .. "z"]); my $u = uniq @a; is(26, $u); } # Test mixing strings and numbers SCOPE: { my @a = ((map { (1 .. 10) } 0 .. 1), (map { ("a" .. "z") } 0 .. 1)); my $fa = freeze(\@a); my @u = uniq map { $_ } @a; my $fu = freeze(\@u); is_deeply(\@u, [1 .. 10, "a" .. "z"]); is($fa, freeze(\@a)); is($fu, freeze([1 .. 10, "a" .. "z"])); my $u = uniq @a; is(10 + 26, $u); } SCOPE: { my @a; tie @a, "Tie::StdArray"; @a = ((map { (1 .. 10) } 0 .. 1), (map { ("a" .. "z") } 0 .. 1)); my @u = uniq @a; is_deeply(\@u, [1 .. 10, "a" .. "z"]); @a = ((map { (1 .. 10) } 0 .. 1), (map { ("a" .. "z") } 0 .. 1)); my $u = uniq @a; is(10 + 26, $u); } SCOPE: { my @foo = ('a', 'b', '', undef, 'b', 'c', ''); my @ufoo = ('a', 'b', '', undef, 'c'); is_deeply([uniq @foo], \@ufoo, 'undef is supported correctly'); } leak_free_ok( uniq => sub { my @a = map { (1 .. 1000) } 0 .. 1; my @u = uniq @a; uniq @a[1 .. 100]; } ); # This test (and the associated fix) are from Kevin Ryde; see RT#49796 leak_free_ok( 'uniq with exception in overloading stringify', sub { eval { my $obj = DieOnStringify->new; my @u = uniq "foo", $obj, "bar", $obj; }; } ); done_testing; List-MoreUtils-0.430/t/xs/duplicates.t0000644000175000017500000000722513744044755015776 0ustar snosno#!perl use strict ("subs", "vars", "refs"); use warnings ("all"); BEGIN { $ENV{LIST_MOREUTILS_PP} = 0; } END { delete $ENV{LIST_MOREUTILS_PP} } # for VMS use List::MoreUtils (":all"); use lib ("t/lib"); use Test::More; use Test::LMU; use Tie::Array (); SCOPE: { my @s = (1001 .. 1200); my @d = (1 .. 1000); my @a = (@d, @s, @d); my $fa = freeze(\@a); my @u = duplicates @a; is($fa, freeze(\@a), "duplicates:G_ARRAY leaves numbers untouched"); is_deeply(\@u, [@d], "duplicates of numbers"); my $u = duplicates @a; is($fa, freeze(\@a), "duplicates:G_SCALAR leaves numbers untouched"); is(scalar @d, $u, "scalar result of duplicates of numbers"); } # Test strings SCOPE: { my @s = ("AA" .. "ZZ"); my @d = ("aa" .. "zz"); my @a = (@d, @s, @d); my $fa = freeze(\@a); my @u = duplicates @a; is($fa, freeze(\@a), "duplicates:G_ARRAY leaves numbers untouched"); is_deeply(\@u, [@d], "duplicates of numbers"); my $u = duplicates @a; is($fa, freeze(\@a), "duplicates:G_SCALAR leaves numbers untouched"); is(scalar @d, $u, "scalar result of duplicates of numbers"); } # Test mixing strings and numbers SCOPE: { my @s = (1001 .. 1200, "AA" .. "ZZ"); my @d = (1 .. 1000, "aa" .. "zz"); my $fd = freeze(\@d); my @a = (@d, @s, @d); my $fa = freeze(\@a); my @u = duplicates map { $_ } @a; my $fu = freeze(\@u); is_deeply(\@u, [@d], "duplicates of numbers/strings mixture"); is($fd, freeze(\@d), "frozen duplicates of numbers/strings mixture"); is($fa, freeze(\@a), "duplicates:G_ARRAY leaves mixture untouched"); is($fu, $fd); my $u = duplicates @a; is($fa, freeze(\@a), "duplicates:G_SCALAR leaves mixture untouched"); is(scalar @d, $u, "scalar result of duplicates of numbers/strings mixture"); } SCOPE: { my @a; tie @a, "Tie::StdArray"; my @s = (1001 .. 1200, "AA" .. "ZZ"); my @d = (1 .. 1000, "aa" .. "zz"); @a = (@d, @s, @d); my $fa = freeze(\@a); my @u = duplicates @a; is_deeply(\@u, [@d], "duplicates of tied array of numbers/strings mixture"); is($fa, freeze(\@a), "duplicates:G_ARRAY leaves mixture untouched"); @a = (@u, @d); $fa = freeze(\@a); my $u = duplicates @a; is($fa, freeze(\@a), "duplicates:G_SCALAR leaves mixture untouched"); is(scalar @d, $u, "scalar result of duplicates of tied array of numbers/strings mixture"); } SCOPE: { my @foo = ('a', 'b', '', undef, 'b', 'c', '', undef); my @dfoo = ('b', '', undef); is_deeply([duplicates @foo], \@dfoo, "two undef's are supported correctly by duplicates"); @foo = ('a', undef, 'b', '', 'b', 'c', ''); @dfoo = ('b', ''); is_deeply([duplicates @foo], \@dfoo, 'one undef is ignored correctly by duplicates'); is((scalar duplicates @foo), scalar @dfoo, 'scalar one undef is ignored correctly by duplicates'); } leak_free_ok( duplicates => sub { my @s = (1001 .. 1200, "AA" .. "ZZ"); my @d = map { (1 .. 1000, "aa" .. "zz") } 0 .. 1; my @a = (@d, @s); my @u = duplicates @a; scalar duplicates @a; } ); # This test (and the associated fix) are from Kevin Ryde; see RT#49796 leak_free_ok( 'duplicates with exception in overloading stringify', sub { eval { my $obj = DieOnStringify->new; my @foo = ('a', 'b', '', undef, $obj, 'b', 'c', '', undef, $obj); my @u = duplicates @foo; }; eval { my $obj = DieOnStringify->new; my $u = duplicates 'a', 'b', '', undef, $obj, 'b', 'c', '', undef, $obj; }; } ); done_testing; List-MoreUtils-0.430/t/xs/any.t0000644000175000017500000000154113744044755014423 0ustar snosno#!perl use strict ("subs", "vars", "refs"); use warnings ("all"); BEGIN { $ENV{LIST_MOREUTILS_PP} = 0; } END { delete $ENV{LIST_MOREUTILS_PP} } # for VMS use List::MoreUtils (":all"); use lib ("t/lib"); use Test::More; use Test::LMU; # Normal cases my @list = (1 .. 10000); is_true(any { $_ == 5000 } @list); is_true(any { $_ == 5000 } 1 .. 10000); is_true(any { defined } @list); is_false(any { not defined } @list); is_true(any { not defined } undef); is_false(any {}); leak_free_ok( any => sub { my $ok = any { $_ == 5000 } @list; my $ok2 = any { $_ == 5000 } 1 .. 10000; } ); leak_free_ok( 'any with a coderef that dies' => sub { # This test is from Kevin Ryde; see RT#48669 eval { my $ok = any { die } 1; }; } ); is_dying('any without sub' => sub { &any(42, 4711); }); done_testing; List-MoreUtils-0.430/t/xs/firstidx.t0000644000175000017500000000200413744044755015463 0ustar snosno#!perl use strict ("subs", "vars", "refs"); use warnings ("all"); BEGIN { $ENV{LIST_MOREUTILS_PP} = 0; } END { delete $ENV{LIST_MOREUTILS_PP} } # for VMS use List::MoreUtils (":all"); use lib ("t/lib"); BEGIN { $INC{'List/MoreUtils.pm'} or *first_index = __PACKAGE__->can("firstidx"); } use Test::More; use Test::LMU; my @list = (1 .. 10000); is(4999, (firstidx { $_ >= 5000 } @list), "firstidx"); is(-1, (firstidx { not defined } @list), "invalid firstidx"); is(0, (firstidx { defined } @list), "real firstidx"); is(-1, (firstidx {}), "empty firstidx"); SKIP: { # Test the alias is(4999, first_index { $_ >= 5000 } @list); is(-1, first_index { not defined } @list); is(0, first_index { defined } @list); is(-1, first_index {}); } leak_free_ok( firstidx => sub { my $i = firstidx { $_ >= 5000 } @list; my $i2 = firstidx { $_ >= 5000 } 1 .. 10000; } ); is_dying('firstidx without sub' => sub { &firstidx(42, 4711); }); done_testing; List-MoreUtils-0.430/t/xs/notall_u.t0000644000175000017500000000121513744044755015447 0ustar snosno#!perl use strict ("subs", "vars", "refs"); use warnings ("all"); BEGIN { $ENV{LIST_MOREUTILS_PP} = 0; } END { delete $ENV{LIST_MOREUTILS_PP} } # for VMS use List::MoreUtils (":all"); use lib ("t/lib"); use Test::More; use Test::LMU; # Normal cases my @list = (1 .. 10000); is_true(notall_u { !defined } @list); is_true(notall_u { $_ < 10000 } @list); is_false(notall_u { $_ <= 10000 } @list); is_undef(notall_u {}); leak_free_ok( notall_u => sub { my $ok = notall_u { $_ == 5000 } @list; my $ok2 = notall_u { $_ == 5000 } 1 .. 10000; } ); is_dying('notall_u without sub' => sub { ¬all_u(42, 4711); }); done_testing; List-MoreUtils-0.430/t/xs/bsearch.t0000644000175000017500000000220613744044755015242 0ustar snosno#!perl use strict ("subs", "vars", "refs"); use warnings ("all"); BEGIN { $ENV{LIST_MOREUTILS_PP} = 0; } END { delete $ENV{LIST_MOREUTILS_PP} } # for VMS use List::MoreUtils (":all"); use lib ("t/lib"); use Test::More; use Test::LMU; my @list = my @in = 1 .. 1000; for my $elem (@in) { ok(scalar bsearch { $_ - $elem } @list); } for my $elem (@in) { my ($e) = bsearch { $_ - $elem } @list; ok($e == $elem); } my @out = (-10 .. 0, 1001 .. 1011); for my $elem (@out) { my $r = bsearch { $_ - $elem } @list; ok(!defined $r); } leak_free_ok( bsearch => sub { my $elem = int(rand(1000)) + 1; scalar bsearch { $_ - $elem } @list; } ); leak_free_ok( 'bsearch with stack-growing' => sub { my $elem = int(rand(1000)); scalar bsearch { grow_stack(); $_ - $elem } @list; } ); leak_free_ok( 'bsearch with stack-growing and exception' => sub { my $elem = int(rand(1000)); eval { scalar bsearch { grow_stack(); $_ - $elem or die "Goal!"; $_ - $elem } @list; }; } ); is_dying('bsearch without sub' => sub { &bsearch(42, (1 .. 100)); }); done_testing; List-MoreUtils-0.430/t/xs/false.t0000644000175000017500000000144313744044755014727 0ustar snosno#!perl use strict ("subs", "vars", "refs"); use warnings ("all"); BEGIN { $ENV{LIST_MOREUTILS_PP} = 0; } END { delete $ENV{LIST_MOREUTILS_PP} } # for VMS use List::MoreUtils (":all"); use lib ("t/lib"); use Test::More; use Test::LMU; # The null set should return zero my $null_scalar = false {}; my @null_list = false {}; is($null_scalar, 0, 'false(null) returns undef'); is_deeply(\@null_list, [0], 'false(null) returns undef'); # Normal cases my @list = (1 .. 10000); is(10000, false { not defined } @list); is(0, false { defined } @list); is(1, false { $_ > 1 } @list); leak_free_ok( false => sub { my $n = false { $_ == 5000 } @list; my $n2 = false { $_ == 5000 } 1 .. 10000; } ); is_dying('false without sub' => sub { &false(42, 4711); }); done_testing; List-MoreUtils-0.430/t/xs/onlyres.t0000644000175000017500000000212313744044755015324 0ustar snosno#!perl use strict ("subs", "vars", "refs"); use warnings ("all"); BEGIN { $ENV{LIST_MOREUTILS_PP} = 0; } END { delete $ENV{LIST_MOREUTILS_PP} } # for VMS use List::MoreUtils (":all"); use lib ("t/lib"); BEGIN { $INC{'List/MoreUtils.pm'} or *only_result = __PACKAGE__->can("onlyres"); } use Test::More; use Test::LMU; my @list = (1 .. 300); is("Hallelujah", onlyres { 150 == $_ and "Hallelujah" } @list); is(1, onlyres { 300 == $_ } @list); is(undef, onlyres { 0 == $_ } @list); is(undef, onlyres { 1 <= $_ } @list); is(undef, onlyres { !(127 & $_) } @list); # Test aliases is(1, only_result { 150 == $_ } @list); is("Hallelujah", only_result { 300 == $_ and "Hallelujah" } @list); is(undef, only_result { 0 == $_ } @list); is(undef, only_result { 1 <= $_ } @list); is(undef, only_result { !(127 & $_) } @list); leak_free_ok( onlyres => sub { my $ok = onlyres { 150 <= $_ } @list; my $ok2 = onlyres { 150 <= $_ } 1 .. 300; } ); is_dying('onlyres without sub' => sub { &onlyres(42, 4711); }); done_testing; List-MoreUtils-0.430/t/xs/part.t0000644000175000017500000000452013744044755014602 0ustar snosno#!perl use strict ("subs", "vars", "refs"); use warnings ("all"); BEGIN { $ENV{LIST_MOREUTILS_PP} = 0; } END { delete $ENV{LIST_MOREUTILS_PP} } # for VMS use List::MoreUtils (":all"); use lib ("t/lib"); use Test::More; use Test::LMU; my @list = 1 .. 12; my $i = 0; my @part = part { $i++ % 3 } @list; is_deeply($part[0], [1, 4, 7, 10], " i: part % 3"); is_deeply($part[1], [2, 5, 8, 11], " ii: part % 3"); is_deeply($part[2], [3, 6, 9, 12], "iii: part % 3"); $list[2] = 0; is($part[2][0], 3, 'Values are not aliases'); @list = 1 .. 12; @part = part { 3 } @list; is($part[0], undef, " i: part 3"); is($part[1], undef, " ii: part 3"); is($part[2], undef, "iii: part 3"); is_deeply($part[3], [1 .. 12], " iv: part 3"); eval { @part = part { -1 } @list; }; like($@, qr/^Modification of non-creatable array value attempted, subscript -1/); $i = 0; @part = part { $i++ == 0 ? 0 : -1 } @list; is_deeply($part[0], [1 .. 12], "part with negative indices"); SKIP: { $INC{'List/MoreUtils/XS.pm'} and skip "Only PurePerl will warn here ...", 1; my @warns = (); local $SIG{__WARN__} = sub { push @warns, [@_] }; @part = part { undef } @list; is_deeply($part[0], [1 .. 12], "part with undef"); like(join("\n", @{$warns[0]}), qr/Use of uninitialized value in array element.*line\s+\d+\.$/, "warning of undef"); is_deeply(\@warns, [($warns[0]) x 12], "amount of similar undef warnings"); } @part = part { 10000 } @list; is_deeply($part[10000], [@list], " i: part 10_000"); is($part[0], undef, " ii: part 10_000"); is($part[@part / 2], undef, "iii: part 10_000"); is($part[9999], undef, " iv: part 10_000"); # Changing the list in place used to destroy # its elements due to a wrong refcnt @list = 1 .. 10; @list = part { $_ } @list; foreach (1 .. 10) { is_deeply($list[$_], [$_], "part \$_: $_"); } leak_free_ok( part => sub { my @list = 1 .. 12; my $i = 0; my @part = part { $i++ % 3 } @list; } ); leak_free_ok( 'part with stack-growing' => sub { # This test is from Kevin Ryde; see RT#38699 my @part = part { grow_stack(); 1024 } 'one', 'two'; } ); leak_free_ok( 'part with exception' => sub { my @long_list = int rand(1000) for 0 .. 1E7; my @part = part { $_ == 1E7 and die "Too much!"; ($_ % 10) * 2 } @long_list; } ); done_testing; List-MoreUtils-0.430/t/xs/lastval.t0000644000175000017500000000132513744044755015302 0ustar snosno#!perl use strict ("subs", "vars", "refs"); use warnings ("all"); BEGIN { $ENV{LIST_MOREUTILS_PP} = 0; } END { delete $ENV{LIST_MOREUTILS_PP} } # for VMS use List::MoreUtils (":all"); use lib ("t/lib"); BEGIN { $INC{'List/MoreUtils.pm'} or *last_value = __PACKAGE__->can("lastval"); } use Test::More; use Test::LMU; my $x = lastval { $_ > 5 } 4 .. 9; is($x, 9); $x = lastval { $_ > 5 } 1 .. 4; is($x, undef); is_undef(lastval { $_ > 5 }); # Test aliases $x = last_value { $_ > 5 } 4 .. 9; is($x, 9); $x = last_value { $_ > 5 } 1 .. 4; is($x, undef); leak_free_ok( lastval => sub { $x = lastval { $_ > 5 } 4 .. 9; } ); is_dying('lastval without sub' => sub { &lastval(42, 4711); }); done_testing; List-MoreUtils-0.430/t/xs/lastidx.t0000644000175000017500000000156213744044755015307 0ustar snosno#!perl use strict ("subs", "vars", "refs"); use warnings ("all"); BEGIN { $ENV{LIST_MOREUTILS_PP} = 0; } END { delete $ENV{LIST_MOREUTILS_PP} } # for VMS use List::MoreUtils (":all"); use lib ("t/lib"); BEGIN { $INC{'List/MoreUtils.pm'} or *last_index = __PACKAGE__->can("lastidx"); } use Test::More; use Test::LMU; my @list = (1 .. 10000); is(9999, lastidx { $_ >= 5000 } @list); is(-1, lastidx { not defined } @list); is(9999, lastidx { defined } @list); is(-1, lastidx {}); # Test aliases is(9999, last_index { $_ >= 5000 } @list); is(-1, last_index { not defined } @list); is(9999, last_index { defined } @list); is(-1, last_index {}); leak_free_ok( lastidx => sub { my $i = lastidx { $_ >= 5000 } @list; my $i2 = lastidx { $_ >= 5000 } 1 .. 10000; } ); is_dying('lastidx without sub' => sub { &lastidx(42, 4711); }); done_testing; List-MoreUtils-0.430/t/xs/insert_after.t0000644000175000017500000000253113744044755016321 0ustar snosno#!perl use strict ("subs", "vars", "refs"); use warnings ("all"); BEGIN { $ENV{LIST_MOREUTILS_PP} = 0; } END { delete $ENV{LIST_MOREUTILS_PP} } # for VMS use List::MoreUtils (":all"); use lib ("t/lib"); use Test::More; use Test::LMU; my @list = qw{This is a list}; insert_after { $_ eq "a" } "longer" => @list; is(join(' ', @list), "This is a longer list"); insert_after { 0 } "bla" => @list; is(join(' ', @list), "This is a longer list"); insert_after { $_ eq "list" } "!" => @list; is(join(' ', @list), "This is a longer list !"); @list = (qw{This is}, undef, qw{list}); insert_after { not defined($_) } "longer" => @list; $list[2] = "a"; is(join(' ', @list), "This is a longer list"); leak_free_ok( insert_after => sub { @list = qw{This is a list}; insert_after { $_ eq 'a' } "longer" => @list; } ); leak_free_ok( 'insert_after with exception' => sub { eval { my @list = (qw{This is}, DieOnStringify->new, qw{a list}); insert_after { $_ eq 'a' } "longer" => @list; }; } ); is_dying('insert_after without sub' => sub { &insert_after(42, 4711, [qw(die bart die)]); }); is_dying('insert_after without sub and array' => sub { &insert_after(42, 4711, "13"); }); is_dying( 'insert_after without array' => sub { &insert_after(sub { }, 4711, "13"); } ); done_testing; List-MoreUtils-0.430/t/xs/all.t0000644000175000017500000000113013744044755014376 0ustar snosno#!perl use strict ("subs", "vars", "refs"); use warnings ("all"); BEGIN { $ENV{LIST_MOREUTILS_PP} = 0; } END { delete $ENV{LIST_MOREUTILS_PP} } # for VMS use List::MoreUtils (":all"); use lib ("t/lib"); use Test::More; use Test::LMU; # Normal cases my @list = (1 .. 10000); is_true(all { defined } @list); is_true(all { $_ > 0 } @list); is_false(all { $_ < 5000 } @list); is_true(all {}); leak_free_ok( all => sub { my $ok = all { $_ == 5000 } @list; my $ok2 = all { $_ == 5000 } 1 .. 10000; } ); is_dying('all without sub' => sub { &all(42, 4711); }); done_testing; List-MoreUtils-0.430/t/xs/pairwise.t0000644000175000017500000000654513744044755015470 0ustar snosno#!perl use strict ("subs", "vars", "refs"); use warnings ("all"); BEGIN { $ENV{LIST_MOREUTILS_PP} = 0; } END { delete $ENV{LIST_MOREUTILS_PP} } # for VMS use List::MoreUtils (":all"); use lib ("t/lib"); use Test::More; use Test::LMU; my @a = (1, 2, 3, 4, 5); my @b = (2, 4, 6, 8, 10); my @c = pairwise { $a + $b } @a, @b; is_deeply(\@c, [3, 6, 9, 12, 15], "pw1"); @c = pairwise { $a * $b } @a, @b; # returns (2, 8, 18) is_deeply(\@c, [2, 8, 18, 32, 50], "pw2"); # Did we modify the input arrays? is_deeply(\@a, [1, 2, 3, 4, 5], "pw3"); is_deeply(\@b, [2, 4, 6, 8, 10], "pw4"); # $a and $b should be aliases: test @b = @a = (1, 2, 3); @c = pairwise { $a++; $b *= 2 } @a, @b; is_deeply(\@a, [2, 3, 4], "pw5"); is_deeply(\@b, [2, 4, 6], "pw6"); is_deeply(\@c, [2, 4, 6], "pw7"); # sub returns more than two items @a = (1, 1, 2, 3, 5); @b = (2, 3, 5, 7, 11, 13); @c = pairwise { ($a) x $b } @a, @b; is_deeply(\@c, [(1) x 2, (1) x 3, (2) x 5, (3) x 7, (5) x 11, (undef) x 13], "pw8"); is_deeply(\@a, [1, 1, 2, 3, 5], "pw9"); is_deeply(\@b, [2, 3, 5, 7, 11, 13], "pwX"); (@a, @b) = (); push @a, int rand(1000) for 0 .. rand(1000); push @b, int rand(1000) for 0 .. rand(1000); SCOPE: { local $SIG{__WARN__} = sub { }; # XXX my @res1 = pairwise { $a + $b } @a, @b; # Test this one more thoroughly: the XS code looks flakey # correctness of pairwise_perl proved by human auditing. :-) my $limit = $#a > $#b ? $#a : $#b; my @res2 = map { $a[$_] + $b[$_] } 0 .. $limit; is_deeply(\@res1, \@res2); } @a = qw/a b c/; @b = qw/1 2 3/; @c = pairwise { ($a, $b) } @a, @b; is_deeply(\@c, [qw/a 1 b 2 c 3/], "pw map"); SKIP: { $ENV{PERL5OPT} and skip 'A defined PERL5OPT may inject extra deps crashing this test', 1; # Test that a die inside the code-reference will not be trapped eval { pairwise { die "I died\n" } @a, @b; }; is($@, "I died\n"); } leak_free_ok( pairwise => sub { @a = (1); @b = (2); @c = pairwise { $a + $b } @a, @b; } ); leak_free_ok( 'exceptional block' => sub { @a = qw/a b c/; @b = qw/1 2 3/; eval { @c = pairwise { $b == 3 and die "Primes suck!"; "$a:$b" } @a, @b; }; } ); SKIP: { $INC{'List/MoreUtils/XS.pm'} or skip "PurePerl will warn here ...", 1; my ($a, $b, @t); eval { my @l1 = (1 .. 10); @t = pairwise { $a + $b } @l1, @l1; }; my $err = $@; like($err, qr/Can't use lexical \$a or \$b in pairwise code block/, "pairwise die's on broken caller"); } SKIP: { $INC{'List/MoreUtils/XS.pm'} and skip "XS will die on purpose here ...", 1; my @warns = (); local $SIG{__WARN__} = sub { push @warns, @_ }; my ($a, $b, @t); my @l1 = (1 .. 10); @t = pairwise { $a + $b } @l1, @l1; like(join("", @warns[0, 1]), qr/Use of uninitialized value.*? in addition/, "warning on broken caller"); } is_dying('pairwise without sub' => sub { &pairwise(42, \@a, \@b); }); SKIP: { $INC{'List/MoreUtils/XS.pm'} or skip "PurePerl will not core here ...", 2; is_dying( 'pairwise without first ARRAY' => sub { @c = &pairwise(sub { }, 1, \@b); } ); is_dying( 'pairwise without second ARRAY' => sub { @c = &pairwise(sub { }, \@a, 2); } ); } done_testing; List-MoreUtils-0.430/t/xs/any_u.t0000644000175000017500000000157313744044755014754 0ustar snosno#!perl use strict ("subs", "vars", "refs"); use warnings ("all"); BEGIN { $ENV{LIST_MOREUTILS_PP} = 0; } END { delete $ENV{LIST_MOREUTILS_PP} } # for VMS use List::MoreUtils (":all"); use lib ("t/lib"); use Test::More; use Test::LMU; # Normal cases my @list = (1 .. 10000); is_true(any_u { $_ == 5000 } @list); is_true(any_u { $_ == 5000 } 1 .. 10000); is_true(any_u { defined } @list); is_false(any_u { not defined } @list); is_true(any_u { not defined } undef); is_undef(any_u {}); leak_free_ok( any_u => sub { my $ok = any_u { $_ == 5000 } @list; my $ok2 = any_u { $_ == 5000 } 1 .. 10000; } ); leak_free_ok( 'any_u with a coderef that dies' => sub { # This test is from Kevin Ryde; see RT#48669 eval { my $ok = any_u { die } 1; }; } ); is_dying('any_u without sub' => sub { &any_u(42, 4711); }); done_testing; List-MoreUtils-0.430/t/xs/frequency.t0000644000175000017500000000763013744044755015642 0ustar snosno#!perl use strict ("subs", "vars", "refs"); use warnings ("all"); BEGIN { $ENV{LIST_MOREUTILS_PP} = 0; } END { delete $ENV{LIST_MOREUTILS_PP} } # for VMS use List::MoreUtils (":all"); use lib ("t/lib"); use Test::More; use Test::LMU; use Tie::Array (); SCOPE: { my @s = (1001 .. 1200); my @d = (1 .. 1000); my @a = (@d, @s, @d); my %e = ((map { $_ => 2 } @d), map { $_ => 1 } @s); my $fa = freeze(\@a); my %f = frequency @a; is($fa, freeze(\@a), "frequency:G_ARRAY leaves numbers untouched"); is_deeply(\%f, {%e}, "frequency of numbers"); my $f = frequency @a; is($fa, freeze(\@a), "frequency:G:SCALAR leaves numbers untouched"); is(scalar keys %e, $f, "scalar result of frequency of numbers"); } # Test strings SCOPE: { my @s = ("AA" .. "ZZ"); my @d = ("aa" .. "zz"); my @a = (@d, @s, @d); my $fa = freeze(\@a); my %e = ((map { $_ => 2 } @d), map { $_ => 1 } @s); my %f = frequency @a; is($fa, freeze(\@a), "frequency:G_ARRAY leaves strings untouched"); is_deeply(\%f, {%e}, "frequency of strings"); my $f = frequency @a; is($fa, freeze(\@a), "frequency:G_SCALAR leaves strings untouched"); is(scalar keys %e, $f, "scalar result of frequency of strings"); } # Test mixing strings and numbers SCOPE: { my @s = (1001 .. 1200, "AA" .. "ZZ"); my @d = (1 .. 1000, "aa" .. "zz"); my @a = (@d, @s, @d); my %e = ((map { $_ => 2 } @d), map { $_ => 1 } @s); my $fa = freeze(\@a); my %f = frequency @a; is($fa, freeze(\@a), "frequency:G_ARRAY leaves number/strings mixture untouched"); is_deeply(\%f, {%e}, "frequency of number/strings mixture"); my $f = frequency @a; is($fa, freeze(\@a), "frequency:G_SCALAR leaves number/strings mixture untouched"); is(scalar keys %e, $f, "scalar result of frequency of number/strings mixture"); } SCOPE: { my @a; tie @a, "Tie::StdArray"; my @s = (1001 .. 1200, "AA" .. "ZZ"); my @d = (1 .. 1000, "aa" .. "zz"); @a = (@d, @s, @d); my $fa = freeze(\@a); my %e = ((map { $_ => 2 } @d), map { $_ => 1 } @s); my %f = frequency @a; is($fa, freeze(\@a), "frequency:G_ARRAY leaves tied array of number/strings mixture untouched"); is_deeply(\%f, {%e}, "frequency of tied array of number/strings mixture"); my $f = frequency @a; is($fa, freeze(\@a), "frequency:G_SCALAR leaves tied array of number/strings mixture untouched"); is(scalar keys %e, $f, "scalar result of frequency of tied array of number/strings mixture"); } SCOPE: { my @foo = ('a', 'b', '', undef, 'b', 'c', '', undef); my %e = ( a => 1, b => 2, '' => 2, c => 1 ); my @f = frequency @foo; my $seen_undef; ref $f[-2] and ref $f[-2] eq "SCALAR" and not defined ${$f[-2]} and (undef, $seen_undef) = splice @f, -2, 2, (); my %f = @f; is_deeply(\%f, \%e, "stuff around undef's is supported correctly by frequency"); is($seen_undef, 2, "two undef's are supported correctly by frequency"); } leak_free_ok( frequency => sub { my @s = (1001 .. 1200, "AA" .. "ZZ"); my @d = map { (1 .. 1000, "aa" .. "zz") } 0 .. 1; my @a = (@d, @s); my %f = frequency @a; }, 'scalar frequency' => sub { my @s = (1001 .. 1200, "AA" .. "ZZ"); my @d = map { (1 .. 1000, "aa" .. "zz") } 0 .. 1; my @a = (@d, @s); my $f = frequency @a; } ); leak_free_ok( 'frequency with exception in overloading stringify', sub { eval { my $obj = DieOnStringify->new; my @foo = ('a', 'b', '', undef, $obj, 'b', 'c', '', undef, $obj); my %f = frequency @foo; }; eval { my $obj = DieOnStringify->new; my $f = frequency 'a', 'b', '', undef, $obj, 'b', 'c', '', undef, $obj; }; } ); done_testing; List-MoreUtils-0.430/t/xs/listcmp.t0000644000175000017500000000664613744044755015322 0ustar snosno#!perl use strict ("subs", "vars", "refs"); use warnings ("all"); BEGIN { $ENV{LIST_MOREUTILS_PP} = 0; } END { delete $ENV{LIST_MOREUTILS_PP} } # for VMS use List::MoreUtils (":all"); use lib ("t/lib"); use Test::More; use Test::LMU; use Tie::Array (); SCOPE: { my @a = qw(one two three four five six seven eight nine ten eleven twelve thirteen); my @b = qw(two three five seven eleven thirteen seventeen); my @c = qw(one one two three five eight thirteen twentyone); my %expected = ( one => [0, 2], two => [0, 1, 2], three => [0, 1, 2], four => [0], five => [0, 1, 2], six => [0], seven => [0, 1], eight => [0, 2], nine => [0], ten => [0], eleven => [0, 1], twelve => [0], thirteen => [0, 1, 2], seventeen => [1], twentyone => [2], ); my %cmped = listcmp @a, @b, @c; is_deeply(\%cmped, \%expected, "Sequence vs. Prime vs. Fibonacci sorted out correctly"); } SCOPE: { my @a = ("one", "two", "three", "four", "five", "six", "seven", "eight", "nine", "ten", "eleven", "twelve", "thirteen"); my @b = (undef, "two", "three", undef, "five", undef, "seven", undef, undef, undef, "eleven", undef, "thirteen"); my %expected = ( one => [0], two => [0, 1], three => [0, 1], four => [0], five => [0, 1], six => [0], seven => [0, 1], eight => [0], nine => [0], ten => [0], eleven => [0, 1], twelve => [0], thirteen => [0, 1], ); my %cmped = listcmp @a, @b; is_deeply(\%cmped, \%expected, "Sequence vs. Prime filled with undef sorted out correctly"); } leak_free_ok( listcmp => sub { my @a = ("one", "two", "three", "four", "five", "six", "seven", "eight", "nine", "ten", "eleven", "twelve", "thirteen"); my @b = (undef, "two", "three", undef, "five", undef, "seven", undef, undef, undef, "eleven", undef, "thirteen"); my %expected = ( one => [0], two => [0, 1], three => [0, 1], four => [0], five => [0, 1], six => [0], seven => [0, 1], eight => [0], nine => [0], ten => [0], eleven => [0, 1], twelve => [0], thirteen => [0, 1], ); my %cmped = listcmp @a, @b; } ); # This test (and the associated fix) are from Kevin Ryde; see RT#49796 leak_free_ok( 'listcmp with exception in overloading stringify at begin' => sub { eval { my @a = ("one", "two", "three"); my @b = (DieOnStringify->new, "two", "three"); my %expected = ( one => [0], two => [0, 1], three => [0, 1], ); my %cmped = listcmp @a, @b; }; }, 'listcmp with exception in overloading stringify at end' => sub { eval { my @a = ("one", "two", "three"); my @b = ("two", "three", DieOnStringify->new); my %expected = ( one => [0], two => [0, 1], three => [0, 1], ); my %cmped = listcmp @a, @b; }; } ); done_testing; List-MoreUtils-0.430/t/xs/binsert.t0000644000175000017500000000716313744044755015310 0ustar snosno#!perl use strict ("subs", "vars", "refs"); use warnings ("all"); BEGIN { $ENV{LIST_MOREUTILS_PP} = 0; } END { delete $ENV{LIST_MOREUTILS_PP} } # for VMS use List::MoreUtils (":all"); use lib ("t/lib"); use Test::More; use Test::LMU; SCOPE: { my @list = (); is(0, (binsert { $_ cmp "Hello" } "Hello", @list), "Inserting into empty list"); is(1, (binsert { $_ cmp "world" } "world", @list), "Inserting into one-item list"); } my @even = map { $_ * 2 } 1 .. 100; my @odd = map { $_ * 2 - 1 } 1 .. 100; my (@expected, @in); @in = @even; @expected = mesh @odd, @even; foreach my $v (@odd) { binsert { $_ <=> $v } $v, @in; } is_deeply(\@in, \@expected, "binsert odd elements into even list succeeded"); @in = @even; @expected = mesh @odd, @even; foreach my $v (reverse @odd) { binsert { $_ <=> $v } $v, @in; } is_deeply(\@in, \@expected, "binsert odd elements reversely into even list succeeded"); @in = @odd; foreach my $v (@even) { binsert { $_ <=> $v } $v, @in; } is_deeply(\@in, \@expected, "binsert even elements into odd list succeeded"); @in = @odd; foreach my $v (reverse @even) { binsert { $_ <=> $v } $v, @in; } is_deeply(\@in, \@expected, "binsert even elements reversely into odd list succeeded"); @in = @even; @expected = map { $_, $_ } @in; foreach my $v (@even) { binsert { $_ <=> $v } $v, @in; } is_deeply(\@in, \@expected, "binsert existing even elements into even list succeeded"); @in = @even; @expected = map { $_, $_ } @in; foreach my $v (reverse @even) { binsert { $_ <=> $v } $v, @in; } is_deeply(\@in, \@expected, "binsert existing even elements reversely into even list succeeded"); leak_free_ok( 'binsert random' => sub { my @list = map { $_ * 2 } 1 .. 100; my $elem = int(rand(100)) + 1; binsert { $_ <=> $elem } $elem, @list; }, 'binsert existing random' => sub { my @list = map { $_ * 2 } 1 .. 100; my $elem = 2 * (int(rand(100)) + 1); binsert { $_ <=> $elem } $elem, @list; }, 'binsert odd into even' => sub { my @list = @even; foreach my $elem (@odd) { binsert { $_ <=> $elem } $elem, @list; } }, 'binsert even into odd' => sub { my @list = @odd; foreach my $elem (@even) { binsert { $_ <=> $elem } $elem, @list; } }, 'binsert odd into odd' => sub { my @list = @odd; foreach my $elem (@odd) { binsert { $_ <=> $elem } $elem, @list; } }, 'binsert even into even' => sub { my @list = @even; foreach my $elem (@even) { binsert { $_ <=> $elem } $elem, @list; } }, ); leak_free_ok( 'binsert random with stack-growing' => sub { my @list = map { $_ * 2 } 1 .. 100; my $elem = int(rand(100)) + 1; binsert { grow_stack(); $_ <=> $elem } $elem, @list; }, 'binsert odd with stack-growing' => sub { my @list = @even; foreach my $elem (@odd) { binsert { grow_stack(); $_ <=> $elem } $elem, @list; } }, 'binsert even with stack-growing' => sub { my @list = @odd; foreach my $elem (@even) { binsert { grow_stack(); $_ <=> $elem } $elem, @list; } }, ); leak_free_ok( 'binsert with stack-growing and exception' => sub { my @list = map { $_ * 2 } 1 .. 100; my $elem = int(rand(100)) + 1; eval { binsert { grow_stack(); $_ <=> $elem or die "Goal!"; $_ <=> $elem } $elem, @list; }; } ); is_dying('binsert without sub' => sub { &binsert(42, @even); }); done_testing; List-MoreUtils-0.430/t/xs/insert_after_string.t0000644000175000017500000000214713744044755017712 0ustar snosno#!perl use strict ("subs", "vars", "refs"); use warnings ("all"); BEGIN { $ENV{LIST_MOREUTILS_PP} = 0; } END { delete $ENV{LIST_MOREUTILS_PP} } # for VMS use List::MoreUtils (":all"); use lib ("t/lib"); use Test::More; use Test::LMU; my @list = qw{This is a list}; insert_after_string "a", "longer" => @list; is(join(' ', @list), "This is a longer list"); @list = (undef, qw{This is a list}); insert_after_string "a", "longer", @list; shift @list; is(join(' ', @list), "This is a longer list"); @list = ("This\0", "is\0", "a\0", "list\0"); insert_after_string "a\0", "longer\0", @list; is(join(' ', @list), "This\0 is\0 a\0 longer\0 list\0"); leak_free_ok( insert_after_string => sub { @list = qw{This is a list}; insert_after_string "a", "longer", @list; } ); leak_free_ok( 'insert_after_string with exception' => sub { eval { my @list = (qw{This is}, DieOnStringify->new, qw{a list}); insert_after_string "a", "longer", @list; }; } ); is_dying('insert_after_string without array' => sub { &insert_after_string(42, 4711, "13"); }); done_testing; List-MoreUtils-0.430/t/xs/slideatatime.t0000644000175000017500000000301113744044755016273 0ustar snosno#!perl use strict ("subs", "vars", "refs"); use warnings ("all"); BEGIN { $ENV{LIST_MOREUTILS_PP} = 0; } END { delete $ENV{LIST_MOREUTILS_PP} } # for VMS use List::MoreUtils (":all"); use lib ("t/lib"); use Test::More; use Test::LMU; local $" = " "; my $it; my @r; my @x = ('a' .. 'g'); $it = slideatatime 3, 3, @x; while (my @vals = $it->()) { push @r, "@vals"; } is(is_deeply(\@r, ['a b c', 'd e f', 'g']), 1, "slideatatime as natatime with 3 elements"); $it = slideatatime 2, 3, @x; @r = (); while (my @vals = $it->()) { push @r, "@vals"; } is(is_deeply(\@r, ['a b c', 'c d e', 'e f g', 'g']), 1, "slideatatime moving 3 elements by 2 items"); $it = slideatatime 1, 3, @x; @r = (); while (my @vals = $it->()) { push @r, "@vals"; } is(is_deeply(\@r, ['a b c', 'b c d', 'c d e', 'd e f', 'e f g', 'f g', 'g']), 1, "slideatatime moving 3 elements by 1 item"); my @a = (1 .. 1000); $it = slideatatime 1, 1, @a; @r = (); while (my @vals = &$it) { push @r, @vals; } is(is_deeply(\@r, \@a), 1, "slideatatime as natatime with 1 element"); leak_free_ok( slideatatime => sub { my @y = 1; my $it = slideatatime 2, 2, @y; while (my @vals = $it->()) { # do nothing } }, 'slideatatime with exception' => sub { my @r; eval { my $it = slideatatime 1, 3, @x; while (my @vals = $it->()) { scalar @vals == 3 or die; push @r, "@vals"; } }; } ); done_testing; List-MoreUtils-0.430/t/xs/Import.t0000644000175000017500000000441513744044755015111 0ustar snosno#!perl use strict ("subs", "vars", "refs"); use warnings ("all"); BEGIN { $ENV{LIST_MOREUTILS_PP} = 0; } END { delete $ENV{LIST_MOREUTILS_PP} } # for VMS use List::MoreUtils (":all"); use lib ("t/lib"); use Test::More; use Test::LMU; my @pure_funcs = qw(any all none notall one any_u all_u none_u notall_u one_u true false insert_after insert_after_string apply indexes after after_incl before before_incl firstidx lastidx onlyidx firstval lastval onlyval firstres lastres onlyres singleton each_array each_arrayref pairwise natatime mesh uniq minmax part bsearch bsearchidx); my @v0_33 = qw(sort_by nsort_by); my %alias_list = ( v0_22 => { first_index => "firstidx", last_index => "lastidx", first_value => "firstval", last_value => "lastval", zip => "mesh", }, v0_33 => { distinct => "uniq", }, v0_400 => { first_result => "firstres", only_index => "onlyidx", only_value => "onlyval", only_result => "onlyres", last_result => "lastres", bsearch_index => "bsearchidx", }, ); can_ok(__PACKAGE__, $_) for @pure_funcs; SKIP: { $INC{'List/MoreUtils.pm'} or skip "List::MoreUtils::XS doesn't alias", 1; can_ok(__PACKAGE__, $_) for @v0_33; can_ok(__PACKAGE__, $_) for map { keys %$_ } values %alias_list; } done_testing; 1; =head1 AUTHOR Jens Rehsack Erehsack AT cpan.orgE Adam Kennedy Eadamk@cpan.orgE =head1 COPYRIGHT AND LICENSE Copyright 2013 - 2017 by Jens Rehsack All code added with 0.417 or later is licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in compliance with the License. You may obtain a copy of the License at http://www.apache.org/licenses/LICENSE-2.0 Unless required by applicable law or agreed to in writing, software distributed under the License is distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the License for the specific language governing permissions and limitations under the License. All code until 0.416 is licensed 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 List-MoreUtils-0.430/t/xs/natatime.t0000644000175000017500000000142713744044755015441 0ustar snosno#!perl use strict ("subs", "vars", "refs"); use warnings ("all"); BEGIN { $ENV{LIST_MOREUTILS_PP} = 0; } END { delete $ENV{LIST_MOREUTILS_PP} } # for VMS use List::MoreUtils (":all"); use lib ("t/lib"); use Test::More; use Test::LMU; my @x = ('a' .. 'g'); my $it = natatime 3, @x; my @r; local $" = " "; while (my @vals = $it->()) { push @r, "@vals"; } is(is_deeply(\@r, ['a b c', 'd e f', 'g']), 1, "natatime with 3 elements"); my @a = (1 .. 1000); $it = natatime 1, @a; @r = (); while (my @vals = &$it) { push @r, @vals; } is(is_deeply(\@r, \@a), 1, "natatime with 1 element"); leak_free_ok( natatime => sub { my @y = 1; my $it = natatime 2, @y; while (my @vals = $it->()) { # do nothing } } ); done_testing; List-MoreUtils-0.430/t/xs/after.t0000644000175000017500000000135613744044755014741 0ustar snosno#!perl use strict ("subs", "vars", "refs"); use warnings ("all"); BEGIN { $ENV{LIST_MOREUTILS_PP} = 0; } END { delete $ENV{LIST_MOREUTILS_PP} } # for VMS use List::MoreUtils (":all"); use lib ("t/lib"); use Test::More; use Test::LMU; my @x = after { $_ % 5 == 0 } 1 .. 9; is_deeply(\@x, [6, 7, 8, 9], "after 5"); @x = after { /foo/ } qw{bar baz}; is_deeply(\@x, [], 'Got the null list'); @x = after { /b/ } qw{bar baz foo }; is_deeply(\@x, [qw{baz foo }], "after /b/"); leak_free_ok( after => sub { @x = after { /z/ } qw{bar baz foo}; } ); is_dying('after without sub' => sub { &after(42, 4711); }); @x = (1, after { /foo/ } qw(abc def)); is_deeply(\@x, [1], "check XS implementation doesn't mess up stack"); done_testing; List-MoreUtils-0.430/t/xs/after_incl.t0000644000175000017500000000127413744044755015745 0ustar snosno#!perl use strict ("subs", "vars", "refs"); use warnings ("all"); BEGIN { $ENV{LIST_MOREUTILS_PP} = 0; } END { delete $ENV{LIST_MOREUTILS_PP} } # for VMS use List::MoreUtils (":all"); use lib ("t/lib"); use Test::More; use Test::LMU; my @x = after_incl { $_ % 5 == 0 } 1 .. 9; is_deeply(\@x, [5, 6, 7, 8, 9], "after 5, included"); @x = after_incl { /foo/ } qw{bar baz}; is_deeply(\@x, [], 'Got the null list'); @x = after_incl { /b/ } qw{bar baz foo}; is_deeply(\@x, [qw{bar baz foo}], "after /b/, included"); leak_free_ok( after_incl => sub { @x = after_incl { /z/ } qw{bar baz foo}; } ); is_dying('after_incl without sub' => sub { &after_incl(42, 4711); }); done_testing; List-MoreUtils-0.430/t/xs/firstval.t0000644000175000017500000000134013744044755015463 0ustar snosno#!perl use strict ("subs", "vars", "refs"); use warnings ("all"); BEGIN { $ENV{LIST_MOREUTILS_PP} = 0; } END { delete $ENV{LIST_MOREUTILS_PP} } # for VMS use List::MoreUtils (":all"); use lib ("t/lib"); BEGIN { $INC{'List/MoreUtils.pm'} or *first_value = __PACKAGE__->can("firstval"); } use Test::More; use Test::LMU; my $x = firstval { $_ > 5 } 4 .. 9; is($x, 6); $x = firstval { $_ > 5 } 1 .. 4; is($x, undef); is_undef(firstval { $_ > 5 }); # Test aliases $x = first_value { $_ > 5 } 4 .. 9; is($x, 6); $x = first_value { $_ > 5 } 1 .. 4; is($x, undef); leak_free_ok( firstval => sub { $x = firstval { $_ > 5 } 4 .. 9; } ); is_dying('firstval without sub' => sub { &firstval(42, 4711); }); done_testing; List-MoreUtils-0.430/t/xs/before.t0000644000175000017500000000120713744044755015075 0ustar snosno#!perl use strict ("subs", "vars", "refs"); use warnings ("all"); BEGIN { $ENV{LIST_MOREUTILS_PP} = 0; } END { delete $ENV{LIST_MOREUTILS_PP} } # for VMS use List::MoreUtils (":all"); use lib ("t/lib"); use Test::More; use Test::LMU; my @x = before { $_ % 5 == 0 } 1 .. 9; is_deeply(\@x, [1, 2, 3, 4], "before 5"); @x = before { /b/ } qw{bar baz}; is_deeply(\@x, [], 'Got the null list'); @x = before { /f/ } qw{bar baz foo}; is_deeply(\@x, [qw{bar baz}], "before /f/"); leak_free_ok( before => sub { @x = before { /f/ } qw{ bar baz foo }; } ); is_dying('before without sub' => sub { &before(42, 4711); }); done_testing; List-MoreUtils-0.430/t/xs/none.t0000644000175000017500000000114713744044755014575 0ustar snosno#!perl use strict ("subs", "vars", "refs"); use warnings ("all"); BEGIN { $ENV{LIST_MOREUTILS_PP} = 0; } END { delete $ENV{LIST_MOREUTILS_PP} } # for VMS use List::MoreUtils (":all"); use lib ("t/lib"); use Test::More; use Test::LMU; # Normal cases my @list = (1 .. 10000); is_true(none { not defined } @list); is_true(none { $_ > 10000 } @list); is_false(none { defined } @list); is_true(none {}); leak_free_ok( none => sub { my $ok = none { $_ == 5000 } @list; my $ok2 = none { $_ == 5000 } 1 .. 10000; } ); is_dying('none without sub' => sub { &none(42, 4711); }); done_testing; List-MoreUtils-0.430/t/xs/bremove.t0000644000175000017500000000617013744044755015276 0ustar snosno#!perl use strict ("subs", "vars", "refs"); use warnings ("all"); BEGIN { $ENV{LIST_MOREUTILS_PP} = 0; } END { delete $ENV{LIST_MOREUTILS_PP} } # for VMS use List::MoreUtils (":all"); use lib ("t/lib"); use Test::More; use Test::LMU; my @even = map { $_ * 2 } 1 .. 100; my @odd = map { $_ * 2 - 1 } 1 .. 100; my (@expected, @in); @expected = @even; @in = mesh @odd, @even; foreach my $v (@odd) { is($v, (bremove { $_ <=> $v } @in), "$v in order removed"); } is_deeply(\@in, \@expected, "bremove all odd elements succeeded"); @in = mesh @odd, @even; foreach my $v (reverse @odd) { is($v, (bremove { $_ <=> $v } @in), "$v reverse ordered removed"); } is_deeply(\@in, \@expected, "bremove all odd elements reversely succeeded"); @expected = @odd; @in = mesh @odd, @even; foreach my $v (@even) { is($v, (bremove { $_ <=> $v } @in), "$v in order removed"); } is_deeply(\@in, \@expected, "bremove all even elements succeeded"); @in = mesh @odd, @even; foreach my $v (reverse @even) { is($v, (bremove { $_ <=> $v } @in), "$v reverse ordered removed"); } is_deeply(\@in, \@expected, "bremove all even elements reversely succeeded"); # test from shawnlaffan from GH issue #2 of List-MoreUtils-XS SCOPE: { my @list = ('somestring'); my $target = $list[0]; is($target, (bremove { $_ cmp $target } @list), 'removed from single item list'); } leak_free_ok( 'bremove first' => sub { my @list = (1 .. 100); my $v = $list[0]; bremove { $_ <=> $v } @list; }, 'bremove last' => sub { my @list = (1 .. 100); my $v = $list[-1]; bremove { $_ <=> $v } @list; }, 'bremove middle' => sub { my @list = (1 .. 100); my $v = $list[int($#list / 2)]; bremove { $_ <=> $v } @list; }, ); leak_free_ok( 'bremove first with stack-growing' => sub { my @list = mesh @odd, @even; my $v = $list[0]; bremove { grow_stack(); $_ <=> $v } @list; }, 'bremove last with stack-growing' => sub { my @list = mesh @odd, @even; my $v = $list[-1]; bremove { grow_stack(); $_ <=> $v } @list; }, 'bremove middle with stack-growing' => sub { my @list = mesh @odd, @even; my $v = $list[int($#list / 2)]; bremove { grow_stack(); $_ <=> $v } @list; }, ); leak_free_ok( 'bremove first with stack-growing and exception' => sub { my @list = mesh @odd, @even; my $v = $list[0]; eval { bremove { grow_stack(); $_ <=> $v or die "Goal!"; $_ <=> $v } @list; }; }, 'bremove last with stack-growing and exception' => sub { my @list = mesh @odd, @even; my $v = $list[-1]; eval { bremove { grow_stack(); $_ <=> $v or die "Goal!"; $_ <=> $v } @list; }; }, 'bremove middle with stack-growing and exception' => sub { my @list = mesh @odd, @even; my $v = $list[int($#list / 2)]; eval { bremove { grow_stack(); $_ <=> $v or die "Goal!"; $_ <=> $v } @list; }; }, ); is_dying('bremove without sub' => sub { &bremove(42, @even); }); done_testing; List-MoreUtils-0.430/t/xs/qsort.t0000644000175000017500000000116013744044755015001 0ustar snosno#!perl use strict ("subs", "vars", "refs"); use warnings ("all"); BEGIN { $ENV{LIST_MOREUTILS_PP} = 0; } END { delete $ENV{LIST_MOREUTILS_PP} } # for VMS use List::MoreUtils (":all"); use lib ("t/lib"); use Test::More; use Test::LMU; plan skip_all => "It's insane to use a pure-perl qsort" unless $INC{'List/MoreUtils/XS.pm'}; my @ltn_asc = qw(2 3 5 7 11 13 17 19 23 29 31 37); my @ltn_des = reverse @ltn_asc; my @l; @l = @ltn_des; qsort sub { $a <=> $b }, @l; is_deeply(\@l, \@ltn_asc, "sorted ascending"); @l = @ltn_asc; qsort sub { $b <=> $a }, @l; is_deeply(\@l, \@ltn_des, "sorted descending"); done_testing; List-MoreUtils-0.430/GPL-10000644000175000017500000003053113735543464013257 0ustar snosno GNU GENERAL PUBLIC LICENSE Version 1, February 1989 Copyright (C) 1989 Free Software Foundation, Inc. 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. Preamble The license agreements of most software companies try to keep users at the mercy of those companies. By contrast, our General Public License is intended to guarantee your freedom to share and change free software--to make sure the software is free for all its users. The General Public License applies to the Free Software Foundation's software and to any other program whose authors commit to using it. You can use it for your programs, too. When we speak of free software, we are referring to freedom, not price. Specifically, the General Public License is designed to make sure that you have the freedom to give away or sell copies of free software, that you receive source code or can get it if you want it, that you can change the software or use pieces of it in new free programs; and that you know you can do these things. To protect your rights, we need to make restrictions that forbid anyone to deny you these rights or to ask you to surrender the rights. These restrictions translate to certain responsibilities for you if you distribute copies of the software, or if you modify it. For example, if you distribute copies of a such a program, whether gratis or for a fee, you must give the recipients all the rights that you have. You must make sure that they, too, receive or can get the source code. And you must tell them their rights. We protect your rights with two steps: (1) copyright the software, and (2) offer you this license which gives you legal permission to copy, distribute and/or modify the software. Also, for each author's protection and ours, we want to make certain that everyone understands that there is no warranty for this free software. If the software is modified by someone else and passed on, we want its recipients to know that what they have is not the original, so that any problems introduced by others will not reflect on the original authors' reputations. The precise terms and conditions for copying, distribution and modification follow. GNU GENERAL PUBLIC LICENSE TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 0. This License Agreement applies to any program or other work which contains a notice placed by the copyright holder saying it may be distributed under the terms of this General Public License. The "Program", below, refers to any such program or work, and a "work based on the Program" means either the Program or any work containing the Program or a portion of it, either verbatim or with modifications. Each licensee is addressed as "you". 1. You may copy and distribute verbatim copies of the Program's source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice and disclaimer of warranty; keep intact all the notices that refer to this General Public License and to the absence of any warranty; and give any other recipients of the Program a copy of this General Public License along with the Program. You may charge a fee for the physical act of transferring a copy. 2. You may modify your copy or copies of the Program or any portion of it, and copy and distribute such modifications under the terms of Paragraph 1 above, provided that you also do the following: a) cause the modified files to carry prominent notices stating that you changed the files and the date of any change; and b) cause the whole of any work that you distribute or publish, that in whole or in part contains the Program or any part thereof, either with or without modifications, to be licensed at no charge to all third parties under the terms of this General Public License (except that you may choose to grant warranty protection to some or all third parties, at your option). c) If the modified program normally reads commands interactively when run, you must cause it, when started running for such interactive use in the simplest and most usual way, to print or display an announcement including an appropriate copyright notice and a notice that there is no warranty (or else, saying that you provide a warranty) and that users may redistribute the program under these conditions, and telling the user how to view a copy of this General Public License. d) You may charge a fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee. Mere aggregation of another independent work with the Program (or its derivative) on a volume of a storage or distribution medium does not bring the other work under the scope of these terms. 3. You may copy and distribute the Program (or a portion or derivative of it, under Paragraph 2) in object code or executable form under the terms of Paragraphs 1 and 2 above provided that you also do one of the following: a) accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Paragraphs 1 and 2 above; or, b) accompany it with a written offer, valid for at least three years, to give any third party free (except for a nominal charge for the cost of distribution) a complete machine-readable copy of the corresponding source code, to be distributed under the terms of Paragraphs 1 and 2 above; or, c) accompany it with the information you received as to where the corresponding source code may be obtained. (This alternative is allowed only for noncommercial distribution and only if you received the program in object code or executable form alone.) Source code for a work means the preferred form of the work for making modifications to it. For an executable file, complete source code means all the source code for all modules it contains; but, as a special exception, it need not include source code for modules which are standard libraries that accompany the operating system on which the executable file runs, or for standard header files or definitions files that accompany that operating system. 4. You may not copy, modify, sublicense, distribute or transfer the Program except as expressly provided under this General Public License. Any attempt otherwise to copy, modify, sublicense, distribute or transfer the Program is void, and will automatically terminate your rights to use the Program under this License. However, parties who have received copies, or rights to use copies, from you under this General Public License will not have their licenses terminated so long as such parties remain in full compliance. 5. By copying, distributing or modifying the Program (or any work based on the Program) you indicate your acceptance of this license to do so, and all its terms and conditions. 6. Each time you redistribute the Program (or any work based on the Program), the recipient automatically receives a license from the original licensor to copy, distribute or modify the Program subject to these terms and conditions. You may not impose any further restrictions on the recipients' exercise of the rights granted herein. 7. The Free Software Foundation may publish revised and/or new versions of the General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Program specifies a version number of the license which applies to it and "any later version", you have the option of following the terms and conditions either of that version or of any later version published by the Free Software Foundation. If the Program does not specify a version number of the license, you may choose any version ever published by the Free Software Foundation. 8. If you wish to incorporate parts of the Program into other free programs whose distribution conditions are different, write to the author to ask for permission. For software which is copyrighted by the Free Software Foundation, write to the Free Software Foundation; we sometimes make exceptions for this. Our decision will be guided by the two goals of preserving the free status of all derivatives of our free software and of promoting the sharing and reuse of software generally. NO WARRANTY 9. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 10. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. END OF TERMS AND CONDITIONS Appendix: How to Apply These Terms to Your New Programs If you develop a new program, and you want it to be of the greatest possible use to humanity, the best way to achieve this is to make it free software which everyone can redistribute and change under these terms. To do so, attach the following notices to the program. It is safest to attach them to the start of each source file to most effectively convey the exclusion of warranty; and each file should have at least the "copyright" line and a pointer to where the full notice is found. Copyright (C) 19yy This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 1, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston MA 02110-1301 USA Also add information on how to contact you by electronic and paper mail. If the program is interactive, make it output a short notice like this when it starts in an interactive mode: Gnomovision version 69, Copyright (C) 19xx name of author Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. This is free software, and you are welcome to redistribute it under certain conditions; type `show c' for details. The hypothetical commands `show w' and `show c' should show the appropriate parts of the General Public License. Of course, the commands you use may be called something other than `show w' and `show c'; they could even be mouse-clicks or menu items--whatever suits your program. You should also get your employer (if you work as a programmer) or your school, if any, to sign a "copyright disclaimer" for the program, if necessary. Here a sample; alter the names: Yoyodyne, Inc., hereby disclaims all copyright interest in the program `Gnomovision' (a program to direct compilers to make passes at assemblers) written by James Hacker. , 1 April 1989 Ty Coon, President of Vice That's all there is to it! List-MoreUtils-0.430/Changes0000644000175000017500000004475013744035332014045 0ustar snosnoRevision history for Perl extension List-MoreUtils 0.430 2020-10-21 - bump List::MoreUtils::XS requirement to 0.430 - release 0.429_001 without any further changes 0.429_001 2020-10-05 - fix failing installation in parallel make (Issue#38) - infrastructure improvements and tooling updates, lot's of author tests with according fixes added - added slide and slideatatime functions wished by SCHWERN - documentation fixes (PR#21, PR#33, PR#34, RT#126029, RT#132043, RT#132940) 0.428 2017-12-11 - release 0.427_001 without further changes 0.427_001 2017-11-06 - fix Issue#22 (Upgrading from LMU 0.416 to split XS/PP version will fail) reported by Graham Knop (haarg), this time hopefully the right way, repeated in RT#123310. - fix Issue#29 (pairwise() PP implementation add tail undefs if arrays sizes differs) reported by 0x62ash 0.426 2017-10-12 - release 0.425_002 without further changes 0.425_002 2017-10-05 - re-introduce Config::AutoConf (https://rt.cpan.org/Ticket/Display.html?id=122875#txn-1745984) for final satisfying RT#122875 - bump required version of List::MoreUtils::XS to 0.426, if XS is available 0.425_001 2017-09-27 - fix broken arrayify prototype - revert removal of old List::MoreUtils::XS parts 0.425 2017-09-06 - release 0.424_001 as 0.425 with XS is META.* after 136:0 PASS:FAIL on CPAN Tester Matrix 0.424_001 2017-09-05 - Makefile.PL: modify PREREQ_PM instead of recommend dynamically 0.423 2017-08-22 - sync version with List::MoreUtils::XS - add examples for binsert/bremove (LMU::XS issue #1, Thanks to shawnlaffan) - update tests to latest List::MoreUtils::XS - recommend List::MoreUtils::XS 0.423 0.420_001 2017-08-15 - add some new functions: * qsort (XS only) * binsert * bremove * listcmp * arrayify (RT#17230) * samples (RT#77562) * minmaxstr (RT#106401) * lower_bound * upper_bound * equal_range * frequencies * occurrences * mode (RT#91991) * zip6 (RT#42921) * reduce_0 * reduce_1 * reduce_u - improve tests - make List::MoreUtils::XS independent from List::MoreUtils Note that List::MoreUtils::XS doesn't guarantee API stability - this feature is only provided through List::MoreUtils as frontend. - improve Makefile.PL regarding some build artifacts 0.419 2017-04-06 - Fix RT#120799: Makefile.PL fails due to unescaped paths interpolated in regex pattern (thanks, A. Sinan Unur) 0.418 2017-03-29 - Clarify license conditions - fix Changes version/date of 0.417_001 0.417_001 2017-03-21 - Divorce List::MoreUtils and List::MoreUtils::XS - Change license to Apache 2.0 to avoid code stealing without credits - Don't support Perl 5.6 out of the box anymore - fix RT#120235 - uniq examples are incorrect - remove things which will be never done from TODO list as suggested by Mark Aufflick in PR#18 - Apply patch from Yanick Champoux to avoid spelling checker complains 0.416 2016-07-06 - Change the way how the XS part is loaded as a result of RT#115808 - Fix some spelling errors (fix RT#115807), thanks Salvatore Bonaccorso - Requires XSLoader 0.22 0.415 2016-05-01 - Release 0.414_001 as 0.415 without further changes 0.414_001 2016-04-13 - fix RT#75727 - after's XS implementation call XSRETURN(-1) when it doesn't find an element (2nd patch provided by Reini Urban, regression test provided by Tony Cook) - fix RT#113117 - XS's minmax() sometimes return undef (perl >= 5.20), thanks PERLANCAR and SREZIC - explicit test for thesis in RT#110998 - XS implementation of pairwise fails with memory allocation error when there are more return values than in original lists -- thesis is proven wrong - efficiency improvements by bulk88 - improve some tests to get clearer reports - distinguish between "Makefile.PL find's a .git directory" and "Makefile.PL runs in maintainer mode" 0.413 2015-06-10 - Fix compiling in c++ mode (depreciated, but some people seem to require it). Solves RT#104690 0.412 2015-05-19 - release 0.411_001 without further changes 0.411_001 2015-05-11 - move generation of test endpoints to author stage as requested per issue/#9 - add a rough guide for contributors - fix rt#103251 to avoid removing bundled stuff by accident - Fix compilation errors under cl (Thanks to jddurand) 0.410 2015-03-30 - release 0.409_003 after no further issues came up 0.409_003 2015-03-27 - update bundled bootstrap modules * Data::Tumbler to 0.010 * Test::WriteVariants to 0.012 * Config::AutoConf to 0.311 - fix spelling (and add stop-words for names etc. in author tests) 0.409_002 2015-03-23 - fix multiple mg_get can break weird tie's (thanks to leont) - fix test run using PERL5OPT=d:Confess (thanks kentl & ribasushi) - use base instead of parent, cause parent isn't bundled before 5.10.1 (smoke report from SREZIC) - update bundled modules (for bootstrapping) and ppport.h (from 3.25 to 3.31) 0.409_001 2015-03-21 - fix RT#102885: uniq bug broke tied array (reported by louying@pwrd.com) - fix issue/8: Macros introduced in dfd851147f cause problems with MSVC (reported by A. Sinan Unur) - Update ppport.h from 3.25 to 3.31 0.408 2015-03-18 - fix RT#102840: uniq broken for call-by-function-return (reported by Jean-Damien Durand), with a new test case thanks to Thomas Sibley - fix RT#102853: hent_val accesses (reported by Brad Forschinger with a reasonable patch) - fix RT#102833: Compilation error with perl 5.21.7+ (reported by Slaven Rezic) - fix regex for RT#44518 test 0.407 2015-03-17 - Added one(), onlyidx(), onlyval() (RT#73134, MHASCH) and onlyres() - improve XS maintainability - document how uniq/distinct deal with undef (RT#49800) - add bsearchidx to satisfy RT#63470 - add singleton to satisfy RT#94382 - fix RT#82039 - uniq changes the type of its arguments - fix RT#44518 again 0.406 2015-03-03 - add new functions firstres and lastres in addition to firstidx, lastidx, firstval and lastval - regenerate MANIFEST to bundle README.md 0.405 2015-02-14 - fix RT#78527 - first_val/last_val in documentation - fix RT#102055 - ExtUtils::MakeMaker required version absurdly high - update README (deploy it as README.md now) - fix compiler issue for older/ansi-c89 compilers - remove local compat workarounds in favour for ppport.h 0.404 2015-01-28 - fix ancient toolchains (PREREQ_PM & Co. set appropriately), reported by ilmari - bump version required of Test::More to 0.96 (#toolchain calls it a "sane subset") - fix some meta-data #toolchain pointed out 0.403 2015-01-27 - remove most recent stable perl recommendation from meta to workaround misbehaving CPAN clients blocking update - update copyright date - ensure AUTHOR is a string on older toolchains 0.402 2014-12-17 - bump Config::AutoConf and Test::WriteVariants requirement for improved 5.6 compatibility (fixes rt#101121) - use base instead of parent in configure stage (improves building on 5.6) - fix rt#101067 by applying patch from Father Chrysostomos (thanks to Lukas Mai (MAUKE) for reporting and explaining) 0.401 2014-12-08 - update bundled Config::AutoConf to 0.307 - release after long testing period 0.400_010 2014-12-08 - bundle configure_requires using inc::latest - fix RT#96596 by checking types before starting logic ... * RT#86260 reported the same issue - lower minimum perl required to 5.6 - switch to check_produce_loadable_xs_build of Config::AutoConf 0.306 0.400_009 2014-05-05 - improve documentation (David Golden, Jens Rehsack) - bundle non-core modules (compared to 5.14) 0.400_008 2014-04-24 - fix none for 0.24 and clarify API tag documentation (David Golden) - refactor import tags for clarity (David Golden) 0.400_007 2014-04-22 - cut out exporter-related cruft; it was only necessary when needing to choose between multiple implementations (Toby Inkster) - Reorganize and clarify documentation (David Golden) - revise SYNOPSIS and DESCRIPTION for revised export model (David Golden) - introduce ":like_*" import tags (Toby Inkster, Jens Rehsack) - remove Data::Tumbler and Module::Pluggable from configure dependencies, they're coming with Test::WriteVariants 0.400_006 2014-04-01 - fix typos in POD (RT#87490 - thanks to David Steinbrunner) - refactor LMU as discussed with David Golden, Tim Bunce and Toby Inkster 0.400_005 2014-03-24 - rename implementations from alias => relax and tassilo => strict - remove 'sno' implementation - add precedence 'default' in addition to 'all' for those who prefer strict over relax - move dependency Module::Runtime from configure to runtime 0.400_004 2014-03-21 - Switch from Sub::Exporter to Exporter::Tiny (Toby Inkster) - fix issues on older perls back to 5.8.1 (Config::AutoConf will not do out of the box, but this can be fixed) - fix backward compatibility issues (RT#94013 in conjunction with RT#93995) Details needs to be discussed with Moose community (unless they stop caring) to get out of distinguishing hell as soon as possible - fix some spelling issues reported by David Steinbrunner (RT#86347) - clarify depedencies, especially recommended ones - add some additional tests to prove reported bugs (informed reporters when not reproducable) 0.400_003 2014-03-18 - fix compile error on threaded perls (RT#93934 - thanks Andreas Koenig for reporting) - fix exporter configuration (RT#93929 - thanks Andreas Koenig for reporting) - fix RT#40905 by allowing choose an appropriate implementation - add test for RT#76749 - seems not reproducable (but hopefully reporter David J. Oswald can fix the test to help fixing the issue beyond) 0.400_002 2014-03-16 - reduce minimum perl version to 5.8.1 - split implementations between existing authors - switch to DynaLoader and Sub::Exporter - rely for testing on Test::WriteVariants and Data::Tumbler (DBI::Test technology to improve tests) - fix 64-bit integer precision (RT#93207 reported by Dana Jacobsen) 0.400_001 2013-10-11 - Reformat Changes as per CPAN::Changes::Spec - taking FIRSTCOME power and move repository to GitHub - merge Tassilo's 0.25_nn dev releases back * mark "any" and "all" as "to be discussed" ==> API changes made by Alias/ADAMK - bump version to clarify new age (contributors welcome!) - bump minimum perl version to 5.8.3 0.33 2011-08-04 - Updated can_xs to fix a bug in it 0.32 2011-05-20 - Production release, no other changes 0.31_02 2011-03-21 - More accurate detection of XS support (ADAMK) 0.31_01 2011-03-21 - Updating copyright year (ADAMK) - Teak documentation of all() and none() (WYANT) - Memory leak fixed for apply() and XS version restored (ARC) - Memory leak fixed for indexes() and XS version restored (ARC) - Memory leak fixed for part() and XS version restored (ARC) 0.30 2010-12-16 - Change the way we localise PERL_DL_NONLAZY to false to remove a warning that some people were seeing. The new approach is taken from the way that List::Util does it. 0.29 2010-12-08 - Removed an erroneous Test::NoWarnings dependency 0.28 2010-12-07 - Switching to a production release - Restored the regression test for RT #38630 from 0.23. As apply() was disabled in 0.27_04 this test will only act to validate the future XS restoration of apply(). - Adding uniq warning tests, disabled initially 0.27_04 2010-12-06 - The behaviour of any/all/none/notall has changed when passed a null list to treat a null list as a legitimate list. Instead of returning C the functions now return the following: any {} == false, all {} == true, none {} == true, notall {} == false. Resolves #40905: Returning undef when none is passed an empty - Disabled the leaking XS versions of part(), apply() and indexes() 0.27_03 2010-12-06 - General house cleaning 0.27_02 2010-12-01 - Reduced test suite peak memory consumption by 5-10 meg - Added the 'distinct' alias for the uniq function, for people that like their chained map/grep/sort pipelines with a SQL'ish flavour. - Expanded test suite for the any() group of functions. - The any() group of functions now strictly always return scalar boolean true, false and undef to match the XS version. 0.27_01 2012-12-01 - Refactored the split test scripts into a common test module to be shared between both the Perl and XS versions. - Reapply fix for http://rt.cpan.org/Ticket/Display.html?id=39847 "minmax error: unpredictable results with lists of 1 element" 0.26 2010-11-23 - No changes - Some parts of the CPAN cloud were confusing my 0.24 release with the older deleted 0.24. Bumping version past Tassilo's to clarify things. 0.24 2010-11-22 - No changes, switching to a production version 0.23_01 2010-09-25 - First attempt at repackaging the List::MoreUtils code in Makefile.PL and release toolchain similar to Params::Util 0.25_02 2009-08-01 - MS VC++ 7 doesn't like inline nor 'long long' (patch provided by Taro Nishino (taro DOT nishino AT gmail.com) - Newx isbn't around in older perls so use New(0,...) instead 0.25_01 2009-07-30 - it seems the only way of handling the stack that works on all flavors of the multicall API is by making a shallow copy of it and use that between the PUSH/POP_MULTICALL bracket - fix awkward ok() override in List-MoreUtils.t so that it reports line numbers in test failures properly 0.24 2009-07-19 - List::MoreUtils was not handling the stack properly when the stack was grown from inside code-references - a couple of tests for each_arrayref were calling each_array 0.23 2009-04-19 - BACKWARDS INCOMPATIBLE CHANGE: fixed: Returning undef when none is passed an empty array is counterintuitive (http://rt.cpan.org/Ticket/Display.html?id=40905) - fixed: minmax error: unpredictable results with lists of 1 element (http://rt.cpan.org/Ticket/Display.html?id=39847) - fixed: bug: uniq doesn't like undef values. uniq warns on undef values (http://rt.cpan.org/Ticket/Display.html?id=37533) (http://rt.cpan.org/Ticket/Display.html?id=43214) - fixed: bug in pairwise when $a and $b are lexically defined using my (http://rt.cpan.org/Ticket/Display.html?id=44518) - fixed: Big memory leak with XS part() (http://rt.cpan.org/Ticket/Display.html?id=41097) - fixed: memory leak in indexes() [XS] (http://rt.cpan.org/Public/Bug/Display.html?id=41494) - reduced memory-requirements for the part() tests as that was responsible for a lot of unnecessary test-failures - new function bsearch() which performs a binary search 0.22 2006-07-02 - SvPV_nolen doesn't exist on pre 5.6 perls 0.21 2006-06-18 - propagate dies from inside the code-reference of pairwise to caller 0.20 2006-04-25 - part() would destroy the list elements when changing an array in place (@list = part { ... } @list) 0.19 2006-03-13 - working down myself the queue of suggestions: part() added (Ricardo SIGNES ) 0.18 2006-02-25 - each_arrayref (XS) couldn't deal with refs to list literals (brought up by David Filmer in comp.lang.perl.misc) 0.17 2005-12-07 - each_arrayref had no XS implementation and wasn't mentioned in the PODs (patch by Anno Siegel ) 0.16 2005-11-14 - a dangling semicolon in some macros prevented the XS portion to compile on some compilers (Lars Thegler ) 0.15 2005-11-11 - 0.13 and 0.14 broke the module on 5.6.x (spotted by Thomas A. Lowery ) - internals changed to make use of the new MULTICALL API which had to be backported to 5.005_x 0.14 2005-11-10 - 0.13 fixed the leaks but rendered the XS part uncompilable for perls < 5.6.0: Fixed (spotted by Lars Thegler ) 0.13 2005-11-09 - nearly all functions receiving a CODE-block as first argument had a hefty memory-leak: Fixed (spotted by Thomas A. Lowery ) 0.12 2005-09-28 - first_index and each_arrayref weren't exportable (spotted by Darren Duncan) 0.11 2005-09-27 - make sure that Test::Pod and Test::Pod::Coverage are installed in the required minimum versions (thanks to Ricardo Signes ) 0.10 2005-04-01 - new function minmax() with comparisons in O(3n/2 - 2) - some POD corrections (Adam Kennedy) - POD- and POD-coverage tests 0.09 2004-12-04 - 0.08 only fixed uniq() for scalar context 0.08 2004-12-03 - uniq() was not mentioned in the perldocs and only had the XS implementation - uniq() also produced wrong results on 5.8.0 (thanks to Slaven Rezic for spotting it and suggesting a workaround) - the test-suite triggered a bug in 5.6.x perls - the test-suite now tests both the XS- and Perl-implementation - a wrong example in the perldocs fixed (Ron Savage) 0.07 2004-12-01 - new functions: after, after_incl, before, before_incl, indexes lastval, firstval, pairwise, each_array, natatime, mesh (all from Eric J. Roodes' List::MoreUtil). 0.06 2004-11-14 - new function 'apply' on behalf of Brian McCauley () 0.05 2004-09-18 - merged in insert_after() and insert_after_string() from List::Utils which is now obsolete (thanks to James Keenan and Terrence Brannon ) 0.04 2004-07-10 - renamed to List::MoreUtils on suggestion by Steve Purkis 0.03 2004-07-09 - some compilers don't like the stale goto labels without any statement following. Fixed. (Robert Rothenberg ) 0.02 2004-07-08 - added Perl implementations of all functions as a fallback (Adam Kennedy ) 0.01 2004-07-05 - original version; created by h2xs 1.23 with options -b 5.5.3 -A -n List::Any List-MoreUtils-0.430/Makefile.PL0000644000175000017500000001773313744035216014526 0ustar snosno#!perl use strict; use warnings; use 5.008_001; use Config; use ExtUtils::MakeMaker; BEGIN { unless (grep { $_ eq "." } @INC) { use lib "."; } } use inc::latest 'Capture::Tiny'; use inc::latest 'Config::AutoConf'; if (inc::latest->can("write")) { inc::latest->write("inc"); for my $mod (inc::latest->loaded_modules) { inc::latest->bundle_module($mod, "inc"); } } use inc::Config::AutoConf::LMU (); inc::Config::AutoConf::LMU->_set_argv(@ARGV); # XXX hack because we cannot construct for global use my $loadable_xs = inc::Config::AutoConf::LMU->check_produce_loadable_xs_build(); if (-d "Sandbox") { unless (grep { $_ eq "." } @INC) { use lib "."; } eval "use Sandbox::Tumble ();"; $@ and die $@; eval "use File::Path ();"; File::Path->import; -d 't/xs' and rmtree('t/xs'); -d 't/pureperl' and rmtree('t/pureperl'); Sandbox::Tumble->tumble(qw(t)); } my $conflictMsg = < '0.038', ($loadable_xs ? ('List::MoreUtils::XS' => '0.430') : ()) ); my %BUNDLE_CONFIGURE_DEPS = ( 'inc::latest' => '0.500', 'Config::AutoConf' => '0.315', ); my %CONFIGURE_DEPS = ( 'ExtUtils::MakeMaker' => 0, ); my %TEST_DEPS = ( 'Storable' => 0, 'Test::More' => 0.96, ); my %CONFLICTS = ( 'List::MoreUtils' => '0.416', 'List::MoreUtils::PP' => '0.416', 'List::MoreUtils::XS' => '0.416', ); WriteMakefile1( META_MERGE => { 'meta-spec' => {version => 2}, resources => { homepage => 'https://metacpan.org/release/List-MoreUtils', repository => { url => 'https://github.com/perl5-utils/List-MoreUtils.git', web => 'https://github.com/perl5-utils/List-MoreUtils', type => 'git', }, bugtracker => { web => 'https://rt.cpan.org/Dist/Display.html?Name=List-MoreUtils', mailto => 'bug-List-MoreUtils@rt.cpan.org', }, license => 'apache_2_0', }, prereqs => { develop => { requires => { %BUNDLE_CONFIGURE_DEPS, 'Test::CPAN::Changes' => 0, 'Test::CheckManifest' => 0, 'Module::CPANTS::Analyse' => '0.96', 'Test::Kwalitee' => 0, 'Test::Perl::Critic' => 0, 'Test::PerlTidy' => 0, 'Test::Pod' => 0, 'Test::Pod::Coverage' => 0, 'Test::Pod::Spelling::CommonMistakes' => 0, 'Test::Spelling' => 0, 'Test::WriteVariants' => '0.014', }, }, configure => { requires => {%CONFIGURE_DEPS}, recommends => {'Config::AutoConf' => '0.315'} }, test => { requires => {%TEST_DEPS}, requires => {'Test::LeakTrace' => 0} }, runtime => {requires => {%RUN_DEPS}}, }, }, NAME => 'List::MoreUtils', ABSTRACT => 'Provide the stuff missing in List::Util', VERSION_FROM => 'lib/List/MoreUtils.pm', AUTHOR => [ 'Tassilo von Parseval ', 'Adam Kennedy ', 'Jens Rehsack ' ], LICENSE => 'apache_2_0', CONFIGURE_REQUIRES => \%CONFIGURE_DEPS, CONFLICTS => \%CONFLICTS, PREREQ_PM => \%RUN_DEPS, TEST_REQUIRES => \%TEST_DEPS, (-d "Sandbox" ? (realclean => {FILES => "t/pureperl t/xs M*.bak"}) : ()), depend => {'$(FIRST_MAKEFILE)' => '$(VERSION_FROM)'}, test => {TESTS => join(' ', 't/*.t', 't/pureperl/*.t', ($loadable_xs ? 't/xs/*.t' : ()), 'xt/*.t')}, # Otherwise 'cxinc' isn't defined ($] < 5.012 ? (DEFINE => '-DPERL_EXT') : (),), ); sub CheckConflicts { my %params = @_; my %conflicts = %{$params{CONFLICTS}}; my $found = 0; my @kill; while (my ($module, $version) = each(%conflicts)) { undef $@; eval "require $module"; next if $@; my $installed = eval "\$" . $module . "::VERSION"; if ($installed le $version) { ++$found; if ($module eq "List::MoreUtils" or $module eq "List::MoreUtils::PP") { (my $modfile = "${module}.pm") =~ s,::,/,g; warn sprintf($selfConflictMsg, $params{NAME}, $module, $installed, $INC{$modfile}); push @kill, $modfile; } else { warn sprintf($conflictMsg, $params{NAME}, $module, $installed, $params{NAME}); } } } if (@kill) { package MY; no warnings 'once'; *install = sub { my $self = shift; (my $targets = $self->SUPER::install) =~ s/^(pure_site_install\s+::?)/$1 delete_conflicting_files/m; return "\ndelete_conflicting_files :\n" . join("", map { "\t\$(NOECHO) \$(RM_F) " . $self->quote_literal($self->catfile('$(DESTINSTALLSITEARCH)', $_)) . "\n" } @kill) . $targets; }; } return !$found; } sub WriteMakefile1 { # originally written by Alexandr Ciornii, version 0.21. Added by eumm-upgrade. my %params = @_; my $eumm_version = $ExtUtils::MakeMaker::VERSION; $eumm_version = eval $eumm_version; die "EXTRA_META is deprecated" if (exists($params{EXTRA_META})); die "License not specified" if (!exists($params{LICENSE})); $params{TEST_REQUIRES} and $eumm_version < 6.6303 and $params{BUILD_REQUIRES} = {%{$params{BUILD_REQUIRES} || {}}, %{delete $params{TEST_REQUIRES}}}; #EUMM 6.5502 has problems with BUILD_REQUIRES $params{BUILD_REQUIRES} and $eumm_version < 6.5503 and $params{PREREQ_PM} = {%{$params{PREREQ_PM} || {}}, %{delete $params{BUILD_REQUIRES}}}; ref $params{AUTHOR} and "ARRAY" eq ref $params{AUTHOR} and $eumm_version < 6.5702 and $params{AUTHOR} = join(", ", @{$params{AUTHOR}}); delete $params{CONFIGURE_REQUIRES} if ($eumm_version < 6.52); delete $params{MIN_PERL_VERSION} if ($eumm_version < 6.48); delete $params{META_MERGE} if ($eumm_version < 6.46); delete $params{META_ADD}{prereqs} if ($eumm_version < 6.58); delete $params{META_ADD}{'meta-spec'} if ($eumm_version < 6.58); delete $params{META_ADD} if ($eumm_version < 6.46); delete $params{LICENSE} if ($eumm_version < 6.31); delete $params{AUTHOR} if ($] < 5.005); delete $params{ABSTRACT_FROM} if ($] < 5.005); delete $params{BINARY_LOCATION} if ($] < 5.005); # more or less taken from SQL::Statement's Makefile.PL if ($params{CONFLICTS}) { my $ok = CheckConflicts(%params); exit(0) if ($params{PREREQ_FATAL} and not $ok); my $cpan_smoker = grep { $_ =~ m/(?:CR_SMOKER|CPAN_REPORTER|AUTOMATED_TESTING)/ } keys %ENV; unless ($cpan_smoker || $ENV{PERL_MM_USE_DEFAULT}) { sleep 4 unless ($ok); } delete $params{CONFLICTS}; } WriteMakefile(%params); }