#!/usr/bin/perl -w
#
# guess_install version 1.0.3
#
# Can't be bothered to write an installation script?  Just stick this
# in your distribution as 'install'.  This program is in the public
# domain, meaning no copyright restrictions.  More information at
# <http://membled.com/work/apps/guess_install/>.
#
# -- Ed Avis, ed@membled.com, 2002-10-19
#

use strict;
use Getopt::Long;
use File::Copy;
require Cwd; # 'use Cwd' gives warning on some systems

my $test = 0;
my $prefix;
unless (GetOptions('test!' => \$test, 'prefix=s' => \$prefix)
       and defined $prefix) {
    usage(); exit(1);
}
for ($prefix) {
    if (not m!^/!) {
	die "$0: expected an absolute path for prefix: $prefix\n";
    }
    s!/+$!!;
    (-d) || mkdir($_, 0755) || die "cannot make directory $prefix: $!";
}

# Temporary directory in which temp files can be saved.
my $tmpdir = new_tmpdir();
my $leave = 0;
END {
    unless ($leave) {
	for ($tmpdir) {
	    (not defined) || (not -e) || rmdir || warn "cannot rmdir $_: $!";
	}
    }
}
# Don't remove tempfiles on dying.
$SIG{__DIE__} = sub { $leave = 1 };

my @files = <*>;
my ($biggest_exe, $biggest_exe_size);
foreach (@files) {
    next if not -f;
    next if $_ eq 'install';
    my $size = -s _;
    next if (defined $biggest_exe) && ($size <= $biggest_exe_size);
    if (is_exe($_)) {
	$biggest_exe = $_;
	$biggest_exe_size = $size;
    }
}
if (not defined $biggest_exe) {
    die "can't find any executable, so can't guess package name - aborting\n";
}
my $pkg_name = $biggest_exe;

# Try to get the version number either from the executable or from the
# README.  Look for versions first, and failing that, dates.
#
my @look_for_version_in;
push @look_for_version_in, $biggest_exe if defined $biggest_exe;
push @look_for_version_in, sort <README*>;
my $pkg_version;
foreach my $accept_date (0, 1) {
    foreach (@look_for_version_in) {
	warn("strange file $_"), next if not -f;
	$pkg_version = guess_version($_, $accept_date)
	  if not defined $pkg_version;
    }
}

my $inst_name;
if (defined $pkg_version) {
    $inst_name = "$pkg_name-$pkg_version";
}
else {
    warn "cannot guess version from $biggest_exe\n";
    $inst_name = $pkg_name;
}

# Not every file can be installed directly.  Some will require
# processing (gzipping, making executable, etc.).  We keep a list of
# 'versions' of each file - the first version in the list is the
# original in the source directory, and subsequent versions are
# temporary copies we've fiddled around with.  The last version in the
# list is the one that gets installed.  Obviously, for a file which
# needs no processing, the list will have just one entry and the
# original copy will be the version that gets installed.
#
my %versions; # maps source filename to [ versions ]

# Final resting place of each file.  We don't install anything until
# all the processing is done.  Of course, the file that gets copied in
# will be the last 'version', not necessarily the source file itself.
#
my %dest; # maps source filename to destination filename

# Attributes of files, to be set once they are copied in.  If not
# present for a given source filename, no special chmodding is done.
#
my %attr; # maps source filename to 0755 or whatever (a number)

foreach (@files) {
    if ($_ eq 'install') {
	warn "not installing the installer program 'install' itself\n";
	next;
    }

    if (-d) {
	if (/^[Dd]oc/) {
	    # 'doc' subdirectories are the only kind we handle.
	    my $docdir = $_;
	    my $old_wd = Cwd::cwd();
	    chdir $docdir or die "cannot chdir to $docdir: $!";
	    foreach (<*>) {
		if (-d) {
		    warn "skipping directory $docdir/$_\n";
		}
		elsif (not -f) {
		    warn "$docdir/$_: not a regular file, skipping\n";
		}
		else {
		    $versions{"$docdir/$_"} = [ "$docdir/$_" ];
		    $dest{"$docdir/$_"} = "doc/$inst_name/$_";
		}
	    }
	    chdir $old_wd or die "cannot chdir back to $old_wd: $!";
	}
	else {
	    warn "skipping directory $_\n";
	}
	next;
    }
    elsif (not -f) {
	warn "$_: not a regular file, skipping\n";
	next;
    }

    my @versions = ($_);
    my $dest;
    my $attr;

    if (is_exe($_)) {
	my $tmp = tmpfile_in($tmpdir);
	push @versions, $tmp;
	fix_executable($_, $tmp);
	$dest = "bin/$_";
	$attr = 0755;
    }
    elsif (/^change(?:log|s)(?:\..+)?$/i
	   or /^read\.?me(?:\..+)?$/i
	   or /\.(?:html|txt)$/) {
	$dest = "doc/$inst_name/$_";
    }
    elsif (/\.(\d)$/) {
	# Manual page.  Gzip it before installing.
	my $tmp = tmpfile_in($tmpdir);
	push @versions, $tmp;
	gzip($_, $tmp);
	$dest = "share/man/man$1/$_";
    }
    elsif (/\.man$/) {
	# Precompiled manual page, don't install.
	next;
    }
    else {
	warn "$_: don't know how to install, skipping\n";
	next;
    }

    $versions{$_} = \@versions;
    $dest{$_} = $dest;
    $attr{$_} = $attr if defined $attr;
}

