Commit | Line | Data |
---|---|---|
f7218ed4 | 1 | #!./perl -w |
2d981f27 AB |
2 | |
3 | BEGIN { | |
4 | chdir 't' if -d 't'; | |
f7218ed4 | 5 | require './test.pl'; |
43ece5b1 | 6 | set_up_inc('../lib'); |
2d981f27 AB |
7 | } |
8 | ||
fc6e609e | 9 | plan(tests => 63); |
2d981f27 AB |
10 | |
11 | sub empty_sub {} | |
12 | ||
13 | is(empty_sub,undef,"Is empty"); | |
14 | is(empty_sub(1,2,3),undef,"Is still empty"); | |
15 | @test = empty_sub(); | |
16 | is(scalar(@test), 0, 'Didnt return anything'); | |
17 | @test = empty_sub(1,2,3); | |
18 | is(scalar(@test), 0, 'Didnt return anything'); | |
19 | ||
4d198de3 DM |
20 | # RT #63790: calling PL_sv_yes as a sub is special-cased to silently |
21 | # return (so Foo->import() silently fails if import() doesn't exist), | |
22 | # But make sure it correctly pops the stack and mark stack before returning. | |
23 | ||
24 | { | |
25 | my @a; | |
26 | push @a, 4, 5, main->import(6,7); | |
27 | ok(eq_array(\@a, [4,5]), "import with args"); | |
28 | ||
29 | @a = (); | |
30 | push @a, 14, 15, main->import; | |
31 | ok(eq_array(\@a, [14,15]), "import without args"); | |
32 | ||
33 | my $x = 1; | |
34 | ||
35 | @a = (); | |
36 | push @a, 24, 25, &{$x == $x}(26,27); | |
37 | ok(eq_array(\@a, [24,25]), "yes with args"); | |
38 | ||
39 | @a = (); | |
40 | push @a, 34, 35, &{$x == $x}; | |
41 | ok(eq_array(\@a, [34,35]), "yes without args"); | |
42 | } | |
3ed94dc0 | 43 | |
a45346a4 | 44 | # [perl #91844] return should always copy |
3ed94dc0 FC |
45 | { |
46 | $foo{bar} = 7; | |
47 | for my $x ($foo{bar}) { | |
48 | # Pity test.pl doesnt have isn't. | |
49 | isnt \sub { delete $foo{bar} }->(), \$x, | |
50 | 'result of delete(helem) is copied when returned'; | |
51 | } | |
52 | $foo{bar} = 7; | |
53 | for my $x ($foo{bar}) { | |
54 | isnt \sub { return delete $foo{bar} }->(), \$x, | |
55 | 'result of delete(helem) is copied when explicitly returned'; | |
56 | } | |
57 | my $x; | |
58 | isnt \sub { delete $_[0] }->($x), \$x, | |
59 | 'result of delete(aelem) is copied when returned'; | |
60 | isnt \sub { return delete $_[0] }->($x), \$x, | |
61 | 'result of delete(aelem) is copied when explicitly returned'; | |
62 | isnt \sub { ()=\@_; shift }->($x), \$x, | |
63 | 'result of shift is copied when returned'; | |
64 | isnt \sub { ()=\@_; return shift }->($x), \$x, | |
65 | 'result of shift is copied when explicitly returned'; | |
5e267fb8 DM |
66 | |
67 | $foo{bar} = 7; | |
68 | my $r = \$foo{bar}; | |
69 | sub { | |
70 | $$r++; | |
71 | isnt($_[0], $$r, "result of delete(helem) is copied: practical test"); | |
72 | }->(sub { delete $foo{bar} }->()); | |
3ed94dc0 | 73 | } |
f6894bc8 FC |
74 | |
75 | fresh_perl_is | |
76 | <<'end', "main::foo\n", {}, 'sub redefinition sets CvGV'; | |
77 | *foo = \&baz; | |
78 | *bar = *foo; | |
79 | eval 'sub bar { print +(caller 0)[3], "\n" }'; | |
80 | bar(); | |
81 | end | |
e52de15a FC |
82 | |
83 | fresh_perl_is | |
84 | <<'end', "main::foo\nok\n", {}, 'no double free redefining anon stub'; | |
85 | my $sub = sub { 4 }; | |
86 | *foo = $sub; | |
87 | *bar = *foo; | |
88 | undef &$sub; | |
89 | eval 'sub bar { print +(caller 0)[3], "\n" }'; | |
90 | &$sub; | |
91 | undef *foo; | |
92 | undef *bar; | |
93 | print "ok\n"; | |
94 | end | |
7f6ba6d2 FC |
95 | |
96 | # The outer call sets the scalar returned by ${\""}.${\""} to the current | |
97 | # package name. | |
98 | # The inner call sets it to "road". | |
99 | # Each call records the value twice, the outer call surrounding the inner | |
100 | # call. In 5.10-5.18 under ithreads, what gets pushed is | |
101 | # qw(main road road road) because the inner call is clobbering the same | |
102 | # scalar. If __PACKAGE__ is changed to "main", it works, the last element | |
103 | # becoming "main". | |
104 | my @scratch; | |
105 | sub a { | |
106 | for (${\""}.${\""}) { | |
107 | $_ = $_[0]; | |
108 | push @scratch, $_; | |
109 | a("road",1) unless $_[1]; | |
110 | push @scratch, $_; | |
111 | } | |
112 | } | |
113 | a(__PACKAGE__); | |
114 | require Config; | |
7f6ba6d2 FC |
115 | is "@scratch", "main road road main", |
116 | 'recursive calls do not share shared-hash-key TARGs'; | |
8e079c2a FC |
117 | |
118 | # Another test for the same bug, that does not rely on foreach. It depends | |
119 | # on ref returning a shared hash key TARG. | |
120 | undef @scratch; | |
121 | sub b { | |
122 | my ($pack, $depth) = @_; | |
123 | my $o = bless[], $pack; | |
124 | $pack++; | |
125 | push @scratch, (ref $o, $depth||b($pack,$depth+1))[0]; | |
126 | } | |
127 | b('n',0); | |
8e079c2a FC |
128 | is "@scratch", "o n", |
129 | 'recursive calls do not share shared-hash-key TARGs (2)'; | |
2d885586 | 130 | |
2d885586 FC |
131 | # [perl #78194] @_ aliasing op return values |
132 | sub { is \$_[0], \$_[0], | |
133 | '[perl #78194] \$_[0] == \$_[0] when @_ aliases "$x"' } | |
134 | ->("${\''}"); | |
b784b94c FC |
135 | |
136 | # The return statement should make no difference in this case: | |
137 | sub not_constant () { 42 } | |
138 | sub not_constantr() { return 42 } | |
d2440203 FC |
139 | use feature 'lexical_subs'; no warnings 'experimental::lexical_subs'; |
140 | my sub not_constantm () { 42 } | |
141 | my sub not_constantmr() { return 42 } | |
b784b94c FC |
142 | eval { ${\not_constant}++ }; |
143 | is $@, "", 'sub (){42} returns a mutable value'; | |
b784b94c FC |
144 | eval { ${\not_constantr}++ }; |
145 | is $@, "", 'sub (){ return 42 } returns a mutable value'; | |
d2440203 FC |
146 | eval { ${\not_constantm}++ }; |
147 | is $@, "", 'my sub (){42} returns a mutable value'; | |
148 | eval { ${\not_constantmr}++ }; | |
149 | is $@, "", 'my sub (){ return 42 } returns a mutable value'; | |
0ad6fa35 FC |
150 | is eval { |
151 | sub Crunchy () { 1 } | |
152 | sub Munchy { $_[0] = 2 } | |
153 | eval "Crunchy"; # test that freeing this op does not turn off PADTMP | |
154 | Munchy(Crunchy); | |
155 | } || $@, 2, 'freeing ops does not make sub(){42} immutable'; | |
137da2b0 | 156 | |
dd2a7f90 FC |
157 | # &xsub when @_ has nonexistent elements |
158 | { | |
159 | no warnings "uninitialized"; | |
160 | local @_ = (); | |
161 | $#_++; | |
162 | &utf8::encode; | |
163 | is @_, 1, 'num of elems in @_ after &xsub with nonexistent $_[0]'; | |
164 | is $_[0], "", 'content of nonexistent $_[0] is modified by &xsub'; | |
165 | } | |
8c9d3376 FC |
166 | |
167 | # &xsub when @_ itself does not exist | |
168 | undef *_; | |
169 | eval { &utf8::encode }; | |
170 | # The main thing we are testing is that it did not crash. But make sure | |
171 | # *_{ARRAY} was untouched, too. | |
172 | is *_{ARRAY}, undef, 'goto &xsub when @_ does not exist'; | |
7004ee49 FC |
173 | |
174 | # We do not want re.pm loaded at this point. Move this test up or find | |
175 | # another XSUB if this fails. | |
176 | ok !exists $INC{"re.pm"}, 're.pm not loaded yet'; | |
177 | { | |
7004ee49 FC |
178 | sub re::regmust{} |
179 | bless \&re::regmust; | |
180 | DESTROY { | |
a28a9f6b | 181 | no warnings 'redefine', 'prototype'; |
7004ee49 FC |
182 | my $str1 = "$_[0]"; |
183 | *re::regmust = sub{}; # GvSV had no refcount, so this freed it | |
184 | my $str2 = "$_[0]"; # used to be UNKNOWN(0x7fdda29310e0) | |
185 | @str = ($str1, $str2); | |
186 | } | |
a28a9f6b | 187 | local $^W; # Suppress redef warnings in XSLoader |
7004ee49 FC |
188 | require re; |
189 | is $str[1], $str[0], | |
190 | 'XSUB clobbering sub whose DESTROY assigns to the glob'; | |
191 | } | |
a6181857 FC |
192 | { |
193 | no warnings 'redefine'; | |
194 | sub foo {} | |
195 | bless \&foo, 'newATTRSUBbug'; | |
196 | sub newATTRSUBbug::DESTROY { | |
197 | my $str1 = "$_[0]"; | |
198 | *foo = sub{}; # GvSV had no refcount, so this freed it | |
199 | my $str2 = "$_[0]"; # used to be UNKNOWN(0x7fdda29310e0) | |
200 | @str = ($str1, $str2); | |
201 | } | |
202 | splice @str; | |
203 | eval "sub foo{}"; | |
204 | is $str[1], $str[0], | |
205 | 'Pure-Perl sub clobbering sub whose DESTROY assigns to the glob'; | |
206 | } | |
2806bfd8 | 207 | |
2806bfd8 TC |
208 | # [perl #122107] previously this would return |
209 | # Subroutine BEGIN redefined at (eval 2) line 2. | |
210 | fresh_perl_is(<<'EOS', "", { stderr => 1 }, | |
211 | use strict; use warnings; eval q/use File::{Spec}/; eval q/use File::Spec/; | |
212 | EOS | |
213 | "check special blocks are cleared on error"); | |
59e6df9f FC |
214 | |
215 | use constant { constant1 => 1, constant2 => 2 }; | |
216 | { | |
217 | my $w; | |
218 | local $SIG{__WARN__} = sub { $w++ }; | |
219 | eval 'sub constant1; sub constant2($)'; | |
220 | is eval '&constant1', '1', | |
221 | 'stub re-declaration of constant with no prototype'; | |
222 | is eval '&constant2', '2', | |
223 | 'stub re-declaration of constant with wrong prototype'; | |
224 | is $w, 2, 'two warnings from the above'; | |
225 | } | |
7805ed55 FC |
226 | |
227 | package _122845 { | |
228 | our $depth = 0; | |
229 | my $parent; # just to make the sub a closure | |
230 | ||
231 | sub { | |
232 | local $depth = $depth + 1; | |
233 | our $ok++, return if $depth == 2; | |
234 | ||
235 | ()= $parent; # just to make the sub a closure | |
236 | our $whatever; # this causes the crash | |
237 | ||
238 | CORE::__SUB__->(); | |
239 | }->(); | |
240 | }; | |
241 | is $_122845::ok, 1, | |
242 | '[perl #122845] no crash in closure recursion with our-vars'; | |
a70f21d0 FC |
243 | |
244 | () = *predeclared; # vivify the glob at compile time | |
245 | sub predeclared; # now we have a CV stub with no body (incorporeal? :-) | |
246 | sub predeclared { | |
247 | CORE::state $x = 42; | |
248 | sub inside_predeclared { | |
249 | is eval '$x', 42, 'eval q/$var/ in named sub in predeclared sub'; | |
250 | } | |
251 | } | |
252 | predeclared(); # set $x to 42 | |
253 | $main::x = $main::x = "You should not see this."; | |
254 | inside_predeclared(); # run test | |
1956db7e | 255 | |
a934a4a7 AC |
256 | # RT #126845: this used to fail an assertion in Perl_newATTRSUB_x() |
257 | eval 'sub rt126845_1 (); sub rt126845_1 () :lvalue'; | |
258 | pass("RT #126845: stub with prototype, then with attribute"); | |
259 | ||
260 | eval 'sub rt126845_2 (); sub rt126845_2 () :lvalue {}'; | |
261 | pass("RT #126845: stub with prototype, then definition with attribute"); | |
262 | ||
1956db7e DM |
263 | # RT #124156 death during unwinding causes crash |
264 | # the tie allows us to trigger another die while cleaning up the stack | |
265 | # from an earlier die. | |
266 | ||
267 | { | |
268 | package RT124156; | |
269 | ||
270 | sub TIEHASH { bless({}, $_[0]) } | |
271 | sub EXISTS { 0 } | |
272 | sub FETCH { undef } | |
273 | sub STORE { } | |
274 | sub DELETE { die "outer\n" } | |
275 | ||
276 | my @value; | |
277 | eval { | |
278 | @value = sub { | |
279 | @value = sub { | |
280 | my %a; | |
281 | tie %a, "RT124156"; | |
282 | local $a{foo} = "bar"; | |
283 | die "inner"; | |
284 | ("dd2a", "dd2b"); | |
285 | }->(); | |
286 | ("cc3a", "cc3b"); | |
287 | }->(); | |
288 | }; | |
289 | ::is($@, "outer\n", "RT124156 plain"); | |
290 | ||
291 | my $destroyed = 0; | |
292 | sub DESTROY { $destroyed = 1 } | |
293 | ||
294 | sub f { | |
295 | my $x; | |
296 | my $f = sub { | |
297 | $x = 1; # force closure | |
298 | my %a; | |
299 | tie %a, "RT124156"; | |
300 | local $a{foo} = "bar"; | |
301 | die "inner"; | |
302 | }; | |
303 | bless $f, 'RT124156'; | |
304 | $f->(); | |
305 | } | |
306 | ||
307 | eval { f(); }; | |
308 | # as opposed to $@ eq "Can't undef active subroutine" | |
309 | ::is($@, "outer\n", "RT124156 depth"); | |
310 | ::is($destroyed, 1, "RT124156 freed cv"); | |
311 | } | |
6228a1e1 | 312 | |
3b21fb5d DM |
313 | # trapping dying while popping a scope needs to have the right pad at all |
314 | # times. Localising a tied array then dying in STORE raises an exception | |
315 | # while leaving g(). Note that using an object and destructor wouldn't be | |
316 | # sufficient since DESTROY is called with call_sv(...,G_EVAL). | |
317 | # We make sure that the first item in every sub's pad is a lexical with | |
318 | # different values per sub. | |
319 | ||
320 | { | |
321 | package tie_exception; | |
322 | sub TIEARRAY { my $x = 4; bless [0] } | |
323 | sub FETCH { my $x = 5; 1 } | |
324 | sub STORE { my $x = 6; die if $_[0][0]; $_[0][0] = 1 } | |
325 | ||
326 | my $y; | |
327 | sub f { my $x = 7; eval { g() }; $y = $x } | |
328 | sub g { | |
329 | my $x = 8; | |
330 | my @a; | |
331 | tie @a, "tie_exception"; | |
332 | local $a[0]; | |
333 | } | |
334 | ||
335 | f(); | |
3b21fb5d DM |
336 | ::is($y, 7, "tie_exception"); |
337 | } | |
338 | ||
6228a1e1 DM |
339 | |
340 | # check that return pops extraneous stuff from the stack | |
341 | ||
342 | sub check_ret { | |
343 | # the extra scopes push contexts and extra SVs on the stack | |
344 | { | |
345 | my @a = map $_ + 20, @_; | |
346 | for ('x') { | |
347 | return if defined $_[0] && $_[0] < 0; | |
348 | } | |
349 | for ('y') { | |
350 | check_ret(1, do { (2,3,4, return @a ? @a[0..$#a] : ()) }, 4.5); | |
351 | } | |
352 | } | |
353 | } | |
354 | ||
355 | is(scalar check_ret(), undef, "check_ret() scalar"); | |
356 | is(scalar check_ret(5), 25, "check_ret(5) scalar"); | |
357 | is(scalar check_ret(5,6), 26, "check_ret(5,6) scalar"); | |
358 | is(scalar check_ret(5,6,7), 27, "check_ret(5,6,7) scalar"); | |
359 | is(scalar check_ret(5,6,7,8), 28, "check_ret(5,6,7,8) scalar"); | |
360 | is(scalar check_ret(5,6,7,8,9), 29, "check_ret(5,6,7,8,9) scalar"); | |
361 | ||
362 | is(scalar check_ret(-1), undef, "check_ret(-1) scalar"); | |
363 | is(scalar check_ret(-1,5), undef, "check_ret(-1,5) scalar"); | |
364 | ||
365 | is(join('-', 10, check_ret()), "10", "check_ret() list"); | |
366 | is(join('-', 10, check_ret(5)), "10-25", "check_ret(5) list"); | |
367 | is(join('-', 10, check_ret(5,6)), "10-25-26", "check_ret(5,6) list"); | |
368 | is(join('-', 10, check_ret(5,6,7)), "10-25-26-27", "check_ret(5,6,7) list"); | |
369 | is(join('-', 10, check_ret(5,6,7,8)), "10-25-26-27-28", "check_ret(5,6,7,8) list"); | |
370 | is(join('-', 10, check_ret(5,6,7,8,9)), "10-25-26-27-28-29", "check_ret(5,6,7,8,9) list"); | |
371 | ||
372 | is(join('-', 10, check_ret(-1)), "10", "check_ret(-1) list"); | |
373 | is(join('-', 10, check_ret(-1,5)), "10", "check_ret(-1,5) list"); | |
3089a108 DM |
374 | |
375 | # a sub without nested scopes that still leaves rubbish on the stack | |
376 | # which needs popping | |
377 | { | |
378 | my @res = sub { | |
379 | my $false; | |
380 | # conditional leaves rubbish on stack | |
381 | return @_ unless $false and $false; | |
382 | 1; | |
383 | }->('a','b'); | |
384 | is(join('-', @res), "a-b", "unnested rubbish"); | |
385 | } | |
b28bb06c DM |
386 | |
387 | # a sub should copy returned PADTMPs | |
388 | ||
389 | { | |
390 | sub f99 { $_[0] . "x" }; | |
391 | my $a = [ f99(1), f99(2) ]; | |
392 | is("@$a", "1x 2x", "PADTMPs copied on return"); | |
393 | } | |
f7a874b8 DM |
394 | |
395 | # A sub should FREETMPS on exit | |
396 | # RT #124248 | |
397 | ||
398 | { | |
399 | package p124248; | |
400 | my $d = 0; | |
401 | sub DESTROY { $d++ } | |
402 | sub f { ::is($d, 1, "RT 124248"); } | |
403 | sub g { !!(my $x = bless []); } | |
404 | f(g()); | |
405 | } | |
fc6e609e DM |
406 | |
407 | # return should have the right PL_curpm while copying its return args | |
408 | ||
409 | sub curpm { | |
410 | "b" =~ /(.)/; | |
411 | { | |
412 | "c" =~ /(.)/; | |
413 | return $1; | |
414 | } | |
415 | } | |
416 | "a" =~ /(.)/; | |
417 | is(curpm(), 'c', 'return and PL_curpm'); |