ext/XS-APItest/APItest.pm

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