test cv_[gs]et_call_checker_flags()
[perl.git] / ext / XS-APItest / APItest.pm
1 package XS::APItest;
2
3 { use 5.011001; } # 5.11 is a long long time ago... What gives with this?
4 use strict;
5 use warnings;
6 use Carp;
7
8 our $VERSION = '0.91';
9
10 require XSLoader;
11
12 # Export everything since these functions are only used by a test script
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'};
29                 # and any that have AUTOLOAD
30                 next if *{$glob}{HASH}{AUTOLOAD};
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     }
42     foreach (keys %{$exports||{}}) {
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/;
44         $^H{"XS::APItest/$_"} = 1;
45         delete $exports->{$_};
46     }
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 }
56
57 use vars '$WARNINGS_ON_BOOTSTRAP';
58 use vars map "\$${_}_called_PP", qw(BEGIN UNITCHECK CHECK INIT END);
59
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
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++;
75 };
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
91 if ($WARNINGS_ON_BOOTSTRAP) {
92     XSLoader::load();
93 } else {
94     # More CHECK and INIT blocks that could warn:
95     local $^W;
96     XSLoader::load();
97 }
98
99 # This XS function needs the lvalue attr applied.
100 eval 'use attributes __PACKAGE__, \\&lv_temp_object, "lvalue"; 1' or die;
101
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
114   use XS::APItest qw(rpn calcrpn);
115   $triangle = rpn($n $n 1 + * 2 /);
116   calcrpn $triangle { $n $n 1 + * 2 / }
117
118 =head1 ABSTRACT
119
120 This module tests the perl C API. Also exposes various bit of the perl
121 internals for the use of core test scripts.
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
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
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
225 arg is passed as the args to the called function. They return whatever
226 the C function itself pushed onto the stack, plus the return value from
227 the function; for example
228
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
233
234 =item B<eval_sv>
235
236 Evaluates the passed SV. Result handling is done the same as for
237 C<call_sv()> etc.
238
239 =item B<eval_pv>
240
241 Exercises the C function of the same name in scalar context. Returns the
242 same SV that the C function returns.
243
244 =item B<require_pv>
245
246 Exercises the C function of the same name. Returns nothing.
247
248 =back
249
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
257 =item DEFSV
258
259 Behaves like C<$_>.
260
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
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>,
342 Hugo van der Sanden E<lt>hv@crypt.compulink.co.ukE<gt>,
343 Andrew Main (Zefram) <zefram@fysh.org>
344
345 =head1 COPYRIGHT AND LICENSE
346
347 Copyright (C) 2002,2004 Tim Jenness, Christian Soeller, Hugo van der Sanden.
348 All Rights Reserved.
349
350 Copyright (C) 2009 Andrew Main (Zefram) <zefram@fysh.org>
351
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