Commit | Line | Data |
---|---|---|
3e61d65a JH |
1 | package XS::APItest; |
2 | ||
45c5a37a | 3 | { use 5.011001; } # 5.11 is a long long time ago... What gives with this? |
3e61d65a JH |
4 | use strict; |
5 | use warnings; | |
6 | use Carp; | |
7 | ||
36791795 | 8 | our $VERSION = '0.91'; |
b7dfc24f | 9 | |
b58f046e | 10 | require XSLoader; |
3e61d65a JH |
11 | |
12 | # Export everything since these functions are only used by a test script | |
e2f1cb34 NC |
13 | # Export subpackages too - in effect, export all their routines into us, then |
14 | # export everything from us. | |
15 | sub import { | |
16 | my $package = shift; | |
17 | croak ("Can't export for '$package'") unless $package eq __PACKAGE__; | |
18 | my $exports; | |
19 | @{$exports}{@_} = () if @_; | |
20 | ||
21 | my $callpkg = caller; | |
22 | ||
23 | my @stashes = ('XS::APItest::', \%XS::APItest::); | |
24 | while (my ($stash_name, $stash) = splice @stashes, 0, 2) { | |
25 | while (my ($sym_name, $glob) = each %$stash) { | |
26 | if ($sym_name =~ /::$/) { | |
27 | # Skip any subpackages that are clearly OO | |
28 | next if *{$glob}{HASH}{'new'}; | |
120b7a08 S |
29 | # and any that have AUTOLOAD |
30 | next if *{$glob}{HASH}{AUTOLOAD}; | |
e2f1cb34 NC |
31 | push @stashes, "$stash_name$sym_name", *{$glob}{HASH}; |
32 | } elsif (ref $glob eq 'SCALAR' || *{$glob}{CODE}) { | |
33 | if ($exports) { | |
34 | next if !exists $exports->{$sym_name}; | |
35 | delete $exports->{$sym_name}; | |
36 | } | |
37 | no strict 'refs'; | |
38 | *{"$callpkg\::$sym_name"} = \&{"$stash_name$sym_name"}; | |
39 | } | |
40 | } | |
41 | } | |
83f8bb56 | 42 | foreach (keys %{$exports||{}}) { |
03d05f6e | 43 | next unless /\A(?:rpn|calcrpn|stufftest|swaptwostmts|looprest|scopelessblock|stmtasexpr|stmtsasexpr|loopblock|blockasexpr|swaplabel|labelconst|arrayfullexpr|arraylistexpr|arraytermexpr|arrayarithexpr|arrayexprflags|DEFSV|with_vars|join_with_space)\z/; |
83f8bb56 Z |
44 | $^H{"XS::APItest/$_"} = 1; |
45 | delete $exports->{$_}; | |
46 | } | |
e2f1cb34 NC |
47 | if ($exports) { |
48 | my @carp = keys %$exports; | |
49 | if (@carp) { | |
50 | croak(join '', | |
51 | (map "\"$_\" is not exported by the $package module\n", sort @carp), | |
52 | "Can't continue after import errors"); | |
53 | } | |
54 | } | |
55 | } | |
3e61d65a | 56 | |
84ac5fd7 | 57 | use vars '$WARNINGS_ON_BOOTSTRAP'; |
0932863f NC |
58 | use vars map "\$${_}_called_PP", qw(BEGIN UNITCHECK CHECK INIT END); |
59 | ||
9568a123 NC |
60 | BEGIN { |
61 | # This is arguably a hack, but it disposes of the UNITCHECK block without | |
62 | # needing to preprocess the source code | |
63 | if ($] < 5.009) { | |
64 | eval 'sub UNITCHECK (&) {}; 1' or die $@; | |
65 | } | |
66 | } | |
67 | ||
0932863f NC |
68 | # Do these here to verify that XS code and Perl code get called at the same |
69 | # times | |
70 | BEGIN { | |
71 | $BEGIN_called_PP++; | |
72 | } | |
73 | UNITCHECK { | |
74 | $UNITCHECK_called_PP++; | |
9568a123 | 75 | }; |
0932863f NC |
76 | { |
77 | # Need $W false by default, as some tests run under -w, and under -w we | |
78 | # can get warnings about "Too late to run CHECK" block (and INIT block) | |
79 | no warnings 'void'; | |
80 | CHECK { | |
81 | $CHECK_called_PP++; | |
82 | } | |
83 | INIT { | |
84 | $INIT_called_PP++; | |
85 | } | |
86 | } | |
87 | END { | |
88 | $END_called_PP++; | |
89 | } | |
90 | ||
84ac5fd7 | 91 | if ($WARNINGS_ON_BOOTSTRAP) { |
b58f046e | 92 | XSLoader::load(); |
84ac5fd7 | 93 | } else { |
0932863f | 94 | # More CHECK and INIT blocks that could warn: |
84ac5fd7 | 95 | local $^W; |
b58f046e | 96 | XSLoader::load(); |
84ac5fd7 | 97 | } |
3e61d65a | 98 | |
fba8e77b FC |
99 | # This XS function needs the lvalue attr applied. |
100 | eval 'use attributes __PACKAGE__, \\&lv_temp_object, "lvalue"; 1' or die; | |
101 | ||
3e61d65a JH |
102 | 1; |
103 | __END__ | |
104 | ||
105 | =head1 NAME | |
106 | ||
107 | XS::APItest - Test the perl C API | |
108 | ||
109 | =head1 SYNOPSIS | |
110 | ||
111 | use XS::APItest; | |
112 | print_double(4); | |
113 | ||
83f8bb56 Z |
114 | use XS::APItest qw(rpn calcrpn); |
115 | $triangle = rpn($n $n 1 + * 2 /); | |
116 | calcrpn $triangle { $n $n 1 + * 2 / } | |
117 | ||
3e61d65a JH |
118 | =head1 ABSTRACT |
119 | ||
d97c33b5 DM |
120 | This module tests the perl C API. Also exposes various bit of the perl |
121 | internals for the use of core test scripts. | |
3e61d65a JH |
122 | |
123 | =head1 DESCRIPTION | |
124 | ||
125 | This module can be used to check that the perl C API is behaving | |
126 | correctly. This module provides test functions and an associated | |
127 | test script that verifies the output. | |
128 | ||
129 | This module is not meant to be installed. | |
130 | ||
131 | =head2 EXPORT | |
132 | ||
133 | Exports all the test functions: | |
134 | ||
135 | =over 4 | |
136 | ||
137 | =item B<print_double> | |
138 | ||
139 | Test that a double-precision floating point number is formatted | |
140 | correctly by C<printf>. | |
141 | ||
142 | print_double( $val ); | |
143 | ||
144 | Output is sent to STDOUT. | |
145 | ||
146 | =item B<print_long_double> | |
147 | ||
148 | Test that a C<long double> is formatted correctly by | |
149 | C<printf>. Takes no arguments - the test value is hard-wired | |
150 | into the function (as "7"). | |
151 | ||
152 | print_long_double(); | |
153 | ||
154 | Output is sent to STDOUT. | |
155 | ||
156 | =item B<have_long_double> | |
157 | ||
158 | Determine whether a C<long double> is supported by Perl. This should | |
159 | be used to determine whether to test C<print_long_double>. | |
160 | ||
161 | print_long_double() if have_long_double; | |
162 | ||
163 | =item B<print_nv> | |
164 | ||
165 | Test that an C<NV> is formatted correctly by | |
166 | C<printf>. | |
167 | ||
168 | print_nv( $val ); | |
169 | ||
170 | Output is sent to STDOUT. | |
171 | ||
172 | =item B<print_iv> | |
173 | ||
174 | Test that an C<IV> is formatted correctly by | |
175 | C<printf>. | |
176 | ||
177 | print_iv( $val ); | |
178 | ||
179 | Output is sent to STDOUT. | |
180 | ||
181 | =item B<print_uv> | |
182 | ||
183 | Test that an C<UV> is formatted correctly by | |
184 | C<printf>. | |
185 | ||
186 | print_uv( $val ); | |
187 | ||
188 | Output is sent to STDOUT. | |
189 | ||
190 | =item B<print_int> | |
191 | ||
192 | Test that an C<int> is formatted correctly by | |
193 | C<printf>. | |
194 | ||
195 | print_int( $val ); | |
196 | ||
197 | Output is sent to STDOUT. | |
198 | ||
199 | =item B<print_long> | |
200 | ||
201 | Test that an C<long> is formatted correctly by | |
202 | C<printf>. | |
203 | ||
204 | print_long( $val ); | |
205 | ||
206 | Output is sent to STDOUT. | |
207 | ||
208 | =item B<print_float> | |
209 | ||
210 | Test that a single-precision floating point number is formatted | |
211 | correctly by C<printf>. | |
212 | ||
213 | print_float( $val ); | |
214 | ||
215 | Output is sent to STDOUT. | |
216 | ||
27fcb6ee FC |
217 | =item B<filter> |
218 | ||
219 | Installs a source filter that substitutes "e" for "o" (witheut regard fer | |
220 | what it might be medifying). | |
221 | ||
d1f347d7 DM |
222 | =item B<call_sv>, B<call_pv>, B<call_method> |
223 | ||
224 | These exercise the C calls of the same names. Everything after the flags | |
04a9cc25 | 225 | arg is passed as the args to the called function. They return whatever |
d1f347d7 DM |
226 | the C function itself pushed onto the stack, plus the return value from |
227 | the function; for example | |
228 | ||
555bd962 BG |
229 | call_sv( sub { @_, 'c' }, G_ARRAY, 'a', 'b'); |
230 | # returns 'a', 'b', 'c', 3 | |
231 | call_sv( sub { @_ }, G_SCALAR, 'a', 'b'); | |
232 | # returns 'b', 1 | |
d1f347d7 DM |
233 | |
234 | =item B<eval_sv> | |
235 | ||
3c4b39be | 236 | Evaluates the passed SV. Result handling is done the same as for |
d1f347d7 DM |
237 | C<call_sv()> etc. |
238 | ||
239 | =item B<eval_pv> | |
240 | ||
3c4b39be | 241 | Exercises the C function of the same name in scalar context. Returns the |
d1f347d7 DM |
242 | same SV that the C function returns. |
243 | ||
244 | =item B<require_pv> | |
245 | ||
3c4b39be | 246 | Exercises the C function of the same name. Returns nothing. |
d1f347d7 | 247 | |
3e61d65a JH |
248 | =back |
249 | ||
83f8bb56 Z |
250 | =head1 KEYWORDS |
251 | ||
252 | These are not supplied by default, but must be explicitly imported. | |
253 | They are lexically scoped. | |
254 | ||
255 | =over | |
256 | ||
ce409cc8 LM |
257 | =item DEFSV |
258 | ||
259 | Behaves like C<$_>. | |
260 | ||
83f8bb56 Z |
261 | =item rpn(EXPRESSION) |
262 | ||
263 | This construct is a Perl expression. I<EXPRESSION> must be an RPN | |
264 | arithmetic expression, as described below. The RPN expression is | |
265 | evaluated, and its value is returned as the value of the Perl expression. | |
266 | ||
267 | =item calcrpn VARIABLE { EXPRESSION } | |
268 | ||
269 | This construct is a complete Perl statement. (No semicolon should | |
270 | follow the closing brace.) I<VARIABLE> must be a Perl scalar C<my> | |
271 | variable, and I<EXPRESSION> must be an RPN arithmetic expression as | |
272 | described below. The RPN expression is evaluated, and its value is | |
273 | assigned to the variable. | |
274 | ||
275 | =back | |
276 | ||
277 | =head2 RPN expression syntax | |
278 | ||
279 | Tokens of an RPN expression may be separated by whitespace, but such | |
280 | separation is usually not required. It is required only where unseparated | |
281 | tokens would look like a longer token. For example, C<12 34 +> can be | |
282 | written as C<12 34+>, but not as C<1234 +>. | |
283 | ||
284 | An RPN expression may be any of: | |
285 | ||
286 | =over | |
287 | ||
288 | =item C<1234> | |
289 | ||
290 | A sequence of digits is an unsigned decimal literal number. | |
291 | ||
292 | =item C<$foo> | |
293 | ||
294 | An alphanumeric name preceded by dollar sign refers to a Perl scalar | |
295 | variable. Only variables declared with C<my> or C<state> are supported. | |
296 | If the variable's value is not a native integer, it will be converted | |
297 | to an integer, by Perl's usual mechanisms, at the time it is evaluated. | |
298 | ||
299 | =item I<A> I<B> C<+> | |
300 | ||
301 | Sum of I<A> and I<B>. | |
302 | ||
303 | =item I<A> I<B> C<-> | |
304 | ||
305 | Difference of I<A> and I<B>, the result of subtracting I<B> from I<A>. | |
306 | ||
307 | =item I<A> I<B> C<*> | |
308 | ||
309 | Product of I<A> and I<B>. | |
310 | ||
311 | =item I<A> I<B> C</> | |
312 | ||
313 | Quotient when I<A> is divided by I<B>, rounded towards zero. | |
314 | Division by zero generates an exception. | |
315 | ||
316 | =item I<A> I<B> C<%> | |
317 | ||
318 | Remainder when I<A> is divided by I<B> with the quotient rounded towards zero. | |
319 | Division by zero generates an exception. | |
320 | ||
321 | =back | |
322 | ||
323 | Because the arithmetic operators all have fixed arity and are postfixed, | |
324 | there is no need for operator precedence, nor for a grouping operator | |
325 | to override precedence. This is half of the point of RPN. | |
326 | ||
327 | An RPN expression can also be interpreted in another way, as a sequence | |
328 | of operations on a stack, one operation per token. A literal or variable | |
329 | token pushes a value onto the stack. A binary operator pulls two items | |
330 | off the stack, performs a calculation with them, and pushes the result | |
331 | back onto the stack. The stack starts out empty, and at the end of the | |
332 | expression there must be exactly one value left on the stack. | |
333 | ||
3e61d65a JH |
334 | =head1 SEE ALSO |
335 | ||
336 | L<XS::Typemap>, L<perlapi>. | |
337 | ||
338 | =head1 AUTHORS | |
339 | ||
340 | Tim Jenness, E<lt>t.jenness@jach.hawaii.eduE<gt>, | |
341 | Christian Soeller, E<lt>csoelle@mph.auckland.ac.nzE<gt>, | |
83f8bb56 Z |
342 | Hugo van der Sanden E<lt>hv@crypt.compulink.co.ukE<gt>, |
343 | Andrew Main (Zefram) <zefram@fysh.org> | |
3e61d65a JH |
344 | |
345 | =head1 COPYRIGHT AND LICENSE | |
346 | ||
d1f347d7 | 347 | Copyright (C) 2002,2004 Tim Jenness, Christian Soeller, Hugo van der Sanden. |
3e61d65a JH |
348 | All Rights Reserved. |
349 | ||
83f8bb56 Z |
350 | Copyright (C) 2009 Andrew Main (Zefram) <zefram@fysh.org> |
351 | ||
3e61d65a JH |
352 | This library is free software; you can redistribute it and/or modify |
353 | it under the same terms as Perl itself. | |
354 | ||
355 | =cut |