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
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' );
