1#!./perl 2 3use strict; 4use warnings; 5 6use List::Util qw(reduce min); 7use Test::More; 8plan tests => 33; 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# These tests are only relevant for the real multicall implementation. The 129# pseudo-multicall implementation behaves differently. 130SKIP: { 131 $List::Util::REAL_MULTICALL ||= 0; # Avoid use only once 132 skip("Poor man's MULTICALL can't cope", 2) 133 if !$List::Util::REAL_MULTICALL; 134 135 # Can we goto a label from the reduction sub? 136 eval {()=reduce{goto foo} 1,2; foo: 1}; 137 like($@, qr/^Can't "goto" out of a pseudo block/, "goto label"); 138 139 # Can we goto a subroutine? 140 eval {()=reduce{goto sub{}} 1,2;}; 141 like($@, qr/^Can't goto subroutine from a sort sub/, "goto sub"); 142} 143 144{ 145 my @ret = reduce { $a + $b } 1 .. 5; 146 is_deeply( \@ret, [ 15 ], 'reduce in list context yields only final answer' ); 147} 148 149# XSUB callback 150use constant XSUBC => 42; 151 152is reduce(\&XSUBC, 1, 2, 3), 42, "xsub callbacks"; 153 154eval { &reduce(1) }; 155ok($@ =~ /^Not a subroutine reference/, 'check for code reference'); 156eval { &reduce(1,2) }; 157ok($@ =~ /^Not a subroutine reference/, 'check for code reference'); 158eval { &reduce(qw(a b)) }; 159ok($@ =~ /^Not a subroutine reference/, 'check for code reference'); 160eval { &reduce([],1,2,3) }; 161ok($@ =~ /^Not a subroutine reference/, 'check for code reference'); 162eval { &reduce(+{},1,2,3) }; 163ok($@ =~ /^Not a subroutine reference/, 'check for code reference'); 164 165my @names = ("a\x{100}c", "d\x{101}efgh", 'ijk'); 166my $longest = reduce { length($a) > length($b) ? $a : $b } @names; 167is( length($longest), 6, 'missing SMG rt#121992'); 168