[perl5.git] / lib / ExtUtils / CBuilder / Platform / Windows.pm

package ExtUtils::CBuilder::Platform::Windows;

use strict;
use warnings;

use File::Basename;
use File::Spec;

use ExtUtils::CBuilder::Base;

use vars qw($VERSION @ISA);
$VERSION = '0.01';
@ISA = qw(ExtUtils::CBuilder::Base);

sub new {
  my $class = shift;
  my $self = $class->SUPER::new(@_);
  my $cf = $self->{config};

  # Inherit from an appropriate compiler driver class
  unshift @ISA, "ExtUtils::CBuilder::Platform::Windows::" . $self->_compiler_type;

  return $self;
}

sub _compiler_type {
  my $self = shift;
  my $cc = $self->{config}{cc};

  return (  $cc =~ /cl(\.exe)?$/ ? 'MSVC'
	  : $cc =~ /bcc32(\.exe)?$/ ? 'BCC'
	  : 'GCC');
}

sub split_like_shell {
  # As it turns out, Windows command-parsing is very different from
  # Unix command-parsing.  Double-quotes mean different things,
  # backslashes don't necessarily mean escapes, and so on.  So we
  # can't use Text::ParseWords::shellwords() to break a command string
  # into words.  The algorithm below was bashed out by Randy and Ken
  # (mostly Randy), and there are a lot of regression tests, so we
  # should feel free to adjust if desired.
  
  (my $self, local $_) = @_;
  
  return @$_ if defined() && UNIVERSAL::isa($_, 'ARRAY');
  
  my @argv;
  return @argv unless defined() && length();
  
  my $arg = '';
  my( $i, $quote_mode ) = ( 0, 0 );
  
  while ( $i < length() ) {
    
    my $ch      = substr( $_, $i  , 1 );
    my $next_ch = substr( $_, $i+1, 1 );
    
    if ( $ch eq '\\' && $next_ch eq '"' ) {
      $arg .= '"';
      $i++;
    } elsif ( $ch eq '\\' && $next_ch eq '\\' ) {
      $arg .= '\\';
      $i++;
    } elsif ( $ch eq '"' && $next_ch eq '"' && $quote_mode ) {
      $quote_mode = !$quote_mode;
      $arg .= '"';
      $i++;
    } elsif ( $ch eq '"' && $next_ch eq '"' && !$quote_mode &&
	      ( $i + 2 == length()  ||
		substr( $_, $i + 2, 1 ) eq ' ' )
	    ) { # for cases like: a"" => [ 'a' ]
      push( @argv, $arg );
      $arg = '';
      $i += 2;
    } elsif ( $ch eq '"' ) {
      $quote_mode = !$quote_mode;
    } elsif ( $ch eq ' ' && !$quote_mode ) {
      push( @argv, $arg ) if $arg;
      $arg = '';
      ++$i while substr( $_, $i + 1, 1 ) eq ' ';
    } else {
      $arg .= $ch;
    }
    
    $i++;
  }
  
  push( @argv, $arg ) if defined( $arg ) && length( $arg );
  return @argv;
}

sub compile {
  my ($self, %args) = @_;
  my $cf = $self->{config};

  die "Missing 'source' argument to compile()" unless defined $args{source};

  my ($basename, $srcdir) =
    ( File::Basename::fileparse($args{source}, '\.[^.]+$') )[0,1];

  $srcdir ||= File::Spec->curdir();

  my %spec = (
    srcdir      => $srcdir,
    builddir    => $srcdir,
    basename    => $basename,
    source      => $args{source},
    output      => File::Spec->catfile($srcdir, $basename) . $cf->{obj_ext},
    cc          => $cf->{cc},
    cflags      => [
                     $self->split_like_shell($cf->{ccflags}),
                     $self->split_like_shell($cf->{cccdlflags}),
                   ],
    optimize    => [ $self->split_like_shell($cf->{optimize})    ],
    defines     => [ '' ],
    includes    => [ @{$args{include_dirs} || []} ],
    perlinc     => [
                     $self->perl_inc(),
                     $self->split_like_shell($cf->{incpath}),
                   ],
    use_scripts => 1, # XXX provide user option to change this???
  );

  $self->add_to_cleanup($spec{output});

  $self->normalize_filespecs(
    \$spec{source},
    \$spec{output},
     $spec{includes},
     $spec{perlinc},
  );

  my @cmds = $self->format_compiler_cmd(%spec);
  while ( my $cmd = shift @cmds ) {
    $self->do_system( @$cmd )
      or die "error building $cf->{dlext} file from '$args{source}'";
  }

  (my $out = $spec{output}) =~ tr/'"//d;
  return $out;
}

sub need_prelink { 1 }

