Commit | Line | Data |
bb4e9162 |
1 | package Module::Build::Platform::Windows; |
2 | |
3 | use strict; |
7a827510 |
4 | use vars qw($VERSION); |
5 | $VERSION = '0.2808_01'; |
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 | |
178 | sub split_like_shell { |
179 | # As it turns out, Windows command-parsing is very different from |
180 | # Unix command-parsing. Double-quotes mean different things, |
181 | # backslashes don't necessarily mean escapes, and so on. So we |
182 | # can't use Text::ParseWords::shellwords() to break a command string |
183 | # into words. The algorithm below was bashed out by Randy and Ken |
184 | # (mostly Randy), and there are a lot of regression tests, so we |
185 | # should feel free to adjust if desired. |
186 | |
187 | (my $self, local $_) = @_; |
188 | |
189 | return @$_ if defined() && UNIVERSAL::isa($_, 'ARRAY'); |
190 | |
191 | my @argv; |
192 | return @argv unless defined() && length(); |
193 | |
194 | my $arg = ''; |
195 | my( $i, $quote_mode ) = ( 0, 0 ); |
196 | |
197 | while ( $i < length() ) { |
198 | |
199 | my $ch = substr( $_, $i , 1 ); |
200 | my $next_ch = substr( $_, $i+1, 1 ); |
201 | |
202 | if ( $ch eq '\\' && $next_ch eq '"' ) { |
203 | $arg .= '"'; |
204 | $i++; |
205 | } elsif ( $ch eq '\\' && $next_ch eq '\\' ) { |
206 | $arg .= '\\'; |
207 | $i++; |
208 | } elsif ( $ch eq '"' && $next_ch eq '"' && $quote_mode ) { |
209 | $quote_mode = !$quote_mode; |
210 | $arg .= '"'; |
211 | $i++; |
212 | } elsif ( $ch eq '"' && $next_ch eq '"' && !$quote_mode && |
213 | ( $i + 2 == length() || |
214 | substr( $_, $i + 2, 1 ) eq ' ' ) |
215 | ) { # for cases like: a"" => [ 'a' ] |
216 | push( @argv, $arg ); |
217 | $arg = ''; |
218 | $i += 2; |
219 | } elsif ( $ch eq '"' ) { |
220 | $quote_mode = !$quote_mode; |
221 | } elsif ( $ch eq ' ' && !$quote_mode ) { |
222 | push( @argv, $arg ) if $arg; |
223 | $arg = ''; |
224 | ++$i while substr( $_, $i + 1, 1 ) eq ' '; |
225 | } else { |
226 | $arg .= $ch; |
227 | } |
228 | |
229 | $i++; |
230 | } |
231 | |
232 | push( @argv, $arg ) if defined( $arg ) && length( $arg ); |
233 | return @argv; |
234 | } |
235 | |
236 | 1; |
237 | |
238 | __END__ |
239 | |
240 | =head1 NAME |
241 | |
242 | Module::Build::Platform::Windows - Builder class for Windows platforms |
243 | |
244 | =head1 DESCRIPTION |
245 | |
246 | The sole purpose of this module is to inherit from |
247 | C<Module::Build::Base> and override a few methods. Please see |
248 | L<Module::Build> for the docs. |
249 | |
250 | =head1 AUTHOR |
251 | |
77e96e88 |
252 | Ken Williams <kwilliams@cpan.org>, Randy W. Sims <RandyS@ThePierianSpring.org> |
bb4e9162 |
253 | |
254 | =head1 SEE ALSO |
255 | |
256 | perl(1), Module::Build(3) |
257 | |
258 | =cut |