This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
429cea6b9b1f952f6847640784ee104f13043877
[perl5.git] / ext / XS-APItest / t / call_checker.t
1 use warnings;
2 use strict;
3 use Test::More tests => 67;
4
5 use XS::APItest;
6
7 XS::APItest::test_cv_getset_call_checker();
8 ok 1;
9
10 my @z = ();
11 my @a = qw(a);
12 my @b = qw(a b);
13 my @c = qw(a b c);
14
15 my($foo_got, $foo_ret);
16 sub foo($@) { $foo_got = [ @_ ]; return "z"; }
17
18 sub bar (\@$) { }
19 sub baz { }
20
21 $foo_got = undef;
22 eval q{$foo_ret = foo(@b, @c);};
23 is $@, "";
24 is_deeply $foo_got, [ 2, qw(a b c) ];
25 is $foo_ret, "z";
26
27 $foo_got = undef;
28 eval q{$foo_ret = &foo(@b, @c);};
29 is $@, "";
30 is_deeply $foo_got, [ qw(a b), qw(a b c) ];
31 is $foo_ret, "z";
32
33 cv_set_call_checker_lists(\&foo);
34
35 $foo_got = undef;
36 eval q{$foo_ret = foo(@b, @c);};
37 is $@, "";
38 is_deeply $foo_got, [ qw(a b), qw(a b c) ];
39 is $foo_ret, "z";
40
41 $foo_got = undef;
42 eval q{$foo_ret = &foo(@b, @c);};
43 is $@, "";
44 is_deeply $foo_got, [ qw(a b), qw(a b c) ];
45 is $foo_ret, "z";
46
47 cv_set_call_checker_scalars(\&foo);
48
49 $foo_got = undef;
50 eval q{$foo_ret = foo(@b, @c);};
51 is $@, "";
52 is_deeply $foo_got, [ 2, 3 ];
53 is $foo_ret, "z";
54
55 $foo_got = undef;
56 eval q{$foo_ret = foo(@b, @c, @a, @c);};
57 is $@, "";
58 is_deeply $foo_got, [ 2, 3, 1, 3 ];
59 is $foo_ret, "z";
60
61 $foo_got = undef;
62 eval q{$foo_ret = foo(@b);};
63 is $@, "";
64 is_deeply $foo_got, [ 2 ];
65 is $foo_ret, "z";
66
67 $foo_got = undef;
68 eval q{$foo_ret = foo();};
69 is $@, "";
70 is_deeply $foo_got, [];
71 is $foo_ret, "z";
72
73 $foo_got = undef;
74 eval q{$foo_ret = &foo(@b, @c);};
75 is $@, "";
76 is_deeply $foo_got, [ qw(a b), qw(a b c) ];
77 is $foo_ret, "z";
78
79 cv_set_call_checker_proto(\&foo, "\\\@\$");
80 $foo_got = undef;
81 eval q{$foo_ret = foo(@b, @c);};
82 is $@, "";
83 is_deeply $foo_got, [ \@b, 3 ];
84 is $foo_ret, "z";
85
86 cv_set_call_checker_proto(\&foo, undef);
87 $foo_got = undef;
88 eval q{$foo_ret = foo(@b, @c);};
89 isnt $@, "";
90 is_deeply $foo_got, undef;
91 is $foo_ret, "z";
92
93 cv_set_call_checker_proto(\&foo, \&bar);
94 $foo_got = undef;
95 eval q{$foo_ret = foo(@b, @c);};
96 is $@, "";
97 is_deeply $foo_got, [ \@b, 3 ];
98 is $foo_ret, "z";
99
100 cv_set_call_checker_proto(\&foo, \&baz);
101 $foo_got = undef;
102 eval q{$foo_ret = foo(@b, @c);};
103 isnt $@, "";
104 is_deeply $foo_got, undef;
105 is $foo_ret, "z";
106
107 cv_set_call_checker_proto_or_list(\&foo, "\\\@\$");
108 $foo_got = undef;
109 eval q{$foo_ret = foo(@b, @c);};
110 is $@, "";
111 is_deeply $foo_got, [ \@b, 3 ];
112 is $foo_ret, "z";
113
114 cv_set_call_checker_proto_or_list(\&foo, undef);
115 $foo_got = undef;
116 eval q{$foo_ret = foo(@b, @c);};
117 is $@, "";
118 is_deeply $foo_got, [ qw(a b), qw(a b c) ];
119 is $foo_ret, "z";
120
121 cv_set_call_checker_proto_or_list(\&foo, \&bar);
122 $foo_got = undef;
123 eval q{$foo_ret = foo(@b, @c);};
124 is $@, "";
125 is_deeply $foo_got, [ \@b, 3 ];
126 is $foo_ret, "z";
127
128 cv_set_call_checker_proto_or_list(\&foo, \&baz);
129 $foo_got = undef;
130 eval q{$foo_ret = foo(@b, @c);};
131 is $@, "";
132 is_deeply $foo_got, [ qw(a b), qw(a b c) ];
133 is $foo_ret, "z";
134
135 cv_set_call_checker_multi_sum(\&foo);
136
137 $foo_got = undef;
138 eval q{$foo_ret = foo(@b, @c);};
139 is $@, "";
140 is_deeply $foo_got, undef;
141 is $foo_ret, 5;
142
143 $foo_got = undef;
144 eval q{$foo_ret = foo(@b);};
145 is $@, "";
146 is_deeply $foo_got, undef;
147 is $foo_ret, 2;
148
149 $foo_got = undef;
150 eval q{$foo_ret = foo();};
151 is $@, "";
152 is_deeply $foo_got, undef;
153 is $foo_ret, 0;
154
155 $foo_got = undef;
156 eval q{$foo_ret = foo(@b, @c, @a, @c);};
157 is $@, "";
158 is_deeply $foo_got, undef;
159 is $foo_ret, 9;
160
161 sub MODIFY_CODE_ATTRIBUTES { cv_set_call_checker_lists($_[1]); () }
162 BEGIN {
163   *foo2 = sub($$) :Attr { $foo_got = [ @_ ]; return "z"; };
164 }
165
166 $foo_got = undef;
167 eval q{$foo_ret = foo2(@b, @c);};
168 is $@, "";
169 is_deeply $foo_got, [ qw(a b), qw(a b c) ];
170 is $foo_ret, "z";
171
172 1;