Commit | Line | Data |
fd37f5a1 |
1 | print "1..64\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 | |
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 | |
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 | |
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 | |
a98df962 |
180 | sub o : lvalue { $o } |
cd06dffe |
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 " |
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 " |
254 | unless /Can\'t return a readonly value from lvalue subroutine/; |
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 | |
286 | print "# '$_'.\nnot " |
287 | unless /Can\'t return an uninitialized value from lvalue subroutine/; |
288 | print "ok 34\n"; |
289 | |
290 | $x = '1234567'; |
cd06dffe |
291 | |
292 | $_ = undef; |
293 | eval <<'EOE' or $_ = $@; |
78f9721b |
294 | sub lv1t : lvalue { index $x, 2 } |
cd06dffe |
295 | lv1t = (2,3); |
296 | 1; |
297 | EOE |
298 | |
299 | print "# '$_'.\nnot " |
78f9721b |
300 | unless /Can\'t modify index in lvalue subroutine return/; |
cd06dffe |
301 | print "ok 35\n"; |
302 | |
303 | $_ = undef; |
304 | eval <<'EOE' or $_ = $@; |
78f9721b |
305 | sub lv2t : lvalue { shift } |
306 | (lv2t) = (2,3); |
cd06dffe |
307 | 1; |
308 | EOE |
309 | |
310 | print "# '$_'.\nnot " |
78f9721b |
311 | unless /Can\'t modify shift in lvalue subroutine return/; |
cd06dffe |
312 | print "ok 36\n"; |
313 | |
314 | $xxx = 'xxx'; |
315 | sub xxx () { $xxx } # Not lvalue |
cd06dffe |
316 | |
317 | $_ = undef; |
318 | eval <<'EOE' or $_ = $@; |
78f9721b |
319 | sub lv1tmp : lvalue { xxx } # is it a TEMP? |
cd06dffe |
320 | lv1tmp = (2,3); |
321 | 1; |
322 | EOE |
323 | |
324 | print "# '$_'.\nnot " |
78f9721b |
325 | unless /Can\'t modify non-lvalue subroutine call in lvalue subroutine return/; |
cd06dffe |
326 | print "ok 37\n"; |
327 | |
328 | $_ = undef; |
329 | eval <<'EOE' or $_ = $@; |
330 | (lv1tmp) = (2,3); |
331 | 1; |
332 | EOE |
333 | |
334 | print "# '$_'.\nnot " |
335 | unless /Can\'t return a temporary from lvalue subroutine/; |
336 | print "ok 38\n"; |
337 | |
9a049f1c |
338 | sub yyy () { 'yyy' } # Const, not lvalue |
cd06dffe |
339 | |
340 | $_ = undef; |
341 | eval <<'EOE' or $_ = $@; |
78f9721b |
342 | sub lv1tmpr : lvalue { yyy } # is it read-only? |
cd06dffe |
343 | lv1tmpr = (2,3); |
344 | 1; |
345 | EOE |
346 | |
347 | print "# '$_'.\nnot " |
78f9721b |
348 | unless /Can\'t modify constant item in lvalue subroutine return/; |
cd06dffe |
349 | print "ok 39\n"; |
350 | |
351 | $_ = undef; |
352 | eval <<'EOE' or $_ = $@; |
353 | (lv1tmpr) = (2,3); |
354 | 1; |
355 | EOE |
356 | |
357 | print "# '$_'.\nnot " |
358 | unless /Can\'t return a readonly value from lvalue subroutine/; |
359 | print "ok 40\n"; |
360 | |
a98df962 |
361 | sub lva : lvalue {@a} |
cd06dffe |
362 | |
363 | $_ = undef; |
364 | @a = (); |
365 | $a[1] = 12; |
366 | eval <<'EOE' or $_ = $@; |
367 | (lva) = (2,3); |
368 | 1; |
369 | EOE |
370 | |
78f9721b |
371 | print "# '$_'.\nnot " unless "'@a' $_" eq "'2 3' "; |
cd06dffe |
372 | print "ok 41\n"; |
373 | |
374 | $_ = undef; |
375 | @a = (); |
376 | $a[0] = undef; |
377 | $a[1] = 12; |
378 | eval <<'EOE' or $_ = $@; |
379 | (lva) = (2,3); |
380 | 1; |
381 | EOE |
382 | |
383 | print "# '$_'.\nnot " unless "'@a' $_" eq "'2 3' "; |
384 | print "ok 42\n"; |
385 | |
386 | $_ = undef; |
387 | @a = (); |
388 | $a[0] = undef; |
389 | $a[1] = 12; |
390 | eval <<'EOE' or $_ = $@; |
391 | (lva) = (2,3); |
392 | 1; |
393 | EOE |
394 | |
395 | print "# '$_'.\nnot " unless "'@a' $_" eq "'2 3' "; |
396 | print "ok 43\n"; |
397 | |
a98df962 |
398 | sub lv1n : lvalue { $newvar } |
cd06dffe |
399 | |
400 | $_ = undef; |
401 | eval <<'EOE' or $_ = $@; |
402 | lv1n = (3,4); |
403 | 1; |
404 | EOE |
405 | |
406 | print "# '$_', '$newvar'.\nnot " unless "'$newvar' $_" eq "'4' "; |
407 | print "ok 44\n"; |
408 | |
a98df962 |
409 | sub lv1nn : lvalue { $nnewvar } |
cd06dffe |
410 | |
411 | $_ = undef; |
412 | eval <<'EOE' or $_ = $@; |
413 | (lv1nn) = (3,4); |
414 | 1; |
415 | EOE |
416 | |
417 | print "# '$_'.\nnot " unless "'$nnewvar' $_" eq "'3' "; |
418 | print "ok 45\n"; |
419 | |
420 | $a = \&lv1nn; |
421 | $a->() = 8; |
422 | print "# '$nnewvar'.\nnot " unless $nnewvar eq '8'; |
423 | print "ok 46\n"; |
d32f2495 |
424 | |
425 | # This must happen at run time |
426 | eval { |
427 | sub AUTOLOAD : lvalue { $newvar }; |
428 | }; |
429 | foobar() = 12; |
430 | print "# '$newvar'.\nnot " unless $newvar eq "12"; |
431 | print "ok 47\n"; |
432 | |
8b6e3824 |
433 | print "ok 48 # Skip: removed test\n"; |
434 | |
435 | print "ok 49 # Skip: removed test\n"; |
26191e78 |
436 | |
78f9721b |
437 | { |
438 | my %hash; my @array; |
439 | sub alv : lvalue { $array[1] } |
440 | sub alv2 : lvalue { $array[$_[0]] } |
441 | sub hlv : lvalue { $hash{"foo"} } |
442 | sub hlv2 : lvalue { $hash{$_[0]} } |
443 | $array[1] = "not ok 51\n"; |
444 | alv() = "ok 50\n"; |
445 | print alv(); |
446 | |
447 | alv2(20) = "ok 51\n"; |
448 | print $array[20]; |
449 | |
450 | $hash{"foo"} = "not ok 52\n"; |
451 | hlv() = "ok 52\n"; |
452 | print $hash{foo}; |
453 | |
454 | $hash{bar} = "not ok 53\n"; |
455 | hlv("bar") = "ok 53\n"; |
456 | print hlv("bar"); |
457 | |
458 | sub array : lvalue { @array } |
459 | sub array2 : lvalue { @array2 } # This is a global. |
460 | sub hash : lvalue { %hash } |
461 | sub hash2 : lvalue { %hash2 } # So's this. |
462 | @array2 = qw(foo bar); |
463 | %hash2 = qw(foo bar); |
464 | |
465 | (array()) = qw(ok 54); |
466 | print "not " unless "@array" eq "ok 54"; |
467 | print "ok 54\n"; |
468 | |
469 | (array2()) = qw(ok 55); |
470 | print "not " unless "@array2" eq "ok 55"; |
471 | print "ok 55\n"; |
472 | |
473 | (hash()) = qw(ok 56); |
474 | print "not " unless $hash{ok} == 56; |
475 | print "ok 56\n"; |
476 | |
477 | (hash2()) = qw(ok 57); |
478 | print "not " unless $hash2{ok} == 57; |
479 | print "ok 57\n"; |
480 | |
481 | @array = qw(a b c d); |
482 | sub aslice1 : lvalue { @array[0,2] }; |
483 | (aslice1()) = ("ok", "already"); |
484 | print "# @array\nnot " unless "@array" eq "ok b already d"; |
485 | print "ok 58\n"; |
486 | |
487 | @array2 = qw(a B c d); |
488 | sub aslice2 : lvalue { @array2[0,2] }; |
489 | (aslice2()) = ("ok", "already"); |
490 | print "not " unless "@array2" eq "ok B already d"; |
491 | print "ok 59\n"; |
492 | |
493 | %hash = qw(a Alpha b Beta c Gamma); |
494 | sub hslice : lvalue { @hash{"c", "b"} } |
495 | (hslice()) = ("CISC", "BogoMIPS"); |
496 | print "not " unless join("/",@hash{"c","a","b"}) eq "CISC/Alpha/BogoMIPS"; |
497 | print "ok 60\n"; |
498 | } |
499 | |
500 | $str = "Hello, world!"; |
501 | sub sstr : lvalue { substr($str, 1, 4) } |
502 | sstr() = "i"; |
503 | print "not " unless $str eq "Hi, world!"; |
504 | print "ok 61\n"; |
505 | |
506 | $str = "Made w/ JavaScript"; |
507 | sub veclv : lvalue { vec($str, 2, 32) } |
e6b8b224 |
508 | if (ord('A') != 193) { |
509 | veclv() = 0x5065726C; |
510 | } |
511 | else { # EBCDIC? |
512 | veclv() = 0xD7859993; |
513 | } |
78f9721b |
514 | print "# $str\nnot " unless $str eq "Made w/ PerlScript"; |
515 | print "ok 62\n"; |
516 | |
517 | sub position : lvalue { pos } |
518 | @p = (); |
519 | $_ = "fee fi fo fum"; |
520 | while (/f/g) { |
521 | push @p, position; |
522 | position() += 6; |
523 | } |
524 | print "# @p\nnot " unless "@p" eq "1 8"; |
525 | print "ok 63\n"; |
7c8af4ef |
526 | |
527 | # Bug 20001223.002: split thought that the list had only one element |
528 | @ary = qw(4 5 6); |
529 | sub lval1 : lvalue { $ary[0]; } |
530 | sub lval2 : lvalue { $ary[1]; } |
531 | (lval1(), lval2()) = split ' ', "1 2 3 4"; |
532 | print "not " unless join(':', @ary) eq "1:2:6"; |
533 | print "ok 64\n"; |