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