This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Remove unneeded 'use' from ext/XS-APItest/t/peep.t Devel::Peek is not used by ext...
[perl5.git] / ext / XS-APItest / APItest.pm
1 package XS::APItest;
2
3 use 5.008;
4 use strict;
5 use warnings;
6 use Carp;
7
8 use base 'DynaLoader';
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     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 }
47
48 our $VERSION = '0.22';
49
50 use vars '$WARNINGS_ON_BOOTSTRAP';
51 use vars map "\$${_}_called_PP", qw(BEGIN UNITCHECK CHECK INIT END);
52
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
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++;
68 };
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
84 if ($WARNINGS_ON_BOOTSTRAP) {
85     bootstrap XS::APItest $VERSION;
86 } else {
87     # More CHECK and INIT blocks that could warn:
88     local $^W;
89     bootstrap XS::APItest $VERSION;
90 }
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
106 This module tests the perl C API. Also exposes various bit of the perl
107 internals for the use of core test scripts.
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
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
215 Evaluates the passed SV. Result handling is done the same as for
216 C<call_sv()> etc.
217
218 =item B<eval_pv>
219
220 Exercises the C function of the same name in scalar context. Returns the
221 same SV that the C function returns.
222
223 =item B<require_pv>
224
225 Exercises the C function of the same name. Returns nothing.
226
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
241 Copyright (C) 2002,2004 Tim Jenness, Christian Soeller, Hugo van der Sanden.
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