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