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