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.46';
   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 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'); # returns 'a', 'b', 'c', 3
 230     call_sv( sub { @_ },      G_SCALAR, 'a', 'b'); # returns 'b', 1
 231
 232 =item B<eval_sv>
 233
 234 Evaluates the passed SV. Result handling is done the same as for
 235 C<call_sv()> etc.
 236
 237 =item B<eval_pv>
 238
 239 Exercises the C function of the same name in scalar context. Returns the
 240 same SV that the C function returns.
 241
 242 =item B<require_pv>
 243
 244 Exercises the C function of the same name. Returns nothing.
 245
 246 =back
 247
 248 =head1 KEYWORDS
 249
 250 These are not supplied by default, but must be explicitly imported.
 251 They are lexically scoped.
 252
 253 =over
 254
 255 =item rpn(EXPRESSION)
 256
 257 This construct is a Perl expression.  I<EXPRESSION> must be an RPN
 258 arithmetic expression, as described below.  The RPN expression is
 259 evaluated, and its value is returned as the value of the Perl expression.
 260
 261 =item calcrpn VARIABLE { EXPRESSION }
 262
 263 This construct is a complete Perl statement.  (No semicolon should
 264 follow the closing brace.)  I<VARIABLE> must be a Perl scalar C<my>
 265 variable, and I<EXPRESSION> must be an RPN arithmetic expression as
 266 described below.  The RPN expression is evaluated, and its value is
 267 assigned to the variable.
 268
 269 =back
 270
 271 =head2 RPN expression syntax
 272
 273 Tokens of an RPN expression may be separated by whitespace, but such
 274 separation is usually not required.  It is required only where unseparated
 275 tokens would look like a longer token.  For example, C<12 34 +> can be
 276 written as C<12 34+>, but not as C<1234 +>.
 277
 278 An RPN expression may be any of:
 279
 280 =over
 281
 282 =item C<1234>
 283
 284 A sequence of digits is an unsigned decimal literal number.
 285
 286 =item C<$foo>
 287
 288 An alphanumeric name preceded by dollar sign refers to a Perl scalar
 289 variable.  Only variables declared with C<my> or C<state> are supported.
 290 If the variable's value is not a native integer, it will be converted
 291 to an integer, by Perl's usual mechanisms, at the time it is evaluated.
 292
 293 =item I<A> I<B> C<+>
 294
 295 Sum of I<A> and I<B>.
 296
 297 =item I<A> I<B> C<->
 298
 299 Difference of I<A> and I<B>, the result of subtracting I<B> from I<A>.
 300
 301 =item I<A> I<B> C<*>
 302
 303 Product of I<A> and I<B>.
 304
 305 =item I<A> I<B> C</>
 306
 307 Quotient when I<A> is divided by I<B>, rounded towards zero.
 308 Division by zero generates an exception.
 309
 310 =item I<A> I<B> C<%>
 311
 312 Remainder when I<A> is divided by I<B> with the quotient rounded towards zero.
 313 Division by zero generates an exception.
 314
 315 =back
 316
 317 Because the arithmetic operators all have fixed arity and are postfixed,
 318 there is no need for operator precedence, nor for a grouping operator
 319 to override precedence.  This is half of the point of RPN.
 320
 321 An RPN expression can also be interpreted in another way, as a sequence
 322 of operations on a stack, one operation per token.  A literal or variable
 323 token pushes a value onto the stack.  A binary operator pulls two items
 324 off the stack, performs a calculation with them, and pushes the result
 325 back onto the stack.  The stack starts out empty, and at the end of the
 326 expression there must be exactly one value left on the stack.
 327
 328 =head1 SEE ALSO
 329
 330 L<XS::Typemap>, L<perlapi>.
 331
 332 =head1 AUTHORS
 333
 334 Tim Jenness, E<lt>t.jenness@jach.hawaii.eduE<gt>,
 335 Christian Soeller, E<lt>csoelle@mph.auckland.ac.nzE<gt>,
 336 Hugo van der Sanden E<lt>hv@crypt.compulink.co.ukE<gt>,
 337 Andrew Main (Zefram) <zefram@fysh.org>
 338
 339 =head1 COPYRIGHT AND LICENSE
 340
 341 Copyright (C) 2002,2004 Tim Jenness, Christian Soeller, Hugo van der Sanden.
 342 All Rights Reserved.
 343
 344 Copyright (C) 2009 Andrew Main (Zefram) <zefram@fysh.org>
 345
 346 This library is free software; you can redistribute it and/or modify
 347 it under the same terms as Perl itself.
 348
 349 =cut