Commit | Line | Data |
cd06dffe |
1 | BEGIN { |
2 | chdir 't' if -d 't'; |
20822f61 |
3 | @INC = '../lib'; |
cb949c37 |
4 | require './test.pl'; |
cd06dffe |
5 | } |
eac910c8 |
6 | plan tests=>71; |
cd06dffe |
7 | |
78f9721b |
8 | sub a : lvalue { my $a = 34; ${\(bless \$a)} } # Return a temporary |
9 | sub b : lvalue { ${\shift} } |
cd06dffe |
10 | |
11 | my $out = a(b()); # Check that temporaries are allowed. |
cb949c37 |
12 | is(ref $out, 'main'); # Not reached if error. |
cd06dffe |
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 |
16 | |
17 | my $in; |
18 | |
19 | # Check that we can return localized values from subroutines: |
20 | |
a98df962 |
21 | sub in : lvalue { $in = shift; } |
22 | sub neg : lvalue { #(num_str) return num_str |
cd06dffe |
23 | local $_ = shift; |
24 | s/^\+/-/; |
25 | $_; |
26 | } |
27 | in(neg("+2")); |
28 | |
29 | |
cb949c37 |
30 | is($in, '-2'); |
cd06dffe |
31 | |
a98df962 |
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 |
37 | |
38 | $in = 5; |
39 | $blah = 3; |
40 | |
41 | get_st = 7; |
42 | |
cb949c37 |
43 | cmp_ok($blah, '==', 7); |
cd06dffe |
44 | |
45 | get_lex = 7; |
46 | |
cb949c37 |
47 | cmp_ok($in, '==', 7); |
cd06dffe |
48 | |
49 | ++get_st; |
50 | |
cb949c37 |
51 | cmp_ok($blah, '==', 8); |
cd06dffe |
52 | |
53 | ++get_lex; |
54 | |
cb949c37 |
55 | cmp_ok($in, '==', 8); |
cd06dffe |
56 | |
57 | id(get_st) = 10; |
58 | |
cb949c37 |
59 | cmp_ok($blah, '==', 10); |
cd06dffe |
60 | |
61 | id(get_lex) = 10; |
62 | |
cb949c37 |
63 | cmp_ok($in, '==', 10); |
cd06dffe |
64 | |
65 | ++id(get_st); |
66 | |
cb949c37 |
67 | cmp_ok($blah, '==', 11); |
cd06dffe |
68 | |
69 | ++id(get_lex); |
70 | |
cb949c37 |
71 | cmp_ok($in, '==', 11); |
cd06dffe |
72 | |
73 | id1(get_st) = 20; |
74 | |
cb949c37 |
75 | cmp_ok($blah, '==', 20); |
cd06dffe |
76 | |
77 | id1(get_lex) = 20; |
78 | |
cb949c37 |
79 | cmp_ok($in, '==', 20); |
cd06dffe |
80 | |
81 | ++id1(get_st); |
82 | |
cb949c37 |
83 | cmp_ok($blah, '==', 21); |
cd06dffe |
84 | |
85 | ++id1(get_lex); |
86 | |
cb949c37 |
87 | cmp_ok($in, '==', 21); |
cd06dffe |
88 | |
89 | inc(get_st); |
90 | |
cb949c37 |
91 | cmp_ok($blah, '==', 22); |
cd06dffe |
92 | |
93 | inc(get_lex); |
94 | |
cb949c37 |
95 | cmp_ok($in, '==', 22); |
cd06dffe |
96 | |
97 | inc(id(get_st)); |
98 | |
cb949c37 |
99 | cmp_ok($blah, '==', 23); |
cd06dffe |
100 | |
101 | inc(id(get_lex)); |
102 | |
cb949c37 |
103 | cmp_ok($in, '==', 23); |
cd06dffe |
104 | |
105 | ++inc(id1(id(get_st))); |
106 | |
cb949c37 |
107 | cmp_ok($blah, '==', 25); |
cd06dffe |
108 | |
109 | ++inc(id1(id(get_lex))); |
110 | |
cb949c37 |
111 | cmp_ok($in, '==', 25); |
cd06dffe |
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 |
121 | sub a3 :lvalue {@a} |
122 | sub b2 : lvalue {@b} |
123 | sub c4: lvalue {@c} |
cd06dffe |
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 |
136 | like($_, qr/Can\'t return an uninitialized value from lvalue subroutine/); |
137 | print "ok 22\n"; |
138 | |
cd06dffe |
139 | =cut |
140 | |
cd06dffe |
141 | |
142 | my $var; |
143 | |
a98df962 |
144 | sub a::var : lvalue { $var } |
cd06dffe |
145 | |
146 | "a"->var = 45; |
147 | |
cb949c37 |
148 | cmp_ok($var, '==', 45); |
cd06dffe |
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 |
158 | |
159 | o->var = 49; |
160 | |
cb949c37 |
161 | cmp_ok($var, '==', 49); |
cd06dffe |
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 |
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 |
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 |
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 |
201 | |
202 | $x0 = $x1 = $_ = undef; |
203 | $nolv = \&nolv; |
204 | |
205 | eval <<'EOE' or $_ = $@; |
206 | $nolv->() = (2,3); |
207 | 1; |
208 | EOE |
209 | |
cb949c37 |
210 | like($_, qr/Can\'t modify non-lvalue subroutine call/) |
211 | or diag "'$_', '$x0', '$x1'"; |
cd06dffe |
212 | |
a98df962 |
213 | sub lv0 : lvalue { } # Converted to lv10 in scalar context |
cd06dffe |
214 | |
215 | $_ = undef; |
216 | eval <<'EOE' or $_ = $@; |
217 | lv0 = (2,3); |
218 | 1; |
219 | EOE |
220 | |
cb949c37 |
221 | like($_, qr/Can't return undef from lvalue subroutine/); |
cd06dffe |
222 | |
a98df962 |
223 | sub lv10 : lvalue {} |
cd06dffe |
224 | |
225 | $_ = undef; |
226 | eval <<'EOE' or $_ = $@; |
227 | (lv0) = (2,3); |
228 | 1; |
229 | EOE |
230 | |
cb949c37 |
231 | ok(!defined $_) or diag $_; |
cd06dffe |
232 | |
a98df962 |
233 | sub lv1u :lvalue { undef } |
cd06dffe |
234 | |
235 | $_ = undef; |
236 | eval <<'EOE' or $_ = $@; |
237 | lv1u = (2,3); |
238 | 1; |
239 | EOE |
240 | |
cb949c37 |
241 | like($_, qr/Can't return undef from lvalue subroutine/); |
cd06dffe |
242 | |
243 | $_ = undef; |
244 | eval <<'EOE' or $_ = $@; |
245 | (lv1u) = (2,3); |
246 | 1; |
247 | EOE |
248 | |
4c8a4e58 |
249 | # Fixed by change @10777 |
250 | #print "# '$_'.\nnot " |
251 | # unless /Can\'t return an uninitialized value from lvalue subroutine/; |
cb949c37 |
252 | # print "ok 34 # Skip: removed test\n"; |
cd06dffe |
253 | |
254 | $x = '1234567'; |
cd06dffe |
255 | |
256 | $_ = undef; |
257 | eval <<'EOE' or $_ = $@; |
78f9721b |
258 | sub lv1t : lvalue { index $x, 2 } |
cd06dffe |
259 | lv1t = (2,3); |
260 | 1; |
261 | EOE |
262 | |
cb949c37 |
263 | like($_, qr/Can\'t modify index in lvalue subroutine return/); |
cd06dffe |
264 | |
265 | $_ = undef; |
266 | eval <<'EOE' or $_ = $@; |
78f9721b |
267 | sub lv2t : lvalue { shift } |
268 | (lv2t) = (2,3); |
cd06dffe |
269 | 1; |
270 | EOE |
271 | |
cb949c37 |
272 | like($_, qr/Can\'t modify shift in lvalue subroutine return/); |
cd06dffe |
273 | |
274 | $xxx = 'xxx'; |
275 | sub xxx () { $xxx } # Not lvalue |
cd06dffe |
276 | |
277 | $_ = undef; |
278 | eval <<'EOE' or $_ = $@; |
78f9721b |
279 | sub lv1tmp : lvalue { xxx } # is it a TEMP? |
cd06dffe |
280 | lv1tmp = (2,3); |
281 | 1; |
282 | EOE |
283 | |
cb949c37 |
284 | like($_, qr/Can\'t modify non-lvalue subroutine call in lvalue subroutine return/); |
cd06dffe |
285 | |
286 | $_ = undef; |
287 | eval <<'EOE' or $_ = $@; |
288 | (lv1tmp) = (2,3); |
289 | 1; |
290 | EOE |
291 | |
cb949c37 |
292 | like($_, qr/Can\'t return a temporary from lvalue subroutine/); |
cd06dffe |
293 | |
9a049f1c |
294 | sub yyy () { 'yyy' } # Const, not lvalue |
cd06dffe |
295 | |
296 | $_ = undef; |
297 | eval <<'EOE' or $_ = $@; |
78f9721b |
298 | sub lv1tmpr : lvalue { yyy } # is it read-only? |
cd06dffe |
299 | lv1tmpr = (2,3); |
300 | 1; |
301 | EOE |
302 | |
cb949c37 |
303 | like($_, qr/Can\'t modify constant item in lvalue subroutine return/); |
cd06dffe |
304 | |
305 | $_ = undef; |
306 | eval <<'EOE' or $_ = $@; |
307 | (lv1tmpr) = (2,3); |
308 | 1; |
309 | EOE |
310 | |
cb949c37 |
311 | like($_, qr/Can\'t return a readonly value from lvalue subroutine/); |
cd06dffe |
312 | |
a98df962 |
313 | sub lva : lvalue {@a} |
cd06dffe |
314 | |
315 | $_ = undef; |
316 | @a = (); |
317 | $a[1] = 12; |
318 | eval <<'EOE' or $_ = $@; |
319 | (lva) = (2,3); |
320 | 1; |
321 | EOE |
322 | |
cb949c37 |
323 | is("'@a' $_", "'2 3' "); |
cd06dffe |
324 | |
325 | $_ = undef; |
326 | @a = (); |
327 | $a[0] = undef; |
328 | $a[1] = 12; |
329 | eval <<'EOE' or $_ = $@; |
330 | (lva) = (2,3); |
331 | 1; |
332 | EOE |
333 | |
cb949c37 |
334 | is("'@a' $_", "'2 3' "); |
cd06dffe |
335 | |
336 | $_ = undef; |
337 | @a = (); |
338 | $a[0] = undef; |
339 | $a[1] = 12; |
340 | eval <<'EOE' or $_ = $@; |
341 | (lva) = (2,3); |
342 | 1; |
343 | EOE |
344 | |
cb949c37 |
345 | is("'@a' $_", "'2 3' "); |
cd06dffe |
346 | |
a98df962 |
347 | sub lv1n : lvalue { $newvar } |
cd06dffe |
348 | |
349 | $_ = undef; |
350 | eval <<'EOE' or $_ = $@; |
351 | lv1n = (3,4); |
352 | 1; |
353 | EOE |
354 | |
cb949c37 |
355 | is("'$newvar' $_", "'4' "); |
cd06dffe |
356 | |
a98df962 |
357 | sub lv1nn : lvalue { $nnewvar } |
cd06dffe |
358 | |
359 | $_ = undef; |
360 | eval <<'EOE' or $_ = $@; |
361 | (lv1nn) = (3,4); |
362 | 1; |
363 | EOE |
364 | |
cb949c37 |
365 | is("'$nnewvar' $_", "'3' "); |
cd06dffe |
366 | |
367 | $a = \&lv1nn; |
368 | $a->() = 8; |
cb949c37 |
369 | is($nnewvar, '8'); |
d32f2495 |
370 | |
84251760 |
371 | eval 'sub AUTOLOAD : lvalue { $newvar }'; |
d32f2495 |
372 | foobar() = 12; |
cb949c37 |
373 | is($newvar, "12"); |
26191e78 |
374 | |
78f9721b |
375 | { |
376 | my %hash; my @array; |
377 | sub alv : lvalue { $array[1] } |
378 | sub alv2 : lvalue { $array[$_[0]] } |
379 | sub hlv : lvalue { $hash{"foo"} } |
380 | sub hlv2 : lvalue { $hash{$_[0]} } |
381 | $array[1] = "not ok 51\n"; |
382 | alv() = "ok 50\n"; |
cb949c37 |
383 | is(alv(), "ok 50\n"); |
78f9721b |
384 | |
385 | alv2(20) = "ok 51\n"; |
cb949c37 |
386 | is($array[20], "ok 51\n"); |
78f9721b |
387 | |
388 | $hash{"foo"} = "not ok 52\n"; |
389 | hlv() = "ok 52\n"; |
cb949c37 |
390 | is($hash{foo}, "ok 52\n"); |
78f9721b |
391 | |
392 | $hash{bar} = "not ok 53\n"; |
393 | hlv("bar") = "ok 53\n"; |
cb949c37 |
394 | is(hlv("bar"), "ok 53\n"); |
78f9721b |
395 | |
396 | sub array : lvalue { @array } |
397 | sub array2 : lvalue { @array2 } # This is a global. |
398 | sub hash : lvalue { %hash } |
399 | sub hash2 : lvalue { %hash2 } # So's this. |
400 | @array2 = qw(foo bar); |
401 | %hash2 = qw(foo bar); |
402 | |
403 | (array()) = qw(ok 54); |
cb949c37 |
404 | is("@array", "ok 54"); |
78f9721b |
405 | |
406 | (array2()) = qw(ok 55); |
cb949c37 |
407 | is("@array2", "ok 55"); |
78f9721b |
408 | |
409 | (hash()) = qw(ok 56); |
cb949c37 |
410 | cmp_ok($hash{ok}, '==', 56); |
78f9721b |
411 | |
412 | (hash2()) = qw(ok 57); |
cb949c37 |
413 | cmp_ok($hash2{ok}, '==', 57); |
78f9721b |
414 | |
415 | @array = qw(a b c d); |
416 | sub aslice1 : lvalue { @array[0,2] }; |
417 | (aslice1()) = ("ok", "already"); |
cb949c37 |
418 | is("@array", "ok b already d"); |
78f9721b |
419 | |
420 | @array2 = qw(a B c d); |
421 | sub aslice2 : lvalue { @array2[0,2] }; |
422 | (aslice2()) = ("ok", "already"); |
cb949c37 |
423 | is("@array2", "ok B already d"); |
78f9721b |
424 | |
425 | %hash = qw(a Alpha b Beta c Gamma); |
426 | sub hslice : lvalue { @hash{"c", "b"} } |
427 | (hslice()) = ("CISC", "BogoMIPS"); |
cb949c37 |
428 | is(join("/",@hash{"c","a","b"}), "CISC/Alpha/BogoMIPS"); |
78f9721b |
429 | } |
430 | |
431 | $str = "Hello, world!"; |
432 | sub sstr : lvalue { substr($str, 1, 4) } |
433 | sstr() = "i"; |
cb949c37 |
434 | is($str, "Hi, world!"); |
78f9721b |
435 | |
436 | $str = "Made w/ JavaScript"; |
437 | sub veclv : lvalue { vec($str, 2, 32) } |
e6b8b224 |
438 | if (ord('A') != 193) { |
439 | veclv() = 0x5065726C; |
440 | } |
441 | else { # EBCDIC? |
442 | veclv() = 0xD7859993; |
443 | } |
cb949c37 |
444 | is($str, "Made w/ PerlScript"); |
78f9721b |
445 | |
446 | sub position : lvalue { pos } |
447 | @p = (); |
448 | $_ = "fee fi fo fum"; |
449 | while (/f/g) { |
450 | push @p, position; |
451 | position() += 6; |
452 | } |
cb949c37 |
453 | is("@p", "1 8"); |
7c8af4ef |
454 | |
455 | # Bug 20001223.002: split thought that the list had only one element |
456 | @ary = qw(4 5 6); |
457 | sub lval1 : lvalue { $ary[0]; } |
458 | sub lval2 : lvalue { $ary[1]; } |
459 | (lval1(), lval2()) = split ' ', "1 2 3 4"; |
cb949c37 |
460 | |
461 | is(join(':', @ary), "1:2:6"); |
1c4274f4 |
462 | |
f9bc45ef |
463 | # check that an element of a tied hash/array can be assigned to via lvalueness |
464 | |
465 | package Tie_Hash; |
466 | |
467 | our ($key, $val); |
468 | sub TIEHASH { bless \my $v => __PACKAGE__ } |
469 | sub STORE { ($key, $val) = @_[1,2] } |
470 | |
471 | package main; |
472 | sub lval_tie_hash : lvalue { |
473 | tie my %t => 'Tie_Hash'; |
474 | $t{key}; |
475 | } |
476 | |
477 | eval { lval_tie_hash() = "value"; }; |
478 | |
cb949c37 |
479 | is($@, "", "element of tied hash"); |
f9bc45ef |
480 | |
cb949c37 |
481 | is("$Tie_Hash::key-$Tie_Hash::val", "key-value"); |
f9bc45ef |
482 | |
483 | |
484 | package Tie_Array; |
485 | |
486 | our @val; |
487 | sub TIEARRAY { bless \my $v => __PACKAGE__ } |
488 | sub STORE { $val[ $_[1] ] = $_[2] } |
489 | |
490 | package main; |
491 | sub lval_tie_array : lvalue { |
492 | tie my @t => 'Tie_Array'; |
493 | $t[0]; |
494 | } |
495 | |
496 | eval { lval_tie_array() = "value"; }; |
497 | |
f9bc45ef |
498 | |
cb949c37 |
499 | is($@, "", "element of tied array"); |
f9bc45ef |
500 | |
cb949c37 |
501 | is ($Tie_Array::val[0], "value"); |
1c4274f4 |
502 | |
503 | TODO: { |
504 | local $TODO = 'test explicit return of lval expr'; |
505 | |
506 | # subs are corrupted copies from tests 1-~4 |
507 | sub bad_get_lex : lvalue { return $in }; |
508 | sub bad_get_st : lvalue { return $blah } |
509 | |
510 | sub bad_id : lvalue { return ${\shift} } |
511 | sub bad_id1 : lvalue { return $_[0] } |
512 | sub bad_inc : lvalue { return ${\++$_[0]} } |
513 | |
514 | $in = 5; |
515 | $blah = 3; |
516 | |
517 | bad_get_st = 7; |
518 | |
519 | is( $blah, 7 ); |
520 | |
521 | bad_get_lex = 7; |
522 | |
523 | is($in, 7, "yada"); |
524 | |
525 | ++bad_get_st; |
526 | |
527 | is($blah, 8, "yada"); |
528 | } |
529 | |
4546bcba |
530 | TODO: { |
531 | local $TODO = "bug #23790"; |
532 | my @arr = qw /one two three/; |
533 | my $line = "zero"; |
534 | sub lval_array () : lvalue {@arr} |
535 | |
536 | for (lval_array) { |
537 | $line .= $_; |
538 | } |
539 | |
540 | is($line, "zeroonetwothree"); |
541 | } |
cb0d96b9 |
542 | |
543 | { |
544 | package Foo; |
545 | sub AUTOLOAD :lvalue { *{$AUTOLOAD} }; |
546 | package main; |
547 | my $foo = bless {},"Foo"; |
548 | my $result; |
549 | $foo->bar = sub { $result = "bar" }; |
550 | $foo->bar; |
551 | is ($result, 'bar', "RT #41550"); |
552 | } |
885ef6f5 |
553 | |
554 | fresh_perl_is(<<'----', <<'====', "lvalue can not be set after definition. [perl #68758]"); |
555 | use warnings; |
556 | our $x; |
557 | sub foo { $x } |
558 | sub foo : lvalue; |
559 | foo = 3; |
560 | ---- |
561 | lvalue attribute ignored after the subroutine has been defined at - line 4. |
562 | Can't modify non-lvalue subroutine call in scalar assignment at - line 5, near "3;" |
563 | Execution of - aborted due to compilation errors. |
564 | ==== |
eac910c8 |
565 | |
566 | { |
567 | my $x; |
568 | sub lval_decl : lvalue; |
569 | sub lval_decl { $x } |
570 | lval_decl = 5; |
571 | is($x, 5, "subroutine declared with lvalue before definition retains lvalue. [perl #68758]"); |
572 | } |