t/op/loopctl.t - metacpan.org

#!./perl

# We have the following types of loop:
#
# 1a)  while(A) {B}
# 1b)  B while A;
#
# 2a)  until(A) {B}
# 2b)  B until A;
#
# 3a)  for(@A)  {B}
# 3b)  B for A;
#
# 4a)  for (A;B;C) {D}
#
# 5a)  { A }        # a bare block is a loop which runs once
#
# Loops of type (b) don't allow for next/last/redo style
#  control, so we ignore them here. Type (a) loops can
#  all be labelled, so there are ten possibilities (each
#  of 5 types, labelled/unlabelled). We therefore need
#  thirty tests to try the three control statements against
#  the ten types of loop. For the first four types it's useful
#  to distinguish the case where next re-iterates from the case
#  where it leaves the loop. That makes 38.
# All these tests rely on "last LABEL"
#  so if they've *all* failed, maybe you broke that...
#
# These tests are followed by an extra test of nested loops.
# Feel free to add more here.
#
#  -- .robin. <robin@kitsite.com>  2001-03-13
BEGIN {
    chdir 't' if -d 't';
    @INC = qw(. ../lib);
    require "./test.pl";
}

plan( tests => 67 );

my $ok;

TEST1: {

  $ok = 0;

  my $x = 1;
  my $first_time = 1;
  while($x--) {
    if (!$first_time) {
      $ok = 1;
      last TEST1;
    }
    $ok = 0;
    $first_time = 0;
    redo;
    last TEST1;
  }
  continue {
    $ok = 0;
    last TEST1;
  }
  $ok = 0;
}
cmp_ok($ok,'==',1,'no label on while()');

TEST2: {

  $ok = 0;

  my $x = 2;
  my $first_time = 1;
  my $been_in_continue = 0;
  while($x--) {
    if (!$first_time) {
      $ok = $been_in_continue;
      last TEST2;
    }
    $ok = 0;
    $first_time = 0;
    next;
    last TEST2;
  }
  continue {
    $been_in_continue = 1;
  }
  $ok = 0;
}
cmp_ok($ok,'==',1,'no label on while() successful next');

TEST3: {

  $ok = 0;

  my $x = 1;
  my $first_time = 1;
  my $been_in_loop = 0;
  my $been_in_continue = 0;
  while($x--) {
    $been_in_loop = 1;
    if (!$first_time) {
      $ok = 0;
      last TEST3;
    }
    $ok = 0;
    $first_time = 0;
    next;
    last TEST3;
  }
  continue {
    $been_in_continue = 1;
  }
  $ok = $been_in_loop && $been_in_continue;
}
cmp_ok($ok,'==',1,'no label on while() unsuccessful next');

TEST4: {

  $ok = 0;

  my $x = 1;
  my $first_time = 1;
  while($x++) {
    if (!$first_time) {
      $ok = 0;
      last TEST4;
    }
    $ok = 0;
    $first_time = 0;
    last;
    last TEST4;
  }
  continue {
    $ok = 0;
    last TEST4;
  }
  $ok = 1;
}
cmp_ok($ok,'==',1,'no label on while() last');

TEST5: {

  $ok = 0;

  my $x = 0;
  my $first_time = 1;
  until($x++) {
    if (!$first_time) {
      $ok = 1;
      last TEST5;
    }
    $ok = 0;
    $first_time = 0;
    redo;
    last TEST5;
  }
  continue {
    $ok = 0;
    last TEST5;
  }
  $ok = 0;
}
cmp_ok($ok,'==',1,'no label on until()');

TEST6: {

  $ok = 0;

  my $x = 0;
  my $first_time = 1;
  my $been_in_continue = 0;
  until($x++ >= 2) {
    if (!$first_time) {
      $ok = $been_in_continue;
      last TEST6;
    }
    $ok = 0;
    $first_time = 0;
    next;
    last TEST6;
  }
  continue {
    $been_in_continue = 1;
  }
  $ok = 0;
}
cmp_ok($ok,'==',1,'no label on until() successful next');

