local-lib5/lib/perl5/Module/Build/Platform/Windows.pm

   1 package Module::Build::Platform::Windows;
   2
   3 use strict;
   4 use vars qw($VERSION);
   5 $VERSION = '0.35';
   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 ( lc $basename eq lc $self->build_script ) {
  41     if ( $self->build_bat ) {
  42       $self->log_info("Deleting $basename.bat\n");
  43       my $full_progname = $0;
  44       $full_progname =~ s/(?:\.bat)?$/.bat/i;
  45
  46       # Voodoo required to have a batch file delete itself without error;
  47       # Syntax differs between 9x & NT: the later requires a null arg (???)
  48       require Win32;
  49       my $null_arg = (Win32::IsWinNT()) ? '""' : '';
  50       my $cmd = qq(start $null_arg /min "\%comspec\%" /c del "$full_progname");
  51
  52       my $fh = IO::File->new(">> $basename.bat")
  53         or die "Can't create $basename.bat: $!";
  54       print $fh $cmd;
  55       close $fh ;
  56     } else {
  57       $self->delete_filetree($self->build_script . '.bat');
  58     }
  59   }
  60 }
  61
  62 sub make_executable {
  63   my $self = shift;
  64
  65   $self->SUPER::make_executable(@_);
  66
  67   foreach my $script (@_) {
  68
  69     # Native batch script
  70     if ( $script =~ /\.(bat|cmd)$/ ) {
  71       $self->SUPER::make_executable($script);
  72       next;
  73
  74     # Perl script that needs to be wrapped in a batch script
  75     } else {
  76       my %opts = ();
  77       if ( $script eq $self->build_script ) {
  78         $opts{ntargs}    = q(-x -S %0 --build_bat %*);
  79         $opts{otherargs} = q(-x -S "%0" --build_bat %1 %2 %3 %4 %5 %6 %7 %8 %9);
  80       }
  81
  82       my $out = eval {$self->pl2bat(in => $script, update => 1, %opts)};
  83       if ( $@ ) {
  84         $self->log_warn("WARNING: Unable to convert file '$script' to an executable script:\n$@");
  85       } else {
  86         $self->SUPER::make_executable($out);
  87       }
  88     }
  89   }
  90 }
  91
  92 # This routine was copied almost verbatim from the 'pl2bat' utility
  93 # distributed with perl. It requires too much voodoo with shell quoting
  94 # differences and shortcomings between the various flavors of Windows
  95 # to reliably shell out
  96 sub pl2bat {
  97   my $self = shift;
  98   my %opts = @_;
  99
 100   # NOTE: %0 is already enclosed in doublequotes by cmd.exe, as appropriate
 101   $opts{ntargs}    = '-x -S %0 %*' unless exists $opts{ntargs};
 102   $opts{otherargs} = '-x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9' unless exists $opts{otherargs};
 103
 104   $opts{stripsuffix} = '/\\.plx?/' unless exists $opts{stripsuffix};
 105   $opts{stripsuffix} = ($opts{stripsuffix} =~ m{^/([^/]*[^/\$]|)\$?/?$} ? $1 : "\Q$opts{stripsuffix}\E");
 106
 107   unless (exists $opts{out}) {
 108     $opts{out} = $opts{in};
 109     $opts{out} =~ s/$opts{stripsuffix}$//oi;
 110     $opts{out} .= '.bat' unless $opts{in} =~ /\.bat$/i or $opts{in} =~ /^-$/;
 111   }
 112
 113   my $head = <<EOT;
 114     \@rem = '--*-Perl-*--
 115     \@echo off
 116     if "%OS%" == "Windows_NT" goto WinNT
 117     perl $opts{otherargs}
 118     goto endofperl
 119     :WinNT
 120     perl $opts{ntargs}
 121     if NOT "%COMSPEC%" == "%SystemRoot%\\system32\\cmd.exe" goto endofperl
 122     if %errorlevel% == 9009 echo You do not have Perl in your PATH.
 123     if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
 124     goto endofperl
 125     \@rem ';
 126 EOT
 127
 128   $head =~ s/^\s+//gm;
 129   my $headlines = 2 + ($head =~ tr/\n/\n/);
 130   my $tail = "\n__END__\n:endofperl\n";
 131
 132   my $linedone  = 0;
 133   my $taildone  = 0;
 134   my $linenum   = 0;
 135   my $skiplines = 0;
 136
 137   my $start = $Config{startperl};
 138   $start = "#!perl" unless $start =~ /^#!.*perl/;
 139
 140   my $in = IO::File->new("< $opts{in}") or die "Can't open $opts{in}: $!";
 141   my @file = <$in>;
 142   $in->close;
 143
 144   foreach my $line ( @file ) {
 145     $linenum++;
 146     if ( $line =~ /^:endofperl\b/ ) {
 147       if (!exists $opts{update}) {
 148         warn "$opts{in} has already been converted to a batch file!\n";
 149         return;
 150       }
 151       $taildone++;
 152     }
 153     if ( not $linedone and $line =~ /^#!.*perl/ ) {
 154       if (exists $opts{update}) {
 155         $skiplines = $linenum - 1;
 156         $line .= "#line ".(1+$headlines)."\n";
 157       } else {
 158         $line .= "#line ".($linenum+$headlines)."\n";
 159       }
 160         $linedone++;
 161     }
 162     if ( $line =~ /^#\s*line\b/ and $linenum == 2 + $skiplines ) {
 163       $line = "";
 164     }
 165   }
 166
 167   my $out = IO::File->new("> $opts{out}") or die "Can't open $opts{out}: $!";
 168   print $out $head;
 169   print $out $start, ( $opts{usewarnings} ? " -w" : "" ),
 170              "\n#line ", ($headlines+1), "\n" unless $linedone;
 171   print $out @file[$skiplines..$#file];
 172   print $out $tail unless $taildone;
 173   $out->close;
 174
 175   return $opts{out};
 176 }
 177
 178
 179 sub _quote_args {
 180   # Returns a string that can become [part of] a command line with
 181   # proper quoting so that the subprocess sees this same list of args.
 182   my ($self, @args) = @_;
 183
 184   my @quoted;
 185
 186   for (@args) {
 187     if ( /^[^\s*?!\$<>;|'"\[\]\{\}]+$/ ) {
 188       # Looks pretty safe
 189       push @quoted, $_;
 190     } else {
 191       # XXX this will obviously have to improve - is there already a
 192       # core module lying around that does proper quoting?
 193       s/"/\\"/g;
 194       push @quoted, qq("$_");
 195     }
 196   }
 197
 198   return join " ", @quoted;
 199 }
 200
 201
 202 sub split_like_shell {
 203   # As it turns out, Windows command-parsing is very different from
 204   # Unix command-parsing.  Double-quotes mean different things,
 205   # backslashes don't necessarily mean escapes, and so on.  So we
 206   # can't use Text::ParseWords::shellwords() to break a command string
 207   # into words.  The algorithm below was bashed out by Randy and Ken
 208   # (mostly Randy), and there are a lot of regression tests, so we
 209   # should feel free to adjust if desired.
 210
 211   (my $self, local $_) = @_;
 212
 213   return @$_ if defined() && UNIVERSAL::isa($_, 'ARRAY');
 214
 215   my @argv;
 216   return @argv unless defined() && length();
 217
 218   my $arg = '';
 219   my( $i, $quote_mode ) = ( 0, 0 );
 220
 221   while ( $i < length() ) {
 222
 223     my $ch      = substr( $_, $i  , 1 );
 224     my $next_ch = substr( $_, $i+1, 1 );
 225
 226     if ( $ch eq '\\' && $next_ch eq '"' ) {
 227       $arg .= '"';
 228       $i++;
 229     } elsif ( $ch eq '\\' && $next_ch eq '\\' ) {
 230       $arg .= '\\';
 231       $i++;
 232     } elsif ( $ch eq '"' && $next_ch eq '"' && $quote_mode ) {
 233       $quote_mode = !$quote_mode;
 234       $arg .= '"';
 235       $i++;
 236     } elsif ( $ch eq '"' && $next_ch eq '"' && !$quote_mode &&
 237               ( $i + 2 == length()  ||
 238                 substr( $_, $i + 2, 1 ) eq ' ' )
 239             ) { # for cases like: a"" => [ 'a' ]
 240       push( @argv, $arg );
 241       $arg = '';
 242       $i += 2;
 243     } elsif ( $ch eq '"' ) {
 244       $quote_mode = !$quote_mode;
 245     } elsif ( $ch eq ' ' && !$quote_mode ) {
 246       push( @argv, $arg ) if $arg;
 247       $arg = '';
 248       ++$i while substr( $_, $i + 1, 1 ) eq ' ';
 249     } else {
 250       $arg .= $ch;
 251     }
 252
 253     $i++;
 254   }
 255
 256   push( @argv, $arg ) if defined( $arg ) && length( $arg );
 257   return @argv;
 258 }
 259
 260
 261 # system(@cmd) does not like having double-quotes in it on Windows.
 262 # So we quote them and run it as a single command.
 263 sub do_system {
 264   my ($self, @cmd) = @_;
 265
 266   my $cmd = $self->_quote_args(@cmd);
 267   my $status = system($cmd);
 268   if ($status and $! =~ /Argument list too long/i) {
 269     my $env_entries = '';
 270     foreach (sort keys %ENV) { $env_entries .= "$_=>".length($ENV{$_})."; " }
 271     warn "'Argument list' was 'too long', env lengths are $env_entries";
 272   }
 273   return !$status;
 274 }
 275
 276
 277 1;
 278
 279 __END__
 280
 281 =head1 NAME
 282
 283 Module::Build::Platform::Windows - Builder class for Windows platforms
 284
 285 =head1 DESCRIPTION
 286
 287 The sole purpose of this module is to inherit from
 288 C<Module::Build::Base> and override a few methods.  Please see
 289 L<Module::Build> for the docs.
 290
 291 =head1 AUTHOR
 292
 293 Ken Williams <kwilliams@cpan.org>, Randy W. Sims <RandyS@ThePierianSpring.org>
 294
 295 =head1 SEE ALSO
 296
 297 perl(1), Module::Build(3)
 298
 299 =cut