call_checker.t revision 1.3
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