This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
[perl #72724] explicit return doesn’t work with lvalue subs
[perl5.git] / t / op / sub_lval.t
1 BEGIN {
2     chdir 't' if -d 't';
3     @INC = '../lib';
4     require './test.pl';
5 }
6 plan tests=>90;
7
8 sub a : lvalue { my $a = 34; ${\(bless \$a)} }  # Return a temporary
9 sub b : lvalue { ${\shift} }
10
11 my $out = a(b());               # Check that temporaries are allowed.
12 is(ref $out, 'main'); # Not reached if error.
13
14 my @out = grep /main/, a(b()); # Check that temporaries are allowed.
15 cmp_ok(scalar @out, '==', 1); # Not reached if error.
16
17 my $in;
18
19 # Check that we can return localized values from subroutines:
20
21 sub in : lvalue { $in = shift; }
22 sub neg : lvalue {  #(num_str) return num_str
23     local $_ = shift;
24     s/^\+/-/;
25     $_;
26 }
27 in(neg("+2"));
28
29
30 is($in, '-2');
31
32 sub get_lex : lvalue { $in }
33 sub get_st : lvalue { $blah }
34 sub id : lvalue { ${\shift} }
35 sub id1 : lvalue { $_[0] }
36 sub inc : lvalue { ${\++$_[0]} }
37
38 $in = 5;
39 $blah = 3;
40
41 get_st = 7;
42
43 cmp_ok($blah, '==', 7);
44
45 get_lex = 7;
46
47 cmp_ok($in, '==', 7);
48
49 ++get_st;
50
51 cmp_ok($blah, '==', 8);
52
53 ++get_lex;
54
55 cmp_ok($in, '==', 8);
56
57 id(get_st) = 10;
58
59 cmp_ok($blah, '==', 10);
60
61 id(get_lex) = 10;
62
63 cmp_ok($in, '==', 10);
64
65 ++id(get_st);
66
67 cmp_ok($blah, '==', 11);
68
69 ++id(get_lex);
70
71 cmp_ok($in, '==', 11);
72
73 id1(get_st) = 20;
74
75 cmp_ok($blah, '==', 20);
76
77 id1(get_lex) = 20;
78
79 cmp_ok($in, '==', 20);
80
81 ++id1(get_st);
82
83 cmp_ok($blah, '==', 21);
84
85 ++id1(get_lex);
86
87 cmp_ok($in, '==', 21);
88
89 inc(get_st);
90
91 cmp_ok($blah, '==', 22);
92
93 inc(get_lex);
94
95 cmp_ok($in, '==', 22);
96
97 inc(id(get_st));
98
99 cmp_ok($blah, '==', 23);
100
101 inc(id(get_lex));
102
103 cmp_ok($in, '==', 23);
104
105 ++inc(id1(id(get_st)));
106
107 cmp_ok($blah, '==', 25);
108
109 ++inc(id1(id(get_lex)));
110
111 cmp_ok($in, '==', 25);
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
121 sub a3 :lvalue {@a}
122 sub b2 : lvalue {@b}
123 sub c4: lvalue {@c}
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
136 like($_, qr/Can\'t return an uninitialized value from lvalue subroutine/);
137 print "ok 22\n";
138
139 =cut
140
141
142 my $var;
143
144 sub a::var : lvalue { $var }
145
146 "a"->var = 45;
147
148 cmp_ok($var, '==', 45);
149
150 my $oo;
151 $o = bless \$oo, "a";
152
153 $o->var = 47;
154
155 cmp_ok($var, '==', 47);
156
157 sub o : lvalue { $o }
158
159 o->var = 49;
160
161 cmp_ok($var, '==', 49);
162
163 sub nolv () { $x0, $x1 } # Not lvalue
164
165 $_ = '';
166
167 eval <<'EOE' or $_ = $@;
168   nolv = (2,3);
169   1;
170 EOE
171
172 like($_, qr/Can\'t modify non-lvalue subroutine call in scalar assignment/);
173
174 $_ = '';
175
176 eval <<'EOE' or $_ = $@;
177   nolv = (2,3) if $_;
178   1;
179 EOE
180
181 like($_, qr/Can\'t modify non-lvalue subroutine call in scalar assignment/);
182
183 $_ = '';
184
185 eval <<'EOE' or $_ = $@;
186   &nolv = (2,3) if $_;
187   1;
188 EOE
189
190 like($_, qr/Can\'t modify non-lvalue subroutine call in scalar assignment/);
191
192 $x0 = $x1 = $_ = undef;
193 $nolv = \&nolv;
194
195 eval <<'EOE' or $_ = $@;
196   $nolv->() = (2,3) if $_;
197   1;
198 EOE
199
200 ok(!defined $_) or diag "'$_', '$x0', '$x1'";
201
202 $x0 = $x1 = $_ = undef;
203 $nolv = \&nolv;
204
205 eval <<'EOE' or $_ = $@;
206   $nolv->() = (2,3);
207   1;
208 EOE
209
210 like($_, qr/Can\'t modify non-lvalue subroutine call/)
211   or diag "'$_', '$x0', '$x1'";
212
213 sub lv0 : lvalue { }            # Converted to lv10 in scalar context
214
215 $_ = undef;
216 eval <<'EOE' or $_ = $@;
217   lv0 = (2,3);
218   1;
219 EOE
220
221 like($_, qr/Can't return undef from lvalue subroutine/);
222
223 sub lv10 : lvalue {}
224
225 $_ = undef;
226 eval <<'EOE' or $_ = $@;
227   (lv0) = (2,3);
228   1;
229 EOE
230
231 ok(!defined $_) or diag $_;
232
233 sub lv1u :lvalue { undef }
234
235 $_ = undef;
236 eval <<'EOE' or $_ = $@;
237   lv1u = (2,3);
238   1;
239 EOE
240
241 like($_, qr/Can't return undef from lvalue subroutine/);
242
243 $_ = undef;
244 eval <<'EOE' or $_ = $@;
245   (lv1u) = (2,3);
246   1;
247 EOE
248
249 # Fixed by change @10777
250 #print "# '$_'.\nnot "
251 #  unless /Can\'t return an uninitialized value from lvalue subroutine/;
252 # print "ok 34 # Skip: removed test\n";
253
254 $x = '1234567';
255
256 $_ = undef;
257 eval <<'EOE' or $_ = $@;
258   sub lv1t : lvalue { index $x, 2 }
259   lv1t = (2,3);
260   1;
261 EOE
262
263 like($_, qr/Can\'t modify index in lvalue subroutine return/);
264
265 $_ = undef;
266 eval <<'EOE' or $_ = $@;
267   sub lv2t : lvalue { shift }
268   (lv2t) = (2,3);
269   1;
270 EOE
271
272 like($_, qr/Can\'t modify shift in lvalue subroutine return/);
273
274 $xxx = 'xxx';
275 sub xxx () { $xxx }  # Not lvalue
276
277 $_ = undef;
278 eval <<'EOE' or $_ = $@;
279   sub lv1tmp : lvalue { xxx }                   # is it a TEMP?
280   lv1tmp = (2,3);
281   1;
282 EOE
283
284 like($_, qr/Can\'t modify non-lvalue subroutine call in lvalue subroutine return/);
285
286 $_ = undef;
287 eval <<'EOE' or $_ = $@;
288   (lv1tmp) = (2,3);
289   1;
290 EOE
291
292 like($_, qr/Can\'t return a temporary from lvalue subroutine/);
293
294 sub yyy () { 'yyy' } # Const, not lvalue
295
296 $_ = undef;
297 eval <<'EOE' or $_ = $@;
298   sub lv1tmpr : lvalue { yyy }                  # is it read-only?
299   lv1tmpr = (2,3);
300   1;
301 EOE
302
303 like($_, qr/Can\'t modify constant item in lvalue subroutine return/);
304
305 $_ = undef;
306 eval <<'EOE' or $_ = $@;
307   (lv1tmpr) = (2,3);
308   1;
309 EOE
310
311 like($_, qr/Can\'t return a readonly value from lvalue subroutine/);
312
313 sub lva : lvalue {@a}
314
315 $_ = undef;
316 @a = ();
317 $a[1] = 12;
318 eval <<'EOE' or $_ = $@;
319   (lva) = (2,3);
320   1;
321 EOE
322
323 is("'@a' $_", "'2 3' ");
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
334 is("'@a' $_", "'2 3' ");
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
345 is("'@a' $_", "'2 3' ");
346
347 sub lv1n : lvalue { $newvar }
348
349 $_ = undef;
350 eval <<'EOE' or $_ = $@;
351   lv1n = (3,4);
352   1;
353 EOE
354
355 is("'$newvar' $_", "'4' ");
356
357 sub lv1nn : lvalue { $nnewvar }
358
359 $_ = undef;
360 eval <<'EOE' or $_ = $@;
361   (lv1nn) = (3,4);
362   1;
363 EOE
364
365 is("'$nnewvar' $_", "'3' ");
366
367 $a = \&lv1nn;
368 $a->() = 8;
369 is($nnewvar, '8');
370
371 eval 'sub AUTOLOAD : lvalue { $newvar }';
372 foobar() = 12;
373 is($newvar, "12");
374
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";
383 is(alv(), "ok 50\n");
384
385 alv2(20) = "ok 51\n";
386 is($array[20], "ok 51\n");
387
388 $hash{"foo"} = "not ok 52\n";
389 hlv() = "ok 52\n";
390 is($hash{foo}, "ok 52\n");
391
392 $hash{bar} = "not ok 53\n";
393 hlv("bar") = "ok 53\n";
394 is(hlv("bar"), "ok 53\n");
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);
404 is("@array", "ok 54");
405
406 (array2()) = qw(ok 55);
407 is("@array2", "ok 55");
408
409 (hash()) = qw(ok 56);
410 cmp_ok($hash{ok}, '==', 56);
411
412 (hash2()) = qw(ok 57);
413 cmp_ok($hash2{ok}, '==', 57);
414
415 @array = qw(a b c d);
416 sub aslice1 : lvalue { @array[0,2] };
417 (aslice1()) = ("ok", "already");
418 is("@array", "ok b already d");
419
420 @array2 = qw(a B c d);
421 sub aslice2 : lvalue { @array2[0,2] };
422 (aslice2()) = ("ok", "already");
423 is("@array2", "ok B already d");
424
425 %hash = qw(a Alpha b Beta c Gamma);
426 sub hslice : lvalue { @hash{"c", "b"} }
427 (hslice()) = ("CISC", "BogoMIPS");
428 is(join("/",@hash{"c","a","b"}), "CISC/Alpha/BogoMIPS");
429 }
430
431 $str = "Hello, world!";
432 sub sstr : lvalue { substr($str, 1, 4) }
433 sstr() = "i";
434 is($str, "Hi, world!");
435
436 $str = "Made w/ JavaScript";
437 sub veclv : lvalue { vec($str, 2, 32) }
438 if (ord('A') != 193) {
439     veclv() = 0x5065726C;
440 }
441 else { # EBCDIC?
442     veclv() = 0xD7859993;
443 }
444 is($str, "Made w/ PerlScript");
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 }
453 is("@p", "1 8");
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";
460
461 is(join(':', @ary), "1:2:6");
462
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
479 is($@, "", "element of tied hash");
480
481 is("$Tie_Hash::key-$Tie_Hash::val", "key-value");
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
498
499 is($@, "", "element of tied array");
500
501 is ($Tie_Array::val[0], "value");
502
503
504 # Test explicit return of lvalue expression
505 {
506     # subs are copies from tests 1-~18 with an explicit return added.
507     # They used not to work, which is why they are ‘badly’ named.
508     sub bad_get_lex : lvalue { return $in };
509     sub bad_get_st  : lvalue { return $blah }
510
511     sub bad_id  : lvalue { return ${\shift} }
512     sub bad_id1 : lvalue { return $_[0] }
513     sub bad_inc : lvalue { return ${\++$_[0]} }
514
515     $in = 5;
516     $blah = 3;
517
518     bad_get_st = 7;
519
520     is( $blah, 7 );
521
522     bad_get_lex = 7;
523
524     is($in, 7, "yada");
525
526     ++bad_get_st;
527
528     is($blah, 8, "yada");
529
530     ++bad_get_lex;
531     cmp_ok($in, '==', 8);
532
533     bad_id(bad_get_st) = 10;
534     cmp_ok($blah, '==', 10);
535
536     bad_id(bad_get_lex) = 10;
537     cmp_ok($in, '==', 10);
538
539     ++bad_id(bad_get_st);
540     cmp_ok($blah, '==', 11);
541
542     ++bad_id(bad_get_lex);
543     cmp_ok($in, '==', 11);
544
545     bad_id1(bad_get_st) = 20;
546     cmp_ok($blah, '==', 20);
547
548     bad_id1(bad_get_lex) = 20;
549     cmp_ok($in, '==', 20);
550
551     ++bad_id1(bad_get_st);
552     cmp_ok($blah, '==', 21);
553
554     ++bad_id1(bad_get_lex);
555     cmp_ok($in, '==', 21);
556
557     bad_inc(bad_get_st);
558     cmp_ok($blah, '==', 22);
559
560     bad_inc(bad_get_lex);
561     cmp_ok($in, '==', 22);
562
563     bad_inc(bad_id(bad_get_st));
564     cmp_ok($blah, '==', 23);
565
566     bad_inc(bad_id(bad_get_lex));
567     cmp_ok($in, '==', 23);
568
569     ++bad_inc(bad_id1(bad_id(bad_get_st)));
570     cmp_ok($blah, '==', 25);
571
572     ++bad_inc(bad_id1(bad_id(bad_get_lex)));
573     cmp_ok($in, '==', 25);
574 }
575
576 { # bug #23790
577     my @arr  = qw /one two three/;
578     my $line = "zero";
579     sub lval_array () : lvalue {@arr}
580
581     for (lval_array) {
582         $line .= $_;
583     }
584
585     is($line, "zeroonetwothree");
586
587     sub trythislval { scalar(@_)."x".join "", @_ }
588     is(trythislval(lval_array()), "3xonetwothree");
589
590     sub changeme { $_[2] = "free" }
591     changeme(lval_array);
592     is("@arr", "one two free");
593 }
594
595 {
596     package Foo;
597     sub AUTOLOAD :lvalue { *{$AUTOLOAD} };
598     package main;
599     my $foo = bless {},"Foo";
600     my $result;
601     $foo->bar = sub { $result = "bar" };
602     $foo->bar;
603     is ($result, 'bar', "RT #41550");
604 }
605
606 fresh_perl_is(<<'----', <<'====', "lvalue can not be set after definition. [perl #68758]");
607 use warnings;
608 our $x;
609 sub foo { $x }
610 sub foo : lvalue;
611 foo = 3;
612 ----
613 lvalue attribute ignored after the subroutine has been defined at - line 4.
614 Can't modify non-lvalue subroutine call in scalar assignment at - line 5, near "3;"
615 Execution of - aborted due to compilation errors.
616 ====
617
618 {
619     my $x;
620     sub lval_decl : lvalue;
621     sub lval_decl { $x }
622     lval_decl = 5;
623     is($x, 5, "subroutine declared with lvalue before definition retains lvalue. [perl #68758]");
624 }
625
626 sub fleen : lvalue { $pnare }
627 $pnare = __PACKAGE__;
628 ok eval { fleen = 1 }, "lvalues can return COWs (CATTLE?) [perl #75656]";\
629 is $pnare, 1, 'and returning CATTLE actually works';