From: Nicholas Clark Date: Mon, 26 Dec 2005 16:13:57 +0000 (+0000) Subject: Add C_FH and XS_FH arguments to ExtUtils::Constant::WriteConstants, X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=16be8eabce435265b5696f46468c90933be2574a;p=p5sagit%2Fp5-mst-13.2.git 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 --- 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 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 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 --- 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;