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