t/op/while.t

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