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