TEST7: {

  $ok = 0;

  my $x = 0;
  my $first_time = 1;
  my $been_in_loop = 0;
  my $been_in_continue = 0;
  until($x++) {
    $been_in_loop = 1;
    if (!$first_time) {
      $ok = 0;
      last TEST7;
    }
    $ok = 0;
    $first_time = 0;
    next;
    last TEST7;
  }
  continue {
    $been_in_continue = 1;
  }
  $ok = $been_in_loop && $been_in_continue;
}
cmp_ok($ok,'==',1,'no label on until() unsuccessful next');

TEST8: {

  $ok = 0;

  my $x = 0;
  my $first_time = 1;
  until($x++ == 10) {
    if (!$first_time) {
      $ok = 0;
      last TEST8;
    }
    $ok = 0;
    $first_time = 0;
    last;
    last TEST8;
  }
  continue {
    $ok = 0;
    last TEST8;
  }
  $ok = 1;
}
cmp_ok($ok,'==',1,'no label on until() last');

TEST9: {

  $ok = 0;

  my $first_time = 1;
  for(1) {
    if (!$first_time) {
      $ok = 1;
      last TEST9;
    }
    $ok = 0;
    $first_time = 0;
    redo;
    last TEST9;
  }
  continue {
    $ok = 0;
    last TEST9;
  }
  $ok = 0;
}
cmp_ok($ok,'==',1,'no label on for(@array)');

TEST10: {

  $ok = 0;

  my $first_time = 1;
  my $been_in_continue = 0;
  for(1,2) {
    if (!$first_time) {
      $ok = $been_in_continue;
      last TEST10;
    }
    $ok = 0;
    $first_time = 0;
    next;
    last TEST10;
  }
  continue {
    $been_in_continue = 1;
  }
  $ok = 0;
}
cmp_ok($ok,'==',1,'no label on for(@array) successful next');

TEST11: {

  $ok = 0;

  my $first_time = 1;
  my $been_in_loop = 0;
  my $been_in_continue = 0;
  for(1) {
    $been_in_loop = 1;
    if (!$first_time) {
      $ok = 0;
      last TEST11;
    }
    $ok = 0;
    $first_time = 0;
    next;
    last TEST11;
  }
  continue {
    $been_in_continue = 1;
  }
  $ok = $been_in_loop && $been_in_continue;
}
cmp_ok($ok,'==',1,'no label on for(@array) unsuccessful next');

TEST12: {

  $ok = 0;

  my $first_time = 1;
  for(1..10) {
    if (!$first_time) {
      $ok = 0;
      last TEST12;
    }
    $ok = 0;
    $first_time = 0;
    last;
    last TEST12;
  }
  continue {
    $ok=0;
    last TEST12;
  }
  $ok = 1;
}
cmp_ok($ok,'==',1,'no label on for(@array) last');

TEST13: {

  $ok = 0;

  for(my $first_time = 1; 1;) {
    if (!$first_time) {
      $ok = 1;
      last TEST13;
    }
    $ok = 0;
    $first_time=0;

    redo;
    last TEST13;
  }
  $ok = 0;
}
cmp_ok($ok,'==',1,'no label on for(;;)');

TEST14: {

  $ok = 0;

  for(my $first_time = 1; 1; $first_time=0) {
    if (!$first_time) {
      $ok = 1;
      last TEST14;
    }
    $ok = 0;
    next;
    last TEST14;
  }
  $ok = 0;
}
cmp_ok($ok,'==',1,'no label on for(;;) successful next');

TEST15: {

  $ok = 0;

  my $x=1;
  my $been_in_loop = 0;
  for(my $first_time = 1; $x--;) {
    $been_in_loop = 1;
    if (!$first_time) {
      $ok = 0;
      last TEST15;
    }
    $ok = 0;
    $first_time = 0;
    next;
    last TEST15;
  }
  $ok = $been_in_loop;
}
cmp_ok($ok,'==',1,'no label on for(;;) unsuccessful next');

