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
164
165
166
167
168
169
170
|
#!perl -w
# test the MULTICALL macros
# Note: as of Oct 2010, there are not yet comprehensive tests
# for these macros.
use warnings;
use strict;
use Test::More tests => 80;
use XS::APItest;
{
my $sum = 0;
sub add { $sum += $_++ }
my @a = (1..3);
XS::APItest::multicall_each \&add, @a;
is($sum, 6, "sum okay");
is($a[0], 2, "a[0] okay");
is($a[1], 3, "a[1] okay");
is($a[2], 4, "a[2] okay");
}
# [perl #78070]
# multicall using a sub that already has CvDEPTH > 1 caused sub
# to be prematurely freed
{
my $destroyed = 0;
sub REC::DESTROY { $destroyed = 1 }
my $closure_var;
{
my $f = sub {
no warnings 'void';
$closure_var;
my $sub = shift;
if (defined $sub) {
XS::APItest::multicall_each \&$sub, 1,2,3;
}
};
bless $f, 'REC';
$f->($f);
is($destroyed, 0, "f not yet destroyed");
}
is($destroyed, 1, "f now destroyed");
}
# [perl #115602]
# deep recursion realloced the CX stack, but the dMULTICALL local var
# 'cx' still pointed to the old one.
# This doesn't actually test the failure (I couldn't think of a way to
# get the failure to show at the perl level) but it allows valgrind or
# similar to spot any errors.
{
sub rec { my $c = shift; rec($c-1) if $c > 0 };
my @r = XS::APItest::multicall_each { rec(90) } 1,2,3;
pass("recursion");
}
# Confirm that MULTICALL handles arg return correctly in the various
# contexts. Also check that lvalue subs are handled the same way, as
# these take different code paths.
# Whenever an explicit 'return' is used, it is followed by '1;' to avoid
# the return being optimised into a leavesub.
# Adding a 'for' loop pushes extra junk on the stack, which we want to
# avoid being interpreted as a return arg.
{
package Ret;
use XS::APItest qw(multicall_return G_VOID G_SCALAR G_ARRAY);
# Helper function for the block that follows:
# check that @$got matches what would be expected if a function returned
# the items in @$args in $gimme context.
sub gimme_check {
my ($gimme, $got, $args, $desc) = @_;
if ($gimme == G_VOID) {
::is (scalar @$got, 0, "G_VOID: $desc");
}
elsif ($gimme == G_SCALAR) {
::is (scalar @$got, 1, "G_SCALAR: $desc: expect 1 arg");
::is ($got->[0], (@$args ? $args->[-1] : undef),
"G_SCALAR: $desc: correct arg");
}
else {
::is (join('-',@$got), join('-', @$args), "G_ARRAY: $desc");
}
}
for my $gimme (G_VOID, G_SCALAR, G_ARRAY) {
my @a;
# zero args
@a = multicall_return {()} $gimme;
gimme_check($gimme, \@a, [], "()");
sub f1 :lvalue { () }
@a = multicall_return \&f1, $gimme;
gimme_check($gimme, \@a, [], "() lval");
@a = multicall_return { return; 1 } $gimme;
gimme_check($gimme, \@a, [], "return");
sub f2 :lvalue { return; 1 }
@a = multicall_return \&f2, $gimme;
gimme_check($gimme, \@a, [], "return lval");
@a = multicall_return { for (1,2) { return; 1 } } $gimme;
gimme_check($gimme, \@a, [], "for-return");
sub f3 :lvalue { for (1,2) { return; 1 } }
@a = multicall_return \&f3, $gimme;
gimme_check($gimme, \@a, [], "for-return lval");
# one arg
@a = multicall_return {"one"} $gimme;
gimme_check($gimme, \@a, ["one"], "one arg");
sub f4 :lvalue { "one" }
@a = multicall_return \&f4, $gimme;
gimme_check($gimme, \@a, ["one"], "one arg lval");
@a = multicall_return { return "one"; 1} $gimme;
gimme_check($gimme, \@a, ["one"], "return one arg");
sub f5 :lvalue { return "one"; 1 }
@a = multicall_return \&f5, $gimme;
gimme_check($gimme, \@a, ["one"], "return one arg lval");
@a = multicall_return { for (1,2) { return "one"; 1} } $gimme;
gimme_check($gimme, \@a, ["one"], "for-return one arg");
sub f6 :lvalue { for (1,2) { return "one"; 1 } }
@a = multicall_return \&f6, $gimme;
gimme_check($gimme, \@a, ["one"], "for-return one arg lval");
# two args
@a = multicall_return {"one", "two" } $gimme;
gimme_check($gimme, \@a, ["one", "two"], "two args");
sub f7 :lvalue { "one", "two" }
@a = multicall_return \&f7, $gimme;
gimme_check($gimme, \@a, ["one", "two"], "two args lval");
@a = multicall_return { return "one", "two"; 1} $gimme;
gimme_check($gimme, \@a, ["one", "two"], "return two args");
sub f8 :lvalue { return "one", "two"; 1 }
@a = multicall_return \&f8, $gimme;
gimme_check($gimme, \@a, ["one", "two"], "return two args lval");
@a = multicall_return { for (1,2) { return "one", "two"; 1} } $gimme;
gimme_check($gimme, \@a, ["one", "two"], "for-return two args");
sub f9 :lvalue { for (1,2) { return "one", "two"; 1 } }
@a = multicall_return \&f9, $gimme;
gimme_check($gimme, \@a, ["one", "two"], "for-return two args lval");
}
# MULTICALL *shouldn't* clear savestack after each call
sub f10 { my $x = 1; $x };
my @a = XS::APItest::multicall_return \&f10, G_SCALAR;
::is($a[0], 1, "leave scope");
}
|
