Commit | Line | Data |
---|---|---|
f7218ed4 | 1 | #!./perl -w |
2d981f27 AB |
2 | |
3 | BEGIN { | |
4 | chdir 't' if -d 't'; | |
f7218ed4 | 5 | require './test.pl'; |
f537e6f5 FC |
6 | @INC = () unless is_miniperl(); |
7 | unshift @INC, '../lib'; | |
2d981f27 AB |
8 | } |
9 | ||
59e6df9f | 10 | plan( tests => 37 ); |
2d981f27 AB |
11 | |
12 | sub empty_sub {} | |
13 | ||
14 | is(empty_sub,undef,"Is empty"); | |
15 | is(empty_sub(1,2,3),undef,"Is still empty"); | |
16 | @test = empty_sub(); | |
17 | is(scalar(@test), 0, 'Didnt return anything'); | |
18 | @test = empty_sub(1,2,3); | |
19 | is(scalar(@test), 0, 'Didnt return anything'); | |
20 | ||
4d198de3 DM |
21 | # RT #63790: calling PL_sv_yes as a sub is special-cased to silently |
22 | # return (so Foo->import() silently fails if import() doesn't exist), | |
23 | # But make sure it correctly pops the stack and mark stack before returning. | |
24 | ||
25 | { | |
26 | my @a; | |
27 | push @a, 4, 5, main->import(6,7); | |
28 | ok(eq_array(\@a, [4,5]), "import with args"); | |
29 | ||
30 | @a = (); | |
31 | push @a, 14, 15, main->import; | |
32 | ok(eq_array(\@a, [14,15]), "import without args"); | |
33 | ||
34 | my $x = 1; | |
35 | ||
36 | @a = (); | |
37 | push @a, 24, 25, &{$x == $x}(26,27); | |
38 | ok(eq_array(\@a, [24,25]), "yes with args"); | |
39 | ||
40 | @a = (); | |
41 | push @a, 34, 35, &{$x == $x}; | |
42 | ok(eq_array(\@a, [34,35]), "yes without args"); | |
43 | } | |
3ed94dc0 FC |
44 | |
45 | # [perl #81944] return should always copy | |
46 | { | |
47 | $foo{bar} = 7; | |
48 | for my $x ($foo{bar}) { | |
49 | # Pity test.pl doesnt have isn't. | |
50 | isnt \sub { delete $foo{bar} }->(), \$x, | |
51 | 'result of delete(helem) is copied when returned'; | |
52 | } | |
53 | $foo{bar} = 7; | |
54 | for my $x ($foo{bar}) { | |
55 | isnt \sub { return delete $foo{bar} }->(), \$x, | |
56 | 'result of delete(helem) is copied when explicitly returned'; | |
57 | } | |
58 | my $x; | |
59 | isnt \sub { delete $_[0] }->($x), \$x, | |
60 | 'result of delete(aelem) is copied when returned'; | |
61 | isnt \sub { return delete $_[0] }->($x), \$x, | |
62 | 'result of delete(aelem) is copied when explicitly returned'; | |
63 | isnt \sub { ()=\@_; shift }->($x), \$x, | |
64 | 'result of shift is copied when returned'; | |
65 | isnt \sub { ()=\@_; return shift }->($x), \$x, | |
66 | 'result of shift is copied when explicitly returned'; | |
67 | } | |
f6894bc8 FC |
68 | |
69 | fresh_perl_is | |
70 | <<'end', "main::foo\n", {}, 'sub redefinition sets CvGV'; | |
71 | *foo = \&baz; | |
72 | *bar = *foo; | |
73 | eval 'sub bar { print +(caller 0)[3], "\n" }'; | |
74 | bar(); | |
75 | end | |
e52de15a FC |
76 | |
77 | fresh_perl_is | |
78 | <<'end', "main::foo\nok\n", {}, 'no double free redefining anon stub'; | |
79 | my $sub = sub { 4 }; | |
80 | *foo = $sub; | |
81 | *bar = *foo; | |
82 | undef &$sub; | |
83 | eval 'sub bar { print +(caller 0)[3], "\n" }'; | |
84 | &$sub; | |
85 | undef *foo; | |
86 | undef *bar; | |
87 | print "ok\n"; | |
88 | end | |
7f6ba6d2 FC |
89 | |
90 | # The outer call sets the scalar returned by ${\""}.${\""} to the current | |
91 | # package name. | |
92 | # The inner call sets it to "road". | |
93 | # Each call records the value twice, the outer call surrounding the inner | |
94 | # call. In 5.10-5.18 under ithreads, what gets pushed is | |
95 | # qw(main road road road) because the inner call is clobbering the same | |
96 | # scalar. If __PACKAGE__ is changed to "main", it works, the last element | |
97 | # becoming "main". | |
98 | my @scratch; | |
99 | sub a { | |
100 | for (${\""}.${\""}) { | |
101 | $_ = $_[0]; | |
102 | push @scratch, $_; | |
103 | a("road",1) unless $_[1]; | |
104 | push @scratch, $_; | |
105 | } | |
106 | } | |
107 | a(__PACKAGE__); | |
108 | require Config; | |
7f6ba6d2 FC |
109 | is "@scratch", "main road road main", |
110 | 'recursive calls do not share shared-hash-key TARGs'; | |
8e079c2a FC |
111 | |
112 | # Another test for the same bug, that does not rely on foreach. It depends | |
113 | # on ref returning a shared hash key TARG. | |
114 | undef @scratch; | |
115 | sub b { | |
116 | my ($pack, $depth) = @_; | |
117 | my $o = bless[], $pack; | |
118 | $pack++; | |
119 | push @scratch, (ref $o, $depth||b($pack,$depth+1))[0]; | |
120 | } | |
121 | b('n',0); | |
8e079c2a FC |
122 | is "@scratch", "o n", |
123 | 'recursive calls do not share shared-hash-key TARGs (2)'; | |
2d885586 | 124 | |
2d885586 FC |
125 | # [perl #78194] @_ aliasing op return values |
126 | sub { is \$_[0], \$_[0], | |
127 | '[perl #78194] \$_[0] == \$_[0] when @_ aliases "$x"' } | |
128 | ->("${\''}"); | |
b784b94c FC |
129 | |
130 | # The return statement should make no difference in this case: | |
131 | sub not_constant () { 42 } | |
132 | sub not_constantr() { return 42 } | |
d2440203 FC |
133 | use feature 'lexical_subs'; no warnings 'experimental::lexical_subs'; |
134 | my sub not_constantm () { 42 } | |
135 | my sub not_constantmr() { return 42 } | |
b784b94c FC |
136 | eval { ${\not_constant}++ }; |
137 | is $@, "", 'sub (){42} returns a mutable value'; | |
b784b94c FC |
138 | eval { ${\not_constantr}++ }; |
139 | is $@, "", 'sub (){ return 42 } returns a mutable value'; | |
d2440203 FC |
140 | eval { ${\not_constantm}++ }; |
141 | is $@, "", 'my sub (){42} returns a mutable value'; | |
142 | eval { ${\not_constantmr}++ }; | |
143 | is $@, "", 'my sub (){ return 42 } returns a mutable value'; | |
0ad6fa35 FC |
144 | is eval { |
145 | sub Crunchy () { 1 } | |
146 | sub Munchy { $_[0] = 2 } | |
147 | eval "Crunchy"; # test that freeing this op does not turn off PADTMP | |
148 | Munchy(Crunchy); | |
149 | } || $@, 2, 'freeing ops does not make sub(){42} immutable'; | |
137da2b0 FC |
150 | |
151 | # [perl #79908] | |
152 | { | |
153 | my $x = 5; | |
154 | *_79908 = sub (){$x}; | |
155 | $x = 7; | |
d3f8a934 AB |
156 | TODO: { |
157 | local $TODO = "Should be fixed with a deprecation cycle, see 'How about having a recommended way to add constant subs dynamically?' on p5p"; | |
158 | is eval "_79908", 7, 'sub(){$x} does not break closures'; | |
159 | } | |
137da2b0 FC |
160 | isnt eval '\_79908', \$x, 'sub(){$x} returns a copy'; |
161 | ||
162 | # Test another thing that was broken by $x inlinement | |
163 | my $y; | |
164 | no warnings 'once'; | |
165 | local *time = sub():method{$y}; | |
166 | my $w; | |
167 | local $SIG{__WARN__} = sub { $w .= shift }; | |
168 | eval "()=time"; | |
d3f8a934 AB |
169 | TODO: { |
170 | local $TODO = "Should be fixed with a deprecation cycle, see 'How about having a recommended way to add constant subs dynamically?' on p5p"; | |
171 | is $w, undef, | |
172 | '*keyword = sub():method{$y} does not cause ambiguity warnings'; | |
173 | } | |
137da2b0 | 174 | } |
dd2a7f90 FC |
175 | |
176 | # &xsub when @_ has nonexistent elements | |
177 | { | |
178 | no warnings "uninitialized"; | |
179 | local @_ = (); | |
180 | $#_++; | |
181 | &utf8::encode; | |
182 | is @_, 1, 'num of elems in @_ after &xsub with nonexistent $_[0]'; | |
183 | is $_[0], "", 'content of nonexistent $_[0] is modified by &xsub'; | |
184 | } | |
8c9d3376 FC |
185 | |
186 | # &xsub when @_ itself does not exist | |
187 | undef *_; | |
188 | eval { &utf8::encode }; | |
189 | # The main thing we are testing is that it did not crash. But make sure | |
190 | # *_{ARRAY} was untouched, too. | |
191 | is *_{ARRAY}, undef, 'goto &xsub when @_ does not exist'; | |
7004ee49 FC |
192 | |
193 | # We do not want re.pm loaded at this point. Move this test up or find | |
194 | # another XSUB if this fails. | |
195 | ok !exists $INC{"re.pm"}, 're.pm not loaded yet'; | |
196 | { | |
7004ee49 FC |
197 | sub re::regmust{} |
198 | bless \&re::regmust; | |
199 | DESTROY { | |
a28a9f6b | 200 | no warnings 'redefine', 'prototype'; |
7004ee49 FC |
201 | my $str1 = "$_[0]"; |
202 | *re::regmust = sub{}; # GvSV had no refcount, so this freed it | |
203 | my $str2 = "$_[0]"; # used to be UNKNOWN(0x7fdda29310e0) | |
204 | @str = ($str1, $str2); | |
205 | } | |
a28a9f6b | 206 | local $^W; # Suppress redef warnings in XSLoader |
7004ee49 FC |
207 | require re; |
208 | is $str[1], $str[0], | |
209 | 'XSUB clobbering sub whose DESTROY assigns to the glob'; | |
210 | } | |
a6181857 FC |
211 | { |
212 | no warnings 'redefine'; | |
213 | sub foo {} | |
214 | bless \&foo, 'newATTRSUBbug'; | |
215 | sub newATTRSUBbug::DESTROY { | |
216 | my $str1 = "$_[0]"; | |
217 | *foo = sub{}; # GvSV had no refcount, so this freed it | |
218 | my $str2 = "$_[0]"; # used to be UNKNOWN(0x7fdda29310e0) | |
219 | @str = ($str1, $str2); | |
220 | } | |
221 | splice @str; | |
222 | eval "sub foo{}"; | |
223 | is $str[1], $str[0], | |
224 | 'Pure-Perl sub clobbering sub whose DESTROY assigns to the glob'; | |
225 | } | |
2806bfd8 | 226 | |
2806bfd8 TC |
227 | # [perl #122107] previously this would return |
228 | # Subroutine BEGIN redefined at (eval 2) line 2. | |
229 | fresh_perl_is(<<'EOS', "", { stderr => 1 }, | |
230 | use strict; use warnings; eval q/use File::{Spec}/; eval q/use File::Spec/; | |
231 | EOS | |
232 | "check special blocks are cleared on error"); | |
59e6df9f FC |
233 | |
234 | use constant { constant1 => 1, constant2 => 2 }; | |
235 | { | |
236 | my $w; | |
237 | local $SIG{__WARN__} = sub { $w++ }; | |
238 | eval 'sub constant1; sub constant2($)'; | |
239 | is eval '&constant1', '1', | |
240 | 'stub re-declaration of constant with no prototype'; | |
241 | is eval '&constant2', '2', | |
242 | 'stub re-declaration of constant with wrong prototype'; | |
243 | is $w, 2, 'two warnings from the above'; | |
244 | } |