prest/insertperl.pl

   1 # $Id: insertperl.pl.root 449 2005-05-31 19:07:04Z nodine $
   2
   3 use strict;
   4
   5 use Carp;
   6 use Config;
   7 use File::Basename qw(basename dirname fileparse);
   8 use File::Spec;
   9 use DirHandle;
  10
  11 use Text::Restructured::PrestConfig;
  12
  13 use vars qw($VERSION @ISA
  14             $Is_Mac $Is_OS2 $Is_VMS $Is_Win32 $Is_Dos $Is_VOS
  15             $Verbose %pm %static $Xsubpp_Version
  16             %Config_Override
  17            );
  18
  19 my $taintflag = $Text::Restructured::PrestConfig::TAINT =~ /^y/i ? ' -T' : '';
  20 my $perl_exec = "$^X$taintflag";
  21
  22 my($does_shbang) = $Config{'sharpbang'} =~ /^\s*\#\!/;
  23 foreach my $file (@ARGV) {
  24     local (*FIXIN);
  25     local (*FIXOUT);
  26     open FIXIN, $file or croak "Can't read '$file': $1";
  27     local $/ = "\n";
  28     chomp (my $line = <FIXIN>);
  29     next unless $line =~ s/^\s*\#!\s*//;     # Not a shbang file.
  30     # Now figure out the interpreter name.
  31     my($cmd,$arg) = split ' ', $line, 2;
  32     $cmd =~ s!^.*/!!;
  33     my $interpreter;
  34     if ($cmd eq "perl") {
  35         $interpreter = $perl_exec;
  36     }
  37     else {
  38         my(@absdirs) = reverse grep {File::Spec->file_name_is_absolute} File::Spec->path;
  39         $interpreter = '';
  40         my($dir);
  41         foreach $dir (@absdirs) {
  42             if (maybe_command($cmd)) {
  43                 warn "Ignoring $interpreter in $file\n" if $Verbose && $interpreter;
  44                 $interpreter = File::Spec->catfile($dir,$cmd);
  45             }
  46         }
  47     }
  48     # Figure out how to invoke interpreter on this machine.
  49
  50     my($shb) = "";
  51     if ($interpreter) {
  52         print STDOUT "Changing sharpbang in $file to $interpreter" if $Verbose;
  53         # this is probably value-free on DOSISH platforms
  54         if ($does_shbang) {
  55             $shb .= "$Config{'sharpbang'}$interpreter";
  56             $shb .= ' ' . $arg if defined $arg;
  57             $shb .= "\n";
  58         }
  59         $shb .= qq{
  60             eval 'exec $interpreter $arg -S \$0 \${1+"\$\@"}'
  61                 if 0; # not running under some shell
  62         } unless $Is_Win32; # this won't work on win32, so don't
  63     } else {
  64         warn "Can't find $cmd in PATH, $file unchanged"
  65             if $Verbose;
  66         next;
  67     }
  68
  69     unless ( open(FIXOUT,">$file.new") ) {
  70         warn "Can't create new $file: $!\n";
  71         next;
  72     }
  73     my($dev,$ino,$mode) = stat FIXIN;
  74
  75     # Print out the new #! line (or equivalent).
  76     local $\;
  77     undef $/;
  78     print FIXOUT $shb, <FIXIN>;
  79     close FIXIN;
  80     close FIXOUT;
  81
  82     unless ( rename($file, "$file.bak") ) {
  83         warn "Can't rename $file to $file.bak: $!";
  84         next;
  85     }
  86     unless ( rename("$file.new", $file) ) {
  87         warn "Can't rename $file.new to $file: $!";
  88         unless ( rename("$file.bak", $file) ) {
  89             warn "Can't rename $file.bak back to $file either: $!";
  90             warn "Leaving $file renamed as $file.bak\n";
  91         }
  92         next;
  93     }
  94     unlink "$file.bak";
  95 } continue {
  96     close(FIXIN) if fileno(FIXIN);
  97     system("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';;
  98 }
  99
 100 sub maybe_command {
 101     my($file) = @_;
 102     return $file if -x $file && ! -d $file;
 103     return;
 104 }
 105