Add XS::APItest 0.01 from Tim Jenness.

The perl.h change is needed by non-gcc (non-__attribute__)
compilers: without it non-gccs won't have printf() mapped
to PerlIO_stdoutf (when perlio, of course).  This means that
non-gccs would not be able to print the Perl specific datatypes.

p4raw-id: //depot/perl@17176

8 files changed, 349 insertions, 2 deletions

diff --git a/MANIFEST b/MANIFEST
index bead6e1389..59ec4a4dbf 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -714,6 +714,12 @@ ext/Unicode/Normalize/t/func.t	Unicode::Normalize
 ext/Unicode/Normalize/t/norm.t	Unicode::Normalize
 ext/Unicode/Normalize/t/test.t	Unicode::Normalize
 ext/util/make_ext		Used by Makefile to execute extension Makefiles
+ext/XS/APItest/APItest.pm	XS::APItest extension
+ext/XS/APItest/APItest.xs	XS::APItest extension
+ext/XS/APItest/MANIFEST		XS::APItest extension
+ext/XS/APItest/Makefile.PL	XS::APItest extension
+ext/XS/APItest/README		XS::APItest extension
+ext/XS/APItest/t/printf.t	XS::APItest extension
 ext/XS/Typemap/Makefile.PL	XS::Typemap extension
 ext/XS/Typemap/README		XS::Typemap extension
 ext/XS/Typemap/stdio.c		XS::Typemap extension
