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