sub link {
  my ($self, %args) = @_;
  my $cf = $self->{config};

  my @objects = ( ref $args{objects} eq 'ARRAY' ? @{$args{objects}} : $args{objects} );
  my $to = join '', (File::Spec->splitpath($objects[0]))[0,1];
  $to ||= File::Spec->curdir();

  (my $file_base = $args{module_name}) =~ s/.*:://;
  my $output = $args{lib_file} ||
    File::Spec->catfile($to, "$file_base.$cf->{dlext}");

  # if running in perl source tree, look for libs there, not installed
  my $lddlflags = $cf->{lddlflags};
  my $perl_src = $self->perl_src();
  $lddlflags =~ s/\Q$cf->{archlibexp}\E\\CORE/$perl_src/ if $perl_src;

  my %spec = (
    srcdir        => $to,
    builddir      => $to,
    startup       => [ ],
    objects       => \@objects,
    libs          => [ ],
    output        => $output,
    ld            => $cf->{ld},
    libperl       => $cf->{libperl},
    perllibs      => [ $self->split_like_shell($cf->{perllibs})  ],
    libpath       => [ $self->split_like_shell($cf->{libpth})    ],
    lddlflags     => [ $self->split_like_shell($lddlflags) ],
    other_ldflags => [ $self->split_like_shell($args{extra_linker_flags} || '') ],
    use_scripts   => 1, # XXX provide user option to change this???
  );

  unless ( $spec{basename} ) {
    ($spec{basename} = $args{module_name}) =~ s/.*:://;
  }

  $spec{srcdir}   = File::Spec->canonpath( $spec{srcdir}   );
  $spec{builddir} = File::Spec->canonpath( $spec{builddir} );

  $spec{output}    ||= File::Spec->catfile( $spec{builddir},
                                            $spec{basename}  . '.'.$cf->{dlext}   );
  $spec{implib}    ||= File::Spec->catfile( $spec{builddir},
                                            $spec{basename}  . $cf->{lib_ext} );
  $spec{explib}    ||= File::Spec->catfile( $spec{builddir},
                                            $spec{basename}  . '.exp'  );
  $spec{def_file}  ||= File::Spec->catfile( $spec{srcdir}  ,
                                            $spec{basename}  . '.def'  );
  $spec{base_file} ||= File::Spec->catfile( $spec{srcdir}  ,
                                            $spec{basename}  . '.base' );

  $self->add_to_cleanup(
    grep defined,
    @{[ @spec{qw(output implib explib def_file base_file map_file)} ]}
  );

  foreach my $opt ( qw(output implib explib def_file map_file base_file) ) {
    $self->normalize_filespecs( \$spec{$opt} );
  }

  foreach my $opt ( qw(libpath startup objects) ) {
    $self->normalize_filespecs( $spec{$opt} );
  }

  (my $def_base = $spec{def_file}) =~ tr/'"//d;
  $def_base =~ s/\.def$//;
  $self->prelink( dl_name => $args{module_name},
                  dl_file => $def_base,
                  dl_base => $spec{basename} );

  my @cmds = $self->format_linker_cmd(%spec);
  while ( my $cmd = shift @cmds ) {
    $self->do_system( @$cmd );
  }

  $spec{output} =~ tr/'"//d;
  return wantarray
    ? grep defined, @spec{qw[output implib explib def_file map_file base_file]}
    : $spec{output};
}

# canonize & quote paths
sub normalize_filespecs {
  my ($self, @specs) = @_;
  foreach my $spec ( grep defined, @specs ) {
    if ( ref $spec eq 'ARRAY') {
      $self->normalize_filespecs( map {\$_} grep defined, @$spec )
    } elsif ( ref $spec eq 'SCALAR' ) {
      $$spec =~ tr/"//d if $$spec;
      next unless $$spec;
      $$spec = '"' . File::Spec->canonpath($$spec) . '"';
    } elsif ( ref $spec eq '' ) {
      $spec = '"' . File::Spec->canonpath($spec) . '"';
    } else {
      die "Don't know how to normalize " . (ref $spec || $spec) . "\n";
    }
  }
}

# directory of perl's include files
sub perl_inc {
  my $self = shift;

  my $perl_src = $self->perl_src();

  if ($perl_src) {
    File::Spec->catdir($perl_src, "lib", "CORE");
  } else {
    File::Spec->catdir($self->{config}{archlibexp},"CORE");
  }
}

1;

########################################################################

=begin comment

The packages below implement functions for generating properly
formated commandlines for the compiler being used. Each package
defines two primary functions 'format_linker_cmd()' &
'format_compiler_cmd()' that accepts a list of named arguments (a
hash) and returns a list of formated options suitable for invoking the
compiler. By default, if the compiler supports scripting of its
operation then a script file is built containing the options while
those options are removed from the commandline, and a reference to the
script is pushed onto the commandline in their place. Scripting the
compiler in this way helps to avoid the problems associated with long
commandlines under some shells.

=end comment

=cut

########################################################################
package ExtUtils::CBuilder::Platform::Windows::MSVC;

sub format_compiler_cmd {
  my ($self, %spec) = @_;

  foreach my $path ( @{ $spec{includes} || [] },
                     @{ $spec{perlinc}  || [] } ) {
    $path = '-I' . $path;
  }

  %spec = $self->write_compiler_script(%spec)
    if $spec{use_scripts};

  return [ grep {defined && length} (
    $spec{cc},'-nologo','-c',
    @{$spec{includes}}      ,
    @{$spec{cflags}}        ,
    @{$spec{optimize}}      ,
    @{$spec{defines}}       ,
    @{$spec{perlinc}}       ,
    "-Fo$spec{output}"      ,
    $spec{source}           ,
  ) ];
}

sub write_compiler_script {
  my ($self, %spec) = @_;

  my $script = File::Spec->catfile( $spec{srcdir},
                                    $spec{basename} . '.ccs' );

  $self->add_to_cleanup($script);

  print "Generating script '$script'\n" if !$self->{quiet};

  open( SCRIPT, ">$script" )
    or die( "Could not create script '$script': $!" );

  print SCRIPT join( "\n",
    map { ref $_ ? @{$_} : $_ }
    grep defined,
    delete(
      @spec{ qw(includes cflags optimize defines perlinc) } )
  );

  close SCRIPT;

  push @{$spec{includes}}, '@"' . $script . '"';

  return %spec;
}

sub format_linker_cmd {
  my ($self, %spec) = @_;

  foreach my $path ( @{$spec{libpath}} ) {
    $path = "-libpath:$path";
  }

  $spec{def_file}  &&= '-def:'    . $spec{def_file};
  $spec{output}    &&= '-out:'    . $spec{output};
  $spec{implib}    &&= '-implib:' . $spec{implib};
  $spec{map_file}  &&= '-map:'    . $spec{map_file};

  %spec = $self->write_linker_script(%spec)
    if $spec{use_scripts};

  return [ grep {defined && length} (
    $spec{ld}               ,
    @{$spec{lddlflags}}     ,
    @{$spec{libpath}}       ,
    @{$spec{other_ldflags}} ,
    @{$spec{startup}}       ,
    @{$spec{objects}}       ,
    $spec{map_file}         ,
    $spec{libperl}          ,
    @{$spec{perllibs}}      ,
    $spec{def_file}         ,
    $spec{implib}           ,
    $spec{output}           ,
  ) ];
}

