t/op/do.t

   1 #!./perl -w
   2
   3 BEGIN {
   4     chdir 't' if -d 't';
   5     require './test.pl';
   6     set_up_inc( '../lib' );
   7 }
   8 use strict;
   9 no warnings 'void';
  10 use Errno qw(ENOENT EISDIR);
  11
  12 my $called;
  13 my $result = do{ ++$called; 'value';};
  14 is($called, 1, 'do block called');
  15 is($result, 'value', 'do block returns correct value');
  16
  17 unshift @INC, '.';
  18
  19 my $file16 = tempfile();
  20 if (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
  26 my $a = do $file16; die $@ if $@;
  27
  28 my $file17 = tempfile();
  29 if (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
  35 my @a = do $file17; die $@ if $@;
  36
  37 my $file18 = tempfile();
  38 if (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
  43 do $file18; die $@ if $@;
  44
  45 # bug ID 20010920.007 (#7713)
  46 eval qq{ do qq(a file that does not exist); };
  47 is($@, '', "do on a non-existing file, first try");
  48
  49 eval qq{ do uc qq(a file that does not exist); };
  50 is($@, '', "do on a non-existing file, second try");
  51
  52 # 6 must be interpreted as a file name here
  53 $! = 0;
  54 my $do6 = do 6;
  55 my $errno = $1;
  56 is($do6, undef, 'do 6 must be interpreted as a filename');
  57 isnt($!, 0, 'and should set $!');
  58
  59 # [perl #19545]
  60 my ($u, @t);
  61 {
  62     no warnings 'uninitialized';
  63     push @t, ($u = (do {} . "This should be pushed."));
  64 }
  65 is($#t, 0, "empty do result value" );
  66
  67 my $zok = '';
  68 my $owww = do { 1 if $zok };
  69 is($owww, '', 'last is unless');
  70 $owww = do { 2 unless not $zok };
  71 is($owww, 1, 'last is if not');
  72
  73 $zok = 'swish';
  74 $owww = do { 3 unless $zok };
  75 is($owww, 'swish', 'last is unless');
  76 $owww = do { 4 if not $zok };
  77 is($owww, '', 'last is if not');
  78
  79 # [perl #38809]
  80 @a = (7);
  81 my $x = sub { do { return do { @a } }; 2 }->();
  82 is($x, 1, 'return do { } receives caller scalar context');
  83 my @x = sub { do { return do { @a } }; 2 }->();
  84 is("@x", "7", 'return do { } receives caller list context');
  85
  86 @a = (7, 8);
  87 $x = sub { do { return do { 1; @a } }; 3 }->();
  88 is($x, 2, 'return do { ; } receives caller scalar context');
  89 @x = sub { do { return do { 1; @a } }; 3 }->();
  90 is("@x", "7 8", 'return do { ; } receives caller list context');
  91
  92 my @b = (11 .. 15);
  93 $x = sub { do { return do { 1; @a, @b } }; 3 }->();
  94 is($x, 5, 'return do { ; , } receives caller scalar context');
  95 @x = sub { do { return do { 1; @a, @b } }; 3 }->();
  96 is("@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 }->();
  99 is($x, 5, 'return do { ; }, do { ; } receives caller scalar context');
 100 @x = sub { do { return do { 1; @a }, do { 2; @b } }; 3 }->();
 101 is("@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 }->();
 105 is($x, 3, 'do { return } receives caller scalar context');
 106 @x = sub { do { do { 1; return @a } }; 4 }->();
 107 is("@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 }->();
 111 is($x, 4, 'return do { do { ; } } receives caller scalar context');
 112 @x = sub { do { return do { 1; do { 2; @a } } }; 5 }->();
 113 is("@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
 119 my $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);
 133 is($x, 2, 'return $y ? do { } : do { } - scalar context 1');
 134 $x = $test_code->(1, 0);
 135 is($x, 3, 'return $y ? do { } : do { } - scalar context 2');
 136 @x = $test_code->(1, 1);
 137 is("@x", '11 12', 'return $y ? do { } : do { } - list context 1');
 138 @x = $test_code->(1, 0);
 139 is("@x", '21 22 23', 'return $y ? do { } : do { } - list context 2');
 140
 141 $x = $test_code->(0, 0);
 142 is($x, "", 'return (do { }, (do { }) x ...) - scalar context 1');
 143 $x = $test_code->(0, 1);
 144 is($x, 3, 'return (do { }, (do { }) x ...) - scalar context 2');
 145 @x = $test_code->(0, 0);
 146 is("@x", '11 12', 'return (do { }, (do { }) x ...) - list context 1');
 147 @x = $test_code->(0, 1);
 148 is("@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);
 170 is($x, 2, 'return do { if () { } elsif () { } else { } } - scalar 1');
 171 $x = $test_code->(1, 1);
 172 is($x, 3, 'return do { if () { } elsif () { } else { } } - scalar 2');
 173 $x = $test_code->(1, 2);
 174 is($x, 99, 'return do { if () { } elsif () { } else { } } - scalar 3');
 175 @x = $test_code->(1, 0);
 176 is("@x", '11 12', 'return do { if () { } elsif () { } else { } } - list 1');
 177 @x = $test_code->(1, 1);
 178 is("@x", '21 22 23', 'return do { if () { } elsif () { } else { } } - list 2');
 179 @x = $test_code->(1, 2);
 180 is("@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 } }->();
 185 is($x, 20, 'if (1) { $x } receives caller scalar context');
 186
 187 @a = (21 .. 23);
 188 $x = sub { if (1) { @a } }->();
 189 is($x, 3, 'if (1) { @a } receives caller scalar context');
 190 @x = sub { if (1) { @a } }->();
 191 is("@x", "21 22 23", 'if (1) { @a } receives caller list context');
 192
 193 $x = sub { if (1) { 0; 20 } }->();
 194 is($x, 20, 'if (1) { ...; $x } receives caller scalar context');
 195
 196 @a = (24 .. 27);
 197 $x = sub { if (1) { 0; @a } }->();
 198 is($x, 4, 'if (1) { ...; @a } receives caller scalar context');
 199 @x = sub { if (1) { 0; @a } }->();
 200 is("@x", "24 25 26 27", 'if (1) { ...; @a } receives caller list context');
 201
 202 $x = sub { if (1) { 0; 20 } else{} }->();
 203 is($x, 20, 'if (1) { ...; $x } else{} receives caller scalar context');
 204
 205 @a = (24 .. 27);
 206 $x = sub { if (1) { 0; @a } else{} }->();
 207 is($x, 4, 'if (1) { ...; @a } else{} receives caller scalar context');
 208 @x = sub { if (1) { 0; @a } else{} }->();
 209 is("@x", "24 25 26 27", 'if (1) { ...; @a } else{} receives caller list context');
 210
 211 $x = sub { if (0){} else { 0; 20 } }->();
 212 is($x, 20, 'if (0){} else { ...; $x } receives caller scalar context');
 213
 214 @a = (24 .. 27);
 215 $x = sub { if (0){} else { 0; @a } }->();
 216 is($x, 4, 'if (0){} else { ...; @a } receives caller scalar context');
 217 @x = sub { if (0){} else { 0; @a } }->();
 218 is("@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
 221 SKIP: {
 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
 320 done_testing();