1use warnings;
2use strict;
3use Test::More tests => 78;
4
5use XS::APItest;
6
7{
8    local $TODO = "[perl #78502] function pointers don't match on cygwin"
9        if $^O eq "cygwin";
10    ok( eval { XS::APItest::test_cv_getset_call_checker(); 1 },
11        "test_cv_getset_call_checker() works as expected")
12        or diag $@;
13}
14
15my @z = ();
16my @a = qw(a);
17my @b = qw(a b);
18my @c = qw(a b c);
19
20my($foo_got, $foo_ret);
21sub foo($@) { $foo_got = [ @_ ]; return "z"; }
22
23sub bar (\@$) { }
24sub baz { }
25
26$foo_got = undef;
27eval q{$foo_ret = foo(@b, @c);};
28is $@, "";
29is_deeply $foo_got, [ 2, qw(a b c) ];
30is $foo_ret, "z";
31
32$foo_got = undef;
33eval q{$foo_ret = &foo(@b, @c);};
34is $@, "";
35is_deeply $foo_got, [ qw(a b), qw(a b c) ];
36is $foo_ret, "z";
37
38cv_set_call_checker_lists(\&foo);
39
40$foo_got = undef;
41eval q{$foo_ret = foo(@b, @c);};
42is $@, "";
43is_deeply $foo_got, [ qw(a b), qw(a b c) ];
44is $foo_ret, "z";
45
46$foo_got = undef;
47eval q{$foo_ret = &foo(@b, @c);};
48is $@, "";
49is_deeply $foo_got, [ qw(a b), qw(a b c) ];
50is $foo_ret, "z";
51
52cv_set_call_checker_scalars(\&foo);
53
54$foo_got = undef;
55eval q{$foo_ret = foo(@b, @c);};
56is $@, "";
57is_deeply $foo_got, [ 2, 3 ];
58is $foo_ret, "z";
59
60$foo_got = undef;
61eval q{$foo_ret = foo(@b, @c, @a, @c);};
62is $@, "";
63is_deeply $foo_got, [ 2, 3, 1, 3 ];
64is $foo_ret, "z";
65
66$foo_got = undef;
67eval q{$foo_ret = foo(@b);};
68is $@, "";
69is_deeply $foo_got, [ 2 ];
70is $foo_ret, "z";
71
72$foo_got = undef;
73eval q{$foo_ret = foo();};
74is $@, "";
75is_deeply $foo_got, [];
76is $foo_ret, "z";
77
78$foo_got = undef;
79eval q{$foo_ret = &foo(@b, @c);};
80is $@, "";
81is_deeply $foo_got, [ qw(a b), qw(a b c) ];
82is $foo_ret, "z";
83
84cv_set_call_checker_proto(\&foo, "\\\@\$");
85$foo_got = undef;
86eval q{$foo_ret = foo(@b, @c);};
87is $@, "";
88is_deeply $foo_got, [ \@b, 3 ];
89is $foo_ret, "z";
90
91cv_set_call_checker_proto(\&foo, undef);
92$foo_got = undef;
93eval q{$foo_ret = foo(@b, @c);};
94isnt $@, "";
95is_deeply $foo_got, undef;
96is $foo_ret, "z";
97
98cv_set_call_checker_proto(\&foo, \&bar);
99$foo_got = undef;
100eval q{$foo_ret = foo(@b, @c);};
101is $@, "";
102is_deeply $foo_got, [ \@b, 3 ];
103is $foo_ret, "z";
104
105cv_set_call_checker_proto(\&foo, \&baz);
106$foo_got = undef;
107eval q{$foo_ret = foo(@b, @c);};
108isnt $@, "";
109is_deeply $foo_got, undef;
110is $foo_ret, "z";
111
112cv_set_call_checker_proto_or_list(\&foo, "\\\@\$");
113$foo_got = undef;
114eval q{$foo_ret = foo(@b, @c);};
115is $@, "";
116is_deeply $foo_got, [ \@b, 3 ];
117is $foo_ret, "z";
118
119cv_set_call_checker_proto_or_list(\&foo, undef);
120$foo_got = undef;
121eval q{$foo_ret = foo(@b, @c);};
122is $@, "";
123is_deeply $foo_got, [ qw(a b), qw(a b c) ];
124is $foo_ret, "z";
125
126cv_set_call_checker_proto_or_list(\&foo, \&bar);
127$foo_got = undef;
128eval q{$foo_ret = foo(@b, @c);};
129is $@, "";
130is_deeply $foo_got, [ \@b, 3 ];
131is $foo_ret, "z";
132
133cv_set_call_checker_proto_or_list(\&foo, \&baz);
134$foo_got = undef;
135eval q{$foo_ret = foo(@b, @c);};
136is $@, "";
137is_deeply $foo_got, [ qw(a b), qw(a b c) ];
138is $foo_ret, "z";
139
140cv_set_call_checker_multi_sum(\&foo);
141
142$foo_got = undef;
143eval q{$foo_ret = foo(@b, @c);};
144is $@, "";
145is_deeply $foo_got, undef;
146is $foo_ret, 5;
147
148$foo_got = undef;
149eval q{$foo_ret = foo(@b);};
150is $@, "";
151is_deeply $foo_got, undef;
152is $foo_ret, 2;
153
154$foo_got = undef;
155eval q{$foo_ret = foo();};
156is $@, "";
157is_deeply $foo_got, undef;
158is $foo_ret, 0;
159
160$foo_got = undef;
161eval q{$foo_ret = foo(@b, @c, @a, @c);};
162is $@, "";
163is_deeply $foo_got, undef;
164is $foo_ret, 9;
165
166sub MODIFY_CODE_ATTRIBUTES { cv_set_call_checker_lists($_[1]); () }
167BEGIN {
168  *foo2 = sub($$) :Attr { $foo_got = [ @_ ]; return "z"; };
169  my $foo = 3;
170  *foo3 = sub() :Attr { $foo };
171}
172
173$foo_got = undef;
174eval q{$foo_ret = foo2(@b, @c);};
175is $@, "";
176is_deeply $foo_got, [ qw(a b), qw(a b c) ];
177is $foo_ret, "z";
178
179eval q{$foo_ret = foo3(@b, @c);};
180is $@, "";
181is $foo_ret, 3;
182
183cv_set_call_checker_lists(\&foo);
184undef &foo;
185$foo_got = undef;
186eval 'sub foo($@) { $foo_got = [ @_ ]; return "z"; }
187      $foo_ret = foo(@b, @c);';
188is $@, "";
189is_deeply $foo_got, [ 2, qw(a b c) ], 'undef clears call checkers';
190is $foo_ret, "z";
191
192my %got;
193
194sub g {
195    my $name = shift;
196    my $sub = sub ($\@) {
197	$got{$name} = [ @_ ];
198	return $name;
199    };
200    cv_set_call_checker_scalars($sub);
201    return $sub;
202}
203
204BEGIN {
205    *whack = g("whack");
206    *glurp = g("glurp");
207}
208
209%got = ();
210my $whack_ret = whack(@b, @c);
211is $@, "";
212is_deeply $got{whack}, [ 2, 3 ];
213is $whack_ret, "whack";
214
215my $glurp_ret = glurp(@b, @c);
216is $@, "";
217is_deeply $got{glurp}, [ 2, 3 ];
218is $glurp_ret, "glurp";
219
2201;
221