4654118fa17c6698879ab1506c693f39525fe2fd
[perl.git] / t / op / sub_lval.t
1 print "1..64\n";
2
3 BEGIN {
4     chdir 't' if -d 't';
5     @INC = '../lib';
6 }
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 print "# `$out'\nnot " unless ref $out eq 'main'; # Not reached if error.
13 print "ok 1\n";
14
15 my @out = grep /main/, a(b()); # Check that temporaries are allowed.
16 print "# `@out'\nnot " unless @out==1; # Not reached if error.
17 print "ok 2\n";
18
19 my $in;
20
21 # Check that we can return localized values from subroutines:
22
23 sub in : lvalue { $in = shift; }
24 sub neg : lvalue {  #(num_str) return num_str
25     local $_ = shift;
26     s/^\+/-/;
27     $_;
28 }
29 in(neg("+2"));
30
31
32 print "# `$in'\nnot " unless $in eq '-2';
33 print "ok 3\n";
34
35 sub get_lex : lvalue { $in }
36 sub get_st : lvalue { $blah }
37 sub id : lvalue { ${\shift} }
38 sub id1 : lvalue { $_[0] }
39 sub inc : lvalue { ${\++$_[0]} }
40
41 $in = 5;
42 $blah = 3;
43
44 get_st = 7;
45
46 print "# `$blah' ne 7\nnot " unless $blah eq 7;
47 print "ok 4\n";
48
49 get_lex = 7;
50
51 print "# `$in' ne 7\nnot " unless $in eq 7;
52 print "ok 5\n";
53
54 ++get_st;
55
56 print "# `$blah' ne 8\nnot " unless $blah eq 8;
57 print "ok 6\n";
58
59 ++get_lex;
60
61 print "# `$in' ne 8\nnot " unless $in eq 8;
62 print "ok 7\n";
63
64 id(get_st) = 10;
65
66 print "# `$blah' ne 10\nnot " unless $blah eq 10;
67 print "ok 8\n";
68
69 id(get_lex) = 10;
70
71 print "# `$in' ne 10\nnot " unless $in eq 10;
72 print "ok 9\n";
73
74 ++id(get_st);
75
76 print "# `$blah' ne 11\nnot " unless $blah eq 11;
77 print "ok 10\n";
78
79 ++id(get_lex);
80
81 print "# `$in' ne 11\nnot " unless $in eq 11;
82 print "ok 11\n";
83
84 id1(get_st) = 20;
85
86 print "# `$blah' ne 20\nnot " unless $blah eq 20;
87 print "ok 12\n";
88
89 id1(get_lex) = 20;
90
91 print "# `$in' ne 20\nnot " unless $in eq 20;
92 print "ok 13\n";
93
94 ++id1(get_st);
95
96 print "# `$blah' ne 21\nnot " unless $blah eq 21;
97 print "ok 14\n";
98
99 ++id1(get_lex);
100
101 print "# `$in' ne 21\nnot " unless $in eq 21;
102 print "ok 15\n";
103
104 inc(get_st);
105
106 print "# `$blah' ne 22\nnot " unless $blah eq 22;
107 print "ok 16\n";
108
109 inc(get_lex);
110
111 print "# `$in' ne 22\nnot " unless $in eq 22;
112 print "ok 17\n";
113
114 inc(id(get_st));
115
116 print "# `$blah' ne 23\nnot " unless $blah eq 23;
117 print "ok 18\n";
118
119 inc(id(get_lex));
120
121 print "# `$in' ne 23\nnot " unless $in eq 23;
122 print "ok 19\n";
123
124 ++inc(id1(id(get_st)));
125
126 print "# `$blah' ne 25\nnot " unless $blah eq 25;
127 print "ok 20\n";
128
129 ++inc(id1(id(get_lex)));
130
131 print "# `$in' ne 25\nnot " unless $in eq 25;
132 print "ok 21\n";
133
134 @a = (1) x 3;
135 @b = (undef) x 2;
136 $#c = 3;                        # These slots are not fillable.
137
138 # Explanation: empty slots contain &sv_undef.
139
140 =for disabled constructs
141
142 sub a3 :lvalue {@a}
143 sub b2 : lvalue {@b}
144 sub c4: lvalue {@c}
145
146 $_ = '';
147
148 eval <<'EOE' or $_ = $@;
149   ($x, a3, $y, b2, $z, c4, $t) = (34 .. 78);
150   1;
151 EOE
152
153 #@out = ($x, a3, $y, b2, $z, c4, $t);
154 #@in = (34 .. 41, (undef) x 4, 46);
155 #print "# `@out' ne `@in'\nnot " unless "@out" eq "@in";
156
157 print "# '$_'.\nnot "
158   unless /Can\'t return an uninitialized value from lvalue subroutine/;
159 =cut
160
161 print "ok 22\n";
162
163 my $var;
164
165 sub a::var : lvalue { $var }
166
167 "a"->var = 45;
168
169 print "# `$var' ne 45\nnot " unless $var eq 45;
170 print "ok 23\n";
171
172 my $oo;
173 $o = bless \$oo, "a";
174
175 $o->var = 47;
176
177 print "# `$var' ne 47\nnot " unless $var eq 47;
178 print "ok 24\n";
179
180 sub o : lvalue { $o }
181
182 o->var = 49;
183
184 print "# `$var' ne 49\nnot " unless $var eq 49;
185 print "ok 25\n";
186
187 sub nolv () { $x0, $x1 } # Not lvalue
188
189 $_ = '';
190
191 eval <<'EOE' or $_ = $@;
192   nolv = (2,3);
193   1;
194 EOE
195
196 print "not "
197   unless /Can\'t modify non-lvalue subroutine call in scalar assignment/;
198 print "ok 26\n";
199
200 $_ = '';
201
202 eval <<'EOE' or $_ = $@;
203   nolv = (2,3) if $_;
204   1;
205 EOE
206
207 print "not "
208   unless /Can\'t modify non-lvalue subroutine call in scalar assignment/;
209 print "ok 27\n";
210
211 $_ = '';
212
213 eval <<'EOE' or $_ = $@;
214   &nolv = (2,3) if $_;
215   1;
216 EOE
217
218 print "not "
219   unless /Can\'t modify non-lvalue subroutine call in scalar assignment/;
220 print "ok 28\n";
221
222 $x0 = $x1 = $_ = undef;
223 $nolv = \&nolv;
224
225 eval <<'EOE' or $_ = $@;
226   $nolv->() = (2,3) if $_;
227   1;
228 EOE
229
230 print "# '$_', '$x0', '$x1'.\nnot " if defined $_;
231 print "ok 29\n";
232
233 $x0 = $x1 = $_ = undef;
234 $nolv = \&nolv;
235
236 eval <<'EOE' or $_ = $@;
237   $nolv->() = (2,3);
238   1;
239 EOE
240
241 print "# '$_', '$x0', '$x1'.\nnot "
242   unless /Can\'t modify non-lvalue subroutine call/;
243 print "ok 30\n";
244
245 sub lv0 : lvalue { }            # Converted to lv10 in scalar context
246
247 $_ = undef;
248 eval <<'EOE' or $_ = $@;
249   lv0 = (2,3);
250   1;
251 EOE
252
253 print "# '$_'.\nnot "
254   unless /Empty array returned from lvalue subroutine in scalar context/;
255 print "ok 31\n";
256
257 sub lv10 : lvalue {}
258
259 $_ = undef;
260 eval <<'EOE' or $_ = $@;
261   (lv0) = (2,3);
262   1;
263 EOE
264
265 print "# '$_'.\nnot " if defined $_;
266 print "ok 32\n";
267
268 sub lv1u :lvalue { undef }
269
270 $_ = undef;
271 eval <<'EOE' or $_ = $@;
272   lv1u = (2,3);
273   1;
274 EOE
275
276 print "# '$_'.\nnot "
277   unless /Can\'t return a readonly value from lvalue subroutine/;
278 print "ok 33\n";
279
280 $_ = undef;
281 eval <<'EOE' or $_ = $@;
282   (lv1u) = (2,3);
283   1;
284 EOE
285
286 # Fixed by change @10777
287 #print "# '$_'.\nnot "
288 #  unless /Can\'t return an uninitialized value from lvalue subroutine/;
289 print "ok 34 # Skip: removed test\n";
290
291 $x = '1234567';
292
293 $_ = undef;
294 eval <<'EOE' or $_ = $@;
295   sub lv1t : lvalue { index $x, 2 }
296   lv1t = (2,3);
297   1;
298 EOE
299
300 print "# '$_'.\nnot "
301   unless /Can\'t modify index in lvalue subroutine return/;
302 print "ok 35\n";
303
304 $_ = undef;
305 eval <<'EOE' or $_ = $@;
306   sub lv2t : lvalue { shift }
307   (lv2t) = (2,3);
308   1;
309 EOE
310
311 print "# '$_'.\nnot "
312   unless /Can\'t modify shift in lvalue subroutine return/;
313 print "ok 36\n";
314
315 $xxx = 'xxx';
316 sub xxx () { $xxx }  # Not lvalue
317
318 $_ = undef;
319 eval <<'EOE' or $_ = $@;
320   sub lv1tmp : lvalue { xxx }                   # is it a TEMP?
321   lv1tmp = (2,3);
322   1;
323 EOE
324
325 print "# '$_'.\nnot "
326   unless /Can\'t modify non-lvalue subroutine call in lvalue subroutine return/;
327 print "ok 37\n";
328
329 $_ = undef;
330 eval <<'EOE' or $_ = $@;
331   (lv1tmp) = (2,3);
332   1;
333 EOE
334
335 print "# '$_'.\nnot "
336   unless /Can\'t return a temporary from lvalue subroutine/;
337 print "ok 38\n";
338
339 sub yyy () { 'yyy' } # Const, not lvalue
340
341 $_ = undef;
342 eval <<'EOE' or $_ = $@;
343   sub lv1tmpr : lvalue { yyy }                  # is it read-only?
344   lv1tmpr = (2,3);
345   1;
346 EOE
347
348 print "# '$_'.\nnot "
349   unless /Can\'t modify constant item in lvalue subroutine return/;
350 print "ok 39\n";
351
352 $_ = undef;
353 eval <<'EOE' or $_ = $@;
354   (lv1tmpr) = (2,3);
355   1;
356 EOE
357
358 print "# '$_'.\nnot "
359   unless /Can\'t return a readonly value from lvalue subroutine/;
360 print "ok 40\n";
361
362 sub lva : lvalue {@a}
363
364 $_ = undef;
365 @a = ();
366 $a[1] = 12;
367 eval <<'EOE' or $_ = $@;
368   (lva) = (2,3);
369   1;
370 EOE
371
372 print "# '$_'.\nnot " unless "'@a' $_" eq "'2 3' ";
373 print "ok 41\n";
374
375 $_ = undef;
376 @a = ();
377 $a[0] = undef;
378 $a[1] = 12;
379 eval <<'EOE' or $_ = $@;
380   (lva) = (2,3);
381   1;
382 EOE
383
384 print "# '$_'.\nnot " unless "'@a' $_" eq "'2 3' ";
385 print "ok 42\n";
386
387 $_ = undef;
388 @a = ();
389 $a[0] = undef;
390 $a[1] = 12;
391 eval <<'EOE' or $_ = $@;
392   (lva) = (2,3);
393   1;
394 EOE
395
396 print "# '$_'.\nnot " unless "'@a' $_" eq "'2 3' ";
397 print "ok 43\n";
398
399 sub lv1n : lvalue { $newvar }
400
401 $_ = undef;
402 eval <<'EOE' or $_ = $@;
403   lv1n = (3,4);
404   1;
405 EOE
406
407 print "# '$_', '$newvar'.\nnot " unless "'$newvar' $_" eq "'4' ";
408 print "ok 44\n";
409
410 sub lv1nn : lvalue { $nnewvar }
411
412 $_ = undef;
413 eval <<'EOE' or $_ = $@;
414   (lv1nn) = (3,4);
415   1;
416 EOE
417
418 print "# '$_'.\nnot " unless "'$nnewvar' $_" eq "'3' ";
419 print "ok 45\n";
420
421 $a = \&lv1nn;
422 $a->() = 8;
423 print "# '$nnewvar'.\nnot " unless $nnewvar eq '8';
424 print "ok 46\n";
425
426 # This must happen at run time
427 eval {
428     sub AUTOLOAD : lvalue { $newvar };
429 };
430 foobar() = 12;
431 print "# '$newvar'.\nnot " unless $newvar eq "12";
432 print "ok 47\n";
433
434 print "ok 48 # Skip: removed test\n";
435
436 print "ok 49 # Skip: removed test\n";
437
438 {
439 my %hash; my @array;
440 sub alv : lvalue { $array[1] }
441 sub alv2 : lvalue { $array[$_[0]] }
442 sub hlv : lvalue { $hash{"foo"} }
443 sub hlv2 : lvalue { $hash{$_[0]} }
444 $array[1] = "not ok 51\n";
445 alv() = "ok 50\n";
446 print alv();
447
448 alv2(20) = "ok 51\n";
449 print $array[20];
450
451 $hash{"foo"} = "not ok 52\n";
452 hlv() = "ok 52\n";
453 print $hash{foo};
454
455 $hash{bar} = "not ok 53\n";
456 hlv("bar") = "ok 53\n";
457 print hlv("bar");
458
459 sub array : lvalue  { @array  }
460 sub array2 : lvalue { @array2 } # This is a global.
461 sub hash : lvalue   { %hash   }
462 sub hash2 : lvalue  { %hash2  } # So's this.
463 @array2 = qw(foo bar);
464 %hash2 = qw(foo bar);
465
466 (array()) = qw(ok 54);
467 print "not " unless "@array" eq "ok 54";
468 print "ok 54\n";
469
470 (array2()) = qw(ok 55);
471 print "not " unless "@array2" eq "ok 55";
472 print "ok 55\n";
473
474 (hash()) = qw(ok 56);
475 print "not " unless $hash{ok} == 56;
476 print "ok 56\n";
477
478 (hash2()) = qw(ok 57);
479 print "not " unless $hash2{ok} == 57;
480 print "ok 57\n";
481
482 @array = qw(a b c d);
483 sub aslice1 : lvalue { @array[0,2] };
484 (aslice1()) = ("ok", "already");
485 print "# @array\nnot " unless "@array" eq "ok b already d";
486 print "ok 58\n";
487
488 @array2 = qw(a B c d);
489 sub aslice2 : lvalue { @array2[0,2] };
490 (aslice2()) = ("ok", "already");
491 print "not " unless "@array2" eq "ok B already d";
492 print "ok 59\n";
493
494 %hash = qw(a Alpha b Beta c Gamma);
495 sub hslice : lvalue { @hash{"c", "b"} }
496 (hslice()) = ("CISC", "BogoMIPS");
497 print "not " unless join("/",@hash{"c","a","b"}) eq "CISC/Alpha/BogoMIPS";
498 print "ok 60\n";
499 }
500
501 $str = "Hello, world!";
502 sub sstr : lvalue { substr($str, 1, 4) }
503 sstr() = "i";
504 print "not " unless $str eq "Hi, world!";
505 print "ok 61\n";
506
507 $str = "Made w/ JavaScript";
508 sub veclv : lvalue { vec($str, 2, 32) }
509 if (ord('A') != 193) {
510     veclv() = 0x5065726C;
511 }
512 else { # EBCDIC?
513     veclv() = 0xD7859993;
514 }
515 print "# $str\nnot " unless $str eq "Made w/ PerlScript";
516 print "ok 62\n";
517
518 sub position : lvalue { pos }
519 @p = ();
520 $_ = "fee fi fo fum";
521 while (/f/g) {
522     push @p, position;
523     position() += 6;
524 }
525 print "# @p\nnot " unless "@p" eq "1 8";
526 print "ok 63\n";
527
528 # Bug 20001223.002: split thought that the list had only one element
529 @ary = qw(4 5 6);
530 sub lval1 : lvalue { $ary[0]; }
531 sub lval2 : lvalue { $ary[1]; }
532 (lval1(), lval2()) = split ' ', "1 2 3 4";
533 print "not " unless join(':', @ary) eq "1:2:6";
534 print "ok 64\n";