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