lib/Module/Build/Platform/Windows.pm

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