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