21 # You have to do it this way or VMS will get confused.
22 printf "%s %d%s\n", $ok ? "ok" : "not ok",
24 defined $name ? " - $name" : '';
26 printf "# Failed test at line %d\n", (caller)[2] unless $ok;
34 # Test do &sub and proper @_ handling.
37 no warnings 'deprecated';
41 ok( $result eq 'value', ":$result: eq :value:" );
46 no warnings 'deprecated';
47 $result = do foo2(0,1,0);
49 ok( $result eq 'value', ":$result: eq :value:" );
52 $result = do{ ok 1; 'value';};
53 ok( $result eq 'value', ":$result: eq :value:" );
60 no warnings 'deprecated';
61 do blather("ayep","sho nuff");
63 @x = ("jeepers", "okydoke");
64 @y = ("uhhuh", "yeppers");
66 no warnings 'deprecated';
67 do blather(@x,"noofie",@y);
72 if (open(DO, ">$$.16")) {
73 print DO "ok(1, 'do in scalar context') if defined wantarray && not wantarray\n";
74 close DO or die "Could not close: $!";
77 my $a = do "$$.16"; die $@ if $@;
79 if (open(DO, ">$$.17")) {
80 print DO "ok(1, 'do in list context') if defined wantarray && wantarray\n";
81 close DO or die "Could not close: $!";
84 my @a = do "$$.17"; die $@ if $@;
86 if (open(DO, ">$$.18")) {
87 print DO "ok(1, 'do in void context') if not defined wantarray\n";
88 close DO or die "Could not close: $!";
91 do "$$.18"; die $@ if $@;
94 eval qq{ do qq(a file that does not exist); };
95 ok( !$@, "do on a non-existing file, first try" );
97 eval qq{ do uc qq(a file that does not exist); };
98 ok( !$@, "do on a non-existing file, second try" );
100 # 6 must be interpreted as a file name here
101 ok( (!defined do 6) && $!, "'do 6' : $!" );
104 push @t, ($u = (do {} . "This should be pushed."));
105 ok( $#t == 0, "empty do result value" );
108 $owww = do { 1 if $zok };
109 ok( $owww eq '', 'last is unless' );
110 $owww = do { 2 unless not $zok };
111 ok( $owww == 1, 'last is if not' );
114 $owww = do { 3 unless $zok };
115 ok( $owww eq 'swish', 'last is unless' );
116 $owww = do { 4 if not $zok };
117 ok( $owww eq '', 'last is if not' );
121 $x = sub { do { return do { @a } }; 2 }->();
122 ok(defined $x && $x == 1, 'return do { } receives caller scalar context');
123 @x = sub { do { return do { @a } }; 2 }->();
124 ok("@x" eq "7", 'return do { } receives caller list context');
127 $x = sub { do { return do { 1; @a } }; 3 }->();
128 ok(defined $x && $x == 2, 'return do { ; } receives caller scalar context');
129 @x = sub { do { return do { 1; @a } }; 3 }->();
130 ok("@x" eq "7 8", 'return do { ; } receives caller list context');
133 $x = sub { do { return do { 1; @a, @b } }; 3 }->();
134 ok(defined $x && $x == 5, 'return do { ; , } receives caller scalar context');
135 @x = sub { do { return do { 1; @a, @b } }; 3 }->();
136 ok("@x" eq "7 8 11 12 13 14 15", 'return do { ; , } receives caller list context');
138 $x = sub { do { return do { 1; @a }, do { 2; @b } }; 3 }->();
139 ok(defined $x && $x == 5, 'return do { ; }, do { ; } receives caller scalar context');
140 @x = sub { do { return do { 1; @a }, do { 2; @b } }; 3 }->();
141 ok("@x" eq "7 8 11 12 13 14 15", 'return do { ; }, do { ; } receives caller list context');
144 $x = sub { do { do { 1; return @a } }; 4 }->();
145 ok(defined $x && $x == 3, 'do { return } receives caller scalar context');
146 @x = sub { do { do { 1; return @a } }; 4 }->();
147 ok("@x" eq "7 8 9", 'do { return } receives caller list context');
150 $x = sub { do { return do { 1; do { 2; @a } } }; 5 }->();
151 ok(defined $x && $x == 4, 'return do { do { ; } } receives caller scalar context');
152 @x = sub { do { return do { 1; do { 2; @a } } }; 5 }->();
153 ok("@x" eq "7 8 9 10", 'return do { do { ; } } receives caller list context');
155 # Do blocks created by constant folding
157 $x = sub { if (1) { 20 } }->();
158 ok($x == 20, 'if (1) { $x } receives caller scalar context');
161 $x = sub { if (1) { @a } }->();
162 ok($x == 3, 'if (1) { @a } receives caller scalar context');
163 @x = sub { if (1) { @a } }->();
164 ok("@x" eq "21 22 23", 'if (1) { @a } receives caller list context');
166 $x = sub { if (1) { 0; 20 } }->();
167 ok($x == 20, 'if (1) { ...; $x } receives caller scalar context');
170 $x = sub { if (1) { 0; @a } }->();
171 ok($x == 4, 'if (1) { ...; @a } receives caller scalar context');
172 @x = sub { if (1) { 0; @a } }->();
173 ok("@x" eq "24 25 26 27", 'if (1) { ...; @a } receives caller list context');
175 $x = sub { if (1) { 0; 20 } else{} }->();
176 ok($x == 20, 'if (1) { ...; $x } else{} receives caller scalar context');
179 $x = sub { if (1) { 0; @a } else{} }->();
180 ok($x == 4, 'if (1) { ...; @a } else{} receives caller scalar context');
181 @x = sub { if (1) { 0; @a } else{} }->();
182 ok("@x" eq "24 25 26 27", 'if (1) { ...; @a } else{} receives caller list context');
184 $x = sub { if (0){} else { 0; 20 } }->();
185 ok($x == 20, 'if (0){} else { ...; $x } receives caller scalar context');
188 $x = sub { if (0){} else { 0; @a } }->();
189 ok($x == 4, 'if (0){} else { ...; @a } receives caller scalar context');
190 @x = sub { if (0){} else { 0; @a } }->();
191 ok("@x" eq "24 25 26 27", 'if (0){} else { ...; @a } receives caller list context');
195 1 while unlink("$$.16", "$$.17", "$$.18");