t/op/do.t

   1 #!./perl -w
   2
   3 BEGIN {
   4     chdir 't';
   5     @INC = '../lib';
   6     require './test.pl';
   7 }
   8 use strict;
   9 no warnings 'void';
  10
  11 sub foo1
  12 {
  13     ok($_[0], 'in foo1');
  14     'value';
  15 }
  16
  17 sub foo2
  18 {
  19     shift;
  20     ok($_[0], 'in foo2');
  21     my $x = 'value';
  22     $x;
  23 }
  24
  25 my $result;
  26 $_[0] = 0;
  27 {
  28     no warnings 'deprecated';
  29     $result = do foo1(1);
  30 }
  31
  32 is($result, 'value', 'do &sub and proper @_ handling');
  33 cmp_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 }
  40 is($result, 'value', 'do &sub and proper @_ handling');
  41 cmp_ok($_[0], '==', 0, 'do &sub and proper @_ handling');
  42
  43 my $called;
  44 $result = do{ ++$called; 'value';};
  45 is($called, 1, 'do block called');
  46 is($result, 'value', 'do block returns correct value');
  47
  48 my @blathered;
  49 sub 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
  60 my @x = ("jeepers", "okydoke");
  61 my @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
  68 unshift @INC, '.';
  69
  70 my $file16 = tempfile();
  71 if (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
  77 my $a = do $file16; die $@ if $@;
  78
  79 my $file17 = tempfile();
  80 if (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
  86 my @a = do $file17; die $@ if $@;
  87
  88 my $file18 = tempfile();
  89 if (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
  94 do $file18; die $@ if $@;
  95
  96 # bug ID 20010920.007
  97 eval qq{ do qq(a file that does not exist); };
  98 is($@, '', "do on a non-existing file, first try");
  99
 100 eval qq{ do uc qq(a file that does not exist); };
 101 is($@, '', "do on a non-existing file, second try");
 102
 103 # 6 must be interpreted as a file name here
 104 $! = 0;
 105 my $do6 = do 6;
 106 my $errno = $1;
 107 is($do6, undef, 'do 6 must be interpreted as a filename');
 108 isnt($!, 0, 'and should set $!');
 109
 110 # [perl #19545]
 111 my ($u, @t);
 112 {
 113     no warnings 'uninitialized';
 114     push @t, ($u = (do {} . "This should be pushed."));
 115 }
 116 is($#t, 0, "empty do result value" );
 117
 118 my $zok = '';
 119 my $owww = do { 1 if $zok };
 120 is($owww, '', 'last is unless');
 121 $owww = do { 2 unless not $zok };
 122 is($owww, 1, 'last is if not');
 123
 124 $zok = 'swish';
 125 $owww = do { 3 unless $zok };
 126 is($owww, 'swish', 'last is unless');
 127 $owww = do { 4 if not $zok };
 128 is($owww, '', 'last is if not');
 129
 130 # [perl #38809]
 131 @a = (7);
 132 my $x = sub { do { return do { @a } }; 2 }->();
 133 is($x, 1, 'return do { } receives caller scalar context');
 134 @x = sub { do { return do { @a } }; 2 }->();
 135 is("@x", "7", 'return do { } receives caller list context');
 136
 137 @a = (7, 8);
 138 $x = sub { do { return do { 1; @a } }; 3 }->();
 139 is($x, 2, 'return do { ; } receives caller scalar context');
 140 @x = sub { do { return do { 1; @a } }; 3 }->();
 141 is("@x", "7 8", 'return do { ; } receives caller list context');
 142
 143 my @b = (11 .. 15);
 144 $x = sub { do { return do { 1; @a, @b } }; 3 }->();
 145 is($x, 5, 'return do { ; , } receives caller scalar context');
 146 @x = sub { do { return do { 1; @a, @b } }; 3 }->();
 147 is("@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 }->();
 150 is($x, 5, 'return do { ; }, do { ; } receives caller scalar context');
 151 @x = sub { do { return do { 1; @a }, do { 2; @b } }; 3 }->();
 152 is("@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 }->();
 156 is($x, 3, 'do { return } receives caller scalar context');
 157 @x = sub { do { do { 1; return @a } }; 4 }->();
 158 is("@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 }->();
 162 is($x, 4, 'return do { do { ; } } receives caller scalar context');
 163 @x = sub { do { return do { 1; do { 2; @a } } }; 5 }->();
 164 is("@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
 170 my $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);
 184 is($x, 2, 'return $y ? do { } : do { } - scalar context 1');
 185 $x = $test_code->(1, 0);
 186 is($x, 3, 'return $y ? do { } : do { } - scalar context 2');
 187 @x = $test_code->(1, 1);
 188 is("@x", '11 12', 'return $y ? do { } : do { } - list context 1');
 189 @x = $test_code->(1, 0);
 190 is("@x", '21 22 23', 'return $y ? do { } : do { } - list context 2');
 191
 192 $x = $test_code->(0, 0);
 193 is($x, "", 'return (do { }, (do { }) x ...) - scalar context 1');
 194 $x = $test_code->(0, 1);
 195 is($x, 3, 'return (do { }, (do { }) x ...) - scalar context 2');
 196 @x = $test_code->(0, 0);
 197 is("@x", '11 12', 'return (do { }, (do { }) x ...) - list context 1');
 198 @x = $test_code->(0, 1);
 199 is("@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);
 221 is($x, 2, 'return do { if () { } elsif () { } else { } } - scalar 1');
 222 $x = $test_code->(1, 1);
 223 is($x, 3, 'return do { if () { } elsif () { } else { } } - scalar 2');
 224 $x = $test_code->(1, 2);
 225 is($x, 99, 'return do { if () { } elsif () { } else { } } - scalar 3');
 226 @x = $test_code->(1, 0);
 227 is("@x", '11 12', 'return do { if () { } elsif () { } else { } } - list 1');
 228 @x = $test_code->(1, 1);
 229 is("@x", '21 22 23', 'return do { if () { } elsif () { } else { } } - list 2');
 230 @x = $test_code->(1, 2);
 231 is("@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 } }->();
 236 is($x, 20, 'if (1) { $x } receives caller scalar context');
 237
 238 @a = (21 .. 23);
 239 $x = sub { if (1) { @a } }->();
 240 is($x, 3, 'if (1) { @a } receives caller scalar context');
 241 @x = sub { if (1) { @a } }->();
 242 is("@x", "21 22 23", 'if (1) { @a } receives caller list context');
 243
 244 $x = sub { if (1) { 0; 20 } }->();
 245 is($x, 20, 'if (1) { ...; $x } receives caller scalar context');
 246
 247 @a = (24 .. 27);
 248 $x = sub { if (1) { 0; @a } }->();
 249 is($x, 4, 'if (1) { ...; @a } receives caller scalar context');
 250 @x = sub { if (1) { 0; @a } }->();
 251 is("@x", "24 25 26 27", 'if (1) { ...; @a } receives caller list context');
 252
 253 $x = sub { if (1) { 0; 20 } else{} }->();
 254 is($x, 20, 'if (1) { ...; $x } else{} receives caller scalar context');
 255
 256 @a = (24 .. 27);
 257 $x = sub { if (1) { 0; @a } else{} }->();
 258 is($x, 4, 'if (1) { ...; @a } else{} receives caller scalar context');
 259 @x = sub { if (1) { 0; @a } else{} }->();
 260 is("@x", "24 25 26 27", 'if (1) { ...; @a } else{} receives caller list context');
 261
 262 $x = sub { if (0){} else { 0; 20 } }->();
 263 is($x, 20, 'if (0){} else { ...; $x } receives caller scalar context');
 264
 265 @a = (24 .. 27);
 266 $x = sub { if (0){} else { 0; @a } }->();
 267 is($x, 4, 'if (0){} else { ...; @a } receives caller scalar context');
 268 @x = sub { if (0){} else { 0; @a } }->();
 269 is("@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
 272 SKIP: {
 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
 315 done_testing();