Add C_FH and XS_FH arguments to ExtUtils::Constant::WriteConstants,

to allow the caller to pass in file handles. Use this in Contant.t
with tied file handles to capture the output, rather than calling
the lower level routines directly.

p4raw-id: //depot/perl@26490

diff --git a/lib/ExtUtils/Constant.pm b/lib/ExtUtils/Constant.pm
index cd04063..46021b0 100644 (file)
--- a/lib/ExtUtils/Constant.pm
+++ b/lib/ExtUtils/Constant.pm
@@ -432,6 +432,11 @@ for each group with this number or more names in.
 An array of constants' names, either scalars containing names, or hashrefs
 as detailed in L<"C_constant">.
 
+=item C_FH
+
+A filehandle to write the C code to.  If not given, then I<C_FILE> is opened
+for writing.
+
 =item C_FILE
 
 The name of the file to write containing the C code.  The default is
@@ -440,6 +445,11 @@ mistaken for anything related to a legitimate perl package name, and
 not naming the file C<.c> avoids having to override Makefile.PL's
 C<.xs> to C<.c> rules.
 
+=item XS_FH
+
+A filehandle to write the XS code to.  If not given, then I<XS_FILE> is opened
+for writing.
+
 =item XS_FILE
 
 The name of the file to write containing the XS code.  The default is
@@ -474,18 +484,28 @@ sub WriteConstants {
 
   croak "Module name not specified" unless length $ARGS{NAME};
 
-  my ($c_fh, $xs_fh);
-  if ($] <= 5.008) {
-      # We need these little games, rather than doing things unconditionally,
-      # because we're used in core Makefile.PLs before IO is available (needed
-      # by filehandle), but also we want to work on older perls where undefined
-      # scalars do not automatically turn into anonymous file handles.
-      require FileHandle;
-      $c_fh = FileHandle->new();
-      $xs_fh = FileHandle->new();
+  my $c_fh = $ARGS{C_FH};
+  if (!$c_fh) {
+      if ($] <= 5.008) {
+         # We need these little games, rather than doing things
+         # unconditionally, because we're used in core Makefile.PLs before
+         # IO is available (needed by filehandle), but also we want to work on
+         # older perls where undefined scalars do not automatically turn into
+         # anonymous file handles.
+         require FileHandle;
+         $c_fh = FileHandle->new();
+      }
+      open $c_fh, ">$ARGS{C_FILE}" or die "Can't open $ARGS{C_FILE}: $!";
+  }
+
+  my $xs_fh = $ARGS{XS_FH};
+  if (!$xs_fh) {
+      if ($] <= 5.008) {
+         require FileHandle;
+         $xs_fh = FileHandle->new();
+      }
+      open $xs_fh, ">$ARGS{XS_FILE}" or die "Can't open $ARGS{XS_FILE}: $!";
   }
-  open $c_fh, ">$ARGS{C_FILE}" or die "Can't open $ARGS{C_FILE}: $!";
-  open $xs_fh, ">$ARGS{XS_FILE}" or die "Can't open $ARGS{XS_FILE}: $!";
 
   # As this subroutine is intended to make code that isn't edited, there's no
   # need for the user to specify any types that aren't found in the list of
@@ -525,8 +545,8 @@ sub WriteConstants {
                                $ARGS{C_SUBNAME});
   }
 
-  close $c_fh or warn "Error closing $ARGS{C_FILE}: $!";
-  close $xs_fh or warn "Error closing $ARGS{XS_FILE}: $!";
+  close $c_fh or warn "Error closing $ARGS{C_FILE}: $!" unless $ARGS{C_FH};
+  close $xs_fh or warn "Error closing $ARGS{XS_FILE}: $!" unless $ARGS{XS_FH};
 }
 
 1;

diff --git a/lib/ExtUtils/t/Constant.t b/lib/ExtUtils/t/Constant.t
index f440da4..d80a186 100644 (file)
--- a/lib/ExtUtils/t/Constant.t
+++ b/lib/ExtUtils/t/Constant.t
@@ -85,6 +85,30 @@ END {
 chdir $dir or die $!;
 push @INC, '../../lib', '../../../lib';
 
+package TieOut;
+
+sub TIEHANDLE {
+    my $class = shift;
+    bless(\( my $ref = ''), $class);
+}
+
+sub PRINT {
+    my $self = shift;
+    $$self .= join('', @_);
+}
+
+sub PRINTF {
+    my $self = shift;
+    $$self .= sprintf shift, @_;
+}
+
+sub read {
+    my $self = shift;
+    return substr($$self, 0, length($$self), '');
+}
+
+package main;
+
 sub check_for_bonus_files {
   my $dir = shift;
   my %expect = map {($^O eq 'VMS' ? lc($_) : $_), 1} @_;
@@ -322,14 +346,26 @@ sub MANIFEST {
 sub write_and_run_extension {
   my ($name, $items, $export_names, $package, $header, $testfile, $num_tests)
     = @_;
-  my $types = {};
-  my $constant_types = constant_types(); # macro defs
-  my $C_constant = join "\n",
-    C_constant ($package, undef, "IV", $types, undef, undef, @$items);
-  my $XS_constant = XS_constant ($package, $types); # XS for ExtTest::constant
 
-  my $expect = $constant_types . $C_constant .
-    "\n#### XS Section:\n" . $XS_constant;
+  my $c = tie *C, 'TieOut';
+  my $xs = tie *XS, 'TieOut';
+
+  ExtUtils::Constant::WriteConstants(C_FH => \*C, 
+                                    XS_FH => \*XS,
+                                    NAME => $package,
+                                    NAMES => $items,
+                                    );
+
+  my $C_code = $c->read();
+  my $XS_code = $xs->read();
+
+  undef $c;
+  undef $xs;
+
+  untie *C;
+  untie *XS;
+
+  my $expect = $C_code . "\n#### XS Section:\n" . $XS_code;
 
   print "# $name\n# $dir/$subdir being created...\n";
   mkdir $subdir, 0777 or die "mkdir: $!\n";
@@ -345,23 +381,23 @@ sub write_and_run_extension {
   close FH or die "close $header_name: $!\n";
 
   ################ XS
-  my $xs = "$package.xs";
-  push @files, $xs;
-  open FH, ">$xs" or die "open >$xs: $!\n";
+  my $xs_name = "$package.xs";
+  push @files, $xs_name;
+  open FH, ">$xs_name" or die "open >$xs_name: $!\n";
 
-  print FH <<'EOT';
+  print FH <<"EOT";
 #include "EXTERN.h"
 #include "perl.h"
 #include "XSUB.h"
+#include "$header_name"
+
+
+$C_code
+MODULE = $package              PACKAGE = $package
+PROTOTYPES: ENABLE
+$XS_code;
 EOT
 
-  # XXX Here doc these:
-  print FH "#include \"$header_name\"\n\n";
-  print FH $constant_types;
-  print FH $C_constant, "\n";
-  print FH "MODULE = $package          PACKAGE = $package\n";
-  print FH "PROTOTYPES: ENABLE\n";
-  print FH $XS_constant;
   close FH or die "close $xs: $!\n";
 
   ################ PM
@@ -435,6 +471,7 @@ EOT
   chdir $updir or die "chdir '$updir': $!";
   ++$subdir;
 }
+
 # Tests are arrayrefs of the form
 # $name, [items], [export_names], $package, $header, $testfile, $num_tests
 my @tests;