sub write_linker_script {
  my ($self, %spec) = @_;

  my $script = File::Spec->catfile( $spec{srcdir},
                                    $spec{basename} . '.lds' );

  $self->add_to_cleanup($script);

  print "Generating script '$script'\n" if !$self->{quiet};

  open( SCRIPT, ">$script" )
    or die( "Could not create script '$script': $!" );

  print SCRIPT join( "\n",
    map { ref $_ ? @{$_} : $_ }
    grep defined,
    delete(
      @spec{ qw(lddlflags libpath other_ldflags
                startup objects libperl perllibs
                def_file implib map_file)            } )
  );

  close SCRIPT;

  push @{$spec{lddlflags}}, '@"' . $script . '"';

  return %spec;
}

1;

########################################################################
package ExtUtils::CBuilder::Platform::Windows::BCC;

sub format_compiler_cmd {
  my ($self, %spec) = @_;

  foreach my $path ( @{ $spec{includes} || [] },
                     @{ $spec{perlinc}  || [] } ) {
    $path = '-I' . $path;
  }

  %spec = $self->write_compiler_script(%spec)
    if $spec{use_scripts};

  return [ grep {defined && length} (
    $spec{cc}, '-c'         ,
    @{$spec{includes}}      ,
    @{$spec{cflags}}        ,
    @{$spec{optimize}}      ,
    @{$spec{defines}}       ,
    @{$spec{perlinc}}       ,
    "-o$spec{output}"       ,
    $spec{source}           ,
  ) ];
}

sub write_compiler_script {
  my ($self, %spec) = @_;

  my $script = File::Spec->catfile( $spec{srcdir},
                                    $spec{basename} . '.ccs' );

  $self->add_to_cleanup($script);

  print "Generating script '$script'\n" if !$self->{quiet};

  open( SCRIPT, ">$script" )
    or die( "Could not create script '$script': $!" );

  print SCRIPT join( "\n",
    map { ref $_ ? @{$_} : $_ }
    grep defined,
    delete(
      @spec{ qw(includes cflags optimize defines perlinc) } )
  );

  close SCRIPT;

  push @{$spec{includes}}, '@"' . $script . '"';

  return %spec;
}

sub format_linker_cmd {
  my ($self, %spec) = @_;

  foreach my $path ( @{$spec{libpath}} ) {
    $path = "-L$path";
  }

  push( @{$spec{startup}}, 'c0d32.obj' )
    unless ( $spec{starup} && @{$spec{startup}} );

  %spec = $self->write_linker_script(%spec)
    if $spec{use_scripts};

  return [ grep {defined && length} (
    $spec{ld}               ,
    @{$spec{lddlflags}}     ,
    @{$spec{libpath}}       ,
    @{$spec{other_ldflags}} ,
    @{$spec{startup}}       ,
    @{$spec{objects}}       , ',',
    $spec{output}           , ',',
    $spec{map_file}         , ',',
    $spec{libperl}          ,
    @{$spec{perllibs}}      , ',',
    $spec{def_file}
  ) ];
}

sub write_linker_script {
  my ($self, %spec) = @_;

  # To work around Borlands "unique" commandline syntax,
  # two scripts are used:

  my $ld_script = File::Spec->catfile( $spec{srcdir},
                                       $spec{basename} . '.lds' );
  my $ld_libs   = File::Spec->catfile( $spec{srcdir},
                                       $spec{basename} . '.lbs' );

  $self->add_to_cleanup($ld_script, $ld_libs);

  print "Generating scripts '$ld_script' and '$ld_libs'.\n" if !$self->{quiet};

  # Script 1: contains options & names of object files.
  open( LD_SCRIPT, ">$ld_script" )
    or die( "Could not create linker script '$ld_script': $!" );

  print LD_SCRIPT join( " +\n",
    map { @{$_} }
    grep defined,
    delete(
      @spec{ qw(lddlflags libpath other_ldflags startup objects) } )
  );

  close LD_SCRIPT;

  # Script 2: contains name of libs to link against.
  open( LD_LIBS, ">$ld_libs" )
    or die( "Could not create linker script '$ld_libs': $!" );

  print LD_LIBS join( " +\n",
     (delete $spec{libperl}  || ''),
    @{delete $spec{perllibs} || []},
  );

  close LD_LIBS;

  push @{$spec{lddlflags}}, '@"' . $ld_script  . '"';
  push @{$spec{perllibs}},  '@"' . $ld_libs    . '"';

  return %spec;
}

1;

########################################################################
package ExtUtils::CBuilder::Platform::Windows::GCC;

sub format_compiler_cmd {
  my ($self, %spec) = @_;

  foreach my $path ( @{ $spec{includes} || [] },
                     @{ $spec{perlinc}  || [] } ) {
    $path = '-I' . $path;
  }

  # split off any -arguments included in cc
  my @cc = split / (?=-)/, $spec{cc};

  return [ grep {defined && length} (
    @cc, '-c'               ,
    @{$spec{includes}}      ,
    @{$spec{cflags}}        ,
    @{$spec{optimize}}      ,
    @{$spec{defines}}       ,
    @{$spec{perlinc}}       ,
    '-o', $spec{output}     ,
    $spec{source}           ,
  ) ];
}

