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