Commit | Line | Data |
bb4e9162 |
1 | package Module::Build::Platform::Windows; |
2 | |
3 | use strict; |
7a827510 |
4 | use vars qw($VERSION); |
15cb7b9d |
5 | $VERSION = '0.31012'; |
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 | |
40 | if ( $basename eq $self->build_script ) { |
41 | if ( $self->build_bat ) { |
42 | my $full_progname = $0; |
43 | $full_progname =~ s/(?:\.bat)?$/.bat/i; |
44 | |
45 | # Vodoo 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 | my $fh = IO::File->new(">> $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 (@_) { |
bb4e9162 |
67 | |
f943a5bf |
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 |
bb4e9162 |
74 | } else { |
f943a5bf |
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 | } |
bb4e9162 |
87 | } |
88 | } |
89 | } |
90 | |
91 | # This routine was copied almost verbatim from the 'pl2bat' utility |
92 | # distributed with perl. It requires too much vodoo 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 | my $in = IO::File->new("< $opts{in}") or die "Can't open $opts{in}: $!"; |
140 | my @file = <$in>; |
141 | $in->close; |
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 | my $out = IO::File->new("> $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 | $out->close; |
173 | |
174 | return $opts{out}; |
175 | } |
176 | |
177 | |
738349a8 |
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 | |
bb4e9162 |
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 | |
738349a8 |
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 | |
bb4e9162 |
276 | 1; |
277 | |
278 | __END__ |
279 | |
280 | =head1 NAME |
281 | |
282 | Module::Build::Platform::Windows - Builder class for Windows platforms |
283 | |
284 | =head1 DESCRIPTION |
285 | |
286 | The sole purpose of this module is to inherit from |
287 | C<Module::Build::Base> and override a few methods. Please see |
288 | L<Module::Build> for the docs. |
289 | |
290 | =head1 AUTHOR |
291 | |
77e96e88 |
292 | Ken Williams <kwilliams@cpan.org>, Randy W. Sims <RandyS@ThePierianSpring.org> |
bb4e9162 |
293 | |
294 | =head1 SEE ALSO |
295 | |
296 | perl(1), Module::Build(3) |
297 | |
298 | =cut |