Commit | Line | Data |
cd06dffe |
1 | print "1..46\n"; |
2 | |
3 | BEGIN { |
4 | chdir 't' if -d 't'; |
5 | unshift @INC, '../lib'; |
6 | } |
7 | |
8 | sub a {use attrs 'lvalue'; my $a = 34; bless \$a} # Return a temporary |
9 | sub b {use attrs '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 {use attrs 'lvalue'; $in = shift;} |
24 | sub neg {use attrs '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 {use attrs 'lvalue'; $in} |
36 | sub get_st {use attrs 'lvalue'; $blah} |
37 | sub id {use attrs 'lvalue'; shift} |
38 | sub id1 {use attrs 'lvalue'; $_[0]} |
39 | sub inc {use attrs '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 {use attrs 'lvalue'; @a} |
143 | sub b2 {use attrs 'lvalue'; @b} |
144 | sub c4 {use attrs '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 {use attrs '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 {use attrs '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 indirect subroutine call/; |
243 | print "ok 30\n"; |
244 | |
245 | sub lv0 {use attrs '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 /Can\'t return a readonly value from lvalue subroutine/; |
255 | print "ok 31\n"; |
256 | |
257 | sub lv10 {use attrs '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 {use attrs '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 | print "# '$_'.\nnot " |
287 | unless /Can\'t return an uninitialized value from lvalue subroutine/; |
288 | print "ok 34\n"; |
289 | |
290 | $x = '1234567'; |
291 | sub lv1t {use attrs 'lvalue'; index $x, 2 } |
292 | |
293 | $_ = undef; |
294 | eval <<'EOE' or $_ = $@; |
295 | lv1t = (2,3); |
296 | 1; |
297 | EOE |
298 | |
299 | print "# '$_'.\nnot " |
300 | unless /Can\'t return a temporary from lvalue subroutine/; |
301 | print "ok 35\n"; |
302 | |
303 | $_ = undef; |
304 | eval <<'EOE' or $_ = $@; |
305 | (lv1t) = (2,3); |
306 | 1; |
307 | EOE |
308 | |
309 | print "# '$_'.\nnot " |
310 | unless /Can\'t return a temporary from lvalue subroutine/; |
311 | print "ok 36\n"; |
312 | |
313 | $xxx = 'xxx'; |
314 | sub xxx () { $xxx } # Not lvalue |
315 | sub lv1tmp {use attrs 'lvalue'; xxx } # is it a TEMP? |
316 | |
317 | $_ = undef; |
318 | eval <<'EOE' or $_ = $@; |
319 | lv1tmp = (2,3); |
320 | 1; |
321 | EOE |
322 | |
323 | print "# '$_'.\nnot " |
324 | unless /Can\'t return a temporary from lvalue subroutine/; |
325 | print "ok 37\n"; |
326 | |
327 | $_ = undef; |
328 | eval <<'EOE' or $_ = $@; |
329 | (lv1tmp) = (2,3); |
330 | 1; |
331 | EOE |
332 | |
333 | print "# '$_'.\nnot " |
334 | unless /Can\'t return a temporary from lvalue subroutine/; |
335 | print "ok 38\n"; |
336 | |
337 | sub xxx () { 'xxx' } # Not lvalue |
338 | sub lv1tmpr {use attrs 'lvalue'; xxx } # is it a TEMP? |
339 | |
340 | $_ = undef; |
341 | eval <<'EOE' or $_ = $@; |
342 | lv1tmpr = (2,3); |
343 | 1; |
344 | EOE |
345 | |
346 | print "# '$_'.\nnot " |
347 | unless /Can\'t return a readonly value from lvalue subroutine/; |
348 | print "ok 39\n"; |
349 | |
350 | $_ = undef; |
351 | eval <<'EOE' or $_ = $@; |
352 | (lv1tmpr) = (2,3); |
353 | 1; |
354 | EOE |
355 | |
356 | print "# '$_'.\nnot " |
357 | unless /Can\'t return a readonly value from lvalue subroutine/; |
358 | print "ok 40\n"; |
359 | |
360 | =for disabled constructs |
361 | |
362 | sub lva {use attrs '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 " |
373 | unless /Can\'t return an uninitialized value from lvalue subroutine/; |
374 | print "ok 41\n"; |
375 | |
376 | $_ = undef; |
377 | @a = (); |
378 | $a[0] = undef; |
379 | $a[1] = 12; |
380 | eval <<'EOE' or $_ = $@; |
381 | (lva) = (2,3); |
382 | 1; |
383 | EOE |
384 | |
385 | print "# '$_'.\nnot " unless "'@a' $_" eq "'2 3' "; |
386 | print "ok 42\n"; |
387 | |
388 | $_ = undef; |
389 | @a = (); |
390 | $a[0] = undef; |
391 | $a[1] = 12; |
392 | eval <<'EOE' or $_ = $@; |
393 | (lva) = (2,3); |
394 | 1; |
395 | EOE |
396 | |
397 | print "# '$_'.\nnot " unless "'@a' $_" eq "'2 3' "; |
398 | print "ok 43\n"; |
399 | |
400 | =cut |
401 | |
402 | print "ok $_\n" for 41..43; |
403 | |
404 | sub lv1n {use attrs 'lvalue'; $newvar } |
405 | |
406 | $_ = undef; |
407 | eval <<'EOE' or $_ = $@; |
408 | lv1n = (3,4); |
409 | 1; |
410 | EOE |
411 | |
412 | print "# '$_', '$newvar'.\nnot " unless "'$newvar' $_" eq "'4' "; |
413 | print "ok 44\n"; |
414 | |
415 | sub lv1nn {use attrs 'lvalue'; $nnewvar } |
416 | |
417 | $_ = undef; |
418 | eval <<'EOE' or $_ = $@; |
419 | (lv1nn) = (3,4); |
420 | 1; |
421 | EOE |
422 | |
423 | print "# '$_'.\nnot " unless "'$nnewvar' $_" eq "'3' "; |
424 | print "ok 45\n"; |
425 | |
426 | $a = \&lv1nn; |
427 | $a->() = 8; |
428 | print "# '$nnewvar'.\nnot " unless $nnewvar eq '8'; |
429 | print "ok 46\n"; |