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