sub format_linker_cmd {
  my ($self, %spec) = @_;

  # The Config.pm variable 'libperl' is hardcoded to the full name
  # of the perl import library (i.e. 'libperl56.a'). GCC will not
  # find it unless the 'lib' prefix & the extension are stripped.
  $spec{libperl} =~ s/^(?:lib)?([^.]+).*$/-l$1/;

  unshift( @{$spec{other_ldflags}}, '-nostartfiles' )
    if ( $spec{startup} && @{$spec{startup}} );

  # From ExtUtils::MM_Win32:
  #
  ## one thing for GCC/Mingw32:
  ## we try to overcome non-relocateable-DLL problems by generating
  ##    a (hopefully unique) image-base from the dll's name
  ## -- BKS, 10-19-1999
  File::Basename::basename( $spec{output} ) =~ /(....)(.{0,4})/;
  $spec{image_base} = sprintf( "0x%x0000", unpack('n', $1 ^ $2) );

  %spec = $self->write_linker_script(%spec)
    if $spec{use_scripts};

  foreach my $path ( @{$spec{libpath}} ) {
    $path = "-L$path";
  }

  my @cmds; # Stores the series of commands needed to build the module.

  push @cmds, [
    'dlltool', '--def'        , $spec{def_file},
               '--output-exp' , $spec{explib}
  ];

  # split off any -arguments included in ld
  my @ld = split / (?=-)/, $spec{ld};

  push @cmds, [ grep {defined && length} (
    @ld                       ,
    '-o', $spec{output}       ,
    "-Wl,--base-file,$spec{base_file}"   ,
    "-Wl,--image-base,$spec{image_base}" ,
    @{$spec{lddlflags}}       ,
    @{$spec{libpath}}         ,
    @{$spec{startup}}         ,
    @{$spec{objects}}         ,
    @{$spec{other_ldflags}}   ,
    $spec{libperl}            ,
    @{$spec{perllibs}}        ,
    $spec{explib}             ,
    $spec{map_file} ? ('-Map', $spec{map_file}) : ''
  ) ];

  push @cmds, [
    'dlltool', '--def'        , $spec{def_file},
               '--output-exp' , $spec{explib},
               '--base-file'  , $spec{base_file}
  ];

  push @cmds, [ grep {defined && length} (
    @ld                       ,
    '-o', $spec{output}       ,
    "-Wl,--image-base,$spec{image_base}" ,
    @{$spec{lddlflags}}       ,
    @{$spec{libpath}}         ,
    @{$spec{startup}}         ,
    @{$spec{objects}}         ,
    @{$spec{other_ldflags}}   ,
    $spec{libperl}            ,
    @{$spec{perllibs}}        ,
    $spec{explib}             ,
    $spec{map_file} ? ('-Map', $spec{map_file}) : ''
  ) ];

  return @cmds;
}

sub write_linker_script {
  my ($self, %spec) = @_;

  my $script = File::Spec->catfile( $spec{srcdir},
                                    $spec{basename} . '.lds' );

  $self->add_to_cleanup($script);

  print "Generating script '$script'\n" if !$self->{quiet};

  open( SCRIPT, ">$script" )
    or die( "Could not create script '$script': $!" );

  print( SCRIPT 'SEARCH_DIR(' . $_ . ")\n" )
    for @{delete $spec{libpath} || []};

  # gcc takes only one startup file, so the first object in startup is
  # specified as the startup file and any others are shifted into the
  # beginning of the list of objects.
  if ( $spec{startup} && @{$spec{startup}} ) {
    print SCRIPT 'STARTUP(' . shift( @{$spec{startup}} ) . ")\n";
    unshift @{$spec{objects}},
      @{delete $spec{startup} || []};
  }

  print SCRIPT 'INPUT(' . join( ',',
    @{delete $spec{objects}  || []}
  ) . ")\n";

  print SCRIPT 'INPUT(' . join( ' ',
     (delete $spec{libperl}  || ''),
    @{delete $spec{perllibs} || []},
  ) . ")\n";

  close SCRIPT;

  push @{$spec{other_ldflags}}, '"' . $script . '"';

  return %spec;
}

1;

__END__

=head1 NAME

ExtUtils::CBuilder::Platform::Windows - Builder class for Windows platforms

=head1 DESCRIPTION

This module implements the Windows-specific parts of ExtUtils::CBuilder.
Most of the Windows-specific stuff has to do with compiling and
linking C code.  Currently we support the 3 compilers perl itself
supports: MSVC, BCC, and GCC.

This module inherits from C<ExtUtils::CBuilder::Base>, so any functionality
not implemented here will be implemented there.  The interfaces are
defined by the L<ExtUtils::CBuilder> documentation.

=head1 AUTHOR

Ken Williams <ken@mathforum.org>

Most of the code here was written by Randy W. Sims <RandyS@ThePierianSpring.org>.

=head1 SEE ALSO

perl(1), ExtUtils::CBuilder(3), ExtUtils::MakeMaker(3)

