1#!./perl
2
3BEGIN {
4    unless (-d 'blib') {
5	chdir 't' if -d 't';
6	@INC = '../lib';
7	require Config; import Config;
8	keys %Config; # Silence warning
9	if ($Config{extensions} !~ /\bList\/Util\b/) {
10	    print "1..0 # Skip: List::Util was not built\n";
11	    exit 0;
12	}
13    }
14}
15
16
17use List::Util qw(reduce min);
18use Test::More;
19plan tests => 29 + ($::PERL_ONLY ? 0 : 2);
20
21my $v = reduce {};
22
23is( $v,	undef,	'no args');
24
25$v = reduce { $a / $b } 756,3,7,4;
26is( $v,	9,	'4-arg divide');
27
28$v = reduce { $a / $b } 6;
29is( $v,	6,	'one arg');
30
31@a = map { rand } 0 .. 20;
32$v = reduce { $a < $b ? $a : $b } @a;
33is( $v,	min(@a),	'min');
34
35@a = map { pack("C", int(rand(256))) } 0 .. 20;
36$v = reduce { $a . $b } @a;
37is( $v,	join("",@a),	'concat');
38
39sub add {
40  my($aa, $bb) = @_;
41  return $aa + $bb;
42}
43
44$v = reduce { my $t="$a $b\n"; 0+add($a, $b) } 3, 2, 1;
45is( $v,	6,	'call sub');
46
47# Check that eval{} inside the block works correctly
48$v = reduce { eval { die }; $a + $b } 0,1,2,3,4;
49is( $v,	10,	'use eval{}');
50
51$v = !defined eval { reduce { die if $b > 2; $a + $b } 0,1,2,3,4 };
52ok($v, 'die');
53
54sub foobar { reduce { (defined(wantarray) && !wantarray) ? $a+1 : 0 } 0,1,2,3 }
55($v) = foobar();
56is( $v,	3,	'scalar context');
57
58sub add2 { $a + $b }
59
60$v = reduce \&add2, 1,2,3;
61is( $v,	6,	'sub reference');
62
63$v = reduce { add2() } 3,4,5;
64is( $v, 12,	'call sub');
65
66
67$v = reduce { eval "$a + $b" } 1,2,3;
68is( $v, 6, 'eval string');
69
70$a = 8; $b = 9;
71$v = reduce { $a * $b } 1,2,3;
72is( $a, 8, 'restore $a');
73is( $b, 9, 'restore $b');
74
75# Can we leave the sub with 'return'?
76$v = reduce {return $a+$b} 2,4,6;
77is($v, 12, 'return');
78
79# ... even in a loop?
80$v = reduce {while(1) {return $a+$b} } 2,4,6;
81is($v, 12, 'return from loop');
82
83# Does it work from another package?
84{ package Foo;
85  $a = $b;
86  ::is((List::Util::reduce {$a*$b} (1..4)), 24, 'other package');
87}
88
89# Can we undefine a reduce sub while it's running?
90sub self_immolate {undef &self_immolate; 1}
91eval { $v = reduce \&self_immolate, 1,2; };
92like($@, qr/^Can't undef active subroutine/, "undef active sub");
93
94# Redefining an active sub should not fail, but whether the
95# redefinition takes effect immediately depends on whether we're
96# running the Perl or XS implementation.
97
98sub self_updating { local $^W; *self_updating = sub{1} ;1 }
99eval { $v = reduce \&self_updating, 1,2; };
100is($@, '', 'redefine self');
101
102{ my $failed = 0;
103
104    sub rec { my $n = shift;
105        if (!defined($n)) {  # No arg means we're being called by reduce()
106            return 1; }
107        if ($n<5) { rec($n+1); }
108        else { $v = reduce \&rec, 1,2; }
109        $failed = 1 if !defined $n;
110    }
111
112    rec(1);
113    ok(!$failed, 'from active sub');
114}
115
116# Calling a sub from reduce should leave its refcount unchanged.
117SKIP: {
118    skip("No Internals::SvREFCNT", 1) if !defined &Internals::SvREFCNT;
119    sub mult {$a*$b}
120    my $refcnt = &Internals::SvREFCNT(\&mult);
121    $v = reduce \&mult, 1..6;
122    is(&Internals::SvREFCNT(\&mult), $refcnt, "Refcount unchanged");
123}
124
125{
126  my $ok = 'failed';
127  local $SIG{__DIE__} = sub { $ok = $_[0] =~ /Not a (subroutine|CODE) reference/ ? '' : $_[0] };
128  eval { &reduce('foo',1,2) };
129  is($ok, '', 'Not a subroutine reference');
130  $ok = 'failed';
131  eval { &reduce({},1,2) };
132  is($ok, '', 'Not a subroutine reference');
133}
134
135# The remainder of the tests are only relevant for the XS
136# implementation. The Perl-only implementation behaves differently
137# (and more flexibly) in a way that we can't emulate from XS.
138if (!$::PERL_ONLY) { SKIP: {
139
140    $List::Util::REAL_MULTICALL ||= 0; # Avoid use only once
141    skip("Poor man's MULTICALL can't cope", 2)
142      if !$List::Util::REAL_MULTICALL;
143
144    # Can we goto a label from the reduction sub?
145    eval {()=reduce{goto foo} 1,2; foo: 1};
146    like($@, qr/^Can't "goto" out of a pseudo block/, "goto label");
147
148    # Can we goto a subroutine?
149    eval {()=reduce{goto sub{}} 1,2;};
150    like($@, qr/^Can't goto subroutine from a sort sub/, "goto sub");
151
152} }
153
154# XSUB callback
155use constant XSUBC => 42;
156
157is reduce(\&XSUBC, 1, 2, 3), 42, "xsub callbacks";
158
159eval { &reduce(1) };
160ok($@ =~ /^Not a subroutine reference/, 'check for code reference');
161eval { &reduce(1,2) };
162ok($@ =~ /^Not a subroutine reference/, 'check for code reference');
163eval { &reduce(qw(a b)) };
164ok($@ =~ /^Not a subroutine reference/, 'check for code reference');
165eval { &reduce([],1,2,3) };
166ok($@ =~ /^Not a subroutine reference/, 'check for code reference');
167eval { &reduce(+{},1,2,3) };
168ok($@ =~ /^Not a subroutine reference/, 'check for code reference');
169
170