diff --git a/ext/XS/APItest/APItest.pm b/ext/XS/APItest/APItest.pm
new file mode 100644
index 0000000000..2a01152437
--- /dev/null
+++ b/ext/XS/APItest/APItest.pm
@@ -0,0 +1,155 @@
+package XS::APItest;
+
+use 5.008;
+use strict;
+use warnings;
+use Carp;
+
+use base qw/ DynaLoader Exporter /;
+
+# Items to export into callers namespace by default. Note: do not export
+# names by default without a very good reason. Use EXPORT_OK instead.
+# Do not simply export all your public functions/methods/constants.
+
+# Export everything since these functions are only used by a test script
+our @EXPORT = qw( print_double print_nv print_iv print_int
+		  print_float print_long_double have_long_double
+		  print_uv print_long
+);
+
+our $VERSION = '0.01';
+
+bootstrap XS::APItest $VERSION;
+
+1;
+__END__
+
+=head1 NAME
+
+XS::APItest - Test the perl C API
+
+=head1 SYNOPSIS
+
+  use XS::APItest;
+  print_double(4);
+
+=head1 ABSTRACT
+
+This module tests the perl C API. Currently tests that C<printf>
+works correctly.
+
+=head1 DESCRIPTION
+
+This module can be used to check that the perl C API is behaving
+correctly. This module provides test functions and an associated
+test script that verifies the output.
+
+This module is not meant to be installed.
+
+=head2 EXPORT
+
+Exports all the test functions:
+
+=over 4
+
+=item B<print_double>
+
+Test that a double-precision floating point number is formatted
+correctly by C<printf>.
+
+  print_double( $val );
+
+Output is sent to STDOUT.
+
+=item B<print_long_double>
+
+Test that a C<long double> is formatted correctly by
+C<printf>. Takes no arguments - the test value is hard-wired
+into the function (as "7").
+
+  print_long_double();
+
+Output is sent to STDOUT.
+
+=item B<have_long_double>
+
+Determine whether a C<long double> is supported by Perl.  This should
+be used to determine whether to test C<print_long_double>.
+
+  print_long_double() if have_long_double;
+
+=item B<print_nv>
+
+Test that an C<NV> is formatted correctly by
+C<printf>.
+
+  print_nv( $val );
+
+Output is sent to STDOUT.
+
+=item B<print_iv>
+
+Test that an C<IV> is formatted correctly by
+C<printf>.
+
+  print_iv( $val );
+
+Output is sent to STDOUT.
+
+=item B<print_uv>
+
+Test that an C<UV> is formatted correctly by
+C<printf>.
+
+  print_uv( $val );
+
+Output is sent to STDOUT.
+
+=item B<print_int>
+
+Test that an C<int> is formatted correctly by
+C<printf>.
+
+  print_int( $val );
+
+Output is sent to STDOUT.
+
+=item B<print_long>
+
+Test that an C<long> is formatted correctly by
+C<printf>.
+
+  print_long( $val );
+
+Output is sent to STDOUT.
+
+=item B<print_float>
+
+Test that a single-precision floating point number is formatted
+correctly by C<printf>.
+
+  print_float( $val );
+
+Output is sent to STDOUT.
+
+=back
+
+=head1 SEE ALSO
+
+L<XS::Typemap>, L<perlapi>.
+
+=head1 AUTHORS
+
+Tim Jenness, E<lt>t.jenness@jach.hawaii.eduE<gt>,
+Christian Soeller, E<lt>csoelle@mph.auckland.ac.nzE<gt>,
+Hugo van der Sanden E<lt>hv@crypt.compulink.co.ukE<gt>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright (C) 2002 Tim Jenness, Christian Soeller, Hugo van der Sanden.
+All Rights Reserved.
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself. 
+
+=cut
diff --git a/ext/XS/APItest/APItest.xs b/ext/XS/APItest/APItest.xs
new file mode 100644
index 0000000000..a24e7fb982
--- /dev/null
+++ b/ext/XS/APItest/APItest.xs
@@ -0,0 +1,71 @@
+#include "EXTERN.h"
+#include "perl.h"
+#include "XSUB.h"
+
+MODULE = XS::APItest		PACKAGE = XS::APItest
+
+PROTOTYPES: DISABLE
+
+void
+print_double(val)
+        double val
+        CODE:
+        printf("%5.3f\n",val);
+
+int
+have_long_double()
+        CODE:
+#ifdef HAS_LONG_DOUBLE
+        RETVAL = 1;
+#else
+        RETVAL = 0;
+#endif
+
+void
+print_long_double()
+        CODE:
+#ifdef HAS_LONG_DOUBLE
+#   if LONG_DOUBLESIZE > DOUBLESIZE
+        long double val = 7.0;
+        printf("%5.3" PERL_PRIfldbl "\n",val);
+#   else
+        double val = 7.0;
+        printf("%5.3f\n",val);
+#   endif
+#endif
+
+void
+print_nv(val)
+        NV val
+        CODE:
+        printf("%5.3Vf\n",val);
+
+void
+print_iv(val)
+        IV val
+        CODE:
+        printf("%Vd\n",val);
+
+void
+print_uv(val)
+        UV val
+        CODE:
+        printf("%Vu\n",val);
+
+void
+print_int(val)
+        int val
+        CODE:
+        printf("%d\n",val);
+
+void
+print_long(val)
+        long val
+        CODE:
+        printf("%ld\n",val);
+
+void
+print_float(val)
+        float val
+        CODE:
+        printf("%5.3f\n",val);
diff --git a/ext/XS/APItest/MANIFEST b/ext/XS/APItest/MANIFEST
new file mode 100644
index 0000000000..7a7e094edc
--- /dev/null
+++ b/ext/XS/APItest/MANIFEST
@@ -0,0 +1,6 @@
+Makefile.PL
+MANIFEST
+README
+APItest.pm
+APItest.xs
+t/printf.t
diff --git a/ext/XS/APItest/Makefile.PL b/ext/XS/APItest/Makefile.PL
new file mode 100644
index 0000000000..6e6cb496ff
--- /dev/null
+++ b/ext/XS/APItest/Makefile.PL
@@ -0,0 +1,19 @@
+use 5.008;
+use ExtUtils::MakeMaker;
+# See lib/ExtUtils/MakeMaker.pm for details of how to influence
+# the contents of the Makefile that is written.
+WriteMakefile(
+    'NAME'		=> 'XS::APItest',
+    'VERSION_FROM'	=> 'APItest.pm', # finds $VERSION
+    'PREREQ_PM'		=> {}, # e.g., Module::Name => 1.1
+    ($] >= 5.005 ?    ## Add these new keywords supported since 5.005
+      (ABSTRACT_FROM => 'APItest.pm', # retrieve abstract from module
+       AUTHOR     => 'Tim Jenness <t.jenness@jach.hawaii.edu>, Christian Soeller <csoelle@mph.auckland.ac.nz>, Hugo van der Sanden <hv@crypt.compulink.co.uk>') : ()),
+    'LIBS'		=> [''], # e.g., '-lm'
+    'DEFINE'		=> '', # e.g., '-DHAVE_SOMETHING'
+    'INC'		=> '-I.', # e.g., '-I. -I/usr/include/other'
+	# Un-comment this if you add C files to link with later:
+    # 'OBJECT'		=> '$(O_FILES)', # link all the C files too
+);
+
+sub MY::install { "install ::\n"  };
diff --git a/ext/XS/APItest/README b/ext/XS/APItest/README
new file mode 100644
index 0000000000..dbfc91a1d7
--- /dev/null
+++ b/ext/XS/APItest/README
@@ -0,0 +1,29 @@
+XS::APItest version 0.01
+========================
+
+This module is used to test that the Perl C API is working correctly.
+It is not meant to be installed.
+
+Currently tests that printf formatting works correctly.
+
+INSTALLATION
+
+To install this module type the following:
+
+   perl Makefile.PL
+   make
+   make test
+   make install
+
+DEPENDENCIES
+
+None.
+
+COPYRIGHT AND LICENCE
+
+Copyright (C) 2002 Tim Jenness, Christian Soeller and Hugo van der Sanden.
+All Rights Reserved.
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself. 
+
diff --git a/ext/XS/APItest/t/printf.t b/ext/XS/APItest/t/printf.t
new file mode 100644
index 0000000000..c44c8ab9ac
--- /dev/null
+++ b/ext/XS/APItest/t/printf.t
@@ -0,0 +1,62 @@
+BEGIN {
+    chdir 't' if -d 't';
+    @INC = '../lib';
+    require Config; import Config;
+    if ($Config{'extensions'} !~ /\bXS\/APItest\b/) {
+        print "1..0 # Skip: XS::APItest was not built\n";
+        exit 0;
+    }
+}
+
+use Test::More tests => 15;
+
+BEGIN { use_ok('XS::APItest') };
+
+#########################
+
+my $ldok = have_long_double();
+
+# first some IO redirection
+ok open(my $oldout, ">&STDOUT"), "saving STDOUT";
+ok open(STDOUT, '>', "foo.out"),"redirecting STDOUT";
+
+# Allow for it to be removed
+END { unlink "foo.out"; };
+
+select STDOUT; $| = 1; # make unbuffered
+
+# Run the printf tests
+print_double(5);
+print_nv(6);
+print_int(3);
+print_iv(2);
+print_iv(-2);
+print_uv(3);
+print_long(4);
+print_float(4);
+print_long_double() if $ldok;  # val=7 hardwired
+
+# Now redirect STDOUT and read from the file
+ok open(STDOUT, ">&", $oldout), "restore STDOUT";
+ok open(my $foo, "<foo.out"), "open foo.out";
+print "# Test output by reading from file\n";
+# now test the output
+my @output = map { chomp; $_ } <$foo>;
+close $foo;
+ok @output >= 9, "captured at least nine output lines";
+
+is($output[0], "5.000", "print_double");
+is($output[1], "6.000", "print_nv");
+is($output[2], "3", "print_int");
+is($output[3], "2", "print_iv positive");
+is($output[4], "-2", "print_iv negative");
+is($output[5], "3", "print_uv");
+is($output[6], "4", "print_long");
+is($output[7], "4.000", "print_float");
+
+SKIP: {
+   skip "No long doubles", 1 unless $ldok;
+   is($output[8], "7.000", "print_long_double");
+}
+
+
diff --git a/perl.h b/perl.h
index 0403345719..d7b281a7cb 100644
--- a/perl.h
+++ b/perl.h
@@ -3828,9 +3828,8 @@ typedef struct am_table_short AMTS;
 #   define Atoul(s)	Strtoul(s, (char **)NULL, 10)
 #endif
 
-#if !defined(PERLIO_IS_STDIO) && defined(HASATTRIBUTE)
+#if !defined(PERLIO_IS_STDIO)
 /*
- * Now we have __attribute__ out of the way
  * Remap printf
  */
 #undef printf