1package ExtUtils::CBuilder::Platform::Windows; 2use strict; 3use warnings; 4 5use File::Basename; 6use File::Spec; 7 8use ExtUtils::CBuilder::Base; 9use IO::File; 10 11our $VERSION = '0.280240'; # VERSION 12our @ISA = qw(ExtUtils::CBuilder::Base); 13 14=begin comment 15 16The compiler-specific packages implement functions for generating properly 17formatted commandlines for the compiler being used. Each package 18defines two primary functions 'format_linker_cmd()' & 19'format_compiler_cmd()' that accepts a list of named arguments (a 20hash) and returns a list of formatted options suitable for invoking the 21compiler. By default, if the compiler supports scripting of its 22operation then a script file is built containing the options while 23those options are removed from the commandline, and a reference to the 24script is pushed onto the commandline in their place. Scripting the 25compiler in this way helps to avoid the problems associated with long 26commandlines under some shells. 27 28=end comment 29 30=cut 31 32sub new { 33 my $class = shift; 34 my $self = $class->SUPER::new(@_); 35 my $cf = $self->{config}; 36 37 # Inherit from an appropriate compiler driver class 38 my $driver = "ExtUtils::CBuilder::Platform::Windows::" . $self->_compiler_type; 39 eval "require $driver" or die "Could not load compiler driver: $@"; 40 unshift @ISA, $driver; 41 42 return $self; 43} 44 45sub _compiler_type { 46 my $self = shift; 47 my $cc = $self->{config}{cc}; 48 49 return ( $cc =~ /cl(\.exe)?$/ ? 'MSVC' 50 : $cc =~ /bcc32(\.exe)?$/ ? 'BCC' 51 : 'GCC'); 52} 53 54# native quoting, not shell quoting 55sub quote_literal { 56 my ($self, $string) = @_; 57 58 # some of these characters don't need to be quoted for "native" quoting, but 59 # quote them anyway so they are more likely to make it through cmd.exe 60 if (length $string && $string !~ /[ \t\n\x0b"|<>%]/) { 61 return $string; 62 } 63 64 $string =~ s{(\\*)(?="|\z)}{$1$1}g; 65 $string =~ s{"}{\\"}g; 66 67 return qq{"$string"}; 68} 69 70sub split_like_shell { 71 # Since Windows will pass the whole command string (not an argument 72 # array) to the target program and make the program parse it itself, 73 # we don't actually need to do any processing here. 74 (my $self, local $_) = @_; 75 76 return @$_ if defined() && UNIVERSAL::isa($_, 'ARRAY'); 77 return unless defined() && length(); 78 return ($_); 79} 80 81sub do_system { 82 # See above 83 my $self = shift; 84 my $cmd = join ' ', 85 grep length, 86 map {$a=$_;$a=~s/\t/ /g;$a=~s/^\s+|\s+$//;$a} 87 grep defined, @_; 88 89 if (!$self->{quiet}) { 90 print $cmd . "\n"; 91 } 92 local $self->{quiet} = 1; 93 return $self->SUPER::do_system($cmd); 94} 95 96sub arg_defines { 97 my ($self, %args) = @_; 98 s/"/\\"/g foreach values %args; 99 return map qq{"-D$_=$args{$_}"}, sort keys %args; 100} 101 102sub compile { 103 my ($self, %args) = @_; 104 my $cf = $self->{config}; 105 106 die "Missing 'source' argument to compile()" unless defined $args{source}; 107 108 $args{include_dirs} = [ $args{include_dirs} ] 109 if exists($args{include_dirs}) && ref($args{include_dirs}) ne "ARRAY"; 110 111 my ($basename, $srcdir) = 112 ( File::Basename::fileparse($args{source}, '\.[^.]+$') )[0,1]; 113 114 $srcdir ||= File::Spec->curdir(); 115 116 my @defines = $self->arg_defines( %{ $args{defines} || {} } ); 117 118 my %spec = ( 119 srcdir => $srcdir, 120 builddir => $srcdir, 121 basename => $basename, 122 source => $args{source}, 123 output => $args{object_file} || File::Spec->catfile($srcdir, $basename) . $cf->{obj_ext}, 124 cc => $cf->{cc}, 125 cflags => [ 126 $self->split_like_shell($cf->{ccflags}), 127 $self->split_like_shell($cf->{cccdlflags}), 128 $self->split_like_shell($args{extra_compiler_flags}), 129 ], 130 optimize => [ $self->split_like_shell($cf->{optimize}) ], 131 defines => \@defines, 132 includes => [ @{$args{include_dirs} || []} ], 133 perlinc => [ 134 $self->perl_inc(), 135 $self->split_like_shell($cf->{incpath}), 136 ], 137 use_scripts => 1, # XXX provide user option to change this??? 138 ); 139 140 $self->normalize_filespecs( 141 \$spec{source}, 142 \$spec{output}, 143 $spec{includes}, 144 $spec{perlinc}, 145 ); 146 147 my @cmds = $self->format_compiler_cmd(%spec); 148 while ( my $cmd = shift @cmds ) { 149 $self->do_system( @$cmd ) 150 or die "error building $cf->{dlext} file from '$args{source}'"; 151 } 152 153 (my $out = $spec{output}) =~ tr/'"//d; 154 return $out; 155} 156 157sub need_prelink { 1 } 158 159sub link { 160 my ($self, %args) = @_; 161 my $cf = $self->{config}; 162 163 my @objects = ( ref $args{objects} eq 'ARRAY' ? @{$args{objects}} : $args{objects} ); 164 my $to = join '', (File::Spec->splitpath($objects[0]))[0,1]; 165 $to ||= File::Spec->curdir(); 166 167 (my $file_base = $args{module_name}) =~ s/.*:://; 168 my $output = $args{lib_file} || 169 File::Spec->catfile($to, "$file_base.$cf->{dlext}"); 170 171 # if running in perl source tree, look for libs there, not installed 172 my $lddlflags = $cf->{lddlflags}; 173 my $perl_src = $self->perl_src(); 174 $lddlflags =~ s{\Q$cf->{archlibexp}\E[\\/]CORE}{$perl_src/lib/CORE} if $perl_src; 175 176 my %spec = ( 177 srcdir => $to, 178 builddir => $to, 179 startup => [ ], 180 objects => \@objects, 181 libs => [ ], 182 output => $output, 183 ld => $cf->{ld}, 184 libperl => $cf->{libperl}, 185 perllibs => [ $self->split_like_shell($cf->{perllibs}) ], 186 libpath => [ $self->split_like_shell($cf->{libpth}) ], 187 lddlflags => [ $self->split_like_shell($lddlflags) ], 188 other_ldflags => [ $self->split_like_shell($args{extra_linker_flags} || '') ], 189 use_scripts => 1, # XXX provide user option to change this??? 190 ); 191 192 unless ( $spec{basename} ) { 193 ($spec{basename} = $args{module_name}) =~ s/.*:://; 194 } 195 196 $spec{srcdir} = File::Spec->canonpath( $spec{srcdir} ); 197 $spec{builddir} = File::Spec->canonpath( $spec{builddir} ); 198 199 $spec{output} ||= File::Spec->catfile( $spec{builddir}, 200 $spec{basename} . '.'.$cf->{dlext} ); 201 $spec{manifest} ||= $spec{output} . '.manifest'; 202 $spec{implib} ||= File::Spec->catfile( $spec{builddir}, 203 $spec{basename} . $cf->{lib_ext} ); 204 $spec{explib} ||= File::Spec->catfile( $spec{builddir}, 205 $spec{basename} . '.exp' ); 206 if ($cf->{cc} eq 'cl') { 207 $spec{dbg_file} ||= File::Spec->catfile( $spec{builddir}, 208 $spec{basename} . '.pdb' ); 209 } 210 elsif ($cf->{cc} eq 'bcc32') { 211 $spec{dbg_file} ||= File::Spec->catfile( $spec{builddir}, 212 $spec{basename} . '.tds' ); 213 } 214 $spec{def_file} ||= File::Spec->catfile( $spec{srcdir} , 215 $spec{basename} . '.def' ); 216 $spec{base_file} ||= File::Spec->catfile( $spec{srcdir} , 217 $spec{basename} . '.base' ); 218 219 $self->add_to_cleanup( 220 grep defined, 221 @{[ @spec{qw(manifest implib explib dbg_file def_file base_file map_file)} ]} 222 ); 223 224 foreach my $opt ( qw(output manifest implib explib dbg_file def_file map_file base_file) ) { 225 $self->normalize_filespecs( \$spec{$opt} ); 226 } 227 228 foreach my $opt ( qw(libpath startup objects) ) { 229 $self->normalize_filespecs( $spec{$opt} ); 230 } 231 232 (my $def_base = $spec{def_file}) =~ tr/'"//d; 233 $def_base =~ s/\.def$//; 234 $self->prelink( %args, 235 dl_name => $args{module_name}, 236 dl_file => $def_base, 237 dl_base => $spec{basename} ); 238 239 my @cmds = $self->format_linker_cmd(%spec); 240 while ( my $cmd = shift @cmds ) { 241 $self->do_system( @$cmd ) or die "error building $output from @objects" 242 } 243 244 $spec{output} =~ tr/'"//d; 245 return wantarray 246 ? grep defined, @spec{qw[output manifest implib explib dbg_file def_file map_file base_file]} 247 : $spec{output}; 248} 249 250# canonize & quote paths 251sub normalize_filespecs { 252 my ($self, @specs) = @_; 253 foreach my $spec ( grep defined, @specs ) { 254 if ( ref $spec eq 'ARRAY') { 255 $self->normalize_filespecs( map {\$_} grep defined, @$spec ) 256 } elsif ( ref $spec eq 'SCALAR' ) { 257 $$spec =~ tr/"//d if $$spec; 258 next unless $$spec; 259 $$spec = '"' . File::Spec->canonpath($$spec) . '"'; 260 } elsif ( ref $spec eq '' ) { 261 $spec = '"' . File::Spec->canonpath($spec) . '"'; 262 } else { 263 die "Don't know how to normalize " . (ref $spec || $spec) . "\n"; 264 } 265 } 266} 267 268# directory of perl's include files 269sub perl_inc { 270 my $self = shift; 271 272 my $perl_src = $self->perl_src(); 273 274 if ($perl_src) { 275 File::Spec->catdir($perl_src, "lib", "CORE"); 276 } else { 277 File::Spec->catdir($self->{config}{archlibexp},"CORE"); 278 } 279} 280 2811; 282 283__END__ 284 285=head1 NAME 286 287ExtUtils::CBuilder::Platform::Windows - Builder class for Windows platforms 288 289=head1 DESCRIPTION 290 291This module implements the Windows-specific parts of ExtUtils::CBuilder. 292Most of the Windows-specific stuff has to do with compiling and 293linking C code. Currently we support the 3 compilers perl itself 294supports: MSVC, BCC, and GCC. 295 296This module inherits from C<ExtUtils::CBuilder::Base>, so any functionality 297not implemented here will be implemented there. The interfaces are 298defined by the L<ExtUtils::CBuilder> documentation. 299 300=head1 AUTHOR 301 302Ken Williams <ken@mathforum.org> 303 304Most of the code here was written by Randy W. Sims <RandyS@ThePierianSpring.org>. 305 306=head1 SEE ALSO 307 308perl(1), ExtUtils::CBuilder(3), ExtUtils::MakeMaker(3) 309 310=cut 311