This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Let while.t run from the top level
[perl5.git] / t / cmd / 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 }