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