dslinux/user/perl/ext/List/Util/t 00version.t blessed.t dualvar.t first.t isvstring.t lln.t max.t maxstr.t min.t minstr.t openhan.t p_blessed.t p_first.t p_lln.t p_max.t p_maxstr.t p_min.t p_minstr.t p_openhan.t p_readonly.t p_reduce.t p_refaddr.t p_reftype.t p_shuffle.t p_sum.t p_tainted.t proto.t readonly.t reduce.t refaddr.t reftype.t shuffle.t sum.t tainted.t weak.t
cayenne
dslinux_cayenne at user.in-berlin.de
Tue Dec 5 05:26:52 CET 2006
Update of /cvsroot/dslinux/dslinux/user/perl/ext/List/Util/t
In directory antilope:/tmp/cvs-serv7729/ext/List/Util/t
Added Files:
00version.t blessed.t dualvar.t first.t isvstring.t lln.t
max.t maxstr.t min.t minstr.t openhan.t p_blessed.t p_first.t
p_lln.t p_max.t p_maxstr.t p_min.t p_minstr.t p_openhan.t
p_readonly.t p_reduce.t p_refaddr.t p_reftype.t p_shuffle.t
p_sum.t p_tainted.t proto.t readonly.t reduce.t refaddr.t
reftype.t shuffle.t sum.t tainted.t weak.t
Log Message:
Adding fresh perl source to HEAD to branch from
--- NEW FILE: p_minstr.t ---
#!./perl
# force perl-only version to be tested
$List::Util::TESTING_PERL_ONLY = $List::Util::TESTING_PERL_ONLY = 1;
(my $f = __FILE__) =~ s/p_//;
do $f;
--- NEW FILE: p_shuffle.t ---
#!./perl
# force perl-only version to be tested
$List::Util::TESTING_PERL_ONLY = $List::Util::TESTING_PERL_ONLY = 1;
(my $f = __FILE__) =~ s/p_//;
do $f;
--- NEW FILE: shuffle.t ---
#!./perl
BEGIN {
unless (-d 'blib') {
chdir 't' if -d 't';
@INC = '../lib';
require Config; import Config;
keys %Config; # Silence warning
if ($Config{extensions} !~ /\bList\/Util\b/) {
print "1..0 # Skip: List::Util was not built\n";
exit 0;
}
}
}
use Test::More tests => 6;
use List::Util qw(shuffle);
my @r;
@r = shuffle();
ok( !@r, 'no args');
@r = shuffle(9);
is( 0+ at r, 1, '1 in 1 out');
is( $r[0], 9, 'one arg');
my @in = 1..100;
@r = shuffle(@in);
is( 0+ at r, 0+ at in, 'arg count');
isnt( "@r", "@in", 'result different to args');
my @s = sort { $a <=> $b } @r;
is( "@in", "@s", 'values');
--- NEW FILE: reftype.t ---
#!./perl
BEGIN {
unless (-d 'blib') {
chdir 't' if -d 't';
@INC = '../lib';
require Config; import Config;
keys %Config; # Silence warning
if ($Config{extensions} !~ /\bList\/Util\b/) {
print "1..0 # Skip: List::Util was not built\n";
exit 0;
}
}
}
use Test::More tests => 23;
use Scalar::Util qw(reftype);
use vars qw($t $y $x *F);
use Symbol qw(gensym);
# Ensure we do not trigger and tied methods
tie *F, 'MyTie';
@test = (
[ undef, 1, 'number' ],
[ undef, 'A', 'string' ],
[ HASH => {}, 'HASH ref' ],
[ ARRAY => [], 'ARRAY ref' ],
[ SCALAR => \$t, 'SCALAR ref' ],
[ REF => \(\$t), 'REF ref' ],
[ GLOB => \*F, 'tied GLOB ref' ],
[ GLOB => gensym, 'GLOB ref' ],
[ CODE => sub {}, 'CODE ref' ],
# [ IO => *STDIN{IO} ] the internal sv_reftype returns UNKNOWN
);
foreach $test (@test) {
my($type,$what, $n) = @$test;
is( reftype($what), $type, $n);
next unless ref($what);
bless $what, "ABC";
is( reftype($what), $type, $n);
bless $what, "0";
is( reftype($what), $type, $n);
}
package MyTie;
sub TIEHANDLE { bless {} }
sub DESTROY {}
sub AUTOLOAD {
warn "$AUTOLOAD called";
exit 1; # May be in an eval
}
--- NEW FILE: p_readonly.t ---
#!./perl
# force perl-only version to be tested
$List::Util::TESTING_PERL_ONLY = $List::Util::TESTING_PERL_ONLY = 1;
(my $f = __FILE__) =~ s/p_//;
do $f;
--- NEW FILE: sum.t ---
#!./perl
BEGIN {
unless (-d 'blib') {
chdir 't' if -d 't';
@INC = '../lib';
require Config; import Config;
keys %Config; # Silence warning
if ($Config{extensions} !~ /\bList\/Util\b/) {
print "1..0 # Skip: List::Util was not built\n";
exit 0;
}
}
}
use Test::More tests => 6;
use List::Util qw(sum);
my $v = sum;
is( $v, undef, 'no args');
$v = sum(9);
is( $v, 9, 'one arg');
$v = sum(1,2,3,4);
is( $v, 10, '4 args');
$v = sum(-1);
is( $v, -1, 'one -1');
my $x = -3;
$v = sum($x, 3);
is( $v, 0, 'variable arg');
$v = sum(-3.5,3);
is( $v, -0.5, 'real numbers');
--- NEW FILE: weak.t ---
#!./perl
BEGIN {
unless (-d 'blib') {
chdir 't' if -d 't';
@INC = '../lib';
require Config; import Config;
keys %Config; # Silence warning
if ($Config{extensions} !~ /\bList\/Util\b/) {
print "1..0 # Skip: List::Util was not built\n";
exit 0;
}
}
}
use Scalar::Util ();
use Test::More (grep { /weaken/ } @Scalar::Util::EXPORT_FAIL)
? (skip_all => 'weaken requires XS version')
: (tests => 22);
if (0) {
require Devel::Peek;
Devel::Peek->import('Dump');
}
else {
*Dump = sub {};
}
Scalar::Util->import(qw(weaken isweak));
if(1) {
my ($y,$z);
#
# Case 1: two references, one is weakened, the other is then undef'ed.
#
{
my $x = "foo";
$y = \$x;
$z = \$x;
}
print "# START\n";
Dump($y); Dump($z);
ok( ref($y) and ref($z));
print "# WEAK:\n";
weaken($y);
Dump($y); Dump($z);
ok( ref($y) and ref($z));
print "# UNDZ:\n";
undef($z);
Dump($y); Dump($z);
ok( not (defined($y) and defined($z)) );
print "# UNDY:\n";
undef($y);
Dump($y); Dump($z);
ok( not (defined($y) and defined($z)) );
print "# FIN:\n";
Dump($y); Dump($z);
#
# Case 2: one reference, which is weakened
#
print "# CASE 2:\n";
{
my $x = "foo";
$y = \$x;
}
ok( ref($y) );
print "# BW: \n";
Dump($y);
weaken($y);
print "# AW: \n";
Dump($y);
ok( not defined $y );
print "# EXITBLOCK\n";
}
#
# Case 3: a circular structure
#
$flag = 0;
{
my $y = bless {}, Dest;
Dump($y);
print "# 1: $y\n";
$y->{Self} = $y;
Dump($y);
print "# 2: $y\n";
$y->{Flag} = \$flag;
print "# 3: $y\n";
weaken($y->{Self});
print "# WKED\n";
ok( ref($y) );
print "# VALS: HASH ",$y," SELF ",\$y->{Self}," Y ",\$y,
" FLAG: ",\$y->{Flag},"\n";
print "# VPRINT\n";
}
print "# OUT $flag\n";
ok( $flag == 1 );
print "# AFTER\n";
undef $flag;
print "# FLAGU\n";
#
# Case 4: a more complicated circular structure
#
$flag = 0;
{
my $y = bless {}, Dest;
my $x = bless {}, Dest;
$x->{Ref} = $y;
$y->{Ref} = $x;
$x->{Flag} = \$flag;
$y->{Flag} = \$flag;
weaken($x->{Ref});
}
ok( $flag == 2 );
#
# Case 5: deleting a weakref before the other one
#
{
my $x = "foo";
$y = \$x;
$z = \$x;
}
print "# CASE5\n";
Dump($y);
weaken($y);
Dump($y);
undef($y);
ok( not defined $y);
ok( ref($z) );
#
# Case 6: test isweakref
#
$a = 5;
ok(!isweak($a));
$b = \$a;
ok(!isweak($b));
weaken($b);
ok(isweak($b));
$b = \$a;
ok(!isweak($b));
$x = {};
weaken($x->{Y} = \$a);
ok(isweak($x->{Y}));
ok(!isweak($x->{Z}));
#
# Case 7: test weaken on a read only ref
#
SKIP: {
# Doesn't work for older perls, see bug [perl #24506]
skip("Test does not work with perl < 5.8.3", 5) if $] < 5.008003;
$a = eval '\"hello"';
ok(ref($a)) or print "# didn't get a ref from eval\n";
$b = $a;
eval{weaken($b)};
# we didn't die
ok($@ eq "") or print "# died with $@\n";
ok(isweak($b));
ok($$b eq "hello") or print "# b is '$$b'\n";
$a="";
ok(not $b) or print "# b didn't go away\n";
}
package Dest;
sub DESTROY {
print "# INCFLAG\n";
${$_[0]{Flag}} ++;
}
--- NEW FILE: refaddr.t ---
#!./perl
BEGIN {
unless (-d 'blib') {
chdir 't' if -d 't';
@INC = '../lib';
require Config; import Config;
keys %Config; # Silence warning
if ($Config{extensions} !~ /\bList\/Util\b/) {
print "1..0 # Skip: List::Util was not built\n";
exit 0;
}
}
}
use Test::More tests => 29;
use Scalar::Util qw(refaddr);
use vars qw($t $y $x *F $v $r);
use Symbol qw(gensym);
# Ensure we do not trigger and tied methods
tie *F, 'MyTie';
my $i = 1;
foreach $v (undef, 10, 'string') {
is(refaddr($v), undef, "not " . (defined($v) ? "'$v'" : "undef"));
}
foreach $r ({}, \$t, [], \*F, sub {}) {
my $n = "$r";
$n =~ /0x(\w+)/;
my $addr = do { local $^W; hex $1 };
my $before = ref($r);
is( refaddr($r), $addr, $n);
is( ref($r), $before, $n);
my $obj = bless $r, 'FooBar';
is( refaddr($r), $addr, "blessed with overload $n");
is( ref($r), 'FooBar', $n);
}
{
my $z = '77';
my $y = \$z;
my $a = '78';
my $b = \$a;
tie my %x, 'Hash3', {};
$x{$y} = 22;
$x{$b} = 23;
my $xy = $x{$y};
my $xb = $x{$b};
ok(ref($x{$y}));
ok(ref($x{$b}));
ok(refaddr($xy) == refaddr($y));
ok(refaddr($xb) == refaddr($b));
ok(refaddr($x{$y}));
ok(refaddr($x{$b}));
}
package FooBar;
use overload '0+' => sub { 10 },
'+' => sub { 10 + $_[1] };
package MyTie;
sub TIEHANDLE { bless {} }
sub DESTROY {}
sub AUTOLOAD {
warn "$AUTOLOAD called";
exit 1; # May be in an eval
}
package Hash3;
use Scalar::Util qw(refaddr);
sub TIEHASH
{
my $pkg = shift;
return bless [ @_ ], $pkg;
}
sub FETCH
{
my $self = shift;
my $key = shift;
my ($underlying) = @$self;
return $underlying->{refaddr($key)};
}
sub STORE
{
my $self = shift;
my $key = shift;
my $value = shift;
my ($underlying) = @$self;
return ($underlying->{refaddr($key)} = $key);
}
--- NEW FILE: 00version.t ---
#!./perl
BEGIN {
unless (-d 'blib') {
chdir 't' if -d 't';
@INC = '../lib';
require Config; import Config;
keys %Config; # Silence warning
if ($Config{extensions} !~ /\bList\/Util\b/) {
print "1..0 # Skip: List::Util was not built\n";
exit 0;
}
}
}
use Scalar::Util ();
use List::Util ();
use Test::More tests => 1;
is( $Scalar::Util::VERSION, $List::Util::VERSION, "VERSION mismatch");
--- NEW FILE: p_maxstr.t ---
#!./perl
# force perl-only version to be tested
$List::Util::TESTING_PERL_ONLY = $List::Util::TESTING_PERL_ONLY = 1;
(my $f = __FILE__) =~ s/p_//;
do $f;
--- NEW FILE: p_sum.t ---
#!./perl
# force perl-only version to be tested
$List::Util::TESTING_PERL_ONLY = $List::Util::TESTING_PERL_ONLY = 1;
(my $f = __FILE__) =~ s/p_//;
do $f;
--- NEW FILE: p_refaddr.t ---
#!./perl
# force perl-only version to be tested
$List::Util::TESTING_PERL_ONLY = $List::Util::TESTING_PERL_ONLY = 1;
(my $f = __FILE__) =~ s/p_//;
do $f;
--- NEW FILE: isvstring.t ---
#!./perl
BEGIN {
unless (-d 'blib') {
chdir 't' if -d 't';
@INC = '../lib';
require Config; import Config;
keys %Config; # Silence warning
if ($Config{extensions} !~ /\bList\/Util\b/) {
print "1..0 # Skip: List::Util was not built\n";
exit 0;
}
}
}
$|=1;
use Scalar::Util ();
use Test::More (grep { /isvstring/ } @Scalar::Util::EXPORT_FAIL)
? (skip_all => 'isvstring requires XS version')
: (tests => 3);
Scalar::Util->import(qw[isvstring]);
$vs = ord("A") == 193 ? 241.75.240 : 49.46.48;
ok( $vs == "1.0", 'dotted num');
ok( isvstring($vs), 'isvstring');
$sv = "1.0";
ok( !isvstring($sv), 'not isvstring');
--- NEW FILE: max.t ---
#!./perl
BEGIN {
unless (-d 'blib') {
chdir 't' if -d 't';
@INC = '../lib';
require Config; import Config;
keys %Config; # Silence warning
if ($Config{extensions} !~ /\bList\/Util\b/) {
print "1..0 # Skip: List::Util was not built\n";
exit 0;
}
}
}
use strict;
use Test::More tests => 5;
use List::Util qw(max);
my $v;
ok(defined &max, 'defined');
$v = max(1);
is($v, 1, 'single arg');
$v = max (1,2);
is($v, 2, '2-arg ordered');
$v = max(2,1);
is($v, 2, '2-arg reverse ordered');
my @a = map { rand() } 1 .. 20;
my @b = sort { $a <=> $b } @a;
$v = max(@a);
is($v, $b[-1], '20-arg random order');
--- NEW FILE: openhan.t ---
#!./perl
BEGIN {
unless (-d 'blib') {
chdir 't' if -d 't';
@INC = '../lib';
require Config; import Config;
keys %Config; # Silence warning
if ($Config{extensions} !~ /\bList\/Util\b/) {
print "1..0 # Skip: List::Util was not built\n";
exit 0;
}
}
}
use strict;
use vars qw(*CLOSED);
use Test::More tests => 4;
use Scalar::Util qw(openhandle);
ok(defined &openhandle, 'defined');
my $fh = \*STDERR;
is(openhandle($fh), $fh, 'STDERR');
is(fileno(openhandle(*STDERR)), fileno(STDERR), 'fileno(STDERR)');
is(openhandle(*CLOSED), undef, 'closed');
--- NEW FILE: p_lln.t ---
#!./perl
# force perl-only version to be tested
$List::Util::TESTING_PERL_ONLY = $List::Util::TESTING_PERL_ONLY = 1;
(my $f = __FILE__) =~ s/p_//;
do $f;
--- NEW FILE: proto.t ---
#!./perl
BEGIN {
unless (-d 'blib') {
chdir 't' if -d 't';
@INC = '../lib';
require Config; import Config;
keys %Config; # Silence warning
if ($Config{extensions} !~ /\bList\/Util\b/) {
print "1..0 # Skip: List::Util was not built\n";
exit 0;
}
}
}
use Scalar::Util ();
use Test::More (grep { /set_prototype/ } @Scalar::Util::EXPORT_FAIL)
? (skip_all => 'set_prototype requires XS version')
: (tests => 13);
Scalar::Util->import('set_prototype');
sub f { }
is( prototype('f'), undef, 'no prototype');
$r = set_prototype(\&f,'$');
is( prototype('f'), '$', 'set prototype');
is( $r, \&f, 'return value');
set_prototype(\&f,undef);
is( prototype('f'), undef, 'remove prototype');
set_prototype(\&f,'');
is( prototype('f'), '', 'empty prototype');
sub g (@) { }
is( prototype('g'), '@', '@ prototype');
set_prototype(\&g,undef);
is( prototype('g'), undef, 'remove prototype');
sub stub;
is( prototype('stub'), undef, 'non existing sub');
set_prototype(\&stub,'$$$');
is( prototype('stub'), '$$$', 'change non existing sub');
sub f_decl ($$$$);
is( prototype('f_decl'), '$$$$', 'forward declaration');
set_prototype(\&f_decl,'\%');
is( prototype('f_decl'), '\%', 'change forward declaration');
eval { &set_prototype( 'f', '' ); };
print "not " unless
ok($@ =~ /^set_prototype: not a reference/, 'not a reference');
eval { &set_prototype( \'f', '' ); };
ok($@ =~ /^set_prototype: not a subroutine reference/, 'not a sub reference');
--- NEW FILE: p_tainted.t ---
#!./perl -T
# force perl-only version to be tested
$List::Util::TESTING_PERL_ONLY = $List::Util::TESTING_PERL_ONLY = 1;
(my $f = __FILE__) =~ s/p_//;
do "./$f";
--- NEW FILE: first.t ---
#!./perl
BEGIN {
unless (-d 'blib') {
chdir 't' if -d 't';
@INC = '../lib';
require Config; import Config;
keys %Config; # Silence warning
if ($Config{extensions} !~ /\bList\/Util\b/) {
print "1..0 # Skip: List::Util was not built\n";
exit 0;
}
}
}
use List::Util qw(first);
use Test::More;
plan tests => ($::PERL_ONLY ? 15 : 17);
my $v;
ok(defined &first, 'defined');
$v = first { 8 == ($_ - 1) } 9,4,5,6;
is($v, 9, 'one more than 8');
$v = first { 0 } 1,2,3,4;
is($v, undef, 'none match');
$v = first { 0 };
is($v, undef, 'no args');
$v = first { $_->[1] le "e" and "e" le $_->[2] }
[qw(a b c)], [qw(d e f)], [qw(g h i)];
is_deeply($v, [qw(d e f)], 'reference args');
# Check that eval{} inside the block works correctly
my $i = 0;
$v = first { eval { die }; ($i == 5, $i = $_)[0] } 0,1,2,3,4,5,5;
is($v, 5, 'use of eval');
$v = eval { first { die if $_ } 0,0,1 };
is($v, undef, 'use of die');
sub foobar { first { !defined(wantarray) || wantarray } "not ","not ","not " }
($v) = foobar();
is($v, undef, 'wantarray');
# Can we leave the sub with 'return'?
$v = first {return ($_>6)} 2,4,6,12;
is($v, 12, 'return');
# ... even in a loop?
$v = first {while(1) {return ($_>6)} } 2,4,6,12;
is($v, 12, 'return from loop');
# Does it work from another package?
{ package Foo;
::is(List::Util::first(sub{$_>4},(1..4,24)), 24, 'other package');
}
# Can we undefine a first sub while it's running?
sub self_immolate {undef &self_immolate; 1}
eval { $v = first \&self_immolate, 1,2; };
like($@, qr/^Can't undef active subroutine/, "undef active sub");
# Redefining an active sub should not fail, but whether the
# redefinition takes effect immediately depends on whether we're
# running the Perl or XS implementation.
sub self_updating { local $^W; *self_updating = sub{1} ;1}
eval { $v = first \&self_updating, 1,2; };
is($@, '', 'redefine self');
{ my $failed = 0;
sub rec { my $n = shift;
if (!defined($n)) { # No arg means we're being called by first()
return 1; }
if ($n<5) { rec($n+1); }
else { $v = first \&rec, 1,2; }
$failed = 1 if !defined $n;
}
rec(1);
ok(!$failed, 'from active sub');
}
# Calling a sub from first should leave its refcount unchanged.
SKIP: {
skip("No Internals::SvREFCNT", 1) if !defined &Internals::SvREFCNT;
sub huge {$_>1E6}
my $refcnt = &Internals::SvREFCNT(\&huge);
$v = first \&huge, 1..6;
is(&Internals::SvREFCNT(\&huge), $refcnt, "Refcount unchanged");
}
# The remainder of the tests are only relevant for the XS
# implementation. The Perl-only implementation behaves differently
# (and more flexibly) in a way that we can't emulate from XS.
if (!$::PERL_ONLY) { SKIP: {
$List::Util::REAL_MULTICALL ||= 0; # Avoid use only once
skip("Poor man's MULTICALL can't cope", 2)
if !$List::Util::REAL_MULTICALL;
# Can we goto a label from the 'first' sub?
eval {()=first{goto foo} 1,2; foo: 1};
like($@, qr/^Can't "goto" out of a pseudo block/, "goto label");
# Can we goto a subroutine?
eval {()=first{goto sub{}} 1,2;};
like($@, qr/^Can't goto subroutine from a sort sub/, "goto sub");
} }
--- NEW FILE: lln.t ---
#!/usr/bin/perl -w
BEGIN {
unless (-d 'blib') {
chdir 't' if -d 't';
@INC = '../lib';
require Config; import Config;
keys %Config; # Silence warning
if ($Config{extensions} !~ /\bList\/Util\b/) {
print "1..0 # Skip: List::Util was not built\n";
exit 0;
}
}
}
use strict;
use Test::More tests => 16;
use Scalar::Util qw(looks_like_number);
foreach my $num (qw(1 -1 +1 1.0 +1.0 -1.0 -1.0e-12)) {
ok(looks_like_number($num), "'$num'");
}
is(!!looks_like_number("Inf"), $] >= 5.006001, 'Inf');
is(!!looks_like_number("Infinity"), $] >= 5.008, 'Infinity');
is(!!looks_like_number("NaN"), $] >= 5.008, 'NaN');
is(!!looks_like_number("foo"), '', 'foo');
is(!!looks_like_number(undef), '', 'undef');
is(!!looks_like_number({}), '', 'HASH Ref');
is(!!looks_like_number([]), '', 'ARRAY Ref');
use Math::BigInt;
my $bi = Math::BigInt->new('1234567890');
is(!!looks_like_number($bi), '', 'Math::BigInt');
is(!!looks_like_number("$bi"), 1, 'Stringified Math::BigInt');
# We should copy some of perl core tests like t/base/num.t here
--- NEW FILE: min.t ---
#!./perl
BEGIN {
unless (-d 'blib') {
chdir 't' if -d 't';
@INC = '../lib';
require Config; import Config;
keys %Config; # Silence warning
if ($Config{extensions} !~ /\bList\/Util\b/) {
print "1..0 # Skip: List::Util was not built\n";
exit 0;
}
}
}
use strict;
use Test::More tests => 5;
use List::Util qw(min);
my $v;
ok(defined &min, 'defined');
$v = min(9);
is($v, 9, 'single arg');
$v = min (1,2);
is($v, 1, '2-arg ordered');
$v = min(2,1);
is($v, 1, '2-arg reverse ordered');
my @a = map { rand() } 1 .. 20;
my @b = sort { $a <=> $b } @a;
$v = min(@a);
is($v, $b[0], '20-arg random order');
--- NEW FILE: p_min.t ---
#!./perl
# force perl-only version to be tested
$List::Util::TESTING_PERL_ONLY = $List::Util::TESTING_PERL_ONLY = 1;
(my $f = __FILE__) =~ s/p_//;
do $f;
--- NEW FILE: p_reduce.t ---
#!./perl
# force perl-only version to be tested
$List::Util::TESTING_PERL_ONLY = $List::Util::TESTING_PERL_ONLY = 1;
(my $f = __FILE__) =~ s/p_//;
$::PERL_ONLY = $::PERL_ONLY = 1; # Mustn't use it only once!
do $f;
--- NEW FILE: p_reftype.t ---
#!./perl
# force perl-only version to be tested
$List::Util::TESTING_PERL_ONLY = $List::Util::TESTING_PERL_ONLY = 1;
(my $f = __FILE__) =~ s/p_//;
do $f;
--- NEW FILE: p_max.t ---
#!./perl
# force perl-only version to be tested
$List::Util::TESTING_PERL_ONLY = $List::Util::TESTING_PERL_ONLY = 1;
(my $f = __FILE__) =~ s/p_//;
do $f;
--- NEW FILE: tainted.t ---
#!./perl -T
BEGIN {
unless (-d 'blib') {
chdir 't' if -d 't';
@INC = '../lib';
require Config; import Config;
keys %Config; # Silence warning
if ($Config{extensions} !~ /\bList\/Util\b/) {
print "1..0 # Skip: List::Util was not built\n";
exit 0;
}
}
elsif(!grep {/blib/} @INC) {
unshift(@INC, qw(./inc ./blib/arch ./blib/lib));
}
}
use Test::More tests => 4;
use Scalar::Util qw(tainted);
ok( !tainted(1), 'constant number');
my $var = 2;
ok( !tainted($var), 'known variable');
my $key = (keys %ENV)[0];
ok( tainted($ENV{$key}), 'environment variable');
$var = $ENV{$key};
ok( tainted($var), 'copy of environment variable');
--- NEW FILE: p_blessed.t ---
#!./perl
# force perl-only version to be tested
$List::Util::TESTING_PERL_ONLY = $List::Util::TESTING_PERL_ONLY = 1;
(my $f = __FILE__) =~ s/p_//;
do $f;
--- NEW FILE: minstr.t ---
#!./perl
BEGIN {
unless (-d 'blib') {
chdir 't' if -d 't';
@INC = '../lib';
require Config; import Config;
keys %Config; # Silence warning
if ($Config{extensions} !~ /\bList\/Util\b/) {
print "1..0 # Skip: List::Util was not built\n";
exit 0;
}
}
}
use strict;
use Test::More tests => 5;
use List::Util qw(minstr);
my $v;
ok(defined &minstr, 'defined');
$v = minstr('a');
is($v, 'a', 'single arg');
$v = minstr('a','b');
is($v, 'a', '2-arg ordered');
$v = minstr('B','A');
is($v, 'A', '2-arg reverse ordered');
my @a = map { pack("u", pack("C*",map { int(rand(256))} (0..int(rand(10) + 2)))) } 0 .. 20;
my @b = sort { $a cmp $b } @a;
$v = minstr(@a);
is($v, $b[0], 'random ordered');
--- NEW FILE: p_openhan.t ---
#!./perl
# force perl-only version to be tested
$List::Util::TESTING_PERL_ONLY = $List::Util::TESTING_PERL_ONLY = 1;
(my $f = __FILE__) =~ s/p_//;
do $f;
--- NEW FILE: dualvar.t ---
#!./perl
BEGIN {
unless (-d 'blib') {
chdir 't' if -d 't';
@INC = '../lib';
require Config; import Config;
keys %Config; # Silence warning
if ($Config{extensions} !~ /\bList\/Util\b/) {
print "1..0 # Skip: List::Util was not built\n";
exit 0;
}
}
}
use Scalar::Util ();
use Test::More (grep { /dualvar/ } @Scalar::Util::EXPORT_FAIL)
? (skip_all => 'dualvar requires XS version')
: (tests => 11);
Scalar::Util->import('dualvar');
$var = dualvar( 2.2,"string");
ok( $var == 2.2, 'Numeric value');
ok( $var eq "string", 'String value');
$var2 = $var;
ok( $var2 == 2.2, 'copy Numeric value');
ok( $var2 eq "string", 'copy String value');
$var++;
ok( $var == 3.2, 'inc Numeric value');
ok( $var ne "string", 'inc String value');
my $numstr = "10.2";
my $numtmp = int($numstr); # use $numstr as an int
$var = dualvar($numstr, "");
ok( $var == $numstr, 'NV');
$var = dualvar(1<<31, "");
ok( $var == (1<<31), 'UV 1');
ok( $var > 0, 'UV 2');
tie my $tied, 'Tied';
$var = dualvar($tied, "ok");
ok($var == 7.5, 'Tied num');
ok($var eq 'ok', 'Tied str');
package Tied;
sub TIESCALAR { bless {} }
sub FETCH { 7.5 }
--- NEW FILE: reduce.t ---
#!./perl
BEGIN {
unless (-d 'blib') {
chdir 't' if -d 't';
@INC = '../lib';
require Config; import Config;
keys %Config; # Silence warning
if ($Config{extensions} !~ /\bList\/Util\b/) {
print "1..0 # Skip: List::Util was not built\n";
exit 0;
}
}
}
use List::Util qw(reduce min);
use Test::More;
plan tests => ($::PERL_ONLY ? 21 : 23);
my $v = reduce {};
is( $v, undef, 'no args');
$v = reduce { $a / $b } 756,3,7,4;
is( $v, 9, '4-arg divide');
$v = reduce { $a / $b } 6;
is( $v, 6, 'one arg');
@a = map { rand } 0 .. 20;
$v = reduce { $a < $b ? $a : $b } @a;
is( $v, min(@a), 'min');
@a = map { pack("C", int(rand(256))) } 0 .. 20;
$v = reduce { $a . $b } @a;
is( $v, join("", at a), 'concat');
sub add {
my($aa, $bb) = @_;
return $aa + $bb;
}
$v = reduce { my $t="$a $b\n"; 0+add($a, $b) } 3, 2, 1;
is( $v, 6, 'call sub');
# Check that eval{} inside the block works correctly
$v = reduce { eval { die }; $a + $b } 0,1,2,3,4;
is( $v, 10, 'use eval{}');
$v = !defined eval { reduce { die if $b > 2; $a + $b } 0,1,2,3,4 };
ok($v, 'die');
sub foobar { reduce { (defined(wantarray) && !wantarray) ? $a+1 : 0 } 0,1,2,3 }
($v) = foobar();
is( $v, 3, 'scalar context');
sub add2 { $a + $b }
$v = reduce \&add2, 1,2,3;
is( $v, 6, 'sub reference');
$v = reduce { add2() } 3,4,5;
is( $v, 12, 'call sub');
$v = reduce { eval "$a + $b" } 1,2,3;
is( $v, 6, 'eval string');
$a = 8; $b = 9;
$v = reduce { $a * $b } 1,2,3;
is( $a, 8, 'restore $a');
is( $b, 9, 'restore $b');
# Can we leave the sub with 'return'?
$v = reduce {return $a+$b} 2,4,6;
is($v, 12, 'return');
# ... even in a loop?
$v = reduce {while(1) {return $a+$b} } 2,4,6;
is($v, 12, 'return from loop');
# Does it work from another package?
{ package Foo;
$a = $b;
::is((List::Util::reduce {$a*$b} (1..4)), 24, 'other package');
}
# Can we undefine a reduce sub while it's running?
sub self_immolate {undef &self_immolate; 1}
eval { $v = reduce \&self_immolate, 1,2; };
like($@, qr/^Can't undef active subroutine/, "undef active sub");
# Redefining an active sub should not fail, but whether the
# redefinition takes effect immediately depends on whether we're
# running the Perl or XS implementation.
sub self_updating { local $^W; *self_updating = sub{1} ;1 }
eval { $v = reduce \&self_updating, 1,2; };
is($@, '', 'redefine self');
{ my $failed = 0;
sub rec { my $n = shift;
if (!defined($n)) { # No arg means we're being called by reduce()
return 1; }
if ($n<5) { rec($n+1); }
else { $v = reduce \&rec, 1,2; }
$failed = 1 if !defined $n;
}
rec(1);
ok(!$failed, 'from active sub');
}
# Calling a sub from reduce should leave its refcount unchanged.
SKIP: {
skip("No Internals::SvREFCNT", 1) if !defined &Internals::SvREFCNT;
sub mult {$a*$b}
my $refcnt = &Internals::SvREFCNT(\&mult);
$v = reduce \&mult, 1..6;
is(&Internals::SvREFCNT(\&mult), $refcnt, "Refcount unchanged");
}
# The remainder of the tests are only relevant for the XS
# implementation. The Perl-only implementation behaves differently
# (and more flexibly) in a way that we can't emulate from XS.
if (!$::PERL_ONLY) { SKIP: {
$List::Util::REAL_MULTICALL ||= 0; # Avoid use only once
skip("Poor man's MULTICALL can't cope", 2)
if !$List::Util::REAL_MULTICALL;
# Can we goto a label from the reduction sub?
eval {()=reduce{goto foo} 1,2; foo: 1};
like($@, qr/^Can't "goto" out of a pseudo block/, "goto label");
# Can we goto a subroutine?
eval {()=reduce{goto sub{}} 1,2;};
like($@, qr/^Can't goto subroutine from a sort sub/, "goto sub");
} }
--- NEW FILE: blessed.t ---
#!./perl
BEGIN {
unless (-d 'blib') {
chdir 't' if -d 't';
@INC = '../lib';
require Config; import Config;
keys %Config; # Silence warning
if ($Config{extensions} !~ /\bList\/Util\b/) {
print "1..0 # Skip: List::Util was not built\n";
exit 0;
}
}
}
use Test::More tests => 8;
use Scalar::Util qw(blessed);
use vars qw($t $x);
ok(!blessed(undef), 'undef is not blessed');
ok(!blessed(1), 'Numbers are not blessed');
ok(!blessed('A'), 'Strings are not blessed');
ok(!blessed({}), 'Unblessed HASH-ref');
ok(!blessed([]), 'Unblessed ARRAY-ref');
ok(!blessed(\$t), 'Unblessed SCALAR-ref');
$x = bless [], "ABC";
is(blessed($x), "ABC", 'blessed ARRAY-ref');
$x = bless {}, "DEF";
is(blessed($x), "DEF", 'blessed HASH-ref');
--- NEW FILE: maxstr.t ---
#!./perl
BEGIN {
unless (-d 'blib') {
chdir 't' if -d 't';
@INC = '../lib';
require Config; import Config;
keys %Config; # Silence warning
if ($Config{extensions} !~ /\bList\/Util\b/) {
print "1..0 # Skip: List::Util was not built\n";
exit 0;
}
}
}
use strict;
use Test::More tests => 5;
use List::Util qw(maxstr);
my $v;
ok(defined &maxstr, 'defined');
$v = maxstr('a');
is($v, 'a', 'single arg');
$v = maxstr('a','b');
is($v, 'b', '2-arg ordered');
$v = maxstr('B','A');
is($v, 'B', '2-arg reverse ordered');
my @a = map { pack("u", pack("C*",map { int(rand(256))} (0..int(rand(10) + 2)))) } 0 .. 20;
my @b = sort { $a cmp $b } @a;
$v = maxstr(@a);
is($v, $b[-1], 'random ordered');
--- NEW FILE: p_first.t ---
#!./perl
# force perl-only version to be tested
$List::Util::TESTING_PERL_ONLY = $List::Util::TESTING_PERL_ONLY = 1;
(my $f = __FILE__) =~ s/p_//;
$::PERL_ONLY = $::PERL_ONLY = 1; # Mustn't use it only once!
do $f;
--- NEW FILE: readonly.t ---
#!./perl
BEGIN {
unless (-d 'blib') {
chdir 't' if -d 't';
@INC = '../lib';
require Config; import Config;
keys %Config; # Silence warning
if ($Config{extensions} !~ /\bList\/Util\b/) {
print "1..0 # Skip: List::Util was not built\n";
exit 0;
}
}
}
use Scalar::Util qw(readonly);
use Test::More tests => 9;
ok( readonly(1), 'number constant');
my $var = 2;
ok( !readonly($var), 'number variable');
is( $var, 2, 'no change to number variable');
ok( readonly("fred"), 'string constant');
$var = "fred";
ok( !readonly($var), 'string variable');
is( $var, 'fred', 'no change to string variable');
$var = \2;
ok( !readonly($var), 'reference to constant');
ok( readonly($$var), 'de-reference to constant');
ok( !readonly(*STDOUT), 'glob');
More information about the dslinux-commit
mailing list