Jakub Wilk is now a Perl author.
[perl.git] / 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";