Commit | Line | Data |
---|---|---|
a0c9a42a NC |
1 | #!./perl -w |
2 | ||
3 | require './test.pl'; | |
4 | use strict; | |
5 | no warnings 'void'; | |
8d063cd8 | 6 | |
8d063cd8 LW |
7 | sub foo1 |
8 | { | |
a0c9a42a | 9 | ok($_[0], 'in foo1'); |
8d063cd8 LW |
10 | 'value'; |
11 | } | |
12 | ||
13 | sub foo2 | |
14 | { | |
6d4ff0d2 | 15 | shift; |
a0c9a42a NC |
16 | ok($_[0], 'in foo2'); |
17 | my $x = 'value'; | |
8d063cd8 LW |
18 | $x; |
19 | } | |
20 | ||
a0c9a42a | 21 | my $result; |
5d96a5e0 | 22 | $_[0] = 0; |
96ccdd02 NC |
23 | { |
24 | no warnings 'deprecated'; | |
25 | $result = do foo1(1); | |
26 | } | |
8d063cd8 | 27 | |
a0c9a42a NC |
28 | is($result, 'value', 'do &sub and proper @_ handling'); |
29 | cmp_ok($_[0], '==', 0, 'do &sub and proper @_ handling'); | |
8d063cd8 | 30 | |
5d96a5e0 | 31 | $_[0] = 0; |
96ccdd02 NC |
32 | { |
33 | no warnings 'deprecated'; | |
34 | $result = do foo2(0,1,0); | |
35 | } | |
a0c9a42a NC |
36 | is($result, 'value', 'do &sub and proper @_ handling'); |
37 | cmp_ok($_[0], '==', 0, 'do &sub and proper @_ handling'); | |
5d96a5e0 | 38 | |
a0c9a42a NC |
39 | my $called; |
40 | $result = do{ ++$called; 'value';}; | |
41 | is($called, 1, 'do block called'); | |
42 | is($result, 'value', 'do block returns correct value'); | |
378cc40b | 43 | |
a0c9a42a | 44 | my @blathered; |
378cc40b | 45 | sub blather { |
a0c9a42a | 46 | push @blathered, $_ foreach @_; |
378cc40b LW |
47 | } |
48 | ||
96ccdd02 NC |
49 | { |
50 | no warnings 'deprecated'; | |
51 | do blather("ayep","sho nuff"); | |
a0c9a42a | 52 | is("@blathered", "ayep sho nuff", 'blathered called with list'); |
96ccdd02 | 53 | } |
a0c9a42a NC |
54 | @blathered = (); |
55 | ||
56 | my @x = ("jeepers", "okydoke"); | |
57 | my @y = ("uhhuh", "yeppers"); | |
96ccdd02 NC |
58 | { |
59 | no warnings 'deprecated'; | |
60 | do blather(@x,"noofie",@y); | |
a0c9a42a | 61 | is("@blathered", "@x noofie @y", 'blathered called with arrays too'); |
96ccdd02 | 62 | } |
df739378 JH |
63 | |
64 | unshift @INC, '.'; | |
65 | ||
a0c9a42a NC |
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: $!"; | |
df739378 JH |
71 | } |
72 | ||
a0c9a42a | 73 | my $a = do $file16; die $@ if $@; |
df739378 | 74 | |
a0c9a42a NC |
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: $!"; | |
df739378 JH |
80 | } |
81 | ||
a0c9a42a | 82 | my @a = do $file17; die $@ if $@; |
df739378 | 83 | |
a0c9a42a NC |
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: $!"; | |
df739378 JH |
88 | } |
89 | ||
a0c9a42a | 90 | do $file18; die $@ if $@; |
df739378 | 91 | |
5d96a5e0 MS |
92 | # bug ID 20010920.007 |
93 | eval qq{ do qq(a file that does not exist); }; | |
a0c9a42a | 94 | is($@, '', "do on a non-existing file, first try"); |
5d96a5e0 MS |
95 | |
96 | eval qq{ do uc qq(a file that does not exist); }; | |
a0c9a42a | 97 | is($@, '', "do on a non-existing file, second try"); |
5d96a5e0 | 98 | |
d4a8e56c | 99 | # 6 must be interpreted as a file name here |
a0c9a42a NC |
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 $!'); | |
d4a8e56c | 105 | |
db80722a | 106 | # [perl #19545] |
a0c9a42a NC |
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" ); | |
db80722a | 113 | |
a0c9a42a NC |
114 | my $zok = ''; |
115 | my $owww = do { 1 if $zok }; | |
116 | is($owww, '', 'last is unless'); | |
edbe35ea | 117 | $owww = do { 2 unless not $zok }; |
a0c9a42a | 118 | is($owww, 1, 'last is if not'); |
edbe35ea VP |
119 | |
120 | $zok = 'swish'; | |
121 | $owww = do { 3 unless $zok }; | |
a0c9a42a | 122 | is($owww, 'swish', 'last is unless'); |
edbe35ea | 123 | $owww = do { 4 if not $zok }; |
a0c9a42a | 124 | is($owww, '', 'last is if not'); |
edbe35ea | 125 | |
e91684bf | 126 | # [perl #38809] |
1c8a4223 | 127 | @a = (7); |
a0c9a42a NC |
128 | my $x = sub { do { return do { @a } }; 2 }->(); |
129 | is($x, 1, 'return do { } receives caller scalar context'); | |
1c8a4223 | 130 | @x = sub { do { return do { @a } }; 2 }->(); |
a0c9a42a | 131 | is("@x", "7", 'return do { } receives caller list context'); |
1c8a4223 | 132 | |
e91684bf VP |
133 | @a = (7, 8); |
134 | $x = sub { do { return do { 1; @a } }; 3 }->(); | |
a0c9a42a | 135 | is($x, 2, 'return do { ; } receives caller scalar context'); |
e91684bf | 136 | @x = sub { do { return do { 1; @a } }; 3 }->(); |
a0c9a42a | 137 | is("@x", "7 8", 'return do { ; } receives caller list context'); |
1c8a4223 | 138 | |
a0c9a42a | 139 | my @b = (11 .. 15); |
1c8a4223 | 140 | $x = sub { do { return do { 1; @a, @b } }; 3 }->(); |
a0c9a42a | 141 | is($x, 5, 'return do { ; , } receives caller scalar context'); |
1c8a4223 | 142 | @x = sub { do { return do { 1; @a, @b } }; 3 }->(); |
a0c9a42a | 143 | is("@x", "7 8 11 12 13 14 15", 'return do { ; , } receives caller list context'); |
1c8a4223 VP |
144 | |
145 | $x = sub { do { return do { 1; @a }, do { 2; @b } }; 3 }->(); | |
a0c9a42a | 146 | is($x, 5, 'return do { ; }, do { ; } receives caller scalar context'); |
1c8a4223 | 147 | @x = sub { do { return do { 1; @a }, do { 2; @b } }; 3 }->(); |
a0c9a42a | 148 | is("@x", "7 8 11 12 13 14 15", 'return do { ; }, do { ; } receives caller list context'); |
1c8a4223 | 149 | |
e91684bf VP |
150 | @a = (7, 8, 9); |
151 | $x = sub { do { do { 1; return @a } }; 4 }->(); | |
a0c9a42a | 152 | is($x, 3, 'do { return } receives caller scalar context'); |
e91684bf | 153 | @x = sub { do { do { 1; return @a } }; 4 }->(); |
a0c9a42a | 154 | is("@x", "7 8 9", 'do { return } receives caller list context'); |
1c8a4223 | 155 | |
e91684bf VP |
156 | @a = (7, 8, 9, 10); |
157 | $x = sub { do { return do { 1; do { 2; @a } } }; 5 }->(); | |
a0c9a42a | 158 | is($x, 4, 'return do { do { ; } } receives caller scalar context'); |
e91684bf | 159 | @x = sub { do { return do { 1; do { 2; @a } } }; 5 }->(); |
a0c9a42a | 160 | is("@x", "7 8 9 10", 'return do { do { ; } } receives caller list context'); |
e91684bf | 161 | |
dd3e51dc VP |
162 | # Do blocks created by constant folding |
163 | # [perl #68108] | |
164 | $x = sub { if (1) { 20 } }->(); | |
a0c9a42a | 165 | is($x, 20, 'if (1) { $x } receives caller scalar context'); |
dd3e51dc VP |
166 | |
167 | @a = (21 .. 23); | |
168 | $x = sub { if (1) { @a } }->(); | |
a0c9a42a | 169 | is($x, 3, 'if (1) { @a } receives caller scalar context'); |
dd3e51dc | 170 | @x = sub { if (1) { @a } }->(); |
a0c9a42a | 171 | is("@x", "21 22 23", 'if (1) { @a } receives caller list context'); |
dd3e51dc VP |
172 | |
173 | $x = sub { if (1) { 0; 20 } }->(); | |
a0c9a42a | 174 | is($x, 20, 'if (1) { ...; $x } receives caller scalar context'); |
dd3e51dc VP |
175 | |
176 | @a = (24 .. 27); | |
177 | $x = sub { if (1) { 0; @a } }->(); | |
a0c9a42a | 178 | is($x, 4, 'if (1) { ...; @a } receives caller scalar context'); |
dd3e51dc | 179 | @x = sub { if (1) { 0; @a } }->(); |
a0c9a42a | 180 | is("@x", "24 25 26 27", 'if (1) { ...; @a } receives caller list context'); |
dd3e51dc | 181 | |
ef9da979 | 182 | $x = sub { if (1) { 0; 20 } else{} }->(); |
a0c9a42a | 183 | is($x, 20, 'if (1) { ...; $x } else{} receives caller scalar context'); |
ef9da979 FC |
184 | |
185 | @a = (24 .. 27); | |
186 | $x = sub { if (1) { 0; @a } else{} }->(); | |
a0c9a42a | 187 | is($x, 4, 'if (1) { ...; @a } else{} receives caller scalar context'); |
ef9da979 | 188 | @x = sub { if (1) { 0; @a } else{} }->(); |
a0c9a42a | 189 | is("@x", "24 25 26 27", 'if (1) { ...; @a } else{} receives caller list context'); |
ef9da979 FC |
190 | |
191 | $x = sub { if (0){} else { 0; 20 } }->(); | |
a0c9a42a | 192 | is($x, 20, 'if (0){} else { ...; $x } receives caller scalar context'); |
ef9da979 FC |
193 | |
194 | @a = (24 .. 27); | |
195 | $x = sub { if (0){} else { 0; @a } }->(); | |
a0c9a42a | 196 | is($x, 4, 'if (0){} else { ...; @a } receives caller scalar context'); |
ef9da979 | 197 | @x = sub { if (0){} else { 0; @a } }->(); |
a0c9a42a | 198 | is("@x", "24 25 26 27", 'if (0){} else { ...; @a } receives caller list context'); |
ef9da979 | 199 | |
a0c9a42a | 200 | done_testing(); |