lib/Module/Build/Platform/Windows.pm

   1 package Module::Build::Platform::Windows;
   2
   3 use strict;
   4 use vars qw($VERSION);
   5 $VERSION = '0.31012';
   6 $VERSION = eval $VERSION;
   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
  23 sub have_forkpipe { 0 }
  24
  25 sub _detildefy {
  26   my ($self, $value) = @_;
  27   $value =~ s,^~(?= [/\\] | $ ),$ENV{HOME},x
  28     if $ENV{HOME};
  29   return $value;
  30 }
  31
  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 (@_) {
  67
  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
  74     } else {
  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       }
  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 _quote_args {
 179   # Returns a string that can become [part of] a command line with
 180   # proper quoting so that the subprocess sees this same list of args.
 181   my ($self, @args) = @_;
 182
 183   my @quoted;
 184
 185   for (@args) {
 186     if ( /^[^\s*?!\$<>;|'"\[\]\{\}]+$/ ) {
 187       # Looks pretty safe
 188       push @quoted, $_;
 189     } else {
 190       # XXX this will obviously have to improve - is there already a
 191       # core module lying around that does proper quoting?
 192       s/"/\\"/g;
 193       push @quoted, qq("$_");
 194     }
 195   }
 196
 197   return join " ", @quoted;
 198 }
 199
 200
 201 sub split_like_shell {
 202   # As it turns out, Windows command-parsing is very different from
 203   # Unix command-parsing.  Double-quotes mean different things,
 204   # backslashes don't necessarily mean escapes, and so on.  So we
 205   # can't use Text::ParseWords::shellwords() to break a command string
 206   # into words.  The algorithm below was bashed out by Randy and Ken
 207   # (mostly Randy), and there are a lot of regression tests, so we
 208   # should feel free to adjust if desired.
 209
 210   (my $self, local $_) = @_;
 211
 212   return @$_ if defined() && UNIVERSAL::isa($_, 'ARRAY');
 213
 214   my @argv;
 215   return @argv unless defined() && length();
 216
 217   my $arg = '';
 218   my( $i, $quote_mode ) = ( 0, 0 );
 219
 220   while ( $i < length() ) {
 221
 222     my $ch      = substr( $_, $i  , 1 );
 223     my $next_ch = substr( $_, $i+1, 1 );
 224
 225     if ( $ch eq '\\' && $next_ch eq '"' ) {
 226       $arg .= '"';
 227       $i++;
 228     } elsif ( $ch eq '\\' && $next_ch eq '\\' ) {
 229       $arg .= '\\';
 230       $i++;
 231     } elsif ( $ch eq '"' && $next_ch eq '"' && $quote_mode ) {
 232       $quote_mode = !$quote_mode;
 233       $arg .= '"';
 234       $i++;
 235     } elsif ( $ch eq '"' && $next_ch eq '"' && !$quote_mode &&
 236               ( $i + 2 == length()  ||
 237                 substr( $_, $i + 2, 1 ) eq ' ' )
 238             ) { # for cases like: a"" => [ 'a' ]
 239       push( @argv, $arg );
 240       $arg = '';
 241       $i += 2;
 242     } elsif ( $ch eq '"' ) {
 243       $quote_mode = !$quote_mode;
 244     } elsif ( $ch eq ' ' && !$quote_mode ) {
 245       push( @argv, $arg ) if $arg;
 246       $arg = '';
 247       ++$i while substr( $_, $i + 1, 1 ) eq ' ';
 248     } else {
 249       $arg .= $ch;
 250     }
 251
 252     $i++;
 253   }
 254
 255   push( @argv, $arg ) if defined( $arg ) && length( $arg );
 256   return @argv;
 257 }
 258
 259
 260 # system(@cmd) does not like having double-quotes in it on Windows.
 261 # So we quote them and run it as a single command.
 262 sub do_system {
 263   my ($self, @cmd) = @_;
 264
 265   my $cmd = $self->_quote_args(@cmd);
 266   my $status = system($cmd);
 267   if ($status and $! =~ /Argument list too long/i) {
 268     my $env_entries = '';
 269     foreach (sort keys %ENV) { $env_entries .= "$_=>".length($ENV{$_})."; " }
 270     warn "'Argument list' was 'too long', env lengths are $env_entries";
 271   }
 272   return !$status;
 273 }
 274
 275
 276 1;
 277
 278 __END__
 279
 280 =head1 NAME
 281
 282 Module::Build::Platform::Windows - Builder class for Windows platforms
 283
 284 =head1 DESCRIPTION
 285
 286 The sole purpose of this module is to inherit from
 287 C<Module::Build::Base> and override a few methods.  Please see
 288 L<Module::Build> for the docs.
 289
 290 =head1 AUTHOR
 291
 292 Ken Williams <kwilliams@cpan.org>, Randy W. Sims <RandyS@ThePierianSpring.org>
 293
 294 =head1 SEE ALSO
 295
 296 perl(1), Module::Build(3)
 297
 298 =cut