This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Fix OUTSIDE for named subs inside predeclared subs
[perl5.git] / t / op / sub.t
1 #!./perl -w
2
3 BEGIN {
4     chdir 't' if -d 't';
5     require './test.pl';
6     set_up_inc('../lib');
7 }
8
9 plan( tests => 36 );
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
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 }
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 }
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
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
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;
108 is "@scratch", "main road road main",
109    'recursive calls do not share shared-hash-key TARGs';
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);
121 is "@scratch", "o n", 
122    'recursive calls do not share shared-hash-key TARGs (2)';
123
124 # [perl #78194] @_ aliasing op return values
125 sub { is \$_[0], \$_[0],
126         '[perl #78194] \$_[0] == \$_[0] when @_ aliases "$x"' }
127  ->("${\''}");
128
129 # The return statement should make no difference in this case:
130 sub not_constant () {        42 }
131 sub not_constantr() { return 42 }
132 use feature 'lexical_subs'; no warnings 'experimental::lexical_subs';
133 my sub not_constantm () {        42 }
134 my sub not_constantmr() { return 42 }
135 eval { ${\not_constant}++ };
136 is $@, "", 'sub (){42} returns a mutable value';
137 eval { ${\not_constantr}++ };
138 is $@, "", 'sub (){ return 42 } returns a mutable value';
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';
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';
149
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 }
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';
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 {
171     sub re::regmust{}
172     bless \&re::regmust;
173     DESTROY {
174         no warnings 'redefine', 'prototype';
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     }
180     local $^W; # Suppress redef warnings in XSLoader
181     require re;
182     is $str[1], $str[0],
183       'XSUB clobbering sub whose DESTROY assigns to the glob';
184 }
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 }
200
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");
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 }
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';
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