Commit | Line | Data |
---|---|---|
3e61d65a JH |
1 | package XS::APItest; |
2 | ||
3 | use 5.008; | |
4 | use strict; | |
5 | use warnings; | |
6 | use Carp; | |
7 | ||
e2f1cb34 | 8 | use base 'DynaLoader'; |
3e61d65a JH |
9 | |
10 | # Export everything since these functions are only used by a test script | |
e2f1cb34 NC |
11 | # Export subpackages too - in effect, export all their routines into us, then |
12 | # export everything from us. | |
13 | sub import { | |
14 | my $package = shift; | |
15 | croak ("Can't export for '$package'") unless $package eq __PACKAGE__; | |
16 | my $exports; | |
17 | @{$exports}{@_} = () if @_; | |
18 | ||
19 | my $callpkg = caller; | |
20 | ||
21 | my @stashes = ('XS::APItest::', \%XS::APItest::); | |
22 | while (my ($stash_name, $stash) = splice @stashes, 0, 2) { | |
23 | while (my ($sym_name, $glob) = each %$stash) { | |
24 | if ($sym_name =~ /::$/) { | |
25 | # Skip any subpackages that are clearly OO | |
26 | next if *{$glob}{HASH}{'new'}; | |
27 | push @stashes, "$stash_name$sym_name", *{$glob}{HASH}; | |
28 | } elsif (ref $glob eq 'SCALAR' || *{$glob}{CODE}) { | |
29 | if ($exports) { | |
30 | next if !exists $exports->{$sym_name}; | |
31 | delete $exports->{$sym_name}; | |
32 | } | |
33 | no strict 'refs'; | |
34 | *{"$callpkg\::$sym_name"} = \&{"$stash_name$sym_name"}; | |
35 | } | |
36 | } | |
37 | } | |
38 | if ($exports) { | |
39 | my @carp = keys %$exports; | |
40 | if (@carp) { | |
41 | croak(join '', | |
42 | (map "\"$_\" is not exported by the $package module\n", sort @carp), | |
43 | "Can't continue after import errors"); | |
44 | } | |
45 | } | |
46 | } | |
3e61d65a | 47 | |
e2f1cb34 | 48 | our $VERSION = '0.22'; |
84ac5fd7 NC |
49 | |
50 | use vars '$WARNINGS_ON_BOOTSTRAP'; | |
0932863f NC |
51 | use vars map "\$${_}_called_PP", qw(BEGIN UNITCHECK CHECK INIT END); |
52 | ||
9568a123 NC |
53 | BEGIN { |
54 | # This is arguably a hack, but it disposes of the UNITCHECK block without | |
55 | # needing to preprocess the source code | |
56 | if ($] < 5.009) { | |
57 | eval 'sub UNITCHECK (&) {}; 1' or die $@; | |
58 | } | |
59 | } | |
60 | ||
0932863f NC |
61 | # Do these here to verify that XS code and Perl code get called at the same |
62 | # times | |
63 | BEGIN { | |
64 | $BEGIN_called_PP++; | |
65 | } | |
66 | UNITCHECK { | |
67 | $UNITCHECK_called_PP++; | |
9568a123 | 68 | }; |
0932863f NC |
69 | { |
70 | # Need $W false by default, as some tests run under -w, and under -w we | |
71 | # can get warnings about "Too late to run CHECK" block (and INIT block) | |
72 | no warnings 'void'; | |
73 | CHECK { | |
74 | $CHECK_called_PP++; | |
75 | } | |
76 | INIT { | |
77 | $INIT_called_PP++; | |
78 | } | |
79 | } | |
80 | END { | |
81 | $END_called_PP++; | |
82 | } | |
83 | ||
84ac5fd7 NC |
84 | if ($WARNINGS_ON_BOOTSTRAP) { |
85 | bootstrap XS::APItest $VERSION; | |
86 | } else { | |
0932863f | 87 | # More CHECK and INIT blocks that could warn: |
84ac5fd7 | 88 | local $^W; |
84ac5fd7 NC |
89 | bootstrap XS::APItest $VERSION; |
90 | } | |
3e61d65a JH |
91 | |
92 | 1; | |
93 | __END__ | |
94 | ||
95 | =head1 NAME | |
96 | ||
97 | XS::APItest - Test the perl C API | |
98 | ||
99 | =head1 SYNOPSIS | |
100 | ||
101 | use XS::APItest; | |
102 | print_double(4); | |
103 | ||
104 | =head1 ABSTRACT | |
105 | ||
d97c33b5 DM |
106 | This module tests the perl C API. Also exposes various bit of the perl |
107 | internals for the use of core test scripts. | |
3e61d65a JH |
108 | |
109 | =head1 DESCRIPTION | |
110 | ||
111 | This module can be used to check that the perl C API is behaving | |
112 | correctly. This module provides test functions and an associated | |
113 | test script that verifies the output. | |
114 | ||
115 | This module is not meant to be installed. | |
116 | ||
117 | =head2 EXPORT | |
118 | ||
119 | Exports all the test functions: | |
120 | ||
121 | =over 4 | |
122 | ||
123 | =item B<print_double> | |
124 | ||
125 | Test that a double-precision floating point number is formatted | |
126 | correctly by C<printf>. | |
127 | ||
128 | print_double( $val ); | |
129 | ||
130 | Output is sent to STDOUT. | |
131 | ||
132 | =item B<print_long_double> | |
133 | ||
134 | Test that a C<long double> is formatted correctly by | |
135 | C<printf>. Takes no arguments - the test value is hard-wired | |
136 | into the function (as "7"). | |
137 | ||
138 | print_long_double(); | |
139 | ||
140 | Output is sent to STDOUT. | |
141 | ||
142 | =item B<have_long_double> | |
143 | ||
144 | Determine whether a C<long double> is supported by Perl. This should | |
145 | be used to determine whether to test C<print_long_double>. | |
146 | ||
147 | print_long_double() if have_long_double; | |
148 | ||
149 | =item B<print_nv> | |
150 | ||
151 | Test that an C<NV> is formatted correctly by | |
152 | C<printf>. | |
153 | ||
154 | print_nv( $val ); | |
155 | ||
156 | Output is sent to STDOUT. | |
157 | ||
158 | =item B<print_iv> | |
159 | ||
160 | Test that an C<IV> is formatted correctly by | |
161 | C<printf>. | |
162 | ||
163 | print_iv( $val ); | |
164 | ||
165 | Output is sent to STDOUT. | |
166 | ||
167 | =item B<print_uv> | |
168 | ||
169 | Test that an C<UV> is formatted correctly by | |
170 | C<printf>. | |
171 | ||
172 | print_uv( $val ); | |
173 | ||
174 | Output is sent to STDOUT. | |
175 | ||
176 | =item B<print_int> | |
177 | ||
178 | Test that an C<int> is formatted correctly by | |
179 | C<printf>. | |
180 | ||
181 | print_int( $val ); | |
182 | ||
183 | Output is sent to STDOUT. | |
184 | ||
185 | =item B<print_long> | |
186 | ||
187 | Test that an C<long> is formatted correctly by | |
188 | C<printf>. | |
189 | ||
190 | print_long( $val ); | |
191 | ||
192 | Output is sent to STDOUT. | |
193 | ||
194 | =item B<print_float> | |
195 | ||
196 | Test that a single-precision floating point number is formatted | |
197 | correctly by C<printf>. | |
198 | ||
199 | print_float( $val ); | |
200 | ||
201 | Output is sent to STDOUT. | |
202 | ||
d1f347d7 DM |
203 | =item B<call_sv>, B<call_pv>, B<call_method> |
204 | ||
205 | These exercise the C calls of the same names. Everything after the flags | |
206 | arg is passed as the the args to the called function. They return whatever | |
207 | the C function itself pushed onto the stack, plus the return value from | |
208 | the function; for example | |
209 | ||
210 | call_sv( sub { @_, 'c' }, G_ARRAY, 'a', 'b'); # returns 'a', 'b', 'c', 3 | |
211 | call_sv( sub { @_ }, G_SCALAR, 'a', 'b'); # returns 'b', 1 | |
212 | ||
213 | =item B<eval_sv> | |
214 | ||
3c4b39be | 215 | Evaluates the passed SV. Result handling is done the same as for |
d1f347d7 DM |
216 | C<call_sv()> etc. |
217 | ||
218 | =item B<eval_pv> | |
219 | ||
3c4b39be | 220 | Exercises the C function of the same name in scalar context. Returns the |
d1f347d7 DM |
221 | same SV that the C function returns. |
222 | ||
223 | =item B<require_pv> | |
224 | ||
3c4b39be | 225 | Exercises the C function of the same name. Returns nothing. |
d1f347d7 | 226 | |
3e61d65a JH |
227 | =back |
228 | ||
229 | =head1 SEE ALSO | |
230 | ||
231 | L<XS::Typemap>, L<perlapi>. | |
232 | ||
233 | =head1 AUTHORS | |
234 | ||
235 | Tim Jenness, E<lt>t.jenness@jach.hawaii.eduE<gt>, | |
236 | Christian Soeller, E<lt>csoelle@mph.auckland.ac.nzE<gt>, | |
237 | Hugo van der Sanden E<lt>hv@crypt.compulink.co.ukE<gt> | |
238 | ||
239 | =head1 COPYRIGHT AND LICENSE | |
240 | ||
d1f347d7 | 241 | Copyright (C) 2002,2004 Tim Jenness, Christian Soeller, Hugo van der Sanden. |
3e61d65a JH |
242 | All Rights Reserved. |
243 | ||
244 | This library is free software; you can redistribute it and/or modify | |
245 | it under the same terms as Perl itself. | |
246 | ||
247 | =cut |