cpan/Scalar-List-Utils/t/first.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 use List::Util qw(first);
  17 use Test::More;
  18 plan tests => 22 + ($::PERL_ONLY ? 0 : 2);
  19 my $v;
  20
  21 ok(defined &first,      'defined');
  22
  23 $v = first { 8 == ($_ - 1) } 9,4,5,6;
  24 is($v, 9, 'one more than 8');
  25
  26 $v = first { 0 } 1,2,3,4;
  27 is($v, undef, 'none match');
  28
  29 $v = first { 0 };
  30 is($v, undef, 'no args');
  31
  32 $v = first { $_->[1] le "e" and "e" le $_->[2] }
  33                 [qw(a b c)], [qw(d e f)], [qw(g h i)];
  34 is_deeply($v, [qw(d e f)], 'reference args');
  35
  36 # Check that eval{} inside the block works correctly
  37 my $i = 0;
  38 $v = first { eval { die }; ($i == 5, $i = $_)[0] } 0,1,2,3,4,5,5;
  39 is($v, 5, 'use of eval');
  40
  41 $v = eval { first { die if $_ } 0,0,1 };
  42 is($v, undef, 'use of die');
  43
  44 sub foobar {  first { !defined(wantarray) || wantarray } "not ","not ","not " }
  45
  46 ($v) = foobar();
  47 is($v, undef, 'wantarray');
  48
  49 # Can we leave the sub with 'return'?
  50 $v = first {return ($_>6)} 2,4,6,12;
  51 is($v, 12, 'return');
  52
  53 # ... even in a loop?
  54 $v = first {while(1) {return ($_>6)} } 2,4,6,12;
  55 is($v, 12, 'return from loop');
  56
  57 # Does it work from another package?
  58 { package Foo;
  59   ::is(List::Util::first(sub{$_>4},(1..4,24)), 24, 'other package');
  60 }
  61
  62 # Can we undefine a first sub while it's running?
  63 sub self_immolate {undef &self_immolate; 1}
  64 eval { $v = first \&self_immolate, 1,2; };
  65 like($@, qr/^Can't undef active subroutine/, "undef active sub");
  66
  67 # Redefining an active sub should not fail, but whether the
  68 # redefinition takes effect immediately depends on whether we're
  69 # running the Perl or XS implementation.
  70
  71 sub self_updating { local $^W; *self_updating = sub{1} ;1}
  72 eval { $v = first \&self_updating, 1,2; };
  73 is($@, '', 'redefine self');
  74
  75 { my $failed = 0;
  76
  77     sub rec { my $n = shift;
  78         if (!defined($n)) {  # No arg means we're being called by first()
  79             return 1; }
  80         if ($n<5) { rec($n+1); }
  81         else { $v = first \&rec, 1,2; }
  82         $failed = 1 if !defined $n;
  83     }
  84
  85     rec(1);
  86     ok(!$failed, 'from active sub');
  87 }
  88
  89 # Calling a sub from first should leave its refcount unchanged.
  90 SKIP: {
  91     skip("No Internals::SvREFCNT", 1) if !defined &Internals::SvREFCNT;
  92     sub huge {$_>1E6}
  93     my $refcnt = &Internals::SvREFCNT(\&huge);
  94     $v = first \&huge, 1..6;
  95     is(&Internals::SvREFCNT(\&huge), $refcnt, "Refcount unchanged");
  96 }
  97
  98 # The remainder of the tests are only relevant for the XS
  99 # implementation. The Perl-only implementation behaves differently
 100 # (and more flexibly) in a way that we can't emulate from XS.
 101 if (!$::PERL_ONLY) { SKIP: {
 102
 103     $List::Util::REAL_MULTICALL ||= 0; # Avoid use only once
 104     skip("Poor man's MULTICALL can't cope", 2)
 105       if !$List::Util::REAL_MULTICALL;
 106
 107     # Can we goto a label from the 'first' sub?
 108     eval {()=first{goto foo} 1,2; foo: 1};
 109     like($@, qr/^Can't "goto" out of a pseudo block/, "goto label");
 110
 111     # Can we goto a subroutine?
 112     eval {()=first{goto sub{}} 1,2;};
 113     like($@, qr/^Can't goto subroutine from a sort sub/, "goto sub");
 114
 115 } }
 116
 117 use constant XSUBC_TRUE  => 1;
 118 use constant XSUBC_FALSE => 0;
 119
 120 is first(\&XSUBC_TRUE,  42, 1, 2, 3), 42,    'XSUB callbacks';
 121 is first(\&XSUBC_FALSE, 42, 1, 2, 3), undef, 'XSUB callbacks';
 122
 123
 124 eval { &first(1) };
 125 ok($@ =~ /^Not a subroutine reference/, 'check for code reference');
 126 eval { &first(1,2) };
 127 ok($@ =~ /^Not a subroutine reference/, 'check for code reference');
 128 eval { &first(qw(a b)) };
 129 ok($@ =~ /^Not a subroutine reference/, 'check for code reference');
 130 eval { &first([],1,2,3) };
 131 ok($@ =~ /^Not a subroutine reference/, 'check for code reference');
 132 eval { &first(+{},1,2,3) };
 133 ok($@ =~ /^Not a subroutine reference/, 'check for code reference');
 134