1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
|
#!./perl -w
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
require './test.pl';
}
plan( tests => 26 );
sub empty_sub {}
is(empty_sub,undef,"Is empty");
is(empty_sub(1,2,3),undef,"Is still empty");
@test = empty_sub();
is(scalar(@test), 0, 'Didnt return anything');
@test = empty_sub(1,2,3);
is(scalar(@test), 0, 'Didnt return anything');
# RT #63790: calling PL_sv_yes as a sub is special-cased to silently
# return (so Foo->import() silently fails if import() doesn't exist),
# But make sure it correctly pops the stack and mark stack before returning.
{
my @a;
push @a, 4, 5, main->import(6,7);
ok(eq_array(\@a, [4,5]), "import with args");
@a = ();
push @a, 14, 15, main->import;
ok(eq_array(\@a, [14,15]), "import without args");
my $x = 1;
@a = ();
push @a, 24, 25, &{$x == $x}(26,27);
ok(eq_array(\@a, [24,25]), "yes with args");
@a = ();
push @a, 34, 35, &{$x == $x};
ok(eq_array(\@a, [34,35]), "yes without args");
}
# [perl #81944] return should always copy
{
$foo{bar} = 7;
for my $x ($foo{bar}) {
# Pity test.pl doesnt have isn't.
isnt \sub { delete $foo{bar} }->(), \$x,
'result of delete(helem) is copied when returned';
}
$foo{bar} = 7;
for my $x ($foo{bar}) {
isnt \sub { return delete $foo{bar} }->(), \$x,
'result of delete(helem) is copied when explicitly returned';
}
my $x;
isnt \sub { delete $_[0] }->($x), \$x,
'result of delete(aelem) is copied when returned';
isnt \sub { return delete $_[0] }->($x), \$x,
'result of delete(aelem) is copied when explicitly returned';
isnt \sub { ()=\@_; shift }->($x), \$x,
'result of shift is copied when returned';
isnt \sub { ()=\@_; return shift }->($x), \$x,
'result of shift is copied when explicitly returned';
}
fresh_perl_is
<<'end', "main::foo\n", {}, 'sub redefinition sets CvGV';
*foo = \&baz;
*bar = *foo;
eval 'sub bar { print +(caller 0)[3], "\n" }';
bar();
end
fresh_perl_is
<<'end', "main::foo\nok\n", {}, 'no double free redefining anon stub';
my $sub = sub { 4 };
*foo = $sub;
*bar = *foo;
undef &$sub;
eval 'sub bar { print +(caller 0)[3], "\n" }';
&$sub;
undef *foo;
undef *bar;
print "ok\n";
end
# The outer call sets the scalar returned by ${\""}.${\""} to the current
# package name.
# The inner call sets it to "road".
# Each call records the value twice, the outer call surrounding the inner
# call. In 5.10-5.18 under ithreads, what gets pushed is
# qw(main road road road) because the inner call is clobbering the same
# scalar. If __PACKAGE__ is changed to "main", it works, the last element
# becoming "main".
my @scratch;
sub a {
for (${\""}.${\""}) {
$_ = $_[0];
push @scratch, $_;
a("road",1) unless $_[1];
push @scratch, $_;
}
}
a(__PACKAGE__);
require Config;
is "@scratch", "main road road main",
'recursive calls do not share shared-hash-key TARGs';
# Another test for the same bug, that does not rely on foreach. It depends
# on ref returning a shared hash key TARG.
undef @scratch;
sub b {
my ($pack, $depth) = @_;
my $o = bless[], $pack;
$pack++;
push @scratch, (ref $o, $depth||b($pack,$depth+1))[0];
}
b('n',0);
$::TODO = "not fixed yet" if $Config::Config{useithreads};
is "@scratch", "o n",
'recursive calls do not share shared-hash-key TARGs (2)';
undef $::TODO;
# [perl #78194] @_ aliasing op return values
sub { is \$_[0], \$_[0],
'[perl #78194] \$_[0] == \$_[0] when @_ aliases "$x"' }
->("${\''}");
# The return statement should make no difference in this case:
sub not_constant () { 42 }
sub not_constantr() { return 42 }
use feature 'lexical_subs'; no warnings 'experimental::lexical_subs';
my sub not_constantm () { 42 }
my sub not_constantmr() { return 42 }
eval { ${\not_constant}++ };
is $@, "", 'sub (){42} returns a mutable value';
eval { ${\not_constantr}++ };
is $@, "", 'sub (){ return 42 } returns a mutable value';
eval { ${\not_constantm}++ };
is $@, "", 'my sub (){42} returns a mutable value';
eval { ${\not_constantmr}++ };
is $@, "", 'my sub (){ return 42 } returns a mutable value';
# [perl #79908]
{
my $x = 5;
*_79908 = sub (){$x};
$x = 7;
is eval "_79908", 7, 'sub(){$x} does not break closures';
isnt eval '\_79908', \$x, 'sub(){$x} returns a copy';
# Test another thing that was broken by $x inlinement
my $y;
no warnings 'once';
local *time = sub():method{$y};
my $w;
local $SIG{__WARN__} = sub { $w .= shift };
eval "()=time";
is $w, undef,
'*keyword = sub():method{$y} does not cause ambiguity warnings';
}
|
