[p5sagit/p5-mst-13.2.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 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': $!" );

  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	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	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	93	sub arg_defines {
	94	my ($self, %args) = @_;
	95	s/"/\\"/g foreach values %args;
ea2e6518	96	return map qq{"-D$_=$args{$_}"}, keys %args;
d1cf867f	97	}
d1cf867f	98
6b09c160	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	110	my @defines = $self->arg_defines( %{ $args{defines} \|\| {} } );
d1cf867f	111
6b09c160	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	123	],
6b09c160	124	optimize => [ $self->split_like_shell($cf->{optimize}) ],
d1cf867f	125	defines => \@defines,
6b09c160	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	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	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	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	273	defines two primary functions 'format_linker_cmd()' &
6b09c160	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	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	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
440	print SCRIPT join( "\n",
441	map { ref $_ ? @{$_} : $_ }
442	grep defined,
443	delete(
444	@spec{ qw(includes cflags optimize defines perlinc) } )
445	);
446
447	close SCRIPT;
448
449	push @{$spec{includes}}, '@"' . $script . '"';
450
451	return %spec;
452	}
453
454	sub format_linker_cmd {
455	my ($self, %spec) = @_;
456
457	foreach my $path ( @{$spec{libpath}} ) {
458	$path = "-L$path";
459	}
460
461	push( @{$spec{startup}}, 'c0d32.obj' )
462	unless ( $spec{starup} && @{$spec{startup}} );
463
464	%spec = $self->write_linker_script(%spec)
465	if $spec{use_scripts};
466
467	return [ grep {defined && length} (
468	$spec{ld} ,
469	@{$spec{lddlflags}} ,
470	@{$spec{libpath}} ,
471	@{$spec{other_ldflags}} ,
472	@{$spec{startup}} ,
473	@{$spec{objects}} , ',',
474	$spec{output} , ',',
475	$spec{map_file} , ',',
476	$spec{libperl} ,
477	@{$spec{perllibs}} , ',',
478	$spec{def_file}
479	) ];
480	}
481
482	sub write_linker_script {
483	my ($self, %spec) = @_;
484
485	# To work around Borlands "unique" commandline syntax,
486	# two scripts are used:
487
488	my $ld_script = File::Spec->catfile( $spec{srcdir},
489	$spec{basename} . '.lds' );
490	my $ld_libs = File::Spec->catfile( $spec{srcdir},
491	$spec{basename} . '.lbs' );
492
493	$self->add_to_cleanup($ld_script, $ld_libs);
494
495	print "Generating scripts '$ld_script' and '$ld_libs'.\n" if !$self->{quiet};
496
497	# Script 1: contains options & names of object files.
498	open( LD_SCRIPT, ">$ld_script" )
499	or die( "Could not create linker script '$ld_script': $!" );
500
501	print LD_SCRIPT join( " +\n",
502	map { @{$_} }
503	grep defined,
504	delete(
505	@spec{ qw(lddlflags libpath other_ldflags startup objects) } )
506	);
507
508	close LD_SCRIPT;
509
510	# Script 2: contains name of libs to link against.
511	open( LD_LIBS, ">$ld_libs" )
512	or die( "Could not create linker script '$ld_libs': $!" );
513
514	print LD_LIBS join( " +\n",
515	(delete $spec{libperl} \|\| ''),
516	@{delete $spec{perllibs} \|\| []},
517	);
518
519	close LD_LIBS;
520
521	push @{$spec{lddlflags}}, '@"' . $ld_script . '"';
522	push @{$spec{perllibs}}, '@"' . $ld_libs . '"';
523
524	return %spec;
525	}
526
527	1;
528
529	########################################################################
530	package ExtUtils::CBuilder::Platform::Windows::GCC;
531
532	sub format_compiler_cmd {
533	my ($self, %spec) = @_;
534
535	foreach my $path ( @{ $spec{includes} \|\| [] },
536	@{ $spec{perlinc} \|\| [] } ) {
537	$path = '-I' . $path;
538	}
539
540	# split off any -arguments included in cc
541	my @cc = split / (?=-)/, $spec{cc};
542
543	return [ grep {defined && length} (
544	@cc, '-c' ,
545	@{$spec{includes}} ,
546	@{$spec{cflags}} ,
547	@{$spec{optimize}} ,
548	@{$spec{defines}} ,
549	@{$spec{perlinc}} ,
550	'-o', $spec{output} ,
551	$spec{source} ,
552	) ];
553	}
554
555	sub format_linker_cmd {
556	my ($self, %spec) = @_;
557
558	# The Config.pm variable 'libperl' is hardcoded to the full name
559	# of the perl import library (i.e. 'libperl56.a'). GCC will not
560	# find it unless the 'lib' prefix & the extension are stripped.
561	$spec{libperl} =~ s/^(?:lib)?([^.]+).*$/-l$1/;
562
563	unshift( @{$spec{other_ldflags}}, '-nostartfiles' )
564	if ( $spec{startup} && @{$spec{startup}} );
565
566	# From ExtUtils::MM_Win32:
567	#
568	## one thing for GCC/Mingw32:
569	## we try to overcome non-relocateable-DLL problems by generating
570	## a (hopefully unique) image-base from the dll's name
571	## -- BKS, 10-19-1999
572	File::Basename::basename( $spec{output} ) =~ /(....)(.{0,4})/;
573	$spec{image_base} = sprintf( "0x%x0000", unpack('n', $1 ^ $2) );
574
575	%spec = $self->write_linker_script(%spec)
576	if $spec{use_scripts};
577
578	foreach my $path ( @{$spec{libpath}} ) {
579	$path = "-L$path";
580	}
581
582	my @cmds; # Stores the series of commands needed to build the module.
583
584	push @cmds, [
585	'dlltool', '--def' , $spec{def_file},
586	'--output-exp' , $spec{explib}
587	];
588
589	# split off any -arguments included in ld
590	my @ld = split / (?=-)/, $spec{ld};
591
592	push @cmds, [ grep {defined && length} (
593	@ld ,
594	'-o', $spec{output} ,
595	"-Wl,--base-file,$spec{base_file}" ,
596	"-Wl,--image-base,$spec{image_base}" ,
597	@{$spec{lddlflags}} ,
598	@{$spec{libpath}} ,
599	@{$spec{startup}} ,
600	@{$spec{objects}} ,
601	@{$spec{other_ldflags}} ,
602	$spec{libperl} ,
603	@{$spec{perllibs}} ,
604	$spec{explib} ,
605	$spec{map_file} ? ('-Map', $spec{map_file}) : ''
606	) ];
607
608	push @cmds, [
609	'dlltool', '--def' , $spec{def_file},
610	'--output-exp' , $spec{explib},
611	'--base-file' , $spec{base_file}
612	];
613
614	push @cmds, [ grep {defined && length} (
615	@ld ,
616	'-o', $spec{output} ,
617	"-Wl,--image-base,$spec{image_base}" ,
618	@{$spec{lddlflags}} ,
619	@{$spec{libpath}} ,
620	@{$spec{startup}} ,
621	@{$spec{objects}} ,
622	@{$spec{other_ldflags}} ,
623	$spec{libperl} ,
624	@{$spec{perllibs}} ,
625	$spec{explib} ,
626	$spec{map_file} ? ('-Map', $spec{map_file}) : ''
627	) ];
628
629	return @cmds;
630	}
631
632	sub write_linker_script {
633	my ($self, %spec) = @_;
634
635	my $script = File::Spec->catfile( $spec{srcdir},
636	$spec{basename} . '.lds' );
637
638	$self->add_to_cleanup($script);
639
640	print "Generating script '$script'\n" if !$self->{quiet};
641
642	open( SCRIPT, ">$script" )
643	or die( "Could not create script '$script': $!" );
644
645	print( SCRIPT 'SEARCH_DIR(' . $_ . ")\n" )
646	for @{delete $spec{libpath} \|\| []};
647
648	# gcc takes only one startup file, so the first object in startup is
649	# specified as the startup file and any others are shifted into the
650	# beginning of the list of objects.
651	if ( $spec{startup} && @{$spec{startup}} ) {
652	print SCRIPT 'STARTUP(' . shift( @{$spec{startup}} ) . ")\n";
653	unshift @{$spec{objects}},
654	@{delete $spec{startup} \|\| []};
655	}
656
657	print SCRIPT 'INPUT(' . join( ',',
658	@{delete $spec{objects} \|\| []}
659	) . ")\n";
660
661	print SCRIPT 'INPUT(' . join( ' ',
662	(delete $spec{libperl} \|\| ''),
663	@{delete $spec{perllibs} \|\| []},
664	) . ")\n";
665
666	close SCRIPT;
667
668	push @{$spec{other_ldflags}}, '"' . $script . '"';
669
670	return %spec;
671	}
672
673	1;
674
675	__END__
676
677	=head1 NAME
678
679	ExtUtils::CBuilder::Platform::Windows - Builder class for Windows platforms
680
681	=head1 DESCRIPTION
682
683	This module implements the Windows-specific parts of ExtUtils::CBuilder.
684	Most of the Windows-specific stuff has to do with compiling and
685	linking C code. Currently we support the 3 compilers perl itself
686	supports: MSVC, BCC, and GCC.
687
688	This module inherits from C<ExtUtils::CBuilder::Base>, so any functionality
689	not implemented here will be implemented there. The interfaces are
690	defined by the L<ExtUtils::CBuilder> documentation.
691
692	=head1 AUTHOR
693
694	Ken Williams <ken@mathforum.org>
695
696	Most of the code here was written by Randy W. Sims <RandyS@ThePierianSpring.org>.
697
698	=head1 SEE ALSO
699
700	perl(1), ExtUtils::CBuilder(3), ExtUtils::MakeMaker(3)
701
702	=cut