Commit | Line | Data |
bb4e9162 |
1 | package Module::Build::Platform::Windows; |
2 | |
3 | use strict; |
7a827510 |
4 | use vars qw($VERSION); |
613f422f |
5 | $VERSION = '0.35_08'; |
7a827510 |
6 | $VERSION = eval $VERSION; |
bb4e9162 |
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 | |
dc8021d3 |
23 | sub have_forkpipe { 0 } |
a314697d |
24 | |
7a827510 |
25 | sub _detildefy { |
26 | my ($self, $value) = @_; |
27 | $value =~ s,^~(?= [/\\] | $ ),$ENV{HOME},x |
28 | if $ENV{HOME}; |
29 | return $value; |
30 | } |
31 | |
bb4e9162 |
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 | |
23837600 |
40 | if ( lc $basename eq lc $self->build_script ) { |
bb4e9162 |
41 | if ( $self->build_bat ) { |
613f422f |
42 | $self->log_verbose("Deleting $basename.bat\n"); |
bb4e9162 |
43 | my $full_progname = $0; |
44 | $full_progname =~ s/(?:\.bat)?$/.bat/i; |
45 | |
23837600 |
46 | # Voodoo required to have a batch file delete itself without error; |
bb4e9162 |
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 (@_) { |
bb4e9162 |
68 | |
f943a5bf |
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 |
bb4e9162 |
75 | } else { |
f943a5bf |
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 | } |
bb4e9162 |
88 | } |
89 | } |
90 | } |
91 | |
92 | # This routine was copied almost verbatim from the 'pl2bat' utility |
23837600 |
93 | # distributed with perl. It requires too much voodoo with shell quoting |
bb4e9162 |
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 | |
738349a8 |
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 | |
bb4e9162 |
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. |
613f422f |
210 | |
bb4e9162 |
211 | (my $self, local $_) = @_; |
613f422f |
212 | |
bb4e9162 |
213 | return @$_ if defined() && UNIVERSAL::isa($_, 'ARRAY'); |
613f422f |
214 | |
bb4e9162 |
215 | my @argv; |
216 | return @argv unless defined() && length(); |
613f422f |
217 | |
bb4e9162 |
218 | my $arg = ''; |
219 | my( $i, $quote_mode ) = ( 0, 0 ); |
613f422f |
220 | |
bb4e9162 |
221 | while ( $i < length() ) { |
613f422f |
222 | |
bb4e9162 |
223 | my $ch = substr( $_, $i , 1 ); |
224 | my $next_ch = substr( $_, $i+1, 1 ); |
613f422f |
225 | |
bb4e9162 |
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 | } |
613f422f |
252 | |
bb4e9162 |
253 | $i++; |
254 | } |
613f422f |
255 | |
bb4e9162 |
256 | push( @argv, $arg ) if defined( $arg ) && length( $arg ); |
257 | return @argv; |
258 | } |
259 | |
738349a8 |
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 | |
613f422f |
276 | # Copied from ExtUtils::MM_Win32 |
277 | sub _maybe_command { |
278 | my($self,$file) = @_; |
279 | my @e = exists($ENV{'PATHEXT'}) |
280 | ? split(/;/, $ENV{PATHEXT}) |
281 | : qw(.com .exe .bat .cmd); |
282 | my $e = ''; |
283 | for (@e) { $e .= "\Q$_\E|" } |
284 | chop $e; |
285 | # see if file ends in one of the known extensions |
286 | if ($file =~ /($e)$/i) { |
287 | return $file if -e $file; |
288 | } |
289 | else { |
290 | for (@e) { |
291 | return "$file$_" if -e "$file$_"; |
292 | } |
293 | } |
294 | return; |
295 | } |
296 | |
738349a8 |
297 | |
bb4e9162 |
298 | 1; |
299 | |
300 | __END__ |
301 | |
302 | =head1 NAME |
303 | |
304 | Module::Build::Platform::Windows - Builder class for Windows platforms |
305 | |
306 | =head1 DESCRIPTION |
307 | |
308 | The sole purpose of this module is to inherit from |
309 | C<Module::Build::Base> and override a few methods. Please see |
310 | L<Module::Build> for the docs. |
311 | |
312 | =head1 AUTHOR |
313 | |
77e96e88 |
314 | Ken Williams <kwilliams@cpan.org>, Randy W. Sims <RandyS@ThePierianSpring.org> |
bb4e9162 |
315 | |
316 | =head1 SEE ALSO |
317 | |
318 | perl(1), Module::Build(3) |
319 | |
320 | =cut |