TEST16: {

  $ok = 0;

  for(my $first_time = 1; 1; last TEST16) {
    if (!$first_time) {
      $ok = 0;
      last TEST16;
    }
    $ok = 0;
    $first_time = 0;
    last;
    last TEST16;
  }
  $ok = 1;
}
cmp_ok($ok,'==',1,'no label on for(;;) last');

TEST17: {

  $ok = 0;
  my $first_time = 1;

  {
    if (!$first_time) {
      $ok = 1;
      last TEST17;
    }
    $ok = 0;
    $first_time=0;

    redo;
    last TEST17;
  }
  continue {
    $ok = 0;
    last TEST17;
  }
  $ok = 0;
}
cmp_ok($ok,'==',1,'no label on bare block');

TEST18: {

  $ok = 0;
  {
    next;
    last TEST18;
  }
  continue {
    $ok = 1;
    last TEST18;
  }
  $ok = 0;
}
cmp_ok($ok,'==',1,'no label on bare block next');

TEST19: {

  $ok = 0;
  {
    last;
    last TEST19;
  }
  continue {
    $ok = 0;
    last TEST19;
  }
  $ok = 1;
}
cmp_ok($ok,'==',1,'no label on bare block last');

### Now do it all again with labels

TEST20: {

  $ok = 0;

  my $x = 1;
  my $first_time = 1;
  LABEL20: while($x--) {
    if (!$first_time) {
      $ok = 1;
      last TEST20;
    }
    $ok = 0;
    $first_time = 0;
    redo LABEL20;
    last TEST20;
  }
  continue {
    $ok = 0;
    last TEST20;
  }
  $ok = 0;
}
cmp_ok($ok,'==',1,'label on while()');

TEST21: {

  $ok = 0;

  my $x = 2;
  my $first_time = 1;
  my $been_in_continue = 0;
  LABEL21: while($x--) {
    if (!$first_time) {
      $ok = $been_in_continue;
      last TEST21;
    }
    $ok = 0;
    $first_time = 0;
    next LABEL21;
    last TEST21;
  }
  continue {
    $been_in_continue = 1;
  }
  $ok = 0;
}
cmp_ok($ok,'==',1,'label on while() successful next');

TEST22: {

  $ok = 0;

  my $x = 1;
  my $first_time = 1;
  my $been_in_loop = 0;
  my $been_in_continue = 0;
  LABEL22: while($x--) {
    $been_in_loop = 1;
    if (!$first_time) {
      $ok = 0;
      last TEST22;
    }
    $ok = 0;
    $first_time = 0;
    next LABEL22;
    last TEST22;
  }
  continue {
    $been_in_continue = 1;
  }
  $ok = $been_in_loop && $been_in_continue;
}
cmp_ok($ok,'==',1,'label on while() unsuccessful next');

TEST23: {

  $ok = 0;

  my $x = 1;
  my $first_time = 1;
  LABEL23: while($x++) {
    if (!$first_time) {
      $ok = 0;
      last TEST23;
    }
    $ok = 0;
    $first_time = 0;
    last LABEL23;
    last TEST23;
  }
  continue {
    $ok = 0;
    last TEST23;
  }
  $ok = 1;
}
cmp_ok($ok,'==',1,'label on while() last');

TEST24: {

  $ok = 0;

  my $x = 0;
  my $first_time = 1;
  LABEL24: until($x++) {
    if (!$first_time) {
      $ok = 1;
      last TEST24;
    }
    $ok = 0;
    $first_time = 0;
    redo LABEL24;
    last TEST24;
  }
  continue {
    $ok = 0;
    last TEST24;
  }
  $ok = 0;
}
cmp_ok($ok,'==',1,'label on until()');

TEST25: {

  $ok = 0;

  my $x = 0;
  my $first_time = 1;
  my $been_in_continue = 0;
  LABEL25: until($x++ >= 2) {
    if (!$first_time) {
      $ok = $been_in_continue;
      last TEST25;
    }
    $ok = 0;
    $first_time = 0;
    next LABEL25;
    last TEST25;
  }
  continue {
    $been_in_continue = 1;
  }
  $ok = 0;
}
cmp_ok($ok,'==',1,'label on until() successful next');

