1#!./perl -w 2 3BEGIN { 4 chdir 't'; 5 @INC = '../lib'; 6 require './test.pl'; 7} 8use strict; 9no warnings 'void'; 10 11my $called; 12my $result = do{ ++$called; 'value';}; 13is($called, 1, 'do block called'); 14is($result, 'value', 'do block returns correct value'); 15 16unshift @INC, '.'; 17 18my $file16 = tempfile(); 19if (open my $do, '>', $file16) { 20 print $do "isnt(wantarray, undef, 'do in scalar context');\n"; 21 print $do "cmp_ok(wantarray, '==', 0, 'do in scalar context');\n"; 22 close $do or die "Could not close: $!"; 23} 24 25my $a = do $file16; die $@ if $@; 26 27my $file17 = tempfile(); 28if (open my $do, '>', $file17) { 29 print $do "isnt(wantarray, undef, 'do in list context');\n"; 30 print $do "cmp_ok(wantarray, '!=', 0, 'do in list context');\n"; 31 close $do or die "Could not close: $!"; 32} 33 34my @a = do $file17; die $@ if $@; 35 36my $file18 = tempfile(); 37if (open my $do, '>', $file18) { 38 print $do "is(wantarray, undef, 'do in void context');\n"; 39 close $do or die "Could not close: $!"; 40} 41 42do $file18; die $@ if $@; 43 44# bug ID 20010920.007 45eval qq{ do qq(a file that does not exist); }; 46is($@, '', "do on a non-existing file, first try"); 47 48eval qq{ do uc qq(a file that does not exist); }; 49is($@, '', "do on a non-existing file, second try"); 50 51# 6 must be interpreted as a file name here 52$! = 0; 53my $do6 = do 6; 54my $errno = $1; 55is($do6, undef, 'do 6 must be interpreted as a filename'); 56isnt($!, 0, 'and should set $!'); 57 58# [perl #19545] 59my ($u, @t); 60{ 61 no warnings 'uninitialized'; 62 push @t, ($u = (do {} . "This should be pushed.")); 63} 64is($#t, 0, "empty do result value" ); 65 66my $zok = ''; 67my $owww = do { 1 if $zok }; 68is($owww, '', 'last is unless'); 69$owww = do { 2 unless not $zok }; 70is($owww, 1, 'last is if not'); 71 72$zok = 'swish'; 73$owww = do { 3 unless $zok }; 74is($owww, 'swish', 'last is unless'); 75$owww = do { 4 if not $zok }; 76is($owww, '', 'last is if not'); 77 78# [perl #38809] 79@a = (7); 80my $x = sub { do { return do { @a } }; 2 }->(); 81is($x, 1, 'return do { } receives caller scalar context'); 82my @x = sub { do { return do { @a } }; 2 }->(); 83is("@x", "7", 'return do { } receives caller list context'); 84 85@a = (7, 8); 86$x = sub { do { return do { 1; @a } }; 3 }->(); 87is($x, 2, 'return do { ; } receives caller scalar context'); 88@x = sub { do { return do { 1; @a } }; 3 }->(); 89is("@x", "7 8", 'return do { ; } receives caller list context'); 90 91my @b = (11 .. 15); 92$x = sub { do { return do { 1; @a, @b } }; 3 }->(); 93is($x, 5, 'return do { ; , } receives caller scalar context'); 94@x = sub { do { return do { 1; @a, @b } }; 3 }->(); 95is("@x", "7 8 11 12 13 14 15", 'return do { ; , } receives caller list context'); 96 97$x = sub { do { return do { 1; @a }, do { 2; @b } }; 3 }->(); 98is($x, 5, 'return do { ; }, do { ; } receives caller scalar context'); 99@x = sub { do { return do { 1; @a }, do { 2; @b } }; 3 }->(); 100is("@x", "7 8 11 12 13 14 15", 'return do { ; }, do { ; } receives caller list context'); 101 102@a = (7, 8, 9); 103$x = sub { do { do { 1; return @a } }; 4 }->(); 104is($x, 3, 'do { return } receives caller scalar context'); 105@x = sub { do { do { 1; return @a } }; 4 }->(); 106is("@x", "7 8 9", 'do { return } receives caller list context'); 107 108@a = (7, 8, 9, 10); 109$x = sub { do { return do { 1; do { 2; @a } } }; 5 }->(); 110is($x, 4, 'return do { do { ; } } receives caller scalar context'); 111@x = sub { do { return do { 1; do { 2; @a } } }; 5 }->(); 112is("@x", "7 8 9 10", 'return do { do { ; } } receives caller list context'); 113 114# More tests about context propagation below return() 115@a = (11, 12); 116@b = (21, 22, 23); 117 118my $test_code = sub { 119 my ($x, $y) = @_; 120 if ($x) { 121 return $y ? do { my $z; @a } : do { my $z; @b }; 122 } else { 123 return ( 124 do { my $z; @a }, 125 (do { my$z; @b }) x $y 126 ); 127 } 128 'xxx'; 129}; 130 131$x = $test_code->(1, 1); 132is($x, 2, 'return $y ? do { } : do { } - scalar context 1'); 133$x = $test_code->(1, 0); 134is($x, 3, 'return $y ? do { } : do { } - scalar context 2'); 135@x = $test_code->(1, 1); 136is("@x", '11 12', 'return $y ? do { } : do { } - list context 1'); 137@x = $test_code->(1, 0); 138is("@x", '21 22 23', 'return $y ? do { } : do { } - list context 2'); 139 140$x = $test_code->(0, 0); 141is($x, "", 'return (do { }, (do { }) x ...) - scalar context 1'); 142$x = $test_code->(0, 1); 143is($x, 3, 'return (do { }, (do { }) x ...) - scalar context 2'); 144@x = $test_code->(0, 0); 145is("@x", '11 12', 'return (do { }, (do { }) x ...) - list context 1'); 146@x = $test_code->(0, 1); 147is("@x", '11 12 21 22 23', 'return (do { }, (do { }) x ...) - list context 2'); 148 149$test_code = sub { 150 my ($x, $y) = @_; 151 if ($x) { 152 return do { 153 if ($y == 0) { 154 my $z; 155 @a; 156 } elsif ($y == 1) { 157 my $z; 158 @b; 159 } else { 160 my $z; 161 (wantarray ? reverse(@a) : '99'); 162 } 163 }; 164 } 165 'xxx'; 166}; 167 168$x = $test_code->(1, 0); 169is($x, 2, 'return do { if () { } elsif () { } else { } } - scalar 1'); 170$x = $test_code->(1, 1); 171is($x, 3, 'return do { if () { } elsif () { } else { } } - scalar 2'); 172$x = $test_code->(1, 2); 173is($x, 99, 'return do { if () { } elsif () { } else { } } - scalar 3'); 174@x = $test_code->(1, 0); 175is("@x", '11 12', 'return do { if () { } elsif () { } else { } } - list 1'); 176@x = $test_code->(1, 1); 177is("@x", '21 22 23', 'return do { if () { } elsif () { } else { } } - list 2'); 178@x = $test_code->(1, 2); 179is("@x", '12 11', 'return do { if () { } elsif () { } else { } } - list 3'); 180 181# Do blocks created by constant folding 182# [perl #68108] 183$x = sub { if (1) { 20 } }->(); 184is($x, 20, 'if (1) { $x } receives caller scalar context'); 185 186@a = (21 .. 23); 187$x = sub { if (1) { @a } }->(); 188is($x, 3, 'if (1) { @a } receives caller scalar context'); 189@x = sub { if (1) { @a } }->(); 190is("@x", "21 22 23", 'if (1) { @a } receives caller list context'); 191 192$x = sub { if (1) { 0; 20 } }->(); 193is($x, 20, 'if (1) { ...; $x } receives caller scalar context'); 194 195@a = (24 .. 27); 196$x = sub { if (1) { 0; @a } }->(); 197is($x, 4, 'if (1) { ...; @a } receives caller scalar context'); 198@x = sub { if (1) { 0; @a } }->(); 199is("@x", "24 25 26 27", 'if (1) { ...; @a } receives caller list context'); 200 201$x = sub { if (1) { 0; 20 } else{} }->(); 202is($x, 20, 'if (1) { ...; $x } else{} receives caller scalar context'); 203 204@a = (24 .. 27); 205$x = sub { if (1) { 0; @a } else{} }->(); 206is($x, 4, 'if (1) { ...; @a } else{} receives caller scalar context'); 207@x = sub { if (1) { 0; @a } else{} }->(); 208is("@x", "24 25 26 27", 'if (1) { ...; @a } else{} receives caller list context'); 209 210$x = sub { if (0){} else { 0; 20 } }->(); 211is($x, 20, 'if (0){} else { ...; $x } receives caller scalar context'); 212 213@a = (24 .. 27); 214$x = sub { if (0){} else { 0; @a } }->(); 215is($x, 4, 'if (0){} else { ...; @a } receives caller scalar context'); 216@x = sub { if (0){} else { 0; @a } }->(); 217is("@x", "24 25 26 27", 'if (0){} else { ...; @a } receives caller list context'); 218 219# [rt.cpan.org #72767] do "string" should not propagate warning hints 220SKIP: { 221 skip_if_miniperl("no in-memory files under miniperl", 1); 222 223 my $code = '42; 1'; 224 # Based on Eval::WithLexicals::_eval_do 225 local @INC = (sub { 226 if ($_[1] eq '/eval_do') { 227 open my $fh, '<', \$code; 228 $fh; 229 } else { 230 (); 231 } 232 }, @INC); 233 local $^W; 234 use warnings; 235 my $w; 236 local $SIG{__WARN__} = sub { warn shift; ++$w }; 237 do '/eval_do' or die $@; 238 is($w, undef, 'do STRING does not propagate warning hints'); 239} 240 241# RT#113730 - $@ should be cleared on IO error. 242{ 243 $@ = "should not see"; 244 $! = 0; 245 my $rv = do("some nonexistent file"); 246 my $saved_error = $@; 247 my $saved_errno = $!; 248 ok(!$rv, "do returns false on io errror"); 249 ok(!$saved_error, "\$\@ not set on io error"); 250 ok($saved_errno, "\$! set on io error"); 251} 252 253# do subname should not be do "subname" 254{ 255 my $called; 256 sub fungi { $called .= "fungible" } 257 $@ = "scrimptious scrobblings"; 258 do fungi; 259 is $called, "fungible", "do-file does not force bareword"; 260 isnt $@, "scrimptious scrobblings", "It was interpreted as do-file"; 261} 262 263# do CORE () has always been do-file 264{ 265 my $called; 266 sub CORE { $called .= "fungible" } 267 $@ = "scromptious scrimblings"; 268 do CORE(); 269 is $called, "fungible", "do CORE() calls &CORE"; 270 isnt $@, "scromptious scrimblings", "It was interpreted as do-file"; 271} 272 273# do subname() and $subname() are no longer allowed 274{ 275 sub subname { fail('do subname('. ($_[0] || '') .') called') }; 276 my $subref = sub { fail('do $subref('. ($_[0] || '') .') called') }; 277 foreach my $mode (qw(subname("arg") subname() $subref("arg") $subref())) { 278 eval "do $mode"; 279 like $@, qr/\Asyntax error/, "do $mode is syntax error"; 280 } 281} 282 283done_testing(); 284