File Coverage

blib/lib/Module/Build/Platform/Windows.pm
Criterion Covered Total %
statement 40 108 37.0
branch 17 46 36.9
condition 10 15 66.6
subroutine 7 16 43.7
pod 0 7 0.0
total 74 192 38.5


line stmt bran cond sub pod time code
1             package Module::Build::Platform::Windows;
2              
3 57     57   37221 use strict;
  57         114  
  57         1767  
4 57     57   285 use warnings;
  57         114  
  57         2679  
5             our $VERSION = '0.42_35';
6             $VERSION = eval $VERSION;
7              
8 57     57   342 use Config;
  57         114  
  57         2394  
9 57     57   285 use File::Basename;
  57         114  
  57         5244  
10 57     57   399 use File::Spec;
  57         114  
  57         1197  
11              
12 57     57   285 use Module::Build::Base;
  57         114  
  57         83391  
13              
14             our @ISA = qw(Module::Build::Base);
15              
16              
17             sub manpage_separator {
18 0     0 0 0 return '.';
19             }
20              
21 0     0 0 0 sub have_forkpipe { 0 }
22              
23             sub _detildefy {
24 0     0   0 my ($self, $value) = @_;
25             $value =~ s,^~(?= [/\\] | $ ),$ENV{HOME},x
26 0 0       0 if $ENV{HOME};
27 0         0 return $value;
28             }
29              
30             sub ACTION_realclean {
31 0     0 0 0 my ($self) = @_;
32              
33 0         0 $self->SUPER::ACTION_realclean();
34              
35 0         0 my $basename = basename($0);
36 0         0 $basename =~ s/(?:\.bat)?$//i;
37              
38 0 0       0 if ( lc $basename eq lc $self->build_script ) {
39 0 0       0 if ( $self->build_bat ) {
40 0         0 $self->log_verbose("Deleting $basename.bat\n");
41 0         0 my $full_progname = $0;
42 0         0 $full_progname =~ s/(?:\.bat)?$/.bat/i;
43              
44             # Voodoo required to have a batch file delete itself without error;
45             # Syntax differs between 9x & NT: the later requires a null arg (???)
46 0         0 require Win32;
47 0 0       0 my $null_arg = (Win32::IsWinNT()) ? '""' : '';
48 0         0 my $cmd = qq(start $null_arg /min "\%comspec\%" /c del "$full_progname");
49              
50 0 0       0 open(my $fh, '>>', "$basename.bat")
51             or die "Can't create $basename.bat: $!";
52 0         0 print $fh $cmd;
53 0         0 close $fh ;
54             } else {
55 0         0 $self->delete_filetree($self->build_script . '.bat');
56             }
57             }
58             }
59              
60             sub make_executable {
61 0     0 0 0 my $self = shift;
62              
63 0         0 $self->SUPER::make_executable(@_);
64              
65 0         0 foreach my $script (@_) {
66              
67             # Native batch script
68 0 0       0 if ( $script =~ /\.(bat|cmd)$/ ) {
69 0         0 $self->SUPER::make_executable($script);
70 0         0 next;
71              
72             # Perl script that needs to be wrapped in a batch script
73             } else {
74 0         0 my %opts = ();
75 0 0       0 if ( $script eq $self->build_script ) {
76 0         0 $opts{ntargs} = q(-x -S %0 --build_bat %*);
77 0         0 $opts{otherargs} = q(-x -S "%0" --build_bat %1 %2 %3 %4 %5 %6 %7 %8 %9);
78             }
79              
80 0         0 my $out = eval {$self->pl2bat(in => $script, update => 1, %opts)};
  0         0  
81 0 0       0 if ( $@ ) {
82 0         0 $self->log_warn("WARNING: Unable to convert file '$script' to an executable script:\n$@");
83             } else {
84 0         0 $self->SUPER::make_executable($out);
85             }
86             }
87             }
88             }
89              
90             sub pl2bat {
91 0     0 0 0 my $self = shift;
92 0         0 my %opts = @_;
93 0         0 require ExtUtils::PL2Bat;
94 0         0 return ExtUtils::PL2Bat::pl2bat(%opts);
95             }
96              
97              
98             sub _quote_args {
99             # Returns a string that can become [part of] a command line with
100             # proper quoting so that the subprocess sees this same list of args.
101 0     0   0 my ($self, @args) = @_;
102              
103 0         0 my @quoted;
104              
105 0         0 for (@args) {
106 0 0       0 if ( /^[^\s*?!\$<>;|'"\[\]\{\}]+$/ ) {
107             # Looks pretty safe
108 0         0 push @quoted, $_;
109             } else {
110             # XXX this will obviously have to improve - is there already a
111             # core module lying around that does proper quoting?
112 0         0 s/"/\\"/g;
113 0         0 push @quoted, qq("$_");
114             }
115             }
116              
117 0         0 return join " ", @quoted;
118             }
119              
120              
121             sub split_like_shell {
122             # As it turns out, Windows command-parsing is very different from
123             # Unix command-parsing. Double-quotes mean different things,
124             # backslashes don't necessarily mean escapes, and so on. So we
125             # can't use Text::ParseWords::shellwords() to break a command string
126             # into words. The algorithm below was bashed out by Randy and Ken
127             # (mostly Randy), and there are a lot of regression tests, so we
128             # should feel free to adjust if desired.
129              
130 2850     2850 0 2974203 (my $self, local $_) = @_;
131              
132 2850 100 66     13794 return @$_ if defined() && ref() eq 'ARRAY';
133              
134 2793         4902 my @argv;
135 2793 100 66     9462 return @argv unless defined() && length();
136              
137 2736         4617 my $length = length;
138 2736         13167 m/\G\s*/gc;
139              
140 2736         6498 ARGS: until ( pos == $length ) {
141 3762         5358 my $quote_mode;
142 3762         5700 my $arg = '';
143 3762         6897 CHARS: until ( pos == $length ) {
144 16758 100 100     64695 if ( m/\G((?:\\\\)+)(?=\\?(")?)/gc ) {
    100          
    100          
    100          
    50          
145 570 100       1482 if (defined $2) {
146 399         1653 $arg .= '\\' x (length($1) / 2);
147             }
148             else {
149 171         456 $arg .= $1;
150             }
151             }
152             elsif ( m/\G\\"/gc ) {
153 912         1995 $arg .= '"';
154             }
155             elsif ( m/\G"/gc ) {
156 7239 100 100     18411 if ( $quote_mode && m/\G"/gc ) {
157 798         1596 $arg .= '"';
158             }
159 7239         16188 $quote_mode = !$quote_mode;
160             }
161             elsif ( !$quote_mode && m/\G\s+/gc ) {
162 1083         2109 last;
163             }
164             elsif ( m/\G(.)/sgc ) {
165 6954         17898 $arg .= $1;
166             }
167             }
168 3762         10032 push @argv, $arg;
169             }
170              
171 2736         11001 return @argv;
172             }
173              
174              
175             # system(@cmd) does not like having double-quotes in it on Windows.
176             # So we quote them and run it as a single command.
177             sub do_system {
178 0     0 0   my ($self, @cmd) = @_;
179              
180 0           my $cmd = $self->_quote_args(@cmd);
181 0           my $status = system($cmd);
182 0 0 0       if ($status and $! =~ /Argument list too long/i) {
183 0           my $env_entries = '';
184 0           foreach (sort keys %ENV) { $env_entries .= "$_=>".length($ENV{$_})."; " }
  0            
185 0           warn "'Argument list' was 'too long', env lengths are $env_entries";
186             }
187 0           return !$status;
188             }
189              
190             # Copied from ExtUtils::MM_Win32
191             sub _maybe_command {
192 0     0     my($self,$file) = @_;
193             my @e = exists($ENV{'PATHEXT'})
194             ? split(/;/, $ENV{PATHEXT})
195 0 0         : qw(.com .exe .bat .cmd);
196 0           my $e = '';
197 0           for (@e) { $e .= "\Q$_\E|" }
  0            
198 0           chop $e;
199             # see if file ends in one of the known extensions
200 0 0         if ($file =~ /($e)$/i) {
201 0 0         return $file if -e $file;
202             }
203             else {
204 0           for (@e) {
205 0 0         return "$file$_" if -e "$file$_";
206             }
207             }
208 0           return;
209             }
210              
211              
212             1;
213              
214             __END__