TEST26: {

  $ok = 0;

  my $x = 0;
  my $first_time = 1;
  my $been_in_loop = 0;
  my $been_in_continue = 0;
  LABEL26: until($x++) {
    $been_in_loop = 1;
    if (!$first_time) {
      $ok = 0;
      last TEST26;
    }
    $ok = 0;
    $first_time = 0;
    next LABEL26;
    last TEST26;
  }
  continue {
    $been_in_continue = 1;
  }
  $ok = $been_in_loop && $been_in_continue;
}
cmp_ok($ok,'==',1,'label on until() unsuccessful next');

TEST27: {

  $ok = 0;

  my $x = 0;
  my $first_time = 1;
  LABEL27: until($x++ == 10) {
    if (!$first_time) {
      $ok = 0;
      last TEST27;
    }
    $ok = 0;
    $first_time = 0;
    last LABEL27;
    last TEST27;
  }
  continue {
    $ok = 0;
    last TEST8;
  }
  $ok = 1;
}
cmp_ok($ok,'==',1,'label on until() last');

TEST28: {

  $ok = 0;

  my $first_time = 1;
  LABEL28: for(1) {
    if (!$first_time) {
      $ok = 1;
      last TEST28;
    }
    $ok = 0;
    $first_time = 0;
    redo LABEL28;
    last TEST28;
  }
  continue {
    $ok = 0;
    last TEST28;
  }
  $ok = 0;
}
cmp_ok($ok,'==',1,'label on for(@array)');

TEST29: {

  $ok = 0;

  my $first_time = 1;
  my $been_in_continue = 0;
  LABEL29: for(1,2) {
    if (!$first_time) {
      $ok = $been_in_continue;
      last TEST29;
    }
    $ok = 0;
    $first_time = 0;
    next LABEL29;
    last TEST29;
  }
  continue {
    $been_in_continue = 1;
  }
  $ok = 0;
}
cmp_ok($ok,'==',1,'label on for(@array) successful next');

TEST30: {

  $ok = 0;

  my $first_time = 1;
  my $been_in_loop = 0;
  my $been_in_continue = 0;
  LABEL30: for(1) {
    $been_in_loop = 1;
    if (!$first_time) {
      $ok = 0;
      last TEST30;
    }
    $ok = 0;
    $first_time = 0;
    next LABEL30;
    last TEST30;
  }
  continue {
    $been_in_continue = 1;
  }
  $ok = $been_in_loop && $been_in_continue;
}
cmp_ok($ok,'==',1,'label on for(@array) unsuccessful next');

TEST31: {

  $ok = 0;

  my $first_time = 1;
  LABEL31: for(1..10) {
    if (!$first_time) {
      $ok = 0;
      last TEST31;
    }
    $ok = 0;
    $first_time = 0;
    last LABEL31;
    last TEST31;
  }
  continue {
    $ok=0;
    last TEST31;
  }
  $ok = 1;
}
cmp_ok($ok,'==',1,'label on for(@array) last');

TEST32: {

  $ok = 0;

  LABEL32: for(my $first_time = 1; 1;) {
    if (!$first_time) {
      $ok = 1;
      last TEST32;
    }
    $ok = 0;
    $first_time=0;

    redo LABEL32;
    last TEST32;
  }
  $ok = 0;
}
cmp_ok($ok,'==',1,'label on for(;;)');

TEST33: {

  $ok = 0;

  LABEL33: for(my $first_time = 1; 1; $first_time=0) {
    if (!$first_time) {
      $ok = 1;
      last TEST33;
    }
    $ok = 0;
    next LABEL33;
    last TEST33;
  }
  $ok = 0;
}
cmp_ok($ok,'==',1,'label on for(;;) successful next');

TEST34: {

  $ok = 0;

  my $x=1;
  my $been_in_loop = 0;
  LABEL34: for(my $first_time = 1; $x--;) {
    $been_in_loop = 1;
    if (!$first_time) {
      $ok = 0;
      last TEST34;
    }
    $ok = 0;
    $first_time = 0;
    next LABEL34;
    last TEST34;
  }
  $ok = $been_in_loop;
}
cmp_ok($ok,'==',1,'label on for(;;) unsuccessful next');

