Commit | Line | Data |
---|---|---|
cd06dffe GS |
1 | BEGIN { |
2 | chdir 't' if -d 't'; | |
20822f61 | 3 | @INC = '../lib'; |
cb949c37 | 4 | require './test.pl'; |
cd06dffe | 5 | } |
32cbae3f | 6 | plan tests=>205; |
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); | |
2fe1f0f5 | 134 | #print "# '@out' ne '@in'\nnot " unless "@out" eq "@in"; |
cd06dffe | 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 | ||
32cbae3f FC |
321 | # These next two tests are not necessarily normative. But this way we will |
322 | # know if this discrepancy changes. | |
323 | ||
324 | $_ = undef; | |
325 | eval <<'EOE' or $_ = $@; | |
326 | sub scalarray : lvalue { @a || $b } | |
327 | @a = 1; | |
328 | (scalarray) = (2,3); | |
329 | 1; | |
330 | EOE | |
331 | ||
332 | like($_, qr/Can\'t return a temporary from lvalue subroutine/, | |
333 | 'returning a scalar-context array via ||'); | |
334 | ||
335 | $_ = undef; | |
336 | eval <<'EOE' or $_ = $@; | |
337 | use warnings "FATAL" => "all"; | |
338 | sub myscalarray : lvalue { my @a = 1; @a || $b } | |
339 | (myscalarray) = (2,3); | |
340 | 1; | |
341 | EOE | |
342 | ||
343 | like($_, qr/Useless assignment to a temporary/, | |
344 | 'returning a scalar-context lexical array via ||'); | |
345 | ||
d25b0d7b | 346 | $_ = undef; |
145b2bbb FC |
347 | sub lv2t : lvalue { shift } |
348 | (lv2t($_)) = (2,3); | |
349 | is($_, 2); | |
cd06dffe GS |
350 | |
351 | $xxx = 'xxx'; | |
352 | sub xxx () { $xxx } # Not lvalue | |
cd06dffe GS |
353 | |
354 | $_ = undef; | |
355 | eval <<'EOE' or $_ = $@; | |
78f9721b | 356 | sub lv1tmp : lvalue { xxx } # is it a TEMP? |
cd06dffe GS |
357 | lv1tmp = (2,3); |
358 | 1; | |
359 | EOE | |
360 | ||
da1dff94 | 361 | like($_, qr/Can\'t modify non-lvalue subroutine call at /); |
cd06dffe GS |
362 | |
363 | $_ = undef; | |
364 | eval <<'EOE' or $_ = $@; | |
365 | (lv1tmp) = (2,3); | |
366 | 1; | |
367 | EOE | |
368 | ||
da1dff94 | 369 | like($_, qr/Can\'t modify non-lvalue subroutine call at /); |
fd6c41ce | 370 | |
9a049f1c | 371 | sub yyy () { 'yyy' } # Const, not lvalue |
cd06dffe GS |
372 | |
373 | $_ = undef; | |
374 | eval <<'EOE' or $_ = $@; | |
78f9721b | 375 | sub lv1tmpr : lvalue { yyy } # is it read-only? |
cd06dffe GS |
376 | lv1tmpr = (2,3); |
377 | 1; | |
378 | EOE | |
379 | ||
145b2bbb | 380 | like($_, qr/Can\'t return a readonly value from lvalue subroutine at/); |
cd06dffe GS |
381 | |
382 | $_ = undef; | |
383 | eval <<'EOE' or $_ = $@; | |
384 | (lv1tmpr) = (2,3); | |
385 | 1; | |
386 | EOE | |
387 | ||
cb949c37 | 388 | like($_, qr/Can\'t return a readonly value from lvalue subroutine/); |
cd06dffe | 389 | |
a98df962 | 390 | sub lva : lvalue {@a} |
cd06dffe GS |
391 | |
392 | $_ = undef; | |
393 | @a = (); | |
394 | $a[1] = 12; | |
395 | eval <<'EOE' or $_ = $@; | |
396 | (lva) = (2,3); | |
397 | 1; | |
398 | EOE | |
399 | ||
cb949c37 | 400 | is("'@a' $_", "'2 3' "); |
cd06dffe GS |
401 | |
402 | $_ = undef; | |
403 | @a = (); | |
404 | $a[0] = undef; | |
405 | $a[1] = 12; | |
406 | eval <<'EOE' or $_ = $@; | |
407 | (lva) = (2,3); | |
408 | 1; | |
409 | EOE | |
410 | ||
cb949c37 | 411 | is("'@a' $_", "'2 3' "); |
cd06dffe | 412 | |
40c94d11 FC |
413 | is lva->${\sub { return $_[0] }}, 2, |
414 | 'lvalue->$thing when lvalue returns array'; | |
415 | ||
416 | my @my = qw/ a b c /; | |
417 | sub lvmya : lvalue { @my } | |
418 | ||
419 | is lvmya->${\sub { return $_[0] }}, 3, | |
420 | 'lvalue->$thing when lvalue returns lexical array'; | |
421 | ||
a98df962 | 422 | sub lv1n : lvalue { $newvar } |
cd06dffe GS |
423 | |
424 | $_ = undef; | |
425 | eval <<'EOE' or $_ = $@; | |
426 | lv1n = (3,4); | |
427 | 1; | |
428 | EOE | |
429 | ||
cb949c37 | 430 | is("'$newvar' $_", "'4' "); |
cd06dffe | 431 | |
a98df962 | 432 | sub lv1nn : lvalue { $nnewvar } |
cd06dffe GS |
433 | |
434 | $_ = undef; | |
435 | eval <<'EOE' or $_ = $@; | |
436 | (lv1nn) = (3,4); | |
437 | 1; | |
438 | EOE | |
439 | ||
cb949c37 | 440 | is("'$nnewvar' $_", "'3' "); |
cd06dffe GS |
441 | |
442 | $a = \&lv1nn; | |
443 | $a->() = 8; | |
cb949c37 | 444 | is($nnewvar, '8'); |
d32f2495 | 445 | |
84251760 | 446 | eval 'sub AUTOLOAD : lvalue { $newvar }'; |
d32f2495 | 447 | foobar() = 12; |
cb949c37 | 448 | is($newvar, "12"); |
26191e78 | 449 | |
da1dff94 FC |
450 | # But autoloading should only be triggered by a call to an undefined |
451 | # subroutine. | |
452 | &{"lv1nn"} = 14; | |
453 | is $newvar, 12, 'AUTOLOAD does not take precedence over lvalue sub'; | |
454 | eval { &{"xxx"} = 14 }; | |
455 | is $newvar, 12, 'AUTOLOAD does not take precedence over non-lvalue sub'; | |
456 | ||
78f9721b SM |
457 | { |
458 | my %hash; my @array; | |
459 | sub alv : lvalue { $array[1] } | |
460 | sub alv2 : lvalue { $array[$_[0]] } | |
461 | sub hlv : lvalue { $hash{"foo"} } | |
462 | sub hlv2 : lvalue { $hash{$_[0]} } | |
463 | $array[1] = "not ok 51\n"; | |
464 | alv() = "ok 50\n"; | |
cb949c37 | 465 | is(alv(), "ok 50\n"); |
78f9721b SM |
466 | |
467 | alv2(20) = "ok 51\n"; | |
cb949c37 | 468 | is($array[20], "ok 51\n"); |
78f9721b SM |
469 | |
470 | $hash{"foo"} = "not ok 52\n"; | |
471 | hlv() = "ok 52\n"; | |
cb949c37 | 472 | is($hash{foo}, "ok 52\n"); |
78f9721b SM |
473 | |
474 | $hash{bar} = "not ok 53\n"; | |
475 | hlv("bar") = "ok 53\n"; | |
cb949c37 | 476 | is(hlv("bar"), "ok 53\n"); |
78f9721b SM |
477 | |
478 | sub array : lvalue { @array } | |
479 | sub array2 : lvalue { @array2 } # This is a global. | |
480 | sub hash : lvalue { %hash } | |
481 | sub hash2 : lvalue { %hash2 } # So's this. | |
482 | @array2 = qw(foo bar); | |
483 | %hash2 = qw(foo bar); | |
484 | ||
485 | (array()) = qw(ok 54); | |
cb949c37 | 486 | is("@array", "ok 54"); |
78f9721b SM |
487 | |
488 | (array2()) = qw(ok 55); | |
cb949c37 | 489 | is("@array2", "ok 55"); |
78f9721b SM |
490 | |
491 | (hash()) = qw(ok 56); | |
cb949c37 | 492 | cmp_ok($hash{ok}, '==', 56); |
78f9721b SM |
493 | |
494 | (hash2()) = qw(ok 57); | |
cb949c37 | 495 | cmp_ok($hash2{ok}, '==', 57); |
78f9721b SM |
496 | |
497 | @array = qw(a b c d); | |
498 | sub aslice1 : lvalue { @array[0,2] }; | |
499 | (aslice1()) = ("ok", "already"); | |
cb949c37 | 500 | is("@array", "ok b already d"); |
78f9721b SM |
501 | |
502 | @array2 = qw(a B c d); | |
503 | sub aslice2 : lvalue { @array2[0,2] }; | |
504 | (aslice2()) = ("ok", "already"); | |
cb949c37 | 505 | is("@array2", "ok B already d"); |
78f9721b SM |
506 | |
507 | %hash = qw(a Alpha b Beta c Gamma); | |
508 | sub hslice : lvalue { @hash{"c", "b"} } | |
509 | (hslice()) = ("CISC", "BogoMIPS"); | |
cb949c37 | 510 | is(join("/",@hash{"c","a","b"}), "CISC/Alpha/BogoMIPS"); |
78f9721b SM |
511 | } |
512 | ||
513 | $str = "Hello, world!"; | |
514 | sub sstr : lvalue { substr($str, 1, 4) } | |
515 | sstr() = "i"; | |
cb949c37 | 516 | is($str, "Hi, world!"); |
78f9721b SM |
517 | |
518 | $str = "Made w/ JavaScript"; | |
519 | sub veclv : lvalue { vec($str, 2, 32) } | |
e6b8b224 PP |
520 | if (ord('A') != 193) { |
521 | veclv() = 0x5065726C; | |
522 | } | |
523 | else { # EBCDIC? | |
524 | veclv() = 0xD7859993; | |
525 | } | |
cb949c37 | 526 | is($str, "Made w/ PerlScript"); |
78f9721b SM |
527 | |
528 | sub position : lvalue { pos } | |
529 | @p = (); | |
530 | $_ = "fee fi fo fum"; | |
531 | while (/f/g) { | |
532 | push @p, position; | |
533 | position() += 6; | |
534 | } | |
cb949c37 | 535 | is("@p", "1 8"); |
7c8af4ef | 536 | |
fad4a2e4 FC |
537 | sub keeze : lvalue { keys %__ } |
538 | %__ = ("a","b"); | |
539 | keeze = 64; | |
540 | is scalar %__, '1/64', 'keys assignment through lvalue sub'; | |
541 | ||
7c8af4ef RG |
542 | # Bug 20001223.002: split thought that the list had only one element |
543 | @ary = qw(4 5 6); | |
544 | sub lval1 : lvalue { $ary[0]; } | |
545 | sub lval2 : lvalue { $ary[1]; } | |
546 | (lval1(), lval2()) = split ' ', "1 2 3 4"; | |
cb949c37 NC |
547 | |
548 | is(join(':', @ary), "1:2:6"); | |
1c4274f4 | 549 | |
f9bc45ef TP |
550 | # check that an element of a tied hash/array can be assigned to via lvalueness |
551 | ||
552 | package Tie_Hash; | |
553 | ||
554 | our ($key, $val); | |
555 | sub TIEHASH { bless \my $v => __PACKAGE__ } | |
556 | sub STORE { ($key, $val) = @_[1,2] } | |
557 | ||
558 | package main; | |
559 | sub lval_tie_hash : lvalue { | |
560 | tie my %t => 'Tie_Hash'; | |
561 | $t{key}; | |
562 | } | |
563 | ||
564 | eval { lval_tie_hash() = "value"; }; | |
565 | ||
cb949c37 | 566 | is($@, "", "element of tied hash"); |
f9bc45ef | 567 | |
cb949c37 | 568 | is("$Tie_Hash::key-$Tie_Hash::val", "key-value"); |
f9bc45ef TP |
569 | |
570 | ||
571 | package Tie_Array; | |
572 | ||
573 | our @val; | |
574 | sub TIEARRAY { bless \my $v => __PACKAGE__ } | |
575 | sub STORE { $val[ $_[1] ] = $_[2] } | |
576 | ||
577 | package main; | |
578 | sub lval_tie_array : lvalue { | |
579 | tie my @t => 'Tie_Array'; | |
580 | $t[0]; | |
581 | } | |
582 | ||
583 | eval { lval_tie_array() = "value"; }; | |
584 | ||
f9bc45ef | 585 | |
cb949c37 | 586 | is($@, "", "element of tied array"); |
f9bc45ef | 587 | |
cb949c37 | 588 | is ($Tie_Array::val[0], "value"); |
1c4274f4 | 589 | |
1c4274f4 | 590 | |
4bee03f8 FC |
591 | # Check that tied pad vars that are returned can be assigned to |
592 | sub TIESCALAR { bless [] } | |
593 | sub STORE {$wheel = $_[1]} | |
594 | sub FETCH {$wheel} | |
595 | sub tied_pad_var :lvalue { tie my $tyre, ''; $tyre } | |
596 | sub tied_pad_varr :lvalue { tie my $tyre, ''; return $tyre } | |
597 | tied_pad_var = 1; | |
598 | is $wheel, 1, 'tied pad var returned in scalar lvalue context'; | |
599 | tied_pad_var->${\sub{ $_[0] = 2 }}; | |
600 | is $wheel, 2, 'tied pad var returned in scalar ref context'; | |
601 | (tied_pad_var) = 3; | |
602 | is $wheel, 3, 'tied pad var returned in list lvalue context'; | |
603 | $_ = 4 for tied_pad_var; | |
604 | is $wheel, 4, 'tied pad var returned in list ref context'; | |
605 | tied_pad_varr = 5; | |
606 | is $wheel, 5, 'tied pad var explicitly returned in scalar lvalue context'; | |
607 | tied_pad_varr->${\sub{ $_[0] = 6 }}; | |
608 | is $wheel, 6, 'tied pad var explicitly returned in scalar ref context'; | |
609 | (tied_pad_varr) = 7; | |
610 | is $wheel, 7, 'tied pad var explicitly returned in list lvalue context'; | |
611 | $_ = 8 for tied_pad_varr; | |
612 | is $wheel, 8, 'tied pad var explicitly returned in list ref context'; | |
613 | ||
614 | ||
fa1e92c4 FC |
615 | # Test explicit return of lvalue expression |
616 | { | |
617 | # subs are copies from tests 1-~18 with an explicit return added. | |
618 | # They used not to work, which is why they are ‘badly’ named. | |
1c4274f4 MS |
619 | sub bad_get_lex : lvalue { return $in }; |
620 | sub bad_get_st : lvalue { return $blah } | |
621 | ||
622 | sub bad_id : lvalue { return ${\shift} } | |
623 | sub bad_id1 : lvalue { return $_[0] } | |
624 | sub bad_inc : lvalue { return ${\++$_[0]} } | |
625 | ||
626 | $in = 5; | |
627 | $blah = 3; | |
628 | ||
629 | bad_get_st = 7; | |
630 | ||
631 | is( $blah, 7 ); | |
632 | ||
633 | bad_get_lex = 7; | |
634 | ||
635 | is($in, 7, "yada"); | |
636 | ||
637 | ++bad_get_st; | |
638 | ||
639 | is($blah, 8, "yada"); | |
07fd1c9c FC |
640 | |
641 | ++bad_get_lex; | |
642 | cmp_ok($in, '==', 8); | |
643 | ||
644 | bad_id(bad_get_st) = 10; | |
645 | cmp_ok($blah, '==', 10); | |
646 | ||
647 | bad_id(bad_get_lex) = 10; | |
648 | cmp_ok($in, '==', 10); | |
649 | ||
650 | ++bad_id(bad_get_st); | |
651 | cmp_ok($blah, '==', 11); | |
652 | ||
653 | ++bad_id(bad_get_lex); | |
654 | cmp_ok($in, '==', 11); | |
655 | ||
656 | bad_id1(bad_get_st) = 20; | |
657 | cmp_ok($blah, '==', 20); | |
658 | ||
659 | bad_id1(bad_get_lex) = 20; | |
660 | cmp_ok($in, '==', 20); | |
661 | ||
662 | ++bad_id1(bad_get_st); | |
663 | cmp_ok($blah, '==', 21); | |
664 | ||
665 | ++bad_id1(bad_get_lex); | |
666 | cmp_ok($in, '==', 21); | |
667 | ||
668 | bad_inc(bad_get_st); | |
669 | cmp_ok($blah, '==', 22); | |
670 | ||
671 | bad_inc(bad_get_lex); | |
672 | cmp_ok($in, '==', 22); | |
673 | ||
674 | bad_inc(bad_id(bad_get_st)); | |
675 | cmp_ok($blah, '==', 23); | |
676 | ||
677 | bad_inc(bad_id(bad_get_lex)); | |
678 | cmp_ok($in, '==', 23); | |
679 | ||
680 | ++bad_inc(bad_id1(bad_id(bad_get_st))); | |
681 | cmp_ok($blah, '==', 25); | |
682 | ||
683 | ++bad_inc(bad_id1(bad_id(bad_get_lex))); | |
684 | cmp_ok($in, '==', 25); | |
1ffdc07c FC |
685 | |
686 | # Recursive | |
687 | my $r; | |
688 | my $to_modify; | |
689 | $r = sub :lvalue { | |
690 | my $depth = shift//0; | |
691 | if ($depth == 2) { return $to_modify } | |
692 | return &$r($depth+1); | |
693 | }; | |
694 | &$r(0) = 7; | |
695 | is $to_modify, 7, 'recursive lvalue sub'; | |
f6a9f8a4 FC |
696 | |
697 | # Recursive with substr [perl #72706] | |
698 | my $val = ''; | |
699 | my $pie; | |
700 | $pie = sub :lvalue { | |
701 | my $depth = shift; | |
702 | return &$pie($depth) if $depth--; | |
703 | substr $val, 0; | |
704 | }; | |
705 | for my $depth (0, 1, 2) { | |
706 | my $value = "Good $depth"; | |
707 | eval { | |
708 | &$pie($depth) = $value; | |
709 | }; | |
710 | is($@, '', "recursive lvalue substr return depth $depth"); | |
711 | is($val, $value, | |
712 | "value assigned to recursive lvalue substr (depth $depth)"); | |
713 | } | |
1c4274f4 MS |
714 | } |
715 | ||
91e34d82 | 716 | { # bug #23790 |
4546bcba RGS |
717 | my @arr = qw /one two three/; |
718 | my $line = "zero"; | |
719 | sub lval_array () : lvalue {@arr} | |
720 | ||
721 | for (lval_array) { | |
722 | $line .= $_; | |
723 | } | |
724 | ||
725 | is($line, "zeroonetwothree"); | |
91e34d82 MP |
726 | |
727 | sub trythislval { scalar(@_)."x".join "", @_ } | |
728 | is(trythislval(lval_array()), "3xonetwothree"); | |
729 | ||
730 | sub changeme { $_[2] = "free" } | |
731 | changeme(lval_array); | |
732 | is("@arr", "one two free"); | |
40c94d11 FC |
733 | |
734 | # test again, with explicit return | |
735 | sub rlval_array() : lvalue {return @arr} | |
736 | @arr = qw /one two three/; | |
737 | $line = "zero"; | |
738 | for (rlval_array) { | |
739 | $line .= $_; | |
740 | } | |
741 | is($line, "zeroonetwothree"); | |
742 | is(trythislval(rlval_array()), "3xonetwothree"); | |
743 | changeme(rlval_array); | |
744 | is("@arr", "one two free"); | |
745 | ||
746 | # Variations on the same theme, with multiple vars returned | |
747 | my $scalar = 'half'; | |
748 | sub lval_scalar_array () : lvalue { $scalar, @arr } | |
749 | @arr = qw /one two three/; | |
750 | $line = "zero"; | |
751 | for (lval_scalar_array) { | |
752 | $line .= $_; | |
753 | } | |
754 | is($line, "zerohalfonetwothree"); | |
755 | is(trythislval(lval_scalar_array()), "4xhalfonetwothree"); | |
756 | changeme(lval_scalar_array); | |
757 | is("@arr", "one free three"); | |
758 | ||
759 | sub lval_array_scalar () : lvalue { @arr, $scalar } | |
760 | @arr = qw /one two three/; | |
761 | $line = "zero"; | |
762 | $scalar = 'four'; | |
763 | for (lval_array_scalar) { | |
764 | $line .= $_; | |
765 | } | |
766 | is($line, "zeroonetwothreefour"); | |
767 | is(trythislval(lval_array_scalar()), "4xonetwothreefour"); | |
768 | changeme(lval_array_scalar); | |
769 | is("@arr", "one two free"); | |
770 | ||
771 | # Tests for specific ops not tested above | |
772 | # rv2av | |
773 | @array2 = qw 'one two free'; | |
774 | is join(',', map $_, sub:lvalue{@array2}->()), 'one,two,free', | |
775 | 'rv2av in reference context'; | |
776 | is join(',', map $_, sub:lvalue{@{\@array2}}->()), 'one,two,free', | |
777 | 'rv2av-with-ref in reference context'; | |
778 | # padhv | |
779 | my %hash = qw[a b c d]; | |
780 | like join(',', map $_, sub:lvalue{%hash}->()), | |
781 | qr/^(?:a,b,c,d|c,d,a,b)\z/, 'padhv in reference context'; | |
782 | # rv2hv | |
783 | %hash2 = qw[a b c d]; | |
784 | like join(',', map $_, sub:lvalue{%hash2}->()), | |
785 | qr/^(?:a,b,c,d|c,d,a,b)\z/, 'rv2hv in reference context'; | |
786 | like join(',', map $_, sub:lvalue{%{\%hash2}}->()), | |
787 | qr/^(?:a,b,c,d|c,d,a,b)\z/, 'rv2hv-with-ref in reference context'; | |
4546bcba | 788 | } |
cb0d96b9 NC |
789 | |
790 | { | |
791 | package Foo; | |
792 | sub AUTOLOAD :lvalue { *{$AUTOLOAD} }; | |
793 | package main; | |
794 | my $foo = bless {},"Foo"; | |
795 | my $result; | |
796 | $foo->bar = sub { $result = "bar" }; | |
797 | $foo->bar; | |
798 | is ($result, 'bar', "RT #41550"); | |
799 | } | |
885ef6f5 | 800 | |
c70e3f2a | 801 | SKIP: { skip 'no attributes.pm', 1 unless eval 'require attributes'; |
20e5bab4 | 802 | fresh_perl_is(<<'----', <<'====', {}, "lvalue can not be set after definition. [perl #68758]"); |
885ef6f5 GG |
803 | use warnings; |
804 | our $x; | |
805 | sub foo { $x } | |
806 | sub foo : lvalue; | |
fff96ff7 FC |
807 | sub MODIFY_CODE_ATTRIBUTES {} |
808 | sub foo : lvalue : fr0g; | |
885ef6f5 GG |
809 | foo = 3; |
810 | ---- | |
811 | lvalue attribute ignored after the subroutine has been defined at - line 4. | |
fff96ff7 FC |
812 | lvalue attribute ignored after the subroutine has been defined at - line 6. |
813 | Can't modify non-lvalue subroutine call in scalar assignment at - line 7, near "3;" | |
885ef6f5 GG |
814 | Execution of - aborted due to compilation errors. |
815 | ==== | |
c70e3f2a | 816 | } |
eac910c8 GG |
817 | |
818 | { | |
819 | my $x; | |
820 | sub lval_decl : lvalue; | |
821 | sub lval_decl { $x } | |
822 | lval_decl = 5; | |
823 | is($x, 5, "subroutine declared with lvalue before definition retains lvalue. [perl #68758]"); | |
824 | } | |
f71f472f | 825 | |
c70e3f2a | 826 | SKIP: { skip "no attributes.pm", 2 unless eval { require attributes }; |
b4c6bb84 FC |
827 | sub utf8::valid :lvalue; |
828 | require attributes; | |
829 | is "@{[ &attributes::get(\&utf8::valid) ]}", 'lvalue', | |
4dbb339a FC |
830 | 'sub declaration with :lvalue applies it to XSUBs'; |
831 | ||
b4c6bb84 FC |
832 | BEGIN { *wonky = \&marjibberous } |
833 | sub wonky :lvalue; | |
834 | is "@{[ &attributes::get(\&wonky) ]}", 'lvalue', | |
4dbb339a | 835 | 'sub declaration with :lvalue applies it to assigned stub'; |
c70e3f2a | 836 | } |
4dbb339a | 837 | |
f71f472f FC |
838 | sub fleen : lvalue { $pnare } |
839 | $pnare = __PACKAGE__; | |
840 | ok eval { fleen = 1 }, "lvalues can return COWs (CATTLE?) [perl #75656]";\ | |
841 | is $pnare, 1, 'and returning CATTLE actually works'; | |
a0aa6076 FC |
842 | $pnare = __PACKAGE__; |
843 | ok eval { (fleen) = 1 }, "lvalues can return COWs in list context"; | |
844 | is $pnare, 1, 'and returning COWs in list context actually works'; | |
a1302723 FC |
845 | $pnare = __PACKAGE__; |
846 | ok eval { $_ = 1 for(fleen); 1 }, "lvalues can return COWs in ref cx"; | |
847 | is $pnare, 1, 'and returning COWs in reference context actually works'; | |
145b2bbb FC |
848 | |
849 | ||
850 | # Returning an arbitrary expression, not necessarily lvalue | |
851 | +sub :lvalue { return $ambaga || $ambaga }->() = 73; | |
852 | is $ambaga, 73, 'explicit return of arbitrary expression (scalar context)'; | |
853 | (sub :lvalue { return $ambaga || $ambaga }->()) = 74; | |
854 | is $ambaga, 74, 'explicit return of arbitrary expression (list context)'; | |
855 | +sub :lvalue { $ambaga || $ambaga }->() = 73; | |
856 | is $ambaga, 73, 'implicit return of arbitrary expression (scalar context)'; | |
857 | (sub :lvalue { $ambaga || $ambaga }->()) = 74; | |
858 | is $ambaga, 74, 'implicit return of arbitrary expression (list context)'; | |
145b2bbb FC |
859 | eval { +sub :lvalue { return 3 }->() = 4 }; |
860 | like $@, qr/Can\'t return a readonly value from lvalue subroutine at/, | |
861 | 'assignment to numeric constant explicitly returned from lv sub'; | |
862 | eval { (sub :lvalue { return 3 }->()) = 4 }; | |
863 | like $@, qr/Can\'t return a readonly value from lvalue subroutine at/, | |
864 | 'assignment to num constant explicitly returned (list cx)'; | |
145b2bbb FC |
865 | eval { +sub :lvalue { 3 }->() = 4 }; |
866 | like $@, qr/Can\'t return a readonly value from lvalue subroutine at/, | |
867 | 'assignment to numeric constant implicitly returned from lv sub'; | |
868 | eval { (sub :lvalue { 3 }->()) = 4 }; | |
869 | like $@, qr/Can\'t return a readonly value from lvalue subroutine at/, | |
870 | 'assignment to num constant implicitly returned (list cx)'; | |
bf8fb5eb FC |
871 | |
872 | # reference (potential lvalue) context | |
873 | $suffix = ''; | |
874 | for my $sub (sub :lvalue {$_}, sub :lvalue {return $_}) { | |
875 | &$sub()->${\sub { $_[0] = 37 }}; | |
876 | is $_, '37', 'lvalue->method'.$suffix; | |
877 | ${\scalar &$sub()} = 38; | |
878 | is $_, '38', 'scalar(lvalue)'.$suffix; | |
879 | sub assign39_with_proto ($) { $_[0] = 39 } | |
880 | assign39_with_proto(&$sub()); | |
881 | is $_, '39', 'func(lvalue) when func has $ proto'.$suffix; | |
882 | $_ = 1; | |
883 | ${\(&$sub()||undef)} = 40; | |
884 | is $_, '40', 'lvalue||...'.$suffix; | |
885 | ${\(${\undef}||&$sub())} = 41; # extra ${\...} to bypass const folding | |
886 | is $_, '41', '...||lvalue'.$suffix; | |
887 | $_ = 0; | |
888 | ${\(&$sub()&&undef)} = 42; | |
889 | is $_, '42', 'lvalue&&...'.$suffix; | |
890 | ${\(${\1}&&&$sub())} = 43; | |
891 | is $_, '43', '...&&lvalue'.$suffix; | |
892 | ${\(&$sub())[0]} = 44; | |
893 | is $_, '44', '(lvalue)[0]'.$suffix; | |
894 | } | |
895 | continue { $suffix = ' (explicit return)' } | |
767eda44 FC |
896 | |
897 | # autovivification | |
d507ecb9 | 898 | $suffix = ''; |
767eda44 FC |
899 | for my $sub (sub :lvalue {$_}, sub :lvalue {return $_}) { |
900 | undef $_; | |
901 | &$sub()->[3] = 4; | |
902 | is $_->[3], 4, 'func->[...] autovivification'.$suffix; | |
903 | undef $_; | |
904 | &$sub()->{3} = 4; | |
905 | is $_->{3}, 4, 'func->{...} autovivification'.$suffix; | |
906 | undef $_; | |
907 | ${&$sub()} = 4; | |
908 | is $$_, 4, '${func()} autovivification' .$suffix; | |
909 | undef $_; | |
910 | @{&$sub()} = 4; | |
911 | is "@$_", 4, '@{func()} autovivification' .$suffix; | |
912 | undef $_; | |
913 | %{&$sub()} = (4,5); | |
914 | is join('-',%$_), '4-5', '%{func()} autovivification'.$suffix; | |
0e9700df GG |
915 | undef $_; |
916 | ${ (), &$sub()} = 4; | |
917 | is $$_, 4, '${ (), func()} autovivification' .$suffix; | |
767eda44 FC |
918 | } |
919 | continue { $suffix = ' (explicit return)' } | |
e08be60b FC |
920 | |
921 | # [perl #92406] [perl #92290] Returning a pad var in rvalue context | |
922 | $suffix = ''; | |
923 | for my $sub ( | |
924 | sub :lvalue { my $x = 72; $x }, | |
925 | sub :lvalue { my $x = 72; return $x } | |
926 | ) { | |
927 | is scalar(&$sub), 72, "sub returning pad var in scalar context$suffix"; | |
928 | is +(&$sub)[0], 72, "sub returning pad var in list context$suffix"; | |
929 | } | |
930 | continue { $suffix = ' (explicit return)' } | |
ad37a74e FC |
931 | |
932 | # Returning read-only values in reference context | |
933 | $suffix = ''; | |
934 | for ( | |
935 | sub :lvalue { $] }->(), | |
936 | sub :lvalue { return $] }->() | |
937 | ) { | |
938 | is \$_, \$], 'read-only values are returned in reference context' | |
939 | .$suffix # (they used to be copied) | |
940 | } | |
941 | continue { $suffix = ' (explicit return)' } | |
777d9014 FC |
942 | |
943 | # Returning unwritables from nested lvalue sub call in in rvalue context | |
944 | # First, ensure we are testing what we think we are: | |
945 | if (!Internals::SvREADONLY($])) { Internals::SvREADONLY($],1); } | |
946 | sub squibble : lvalue { return $] } | |
947 | sub squebble : lvalue { squibble } | |
948 | sub squabble : lvalue { return squibble } | |
949 | is $x = squebble, $], 'returning ro from nested lv sub call in rv cx'; | |
950 | is $x = squabble, $], 'explct. returning ro from nested lv sub in rv cx'; | |
951 | is \squebble, \$], 'returning ro from nested lv sub call in ref cx'; | |
952 | is \squabble, \$], 'explct. returning ro from nested lv sub in ref cx'; | |
da1dff94 FC |
953 | |
954 | # [perl #102486] Sub calls as the last statement of an lvalue sub | |
955 | package _102486 { | |
956 | my $called; | |
957 | my $x = 'nonlv'; | |
958 | sub strictlv :lvalue { use strict 'refs'; &$x } | |
959 | sub lv :lvalue { &$x } | |
960 | sub nonlv { ++$called } | |
961 | eval { strictlv }; | |
962 | ::like $@, qr/^Can't use string \("nonlv"\) as a subroutine ref while/, | |
963 | 'strict mode applies to sub:lvalue{ &$string }'; | |
964 | $called = 0; | |
965 | ::ok eval { lv }, | |
966 | 'sub:lvalue{&$x}->() does not die for non-lvalue inner sub call'; | |
967 | ::is $called, 1, 'The &$x actually called the sub'; | |
968 | eval { +sub :lvalue { &$x }->() = 3 }; | |
969 | ::like $@, qr/^Can't modify non-lvalue subroutine call at /, | |
970 | 'sub:lvalue{&$x}->() dies in true lvalue context'; | |
971 | } | |
5811c07e FC |
972 | |
973 | # TARG should be copied in rvalue context | |
974 | sub ucf :lvalue { ucfirst $_[0] } | |
975 | is ucf("just another ") . ucf("perl hacker,\n"), | |
976 | "Just another Perl hacker,\n", 'TARG is copied in rvalue scalar cx'; | |
977 | is join('',ucf("just another "), ucf "perl hacker,\n"), | |
978 | "Just another Perl hacker,\n", 'TARG is copied in rvalue list cx'; | |
979 | sub ucfr : lvalue { | |
980 | @_ ? ucfirst $_[0] : do { | |
981 | is ucfr("just another ") . ucfr("perl hacker,\n"), | |
982 | "Just another Perl hacker,\n", | |
983 | 'TARG is copied in recursive rvalue scalar cx'; | |
984 | is join('',ucfr("just another "), ucfr("perl hacker,\n")), | |
985 | "Just another Perl hacker,\n", | |
986 | 'TARG is copied in recursive rvalue list cx'; | |
987 | } | |
988 | } | |
989 | ucfr(); | |
4587c532 | 990 | |
2d885586 FC |
991 | # Test TARG with potential lvalue context, too |
992 | for (sub : lvalue { "$x" }->()) { | |
993 | is \$_, \$_, '\$_ == \$_ in for(sub :lvalue{"$x"}->()){...}' | |
994 | } | |
995 | ||
4587c532 FC |
996 | # [perl #117947] XSUBs should not be treated as lvalues at run time |
997 | eval { &{\&utf8::is_utf8}("") = 3 }; | |
998 | like $@, qr/^Can't modify non-lvalue subroutine call at /, | |
999 | 'XSUB not seen at compile time dies in lvalue context'; | |
2ec7f6f2 FC |
1000 | |
1001 | # [perl #119797] else implicitly returning value | |
1002 | # This used to cause Bizarre copy of ARRAY in pp_leave | |
1003 | sub else119797 : lvalue { | |
1004 | if ($_[0]) { | |
1005 | 1; # two statements force a leave op | |
1006 | @119797 | |
1007 | } | |
1008 | else { | |
1009 | @119797 | |
1010 | } | |
1011 | } | |
1012 | eval { (else119797(0)) = 1..3 }; | |
1013 | is $@, "", '$@ after writing to array returned by else'; | |
1014 | is "@119797", "1 2 3", 'writing to array returned by else'; | |
1015 | eval { (else119797(1)) = 4..6 }; | |
1016 | is $@, "", '$@ after writing to array returned by if (with else)'; | |
1017 | is "@119797", "4 5 6", 'writing to array returned by if (with else)'; | |
1018 | sub if119797 : lvalue { | |
1019 | if ($_[0]) { | |
1020 | @119797 | |
1021 | } | |
1022 | } | |
1023 | @119797 = (); | |
1024 | eval { (if119797(1)) = 4..6 }; | |
1025 | is $@, "", '$@ after writing to array returned by if'; | |
1026 | is "@119797", "4 5 6", 'writing to array returned by if'; | |
1027 | sub unless119797 : lvalue { | |
1028 | unless ($_[0]) { | |
1029 | @119797 | |
1030 | } | |
1031 | } | |
1032 | @119797 = (); | |
1033 | eval { (unless119797(0)) = 4..6 }; | |
1034 | is $@, "", '$@ after writing to array returned by unless'; | |
1035 | is "@119797", "4 5 6", 'writing to array returned by unless'; | |
a373464f FC |
1036 | sub bare119797 : lvalue { |
1037 | {; | |
1038 | @119797 | |
1039 | } | |
1040 | } | |
1041 | @119797 = (); | |
1042 | eval { (bare119797(0)) = 4..6 }; | |
1043 | is $@, "", '$@ after writing to array returned by bare block'; | |
1044 | is "@119797", "4 5 6", 'writing to array returned by bare block'; |