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)\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.24';
  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