t/cmd/while.t

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