This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Update Module-Build to CPAN version 0.4201
[perl5.git] / cpan / Module-Build / lib / Module / Build / Platform / Windows.pm
CommitLineData
bb4e9162
YST
1package Module::Build::Platform::Windows;
2
3use strict;
7a827510 4use vars qw($VERSION);
d320cf40 5$VERSION = '0.4201';
7a827510 6$VERSION = eval $VERSION;
bb4e9162
YST
7
8use Config;
9use File::Basename;
10use File::Spec;
bb4e9162
YST
11
12use Module::Build::Base;
13
14use vars qw(@ISA);
15@ISA = qw(Module::Build::Base);
16
17
18sub manpage_separator {
19 return '.';
20}
21
dc8021d3 22sub have_forkpipe { 0 }
a314697d 23
7a827510
RGS
24sub _detildefy {
25 my ($self, $value) = @_;
26 $value =~ s,^~(?= [/\\] | $ ),$ENV{HOME},x
27 if $ENV{HOME};
28 return $value;
29}
30
bb4e9162
YST
31sub ACTION_realclean {
32 my ($self) = @_;
33
34 $self->SUPER::ACTION_realclean();
35
36 my $basename = basename($0);
37 $basename =~ s/(?:\.bat)?$//i;
38
23837600 39 if ( lc $basename eq lc $self->build_script ) {
bb4e9162 40 if ( $self->build_bat ) {
613f422f 41 $self->log_verbose("Deleting $basename.bat\n");
bb4e9162
YST
42 my $full_progname = $0;
43 $full_progname =~ s/(?:\.bat)?$/.bat/i;
44
23837600 45 # Voodoo required to have a batch file delete itself without error;
bb4e9162
YST
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
46de787b 51 open(my $fh, '>>', "$basename.bat")
bb4e9162
YST
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
61sub make_executable {
62 my $self = shift;
63
64 $self->SUPER::make_executable(@_);
65
66 foreach my $script (@_) {
bb4e9162 67
f943a5bf
SP
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
SP
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
YST
87 }
88 }
89}
90
91# This routine was copied almost verbatim from the 'pl2bat' utility
23837600 92# distributed with perl. It requires too much voodoo with shell quoting
bb4e9162
YST
93# differences and shortcomings between the various flavors of Windows
94# to reliably shell out
95sub 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 ';
125EOT
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
46de787b 139 open(my $in, '<', "$opts{in}") or die "Can't open $opts{in}: $!";
bb4e9162 140 my @file = <$in>;
46de787b 141 close($in);
bb4e9162
YST
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
46de787b 166 open(my $out, '>', "$opts{out}") or die "Can't open $opts{out}: $!";
bb4e9162
YST
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;
46de787b 172 close($out);
bb4e9162
YST
173
174 return $opts{out};
175}
176
177
738349a8
SH
178sub _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
YST
201sub 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.
53fc1c7e 209
bb4e9162 210 (my $self, local $_) = @_;
53fc1c7e 211
bb4e9162 212 return @$_ if defined() && UNIVERSAL::isa($_, 'ARRAY');
53fc1c7e 213
bb4e9162
YST
214 my @argv;
215 return @argv unless defined() && length();
53fc1c7e 216
bb4e9162
YST
217 my $arg = '';
218 my( $i, $quote_mode ) = ( 0, 0 );
53fc1c7e 219
bb4e9162 220 while ( $i < length() ) {
53fc1c7e 221
bb4e9162
YST
222 my $ch = substr( $_, $i , 1 );
223 my $next_ch = substr( $_, $i+1, 1 );
53fc1c7e 224
bb4e9162
YST
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 }
53fc1c7e 251
bb4e9162
YST
252 $i++;
253 }
53fc1c7e 254
bb4e9162
YST
255 push( @argv, $arg ) if defined( $arg ) && length( $arg );
256 return @argv;
257}
258
738349a8
SH
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.
262sub 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
613f422f
DG
275# Copied from ExtUtils::MM_Win32
276sub _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
738349a8 296
bb4e9162
YST
2971;
298
299__END__
300
301=head1 NAME
302
303Module::Build::Platform::Windows - Builder class for Windows platforms
304
305=head1 DESCRIPTION
306
307The sole purpose of this module is to inherit from
308C<Module::Build::Base> and override a few methods. Please see
309L<Module::Build> for the docs.
310
311=head1 AUTHOR
312
77e96e88 313Ken Williams <kwilliams@cpan.org>, Randy W. Sims <RandyS@ThePierianSpring.org>
bb4e9162
YST
314
315=head1 SEE ALSO
316
317perl(1), Module::Build(3)
318
319=cut