diff --git a/lib/List/Util.pm b/lib/List/Util.pm index 6066ccea..4bd5fd32 100644 --- a/lib/List/Util.pm +++ b/lib/List/Util.pm @@ -131,6 +131,16 @@ block that accumulates lengths by writing this instead as: The remaining list-reduction functions are all specialisations of this generic idea. +For functions operating specifically on numbers, non-numerical values, such as +undef and strings, are compared like core numeric operators do; namely by +treating them as zero and raising a warning in the uninitialized or numeric +categories. + +For string-specific functions undef is also compared like core string operators +do; namely by treating undef as an empty string and raising a warning in the +uninitialized category. + + =head2 any my $bool = any { BLOCK } @list; diff --git a/t/dualvar.t b/t/dualvar.t index 08dff117..3421656b 100644 --- a/t/dualvar.t +++ b/t/dualvar.t @@ -6,7 +6,7 @@ use warnings; use Scalar::Util (); use Test::More (grep { /dualvar/ } @Scalar::Util::EXPORT_FAIL) ? (skip_all => 'dualvar requires XS version') - : (tests => 41); + : (tests => 55); use Config; Scalar::Util->import('dualvar'); @@ -131,3 +131,28 @@ SKIP: { ok(isdual($ary[2]), 'Is a dualvar'); } +ok !eval { dualvar() }, "arg count gets checked"; +ok !eval { dualvar(2, "a", "meep") }, "arg count gets checked"; + +{ + my $warning; + local $SIG{__WARN__} = sub { $warning = shift }; + + my $var = dualvar(undef, undef); + like($warning, qr/Use of uninitialized value in subroutine entry/, 'undef arg warning'); + ok( isdual($var), 'Is a dualvar'); + ok( $var == undef, 'Numeric value'); + ok( $var eq undef, 'String value'); + + my $var2 = dualvar(2.2, undef); + like($warning, qr/Use of uninitialized value in subroutine entry/, 'undef arg warning'); + ok( isdual($var2), 'Is a dualvar'); + ok( $var2 == 2.2, 'Numeric value'); + ok( $var2 eq undef, 'String value'); + + my $var3 = dualvar(undef, "string"); + like($warning, qr/Use of uninitialized value in subroutine entry/, 'undef arg warning'); + ok( isdual($var3), 'Is a dualvar'); + ok( $var3 == undef, 'Numeric value'); + ok( $var3 eq "string", 'String value'); +} diff --git a/t/isvstring.t b/t/isvstring.t index 9d345aa2..5e666f2f 100644 --- a/t/isvstring.t +++ b/t/isvstring.t @@ -7,7 +7,7 @@ $|=1; use Scalar::Util (); use Test::More (grep { /isvstring/ } @Scalar::Util::EXPORT_FAIL) ? (skip_all => 'isvstring requires XS version') - : (tests => 3); + : (tests => 7); Scalar::Util->import(qw[isvstring]); @@ -19,5 +19,13 @@ ok( isvstring($vs), 'isvstring'); my $sv = "1.0"; ok( !isvstring($sv), 'not isvstring'); +ok !eval { isvstring() }, "arg count gets checked"; +ok !eval { isvstring(2, "a") }, "arg count gets checked"; +{ + my $warning; + local $SIG{__WARN__} = sub { $warning = shift }; + ok(!isvstring(undef), 'undef is no ivstring'); + is($warning, undef, 'no undef arg warning'); +} diff --git a/t/max.t b/t/max.t index adb222b1..d8574724 100644 --- a/t/max.t +++ b/t/max.t @@ -3,7 +3,7 @@ use strict; use warnings; -use Test::More tests => 10; +use Test::More tests => 18; use List::Util qw(max); my $v; @@ -63,3 +63,20 @@ is($v, $v1, 'bigint and normal int'); $v = max(1, 2, $v1, 3); is($v, $v1, 'bigint and normal int'); +{ + my $warning; + local $SIG{__WARN__} = sub { $warning = shift }; + + is(max(), undef, 'no arg'); + is($warning, undef, 'no args no warning'); + + is(max(undef), undef, 'undef arg'); + like($warning, qr/Use of uninitialized value in subroutine entry/, 'undef arg warning'); + + is(max("a"), "a", 'non-numeric arg'); + like($warning, qr/Argument "a" isn't numeric in subroutine entry/, 'non-numeric arg warning'); + + is(max(2, undef), 2, 'undef is smaller than 2'); + + is(max(-2, undef), undef, 'undef is larger than -2'); +} diff --git a/t/maxstr.t b/t/maxstr.t index ac135a17..ab88646e 100644 --- a/t/maxstr.t +++ b/t/maxstr.t @@ -3,7 +3,7 @@ use strict; use warnings; -use Test::More tests => 5; +use Test::More tests => 12; use List::Util qw(maxstr); my $v; @@ -23,3 +23,19 @@ my @a = map { pack("u", pack("C*",map { int(rand(256))} (0..int(rand(10) + 2)))) my @b = sort { $a cmp $b } @a; $v = maxstr(@a); is($v, $b[-1], 'random ordered'); + +{ + my $warning; + local $SIG{__WARN__} = sub { $warning = shift }; + + is(maxstr(), undef, 'no arg'); + is($warning, undef, 'no args no warning'); + + is(maxstr(undef), undef, 'single undef arg'); + is($warning, undef, 'no single undef arg warning'); # XXX + + is(maxstr(undef, undef), undef, 'two undef arg'); + like($warning, qr/Use of uninitialized value in subroutine entry/, 'two undef arg warning'); + + is(maxstr("a", undef), "a", 'undef is not gt anything'); +} diff --git a/t/min.t b/t/min.t index 2b85b414..ee532d10 100644 --- a/t/min.t +++ b/t/min.t @@ -3,7 +3,7 @@ use strict; use warnings; -use Test::More tests => 22; +use Test::More tests => 30; use List::Util qw(min); my $v; @@ -80,3 +80,21 @@ is($v, 1, 'bigint and normal int'); ok( $max == $size-1, "max(\$#list, 0) == $size-1"); } } + +{ + my $warning; + local $SIG{__WARN__} = sub { $warning = shift }; + + is(min(), undef, 'no arg'); + is($warning, undef, 'no args no warning'); + + is(min(undef), undef, 'undef arg'); + like($warning, qr/Use of uninitialized value in subroutine entry/, 'undef arg warning'); + + is(min("a"), "a", 'non-numeric arg'); + like($warning, qr/Argument "a" isn't numeric in subroutine entry/, 'non-numeric arg warning'); + + is(min(2, undef), undef, 'undef is smaller than 2'); + + is(min(-2, undef), -2, 'undef is larger than -2'); +} diff --git a/t/minstr.t b/t/minstr.t index ee6f2b72..15d7222c 100644 --- a/t/minstr.t +++ b/t/minstr.t @@ -3,7 +3,7 @@ use strict; use warnings; -use Test::More tests => 5; +use Test::More tests => 12; use List::Util qw(minstr); my $v; @@ -23,3 +23,19 @@ my @a = map { pack("u", pack("C*",map { int(rand(256))} (0..int(rand(10) + 2)))) my @b = sort { $a cmp $b } @a; $v = minstr(@a); is($v, $b[0], 'random ordered'); + +{ + my $warning; + local $SIG{__WARN__} = sub { $warning = shift }; + + is(minstr(), undef, 'no arg'); + is($warning, undef, 'no args no warning'); + + is(minstr(undef), undef, 'single undef arg'); + is($warning, undef, 'no single undef arg warning'); # XXX + + is(minstr(undef, undef), undef, 'two undef arg'); + like($warning, qr/Use of uninitialized value in subroutine entry/, 'two undef arg warning'); + + is(minstr("a", undef), undef, 'undef is lt anything'); +} diff --git a/t/product.t b/t/product.t index 1aad8775..9c67e0eb 100644 --- a/t/product.t +++ b/t/product.t @@ -3,7 +3,7 @@ use strict; use warnings; -use Test::More tests => 25; +use Test::More tests => 30; use Config; use List::Util qw(product); @@ -125,3 +125,16 @@ SKIP: { cmp_ok($t, '>', (1<<61), 'max*max*8'); # may be an NV } + +{ + my $warning; + local $SIG{__WARN__} = sub { $warning = shift }; + + is(product(undef), 0, 'undef arg'); + like($warning, qr/Use of uninitialized value in subroutine entry/, 'undef arg warning'); + + is(product("a"), 0, 'non-numeric arg'); + like($warning, qr/Argument "a" isn't numeric in subroutine entry/, 'non-numeric arg warning'); + + is(product(undef, 1), 0, 'undef is 0'); +} diff --git a/t/prototype.t b/t/prototype.t index 32549a8e..9a997720 100644 --- a/t/prototype.t +++ b/t/prototype.t @@ -4,7 +4,7 @@ use strict; use warnings; use Sub::Util qw( prototype set_prototype ); -use Test::More tests => 13; +use Test::More tests => 17; sub f { } is( prototype('f'), undef, 'no prototype'); @@ -38,3 +38,16 @@ is( prototype('f_decl'), '$$$$', 'forward declaration'); set_prototype('\%', \&f_decl); is( prototype('f_decl'), '\%', 'change forward declaration'); + +{ + my $warning; + local $SIG{__WARN__} = sub { $warning = shift }; + + my @c = prototype(); + is( scalar @c, 0, 'no arg results in empty list'); # XXX + like($warning, qr/Use of uninitialized value in subroutine prototype/, 'no arg results in undef arg warning'); + undef $warning; + + is( prototype(undef), undef, 'undef arg'); + like($warning, qr/Use of uninitialized value in subroutine prototype/, 'undef arg warning'); +} diff --git a/t/readonly.t b/t/readonly.t index c8e19ff4..4c685577 100644 --- a/t/readonly.t +++ b/t/readonly.t @@ -4,7 +4,7 @@ use strict; use warnings; use Scalar::Util qw(readonly); -use Test::More tests => 11; +use Test::More tests => 13; ok( readonly(1), 'number constant'); @@ -41,3 +41,11 @@ $var = 123; ok( try ("abc"), 'reference a constant in a sub'); } ok( !try ($var), 'reference a non-constant in a sub'); + +{ + my $warning; + local $SIG{__WARN__} = sub { $warning = shift }; + + ok(readonly(undef), 'undef is readonly'); + is($warning, undef, 'no warning on undef'); +} diff --git a/t/reftype.t b/t/reftype.t index a40e4149..3a7af2ff 100644 --- a/t/reftype.t +++ b/t/reftype.t @@ -3,7 +3,7 @@ use strict; use warnings; -use Test::More tests => 32; +use Test::More tests => 34; use Scalar::Util qw(reftype); use vars qw(*F); @@ -45,6 +45,14 @@ foreach my $test (@test) { is( reftype($what), $type, $n); } +{ + my $warning; + local $SIG{__WARN__} = sub { $warning = shift }; + + is(reftype(undef), undef, 'undef arg'); + is($warning, undef, 'no undef arg warning'); # XXX +} + package MyTie; sub TIEHANDLE { bless {} } diff --git a/t/sum.t b/t/sum.t index 4639a8ac..d05a0cea 100644 --- a/t/sum.t +++ b/t/sum.t @@ -3,7 +3,7 @@ use strict; use warnings; -use Test::More tests => 17; +use Test::More tests => 23; use Config; use List::Util qw(sum); @@ -38,6 +38,20 @@ my $thr = Foo->new(3); $v = sum($one,$two,$thr); is($v, 6, 'overload'); +{ + my $warning; + local $SIG{__WARN__} = sub { $warning = shift }; + + is(sum(undef), 0, 'undef arg'); + like($warning, qr/Use of uninitialized value in subroutine entry/, 'undef arg warning'); + + is(sum("a"), 0, 'non-numeric arg'); + like($warning, qr/Argument "a" isn't numeric in subroutine entry/, 'non-numeric arg warning'); + + is(sum(2, undef), 2, 'undef gets forced to 0'); + + is(sum(2, "a"), 2, 'strings get forced to 0'); +} { package Foo; diff --git a/t/sum0.t b/t/sum0.t index 6b087417..04632976 100644 --- a/t/sum0.t +++ b/t/sum0.t @@ -3,7 +3,7 @@ use strict; use warnings; -use Test::More tests => 3; +use Test::More tests => 9; use List::Util qw( sum0 ); @@ -15,3 +15,18 @@ is( $v, 9, 'one arg' ); $v = sum0(1,2,3,4); is( $v, 10, '4 args'); + +{ + my $warning; + local $SIG{__WARN__} = sub { $warning = shift }; + + is(sum0(undef), 0, 'undef arg'); + like($warning, qr/Use of uninitialized value in subroutine entry/, 'undef arg warning'); + + is(sum0("a"), 0, 'non-numeric arg'); + like($warning, qr/Argument "a" isn't numeric in subroutine entry/, 'non-numeric arg warning'); + + is(sum0(2, undef), 2, 'undef gets forced to 0'); + + is(sum0(2, "a"), 2, 'strings get forced to 0'); +} diff --git a/t/tainted.t b/t/tainted.t index fb83c86c..81844158 100644 --- a/t/tainted.t +++ b/t/tainted.t @@ -3,7 +3,7 @@ use strict; use warnings; -use Test::More tests => 5; +use Test::More tests => 7; use Scalar::Util qw(tainted); @@ -26,3 +26,11 @@ ok( tainted($var), 'copy of interpreter variable'); tie my $tiedvar, 'Tainted'; ok( tainted($tiedvar), 'for magic variables'); + +{ + my $warning; + local $SIG{__WARN__} = sub { $warning = shift }; + + ok(!tainted(undef), 'undef is not tainted'); + is($warning, undef, 'no undef arg warning'); +} diff --git a/t/uniq.t b/t/uniq.t index 5a6925d1..3596d1db 100644 --- a/t/uniq.t +++ b/t/uniq.t @@ -3,7 +3,7 @@ use strict; use warnings; -use Test::More tests => 30; +use Test::More tests => 33; use List::Util qw( uniqnum uniqstr uniq ); use Tie::Array; @@ -211,3 +211,13 @@ is( scalar( uniqstr qw( a b c d a b e ) ), 5, 'uniqstr() in scalar context' ); 'uniq uniquifies mixed numbers and strings correctly in a tied array' ); } + +{ + my $warning; + local $SIG{__WARN__} = sub { $warning = shift }; + + my @set = uniqnum("a"); + is(@set, 1, 'string arg'); + is($set[0], "a", 'string arg'); + is($warning, undef, 'no string arg warning'); # XXX +}