Commit | Line | Data |
---|---|---|
3089a108 DM |
1 | #!./perl |
2 | ||
cd06dffe GS |
3 | BEGIN { |
4 | chdir 't' if -d 't'; | |
20822f61 | 5 | @INC = '../lib'; |
cb949c37 | 6 | require './test.pl'; |
cd06dffe | 7 | } |
738155d2 | 8 | plan tests=>211; |
cd06dffe | 9 | |
78f9721b SM |
10 | sub a : lvalue { my $a = 34; ${\(bless \$a)} } # Return a temporary |
11 | sub b : lvalue { ${\shift} } | |
cd06dffe GS |
12 | |
13 | my $out = a(b()); # Check that temporaries are allowed. | |
cb949c37 | 14 | is(ref $out, 'main'); # Not reached if error. |
cd06dffe GS |
15 | |
16 | my @out = grep /main/, a(b()); # Check that temporaries are allowed. | |
cb949c37 | 17 | cmp_ok(scalar @out, '==', 1); # Not reached if error. |
cd06dffe GS |
18 | |
19 | my $in; | |
20 | ||
21 | # Check that we can return localized values from subroutines: | |
22 | ||
a98df962 GS |
23 | sub in : lvalue { $in = shift; } |
24 | sub neg : lvalue { #(num_str) return num_str | |
cd06dffe GS |
25 | local $_ = shift; |
26 | s/^\+/-/; | |
27 | $_; | |
28 | } | |
29 | in(neg("+2")); | |
30 | ||
31 | ||
cb949c37 | 32 | is($in, '-2'); |
cd06dffe | 33 | |
a98df962 GS |
34 | sub get_lex : lvalue { $in } |
35 | sub get_st : lvalue { $blah } | |
78f9721b | 36 | sub id : lvalue { ${\shift} } |
a98df962 | 37 | sub id1 : lvalue { $_[0] } |
78f9721b | 38 | sub inc : lvalue { ${\++$_[0]} } |
cd06dffe GS |
39 | |
40 | $in = 5; | |
41 | $blah = 3; | |
42 | ||
43 | get_st = 7; | |
44 | ||
cb949c37 | 45 | cmp_ok($blah, '==', 7); |
cd06dffe GS |
46 | |
47 | get_lex = 7; | |
48 | ||
cb949c37 | 49 | cmp_ok($in, '==', 7); |
cd06dffe GS |
50 | |
51 | ++get_st; | |
52 | ||
cb949c37 | 53 | cmp_ok($blah, '==', 8); |
cd06dffe GS |
54 | |
55 | ++get_lex; | |
56 | ||
cb949c37 | 57 | cmp_ok($in, '==', 8); |
cd06dffe GS |
58 | |
59 | id(get_st) = 10; | |
60 | ||
cb949c37 | 61 | cmp_ok($blah, '==', 10); |
cd06dffe GS |
62 | |
63 | id(get_lex) = 10; | |
64 | ||
cb949c37 | 65 | cmp_ok($in, '==', 10); |
cd06dffe GS |
66 | |
67 | ++id(get_st); | |
68 | ||
cb949c37 | 69 | cmp_ok($blah, '==', 11); |
cd06dffe GS |
70 | |
71 | ++id(get_lex); | |
72 | ||
cb949c37 | 73 | cmp_ok($in, '==', 11); |
cd06dffe GS |
74 | |
75 | id1(get_st) = 20; | |
76 | ||
cb949c37 | 77 | cmp_ok($blah, '==', 20); |
cd06dffe GS |
78 | |
79 | id1(get_lex) = 20; | |
80 | ||
cb949c37 | 81 | cmp_ok($in, '==', 20); |
cd06dffe GS |
82 | |
83 | ++id1(get_st); | |
84 | ||
cb949c37 | 85 | cmp_ok($blah, '==', 21); |
cd06dffe GS |
86 | |
87 | ++id1(get_lex); | |
88 | ||
cb949c37 | 89 | cmp_ok($in, '==', 21); |
cd06dffe GS |
90 | |
91 | inc(get_st); | |
92 | ||
cb949c37 | 93 | cmp_ok($blah, '==', 22); |
cd06dffe GS |
94 | |
95 | inc(get_lex); | |
96 | ||
cb949c37 | 97 | cmp_ok($in, '==', 22); |
cd06dffe GS |
98 | |
99 | inc(id(get_st)); | |
100 | ||
cb949c37 | 101 | cmp_ok($blah, '==', 23); |
cd06dffe GS |
102 | |
103 | inc(id(get_lex)); | |
104 | ||
cb949c37 | 105 | cmp_ok($in, '==', 23); |
cd06dffe GS |
106 | |
107 | ++inc(id1(id(get_st))); | |
108 | ||
cb949c37 | 109 | cmp_ok($blah, '==', 25); |
cd06dffe GS |
110 | |
111 | ++inc(id1(id(get_lex))); | |
112 | ||
cb949c37 | 113 | cmp_ok($in, '==', 25); |
cd06dffe GS |
114 | |
115 | @a = (1) x 3; | |
116 | @b = (undef) x 2; | |
117 | $#c = 3; # These slots are not fillable. | |
118 | ||
119 | # Explanation: empty slots contain &sv_undef. | |
120 | ||
121 | =for disabled constructs | |
122 | ||
a98df962 GS |
123 | sub a3 :lvalue {@a} |
124 | sub b2 : lvalue {@b} | |
125 | sub c4: lvalue {@c} | |
cd06dffe GS |
126 | |
127 | $_ = ''; | |
128 | ||
129 | eval <<'EOE' or $_ = $@; | |
130 | ($x, a3, $y, b2, $z, c4, $t) = (34 .. 78); | |
131 | 1; | |
132 | EOE | |
133 | ||
134 | #@out = ($x, a3, $y, b2, $z, c4, $t); | |
135 | #@in = (34 .. 41, (undef) x 4, 46); | |
2fe1f0f5 | 136 | #print "# '@out' ne '@in'\nnot " unless "@out" eq "@in"; |
cd06dffe | 137 | |
cb949c37 NC |
138 | like($_, qr/Can\'t return an uninitialized value from lvalue subroutine/); |
139 | print "ok 22\n"; | |
140 | ||
cd06dffe GS |
141 | =cut |
142 | ||
cd06dffe GS |
143 | |
144 | my $var; | |
145 | ||
a98df962 | 146 | sub a::var : lvalue { $var } |
cd06dffe GS |
147 | |
148 | "a"->var = 45; | |
149 | ||
cb949c37 | 150 | cmp_ok($var, '==', 45); |
cd06dffe GS |
151 | |
152 | my $oo; | |
153 | $o = bless \$oo, "a"; | |
154 | ||
155 | $o->var = 47; | |
156 | ||
cb949c37 | 157 | cmp_ok($var, '==', 47); |
cd06dffe | 158 | |
a98df962 | 159 | sub o : lvalue { $o } |
cd06dffe GS |
160 | |
161 | o->var = 49; | |
162 | ||
cb949c37 | 163 | cmp_ok($var, '==', 49); |
cd06dffe GS |
164 | |
165 | sub nolv () { $x0, $x1 } # Not lvalue | |
166 | ||
167 | $_ = ''; | |
168 | ||
169 | eval <<'EOE' or $_ = $@; | |
170 | nolv = (2,3); | |
171 | 1; | |
172 | EOE | |
173 | ||
0f948285 | 174 | like($_, qr/Can\'t modify non-lvalue subroutine call of &main::nolv in scalar assignment/); |
cd06dffe GS |
175 | |
176 | $_ = ''; | |
177 | ||
178 | eval <<'EOE' or $_ = $@; | |
179 | nolv = (2,3) if $_; | |
180 | 1; | |
181 | EOE | |
182 | ||
0f948285 | 183 | like($_, qr/Can\'t modify non-lvalue subroutine call of &main::nolv in scalar assignment/); |
cd06dffe GS |
184 | |
185 | $_ = ''; | |
186 | ||
187 | eval <<'EOE' or $_ = $@; | |
188 | &nolv = (2,3) if $_; | |
189 | 1; | |
190 | EOE | |
191 | ||
0f948285 | 192 | like($_, qr/Can\'t modify non-lvalue subroutine call of &main::nolv in scalar assignment/); |
cd06dffe GS |
193 | |
194 | $x0 = $x1 = $_ = undef; | |
195 | $nolv = \&nolv; | |
196 | ||
197 | eval <<'EOE' or $_ = $@; | |
198 | $nolv->() = (2,3) if $_; | |
199 | 1; | |
200 | EOE | |
201 | ||
cb949c37 | 202 | ok(!defined $_) or diag "'$_', '$x0', '$x1'"; |
cd06dffe GS |
203 | |
204 | $x0 = $x1 = $_ = undef; | |
205 | $nolv = \&nolv; | |
206 | ||
207 | eval <<'EOE' or $_ = $@; | |
208 | $nolv->() = (2,3); | |
209 | 1; | |
210 | EOE | |
211 | ||
cb949c37 NC |
212 | like($_, qr/Can\'t modify non-lvalue subroutine call/) |
213 | or diag "'$_', '$x0', '$x1'"; | |
cd06dffe | 214 | |
e2316ad3 | 215 | sub lv0 : lvalue { } |
d25b0d7b | 216 | sub rlv0 : lvalue { return } |
cd06dffe GS |
217 | |
218 | $_ = undef; | |
219 | eval <<'EOE' or $_ = $@; | |
220 | lv0 = (2,3); | |
221 | 1; | |
222 | EOE | |
223 | ||
c73030b8 | 224 | like($_, qr/Can't return undef from lvalue subroutine/); |
cd06dffe | 225 | |
cd06dffe GS |
226 | $_ = undef; |
227 | eval <<'EOE' or $_ = $@; | |
d25b0d7b FC |
228 | rlv0 = (2,3); |
229 | 1; | |
230 | EOE | |
231 | ||
232 | like($_, qr/Can't return undef from lvalue subroutine/, | |
233 | 'explicit return of nothing in scalar context'); | |
234 | ||
235 | $_ = undef; | |
236 | eval <<'EOE' or $_ = $@; | |
cd06dffe GS |
237 | (lv0) = (2,3); |
238 | 1; | |
239 | EOE | |
240 | ||
cb949c37 | 241 | ok(!defined $_) or diag $_; |
cd06dffe | 242 | |
d25b0d7b FC |
243 | $_ = undef; |
244 | eval <<'EOE' or $_ = $@; | |
245 | (rlv0) = (2,3); | |
246 | 1; | |
247 | EOE | |
248 | ||
249 | ok(!defined $_, 'explicit return of nothing in list context') or diag $_; | |
250 | ||
69b22cd1 FC |
251 | ($a,$b)=(); |
252 | (lv0($a,$b)) = (3,4); | |
253 | is +($a//'undef') . ($b//'undef'), 'undefundef', | |
254 | 'list assignment to empty lvalue sub'; | |
255 | ||
256 | ||
a98df962 | 257 | sub lv1u :lvalue { undef } |
d25b0d7b | 258 | sub rlv1u :lvalue { undef } |
cd06dffe GS |
259 | |
260 | $_ = undef; | |
261 | eval <<'EOE' or $_ = $@; | |
262 | lv1u = (2,3); | |
263 | 1; | |
264 | EOE | |
265 | ||
c73030b8 | 266 | like($_, qr/Can't return undef from lvalue subroutine/); |
cd06dffe GS |
267 | |
268 | $_ = undef; | |
269 | eval <<'EOE' or $_ = $@; | |
d25b0d7b FC |
270 | rlv1u = (2,3); |
271 | 1; | |
272 | EOE | |
273 | ||
274 | like($_, qr/Can't return undef from lvalue subroutine/, | |
275 | 'explicitly returning undef in scalar context'); | |
276 | ||
277 | $_ = undef; | |
278 | eval <<'EOE' or $_ = $@; | |
cd06dffe GS |
279 | (lv1u) = (2,3); |
280 | 1; | |
281 | EOE | |
282 | ||
730fb7e7 FC |
283 | ok(!defined, 'implicitly returning undef in list context'); |
284 | ||
285 | $_ = undef; | |
286 | eval <<'EOE' or $_ = $@; | |
287 | (rlv1u) = (2,3); | |
288 | 1; | |
289 | EOE | |
290 | ||
291 | ok(!defined, 'explicitly returning undef in list context'); | |
cd06dffe GS |
292 | |
293 | $x = '1234567'; | |
cd06dffe GS |
294 | |
295 | $_ = undef; | |
296 | eval <<'EOE' or $_ = $@; | |
78f9721b | 297 | sub lv1t : lvalue { index $x, 2 } |
cd06dffe GS |
298 | lv1t = (2,3); |
299 | 1; | |
300 | EOE | |
301 | ||
145b2bbb | 302 | like($_, qr/Can\'t return a temporary from lvalue subroutine/); |
cd06dffe GS |
303 | |
304 | $_ = undef; | |
d25b0d7b FC |
305 | eval <<'EOE' or $_ = $@; |
306 | sub rlv1t : lvalue { index $x, 2 } | |
307 | rlv1t = (2,3); | |
308 | 1; | |
309 | EOE | |
310 | ||
311 | like($_, qr/Can\'t return a temporary from lvalue subroutine/, | |
312 | 'returning a PADTMP explicitly'); | |
313 | ||
314 | $_ = undef; | |
315 | eval <<'EOE' or $_ = $@; | |
316 | (rlv1t) = (2,3); | |
317 | 1; | |
318 | EOE | |
319 | ||
320 | like($_, qr/Can\'t return a temporary from lvalue subroutine/, | |
321 | 'returning a PADTMP explicitly (list context)'); | |
322 | ||
32cbae3f FC |
323 | # These next two tests are not necessarily normative. But this way we will |
324 | # know if this discrepancy changes. | |
325 | ||
326 | $_ = undef; | |
327 | eval <<'EOE' or $_ = $@; | |
328 | sub scalarray : lvalue { @a || $b } | |
329 | @a = 1; | |
330 | (scalarray) = (2,3); | |
331 | 1; | |
332 | EOE | |
333 | ||
334 | like($_, qr/Can\'t return a temporary from lvalue subroutine/, | |
335 | 'returning a scalar-context array via ||'); | |
336 | ||
337 | $_ = undef; | |
338 | eval <<'EOE' or $_ = $@; | |
339 | use warnings "FATAL" => "all"; | |
340 | sub myscalarray : lvalue { my @a = 1; @a || $b } | |
341 | (myscalarray) = (2,3); | |
342 | 1; | |
343 | EOE | |
344 | ||
345 | like($_, qr/Useless assignment to a temporary/, | |
346 | 'returning a scalar-context lexical array via ||'); | |
347 | ||
d25b0d7b | 348 | $_ = undef; |
145b2bbb FC |
349 | sub lv2t : lvalue { shift } |
350 | (lv2t($_)) = (2,3); | |
351 | is($_, 2); | |
cd06dffe GS |
352 | |
353 | $xxx = 'xxx'; | |
354 | sub xxx () { $xxx } # Not lvalue | |
cd06dffe GS |
355 | |
356 | $_ = undef; | |
357 | eval <<'EOE' or $_ = $@; | |
78f9721b | 358 | sub lv1tmp : lvalue { xxx } # is it a TEMP? |
cd06dffe GS |
359 | lv1tmp = (2,3); |
360 | 1; | |
361 | EOE | |
362 | ||
0f948285 | 363 | like($_, qr/Can\'t modify non-lvalue subroutine call of &main::xxx at /); |
cd06dffe GS |
364 | |
365 | $_ = undef; | |
366 | eval <<'EOE' or $_ = $@; | |
367 | (lv1tmp) = (2,3); | |
368 | 1; | |
369 | EOE | |
370 | ||
0f948285 | 371 | like($_, qr/Can\'t modify non-lvalue subroutine call of &main::xxx at /); |
fd6c41ce | 372 | |
9a049f1c | 373 | sub yyy () { 'yyy' } # Const, not lvalue |
cd06dffe GS |
374 | |
375 | $_ = undef; | |
376 | eval <<'EOE' or $_ = $@; | |
78f9721b | 377 | sub lv1tmpr : lvalue { yyy } # is it read-only? |
cd06dffe GS |
378 | lv1tmpr = (2,3); |
379 | 1; | |
380 | EOE | |
381 | ||
145b2bbb | 382 | like($_, qr/Can\'t return a readonly value from lvalue subroutine at/); |
cd06dffe GS |
383 | |
384 | $_ = undef; | |
385 | eval <<'EOE' or $_ = $@; | |
386 | (lv1tmpr) = (2,3); | |
387 | 1; | |
388 | EOE | |
389 | ||
cb949c37 | 390 | like($_, qr/Can\'t return a readonly value from lvalue subroutine/); |
3885a45a FC |
391 | |
392 | eval <<'EOF'; | |
393 | sub lv2tmpr : lvalue { my $x = *foo; Internals::SvREADONLY $x, 1; $x } | |
394 | lv2tmpr = (2,3); | |
395 | EOF | |
396 | ||
397 | like($@, qr/Can\'t return a readonly value from lvalue subroutine at/); | |
398 | ||
399 | eval <<'EOG'; | |
400 | (lv2tmpr) = (2,3); | |
401 | EOG | |
402 | ||
403 | like($@, qr/Can\'t return a readonly value from lvalue subroutine/); | |
cd06dffe | 404 | |
a98df962 | 405 | sub lva : lvalue {@a} |
cd06dffe GS |
406 | |
407 | $_ = undef; | |
408 | @a = (); | |
409 | $a[1] = 12; | |
410 | eval <<'EOE' or $_ = $@; | |
411 | (lva) = (2,3); | |
412 | 1; | |
413 | EOE | |
414 | ||
cb949c37 | 415 | is("'@a' $_", "'2 3' "); |
cd06dffe GS |
416 | |
417 | $_ = undef; | |
418 | @a = (); | |
419 | $a[0] = undef; | |
420 | $a[1] = 12; | |
421 | eval <<'EOE' or $_ = $@; | |
422 | (lva) = (2,3); | |
423 | 1; | |
424 | EOE | |
425 | ||
cb949c37 | 426 | is("'@a' $_", "'2 3' "); |
cd06dffe | 427 | |
40c94d11 FC |
428 | is lva->${\sub { return $_[0] }}, 2, |
429 | 'lvalue->$thing when lvalue returns array'; | |
430 | ||
431 | my @my = qw/ a b c /; | |
432 | sub lvmya : lvalue { @my } | |
433 | ||
434 | is lvmya->${\sub { return $_[0] }}, 3, | |
435 | 'lvalue->$thing when lvalue returns lexical array'; | |
436 | ||
a98df962 | 437 | sub lv1n : lvalue { $newvar } |
cd06dffe GS |
438 | |
439 | $_ = undef; | |
440 | eval <<'EOE' or $_ = $@; | |
441 | lv1n = (3,4); | |
442 | 1; | |
443 | EOE | |
444 | ||
cb949c37 | 445 | is("'$newvar' $_", "'4' "); |
cd06dffe | 446 | |
a98df962 | 447 | sub lv1nn : lvalue { $nnewvar } |
cd06dffe GS |
448 | |
449 | $_ = undef; | |
450 | eval <<'EOE' or $_ = $@; | |
451 | (lv1nn) = (3,4); | |
452 | 1; | |
453 | EOE | |
454 | ||
cb949c37 | 455 | is("'$nnewvar' $_", "'3' "); |
cd06dffe GS |
456 | |
457 | $a = \&lv1nn; | |
458 | $a->() = 8; | |
cb949c37 | 459 | is($nnewvar, '8'); |
d32f2495 | 460 | |
84251760 | 461 | eval 'sub AUTOLOAD : lvalue { $newvar }'; |
d32f2495 | 462 | foobar() = 12; |
cb949c37 | 463 | is($newvar, "12"); |
26191e78 | 464 | |
da1dff94 FC |
465 | # But autoloading should only be triggered by a call to an undefined |
466 | # subroutine. | |
467 | &{"lv1nn"} = 14; | |
468 | is $newvar, 12, 'AUTOLOAD does not take precedence over lvalue sub'; | |
469 | eval { &{"xxx"} = 14 }; | |
470 | is $newvar, 12, 'AUTOLOAD does not take precedence over non-lvalue sub'; | |
471 | ||
78f9721b SM |
472 | { |
473 | my %hash; my @array; | |
474 | sub alv : lvalue { $array[1] } | |
475 | sub alv2 : lvalue { $array[$_[0]] } | |
476 | sub hlv : lvalue { $hash{"foo"} } | |
477 | sub hlv2 : lvalue { $hash{$_[0]} } | |
478 | $array[1] = "not ok 51\n"; | |
479 | alv() = "ok 50\n"; | |
cb949c37 | 480 | is(alv(), "ok 50\n"); |
78f9721b SM |
481 | |
482 | alv2(20) = "ok 51\n"; | |
cb949c37 | 483 | is($array[20], "ok 51\n"); |
78f9721b SM |
484 | |
485 | $hash{"foo"} = "not ok 52\n"; | |
486 | hlv() = "ok 52\n"; | |
cb949c37 | 487 | is($hash{foo}, "ok 52\n"); |
78f9721b SM |
488 | |
489 | $hash{bar} = "not ok 53\n"; | |
490 | hlv("bar") = "ok 53\n"; | |
cb949c37 | 491 | is(hlv("bar"), "ok 53\n"); |
78f9721b SM |
492 | |
493 | sub array : lvalue { @array } | |
494 | sub array2 : lvalue { @array2 } # This is a global. | |
495 | sub hash : lvalue { %hash } | |
496 | sub hash2 : lvalue { %hash2 } # So's this. | |
497 | @array2 = qw(foo bar); | |
498 | %hash2 = qw(foo bar); | |
499 | ||
500 | (array()) = qw(ok 54); | |
cb949c37 | 501 | is("@array", "ok 54"); |
78f9721b SM |
502 | |
503 | (array2()) = qw(ok 55); | |
cb949c37 | 504 | is("@array2", "ok 55"); |
78f9721b SM |
505 | |
506 | (hash()) = qw(ok 56); | |
cb949c37 | 507 | cmp_ok($hash{ok}, '==', 56); |
78f9721b SM |
508 | |
509 | (hash2()) = qw(ok 57); | |
cb949c37 | 510 | cmp_ok($hash2{ok}, '==', 57); |
78f9721b SM |
511 | |
512 | @array = qw(a b c d); | |
513 | sub aslice1 : lvalue { @array[0,2] }; | |
514 | (aslice1()) = ("ok", "already"); | |
cb949c37 | 515 | is("@array", "ok b already d"); |
78f9721b SM |
516 | |
517 | @array2 = qw(a B c d); | |
518 | sub aslice2 : lvalue { @array2[0,2] }; | |
519 | (aslice2()) = ("ok", "already"); | |
cb949c37 | 520 | is("@array2", "ok B already d"); |
78f9721b SM |
521 | |
522 | %hash = qw(a Alpha b Beta c Gamma); | |
523 | sub hslice : lvalue { @hash{"c", "b"} } | |
524 | (hslice()) = ("CISC", "BogoMIPS"); | |
cb949c37 | 525 | is(join("/",@hash{"c","a","b"}), "CISC/Alpha/BogoMIPS"); |
78f9721b SM |
526 | } |
527 | ||
528 | $str = "Hello, world!"; | |
529 | sub sstr : lvalue { substr($str, 1, 4) } | |
530 | sstr() = "i"; | |
cb949c37 | 531 | is($str, "Hi, world!"); |
78f9721b SM |
532 | |
533 | $str = "Made w/ JavaScript"; | |
534 | sub veclv : lvalue { vec($str, 2, 32) } | |
83bcbc61 | 535 | if ($::IS_ASCII) { |
e6b8b224 PP |
536 | veclv() = 0x5065726C; |
537 | } | |
538 | else { # EBCDIC? | |
539 | veclv() = 0xD7859993; | |
540 | } | |
cb949c37 | 541 | is($str, "Made w/ PerlScript"); |
78f9721b SM |
542 | |
543 | sub position : lvalue { pos } | |
544 | @p = (); | |
545 | $_ = "fee fi fo fum"; | |
546 | while (/f/g) { | |
547 | push @p, position; | |
548 | position() += 6; | |
549 | } | |
cb949c37 | 550 | is("@p", "1 8"); |
7c8af4ef | 551 | |
fad4a2e4 FC |
552 | sub keeze : lvalue { keys %__ } |
553 | %__ = ("a","b"); | |
554 | keeze = 64; | |
8bf4c401 | 555 | is Hash::Util::bucket_ratio(%__), '1/64', 'keys assignment through lvalue sub'; |
a061ab0b FC |
556 | eval { (keeze) = 64 }; |
557 | like $@, qr/^Can't modify keys in list assignment at /, | |
558 | 'list assignment to keys through lv sub is forbidden'; | |
738155d2 FC |
559 | sub akeeze : lvalue { keys @_ } |
560 | eval { (akeeze) = 64 }; | |
561 | like $@, qr/^Can't modify keys on array in list assignment at /, | |
562 | 'list assignment to keys @_ through lv sub is forbidden'; | |
fad4a2e4 | 563 | |
7c8af4ef RG |
564 | # Bug 20001223.002: split thought that the list had only one element |
565 | @ary = qw(4 5 6); | |
566 | sub lval1 : lvalue { $ary[0]; } | |
567 | sub lval2 : lvalue { $ary[1]; } | |
568 | (lval1(), lval2()) = split ' ', "1 2 3 4"; | |
cb949c37 NC |
569 | |
570 | is(join(':', @ary), "1:2:6"); | |
1c4274f4 | 571 | |
f9bc45ef TP |
572 | # check that an element of a tied hash/array can be assigned to via lvalueness |
573 | ||
574 | package Tie_Hash; | |
575 | ||
576 | our ($key, $val); | |
577 | sub TIEHASH { bless \my $v => __PACKAGE__ } | |
578 | sub STORE { ($key, $val) = @_[1,2] } | |
579 | ||
580 | package main; | |
581 | sub lval_tie_hash : lvalue { | |
582 | tie my %t => 'Tie_Hash'; | |
583 | $t{key}; | |
584 | } | |
585 | ||
586 | eval { lval_tie_hash() = "value"; }; | |
587 | ||
cb949c37 | 588 | is($@, "", "element of tied hash"); |
f9bc45ef | 589 | |
cb949c37 | 590 | is("$Tie_Hash::key-$Tie_Hash::val", "key-value"); |
f9bc45ef TP |
591 | |
592 | ||
593 | package Tie_Array; | |
594 | ||
595 | our @val; | |
596 | sub TIEARRAY { bless \my $v => __PACKAGE__ } | |
597 | sub STORE { $val[ $_[1] ] = $_[2] } | |
598 | ||
599 | package main; | |
600 | sub lval_tie_array : lvalue { | |
601 | tie my @t => 'Tie_Array'; | |
602 | $t[0]; | |
603 | } | |
604 | ||
605 | eval { lval_tie_array() = "value"; }; | |
606 | ||
f9bc45ef | 607 | |
cb949c37 | 608 | is($@, "", "element of tied array"); |
f9bc45ef | 609 | |
cb949c37 | 610 | is ($Tie_Array::val[0], "value"); |
1c4274f4 | 611 | |
1c4274f4 | 612 | |
4bee03f8 FC |
613 | # Check that tied pad vars that are returned can be assigned to |
614 | sub TIESCALAR { bless [] } | |
615 | sub STORE {$wheel = $_[1]} | |
616 | sub FETCH {$wheel} | |
617 | sub tied_pad_var :lvalue { tie my $tyre, ''; $tyre } | |
618 | sub tied_pad_varr :lvalue { tie my $tyre, ''; return $tyre } | |
619 | tied_pad_var = 1; | |
620 | is $wheel, 1, 'tied pad var returned in scalar lvalue context'; | |
621 | tied_pad_var->${\sub{ $_[0] = 2 }}; | |
622 | is $wheel, 2, 'tied pad var returned in scalar ref context'; | |
623 | (tied_pad_var) = 3; | |
624 | is $wheel, 3, 'tied pad var returned in list lvalue context'; | |
625 | $_ = 4 for tied_pad_var; | |
626 | is $wheel, 4, 'tied pad var returned in list ref context'; | |
627 | tied_pad_varr = 5; | |
628 | is $wheel, 5, 'tied pad var explicitly returned in scalar lvalue context'; | |
629 | tied_pad_varr->${\sub{ $_[0] = 6 }}; | |
630 | is $wheel, 6, 'tied pad var explicitly returned in scalar ref context'; | |
631 | (tied_pad_varr) = 7; | |
632 | is $wheel, 7, 'tied pad var explicitly returned in list lvalue context'; | |
633 | $_ = 8 for tied_pad_varr; | |
634 | is $wheel, 8, 'tied pad var explicitly returned in list ref context'; | |
635 | ||
636 | ||
fa1e92c4 FC |
637 | # Test explicit return of lvalue expression |
638 | { | |
639 | # subs are copies from tests 1-~18 with an explicit return added. | |
640 | # They used not to work, which is why they are ‘badly’ named. | |
1c4274f4 MS |
641 | sub bad_get_lex : lvalue { return $in }; |
642 | sub bad_get_st : lvalue { return $blah } | |
643 | ||
644 | sub bad_id : lvalue { return ${\shift} } | |
645 | sub bad_id1 : lvalue { return $_[0] } | |
646 | sub bad_inc : lvalue { return ${\++$_[0]} } | |
647 | ||
648 | $in = 5; | |
649 | $blah = 3; | |
650 | ||
651 | bad_get_st = 7; | |
652 | ||
653 | is( $blah, 7 ); | |
654 | ||
655 | bad_get_lex = 7; | |
656 | ||
657 | is($in, 7, "yada"); | |
658 | ||
659 | ++bad_get_st; | |
660 | ||
661 | is($blah, 8, "yada"); | |
07fd1c9c FC |
662 | |
663 | ++bad_get_lex; | |
664 | cmp_ok($in, '==', 8); | |
665 | ||
666 | bad_id(bad_get_st) = 10; | |
667 | cmp_ok($blah, '==', 10); | |
668 | ||
669 | bad_id(bad_get_lex) = 10; | |
670 | cmp_ok($in, '==', 10); | |
671 | ||
672 | ++bad_id(bad_get_st); | |
673 | cmp_ok($blah, '==', 11); | |
674 | ||
675 | ++bad_id(bad_get_lex); | |
676 | cmp_ok($in, '==', 11); | |
677 | ||
678 | bad_id1(bad_get_st) = 20; | |
679 | cmp_ok($blah, '==', 20); | |
680 | ||
681 | bad_id1(bad_get_lex) = 20; | |
682 | cmp_ok($in, '==', 20); | |
683 | ||
684 | ++bad_id1(bad_get_st); | |
685 | cmp_ok($blah, '==', 21); | |
686 | ||
687 | ++bad_id1(bad_get_lex); | |
688 | cmp_ok($in, '==', 21); | |
689 | ||
690 | bad_inc(bad_get_st); | |
691 | cmp_ok($blah, '==', 22); | |
692 | ||
693 | bad_inc(bad_get_lex); | |
694 | cmp_ok($in, '==', 22); | |
695 | ||
696 | bad_inc(bad_id(bad_get_st)); | |
697 | cmp_ok($blah, '==', 23); | |
698 | ||
699 | bad_inc(bad_id(bad_get_lex)); | |
700 | cmp_ok($in, '==', 23); | |
701 | ||
702 | ++bad_inc(bad_id1(bad_id(bad_get_st))); | |
703 | cmp_ok($blah, '==', 25); | |
704 | ||
705 | ++bad_inc(bad_id1(bad_id(bad_get_lex))); | |
706 | cmp_ok($in, '==', 25); | |
1ffdc07c FC |
707 | |
708 | # Recursive | |
709 | my $r; | |
710 | my $to_modify; | |
711 | $r = sub :lvalue { | |
712 | my $depth = shift//0; | |
713 | if ($depth == 2) { return $to_modify } | |
714 | return &$r($depth+1); | |
715 | }; | |
716 | &$r(0) = 7; | |
717 | is $to_modify, 7, 'recursive lvalue sub'; | |
f6a9f8a4 FC |
718 | |
719 | # Recursive with substr [perl #72706] | |
720 | my $val = ''; | |
721 | my $pie; | |
722 | $pie = sub :lvalue { | |
723 | my $depth = shift; | |
724 | return &$pie($depth) if $depth--; | |
725 | substr $val, 0; | |
726 | }; | |
727 | for my $depth (0, 1, 2) { | |
728 | my $value = "Good $depth"; | |
729 | eval { | |
730 | &$pie($depth) = $value; | |
731 | }; | |
732 | is($@, '', "recursive lvalue substr return depth $depth"); | |
733 | is($val, $value, | |
734 | "value assigned to recursive lvalue substr (depth $depth)"); | |
735 | } | |
1c4274f4 MS |
736 | } |
737 | ||
91e34d82 | 738 | { # bug #23790 |
4546bcba RGS |
739 | my @arr = qw /one two three/; |
740 | my $line = "zero"; | |
741 | sub lval_array () : lvalue {@arr} | |
742 | ||
743 | for (lval_array) { | |
744 | $line .= $_; | |
745 | } | |
746 | ||
747 | is($line, "zeroonetwothree"); | |
91e34d82 MP |
748 | |
749 | sub trythislval { scalar(@_)."x".join "", @_ } | |
750 | is(trythislval(lval_array()), "3xonetwothree"); | |
751 | ||
752 | sub changeme { $_[2] = "free" } | |
753 | changeme(lval_array); | |
754 | is("@arr", "one two free"); | |
40c94d11 FC |
755 | |
756 | # test again, with explicit return | |
757 | sub rlval_array() : lvalue {return @arr} | |
758 | @arr = qw /one two three/; | |
759 | $line = "zero"; | |
760 | for (rlval_array) { | |
761 | $line .= $_; | |
762 | } | |
763 | is($line, "zeroonetwothree"); | |
764 | is(trythislval(rlval_array()), "3xonetwothree"); | |
765 | changeme(rlval_array); | |
766 | is("@arr", "one two free"); | |
767 | ||
768 | # Variations on the same theme, with multiple vars returned | |
769 | my $scalar = 'half'; | |
770 | sub lval_scalar_array () : lvalue { $scalar, @arr } | |
771 | @arr = qw /one two three/; | |
772 | $line = "zero"; | |
773 | for (lval_scalar_array) { | |
774 | $line .= $_; | |
775 | } | |
776 | is($line, "zerohalfonetwothree"); | |
777 | is(trythislval(lval_scalar_array()), "4xhalfonetwothree"); | |
778 | changeme(lval_scalar_array); | |
779 | is("@arr", "one free three"); | |
780 | ||
781 | sub lval_array_scalar () : lvalue { @arr, $scalar } | |
782 | @arr = qw /one two three/; | |
783 | $line = "zero"; | |
784 | $scalar = 'four'; | |
785 | for (lval_array_scalar) { | |
786 | $line .= $_; | |
787 | } | |
788 | is($line, "zeroonetwothreefour"); | |
789 | is(trythislval(lval_array_scalar()), "4xonetwothreefour"); | |
790 | changeme(lval_array_scalar); | |
791 | is("@arr", "one two free"); | |
792 | ||
793 | # Tests for specific ops not tested above | |
794 | # rv2av | |
795 | @array2 = qw 'one two free'; | |
796 | is join(',', map $_, sub:lvalue{@array2}->()), 'one,two,free', | |
797 | 'rv2av in reference context'; | |
798 | is join(',', map $_, sub:lvalue{@{\@array2}}->()), 'one,two,free', | |
799 | 'rv2av-with-ref in reference context'; | |
800 | # padhv | |
801 | my %hash = qw[a b c d]; | |
802 | like join(',', map $_, sub:lvalue{%hash}->()), | |
803 | qr/^(?:a,b,c,d|c,d,a,b)\z/, 'padhv in reference context'; | |
804 | # rv2hv | |
805 | %hash2 = qw[a b c d]; | |
806 | like join(',', map $_, sub:lvalue{%hash2}->()), | |
807 | qr/^(?:a,b,c,d|c,d,a,b)\z/, 'rv2hv in reference context'; | |
808 | like join(',', map $_, sub:lvalue{%{\%hash2}}->()), | |
809 | qr/^(?:a,b,c,d|c,d,a,b)\z/, 'rv2hv-with-ref in reference context'; | |
4546bcba | 810 | } |
cb0d96b9 NC |
811 | |
812 | { | |
813 | package Foo; | |
814 | sub AUTOLOAD :lvalue { *{$AUTOLOAD} }; | |
815 | package main; | |
816 | my $foo = bless {},"Foo"; | |
817 | my $result; | |
818 | $foo->bar = sub { $result = "bar" }; | |
819 | $foo->bar; | |
820 | is ($result, 'bar', "RT #41550"); | |
821 | } | |
885ef6f5 | 822 | |
c70e3f2a | 823 | SKIP: { skip 'no attributes.pm', 1 unless eval 'require attributes'; |
20e5bab4 | 824 | fresh_perl_is(<<'----', <<'====', {}, "lvalue can not be set after definition. [perl #68758]"); |
885ef6f5 GG |
825 | use warnings; |
826 | our $x; | |
827 | sub foo { $x } | |
828 | sub foo : lvalue; | |
fff96ff7 FC |
829 | sub MODIFY_CODE_ATTRIBUTES {} |
830 | sub foo : lvalue : fr0g; | |
885ef6f5 GG |
831 | foo = 3; |
832 | ---- | |
833 | lvalue attribute ignored after the subroutine has been defined at - line 4. | |
fff96ff7 | 834 | lvalue attribute ignored after the subroutine has been defined at - line 6. |
0f948285 | 835 | Can't modify non-lvalue subroutine call of &main::foo in scalar assignment at - line 7, near "3;" |
885ef6f5 GG |
836 | Execution of - aborted due to compilation errors. |
837 | ==== | |
c70e3f2a | 838 | } |
eac910c8 GG |
839 | |
840 | { | |
841 | my $x; | |
842 | sub lval_decl : lvalue; | |
843 | sub lval_decl { $x } | |
844 | lval_decl = 5; | |
845 | is($x, 5, "subroutine declared with lvalue before definition retains lvalue. [perl #68758]"); | |
846 | } | |
f71f472f | 847 | |
c70e3f2a | 848 | SKIP: { skip "no attributes.pm", 2 unless eval { require attributes }; |
b4c6bb84 FC |
849 | sub utf8::valid :lvalue; |
850 | require attributes; | |
851 | is "@{[ &attributes::get(\&utf8::valid) ]}", 'lvalue', | |
4dbb339a FC |
852 | 'sub declaration with :lvalue applies it to XSUBs'; |
853 | ||
b4c6bb84 FC |
854 | BEGIN { *wonky = \&marjibberous } |
855 | sub wonky :lvalue; | |
856 | is "@{[ &attributes::get(\&wonky) ]}", 'lvalue', | |
4dbb339a | 857 | 'sub declaration with :lvalue applies it to assigned stub'; |
c70e3f2a | 858 | } |
4dbb339a | 859 | |
f71f472f FC |
860 | sub fleen : lvalue { $pnare } |
861 | $pnare = __PACKAGE__; | |
862 | ok eval { fleen = 1 }, "lvalues can return COWs (CATTLE?) [perl #75656]";\ | |
863 | is $pnare, 1, 'and returning CATTLE actually works'; | |
a0aa6076 FC |
864 | $pnare = __PACKAGE__; |
865 | ok eval { (fleen) = 1 }, "lvalues can return COWs in list context"; | |
866 | is $pnare, 1, 'and returning COWs in list context actually works'; | |
a1302723 FC |
867 | $pnare = __PACKAGE__; |
868 | ok eval { $_ = 1 for(fleen); 1 }, "lvalues can return COWs in ref cx"; | |
869 | is $pnare, 1, 'and returning COWs in reference context actually works'; | |
145b2bbb FC |
870 | |
871 | ||
872 | # Returning an arbitrary expression, not necessarily lvalue | |
873 | +sub :lvalue { return $ambaga || $ambaga }->() = 73; | |
874 | is $ambaga, 73, 'explicit return of arbitrary expression (scalar context)'; | |
875 | (sub :lvalue { return $ambaga || $ambaga }->()) = 74; | |
876 | is $ambaga, 74, 'explicit return of arbitrary expression (list context)'; | |
877 | +sub :lvalue { $ambaga || $ambaga }->() = 73; | |
878 | is $ambaga, 73, 'implicit return of arbitrary expression (scalar context)'; | |
879 | (sub :lvalue { $ambaga || $ambaga }->()) = 74; | |
880 | is $ambaga, 74, 'implicit return of arbitrary expression (list context)'; | |
145b2bbb FC |
881 | eval { +sub :lvalue { return 3 }->() = 4 }; |
882 | like $@, qr/Can\'t return a readonly value from lvalue subroutine at/, | |
883 | 'assignment to numeric constant explicitly returned from lv sub'; | |
884 | eval { (sub :lvalue { return 3 }->()) = 4 }; | |
885 | like $@, qr/Can\'t return a readonly value from lvalue subroutine at/, | |
886 | 'assignment to num constant explicitly returned (list cx)'; | |
145b2bbb FC |
887 | eval { +sub :lvalue { 3 }->() = 4 }; |
888 | like $@, qr/Can\'t return a readonly value from lvalue subroutine at/, | |
889 | 'assignment to numeric constant implicitly returned from lv sub'; | |
890 | eval { (sub :lvalue { 3 }->()) = 4 }; | |
891 | like $@, qr/Can\'t return a readonly value from lvalue subroutine at/, | |
892 | 'assignment to num constant implicitly returned (list cx)'; | |
bf8fb5eb FC |
893 | |
894 | # reference (potential lvalue) context | |
895 | $suffix = ''; | |
896 | for my $sub (sub :lvalue {$_}, sub :lvalue {return $_}) { | |
897 | &$sub()->${\sub { $_[0] = 37 }}; | |
898 | is $_, '37', 'lvalue->method'.$suffix; | |
899 | ${\scalar &$sub()} = 38; | |
900 | is $_, '38', 'scalar(lvalue)'.$suffix; | |
901 | sub assign39_with_proto ($) { $_[0] = 39 } | |
902 | assign39_with_proto(&$sub()); | |
903 | is $_, '39', 'func(lvalue) when func has $ proto'.$suffix; | |
904 | $_ = 1; | |
905 | ${\(&$sub()||undef)} = 40; | |
906 | is $_, '40', 'lvalue||...'.$suffix; | |
907 | ${\(${\undef}||&$sub())} = 41; # extra ${\...} to bypass const folding | |
908 | is $_, '41', '...||lvalue'.$suffix; | |
909 | $_ = 0; | |
910 | ${\(&$sub()&&undef)} = 42; | |
911 | is $_, '42', 'lvalue&&...'.$suffix; | |
912 | ${\(${\1}&&&$sub())} = 43; | |
913 | is $_, '43', '...&&lvalue'.$suffix; | |
914 | ${\(&$sub())[0]} = 44; | |
915 | is $_, '44', '(lvalue)[0]'.$suffix; | |
916 | } | |
917 | continue { $suffix = ' (explicit return)' } | |
767eda44 FC |
918 | |
919 | # autovivification | |
d507ecb9 | 920 | $suffix = ''; |
767eda44 FC |
921 | for my $sub (sub :lvalue {$_}, sub :lvalue {return $_}) { |
922 | undef $_; | |
923 | &$sub()->[3] = 4; | |
924 | is $_->[3], 4, 'func->[...] autovivification'.$suffix; | |
925 | undef $_; | |
926 | &$sub()->{3} = 4; | |
927 | is $_->{3}, 4, 'func->{...} autovivification'.$suffix; | |
928 | undef $_; | |
929 | ${&$sub()} = 4; | |
930 | is $$_, 4, '${func()} autovivification' .$suffix; | |
931 | undef $_; | |
932 | @{&$sub()} = 4; | |
933 | is "@$_", 4, '@{func()} autovivification' .$suffix; | |
934 | undef $_; | |
935 | %{&$sub()} = (4,5); | |
936 | is join('-',%$_), '4-5', '%{func()} autovivification'.$suffix; | |
0e9700df GG |
937 | undef $_; |
938 | ${ (), &$sub()} = 4; | |
939 | is $$_, 4, '${ (), func()} autovivification' .$suffix; | |
767eda44 FC |
940 | } |
941 | continue { $suffix = ' (explicit return)' } | |
e08be60b FC |
942 | |
943 | # [perl #92406] [perl #92290] Returning a pad var in rvalue context | |
944 | $suffix = ''; | |
945 | for my $sub ( | |
946 | sub :lvalue { my $x = 72; $x }, | |
947 | sub :lvalue { my $x = 72; return $x } | |
948 | ) { | |
949 | is scalar(&$sub), 72, "sub returning pad var in scalar context$suffix"; | |
950 | is +(&$sub)[0], 72, "sub returning pad var in list context$suffix"; | |
951 | } | |
952 | continue { $suffix = ' (explicit return)' } | |
ad37a74e FC |
953 | |
954 | # Returning read-only values in reference context | |
955 | $suffix = ''; | |
956 | for ( | |
957 | sub :lvalue { $] }->(), | |
958 | sub :lvalue { return $] }->() | |
959 | ) { | |
960 | is \$_, \$], 'read-only values are returned in reference context' | |
961 | .$suffix # (they used to be copied) | |
962 | } | |
963 | continue { $suffix = ' (explicit return)' } | |
777d9014 FC |
964 | |
965 | # Returning unwritables from nested lvalue sub call in in rvalue context | |
966 | # First, ensure we are testing what we think we are: | |
967 | if (!Internals::SvREADONLY($])) { Internals::SvREADONLY($],1); } | |
968 | sub squibble : lvalue { return $] } | |
969 | sub squebble : lvalue { squibble } | |
970 | sub squabble : lvalue { return squibble } | |
971 | is $x = squebble, $], 'returning ro from nested lv sub call in rv cx'; | |
972 | is $x = squabble, $], 'explct. returning ro from nested lv sub in rv cx'; | |
973 | is \squebble, \$], 'returning ro from nested lv sub call in ref cx'; | |
974 | is \squabble, \$], 'explct. returning ro from nested lv sub in ref cx'; | |
da1dff94 FC |
975 | |
976 | # [perl #102486] Sub calls as the last statement of an lvalue sub | |
977 | package _102486 { | |
978 | my $called; | |
979 | my $x = 'nonlv'; | |
980 | sub strictlv :lvalue { use strict 'refs'; &$x } | |
981 | sub lv :lvalue { &$x } | |
982 | sub nonlv { ++$called } | |
983 | eval { strictlv }; | |
984 | ::like $@, qr/^Can't use string \("nonlv"\) as a subroutine ref while/, | |
985 | 'strict mode applies to sub:lvalue{ &$string }'; | |
986 | $called = 0; | |
987 | ::ok eval { lv }, | |
988 | 'sub:lvalue{&$x}->() does not die for non-lvalue inner sub call'; | |
989 | ::is $called, 1, 'The &$x actually called the sub'; | |
990 | eval { +sub :lvalue { &$x }->() = 3 }; | |
0f948285 | 991 | ::like $@, qr/^Can't modify non-lvalue subroutine call of &_102486::nonlv at /, |
da1dff94 FC |
992 | 'sub:lvalue{&$x}->() dies in true lvalue context'; |
993 | } | |
5811c07e FC |
994 | |
995 | # TARG should be copied in rvalue context | |
996 | sub ucf :lvalue { ucfirst $_[0] } | |
997 | is ucf("just another ") . ucf("perl hacker,\n"), | |
998 | "Just another Perl hacker,\n", 'TARG is copied in rvalue scalar cx'; | |
999 | is join('',ucf("just another "), ucf "perl hacker,\n"), | |
1000 | "Just another Perl hacker,\n", 'TARG is copied in rvalue list cx'; | |
1001 | sub ucfr : lvalue { | |
1002 | @_ ? ucfirst $_[0] : do { | |
1003 | is ucfr("just another ") . ucfr("perl hacker,\n"), | |
1004 | "Just another Perl hacker,\n", | |
1005 | 'TARG is copied in recursive rvalue scalar cx'; | |
1006 | is join('',ucfr("just another "), ucfr("perl hacker,\n")), | |
1007 | "Just another Perl hacker,\n", | |
1008 | 'TARG is copied in recursive rvalue list cx'; | |
1009 | } | |
1010 | } | |
1011 | ucfr(); | |
4587c532 | 1012 | |
2d885586 FC |
1013 | # Test TARG with potential lvalue context, too |
1014 | for (sub : lvalue { "$x" }->()) { | |
1015 | is \$_, \$_, '\$_ == \$_ in for(sub :lvalue{"$x"}->()){...}' | |
1016 | } | |
1017 | ||
4587c532 FC |
1018 | # [perl #117947] XSUBs should not be treated as lvalues at run time |
1019 | eval { &{\&utf8::is_utf8}("") = 3 }; | |
0f948285 | 1020 | like $@, qr/^Can't modify non-lvalue subroutine call of &utf8::is_utf8 at /, |
4587c532 | 1021 | 'XSUB not seen at compile time dies in lvalue context'; |
2ec7f6f2 FC |
1022 | |
1023 | # [perl #119797] else implicitly returning value | |
1024 | # This used to cause Bizarre copy of ARRAY in pp_leave | |
1025 | sub else119797 : lvalue { | |
1026 | if ($_[0]) { | |
1027 | 1; # two statements force a leave op | |
1028 | @119797 | |
1029 | } | |
1030 | else { | |
1031 | @119797 | |
1032 | } | |
1033 | } | |
1034 | eval { (else119797(0)) = 1..3 }; | |
1035 | is $@, "", '$@ after writing to array returned by else'; | |
1036 | is "@119797", "1 2 3", 'writing to array returned by else'; | |
1037 | eval { (else119797(1)) = 4..6 }; | |
1038 | is $@, "", '$@ after writing to array returned by if (with else)'; | |
1039 | is "@119797", "4 5 6", 'writing to array returned by if (with else)'; | |
1040 | sub if119797 : lvalue { | |
1041 | if ($_[0]) { | |
1042 | @119797 | |
1043 | } | |
1044 | } | |
1045 | @119797 = (); | |
1046 | eval { (if119797(1)) = 4..6 }; | |
1047 | is $@, "", '$@ after writing to array returned by if'; | |
1048 | is "@119797", "4 5 6", 'writing to array returned by if'; | |
1049 | sub unless119797 : lvalue { | |
1050 | unless ($_[0]) { | |
1051 | @119797 | |
1052 | } | |
1053 | } | |
1054 | @119797 = (); | |
1055 | eval { (unless119797(0)) = 4..6 }; | |
1056 | is $@, "", '$@ after writing to array returned by unless'; | |
1057 | is "@119797", "4 5 6", 'writing to array returned by unless'; | |
a373464f FC |
1058 | sub bare119797 : lvalue { |
1059 | {; | |
1060 | @119797 | |
1061 | } | |
1062 | } | |
1063 | @119797 = (); | |
1064 | eval { (bare119797(0)) = 4..6 }; | |
1065 | is $@, "", '$@ after writing to array returned by bare block'; | |
1066 | is "@119797", "4 5 6", 'writing to array returned by bare block'; | |
3089a108 DM |
1067 | |
1068 | # a sub with nested scopes must pop rubbish on the stack | |
1069 | { | |
1070 | my $x = "a"; | |
1071 | sub loopreturn : lvalue { | |
1072 | for (1,2) { | |
1073 | return $x | |
1074 | } | |
1075 | } | |
1076 | loopreturn = "b"; | |
1077 | is($x, "b", "loopreturn"); | |
1078 | } | |
1079 | ||
1080 | # a sub without nested scopes that still leaves rubbish on the stack | |
1081 | # which needs popping | |
1082 | { | |
1083 | my $x = "a"; | |
1084 | sub junkreturn : lvalue { | |
1085 | my $false; | |
1086 | return $x unless $false and $false; | |
1087 | 1; | |
1088 | } | |
1089 | junkreturn = "b"; | |
1090 | is($x, "b", "junkreturn"); | |
1091 | } |