1package XS::APItest; 2 3{ use 5.011001; } # 5.11 is a long long time ago... What gives with this? 4use strict; 5use warnings; 6use Carp; 7 8our $VERSION = '1.00'; 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|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 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 DEFSV 258 259Behaves like C<$_>. 260 261=item rpn(EXPRESSION) 262 263This construct is a Perl expression. I<EXPRESSION> must be an RPN 264arithmetic expression, as described below. The RPN expression is 265evaluated, and its value is returned as the value of the Perl expression. 266 267=item calcrpn VARIABLE { EXPRESSION } 268 269This construct is a complete Perl statement. (No semicolon should 270follow the closing brace.) I<VARIABLE> must be a Perl scalar C<my> 271variable, and I<EXPRESSION> must be an RPN arithmetic expression as 272described below. The RPN expression is evaluated, and its value is 273assigned to the variable. 274 275=back 276 277=head2 RPN expression syntax 278 279Tokens of an RPN expression may be separated by whitespace, but such 280separation is usually not required. It is required only where unseparated 281tokens would look like a longer token. For example, C<12 34 +> can be 282written as C<12 34+>, but not as C<1234 +>. 283 284An RPN expression may be any of: 285 286=over 287 288=item C<1234> 289 290A sequence of digits is an unsigned decimal literal number. 291 292=item C<$foo> 293 294An alphanumeric name preceded by dollar sign refers to a Perl scalar 295variable. Only variables declared with C<my> or C<state> are supported. 296If the variable's value is not a native integer, it will be converted 297to an integer, by Perl's usual mechanisms, at the time it is evaluated. 298 299=item I<A> I<B> C<+> 300 301Sum of I<A> and I<B>. 302 303=item I<A> I<B> C<-> 304 305Difference of I<A> and I<B>, the result of subtracting I<B> from I<A>. 306 307=item I<A> I<B> C<*> 308 309Product of I<A> and I<B>. 310 311=item I<A> I<B> C</> 312 313Quotient when I<A> is divided by I<B>, rounded towards zero. 314Division by zero generates an exception. 315 316=item I<A> I<B> C<%> 317 318Remainder when I<A> is divided by I<B> with the quotient rounded towards zero. 319Division by zero generates an exception. 320 321=back 322 323Because the arithmetic operators all have fixed arity and are postfixed, 324there is no need for operator precedence, nor for a grouping operator 325to override precedence. This is half of the point of RPN. 326 327An RPN expression can also be interpreted in another way, as a sequence 328of operations on a stack, one operation per token. A literal or variable 329token pushes a value onto the stack. A binary operator pulls two items 330off the stack, performs a calculation with them, and pushes the result 331back onto the stack. The stack starts out empty, and at the end of the 332expression there must be exactly one value left on the stack. 333 334=head1 SEE ALSO 335 336L<XS::Typemap>, L<perlapi>. 337 338=head1 AUTHORS 339 340Tim Jenness, E<lt>t.jenness@jach.hawaii.eduE<gt>, 341Christian Soeller, E<lt>csoelle@mph.auckland.ac.nzE<gt>, 342Hugo van der Sanden E<lt>hv@crypt.compulink.co.ukE<gt>, 343Andrew Main (Zefram) <zefram@fysh.org> 344 345=head1 COPYRIGHT AND LICENSE 346 347Copyright (C) 2002,2004 Tim Jenness, Christian Soeller, Hugo van der Sanden. 348All Rights Reserved. 349 350Copyright (C) 2009 Andrew Main (Zefram) <zefram@fysh.org> 351 352This library is free software; you can redistribute it and/or modify 353it under the same terms as Perl itself. 354 355=cut 356