Skip Menu |
 

This queue is for tickets about the List-MoreUtils CPAN distribution.

Report information
The Basics
Id: 73134
Status: resolved
Priority: 0/
Queue: List-MoreUtils

People
Owner: Nobody in particular
Requestors: kaoru [...] slackwise.net
Cc:
AdminCc:

Bug Information
Severity: Wishlist
Broken in: (no value)
Fixed in: 0.407



Subject: wishlist: one() - returns true if a single element matches, false otherwise
Implemented in pure perl in one.t, with some tests. I found it useful once, maybe others would do.
Subject: one.t
Download one.t
text/x-perl 1.1k
use strict; use warnings; use Test::More; sub one (&@) { my $code_ref = shift; my @list = @_; my $rv; foreach (@list) { my $code_rv = $code_ref->(); if ($code_rv && !$rv) { $rv = 1; } elsif ($code_rv && $rv) { return; } } return 1 if $rv; return; } ok one { $_ eq 'a' } qw(a b c d e f); ok one { $_ eq 'a' } qw(f e d c b a); ok one { $_ eq 'a' } qw(a 2 3 4 5 6); ok one { $_ eq 'a' } qw(1 a 3 4 5 6); ok one { $_ eq 'a' } qw(1 2 a 4 5 6); ok one { $_ eq 'a' } qw(1 2 3 a 5 6); ok one { $_ eq 'a' } qw(1 2 3 4 a 6); ok one { $_ eq 'a' } qw(1 2 3 4 5 a); ok ! one { $_ eq 'a' } qw(); ok ! one { $_ eq 'a' } qw(1 2 3 4 5 6); ok ! one { $_ eq 'a' } qw(2 3 4 5 6 7); ok ! one { $_ eq 'a' } qw(3 4 5 6 7 8); ok ! one { $_ eq 'a' } qw(b c d e f g); ok ! one { $_ eq 'a' } qw(c d e f g h); ok ! one { $_ eq 'a' } qw(1 a 3 a 5 6); ok ! one { $_ eq 'a' } qw(a a a a a a); ok ! one { $_ eq 'a' } qw(a 2 a 4 a 6); ok ! one { $_ eq 'a' } qw(a a c d e f); ok ! one { $_ eq 'a' } qw(a a a d e f); ok ! one { $_ eq 'a' } qw(a a a a e f); ok ! one { $_ eq 'a' } qw(a a a a a f); ok ! one { $_ eq 'a' } qw(a a a a a a); done_testing();
Download (untitled) / with headers
text/plain 375b
This is functionally equivalent (grep { ... } @list) == 1; Since it's very specialized, not to hard to implement and doesn't save any performance (it's probably slower) I'd say it doesn't deserve inclusion. Perhaps as a FAQ entry in the docs. A more general case version equivalent to (grep { ... } @list) == $n has a bit more merit, but I still don't find it enough.
Subject: [PATCH] wishlist: one() - returns true if a single element matches, false otherwise
Download (untitled) / with headers
text/plain 1.4k
On Fri Mar 02 22:25:35 2012, MSCHWERN wrote: Show quoted text
> This is functionally equivalent > > (grep { ... } @list) == 1; > > Since it's very specialized, not to hard to implement and doesn't save > any performance (it's probably slower) I'd say it doesn't deserve > inclusion. Perhaps as a FAQ entry in the docs. > > A more general case version equivalent to (grep { ... } @list) == $n has > a bit more merit, but I still don't find it enough.
Not being hard to implement is a weak point against extentending a module that explicitly puts trivial functionality on top of its agenda. As to performance, of course there can be a huge gain over grep or this same module's true() function by way of shortcut behaviour. Why keep on counting true instances if you already saw enough of them to know the result will be false? And it can be useful. One use case would be option parsing with mutually exclusive alternatives. I would prefer, however, a more complete approach and also have functions that can tell which item was the singular one that matched. I am extending this wishlist suggestion therefore by two more functions. only_index() should return the index of the only item that matched or -1, and only_value() should return the very item or undef, in analogy to first_index()/last_index() and first_value() /last_value(). To promote this idea further, I am attaching a complete patch with implementations in pp and xs, including tests and pod. -Martin
Subject: List-MoreUtils-0.33-MHASCH-01.patch
diff -rup List-MoreUtils-0.33.orig/Changes List-MoreUtils-0.33/Changes --- List-MoreUtils-0.33.orig/Changes 2011-08-04 11:39:36.000000000 +0200 +++ List-MoreUtils-0.33/Changes 2012-09-21 18:58:50.000000000 +0200 @@ -1,5 +1,8 @@ Revision history for Perl extension List-MoreUtils +x.xx (not yet released) + - Added one(), onlyidx(), onlyval() (MHASCH) + 0.33 Thu 4 Aug 2011 - Updated can_xs to fix a bug in it diff -rup List-MoreUtils-0.33.orig/MoreUtils.xs List-MoreUtils-0.33/MoreUtils.xs --- List-MoreUtils-0.33.orig/MoreUtils.xs 2011-08-04 11:39:36.000000000 +0200 +++ List-MoreUtils-0.33/MoreUtils.xs 2012-09-21 18:08:45.000000000 +0200 @@ -345,6 +345,45 @@ CODE: XSRETURN_NO; } +void +one (code, ...) + SV *code; +PROTOTYPE: &@ +CODE: +{ + dMULTICALL; + register int i; + register int found = 0; + HV *stash; + GV *gv; + I32 gimme = G_SCALAR; + SV **args = &PL_stack_base[ax]; + CV *cv; + + if (items <= 1) + XSRETURN_NO; + + cv = sv_2cv(code, &stash, &gv, 0); + PUSH_MULTICALL(cv); + SAVESPTR(GvSV(PL_defgv)); + + for(i = 1 ; i < items ; ++i) { + GvSV(PL_defgv) = args[i]; + MULTICALL; + if (SvTRUE(*PL_stack_sp)) { + if (found++) { + POP_MULTICALL; + XSRETURN_NO; + } + } + } + POP_MULTICALL; + if (found) { + XSRETURN_YES; + } + XSRETURN_NO; +} + int true (code, ...) SV *code; @@ -488,6 +527,45 @@ OUTPUT: RETVAL int +onlyidx (code, ...) + SV *code; +PROTOTYPE: &@ +CODE: +{ + dMULTICALL; + register int i; + register int found = 0; + HV *stash; + GV *gv; + I32 gimme = G_SCALAR; + SV **args = &PL_stack_base[ax]; + CV *cv; + + RETVAL = -1; + + if (items > 1) { + cv = sv_2cv(code, &stash, &gv, 0); + PUSH_MULTICALL(cv); + SAVESPTR(GvSV(PL_defgv)); + + for (i = 1 ; i < items ; ++i) { + GvSV(PL_defgv) = args[i]; + MULTICALL; + if (SvTRUE(*PL_stack_sp)) { + if (found++) { + RETVAL = -1; + break; + } + RETVAL = i-1; + } + } + POP_MULTICALL; + } +} +OUTPUT: + RETVAL + +int insert_after (code, val, avref) SV *code; SV *val; @@ -860,6 +938,48 @@ CODE: } } POP_MULTICALL; + } +} +OUTPUT: + RETVAL + +SV * +onlyval (code, ...) + SV *code; +PROTOTYPE: &@ +CODE: +{ + dMULTICALL; + register int i; + register int found = 0; + HV *stash; + GV *gv; + I32 gimme = G_SCALAR; + SV **args = &PL_stack_base[ax]; + CV *cv; + + RETVAL = &PL_sv_undef; + + if (items > 1) { + cv = sv_2cv(code, &stash, &gv, 0); + PUSH_MULTICALL(cv); + SAVESPTR(GvSV(PL_defgv)); + + for (i = 1; i < items; ++i) { + GvSV(PL_defgv) = args[i]; + MULTICALL; + if (SvTRUE(*PL_stack_sp)) { + if (found++) { + /* see comment in indexes() */ + SvREFCNT_dec(RETVAL); + RETVAL = &PL_sv_undef; + break; + } + /* see comment in indexes() */ + SvREFCNT_inc(RETVAL = args[i]); + } + } + POP_MULTICALL; } } OUTPUT: diff -rup List-MoreUtils-0.33.orig/lib/List/MoreUtils.pm List-MoreUtils-0.33/lib/List/MoreUtils.pm --- List-MoreUtils-0.33.orig/lib/List/MoreUtils.pm 2011-08-04 11:39:36.000000000 +0200 +++ List-MoreUtils-0.33/lib/List/MoreUtils.pm 2012-09-21 19:02:02.000000000 +0200 @@ -7,16 +7,18 @@ use DynaLoader (); use vars qw{ $VERSION @ISA @EXPORT_OK %EXPORT_TAGS }; BEGIN { - $VERSION = '0.33'; - # $VERSION = eval $VERSION; + $VERSION = '0.33_01'; + $VERSION = eval $VERSION; @ISA = qw{ Exporter DynaLoader }; @EXPORT_OK = qw{ - any all none notall true false + any all none notall one true false firstidx first_index lastidx last_index + onlyidx only_index insert_after insert_after_string apply indexes after after_incl before before_incl firstval first_value lastval last_value + onlyval only_value each_array each_arrayref pairwise natatime mesh zip uniq distinct @@ -77,6 +79,18 @@ sub notall (&@) { return NO; } +sub one (&@) { + my $f = shift; + my $found = NO; + foreach ( @_ ) { + if ($f->()) { + return NO if $found; + $found = YES; + } + } + return $found; +} + sub true (&@) { my $f = shift; my $count = 0; @@ -113,6 +127,19 @@ sub lastidx (&@) { return -1; } +sub onlyidx (&@) { + my $f = shift; + my $r = -1; + foreach my $i ( 0 .. $#_ ) { + local *_ = \$_[$i]; + if ($f->()) { + return -1 if -1 != $r; + $r = $i; + } + } + return $r; +} + sub insert_after (&$\@) { my ($f, $val, $list) = @_; my $c = -1; @@ -214,6 +241,20 @@ sub firstval (&@) { return undef; } +sub onlyval (&@) { + my $test = shift; + my $result = undef; + my $found = NO; + foreach ( @_ ) { + if ($test->()) { + return undef if $found; + $result = $_; + $found = YES; + } + } + return $result; +} + sub pairwise (&\@\@) { my $op = shift; @@ -350,8 +391,10 @@ die $@ if $@; # Function aliases *first_index = \&firstidx; *last_index = \&lastidx; +*only_index = \&onlyidx; *first_value = \&firstval; *last_value = \&lastval; +*only_value = \&onlyval; *zip = \&mesh; *distinct = \&uniq; @@ -368,12 +411,14 @@ List::MoreUtils - Provide the stuff miss =head1 SYNOPSIS use List::MoreUtils qw{ - any all none notall true false + any all none notall one true false firstidx first_index lastidx last_index + onlyidx only_index insert_after insert_after_string apply indexes after after_incl before before_incl firstval first_value lastval last_value + onlyval only_val each_array each_arrayref pairwise natatime mesh zip uniq distinct minmax part @@ -434,6 +479,20 @@ turn: Returns false otherwise, or if LIST is empty. +=item one 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, especially if LIST is empty. + +The expression C<one BLOCK LIST> is almost equivalent to +C<1 == true BLOCK LIST>, except for short-cutting. +Evaluation of BLOCK will immediately stop at the second true value. + =item true BLOCK LIST Counts the number of elements in LIST for which the criterion in BLOCK is true. @@ -480,6 +539,23 @@ Returns C<-1> if no such item could be f C<last_index> is an alias for C<lastidx>. +=item onlyidx BLOCK LIST + +=item 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<only_index> is an alias for C<onlyidx>. + =item insert_after BLOCK VALUE LIST Inserts VALUE after the first item in LIST for which the criterion in BLOCK is @@ -556,7 +632,7 @@ Returns the first element in LIST for wh element of LIST is set to C<$_> in turn. Returns C<undef> if no such element has been found. -C<first_val> is an alias for C<firstval>. +C<first_value> is an alias for C<firstval>. =item lastval BLOCK LIST @@ -566,7 +642,17 @@ Returns the last value in LIST for which of LIST is set to C<$_> in turn. Returns C<undef> if no such element has been found. -C<last_val> is an alias for C<lastval>. +C<last_value> is an alias for C<lastval>. + +=item onlyval BLOCK LIST + +=item only_value BLOCK LIST + +Returns the only value in LIST for which BLOCK evaluates to true. +Each element of LIST is set to C<$_> in turn. Returns C<undef> if either +no such element or more than one of these has been found. + +C<only_value> is an alias for C<onlyval>. =item pairwise BLOCK ARRAY1 ARRAY2 diff -rup List-MoreUtils-0.33.orig/t/lib/Test.pm List-MoreUtils-0.33/t/lib/Test.pm --- List-MoreUtils-0.33.orig/t/lib/Test.pm 2011-08-04 11:39:36.000000000 +0200 +++ List-MoreUtils-0.33/t/lib/Test.pm 2012-09-21 18:55:18.000000000 +0200 @@ -7,16 +7,18 @@ use List::MoreUtils ':all'; # Run all tests sub run { - plan tests => 184; + plan tests => 217; test_any(); test_all(); test_none(); test_notall(); + test_one(); test_true(); test_false(); test_firstidx(); test_lastidx(); + test_onlyidx(); test_insert_after(); test_insert_after_string(); test_apply(); @@ -27,6 +29,7 @@ sub run { test_after_incl(); test_firstval(); test_lastval(); + test_onlyval(); test_each_array(); test_pairwise(); test_natatime(); @@ -108,6 +111,22 @@ sub test_notall { }); } +sub test_one { + # 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 ); + + leak_free_ok(one => sub { + my $ok = one { 150 <= $_ } @list; + my $ok2 = one { 150 <= $_ } 1 .. 300; + }); +} + sub test_true { # The null set should return zero my $null_scalar = true { }; @@ -184,6 +203,29 @@ sub test_lastidx { }); } +sub test_onlyidx { + 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; + }); +} + sub test_insert_after { my @list = qw{This is a list}; insert_after { $_ eq "a" } "longer" => @list; @@ -367,6 +409,29 @@ sub test_lastval { }); } +sub test_onlyval { + 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; + }); +} + sub test_each_array { SCOPE: { my @a = ( 7, 3, 'a', undef, 'r' );
RT-Send-CC: dagolden [...] cpan.org
Download (untitled) / with headers
text/plain 113b
Pushed 059791e which contains the final elements from this wishlist. @David, can you short review the doc parts?
RT-Send-CC: dagolden [...] cpan.org
Download (untitled) / with headers
text/plain 184b
@MHASH: would be cool when you fill the (junction) gap for: * all_but_one (with a much better name!) * just_n (n, code, ...) * all_but_n(n, code, ...) Please all with better names ;)


This service is sponsored and maintained by Best Practical Solutions and runs on Perl.org infrastructure.

Please report any issues with rt.cpan.org to rt-cpan-admin@bestpractical.com.