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