#!/usr/bin/perl
# 
# Author:       James Brister <brister@vix.com> -- berkeley-unix --
# Start Date:   Fri, 08 Nov 1996 14:48:44 +0100
# Project:      INN
# File:         fixinterps.pl
# RCSId:        $Id: fixinterps.pl,v 1.2 1996/12/16 20:53:50 brister Exp $
# Description:	Fix interpreter scripts based on config.data values (as
#               substituted into innshellvars.pl). This is written for 
#		perl 4.0 on purpose. 
#
#               The normal subst must have been run on innshellvars.pl
#               beforehand. This doesn't get subst'd as it's done 
#               before installation of innshellvars.pl (and hence must 
#               use the one in the samples directory)
# 

require 'getopts.pl' ;

$0 =~ s!.*/!! ;

$usage = "$0 [ -v -n -q ][ -d dir ][ -f innshellvars.pl ][ -t topdir ] file...\n" ;

&Getopts ("vnqd:f:h") || die $usage ;

die $usage if $opt_h ;

$topdir = ($opt_t || "..") ;
if ( ! -d $topdir ) {
    warn "No such directory: $topdir\n" ;
    $die = 1 ;
}

$config = ($opt_f || "$topdir/samples/innshellvars.pl") ;
if ( ! -f $config ) {
    warn "No such file: $config\n" ;
    $die = 1 ;
}

$dir = ( $opt_d || "." ) ;
if ( ! -d $dir ) {
    warn "No such directory: $dir\n" ;
    $die = 1 ;
}

$verbose = $opt_v ;
$quiet = $opt_q ;

exit (1) if $die ;

do "$config" ;

%interps = ( 'perl', $inn'perl,  #'
	    ) ;

$perlver = &perlVersion($interps{'perl'});

chdir ($dir) ;

foreach ( @ARGV ) {
    &fixInterp ($_) ;
}



# fix up the FILE script.
sub fixInterp {
    local ($file) = @_ ;
    local ($newval,$isperl,$line,$warned,$_);

    if ( ! -f $file ) {
	warn "$file: no such file\n" ;
	return ;
    }

    open (INFILE, "<$file") || die "open($file): $!" ;

    chop ($line = <INFILE>) ;

    ($interp = $line) =~ s/^#!\s*(\S+).*/$1/ ;
    ($base = $interp) =~ s!^.*/([^-_.0-9]*).*!$1! ;
    $newval = $interps{$base};
    $isperl = ($base eq "perl");

    if ( ! $newval ) {
	warn "$file: no substitution defined for $base\n" unless $quiet ;
	return ;
    } elsif ( $newval eq $interp ) {
	# Read the script and check that it doesn't require perl 5.x 
	# and that we're substituting in perl4
	while (<INFILE>) {
	    if ($isperl && $perlver < 5.0 && /^\s*require\s+(5\.\S+)/) {
		$warned++;
		warn ("\nWARNING. The script $file requires perl version ".
		      "$1 (or greater),\nbut ".
		      "your perl\n\n\t$newval\n\nlooks to be version " .
		      "$perlver." .
		      " If you're going to use this script you must fix\n" .
		      "this in config.data, or after installation.\n\n") ;
		  }
	}
	close (INFILE) ;
	warn "$file: no change\n" if $verbose ;
	return ;
    }

    $line =~ s/#!(\s*\S+)(.*)/#!$newval$2/ ;

    ($dev,$ino,$mode,$uid,$gid,$atime,$mtime) = (stat INFILE)[0,1,2,4,5,8,9] ;
    $mode = 0755 unless $dev ;
    $mtime = time unless $dev ;

    rename ($file,"$file.bak") ;

    if ( !open (OUTFILE,">$file") ) {
	close (INFILE) ;
	warn "open($file): $!" ;
	return ;
    }

    print OUTFILE "$line\n" ;
    while ( <INFILE> ) {
	if ($isperl && $perlver < 5.0 && /^\s*require\s+(5\.\S+)/) {
	    warn ("\nWARNING. The script $file requires perl version ".
		  "$1 (or greater),\nbut ".
		  "your perl\n\n\t$newval\n\nlooks to be version " .
		  "$perlver." .
		  " If you're going to use this script you must fix\n" .
		  "this in config.data, or after installation.\n\n") ;
	}
	print OUTFILE $_ ;
    }
    close (OUTFILE) ;
		
    chmod $mode, $file ;
    chown ($uid, $gid, $file) if ($> == 0) ;
    utime ($atime,$mtime,$file) || die "utime ($atime,$mtime,$file)" ;

    warn "$file: to $interps{$base}\n" if $verbose ;
    warn "$file: uid is different\n" if ($> != 0 && $uid != $> && !$quiet) ;

    close (INFILE) ;
}
	

sub perlVersion {
    local ($perl) = @_ ;
    local ($line);
    local ($_);
    local ($rval);

    return 0 if (! -x $perl) ;

    open (PERL,"$perl -v|") || die "Can't check version of perl ($perl)\n";
    while (<PERL>) {
	if (/^this\s+is\s+perl,\s+version\s+(\S+)/i) {
	    $rval = $1;
	}
    }
    close (PERL);

    if ($rval !~ /^\d+\.\d+(_\d+|)$/) {
	warn "perl version from $perl looks suspicious: $rval\n";
    }

    return $rval;
}
