t/op/do.t

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