[ Index ]

PHP Cross Reference of Unnamed Project

title

Body

[close]

/se3-unattended/var/se3/unattended/install/linuxaux/opt/perl/lib/5.10.0/Module/Build/Platform/ -> Windows.pm (source)

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


Generated: Tue Mar 17 22:47:18 2015 Cross-referenced by PHPXref 0.7.1