TEST35: {

  $ok = 0;

  LABEL35: for(my $first_time = 1; 1; last TEST16) {
    if (!$first_time) {
      $ok = 0;
      last TEST35;
    }
    $ok = 0;
    $first_time = 0;
    last LABEL35;
    last TEST35;
  }
  $ok = 1;
}
cmp_ok($ok,'==',1,'label on for(;;) last');

TEST36: {

  $ok = 0;
  my $first_time = 1;

  LABEL36: {
    if (!$first_time) {
      $ok = 1;
      last TEST36;
    }
    $ok = 0;
    $first_time=0;

    redo LABEL36;
    last TEST36;
  }
  continue {
    $ok = 0;
    last TEST36;
  }
  $ok = 0;
}
cmp_ok($ok,'==',1,'label on bare block');

TEST37: {

  $ok = 0;
  LABEL37: {
    next LABEL37;
    last TEST37;
  }
  continue {
    $ok = 1;
    last TEST37;
  }
  $ok = 0;
}
cmp_ok($ok,'==',1,'label on bare block next');

TEST38: {

  $ok = 0;
  LABEL38: {
    last LABEL38;
    last TEST38;
  }
  continue {
    $ok = 0;
    last TEST38;
  }
  $ok = 1;
}
cmp_ok($ok,'==',1,'label on bare block last');

TEST39: {
    $ok = 0;
    my ($x, $y, $z) = (1,1,1);
    one39: while ($x--) {
      $ok = 0;
      two39: while ($y--) {
        $ok = 0;
        three39: while ($z--) {
           next two39;
        }
        continue {
          $ok = 0;
          last TEST39;
        }
      }
      continue {
        $ok = 1;
        last TEST39;
      }
      $ok = 0;
    }
}
cmp_ok($ok,'==',1,'nested constructs');

sub test_last_label { last TEST40 }

TEST40: {
    $ok = 1;
    test_last_label();
    $ok = 0;
}
cmp_ok($ok,'==',1,'dynamically scoped label');

sub test_last { last }

TEST41: {
    $ok = 1;
    test_last();
    $ok = 0;
}
cmp_ok($ok,'==',1,'dynamically scoped');


# [perl #27206] Memory leak in continue loop
# Ensure that the temporary object is freed each time round the loop,
# rather then all 10 of them all being freed right at the end

{
    my $n=10; my $late_free = 0;
    sub X::DESTROY { $late_free++ if $n < 0 };
    {
	($n-- && bless {}, 'X') && redo;
    }
    cmp_ok($late_free,'==',0,"bug 27206: redo memory leak");

    $n = 10; $late_free = 0;
    {
	($n-- && bless {}, 'X') && redo;
    }
    continue { }
    cmp_ok($late_free,'==',0,"bug 27206: redo with continue memory leak");
}

# ensure that redo doesn't clear a lexical declared in the condition

{
    my $i = 1;
    while (my $x = $i) {
	$i++;
	redo if $i == 2;
	cmp_ok($x,'==',1,"while/redo lexical life");
	last;
    }
    $i = 1;
    until (! (my $x = $i)) {
	$i++;
	redo if $i == 2;
	cmp_ok($x,'==',1,"until/redo lexical life");
	last;
    }
    for ($i = 1; my $x = $i; ) {
	$i++;
	redo if $i == 2;
	cmp_ok($x,'==',1,"for/redo lexical life");
	last;
    }

}

{
    $a37725[3] = 1; # use package var
    $i = 2;
    for my $x (reverse @a37725) {
	$x = $i++;
    }
    cmp_ok("@a37725",'eq',"5 4 3 2",'bug 37725: reverse with empty slots bug');
}

# [perl #21469] bad things happened with for $x (...) { *x = *y }

