diff options
Diffstat (limited to 'lib/ExtUtils/Helpers/Windows.pm')
| -rw-r--r-- | lib/ExtUtils/Helpers/Windows.pm | 214 |
1 files changed, 214 insertions, 0 deletions
diff --git a/lib/ExtUtils/Helpers/Windows.pm b/lib/ExtUtils/Helpers/Windows.pm new file mode 100644 index 0000000..62d38d1 --- /dev/null +++ b/lib/ExtUtils/Helpers/Windows.pm @@ -0,0 +1,214 @@ +package ExtUtils::Helpers::Windows; +$ExtUtils::Helpers::Windows::VERSION = '0.022'; +use strict; +use warnings FATAL => 'all'; + +use Exporter 5.57 'import'; +our @EXPORT = qw/make_executable split_like_shell detildefy/; + +use Config; +use Carp qw/carp croak/; + +sub make_executable { + my $script = shift; + if (-T $script && $script !~ / \. (?:bat|cmd) $ /x) { + _pl2bat(in => $script, update => 1); + } + return; +} + +# 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 %opts = @_; + + # NOTE: %0 is already enclosed in doublequotes by cmd.exe, as appropriate + $opts{ntargs} = '-x -S %0 %*'; + $opts{otherargs} = '-x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9'; + + $opts{stripsuffix} = qr/\.plx?/ unless exists $opts{stripsuffix}; + + if (not exists $opts{out}) { + $opts{out} = $opts{in}; + $opts{out} =~ s/$opts{stripsuffix}$//i; + $opts{out} .= '.bat' unless $opts{in} =~ /\.bat$/i or $opts{in} eq '-'; + } + + my $head = <<"EOT"; + \@rem = '--*-Perl-*-- + \@echo off + if "%OS%" == "Windows_NT" goto WinNT + perl $opts{otherargs} + \@set ErrorLevel=%ErrorLevel% + goto endofperl + :WinNT + perl $opts{ntargs} + \@set ErrorLevel=%ErrorLevel% + if NOT "%COMSPEC%" == "%SystemRoot%\\system32\\cmd.exe" goto endofperl + if %errorlevel% == 9009 echo You do not have Perl in your PATH. + goto endofperl + \@rem '; +EOT + + $head =~ s/^\s+//gm; + my $headlines = 2 + ($head =~ tr/\n/\n/); + my $tail = <<'EOT'; + __END__ + :endofperl + @"%COMSPEC%" /c exit /b %ErrorLevel% +EOT + $tail =~ s/^\s+//gm; + + my $linedone = 0; + my $taildone = 0; + my $linenum = 0; + my $skiplines = 0; + + my $start = $Config{startperl}; + $start = '#!perl' unless $start =~ /^#!.*perl/; + + open my $in, '<', $opts{in} or croak "Can't open $opts{in}: $!"; + my @file = <$in>; + close $in; + + 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 = ''; + } + } + + open my $out, '>', $opts{out} or croak "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; + close $out; + + 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. + + local ($_) = @_; + + 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 =~ /\s/ && !$quote_mode ) { + push @argv, $arg if $arg; + $arg = ''; + ++$i while substr( $_, $i + 1, 1 ) =~ /\s/; + } else { + $arg .= $ch; + } + + $i++; + } + + push @argv, $arg if defined $arg && length $arg; + return @argv; +} + +sub detildefy { + my $value = shift; + $value =~ s{ ^ ~ (?= [/\\] | $ ) }[$ENV{USERPROFILE}]x if $ENV{USERPROFILE}; + return $value; +} + +1; + +# ABSTRACT: Windows specific helper bits + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +ExtUtils::Helpers::Windows - Windows specific helper bits + +=head1 VERSION + +version 0.022 + +=for Pod::Coverage make_executable +split_like_shell +detildefy + +=head1 AUTHORS + +=over 4 + +=item * + +Ken Williams <kwilliams@cpan.org> + +=item * + +Leon Timmermans <leont@cpan.org> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2004 by Ken Williams, Leon Timmermans. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut |