1#!./perl
2
3BEGIN {
4    chdir 't' if -d 't';
5    require "./test.pl";
6    set_up_inc('../lib');
7}
8
9plan(26);
10
11my $tmpfile = tempfile();
12open (tmp,'>', $tmpfile) || die "Can't create Cmd_while.tmp.";
13print tmp "tvi925\n";
14print tmp "tvi920\n";
15print tmp "vt100\n";
16print tmp "Amiga\n";
17print tmp "paper\n";
18close tmp or die "Could not close: $!";
19
20# test "last" command
21
22open(fh, $tmpfile) || die "Can't open Cmd_while.tmp.";
23while (<fh>) {
24    last if /vt100/;
25}
26ok(!eof && /vt100/);
27
28# test "next" command
29
30$bad = '';
31open(fh, $tmpfile) || die "Can't open Cmd_while.tmp.";
32while (<fh>) {
33    next if /vt100/;
34    $bad = 1 if /vt100/;
35}
36ok(eof && !/vt100/ && !$bad);
37
38# test "redo" command
39
40$bad = '';
41open(fh,$tmpfile) || die "Can't open Cmd_while.tmp.";
42while (<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}
50ok(eof && !$bad);
51
52# now do the same with a label and a continue block
53
54# test "last" command
55
56$badcont = '';
57open(fh,$tmpfile) || die "Can't open Cmd_while.tmp.";
58line: while (<fh>) {
59    if (/vt100/) {last line;}
60} continue {
61    $badcont = 1 if /vt100/;
62}
63ok(!eof && /vt100/);
64ok(!$badcont);
65
66# test "next" command
67
68$bad = '';
69$badcont = 1;
70open(fh,$tmpfile) || die "Can't open Cmd_while.tmp.";
71entry: while (<fh>) {
72    next entry if /vt100/;
73    $bad = 1 if /vt100/;
74} continue {
75    $badcont = '' if /vt100/;
76}
77ok(eof && !/vt100/ && !$bad);
78ok(!$badcont);
79
80# test "redo" command
81
82$bad = '';
83$badcont = '';
84open(fh,$tmpfile) || die "Can't open Cmd_while.tmp.";
85loop: 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}
95ok(eof && !$bad);
96ok(!$badcont);
97
98close(fh) || die "Can't close Cmd_while.tmp.";
99
100$i = 9;
101{
102    $i++;
103}
104is($i, 10);
105
106# Check curpm is reset when jumping out of a scope
107$i = 0;
108'abc' =~ /b/;
109WHILE:
110while (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}
121is($` . $& . $', "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
181sub 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
218fresh_perl_is <<'72406', "foobar\n", {},
219{ package o; use overload bool => sub { die unless $::ok++; return 1 } }
220use constant OK => bless [], o::;
221do{print("foobar\n");}until OK;
22272406
223    "[perl #72406] segv with do{}until CONST where const is not folded";
224