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