[p5sagit/p5-mst-13.2.git] / lib / Module / Build / Platform / Windows.pm

package Module::Build::Platform::Windows;

use strict;

use Config;
use File::Basename;
use File::Spec;
use IO::File;

use Module::Build::Base;

use vars qw(@ISA);
@ISA = qw(Module::Build::Base);


sub manpage_separator {
    return '.';
}

sub have_forkpipe { 0 }

sub ACTION_realclean {
  my ($self) = @_;

  $self->SUPER::ACTION_realclean();

  my $basename = basename($0);
  $basename =~ s/(?:\.bat)?$//i;

  if ( $basename eq $self->build_script ) {
    if ( $self->build_bat ) {
      my $full_progname = $0;
      $full_progname =~ s/(?:\.bat)?$/.bat/i;

      # Vodoo required to have a batch file delete itself without error;
      # Syntax differs between 9x & NT: the later requires a null arg (???)
      require Win32;
      my $null_arg = (Win32::IsWinNT()) ? '""' : '';
      my $cmd = qq(start $null_arg /min "\%comspec\%" /c del "$full_progname");

      my $fh = IO::File->new(">> $basename.bat")
        or die "Can't create $basename.bat: $!";
      print $fh $cmd;
      close $fh ;
    } else {
      $self->delete_filetree($self->build_script . '.bat');
    }
  }
}

sub make_executable {
  my $self = shift;

  $self->SUPER::make_executable(@_);

  foreach my $script (@_) {

    # Native batch script
    if ( $script =~ /\.(bat|cmd)$/ ) {
      $self->SUPER::make_executable($script);
      next;

    # Perl script that needs to be wrapped in a batch script
    } else {
      my %opts = ();
      if ( $script eq $self->build_script ) {
        $opts{ntargs}    = q(-x -S %0 --build_bat %*);
        $opts{otherargs} = q(-x -S "%0" --build_bat %1 %2 %3 %4 %5 %6 %7 %8 %9);
      }

      my $out = eval {$self->pl2bat(in => $script, update => 1, %opts)};
      if ( $@ ) {
        $self->log_warn("WARNING: Unable to convert file '$script' to an executable script:\n$@");
      } else {
        $self->SUPER::make_executable($out);
      }
    }
  }
}

