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