t/op/while.t

   1 #!./perl
   2
   3 BEGIN {
   4     chdir 't';
   5     require "test.pl";
   6 }
   7
   8 plan(25);
   9
  10 my $tmpfile = tempfile();
  11 open (tmp,'>', $tmpfile) || die "Can't create Cmd_while.tmp.";
  12 print tmp "tvi925\n";
  13 print tmp "tvi920\n";
  14 print tmp "vt100\n";
  15 print tmp "Amiga\n";
  16 print tmp "paper\n";
  17 close tmp or die "Could not close: $!";
  18
  19 # test "last" command
  20
  21 open(fh, $tmpfile) || die "Can't open Cmd_while.tmp.";
  22 while (<fh>) {
  23     last if /vt100/;
  24 }
  25 ok(!eof && /vt100/);
  26
  27 # test "next" command
  28
  29 $bad = '';
  30 open(fh, $tmpfile) || die "Can't open Cmd_while.tmp.";
  31 while (<fh>) {
  32     next if /vt100/;
  33     $bad = 1 if /vt100/;
  34 }
  35 ok(eof && !/vt100/ && !$bad);
  36
  37 # test "redo" command
  38
  39 $bad = '';
  40 open(fh,$tmpfile) || die "Can't open Cmd_while.tmp.";
  41 while (<fh>) {
  42     if (s/vt100/VT100/g) {
  43         s/VT100/Vt100/g;
  44         redo;
  45     }
  46     $bad = 1 if /vt100/;
  47     $bad = 1 if /VT100/;
  48 }
  49 ok(eof && !$bad);
  50
  51 # now do the same with a label and a continue block
  52
  53 # test "last" command
  54
  55 $badcont = '';
  56 open(fh,$tmpfile) || die "Can't open Cmd_while.tmp.";
  57 line: while (<fh>) {
  58     if (/vt100/) {last line;}
  59 } continue {
  60     $badcont = 1 if /vt100/;
  61 }
  62 ok(!eof && /vt100/);
  63 ok(!$badcont);
  64
  65 # test "next" command
  66
  67 $bad = '';
  68 $badcont = 1;
  69 open(fh,$tmpfile) || die "Can't open Cmd_while.tmp.";
  70 entry: while (<fh>) {
  71     next entry if /vt100/;
  72     $bad = 1 if /vt100/;
  73 } continue {
  74     $badcont = '' if /vt100/;
  75 }
  76 ok(eof && !/vt100/ && !$bad);
  77 ok(!$badcont);
  78
  79 # test "redo" command
  80
  81 $bad = '';
  82 $badcont = '';
  83 open(fh,$tmpfile) || die "Can't open Cmd_while.tmp.";
  84 loop: while (<fh>) {
  85     if (s/vt100/VT100/g) {
  86         s/VT100/Vt100/g;
  87         redo loop;
  88     }
  89     $bad = 1 if /vt100/;
  90     $bad = 1 if /VT100/;
  91 } continue {
  92     $badcont = 1 if /vt100/;
  93 }
  94 ok(eof && !$bad);
  95 ok(!$badcont);
  96
  97 close(fh) || die "Can't close Cmd_while.tmp.";
  98
  99 $i = 9;
 100 {
 101     $i++;
 102 }
 103 is($i, 10);
 104
 105 # Check curpm is reset when jumping out of a scope
 106 $i = 0;
 107 'abc' =~ /b/;
 108 WHILE:
 109 while (1) {
 110   $i++;
 111   is($` . $& . $', "abc");
 112   {                             # Localize changes to $` and friends
 113     'end' =~ /end/;
 114     redo WHILE if $i == 1;
 115     next WHILE if $i == 2;
 116     # 3 do a normal loop
 117     last WHILE if $i == 4;
 118   }
 119 }
 120 is($` . $& . $', "abc");
 121
 122 # check that scope cleanup happens right when there's a continue block
 123 {
 124     my $var = 16;
 125     my (@got_var, @got_i);
 126     while (my $i = ++$var) {
 127         next if $i == 17;
 128         last if $i > 17;
 129         my $i = 0;
 130     }
 131     continue {
 132         ($got_var, $got_i) = ($var, $i);
 133     }
 134     is($got_var, 17);
 135     is($got_i, 17);
 136 }
 137
 138 {
 139     my $got_l;
 140     local $l = 18;
 141     {
 142         local $l = 0
 143     }
 144     continue {
 145         $got_l = $l;
 146     }
 147     is($got_l, 18);
 148 }
 149
 150 {
 151     my $got_l;
 152     local $l = 19;
 153     my $x = 0;
 154     while (!$x++) {
 155         local $l = 0
 156     }
 157     continue {
 158         $got_l = $l;
 159     }
 160     is($got_l, $l);
 161 }
 162
 163 {
 164     my $ok = 1;
 165     $i = 20;
 166     while (1) {
 167         my $x;
 168         $ok = 0 if defined $x;
 169         if ($i == 21) {
 170             next;
 171         }
 172         last;
 173     }
 174     continue {
 175         ++$i;
 176     }
 177     ok($ok);
 178 }
 179
 180 sub save_context { $_[0] = wantarray; $_[1] }
 181
 182 {
 183     my $context = -1;
 184     my $p = sub {
 185         my $x = 1;
 186         while ($x--) {
 187             save_context($context, "foo");
 188         }
 189     };
 190     is(scalar($p->()), 0);
 191     is($context, undef, "last statement in while block has 'void' context");
 192 }
 193
 194 {
 195     my $context = -1;
 196     my $p = sub {
 197         my $x = 1;
 198         {
 199             save_context($context, "foo");
 200         }
 201     };
 202     is(scalar($p->()), "foo");
 203     is($context, "", "last statement in block has 'scalar' context");
 204 }
 205
 206 {
 207     # test scope is cleaned
 208     my $i = 0;
 209     my @a;
 210     while ($i++ < 2) {
 211         my $x;
 212         push @a, \$x;
 213     }
 214     ok($a[0] ne $a[1]);
 215 }