# This routine was copied almost verbatim from the 'pl2bat' utility
# distributed with perl. It requires too much vodoo with shell quoting
# differences and shortcomings between the various flavors of Windows
# to reliably shell out
sub pl2bat {
  my $self = shift;
  my %opts = @_;

  # NOTE: %0 is already enclosed in doublequotes by cmd.exe, as appropriate
  $opts{ntargs}    = '-x -S %0 %*' unless exists $opts{ntargs};
  $opts{otherargs} = '-x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9' unless exists $opts{otherargs};

  $opts{stripsuffix} = '/\\.plx?/' unless exists $opts{stripsuffix};
  $opts{stripsuffix} = ($opts{stripsuffix} =~ m{^/([^/]*[^/\$]|)\$?/?$} ? $1 : "\Q$opts{stripsuffix}\E");

  unless (exists $opts{out}) {
    $opts{out} = $opts{in};
    $opts{out} =~ s/$opts{stripsuffix}$//oi;
    $opts{out} .= '.bat' unless $opts{in} =~ /\.bat$/i or $opts{in} =~ /^-$/;
  }

  my $head = <<EOT;
    \@rem = '--*-Perl-*--
    \@echo off
    if "%OS%" == "Windows_NT" goto WinNT
    perl $opts{otherargs}
    goto endofperl
    :WinNT
    perl $opts{ntargs}
    if NOT "%COMSPEC%" == "%SystemRoot%\\system32\\cmd.exe" goto endofperl
    if %errorlevel% == 9009 echo You do not have Perl in your PATH.
    if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
    goto endofperl
    \@rem ';
EOT

  $head =~ s/^\s+//gm;
  my $headlines = 2 + ($head =~ tr/\n/\n/);
  my $tail = "\n__END__\n:endofperl\n";

  my $linedone  = 0;
  my $taildone  = 0;
  my $linenum   = 0;
  my $skiplines = 0;

  my $start = $Config{startperl};
  $start = "#!perl" unless $start =~ /^#!.*perl/;

  my $in = IO::File->new("< $opts{in}") or die "Can't open $opts{in}: $!";
  my @file = <$in>;
  $in->close;

  foreach my $line ( @file ) {
    $linenum++;
    if ( $line =~ /^:endofperl\b/ ) {
      if (!exists $opts{update}) {
        warn "$opts{in} has already been converted to a batch file!\n";
        return;
      }
      $taildone++;
    }
    if ( not $linedone and $line =~ /^#!.*perl/ ) {
      if (exists $opts{update}) {
        $skiplines = $linenum - 1;
        $line .= "#line ".(1+$headlines)."\n";
      } else {
	$line .= "#line ".($linenum+$headlines)."\n";
      }
	$linedone++;
    }
    if ( $line =~ /^#\s*line\b/ and $linenum == 2 + $skiplines ) {
      $line = "";
    }
  }

  my $out = IO::File->new("> $opts{out}") or die "Can't open $opts{out}: $!";
  print $out $head;
  print $out $start, ( $opts{usewarnings} ? " -w" : "" ),
             "\n#line ", ($headlines+1), "\n" unless $linedone;
  print $out @file[$skiplines..$#file];
  print $out $tail unless $taildone;
  $out->close;

  return $opts{out};
}


sub split_like_shell {
  # As it turns out, Windows command-parsing is very different from
  # Unix command-parsing.  Double-quotes mean different things,
  # backslashes don't necessarily mean escapes, and so on.  So we
  # can't use Text::ParseWords::shellwords() to break a command string
  # into words.  The algorithm below was bashed out by Randy and Ken
  # (mostly Randy), and there are a lot of regression tests, so we
  # should feel free to adjust if desired.
  
  (my $self, local $_) = @_;
  
  return @$_ if defined() && UNIVERSAL::isa($_, 'ARRAY');
  
  my @argv;
  return @argv unless defined() && length();
  
  my $arg = '';
  my( $i, $quote_mode ) = ( 0, 0 );
  
  while ( $i < length() ) {
    
    my $ch      = substr( $_, $i  , 1 );
    my $next_ch = substr( $_, $i+1, 1 );
    
    if ( $ch eq '\\' && $next_ch eq '"' ) {
      $arg .= '"';
      $i++;
    } elsif ( $ch eq '\\' && $next_ch eq '\\' ) {
      $arg .= '\\';
      $i++;
    } elsif ( $ch eq '"' && $next_ch eq '"' && $quote_mode ) {
      $quote_mode = !$quote_mode;
      $arg .= '"';
      $i++;
    } elsif ( $ch eq '"' && $next_ch eq '"' && !$quote_mode &&
	      ( $i + 2 == length()  ||
		substr( $_, $i + 2, 1 ) eq ' ' )
	    ) { # for cases like: a"" => [ 'a' ]
      push( @argv, $arg );
      $arg = '';
      $i += 2;
    } elsif ( $ch eq '"' ) {
      $quote_mode = !$quote_mode;
    } elsif ( $ch eq ' ' && !$quote_mode ) {
      push( @argv, $arg ) if $arg;
      $arg = '';
      ++$i while substr( $_, $i + 1, 1 ) eq ' ';
    } else {
      $arg .= $ch;
    }
    
    $i++;
  }
  
  push( @argv, $arg ) if defined( $arg ) && length( $arg );
  return @argv;
}

1;

__END__

=head1 NAME

Module::Build::Platform::Windows - Builder class for Windows platforms

=head1 DESCRIPTION

The sole purpose of this module is to inherit from
C<Module::Build::Base> and override a few methods.  Please see
L<Module::Build> for the docs.

=head1 AUTHOR

Ken Williams <ken@cpan.org>, Randy W. Sims <RandyS@ThePierianSpring.org>

=head1 SEE ALSO

perl(1), Module::Build(3)

=cut
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 (@_) {
bb4e9162	57
f943a5bf	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
bb4e9162	64	} else {
f943a5bf	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	}
bb4e9162	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