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