{
    my $i = 1;
    $x_21469  = 'X';
    $y1_21469 = 'Y1';
    $y2_21469 = 'Y2';
    $y3_21469 = 'Y3';
    for $x_21469 (1,2,3) {
	is($x_21469, $i, "bug 21469: correct at start of loop $i");
	*x_21469 = (*y1_21469, *y2_21469, *y3_21469)[$i-1];
	is($x_21469, "Y$i", "bug 21469: correct at tail of loop $i");
	$i++;
    }
    is($x_21469, 'X', "bug 21469: X okay at end of loop");
}

# [perl #112316] Wrong behavior regarding labels with same prefix
{
    my $fail;
    CATCH: {
    CATCHLOOP: {
            last CATCH;
        }
        $fail = 1;
    }
    ok(!$fail, "perl 112316: Labels with the same prefix don't get mixed up.");
}

# [perl #73618]
{
    sub foo_73618_0 {
        while (0) { }
    }
    sub bar_73618_0 {
        my $i = 0;
        while ($i) { }
    }
    sub foo_73618_undef {
        while (undef) { }
    }
    sub bar_73618_undef {
        my $i = undef;
        while ($i) { }
    }
    sub foo_73618_emptystring {
        while ("") { }
    }
    sub bar_73618_emptystring {
        my $i = "";
        while ($i) { }
    }
    sub foo_73618_0float {
        while (0.0) { }
    }
    sub bar_73618_0float {
        my $i = 0.0;
        while ($i) { }
    }
    sub foo_73618_0string {
        while ("0") { }
    }
    sub bar_73618_0string {
        my $i = "0";
        while ($i) { }
    }
    sub foo_73618_until {
        until (1) { }
    }
    sub bar_73618_until {
        my $i = 1;
        until ($i) { }
    }

    is(scalar(foo_73618_0()), scalar(bar_73618_0()),
       "constant optimization doesn't change return value");
    is(scalar(foo_73618_undef()), scalar(bar_73618_undef()),
       "constant optimization doesn't change return value");
    is(scalar(foo_73618_emptystring()), scalar(bar_73618_emptystring()),
       "constant optimization doesn't change return value");
    is(scalar(foo_73618_0float()), scalar(bar_73618_0float()),
       "constant optimization doesn't change return value");
    is(scalar(foo_73618_0string()), scalar(bar_73618_0string()),
       "constant optimization doesn't change return value");
    { local $TODO = "until is still wrongly optimized";
    is(scalar(foo_73618_until()), scalar(bar_73618_until()),
       "constant optimization doesn't change return value");
    }
}

# [perl #113684]
last_113684:
{
    label1:
    {
        my $label = "label1";
        eval { last $label };
        fail("last with non-constant label");
        last last_113684;
    }
    pass("last with non-constant label");
}
next_113684:
{
    label2:
    {
        my $label = "label2";
        eval { next $label };
        fail("next with non-constant label");
        next next_113684;
    }
    pass("next with non-constant label");
}
redo_113684:
{
    my $count;
    label3:
    {
        if ($count++) {
            pass("redo with non-constant label"); last redo_113684
        }
        my $label = "label3";
        eval { redo $label };
        fail("redo with non-constant label");
    }
}

# [perl #3112]
# The original report, which produced a Bizarre copy
@a  = ();
eval {
    for (1) {
        push @a, last;
    }
};
is @a, 0, 'push @a, last;  does not push';
is $@, "", 'no error, either';
# And my japh, which relied on the misbehaviour
is do{{&{sub{"Just another Perl hacker,\n"}},last}}, undef,
  'last returns nothing';
	Global
`s`	Focus search bar
`?`	Bring up this help dialog
	GitHub
`g` `p`	Go to pull requests
`g` `i`	go to github issues (only if github is preferred repository)
	POD
`g` `a`	Go to author
`g` `c`	Go to changes
`g` `i`	Go to issues
`g` `d`	Go to dist
`g` `r`	Go to repository/SCM
`g` `s`	Go to source
`g` `b`	Go to file browse
	Search terms
module: (e.g. module:Plugin)
distribution: (e.g. distribution:Dancer auth)
author: (e.g. author:SONGMU Redis)
version: (e.g. version:1.00)