ext/List-Util/t/reduce.t

   1 #!./perl
   2
   3 BEGIN {
   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
  17 use List::Util qw(reduce min);
  18 use Test::More;
  19 plan tests => ($::PERL_ONLY ? 23 : 25);
  20
  21 my $v = reduce {};
  22
  23 is( $v, undef,  'no args');
  24
  25 $v = reduce { $a / $b } 756,3,7,4;
  26 is( $v, 9,      '4-arg divide');
  27
  28 $v = reduce { $a / $b } 6;
  29 is( $v, 6,      'one arg');
  30
  31 @a = map { rand } 0 .. 20;
  32 $v = reduce { $a < $b ? $a : $b } @a;
  33 is( $v, min(@a),        'min');
  34
  35 @a = map { pack("C", int(rand(256))) } 0 .. 20;
  36 $v = reduce { $a . $b } @a;
  37 is( $v, join("",@a),    'concat');
  38
  39 sub 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;
  45 is( $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;
  49 is( $v, 10,     'use eval{}');
  50
  51 $v = !defined eval { reduce { die if $b > 2; $a + $b } 0,1,2,3,4 };
  52 ok($v, 'die');
  53
  54 sub foobar { reduce { (defined(wantarray) && !wantarray) ? $a+1 : 0 } 0,1,2,3 }
  55 ($v) = foobar();
  56 is( $v, 3,      'scalar context');
  57
  58 sub add2 { $a + $b }
  59
  60 $v = reduce \&add2, 1,2,3;
  61 is( $v, 6,      'sub reference');
  62
  63 $v = reduce { add2() } 3,4,5;
  64 is( $v, 12,     'call sub');
  65
  66
  67 $v = reduce { eval "$a + $b" } 1,2,3;
  68 is( $v, 6, 'eval string');
  69
  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');
  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 {
 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.
 138 if (!$::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 } }