This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Update IPC-SysV to CPAN version 2.04
[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);
ee76e757 5$VERSION = '0.4005';
7a827510 6$VERSION = eval $VERSION;
bb4e9162
YST
7
8use Config;
9use File::Basename;
10use File::Spec;
11use IO::File;
12
13use Module::Build::Base;
14
15use vars qw(@ISA);
16@ISA = qw(Module::Build::Base);
17
18
19sub manpage_separator {
20 return '.';
21}
22
dc8021d3 23sub have_forkpipe { 0 }
a314697d 24
7a827510
RGS
25sub _detildefy {
26 my ($self, $value) = @_;
27 $value =~ s,^~(?= [/\\] | $ ),$ENV{HOME},x
28 if $ENV{HOME};
29 return $value;
30}
31
bb4e9162
YST
32sub 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
YST
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
YST
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
62sub make_executable {
63 my $self = shift;
64
65 $self->SUPER::make_executable(@_);
66
67 foreach my $script (@_) {
bb4e9162 68
f943a5bf
SP
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
SP
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
YST
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
YST
94# differences and shortcomings between the various flavors of Windows
95# to reliably shell out
96sub 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 ';
126EOT
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
SH
179sub _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
YST
202sub 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.
53fc1c7e 210
bb4e9162 211 (my $self, local $_) = @_;
53fc1c7e 212
bb4e9162 213 return @$_ if defined() && UNIVERSAL::isa($_, 'ARRAY');
53fc1c7e 214
bb4e9162
YST
215 my @argv;
216 return @argv unless defined() && length();
53fc1c7e 217
bb4e9162
YST
218 my $arg = '';
219 my( $i, $quote_mode ) = ( 0, 0 );
53fc1c7e 220
bb4e9162 221 while ( $i < length() ) {
53fc1c7e 222
bb4e9162
YST
223 my $ch = substr( $_, $i , 1 );
224 my $next_ch = substr( $_, $i+1, 1 );
53fc1c7e 225
bb4e9162
YST
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 }
53fc1c7e 252
bb4e9162
YST
253 $i++;
254 }
53fc1c7e 255
bb4e9162
YST
256 push( @argv, $arg ) if defined( $arg ) && length( $arg );
257 return @argv;
258}
259
738349a8
SH
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.
263sub 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
DG
276# Copied from ExtUtils::MM_Win32
277sub _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
YST
2981;
299
300__END__
301
302=head1 NAME
303
304Module::Build::Platform::Windows - Builder class for Windows platforms
305
306=head1 DESCRIPTION
307
308The sole purpose of this module is to inherit from
309C<Module::Build::Base> and override a few methods. Please see
310L<Module::Build> for the docs.
311
312=head1 AUTHOR
313
77e96e88 314Ken Williams <kwilliams@cpan.org>, Randy W. Sims <RandyS@ThePierianSpring.org>
bb4e9162
YST
315
316=head1 SEE ALSO
317
318perl(1), Module::Build(3)
319
320=cut