| 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.91'; |
| 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 |