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

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

use strict;
use vars qw($VERSION);
$VERSION = '0.3603';
$VERSION = eval $VERSION;

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 _detildefy {
  my ($self, $value) = @_;
  $value =~ s,^~(?= [/\\] | $ ),$ENV{HOME},x
    if $ENV{HOME};
  return $value;
}

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

  $self->SUPER::ACTION_realclean();

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

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

      # Voodoo 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 voodoo 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 _quote_args {
  # Returns a string that can become [part of] a command line with
  # proper quoting so that the subprocess sees this same list of args.
  my ($self, @args) = @_;

  my @quoted;

  for (@args) {
    if ( /^[^\s*?!\$<>;|'"\[\]\{\}]+$/ ) {
      # Looks pretty safe
      push @quoted, $_;
    } else {
      # XXX this will obviously have to improve - is there already a
      # core module lying around that does proper quoting?
      s/"/\\"/g;
      push @quoted, qq("$_");
    }
  }

  return join " ", @quoted;
}


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;
}


# system(@cmd) does not like having double-quotes in it on Windows.
# So we quote them and run it as a single command.
sub do_system {
  my ($self, @cmd) = @_;

  my $cmd = $self->_quote_args(@cmd);
  my $status = system($cmd);
  if ($status and $! =~ /Argument list too long/i) {
    my $env_entries = '';
    foreach (sort keys %ENV) { $env_entries .= "$_=>".length($ENV{$_})."; " }
    warn "'Argument list' was 'too long', env lengths are $env_entries";
  }
  return !$status;
}

# Copied from ExtUtils::MM_Win32
sub _maybe_command {
    my($self,$file) = @_;
    my @e = exists($ENV{'PATHEXT'})
          ? split(/;/, $ENV{PATHEXT})
	  : qw(.com .exe .bat .cmd);
    my $e = '';
    for (@e) { $e .= "\Q$_\E|" }
    chop $e;
    # see if file ends in one of the known extensions
    if ($file =~ /($e)$/i) {
	return $file if -e $file;
    }
    else {
	for (@e) {
	    return "$file$_" if -e "$file$_";
	}
    }
    return;
}


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 <kwilliams@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;
7a827510	4	use vars qw($VERSION);
7dc9e1b4	5	$VERSION = '0.3603';
7a827510	6	$VERSION = eval $VERSION;
bb4e9162	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
dc8021d3	23	sub have_forkpipe { 0 }
a314697d	24
7a827510	25	sub _detildefy {
	26	my ($self, $value) = @_;
	27	$value =~ s,^~(?= [/\\] \| $ ),$ENV{HOME},x
	28	if $ENV{HOME};
	29	return $value;
	30	}
	31
bb4e9162	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
23837600	40	if ( lc $basename eq lc $self->build_script ) {
bb4e9162	41	if ( $self->build_bat ) {
613f422f	42	$self->log_verbose("Deleting $basename.bat\n");
bb4e9162	43	my $full_progname = $0;
	44	$full_progname =~ s/(?:\.bat)?$/.bat/i;
	45
23837600	46	# Voodoo required to have a batch file delete itself without error;
bb4e9162	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 (@_) {
bb4e9162	68
f943a5bf	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
bb4e9162	75	} else {
f943a5bf	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	}
bb4e9162	88	}
	89	}
	90	}
	91
	92	# This routine was copied almost verbatim from the 'pl2bat' utility
23837600	93	# distributed with perl. It requires too much voodoo with shell quoting
bb4e9162	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
738349a8	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
bb4e9162	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.
53fc1c7e	210
bb4e9162	211	(my $self, local $_) = @_;
53fc1c7e	212
bb4e9162	213	return @$_ if defined() && UNIVERSAL::isa($_, 'ARRAY');
53fc1c7e	214
bb4e9162	215	my @argv;
bb4e9162	216	return @argv unless defined() && length();
53fc1c7e	217
bb4e9162	218	my $arg = '';
bb4e9162	219	my( $i, $quote_mode ) = ( 0, 0 );
53fc1c7e	220
bb4e9162	221	while ( $i < length() ) {
53fc1c7e	222
bb4e9162	223	my $ch = substr( $_, $i , 1 );
bb4e9162	224	my $next_ch = substr( $_, $i+1, 1 );
53fc1c7e	225
bb4e9162	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	}
53fc1c7e	252
bb4e9162	253	$i++;
bb4e9162	254	}
53fc1c7e	255
bb4e9162	256	push( @argv, $arg ) if defined( $arg ) && length( $arg );
	257	return @argv;
	258	}
	259
738349a8	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
613f422f	276	# Copied from ExtUtils::MM_Win32
	277	sub _maybe_command {
	278	my($self,$file) = @_;
	279	my @e = exists($ENV{'PATHEXT'})
	280	? split(/;/, $ENV{PATHEXT})
	281	: qw(.com .exe .bat .cmd);
	282	my $e = '';
	283	for (@e) { $e .= "\Q$_\E\|" }
	284	chop $e;
	285	# see if file ends in one of the known extensions
	286	if ($file =~ /($e)$/i) {
	287	return $file if -e $file;
	288	}
	289	else {
	290	for (@e) {
	291	return "$file$_" if -e "$file$_";
	292	}
	293	}
	294	return;
	295	}
	296
738349a8	297
bb4e9162	298	1;
	299
	300	__END__
	301
	302	=head1 NAME
	303
	304	Module::Build::Platform::Windows - Builder class for Windows platforms
	305
	306	=head1 DESCRIPTION
	307
	308	The sole purpose of this module is to inherit from
	309	C<Module::Build::Base> and override a few methods. Please see
	310	L<Module::Build> for the docs.
	311
	312	=head1 AUTHOR
	313
77e96e88	314	Ken Williams <kwilliams@cpan.org>, Randy W. Sims <RandyS@ThePierianSpring.org>
bb4e9162	315
	316	=head1 SEE ALSO
	317
	318	perl(1), Module::Build(3)
	319
	320	=cut