[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.12_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 arg_defines {
  my ($self, %args) = @_;
  s/"/\\"/g foreach values %args;
  return map qq{"-D$_=$args{$_}"}, keys %args;
}

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 @defines = $self->arg_defines( %{ $args{defines} || {} } );

  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}),
                     $self->split_like_shell($cf->{extra_compiler_flags}),
                   ],
    optimize    => [ $self->split_like_shell($cf->{optimize})    ],
    defines     => \@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->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(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
formatted 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 formatted 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': $!" );

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