my %destr;
foreach (keys %dest) {
    my ($src, $dest) = ($_, $dest{$_});
    if (not defined $destr{$dest}) {
	$destr{$dest} = $src;
    }
    else {
	die "both $src and $destr{$dest} install as $destr{$dest}\n";
    }
}

foreach (sort keys %versions) {
    my @versions = @{$versions{$_}};
    my $dest = "$prefix/$dest{$_}";
    my $attr = $attr{$_};

    # Print pretty message.
    if (@versions == 0) { die }
    elsif (@versions == 1) {
	print STDERR "$versions[0] -> $dest\n";
    }
    elsif (@versions > 1) {
	print STDERR "$versions[0] -> ... -> $dest\n";
    }
    else { die }

    # Copy the most recent version (after all processing).
    my $final = $versions[$#versions];
    md_copy($final, $dest)
      or die "cannot copy $final to $dest: $!";

    if (defined $attr and not $test) {
	chmod $attr, $dest or die "cannot chmod $attr $dest: $!";
    }

    # Remove the temporary copies.
    if (not $test) {
	foreach (@versions[1 .. $#versions]) {
	    unlink or warn "cannot unlink $_: $!";
	}
    }
}


# Is a file an executable?
sub is_exe {
    my $f = shift;
    (-x $f) && return 1;

    # Not executable, but might be a script.
    for (file($f)) {
	/\bscript\b/     && return 1;
	/\bexecutable\b/ && return 1;
	/\bcommands\b/   && return 1;
    }

    # Give up.
    return 0;
}


# Make a temporary directory.  Although POSIX::tmpnam() is unsafe for
# creating a temporary file, it seems okay to use it to make a
# directory, because mkdir() fails if a directory with the same name
# already exists.  As long as mkdir() is atomic we should be safe.
# (But note DoS due to maximum 1000 tries to choose a filename.  This
# is a lesser evil than the chance of an infinite loop.)
#
# Returns the name of the newly created directory, or dies if it can't
# make one.  It is your responsibility to remove the directory when
# done.
#
sub new_tmpdir {
    use POSIX;
    my $tries = 1000;
    foreach (0 .. $tries-1) {
	my $d = POSIX::tmpnam();
	if ($test) {
	    # Test mode, just assume the directory exists.
	    return $d;
	}
	elsif (mkdir($d, 0755)) {
	    # Made it successfully.
	    return $d;
	}
	elsif ($! eq 'File exists') {
	    # Okay, try again.
	}
	else {
	    # Unexpected error.
	    die "cannot mkdir $d 0755: $!";
	}
    }
    die "cannot make temporary directory, even after $tries tries\n";
}

# Return a new temporary filename in a given directory.  While
# returning a new filename in /tmp/ is inherently unsafe, it's okay to
# do it in a directory that only you can write to.
#
# Returns a filename but does not create it for you.
#
my $tmpfile_counter = 0;
sub tmpfile_in {
    my $d = shift;
    return "$d/" . $tmpfile_counter++;
}

sub usage {
    warn <<END
usage: $0 [--test] [--prefix=<prefix>]
--test flag means don\'t actually install anything, just print
--prefix might be /usr, or /usr/local, etc.
END
;
}

# Guesses the version of a file (an executable or text file).  Returns
# undef if it can't be worked out.
#
# Parameters:
#   filename
#   whether a YYYY-MM-DD date is acceptable as a version number
#
# This routine may run an executable, so don't use it on anything
# untrusted.  $ENV{PATH} will _not_ be searched.
#
sub guess_version {
    my $f = shift;
    my $accept_date = shift;
    my $VERSION_RE = '\b\d+\w*(?:\.\w+)*\b';
    my $DATE_RE = '\b\d{4}-\d\d-\d\d\b'; # ISO 8601 date

    check_filename(\$f);
    if ($f !~ m!^/!) {
	$f = "./$f";
    }

    if (-x $f) {
	# It's a program, run it with --version.
	my $out
	  = `$f --version </dev/null 2>&1 && echo success || echo failure`;
	if (not defined $out) {
	    die "cannot run $f: $!";
	}
	chomp $out;
	if ($out =~ /--version/) {
	    # Looks like an error message from a program that doesn't
	    # grok --version.
	    #
	}
	elsif ($out =~ /\nsuccess$/ and $out =~ /($VERSION_RE)/o) {
	    return $1;
	}
    }

    # Try getting the number straight out of the file (works
    # best with scripts and docs, but binaries might work too).
    #
    my ($got_version, $got_date);
    open (STRINGS, "strings $f |") or die "cannot run strings: $!";
    local $_; # shouldn't be needed, but it is
    while (<STRINGS>) {
	if (/[Vv]ersion\s+($VERSION_RE)/o) {
	    $got_version = $1;
	    last;
	}
	if (/($DATE_RE)/o) {
	    $got_date = $1;
	    # but continue reading since we'd prefer a version number
	}
    }
    if (not close STRINGS) {
	if ($!) {
	    die "cannot close pipe from strings: $!";
	}
	elsif ($got_version or $got_date) {
	    # It's just that strings exited with non-zero status,
	    # probably because we didn't read all its output.
	    #
	}
	else {
	    # Well, we read all its output, so it must have some other
	    # reason to be unhappy.
	    #
	    die "strings returned nonzero status: $?";
	}
    }
    if (defined $got_version) {
	return $got_version;
    }
    elsif (defined $got_date and $accept_date) {
	# Turn YYYY-MM-DD into YYYYMMDD
	$got_date =~ tr/-//d;
	return $got_date;
    }

    # Nope, nothing worked.
    return undef;
}

####
# Special file processors.  These take a source filename (which should
# already exist) and a destination filename (which shouldn't, but the
# directory needs to be there).  They copy source to dest making any
# necessary changes.
#

# Munge an executable so it runs (currently only attempts to fix
# shebang line).  Changes file _contents_ but doesn't do chmod.
#
sub fix_executable {
    return if $test;
    my ($s, $d) = @_;
#    print "copy $s to $d and make exe\n";
    for (file($s)) {
	if (/\bexecutable\b/) {
	    md_copy($s, $d) or die "cannot copy $s to $d: $!";
	}
	elsif (/\b(?:script|commands)\b/) {
	    open(SRC, $s) or die "cannot open $s: $!";
	    chomp (my $first_line = <SRC>);
	    if ($first_line =~ /^\#!\s*(\S+)(.*)$/) {
		# Found shebang line.  Check path to executable.
		my ($exe, $args) = ($1, $2);
		if (-x $exe) {
		    # Okay.
		}
		else {
		    $exe =~ m!([^/]+)$!
		      or die "$s:1:bad shebang line: $first_line";
		    my $interpreter = $1;
		    my $which = which($interpreter);
		    if (not defined $which) {
			die "$s:1:cannot find interpreter $interpreter";
		    }
		    $first_line = "#!$which$args";
		    print "changed shebang line to $first_line\n";
		}
	    }
	    open(DST, ">$d") or die "cannot write to $d: $!";
	    print DST "$first_line\n";
	    while (<SRC>) { print DST $_ }
	    close SRC or warn "cannot close $s: $!";
	    close DST or warn "cannot close $d: $!";
	}
	else {
	    die "unknown output from 'file $s': $_";
	}
    }
}

sub gzip {
    return if $test;
    my ($s, $d) = @_;

    # This slightly paranoid way of running gzip is not strictly
    # necessary (see check_filename()) but it's become a habit.
    #
    local *OLDOUT;
    open(OLDOUT, '>&STDOUT') or die "cannot dup stdout: $!";
    open(STDOUT, ">$d") or die "cannot write to $d: $!";
    my $ok = not system('gzip', '-cv', $s);
    if (not $ok) {
	die "gzip -cv $s failed (system() returned $ok)";
    }
    open(STDOUT, '>&OLDOUT')
      or die "cannot dup stdout back again: $!";
}


# Check that a filename contains no bad characters.  This is because
# we do lots of backticks and stuff and we don't want unexpected
# effects when characters are interpreted by the shell.
#
# Parameter: reference to scalar, which will be modified to untaint it
# (hopefully).  Dies if the filename contains bad characters.
#
sub check_filename {
    my $ref = shift;
    local $_ = $$ref;
    /^([A-Za-z0-9_.,\#~-]*)$/ or die "filename $_ contains bad chars";
    $$ref = $1;
}


# Wrapper for file(1).
sub file {
    my $f = shift;
    check_filename(\$f);
    for (`file $f`) {
	chomp;
	s/^\Q$f\E:\s*//
	  or die "output from 'file $f' doesn't begin with '$f:'\n";
	return $_;
    }
}


# Wrapper for which(1).
sub which {
    my $prog = shift;
    check_filename(\$prog);
    for (`which $prog`) {
	die "cannot find $prog in path" if not defined;
	chomp;
	return $_;
    }
}


# Wrapper for File::Copy::copy which makes directories as needed.  But
# it's not as general as copy(): the destination must be a filename
# within a directory, not a directory name.
#
sub md_copy {
    return 1 if $test;
    my ($s, $d) = @_; die if $d =~ m!/$!;
    my @components;
    local $_ = $d;
    for (;;) {
	s!/+[^/]*$!!;
	last if $_ eq '';
	unshift @components, $_;
    }
    foreach (@components) {
	(-d) || (mkdir($_, 0755)) || die "cannot mkdir $_: $!";
    }
    return copy($s, $d);
}