[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';
@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->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': $!" );

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