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