Commit | Line | Data |
1bfb5477 |
1 | #!./perl |
2 | |
f4a2945e |
3 | BEGIN { |
1bfb5477 |
4 | unless (-d 'blib') { |
f4a2945e |
5 | chdir 't' if -d 't'; |
6 | @INC = '../lib'; |
6b05f64e |
7 | require Config; import Config; |
1bfb5477 |
8 | keys %Config; # Silence warning |
6b05f64e |
9 | if ($Config{extensions} !~ /\bList\/Util\b/) { |
10 | print "1..0 # Skip: List::Util was not built\n"; |
11 | exit 0; |
12 | } |
1bfb5477 |
13 | } |
f4a2945e |
14 | } |
15 | |
1bfb5477 |
16 | |
f4a2945e |
17 | use List::Util qw(reduce min); |
9850bf21 |
18 | use Test::More; |
19 | plan tests => ($::PERL_ONLY ? 21 : 23); |
f4a2945e |
20 | |
cf083cf9 |
21 | my $v = reduce {}; |
f4a2945e |
22 | |
cf083cf9 |
23 | is( $v, undef, 'no args'); |
f4a2945e |
24 | |
cf083cf9 |
25 | $v = reduce { $a / $b } 756,3,7,4; |
26 | is( $v, 9, '4-arg divide'); |
f4a2945e |
27 | |
cf083cf9 |
28 | $v = reduce { $a / $b } 6; |
29 | is( $v, 6, 'one arg'); |
f4a2945e |
30 | |
31 | @a = map { rand } 0 .. 20; |
cf083cf9 |
32 | $v = reduce { $a < $b ? $a : $b } @a; |
33 | is( $v, min(@a), 'min'); |
f4a2945e |
34 | |
35 | @a = map { pack("C", int(rand(256))) } 0 .. 20; |
cf083cf9 |
36 | $v = reduce { $a . $b } @a; |
37 | is( $v, join("",@a), 'concat'); |
1bfb5477 |
38 | |
39 | sub add { |
40 | my($aa, $bb) = @_; |
41 | return $aa + $bb; |
42 | } |
43 | |
cf083cf9 |
44 | $v = reduce { my $t="$a $b\n"; 0+add($a, $b) } 3, 2, 1; |
45 | is( $v, 6, 'call sub'); |
1bfb5477 |
46 | |
47 | # Check that eval{} inside the block works correctly |
cf083cf9 |
48 | $v = reduce { eval { die }; $a + $b } 0,1,2,3,4; |
49 | is( $v, 10, 'use eval{}'); |
1bfb5477 |
50 | |
cf083cf9 |
51 | $v = !defined eval { reduce { die if $b > 2; $a + $b } 0,1,2,3,4 }; |
52 | ok($v, 'die'); |
60f3865b |
53 | |
cf083cf9 |
54 | sub foobar { reduce { (defined(wantarray) && !wantarray) ? $a+1 : 0 } 0,1,2,3 } |
55 | ($v) = foobar(); |
56 | is( $v, 3, 'scalar context'); |
60f3865b |
57 | |
09c2a9b8 |
58 | sub add2 { $a + $b } |
59 | |
cf083cf9 |
60 | $v = reduce \&add2, 1,2,3; |
61 | is( $v, 6, 'sub reference'); |
09c2a9b8 |
62 | |
cf083cf9 |
63 | $v = reduce { add2() } 3,4,5; |
64 | is( $v, 12, 'call sub'); |
09c2a9b8 |
65 | |
09c2a9b8 |
66 | |
cf083cf9 |
67 | $v = reduce { eval "$a + $b" } 1,2,3; |
68 | is( $v, 6, 'eval string'); |
09c2a9b8 |
69 | |
cf083cf9 |
70 | $a = 8; $b = 9; |
71 | $v = reduce { $a * $b } 1,2,3; |
72 | is( $a, 8, 'restore $a'); |
73 | is( $b, 9, 'restore $b'); |
9850bf21 |
74 | |
75 | # Can we leave the sub with 'return'? |
76 | $v = reduce {return $a+$b} 2,4,6; |
77 | is($v, 12, 'return'); |
78 | |
79 | # ... even in a loop? |
80 | $v = reduce {while(1) {return $a+$b} } 2,4,6; |
81 | is($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? |
90 | sub self_immolate {undef &self_immolate; 1} |
91 | eval { $v = reduce \&self_immolate, 1,2; }; |
92 | like($@, 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 | |
98 | sub self_updating { local $^W; *self_updating = sub{1} ;1 } |
99 | eval { $v = reduce \&self_updating, 1,2; }; |
100 | is($@, '', '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. |
117 | SKIP: { |
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 | # The remainder of the tests are only relevant for the XS |
126 | # implementation. The Perl-only implementation behaves differently |
127 | # (and more flexibly) in a way that we can't emulate from XS. |
128 | if (!$::PERL_ONLY) { SKIP: { |
129 | |
130 | skip("Poor man's MULTICALL can't cope", 2) |
131 | if !$List::Util::REAL_MULTICALL; |
132 | |
133 | # Can we goto a label from the reduction sub? |
134 | eval {()=reduce{goto foo} 1,2; foo: 1}; |
135 | like($@, qr/^Can't "goto" out of a pseudo block/, "goto label"); |
136 | |
137 | # Can we goto a subroutine? |
138 | eval {()=reduce{goto sub{}} 1,2;}; |
139 | like($@, qr/^Can't goto subroutine from a sort sub/, "goto sub"); |
140 | |
141 | } } |