This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Fix Borland problem with quoted pre-processor macros in response files
[perl5.git] / lib / ExtUtils / CBuilder / Platform / Windows.pm
CommitLineData
6b09c160
YST
1package ExtUtils::CBuilder::Platform::Windows;
2
3use strict;
4use warnings;
5
6use File::Basename;
7use File::Spec;
8
9use ExtUtils::CBuilder::Base;
10
11use vars qw($VERSION @ISA);
3b91ae7a 12$VERSION = '0.12_01';
6b09c160
YST
13@ISA = qw(ExtUtils::CBuilder::Base);
14
15sub 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
26sub _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
35sub 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
93sub arg_defines {
94 my ($self, %args) = @_;
95 s/"/\\"/g foreach values %args;
ea2e6518 96 return map qq{"-D$_=$args{$_}"}, keys %args;
d1cf867f
SP
97}
98
6b09c160
YST
99sub 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} || {} } );
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 ],
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
151sub need_prelink { 1 }
152
153sub 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
235sub 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
253sub 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
2651;
266
267########################################################################
268
269=begin comment
270
271The packages below implement functions for generating properly
3c4b39be 272formatted commandlines for the compiler being used. Each package
6b09c160
YST
273defines two primary functions 'format_linker_cmd()' &
274'format_compiler_cmd()' that accepts a list of named arguments (a
3c4b39be 275hash) and returns a list of formatted options suitable for invoking the
6b09c160
YST
276compiler. By default, if the compiler supports scripting of its
277operation then a script file is built containing the options while
278those options are removed from the commandline, and a reference to the
279script is pushed onto the commandline in their place. Scripting the
280compiler in this way helps to avoid the problems associated with long
281commandlines under some shells.
282
283=end comment
284
285=cut
286
287########################################################################
288package ExtUtils::CBuilder::Platform::Windows::MSVC;
289
290sub 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
313sub 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
339sub 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
370sub 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
3991;
400
401########################################################################
402package ExtUtils::CBuilder::Platform::Windows::BCC;
403
404sub 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
427sub 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
459sub 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
487sub 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
5321;
533
534########################################################################
535package ExtUtils::CBuilder::Platform::Windows::GCC;
536
537sub 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
560sub 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
637sub 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
6781;
679
680__END__
681
682=head1 NAME
683
684ExtUtils::CBuilder::Platform::Windows - Builder class for Windows platforms
685
686=head1 DESCRIPTION
687
688This module implements the Windows-specific parts of ExtUtils::CBuilder.
689Most of the Windows-specific stuff has to do with compiling and
690linking C code. Currently we support the 3 compilers perl itself
691supports: MSVC, BCC, and GCC.
692
693This module inherits from C<ExtUtils::CBuilder::Base>, so any functionality
694not implemented here will be implemented there. The interfaces are
695defined by the L<ExtUtils::CBuilder> documentation.
696
697=head1 AUTHOR
698
699Ken Williams <ken@mathforum.org>
700
701Most of the code here was written by Randy W. Sims <RandyS@ThePierianSpring.org>.
702
703=head1 SEE ALSO
704
705perl(1), ExtUtils::CBuilder(3), ExtUtils::MakeMaker(3)
706
707=cut