Commit | Line | Data |
1c4274f4 |
1 | print "1..67\n"; |
cd06dffe |
2 | |
3 | BEGIN { |
4 | chdir 't' if -d 't'; |
20822f61 |
5 | @INC = '../lib'; |
cd06dffe |
6 | } |
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. |
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 | |
a98df962 |
23 | sub in : lvalue { $in = shift; } |
24 | sub neg : lvalue { #(num_str) return num_str |
cd06dffe |
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 | |
a98df962 |
35 | sub get_lex : lvalue { $in } |
36 | sub get_st : lvalue { $blah } |
78f9721b |
37 | sub id : lvalue { ${\shift} } |
a98df962 |
38 | sub id1 : lvalue { $_[0] } |
78f9721b |
39 | sub inc : lvalue { ${\++$_[0]} } |
cd06dffe |
40 | |
41 | $in = 5; |
42 | $blah = 3; |
43 | |
44 | get_st = 7; |
45 | |
2f044c87 |
46 | print "# `$blah' ne 7\nnot " unless $blah == 7; |
cd06dffe |
47 | print "ok 4\n"; |
48 | |
49 | get_lex = 7; |
50 | |
2f044c87 |
51 | print "# `$in' ne 7\nnot " unless $in == 7; |
cd06dffe |
52 | print "ok 5\n"; |
53 | |
54 | ++get_st; |
55 | |
2f044c87 |
56 | print "# `$blah' ne 8\nnot " unless $blah == 8; |
cd06dffe |
57 | print "ok 6\n"; |
58 | |
59 | ++get_lex; |
60 | |
2f044c87 |
61 | print "# `$in' ne 8\nnot " unless $in == 8; |
cd06dffe |
62 | print "ok 7\n"; |
63 | |
64 | id(get_st) = 10; |
65 | |
2f044c87 |
66 | print "# `$blah' ne 10\nnot " unless $blah == 10; |
cd06dffe |
67 | print "ok 8\n"; |
68 | |
69 | id(get_lex) = 10; |
70 | |
2f044c87 |
71 | print "# `$in' ne 10\nnot " unless $in == 10; |
cd06dffe |
72 | print "ok 9\n"; |
73 | |
74 | ++id(get_st); |
75 | |
2f044c87 |
76 | print "# `$blah' ne 11\nnot " unless $blah == 11; |
cd06dffe |
77 | print "ok 10\n"; |
78 | |
79 | ++id(get_lex); |
80 | |
2f044c87 |
81 | print "# `$in' ne 11\nnot " unless $in == 11; |
cd06dffe |
82 | print "ok 11\n"; |
83 | |
84 | id1(get_st) = 20; |
85 | |
2f044c87 |
86 | print "# `$blah' ne 20\nnot " unless $blah == 20; |
cd06dffe |
87 | print "ok 12\n"; |
88 | |
89 | id1(get_lex) = 20; |
90 | |
2f044c87 |
91 | print "# `$in' ne 20\nnot " unless $in == 20; |
cd06dffe |
92 | print "ok 13\n"; |
93 | |
94 | ++id1(get_st); |
95 | |
2f044c87 |
96 | print "# `$blah' ne 21\nnot " unless $blah == 21; |
cd06dffe |
97 | print "ok 14\n"; |
98 | |
99 | ++id1(get_lex); |
100 | |
2f044c87 |
101 | print "# `$in' ne 21\nnot " unless $in == 21; |
cd06dffe |
102 | print "ok 15\n"; |
103 | |
104 | inc(get_st); |
105 | |
2f044c87 |
106 | print "# `$blah' ne 22\nnot " unless $blah == 22; |
cd06dffe |
107 | print "ok 16\n"; |
108 | |
109 | inc(get_lex); |
110 | |
2f044c87 |
111 | print "# `$in' ne 22\nnot " unless $in == 22; |
cd06dffe |
112 | print "ok 17\n"; |
113 | |
114 | inc(id(get_st)); |
115 | |
2f044c87 |
116 | print "# `$blah' ne 23\nnot " unless $blah == 23; |
cd06dffe |
117 | print "ok 18\n"; |
118 | |
119 | inc(id(get_lex)); |
120 | |
2f044c87 |
121 | print "# `$in' ne 23\nnot " unless $in == 23; |
cd06dffe |
122 | print "ok 19\n"; |
123 | |
124 | ++inc(id1(id(get_st))); |
125 | |
2f044c87 |
126 | print "# `$blah' ne 25\nnot " unless $blah == 25; |
cd06dffe |
127 | print "ok 20\n"; |
128 | |
129 | ++inc(id1(id(get_lex))); |
130 | |
2f044c87 |
131 | print "# `$in' ne 25\nnot " unless $in == 25; |
cd06dffe |
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 | |
a98df962 |
142 | sub a3 :lvalue {@a} |
143 | sub b2 : lvalue {@b} |
144 | sub c4: lvalue {@c} |
cd06dffe |
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 | |
a98df962 |
165 | sub a::var : lvalue { $var } |
cd06dffe |
166 | |
167 | "a"->var = 45; |
168 | |
2f044c87 |
169 | print "# `$var' ne 45\nnot " unless $var == 45; |
cd06dffe |
170 | print "ok 23\n"; |
171 | |
172 | my $oo; |
173 | $o = bless \$oo, "a"; |
174 | |
175 | $o->var = 47; |
176 | |
2f044c87 |
177 | print "# `$var' ne 47\nnot " unless $var == 47; |
cd06dffe |
178 | print "ok 24\n"; |
179 | |
a98df962 |
180 | sub o : lvalue { $o } |
cd06dffe |
181 | |
182 | o->var = 49; |
183 | |
2f044c87 |
184 | print "# `$var' ne 49\nnot " unless $var == 49; |
cd06dffe |
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 " |
5c0bc887 |
242 | unless /Can\'t modify non-lvalue subroutine call/; |
cd06dffe |
243 | print "ok 30\n"; |
244 | |
a98df962 |
245 | sub lv0 : lvalue { } # Converted to lv10 in scalar context |
cd06dffe |
246 | |
247 | $_ = undef; |
248 | eval <<'EOE' or $_ = $@; |
249 | lv0 = (2,3); |
250 | 1; |
251 | EOE |
252 | |
253 | print "# '$_'.\nnot " |
d8a34499 |
254 | unless /Empty array returned from lvalue subroutine in scalar context/; |
cd06dffe |
255 | print "ok 31\n"; |
256 | |
a98df962 |
257 | sub lv10 : lvalue {} |
cd06dffe |
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 | |
a98df962 |
268 | sub lv1u :lvalue { undef } |
cd06dffe |
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 | |
4c8a4e58 |
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"; |
cd06dffe |
290 | |
291 | $x = '1234567'; |
cd06dffe |
292 | |
293 | $_ = undef; |
294 | eval <<'EOE' or $_ = $@; |
78f9721b |
295 | sub lv1t : lvalue { index $x, 2 } |
cd06dffe |
296 | lv1t = (2,3); |
297 | 1; |
298 | EOE |
299 | |
300 | print "# '$_'.\nnot " |
78f9721b |
301 | unless /Can\'t modify index in lvalue subroutine return/; |
cd06dffe |
302 | print "ok 35\n"; |
303 | |
304 | $_ = undef; |
305 | eval <<'EOE' or $_ = $@; |
78f9721b |
306 | sub lv2t : lvalue { shift } |
307 | (lv2t) = (2,3); |
cd06dffe |
308 | 1; |
309 | EOE |
310 | |
311 | print "# '$_'.\nnot " |
78f9721b |
312 | unless /Can\'t modify shift in lvalue subroutine return/; |
cd06dffe |
313 | print "ok 36\n"; |
314 | |
315 | $xxx = 'xxx'; |
316 | sub xxx () { $xxx } # Not lvalue |
cd06dffe |
317 | |
318 | $_ = undef; |
319 | eval <<'EOE' or $_ = $@; |
78f9721b |
320 | sub lv1tmp : lvalue { xxx } # is it a TEMP? |
cd06dffe |
321 | lv1tmp = (2,3); |
322 | 1; |
323 | EOE |
324 | |
325 | print "# '$_'.\nnot " |
78f9721b |
326 | unless /Can\'t modify non-lvalue subroutine call in lvalue subroutine return/; |
cd06dffe |
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 | |
9a049f1c |
339 | sub yyy () { 'yyy' } # Const, not lvalue |
cd06dffe |
340 | |
341 | $_ = undef; |
342 | eval <<'EOE' or $_ = $@; |
78f9721b |
343 | sub lv1tmpr : lvalue { yyy } # is it read-only? |
cd06dffe |
344 | lv1tmpr = (2,3); |
345 | 1; |
346 | EOE |
347 | |
348 | print "# '$_'.\nnot " |
78f9721b |
349 | unless /Can\'t modify constant item in lvalue subroutine return/; |
cd06dffe |
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 | |
a98df962 |
362 | sub lva : lvalue {@a} |
cd06dffe |
363 | |
364 | $_ = undef; |
365 | @a = (); |
366 | $a[1] = 12; |
367 | eval <<'EOE' or $_ = $@; |
368 | (lva) = (2,3); |
369 | 1; |
370 | EOE |
371 | |
78f9721b |
372 | print "# '$_'.\nnot " unless "'@a' $_" eq "'2 3' "; |
cd06dffe |
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 | |
a98df962 |
399 | sub lv1n : lvalue { $newvar } |
cd06dffe |
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 | |
a98df962 |
410 | sub lv1nn : lvalue { $nnewvar } |
cd06dffe |
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"; |
d32f2495 |
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 | |
8b6e3824 |
434 | print "ok 48 # Skip: removed test\n"; |
435 | |
436 | print "ok 49 # Skip: removed test\n"; |
26191e78 |
437 | |
78f9721b |
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) } |
e6b8b224 |
509 | if (ord('A') != 193) { |
510 | veclv() = 0x5065726C; |
511 | } |
512 | else { # EBCDIC? |
513 | veclv() = 0xD7859993; |
514 | } |
78f9721b |
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"; |
7c8af4ef |
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"; |
1c4274f4 |
535 | |
536 | require './test.pl'; |
537 | curr_test(65); |
538 | |
539 | TODO: { |
540 | local $TODO = 'test explicit return of lval expr'; |
541 | |
542 | # subs are corrupted copies from tests 1-~4 |
543 | sub bad_get_lex : lvalue { return $in }; |
544 | sub bad_get_st : lvalue { return $blah } |
545 | |
546 | sub bad_id : lvalue { return ${\shift} } |
547 | sub bad_id1 : lvalue { return $_[0] } |
548 | sub bad_inc : lvalue { return ${\++$_[0]} } |
549 | |
550 | $in = 5; |
551 | $blah = 3; |
552 | |
553 | bad_get_st = 7; |
554 | |
555 | is( $blah, 7 ); |
556 | |
557 | bad_get_lex = 7; |
558 | |
559 | is($in, 7, "yada"); |
560 | |
561 | ++bad_get_st; |
562 | |
563 | is($blah, 8, "yada"); |
564 | } |
565 | |