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