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