This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Stop shared hash key TARGs from being shared
[perl5.git] / t / op / sub.t
CommitLineData
f7218ed4 1#!./perl -w
2d981f27
AB
2
3BEGIN {
4 chdir 't' if -d 't';
5 @INC = '../lib';
f7218ed4 6 require './test.pl';
2d981f27
AB
7}
8
137da2b0 9plan( tests => 26 );
2d981f27
AB
10
11sub empty_sub {}
12
13is(empty_sub,undef,"Is empty");
14is(empty_sub(1,2,3),undef,"Is still empty");
15@test = empty_sub();
16is(scalar(@test), 0, 'Didnt return anything');
17@test = empty_sub(1,2,3);
18is(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
68fresh_perl_is
69 <<'end', "main::foo\n", {}, 'sub redefinition sets CvGV';
70*foo = \&baz;
71*bar = *foo;
72eval 'sub bar { print +(caller 0)[3], "\n" }';
73bar();
74end
e52de15a
FC
75
76fresh_perl_is
77 <<'end', "main::foo\nok\n", {}, 'no double free redefining anon stub';
78my $sub = sub { 4 };
79*foo = $sub;
80*bar = *foo;
81undef &$sub;
82eval 'sub bar { print +(caller 0)[3], "\n" }';
83&$sub;
84undef *foo;
85undef *bar;
86print "ok\n";
87end
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".
97my @scratch;
98sub a {
99 for (${\""}.${\""}) {
100 $_ = $_[0];
101 push @scratch, $_;
102 a("road",1) unless $_[1];
103 push @scratch, $_;
104 }
105}
106a(__PACKAGE__);
107require Config;
7f6ba6d2
FC
108is "@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.
113undef @scratch;
114sub b {
115 my ($pack, $depth) = @_;
116 my $o = bless[], $pack;
117 $pack++;
118 push @scratch, (ref $o, $depth||b($pack,$depth+1))[0];
119}
120b('n',0);
8e079c2a
FC
121is "@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
125sub { 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:
130sub not_constant () { 42 }
131sub not_constantr() { return 42 }
d2440203
FC
132use feature 'lexical_subs'; no warnings 'experimental::lexical_subs';
133my sub not_constantm () { 42 }
134my sub not_constantmr() { return 42 }
b784b94c
FC
135eval { ${\not_constant}++ };
136is $@, "", 'sub (){42} returns a mutable value';
b784b94c
FC
137eval { ${\not_constantr}++ };
138is $@, "", 'sub (){ return 42 } returns a mutable value';
d2440203
FC
139eval { ${\not_constantm}++ };
140is $@, "", 'my sub (){42} returns a mutable value';
141eval { ${\not_constantmr}++ };
142is $@, "", 'my sub (){ return 42 } returns a mutable value';
137da2b0
FC
143
144# [perl #79908]
145{
146 my $x = 5;
147 *_79908 = sub (){$x};
148 $x = 7;
149 is eval "_79908", 7, 'sub(){$x} does not break closures';
150 isnt eval '\_79908', \$x, 'sub(){$x} returns a copy';
151
152 # Test another thing that was broken by $x inlinement
153 my $y;
154 no warnings 'once';
155 local *time = sub():method{$y};
156 my $w;
157 local $SIG{__WARN__} = sub { $w .= shift };
158 eval "()=time";
159 is $w, undef,
160 '*keyword = sub():method{$y} does not cause ambiguity warnings';
161}