This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
d1ee9cda87d652f46b24ea019788178c115af975
[perl5.git] / cpan / Module-Build / lib / Module / Build / Platform / Windows.pm
1 package Module::Build::Platform::Windows;
2
3 use strict;
4 use vars qw($VERSION);
5 $VERSION = '0.4008';
6 $VERSION = eval $VERSION;
7
8 use Config;
9 use File::Basename;
10 use File::Spec;
11
12 use Module::Build::Base;
13
14 use vars qw(@ISA);
15 @ISA = qw(Module::Build::Base);
16
17
18 sub manpage_separator {
19     return '.';
20 }
21
22 sub have_forkpipe { 0 }
23
24 sub _detildefy {
25   my ($self, $value) = @_;
26   $value =~ s,^~(?= [/\\] | $ ),$ENV{HOME},x
27     if $ENV{HOME};
28   return $value;
29 }
30
31 sub ACTION_realclean {
32   my ($self) = @_;
33
34   $self->SUPER::ACTION_realclean();
35
36   my $basename = basename($0);
37   $basename =~ s/(?:\.bat)?$//i;
38
39   if ( lc $basename eq lc $self->build_script ) {
40     if ( $self->build_bat ) {
41       $self->log_verbose("Deleting $basename.bat\n");
42       my $full_progname = $0;
43       $full_progname =~ s/(?:\.bat)?$/.bat/i;
44
45       # Voodoo required to have a batch file delete itself without error;
46       # Syntax differs between 9x & NT: the later requires a null arg (???)
47       require Win32;
48       my $null_arg = (Win32::IsWinNT()) ? '""' : '';
49       my $cmd = qq(start $null_arg /min "\%comspec\%" /c del "$full_progname");
50
51       open(my $fh, '>>', "$basename.bat")
52         or die "Can't create $basename.bat: $!";
53       print $fh $cmd;
54       close $fh ;
55     } else {
56       $self->delete_filetree($self->build_script . '.bat');
57     }
58   }
59 }
60
61 sub make_executable {
62   my $self = shift;
63
64   $self->SUPER::make_executable(@_);
65
66   foreach my $script (@_) {
67
68     # Native batch script
69     if ( $script =~ /\.(bat|cmd)$/ ) {
70       $self->SUPER::make_executable($script);
71       next;
72
73     # Perl script that needs to be wrapped in a batch script
74     } else {
75       my %opts = ();
76       if ( $script eq $self->build_script ) {
77         $opts{ntargs}    = q(-x -S %0 --build_bat %*);
78         $opts{otherargs} = q(-x -S "%0" --build_bat %1 %2 %3 %4 %5 %6 %7 %8 %9);
79       }
80
81       my $out = eval {$self->pl2bat(in => $script, update => 1, %opts)};
82       if ( $@ ) {
83         $self->log_warn("WARNING: Unable to convert file '$script' to an executable script:\n$@");
84       } else {
85         $self->SUPER::make_executable($out);
86       }
87     }
88   }
89 }
90
91 # This routine was copied almost verbatim from the 'pl2bat' utility
92 # distributed with perl. It requires too much voodoo with shell quoting
93 # differences and shortcomings between the various flavors of Windows
94 # to reliably shell out
95 sub pl2bat {
96   my $self = shift;
97   my %opts = @_;
98
99   # NOTE: %0 is already enclosed in doublequotes by cmd.exe, as appropriate
100   $opts{ntargs}    = '-x -S %0 %*' unless exists $opts{ntargs};
101   $opts{otherargs} = '-x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9' unless exists $opts{otherargs};
102
103   $opts{stripsuffix} = '/\\.plx?/' unless exists $opts{stripsuffix};
104   $opts{stripsuffix} = ($opts{stripsuffix} =~ m{^/([^/]*[^/\$]|)\$?/?$} ? $1 : "\Q$opts{stripsuffix}\E");
105
106   unless (exists $opts{out}) {
107     $opts{out} = $opts{in};
108     $opts{out} =~ s/$opts{stripsuffix}$//oi;
109     $opts{out} .= '.bat' unless $opts{in} =~ /\.bat$/i or $opts{in} =~ /^-$/;
110   }
111
112   my $head = <<EOT;
113     \@rem = '--*-Perl-*--
114     \@echo off
115     if "%OS%" == "Windows_NT" goto WinNT
116     perl $opts{otherargs}
117     goto endofperl
118     :WinNT
119     perl $opts{ntargs}
120     if NOT "%COMSPEC%" == "%SystemRoot%\\system32\\cmd.exe" goto endofperl
121     if %errorlevel% == 9009 echo You do not have Perl in your PATH.
122     if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
123     goto endofperl
124     \@rem ';
125 EOT
126
127   $head =~ s/^\s+//gm;
128   my $headlines = 2 + ($head =~ tr/\n/\n/);
129   my $tail = "\n__END__\n:endofperl\n";
130
131   my $linedone  = 0;
132   my $taildone  = 0;
133   my $linenum   = 0;
134   my $skiplines = 0;
135
136   my $start = $Config{startperl};
137   $start = "#!perl" unless $start =~ /^#!.*perl/;
138
139   open(my $in, '<', "$opts{in}") or die "Can't open $opts{in}: $!";
140   my @file = <$in>;
141   close($in);
142
143   foreach my $line ( @file ) {
144     $linenum++;
145     if ( $line =~ /^:endofperl\b/ ) {
146       if (!exists $opts{update}) {
147         warn "$opts{in} has already been converted to a batch file!\n";
148         return;
149       }
150       $taildone++;
151     }
152     if ( not $linedone and $line =~ /^#!.*perl/ ) {
153       if (exists $opts{update}) {
154         $skiplines = $linenum - 1;
155         $line .= "#line ".(1+$headlines)."\n";
156       } else {
157         $line .= "#line ".($linenum+$headlines)."\n";
158       }
159         $linedone++;
160     }
161     if ( $line =~ /^#\s*line\b/ and $linenum == 2 + $skiplines ) {
162       $line = "";
163     }
164   }
165
166   open(my $out, '>', "$opts{out}") or die "Can't open $opts{out}: $!";
167   print $out $head;
168   print $out $start, ( $opts{usewarnings} ? " -w" : "" ),
169              "\n#line ", ($headlines+1), "\n" unless $linedone;
170   print $out @file[$skiplines..$#file];
171   print $out $tail unless $taildone;
172   close($out);
173
174   return $opts{out};
175 }
176
177
178 sub _quote_args {
179   # Returns a string that can become [part of] a command line with
180   # proper quoting so that the subprocess sees this same list of args.
181   my ($self, @args) = @_;
182
183   my @quoted;
184
185   for (@args) {
186     if ( /^[^\s*?!\$<>;|'"\[\]\{\}]+$/ ) {
187       # Looks pretty safe
188       push @quoted, $_;
189     } else {
190       # XXX this will obviously have to improve - is there already a
191       # core module lying around that does proper quoting?
192       s/"/\\"/g;
193       push @quoted, qq("$_");
194     }
195   }
196
197   return join " ", @quoted;
198 }
199
200
201 sub split_like_shell {
202   # As it turns out, Windows command-parsing is very different from
203   # Unix command-parsing.  Double-quotes mean different things,
204   # backslashes don't necessarily mean escapes, and so on.  So we
205   # can't use Text::ParseWords::shellwords() to break a command string
206   # into words.  The algorithm below was bashed out by Randy and Ken
207   # (mostly Randy), and there are a lot of regression tests, so we
208   # should feel free to adjust if desired.
209
210   (my $self, local $_) = @_;
211
212   return @$_ if defined() && UNIVERSAL::isa($_, 'ARRAY');
213
214   my @argv;
215   return @argv unless defined() && length();
216
217   my $arg = '';
218   my( $i, $quote_mode ) = ( 0, 0 );
219
220   while ( $i < length() ) {
221
222     my $ch      = substr( $_, $i  , 1 );
223     my $next_ch = substr( $_, $i+1, 1 );
224
225     if ( $ch eq '\\' && $next_ch eq '"' ) {
226       $arg .= '"';
227       $i++;
228     } elsif ( $ch eq '\\' && $next_ch eq '\\' ) {
229       $arg .= '\\';
230       $i++;
231     } elsif ( $ch eq '"' && $next_ch eq '"' && $quote_mode ) {
232       $quote_mode = !$quote_mode;
233       $arg .= '"';
234       $i++;
235     } elsif ( $ch eq '"' && $next_ch eq '"' && !$quote_mode &&
236               ( $i + 2 == length()  ||
237                 substr( $_, $i + 2, 1 ) eq ' ' )
238             ) { # for cases like: a"" => [ 'a' ]
239       push( @argv, $arg );
240       $arg = '';
241       $i += 2;
242     } elsif ( $ch eq '"' ) {
243       $quote_mode = !$quote_mode;
244     } elsif ( $ch eq ' ' && !$quote_mode ) {
245       push( @argv, $arg ) if $arg;
246       $arg = '';
247       ++$i while substr( $_, $i + 1, 1 ) eq ' ';
248     } else {
249       $arg .= $ch;
250     }
251
252     $i++;
253   }
254
255   push( @argv, $arg ) if defined( $arg ) && length( $arg );
256   return @argv;
257 }
258
259
260 # system(@cmd) does not like having double-quotes in it on Windows.
261 # So we quote them and run it as a single command.
262 sub do_system {
263   my ($self, @cmd) = @_;
264
265   my $cmd = $self->_quote_args(@cmd);
266   my $status = system($cmd);
267   if ($status and $! =~ /Argument list too long/i) {
268     my $env_entries = '';
269     foreach (sort keys %ENV) { $env_entries .= "$_=>".length($ENV{$_})."; " }
270     warn "'Argument list' was 'too long', env lengths are $env_entries";
271   }
272   return !$status;
273 }
274
275 # Copied from ExtUtils::MM_Win32
276 sub _maybe_command {
277     my($self,$file) = @_;
278     my @e = exists($ENV{'PATHEXT'})
279           ? split(/;/, $ENV{PATHEXT})
280           : qw(.com .exe .bat .cmd);
281     my $e = '';
282     for (@e) { $e .= "\Q$_\E|" }
283     chop $e;
284     # see if file ends in one of the known extensions
285     if ($file =~ /($e)$/i) {
286         return $file if -e $file;
287     }
288     else {
289         for (@e) {
290             return "$file$_" if -e "$file$_";
291         }
292     }
293     return;
294 }
295
296
297 1;
298
299 __END__
300
301 =head1 NAME
302
303 Module::Build::Platform::Windows - Builder class for Windows platforms
304
305 =head1 DESCRIPTION
306
307 The sole purpose of this module is to inherit from
308 C<Module::Build::Base> and override a few methods.  Please see
309 L<Module::Build> for the docs.
310
311 =head1 AUTHOR
312
313 Ken Williams <kwilliams@cpan.org>, Randy W. Sims <RandyS@ThePierianSpring.org>
314
315 =head1 SEE ALSO
316
317 perl(1), Module::Build(3)
318
319 =cut