This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Allow lvalue subs to return TEMPs
[perl5.git] / t / op / sub_lval.t
CommitLineData
cd06dffe
GS
1BEGIN {
2 chdir 't' if -d 't';
20822f61 3 @INC = '../lib';
cb949c37 4 require './test.pl';
cd06dffe 5}
fd6c41ce 6plan tests=>100;
cd06dffe 7
78f9721b
SM
8sub a : lvalue { my $a = 34; ${\(bless \$a)} } # Return a temporary
9sub b : lvalue { ${\shift} }
cd06dffe
GS
10
11my $out = a(b()); # Check that temporaries are allowed.
cb949c37 12is(ref $out, 'main'); # Not reached if error.
cd06dffe
GS
13
14my @out = grep /main/, a(b()); # Check that temporaries are allowed.
cb949c37 15cmp_ok(scalar @out, '==', 1); # Not reached if error.
cd06dffe
GS
16
17my $in;
18
19# Check that we can return localized values from subroutines:
20
a98df962
GS
21sub in : lvalue { $in = shift; }
22sub neg : lvalue { #(num_str) return num_str
cd06dffe
GS
23 local $_ = shift;
24 s/^\+/-/;
25 $_;
26}
27in(neg("+2"));
28
29
cb949c37 30is($in, '-2');
cd06dffe 31
a98df962
GS
32sub get_lex : lvalue { $in }
33sub get_st : lvalue { $blah }
78f9721b 34sub id : lvalue { ${\shift} }
a98df962 35sub id1 : lvalue { $_[0] }
78f9721b 36sub inc : lvalue { ${\++$_[0]} }
cd06dffe
GS
37
38$in = 5;
39$blah = 3;
40
41get_st = 7;
42
cb949c37 43cmp_ok($blah, '==', 7);
cd06dffe
GS
44
45get_lex = 7;
46
cb949c37 47cmp_ok($in, '==', 7);
cd06dffe
GS
48
49++get_st;
50
cb949c37 51cmp_ok($blah, '==', 8);
cd06dffe
GS
52
53++get_lex;
54
cb949c37 55cmp_ok($in, '==', 8);
cd06dffe
GS
56
57id(get_st) = 10;
58
cb949c37 59cmp_ok($blah, '==', 10);
cd06dffe
GS
60
61id(get_lex) = 10;
62
cb949c37 63cmp_ok($in, '==', 10);
cd06dffe
GS
64
65++id(get_st);
66
cb949c37 67cmp_ok($blah, '==', 11);
cd06dffe
GS
68
69++id(get_lex);
70
cb949c37 71cmp_ok($in, '==', 11);
cd06dffe
GS
72
73id1(get_st) = 20;
74
cb949c37 75cmp_ok($blah, '==', 20);
cd06dffe
GS
76
77id1(get_lex) = 20;
78
cb949c37 79cmp_ok($in, '==', 20);
cd06dffe
GS
80
81++id1(get_st);
82
cb949c37 83cmp_ok($blah, '==', 21);
cd06dffe
GS
84
85++id1(get_lex);
86
cb949c37 87cmp_ok($in, '==', 21);
cd06dffe
GS
88
89inc(get_st);
90
cb949c37 91cmp_ok($blah, '==', 22);
cd06dffe
GS
92
93inc(get_lex);
94
cb949c37 95cmp_ok($in, '==', 22);
cd06dffe
GS
96
97inc(id(get_st));
98
cb949c37 99cmp_ok($blah, '==', 23);
cd06dffe
GS
100
101inc(id(get_lex));
102
cb949c37 103cmp_ok($in, '==', 23);
cd06dffe
GS
104
105++inc(id1(id(get_st)));
106
cb949c37 107cmp_ok($blah, '==', 25);
cd06dffe
GS
108
109++inc(id1(id(get_lex)));
110
cb949c37 111cmp_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
121sub a3 :lvalue {@a}
122sub b2 : lvalue {@b}
123sub c4: lvalue {@c}
cd06dffe
GS
124
125$_ = '';
126
127eval <<'EOE' or $_ = $@;
128 ($x, a3, $y, b2, $z, c4, $t) = (34 .. 78);
129 1;
130EOE
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
136like($_, qr/Can\'t return an uninitialized value from lvalue subroutine/);
137print "ok 22\n";
138
cd06dffe
GS
139=cut
140
cd06dffe
GS
141
142my $var;
143
a98df962 144sub a::var : lvalue { $var }
cd06dffe
GS
145
146"a"->var = 45;
147
cb949c37 148cmp_ok($var, '==', 45);
cd06dffe
GS
149
150my $oo;
151$o = bless \$oo, "a";
152
153$o->var = 47;
154
cb949c37 155cmp_ok($var, '==', 47);
cd06dffe 156
a98df962 157sub o : lvalue { $o }
cd06dffe
GS
158
159o->var = 49;
160
cb949c37 161cmp_ok($var, '==', 49);
cd06dffe
GS
162
163sub nolv () { $x0, $x1 } # Not lvalue
164
165$_ = '';
166
167eval <<'EOE' or $_ = $@;
168 nolv = (2,3);
169 1;
170EOE
171
cb949c37 172like($_, qr/Can\'t modify non-lvalue subroutine call in scalar assignment/);
cd06dffe
GS
173
174$_ = '';
175
176eval <<'EOE' or $_ = $@;
177 nolv = (2,3) if $_;
178 1;
179EOE
180
cb949c37 181like($_, qr/Can\'t modify non-lvalue subroutine call in scalar assignment/);
cd06dffe
GS
182
183$_ = '';
184
185eval <<'EOE' or $_ = $@;
186 &nolv = (2,3) if $_;
187 1;
188EOE
189
cb949c37 190like($_, qr/Can\'t modify non-lvalue subroutine call in scalar assignment/);
cd06dffe
GS
191
192$x0 = $x1 = $_ = undef;
193$nolv = \&nolv;
194
195eval <<'EOE' or $_ = $@;
196 $nolv->() = (2,3) if $_;
197 1;
198EOE
199
cb949c37 200ok(!defined $_) or diag "'$_', '$x0', '$x1'";
cd06dffe
GS
201
202$x0 = $x1 = $_ = undef;
203$nolv = \&nolv;
204
205eval <<'EOE' or $_ = $@;
206 $nolv->() = (2,3);
207 1;
208EOE
209
cb949c37
NC
210like($_, qr/Can\'t modify non-lvalue subroutine call/)
211 or diag "'$_', '$x0', '$x1'";
cd06dffe 212
a98df962 213sub lv0 : lvalue { } # Converted to lv10 in scalar context
cd06dffe
GS
214
215$_ = undef;
216eval <<'EOE' or $_ = $@;
217 lv0 = (2,3);
218 1;
219EOE
220
c73030b8 221like($_, qr/Can't return undef from lvalue subroutine/);
cd06dffe 222
a98df962 223sub lv10 : lvalue {}
cd06dffe
GS
224
225$_ = undef;
226eval <<'EOE' or $_ = $@;
227 (lv0) = (2,3);
228 1;
229EOE
230
cb949c37 231ok(!defined $_) or diag $_;
cd06dffe 232
a98df962 233sub lv1u :lvalue { undef }
cd06dffe
GS
234
235$_ = undef;
236eval <<'EOE' or $_ = $@;
237 lv1u = (2,3);
238 1;
239EOE
240
c73030b8 241like($_, qr/Can't return undef from lvalue subroutine/);
cd06dffe
GS
242
243$_ = undef;
244eval <<'EOE' or $_ = $@;
245 (lv1u) = (2,3);
246 1;
247EOE
248
4c8a4e58
JH
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
GS
253
254$x = '1234567';
cd06dffe
GS
255
256$_ = undef;
257eval <<'EOE' or $_ = $@;
78f9721b 258 sub lv1t : lvalue { index $x, 2 }
cd06dffe
GS
259 lv1t = (2,3);
260 1;
261EOE
262
cb949c37 263like($_, qr/Can\'t modify index in lvalue subroutine return/);
cd06dffe
GS
264
265$_ = undef;
266eval <<'EOE' or $_ = $@;
78f9721b
SM
267 sub lv2t : lvalue { shift }
268 (lv2t) = (2,3);
cd06dffe
GS
269 1;
270EOE
271
cb949c37 272like($_, qr/Can\'t modify shift in lvalue subroutine return/);
cd06dffe
GS
273
274$xxx = 'xxx';
275sub xxx () { $xxx } # Not lvalue
cd06dffe
GS
276
277$_ = undef;
278eval <<'EOE' or $_ = $@;
78f9721b 279 sub lv1tmp : lvalue { xxx } # is it a TEMP?
cd06dffe
GS
280 lv1tmp = (2,3);
281 1;
282EOE
283
cb949c37 284like($_, qr/Can\'t modify non-lvalue subroutine call in lvalue subroutine return/);
cd06dffe
GS
285
286$_ = undef;
287eval <<'EOE' or $_ = $@;
288 (lv1tmp) = (2,3);
289 1;
290EOE
291
fd6c41ce
FC
292is($_, undef, "returning a temp from an lvalue sub in list context");
293
294$_ = undef;
295eval <<'EOE' or $_ = $@;
296 lv1tmp = 3;
297 1;
298EOE
299
300is($_, undef, "returning a temp from an lvalue sub in scalar context");
cd06dffe 301
9a049f1c 302sub yyy () { 'yyy' } # Const, not lvalue
cd06dffe
GS
303
304$_ = undef;
305eval <<'EOE' or $_ = $@;
78f9721b 306 sub lv1tmpr : lvalue { yyy } # is it read-only?
cd06dffe
GS
307 lv1tmpr = (2,3);
308 1;
309EOE
310
cb949c37 311like($_, qr/Can\'t modify constant item in lvalue subroutine return/);
cd06dffe
GS
312
313$_ = undef;
314eval <<'EOE' or $_ = $@;
315 (lv1tmpr) = (2,3);
316 1;
317EOE
318
cb949c37 319like($_, qr/Can\'t return a readonly value from lvalue subroutine/);
cd06dffe 320
a98df962 321sub lva : lvalue {@a}
cd06dffe
GS
322
323$_ = undef;
324@a = ();
325$a[1] = 12;
326eval <<'EOE' or $_ = $@;
327 (lva) = (2,3);
328 1;
329EOE
330
cb949c37 331is("'@a' $_", "'2 3' ");
cd06dffe
GS
332
333$_ = undef;
334@a = ();
335$a[0] = undef;
336$a[1] = 12;
337eval <<'EOE' or $_ = $@;
338 (lva) = (2,3);
339 1;
340EOE
341
cb949c37 342is("'@a' $_", "'2 3' ");
cd06dffe
GS
343
344$_ = undef;
345@a = ();
346$a[0] = undef;
347$a[1] = 12;
348eval <<'EOE' or $_ = $@;
349 (lva) = (2,3);
350 1;
351EOE
352
cb949c37 353is("'@a' $_", "'2 3' ");
cd06dffe 354
a98df962 355sub lv1n : lvalue { $newvar }
cd06dffe
GS
356
357$_ = undef;
358eval <<'EOE' or $_ = $@;
359 lv1n = (3,4);
360 1;
361EOE
362
cb949c37 363is("'$newvar' $_", "'4' ");
cd06dffe 364
a98df962 365sub lv1nn : lvalue { $nnewvar }
cd06dffe
GS
366
367$_ = undef;
368eval <<'EOE' or $_ = $@;
369 (lv1nn) = (3,4);
370 1;
371EOE
372
cb949c37 373is("'$nnewvar' $_", "'3' ");
cd06dffe
GS
374
375$a = \&lv1nn;
376$a->() = 8;
cb949c37 377is($nnewvar, '8');
d32f2495 378
84251760 379eval 'sub AUTOLOAD : lvalue { $newvar }';
d32f2495 380foobar() = 12;
cb949c37 381is($newvar, "12");
26191e78 382
78f9721b
SM
383{
384my %hash; my @array;
385sub alv : lvalue { $array[1] }
386sub alv2 : lvalue { $array[$_[0]] }
387sub hlv : lvalue { $hash{"foo"} }
388sub hlv2 : lvalue { $hash{$_[0]} }
389$array[1] = "not ok 51\n";
390alv() = "ok 50\n";
cb949c37 391is(alv(), "ok 50\n");
78f9721b
SM
392
393alv2(20) = "ok 51\n";
cb949c37 394is($array[20], "ok 51\n");
78f9721b
SM
395
396$hash{"foo"} = "not ok 52\n";
397hlv() = "ok 52\n";
cb949c37 398is($hash{foo}, "ok 52\n");
78f9721b
SM
399
400$hash{bar} = "not ok 53\n";
401hlv("bar") = "ok 53\n";
cb949c37 402is(hlv("bar"), "ok 53\n");
78f9721b
SM
403
404sub array : lvalue { @array }
405sub array2 : lvalue { @array2 } # This is a global.
406sub hash : lvalue { %hash }
407sub hash2 : lvalue { %hash2 } # So's this.
408@array2 = qw(foo bar);
409%hash2 = qw(foo bar);
410
411(array()) = qw(ok 54);
cb949c37 412is("@array", "ok 54");
78f9721b
SM
413
414(array2()) = qw(ok 55);
cb949c37 415is("@array2", "ok 55");
78f9721b
SM
416
417(hash()) = qw(ok 56);
cb949c37 418cmp_ok($hash{ok}, '==', 56);
78f9721b
SM
419
420(hash2()) = qw(ok 57);
cb949c37 421cmp_ok($hash2{ok}, '==', 57);
78f9721b
SM
422
423@array = qw(a b c d);
424sub aslice1 : lvalue { @array[0,2] };
425(aslice1()) = ("ok", "already");
cb949c37 426is("@array", "ok b already d");
78f9721b
SM
427
428@array2 = qw(a B c d);
429sub aslice2 : lvalue { @array2[0,2] };
430(aslice2()) = ("ok", "already");
cb949c37 431is("@array2", "ok B already d");
78f9721b
SM
432
433%hash = qw(a Alpha b Beta c Gamma);
434sub hslice : lvalue { @hash{"c", "b"} }
435(hslice()) = ("CISC", "BogoMIPS");
cb949c37 436is(join("/",@hash{"c","a","b"}), "CISC/Alpha/BogoMIPS");
78f9721b
SM
437}
438
439$str = "Hello, world!";
440sub sstr : lvalue { substr($str, 1, 4) }
441sstr() = "i";
cb949c37 442is($str, "Hi, world!");
78f9721b
SM
443
444$str = "Made w/ JavaScript";
445sub veclv : lvalue { vec($str, 2, 32) }
e6b8b224
PP
446if (ord('A') != 193) {
447 veclv() = 0x5065726C;
448}
449else { # EBCDIC?
450 veclv() = 0xD7859993;
451}
cb949c37 452is($str, "Made w/ PerlScript");
78f9721b
SM
453
454sub position : lvalue { pos }
455@p = ();
456$_ = "fee fi fo fum";
457while (/f/g) {
458 push @p, position;
459 position() += 6;
460}
cb949c37 461is("@p", "1 8");
7c8af4ef
RG
462
463# Bug 20001223.002: split thought that the list had only one element
464@ary = qw(4 5 6);
465sub lval1 : lvalue { $ary[0]; }
466sub lval2 : lvalue { $ary[1]; }
467(lval1(), lval2()) = split ' ', "1 2 3 4";
cb949c37
NC
468
469is(join(':', @ary), "1:2:6");
1c4274f4 470
f9bc45ef
TP
471# check that an element of a tied hash/array can be assigned to via lvalueness
472
473package Tie_Hash;
474
475our ($key, $val);
476sub TIEHASH { bless \my $v => __PACKAGE__ }
477sub STORE { ($key, $val) = @_[1,2] }
478
479package main;
480sub lval_tie_hash : lvalue {
481 tie my %t => 'Tie_Hash';
482 $t{key};
483}
484
485eval { lval_tie_hash() = "value"; };
486
cb949c37 487is($@, "", "element of tied hash");
f9bc45ef 488
cb949c37 489is("$Tie_Hash::key-$Tie_Hash::val", "key-value");
f9bc45ef
TP
490
491
492package Tie_Array;
493
494our @val;
495sub TIEARRAY { bless \my $v => __PACKAGE__ }
496sub STORE { $val[ $_[1] ] = $_[2] }
497
498package main;
499sub lval_tie_array : lvalue {
500 tie my @t => 'Tie_Array';
501 $t[0];
502}
503
504eval { lval_tie_array() = "value"; };
505
f9bc45ef 506
cb949c37 507is($@, "", "element of tied array");
f9bc45ef 508
cb949c37 509is ($Tie_Array::val[0], "value");
1c4274f4 510
1c4274f4 511
fa1e92c4
FC
512# Test explicit return of lvalue expression
513{
514 # subs are copies from tests 1-~18 with an explicit return added.
515 # They used not to work, which is why they are ‘badly’ named.
1c4274f4
MS
516 sub bad_get_lex : lvalue { return $in };
517 sub bad_get_st : lvalue { return $blah }
518
519 sub bad_id : lvalue { return ${\shift} }
520 sub bad_id1 : lvalue { return $_[0] }
521 sub bad_inc : lvalue { return ${\++$_[0]} }
522
523 $in = 5;
524 $blah = 3;
525
526 bad_get_st = 7;
527
528 is( $blah, 7 );
529
530 bad_get_lex = 7;
531
532 is($in, 7, "yada");
533
534 ++bad_get_st;
535
536 is($blah, 8, "yada");
07fd1c9c
FC
537
538 ++bad_get_lex;
539 cmp_ok($in, '==', 8);
540
541 bad_id(bad_get_st) = 10;
542 cmp_ok($blah, '==', 10);
543
544 bad_id(bad_get_lex) = 10;
545 cmp_ok($in, '==', 10);
546
547 ++bad_id(bad_get_st);
548 cmp_ok($blah, '==', 11);
549
550 ++bad_id(bad_get_lex);
551 cmp_ok($in, '==', 11);
552
553 bad_id1(bad_get_st) = 20;
554 cmp_ok($blah, '==', 20);
555
556 bad_id1(bad_get_lex) = 20;
557 cmp_ok($in, '==', 20);
558
559 ++bad_id1(bad_get_st);
560 cmp_ok($blah, '==', 21);
561
562 ++bad_id1(bad_get_lex);
563 cmp_ok($in, '==', 21);
564
565 bad_inc(bad_get_st);
566 cmp_ok($blah, '==', 22);
567
568 bad_inc(bad_get_lex);
569 cmp_ok($in, '==', 22);
570
571 bad_inc(bad_id(bad_get_st));
572 cmp_ok($blah, '==', 23);
573
574 bad_inc(bad_id(bad_get_lex));
575 cmp_ok($in, '==', 23);
576
577 ++bad_inc(bad_id1(bad_id(bad_get_st)));
578 cmp_ok($blah, '==', 25);
579
580 ++bad_inc(bad_id1(bad_id(bad_get_lex)));
581 cmp_ok($in, '==', 25);
1ffdc07c
FC
582
583 # Recursive
584 my $r;
585 my $to_modify;
586 $r = sub :lvalue {
587 my $depth = shift//0;
588 if ($depth == 2) { return $to_modify }
589 return &$r($depth+1);
590 };
591 &$r(0) = 7;
592 is $to_modify, 7, 'recursive lvalue sub';
f6a9f8a4
FC
593
594 # Recursive with substr [perl #72706]
595 my $val = '';
596 my $pie;
597 $pie = sub :lvalue {
598 my $depth = shift;
599 return &$pie($depth) if $depth--;
600 substr $val, 0;
601 };
602 for my $depth (0, 1, 2) {
603 my $value = "Good $depth";
604 eval {
605 &$pie($depth) = $value;
606 };
607 is($@, '', "recursive lvalue substr return depth $depth");
608 is($val, $value,
609 "value assigned to recursive lvalue substr (depth $depth)");
610 }
1c4274f4
MS
611}
612
91e34d82 613{ # bug #23790
4546bcba
RGS
614 my @arr = qw /one two three/;
615 my $line = "zero";
616 sub lval_array () : lvalue {@arr}
617
618 for (lval_array) {
619 $line .= $_;
620 }
621
622 is($line, "zeroonetwothree");
91e34d82
MP
623
624 sub trythislval { scalar(@_)."x".join "", @_ }
625 is(trythislval(lval_array()), "3xonetwothree");
626
627 sub changeme { $_[2] = "free" }
628 changeme(lval_array);
629 is("@arr", "one two free");
4546bcba 630}
cb0d96b9
NC
631
632{
633 package Foo;
634 sub AUTOLOAD :lvalue { *{$AUTOLOAD} };
635 package main;
636 my $foo = bless {},"Foo";
637 my $result;
638 $foo->bar = sub { $result = "bar" };
639 $foo->bar;
640 is ($result, 'bar', "RT #41550");
641}
885ef6f5
GG
642
643fresh_perl_is(<<'----', <<'====', "lvalue can not be set after definition. [perl #68758]");
644use warnings;
645our $x;
646sub foo { $x }
647sub foo : lvalue;
648foo = 3;
649----
650lvalue attribute ignored after the subroutine has been defined at - line 4.
651Can't modify non-lvalue subroutine call in scalar assignment at - line 5, near "3;"
652Execution of - aborted due to compilation errors.
653====
eac910c8
GG
654
655{
656 my $x;
657 sub lval_decl : lvalue;
658 sub lval_decl { $x }
659 lval_decl = 5;
660 is($x, 5, "subroutine declared with lvalue before definition retains lvalue. [perl #68758]");
661}
f71f472f
FC
662
663sub fleen : lvalue { $pnare }
664$pnare = __PACKAGE__;
665ok eval { fleen = 1 }, "lvalues can return COWs (CATTLE?) [perl #75656]";\
666is $pnare, 1, 'and returning CATTLE actually works';
a0aa6076
FC
667$pnare = __PACKAGE__;
668ok eval { (fleen) = 1 }, "lvalues can return COWs in list context";
669is $pnare, 1, 'and returning COWs in list context actually works';