=cut
Commit	Line	Data
6b09c160 YST	1	package ExtUtils::CBuilder::Platform::Windows;
	2
	3	use strict;
	4	use warnings;
	5
	6	use File::Basename;
	7	use File::Spec;
	8
	9	use ExtUtils::CBuilder::Base;
	10
	11	use vars qw($VERSION @ISA);
	12	$VERSION = '0.01';
	13	@ISA = qw(ExtUtils::CBuilder::Base);
	14
	15	sub new {
	16	my $class = shift;
	17	my $self = $class->SUPER::new(@_);
	18	my $cf = $self->{config};
	19
	20	# Inherit from an appropriate compiler driver class
	21	unshift @ISA, "ExtUtils::CBuilder::Platform::Windows::" . $self->_compiler_type;
	22
	23	return $self;
	24	}
	25
	26	sub _compiler_type {
	27	my $self = shift;
	28	my $cc = $self->{config}{cc};
	29
	30	return ( $cc =~ /cl(\.exe)?$/ ? 'MSVC'
	31	: $cc =~ /bcc32(\.exe)?$/ ? 'BCC'
	32	: 'GCC');
	33	}
	34
	35	sub split_like_shell {
	36	# As it turns out, Windows command-parsing is very different from
	37	# Unix command-parsing. Double-quotes mean different things,
	38	# backslashes don't necessarily mean escapes, and so on. So we
	39	# can't use Text::ParseWords::shellwords() to break a command string
	40	# into words. The algorithm below was bashed out by Randy and Ken
	41	# (mostly Randy), and there are a lot of regression tests, so we
	42	# should feel free to adjust if desired.
	43
	44	(my $self, local $_) = @_;
	45
	46	return @$_ if defined() && UNIVERSAL::isa($_, 'ARRAY');
	47
	48	my @argv;
	49	return @argv unless defined() && length();
	50
	51	my $arg = '';
	52	my( $i, $quote_mode ) = ( 0, 0 );
	53
	54	while ( $i < length() ) {
	55
	56	my $ch = substr( $_, $i , 1 );
	57	my $next_ch = substr( $_, $i+1, 1 );
	58
	59	if ( $ch eq '\\' && $next_ch eq '"' ) {
	60	$arg .= '"';
	61	$i++;
	62	} elsif ( $ch eq '\\' && $next_ch eq '\\' ) {
	63	$arg .= '\\';
	64	$i++;
65	} elsif ( $ch eq '"' && $next_ch eq '"' && $quote_mode ) {
66	$quote_mode = !$quote_mode;
67	$arg .= '"';
68	$i++;
69	} elsif ( $ch eq '"' && $next_ch eq '"' && !$quote_mode &&
70	( $i + 2 == length() \|\|
71	substr( $_, $i + 2, 1 ) eq ' ' )
72	) { # for cases like: a"" => [ 'a' ]
73	push( @argv, $arg );
74	$arg = '';
75	$i += 2;
76	} elsif ( $ch eq '"' ) {
77	$quote_mode = !$quote_mode;
78	} elsif ( $ch eq ' ' && !$quote_mode ) {
79	push( @argv, $arg ) if $arg;
80	$arg = '';
81	++$i while substr( $_, $i + 1, 1 ) eq ' ';
82	} else {
83	$arg .= $ch;
84	}
85
86	$i++;
87	}
88
89	push( @argv, $arg ) if defined( $arg ) && length( $arg );
90	return @argv;
91	}
92
93	sub compile {
94	my ($self, %args) = @_;
95	my $cf = $self->{config};
96
97	die "Missing 'source' argument to compile()" unless defined $args{source};
98
99	my ($basename, $srcdir) =
100	( File::Basename::fileparse($args{source}, '\.[^.]+$') )[0,1];
101
102	$srcdir \|\|= File::Spec->curdir();
103
104	my %spec = (
105	srcdir => $srcdir,
106	builddir => $srcdir,
107	basename => $basename,
108	source => $args{source},
109	output => File::Spec->catfile($srcdir, $basename) . $cf->{obj_ext},
110	cc => $cf->{cc},
111	cflags => [
112	$self->split_like_shell($cf->{ccflags}),
113	$self->split_like_shell($cf->{cccdlflags}),
114	],
115	optimize => [ $self->split_like_shell($cf->{optimize}) ],
116	defines => [ '' ],
117	includes => [ @{$args{include_dirs} \|\| []} ],
118	perlinc => [
119	$self->perl_inc(),
120	$self->split_like_shell($cf->{incpath}),
121	],
122	use_scripts => 1, # XXX provide user option to change this???
123	);
124
125	$self->add_to_cleanup($spec{output});
126
127	$self->normalize_filespecs(
128	\$spec{source},
129	\$spec{output},
130	$spec{includes},
131	$spec{perlinc},
132	);
133
134	my @cmds = $self->format_compiler_cmd(%spec);
135	while ( my $cmd = shift @cmds ) {
136	$self->do_system( @$cmd )
137	or die "error building $cf->{dlext} file from '$args{source}'";
138	}
139
140	(my $out = $spec{output}) =~ tr/'"//d;
141	return $out;
142	}
143
144	sub need_prelink { 1 }
145
146	sub link {
147	my ($self, %args) = @_;
148	my $cf = $self->{config};
149
150	my @objects = ( ref $args{objects} eq 'ARRAY' ? @{$args{objects}} : $args{objects} );
151	my $to = join '', (File::Spec->splitpath($objects[0]))[0,1];
152	$to \|\|= File::Spec->curdir();
153
154	(my $file_base = $args{module_name}) =~ s/.*:://;
155	my $output = $args{lib_file} \|\|
156	File::Spec->catfile($to, "$file_base.$cf->{dlext}");
157
158	# if running in perl source tree, look for libs there, not installed
159	my $lddlflags = $cf->{lddlflags};
160	my $perl_src = $self->perl_src();
161	$lddlflags =~ s/\Q$cf->{archlibexp}\E\\CORE/$perl_src/ if $perl_src;
162
163	my %spec = (
164	srcdir => $to,
165	builddir => $to,
166	startup => [ ],
167	objects => \@objects,
168	libs => [ ],
169	output => $output,
170	ld => $cf->{ld},
171	libperl => $cf->{libperl},
172	perllibs => [ $self->split_like_shell($cf->{perllibs}) ],
173	libpath => [ $self->split_like_shell($cf->{libpth}) ],
174	lddlflags => [ $self->split_like_shell($lddlflags) ],
175	other_ldflags => [ $self->split_like_shell($args{extra_linker_flags} \|\| '') ],
176	use_scripts => 1, # XXX provide user option to change this???
177	);
178
179	unless ( $spec{basename} ) {
180	($spec{basename} = $args{module_name}) =~ s/.*:://;
181	}
182
183	$spec{srcdir} = File::Spec->canonpath( $spec{srcdir} );
184	$spec{builddir} = File::Spec->canonpath( $spec{builddir} );
185
186	$spec{output} \|\|= File::Spec->catfile( $spec{builddir},
187	$spec{basename} . '.'.$cf->{dlext} );
188	$spec{implib} \|\|= File::Spec->catfile( $spec{builddir},
189	$spec{basename} . $cf->{lib_ext} );
190	$spec{explib} \|\|= File::Spec->catfile( $spec{builddir},
191	$spec{basename} . '.exp' );
192	$spec{def_file} \|\|= File::Spec->catfile( $spec{srcdir} ,
193	$spec{basename} . '.def' );
194	$spec{base_file} \|\|= File::Spec->catfile( $spec{srcdir} ,
195	$spec{basename} . '.base' );
196
197	$self->add_to_cleanup(
198	grep defined,
199	@{[ @spec{qw(output implib explib def_file base_file map_file)} ]}
200	);
201
202	foreach my $opt ( qw(output implib explib def_file map_file base_file) ) {
203	$self->normalize_filespecs( \$spec{$opt} );
204	}
205
206	foreach my $opt ( qw(libpath startup objects) ) {
207	$self->normalize_filespecs( $spec{$opt} );
208	}
209
210	(my $def_base = $spec{def_file}) =~ tr/'"//d;
211	$def_base =~ s/\.def$//;
212	$self->prelink( dl_name => $args{module_name},
213	dl_file => $def_base,
214	dl_base => $spec{basename} );
215
216	my @cmds = $self->format_linker_cmd(%spec);
217	while ( my $cmd = shift @cmds ) {
218	$self->do_system( @$cmd );
219	}
220
221	$spec{output} =~ tr/'"//d;
222	return wantarray
223	? grep defined, @spec{qw[output implib explib def_file map_file base_file]}
224	: $spec{output};
225	}
226
227	# canonize & quote paths
228	sub normalize_filespecs {
229	my ($self, @specs) = @_;
230	foreach my $spec ( grep defined, @specs ) {
231	if ( ref $spec eq 'ARRAY') {
232	$self->normalize_filespecs( map {\$_} grep defined, @$spec )
233	} elsif ( ref $spec eq 'SCALAR' ) {
234	$$spec =~ tr/"//d if $$spec;
235	next unless $$spec;
236	$$spec = '"' . File::Spec->canonpath($$spec) . '"';
237	} elsif ( ref $spec eq '' ) {
238	$spec = '"' . File::Spec->canonpath($spec) . '"';
239	} else {
240	die "Don't know how to normalize " . (ref $spec \|\| $spec) . "\n";
241	}
242	}
243	}
244
245	# directory of perl's include files
246	sub perl_inc {
247	my $self = shift;
248
249	my $perl_src = $self->perl_src();
250
251	if ($perl_src) {
252	File::Spec->catdir($perl_src, "lib", "CORE");
253	} else {
254	File::Spec->catdir($self->{config}{archlibexp},"CORE");
255	}
256	}
257
258	1;
259
260	########################################################################
261
262	=begin comment
263
264	The packages below implement functions for generating properly
265	formated commandlines for the compiler being used. Each package
266	defines two primary functions 'format_linker_cmd()' &
267	'format_compiler_cmd()' that accepts a list of named arguments (a
268	hash) and returns a list of formated options suitable for invoking the
269	compiler. By default, if the compiler supports scripting of its
270	operation then a script file is built containing the options while
271	those options are removed from the commandline, and a reference to the
272	script is pushed onto the commandline in their place. Scripting the
273	compiler in this way helps to avoid the problems associated with long
274	commandlines under some shells.
275
276	=end comment
277
278	=cut
279
280	########################################################################
281	package ExtUtils::CBuilder::Platform::Windows::MSVC;
282
283	sub format_compiler_cmd {
284	my ($self, %spec) = @_;
285
286	foreach my $path ( @{ $spec{includes} \|\| [] },
287	@{ $spec{perlinc} \|\| [] } ) {
288	$path = '-I' . $path;
289	}
290
291	%spec = $self->write_compiler_script(%spec)
292	if $spec{use_scripts};
293
294	return [ grep {defined && length} (
295	$spec{cc},'-nologo','-c',
296	@{$spec{includes}} ,
297	@{$spec{cflags}} ,
298	@{$spec{optimize}} ,
299	@{$spec{defines}} ,
300	@{$spec{perlinc}} ,
301	"-Fo$spec{output}" ,
302	$spec{source} ,
303	) ];
304	}
305
306	sub write_compiler_script {
307	my ($self, %spec) = @_;
308
309	my $script = File::Spec->catfile( $spec{srcdir},
310	$spec{basename} . '.ccs' );
311
312	$self->add_to_cleanup($script);
313
314	print "Generating script '$script'\n" if !$self->{quiet};
315
316	open( SCRIPT, ">$script" )
317	or die( "Could not create script '$script': $!" );
318
319	print SCRIPT join( "\n",
320	map { ref $_ ? @{$_} : $_ }
321	grep defined,
322	delete(
323	@spec{ qw(includes cflags optimize defines perlinc) } )
324	);
325
326	close SCRIPT;
327
328	push @{$spec{includes}}, '@"' . $script . '"';
329
330	return %spec;
331	}
332
333	sub format_linker_cmd {
334	my ($self, %spec) = @_;
335
336	foreach my $path ( @{$spec{libpath}} ) {
337	$path = "-libpath:$path";
338	}
339
340	$spec{def_file} &&= '-def:' . $spec{def_file};
341	$spec{output} &&= '-out:' . $spec{output};
342	$spec{implib} &&= '-implib:' . $spec{implib};
343	$spec{map_file} &&= '-map:' . $spec{map_file};
344
345	%spec = $self->write_linker_script(%spec)
346	if $spec{use_scripts};
347
348	return [ grep {defined && length} (
349	$spec{ld} ,
350	@{$spec{lddlflags}} ,
351	@{$spec{libpath}} ,
352	@{$spec{other_ldflags}} ,
353	@{$spec{startup}} ,
354	@{$spec{objects}} ,
355	$spec{map_file} ,
356	$spec{libperl} ,
357	@{$spec{perllibs}} ,
358	$spec{def_file} ,
359	$spec{implib} ,
360	$spec{output} ,
361	) ];
362	}
363
364	sub write_linker_script {
365	my ($self, %spec) = @_;
366
367	my $script = File::Spec->catfile( $spec{srcdir},
368	$spec{basename} . '.lds' );
369
370	$self->add_to_cleanup($script);
371
372	print "Generating script '$script'\n" if !$self->{quiet};
373
374	open( SCRIPT, ">$script" )
375	or die( "Could not create script '$script': $!" );
376
377	print SCRIPT join( "\n",
378	map { ref $_ ? @{$_} : $_ }
379	grep defined,
380	delete(
381	@spec{ qw(lddlflags libpath other_ldflags
382	startup objects libperl perllibs
383	def_file implib map_file) } )
384	);
385
386	close SCRIPT;
387
388	push @{$spec{lddlflags}}, '@"' . $script . '"';
389
390	return %spec;
391	}
392
393	1;
394
395	########################################################################
396	package ExtUtils::CBuilder::Platform::Windows::BCC;
397
398	sub format_compiler_cmd {
399	my ($self, %spec) = @_;
400
401	foreach my $path ( @{ $spec{includes} \|\| [] },
402	@{ $spec{perlinc} \|\| [] } ) {
403	$path = '-I' . $path;
404	}
405
406	%spec = $self->write_compiler_script(%spec)
407	if $spec{use_scripts};
408
409	return [ grep {defined && length} (
410	$spec{cc}, '-c' ,
411	@{$spec{includes}} ,
412	@{$spec{cflags}} ,
413	@{$spec{optimize}} ,
414	@{$spec{defines}} ,
415	@{$spec{perlinc}} ,
416	"-o$spec{output}" ,
417	$spec{source} ,
418	) ];
419	}
420
421	sub write_compiler_script {
422	my ($self, %spec) = @_;
423
424	my $script = File::Spec->catfile( $spec{srcdir},
425	$spec{basename} . '.ccs' );
426
427	$self->add_to_cleanup($script);
428
429	print "Generating script '$script'\n" if !$self->{quiet};
430
431	open( SCRIPT, ">$script" )
432	or die( "Could not create script '$script': $!" );
433
434	print SCRIPT join( "\n",
435	map { ref $_ ? @{$_} : $_ }
436	grep defined,
437	delete(
438	@spec{ qw(includes cflags optimize defines perlinc) } )
439	);
440
441	close SCRIPT;
442
443	push @{$spec{includes}}, '@"' . $script . '"';
444
445	return %spec;
446	}
447
448	sub format_linker_cmd {
449	my ($self, %spec) = @_;
450
451	foreach my $path ( @{$spec{libpath}} ) {
452	$path = "-L$path";
453	}
454
455	push( @{$spec{startup}}, 'c0d32.obj' )
456	unless ( $spec{starup} && @{$spec{startup}} );
457
458	%spec = $self->write_linker_script(%spec)
459	if $spec{use_scripts};
460
461	return [ grep {defined && length} (
462	$spec{ld} ,
463	@{$spec{lddlflags}} ,
464	@{$spec{libpath}} ,
465	@{$spec{other_ldflags}} ,
466	@{$spec{startup}} ,
467	@{$spec{objects}} , ',',
468	$spec{output} , ',',
469	$spec{map_file} , ',',
470	$spec{libperl} ,
471	@{$spec{perllibs}} , ',',
472	$spec{def_file}
473	) ];
474	}
475
476	sub write_linker_script {
477	my ($self, %spec) = @_;
478
479	# To work around Borlands "unique" commandline syntax,
480	# two scripts are used:
481
482	my $ld_script = File::Spec->catfile( $spec{srcdir},
483	$spec{basename} . '.lds' );
484	my $ld_libs = File::Spec->catfile( $spec{srcdir},
485	$spec{basename} . '.lbs' );
486
487	$self->add_to_cleanup($ld_script, $ld_libs);
488
489	print "Generating scripts '$ld_script' and '$ld_libs'.\n" if !$self->{quiet};
490
491	# Script 1: contains options & names of object files.
492	open( LD_SCRIPT, ">$ld_script" )
493	or die( "Could not create linker script '$ld_script': $!" );
494
495	print LD_SCRIPT join( " +\n",
496	map { @{$_} }
497	grep defined,
498	delete(
499	@spec{ qw(lddlflags libpath other_ldflags startup objects) } )
500	);
501
502	close LD_SCRIPT;
503
504	# Script 2: contains name of libs to link against.
505	open( LD_LIBS, ">$ld_libs" )
506	or die( "Could not create linker script '$ld_libs': $!" );
507
508	print LD_LIBS join( " +\n",
509	(delete $spec{libperl} \|\| ''),
510	@{delete $spec{perllibs} \|\| []},
511	);
512
513	close LD_LIBS;
514
515	push @{$spec{lddlflags}}, '@"' . $ld_script . '"';
516	push @{$spec{perllibs}}, '@"' . $ld_libs . '"';
517
518	return %spec;
519	}
520
521	1;
522
523	########################################################################
524	package ExtUtils::CBuilder::Platform::Windows::GCC;
525
526	sub format_compiler_cmd {
527	my ($self, %spec) = @_;
528
529	foreach my $path ( @{ $spec{includes} \|\| [] },
530	@{ $spec{perlinc} \|\| [] } ) {
531	$path = '-I' . $path;
532	}
533
534	# split off any -arguments included in cc
535	my @cc = split / (?=-)/, $spec{cc};
536
537	return [ grep {defined && length} (
538	@cc, '-c' ,
539	@{$spec{includes}} ,
540	@{$spec{cflags}} ,
541	@{$spec{optimize}} ,
542	@{$spec{defines}} ,
543	@{$spec{perlinc}} ,
544	'-o', $spec{output} ,
545	$spec{source} ,
546	) ];
547	}
548
549	sub format_linker_cmd {
550	my ($self, %spec) = @_;
551
552	# The Config.pm variable 'libperl' is hardcoded to the full name
553	# of the perl import library (i.e. 'libperl56.a'). GCC will not
554	# find it unless the 'lib' prefix & the extension are stripped.
555	$spec{libperl} =~ s/^(?:lib)?([^.]+).*$/-l$1/;
556
557	unshift( @{$spec{other_ldflags}}, '-nostartfiles' )
558	if ( $spec{startup} && @{$spec{startup}} );
559
560	# From ExtUtils::MM_Win32:
561	#
562	## one thing for GCC/Mingw32:
563	## we try to overcome non-relocateable-DLL problems by generating
564	## a (hopefully unique) image-base from the dll's name
565	## -- BKS, 10-19-1999
566	File::Basename::basename( $spec{output} ) =~ /(....)(.{0,4})/;
567	$spec{image_base} = sprintf( "0x%x0000", unpack('n', $1 ^ $2) );
568
569	%spec = $self->write_linker_script(%spec)
570	if $spec{use_scripts};
571
572	foreach my $path ( @{$spec{libpath}} ) {
573	$path = "-L$path";
574	}
575
576	my @cmds; # Stores the series of commands needed to build the module.
577
578	push @cmds, [
579	'dlltool', '--def' , $spec{def_file},
580	'--output-exp' , $spec{explib}
581	];
582
583	# split off any -arguments included in ld
584	my @ld = split / (?=-)/, $spec{ld};
585
586	push @cmds, [ grep {defined && length} (
587	@ld ,
588	'-o', $spec{output} ,
589	"-Wl,--base-file,$spec{base_file}" ,
590	"-Wl,--image-base,$spec{image_base}" ,
591	@{$spec{lddlflags}} ,
592	@{$spec{libpath}} ,
593	@{$spec{startup}} ,
594	@{$spec{objects}} ,
595	@{$spec{other_ldflags}} ,
596	$spec{libperl} ,
597	@{$spec{perllibs}} ,
598	$spec{explib} ,
599	$spec{map_file} ? ('-Map', $spec{map_file}) : ''
600	) ];
601
602	push @cmds, [
603	'dlltool', '--def' , $spec{def_file},
604	'--output-exp' , $spec{explib},
605	'--base-file' , $spec{base_file}
606	];
607
608	push @cmds, [ grep {defined && length} (
609	@ld ,
610	'-o', $spec{output} ,
611	"-Wl,--image-base,$spec{image_base}" ,
612	@{$spec{lddlflags}} ,
613	@{$spec{libpath}} ,
614	@{$spec{startup}} ,
615	@{$spec{objects}} ,
616	@{$spec{other_ldflags}} ,
617	$spec{libperl} ,
618	@{$spec{perllibs}} ,
619	$spec{explib} ,
620	$spec{map_file} ? ('-Map', $spec{map_file}) : ''
621	) ];
622
623	return @cmds;
624	}
625
626	sub write_linker_script {
627	my ($self, %spec) = @_;
628
629	my $script = File::Spec->catfile( $spec{srcdir},
630	$spec{basename} . '.lds' );
631
632	$self->add_to_cleanup($script);
633
634	print "Generating script '$script'\n" if !$self->{quiet};
635
636	open( SCRIPT, ">$script" )
637	or die( "Could not create script '$script': $!" );
638
639	print( SCRIPT 'SEARCH_DIR(' . $_ . ")\n" )
640	for @{delete $spec{libpath} \|\| []};
641
642	# gcc takes only one startup file, so the first object in startup is
643	# specified as the startup file and any others are shifted into the
644	# beginning of the list of objects.
645	if ( $spec{startup} && @{$spec{startup}} ) {
646	print SCRIPT 'STARTUP(' . shift( @{$spec{startup}} ) . ")\n";
647	unshift @{$spec{objects}},
648	@{delete $spec{startup} \|\| []};
649	}
650
651	print SCRIPT 'INPUT(' . join( ',',
652	@{delete $spec{objects} \|\| []}
653	) . ")\n";
654
655	print SCRIPT 'INPUT(' . join( ' ',
656	(delete $spec{libperl} \|\| ''),
657	@{delete $spec{perllibs} \|\| []},
658	) . ")\n";
659
660	close SCRIPT;
661
662	push @{$spec{other_ldflags}}, '"' . $script . '"';
663
664	return %spec;
665	}
666
667	1;
668
669	__END__
670
671	=head1 NAME
672
673	ExtUtils::CBuilder::Platform::Windows - Builder class for Windows platforms
674
675	=head1 DESCRIPTION
676
677	This module implements the Windows-specific parts of ExtUtils::CBuilder.
678	Most of the Windows-specific stuff has to do with compiling and
679	linking C code. Currently we support the 3 compilers perl itself
680	supports: MSVC, BCC, and GCC.
681
682	This module inherits from C<ExtUtils::CBuilder::Base>, so any functionality
683	not implemented here will be implemented there. The interfaces are
684	defined by the L<ExtUtils::CBuilder> documentation.
685
686	=head1 AUTHOR
687
688	Ken Williams <ken@mathforum.org>
689
690	Most of the code here was written by Randy W. Sims <RandyS@ThePierianSpring.org>.
691
692	=head1 SEE ALSO
693
694	perl(1), ExtUtils::CBuilder(3), ExtUtils::MakeMaker(3)
695
696	=cut