# $Id: insertperl.pl.root 449 2005-05-31 19:07:04Z nodine $
use strict;
use Carp;
use Config;
use File::Basename qw(basename dirname fileparse);
use File::Spec;
use DirHandle;
use Text::Restructured::PrestConfig;
use vars qw($VERSION @ISA
            $Is_Mac $Is_OS2 $Is_VMS $Is_Win32 $Is_Dos $Is_VOS
            $Verbose %pm %static $Xsubpp_Version
            %Config_Override
           );
my $taintflag = $Text::Restructured::PrestConfig::TAINT =~ /^y/i ? ' -T' : '';
my $perl_exec = "$^X$taintflag";
my($does_shbang) = $Config{'sharpbang'} =~ /^\s*\#\!/;
foreach my $file (@ARGV) {
    local (*FIXIN);
    local (*FIXOUT);
    open FIXIN, $file or croak "Can't read '$file': $1";
    local $/ = "\n";
    chomp (my $line = <FIXIN>);
    next unless $line =~ s/^\s*\#!\s*//;     # Not a shbang file.
    # Now figure out the interpreter name.
    my($cmd,$arg) = split ' ', $line, 2;
    $cmd =~ s!^.*/!!;
    my $interpreter;
    if ($cmd eq "perl") {
        $interpreter = $perl_exec;
    }
    else {
        my(@absdirs) = reverse grep {File::Spec->file_name_is_absolute} File::Spec->path;
        $interpreter = '';
        my($dir);
        foreach $dir (@absdirs) {
            if (maybe_command($cmd)) {
                warn "Ignoring $interpreter in $file\n" if $Verbose && $interpreter;
                $interpreter = File::Spec->catfile($dir,$cmd);
            }
        }
    }
    # Figure out how to invoke interpreter on this machine.
    my($shb) = "";
    if ($interpreter) {
        print STDOUT "Changing sharpbang in $file to $interpreter" if $Verbose;
        # this is probably value-free on DOSISH platforms
        if ($does_shbang) {
            $shb .= "$Config{'sharpbang'}$interpreter";
            $shb .= ' ' . $arg if defined $arg;
            $shb .= "\n";
        }
        $shb .= qq{
            eval 'exec $interpreter $arg -S \$0 \${1+"\$\@"}'
                if 0; # not running under some shell
        } unless $Is_Win32; # this won't work on win32, so don't
    } else {
        warn "Can't find $cmd in PATH, $file unchanged"
            if $Verbose;
        next;
    }
    unless ( open(FIXOUT,">$file.new") ) {
        warn "Can't create new $file: $!\n";
        next;
    }
    my($dev,$ino,$mode) = stat FIXIN;
     
    # Print out the new #! line (or equivalent).
    local $\;
    undef $/;
    print FIXOUT $shb, <FIXIN>;
    close FIXIN;
    close FIXOUT;
    unless ( rename($file, "$file.bak") ) {     
        warn "Can't rename $file to $file.bak: $!";
        next;
    }
    unless ( rename("$file.new", $file) ) {     
        warn "Can't rename $file.new to $file: $!";
        unless ( rename("$file.bak", $file) ) {
            warn "Can't rename $file.bak back to $file either: $!";
            warn "Leaving $file renamed as $file.bak\n";
        }
        next;
    }
    unlink "$file.bak";
} continue {
    close(FIXIN) if fileno(FIXIN);
    system("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';;
}
sub maybe_command {
    my($file) = @_;
    return $file if -x $file && ! -d $file;
    return;
}