#! /usr/bin/env perl

############################################################################
#
#	ghetto-stow - manage installed software
#	Copyright (c) 2008,2012  Wessel Dankers <wsl@uvt.nl>
#
#	This program is free software: you can redistribute it and/or modify
#	it under the terms of the GNU General Public License as published by
#	the Free Software Foundation, either version 3 of the License, or
#	(at your option) any later version.
#
#	This program is distributed in the hope that it will be useful,
#	but WITHOUT ANY WARRANTY; without even the implied warranty of
#	MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#	GNU General Public License for more details.
#
#	You should have received a copy of the GNU General Public License
#	along with this program.  If not, see <http://www.gnu.org/licenses/>.
#
#	$Id: gstow.pl 37289 2012-06-26 19:16:15Z wsl $
#	$URL: https://svn.uvt.nl/its-id/trunk/sources/ghetto-stow/gstow.pl $
#
############################################################################

use strict;
use warnings FATAL => 'all';
use utf8;

use Getopt::Long qw(:config gnu_getopt);

our $PACKAGE //= 'ghetto-stow';
our $VERSION //= q$Id: gstow.pl 37289 2012-06-26 19:16:15Z wsl $;

my $src = '/opt';
my $dst = '/usr/local';

my $verbose = 0;
my $mode = 'install';
my $dryrun = 0;

my $warned = 0;
$SIG{__WARN__} = sub { $warned++; warn @_ };

# match anthing except the empty string, ‘.’ and ‘..’
my $dotdot = qr{^\.\.?$};

sub info {
	return if shift > $verbose;
	my $msg = shift;
	$msg .= '('.join(', ', @_).")\n";
	print $msg or die "print: $!";
}

sub hashify {
	my %h;
	@h{@_} = ();
	return \%h;
}

sub vcmp {
	my ($a, $b) = @_;
	my $tie = 0;
	my @a = split(/(\d+)/, $a);
	my @b = split(/(\d+)/, $b);
	for(;;) {
		return @b ? -1 : $tie unless @a;
		return 1 unless @b;
		$a = shift @a;
		$b = shift @b;
		if(my $c = lc($a) cmp lc($b)) {
			return $c;
		}
		if(my $c = $a cmp $b) {
			return $c;
		}

		return @b ? -1 : $tie unless @a;
		return 1 unless @b;
		$a = shift @a;
		$b = shift @b;
		if(my $c = ($a || 0) <=> ($b || 0)) {
			return $c;
		}
		$tie ||= $a cmp $b;
	}
}

sub chop_prefix {
	my ($p, $s) = @_;
	my $pl = length $p;
	my $sl = length $s;
	return undef if $sl < $pl;
	my $r = substr $s, 0, $pl, '';
	return undef if $r ne $p;
	return $s;
}

# For recurse_src, $func returns a boolean indicating whether the entry
# is a directory and should be recursed into.

sub _recurse_src {
	my $func = shift;
	my $pkg = shift;

	foreach my $ent (@_) {
		if($func->($pkg, $ent)) {
			my $src_abs = "$src/$pkg/$ent";
			if(opendir(DIR, $src_abs)) {
				my @ents = grep { !/$dotdot/o } readdir(DIR);
				closedir DIR;
				_recurse_src($func, $pkg, map { "$ent/$_" } @ents);
			} else {
				die "($pkg) Can't open $src_abs: $!\n"
			}
		}
	}
}

sub recurse_src {
	my $func = shift;

	foreach my $pkg (@_) {
		my $src_abs = "$src/$pkg";
		die "($pkg) $src_abs is not a directory\n" unless -d $src_abs;

		if(opendir(DIR, $src_abs)) {
			my @ents = grep { !/$dotdot/o } readdir(DIR);
			closedir DIR;
			_recurse_src($func, $pkg, @ents);
		} else {
			die "($pkg) Can't open $src_abs: $!\n"
		}
	}
}

# For recurse_dst, $func returns a boolean indicating whether the entry
# was removed. It gets the number of entries in the directory as an
# argument, or undef if it's not a directory. It also gets a boolean
# as an argument that indicates whether this is a symlink or not.

sub _recurse_dst {
	my $func = shift;
	my $pkgs = shift;

	my $count = 0;
	foreach my $ent (@_) {
		my $dst_abs = "$dst/$ent";
		my $res;
		my $tot;
		my $islink;
		lstat $dst_abs;
		if(-d _) {
			if(opendir(DIR, $dst_abs)) {
				my @ents = grep { !/$dotdot/o } readdir(DIR);
				closedir DIR;
				$res = _recurse_dst($func, $pkgs, map { "$ent/$_" } @ents);
				$tot = @ents;
			} else {
				die "Can't open $dst_abs: $!\n"
			}
		} else {
			$islink = -l _;
		}
		$count++ if $func->($pkgs, $ent, $res, $tot, $islink);
	}
	return $count;
}

sub recurse_dst {
	my $func = shift;
	my $pkgs = shift;

	if(opendir(DIR, $dst)) {
		my @ents = grep { !/$dotdot/o } readdir(DIR);
		closedir DIR;
		_recurse_dst($func, $pkgs, @ents);
	} else {
		die "Can't open $dst: $!\n"
	}
}

# if defined, an existing symlink to that value
# if undefined, an existing directory
my %old;

# if defined, a symlink to that value to be created
# if undefined, a directory to be created
my %new;

# a list of links to be created (in the right order) for each package
my %pkg;

sub symlink_pkg {
	my $link = shift;
	my $rel = chop_prefix($src.'/', $link);
	$rel =~ s,/.*,, if defined $rel;
	return $rel
}

sub prepare_install {
	my $pkg = shift;
	my $ent = shift;

	my $src_abs = "$src/$pkg/$ent";
	my $dst_abs = "$dst/$ent";

	lstat $src_abs;
	my $isdir = -d _;

	my $verb = 'is';
	my $link;
	if(exists $new{$dst_abs}) {
		# oh hey, we were already going to create that.
		$verb = 'will be';
		$link = $new{$dst_abs};
	} elsif(exists $old{$dst_abs}) {
		# well, it seems it exists and we already know of it
		$link = $old{$dst_abs};
	} else {
		# ok so it's totally unknown. let's see if it already exists on disk
		lstat $dst_abs;
		unless(-e _) {
			# ok, it doesn't exist on disk yet. that's always ok.
			if($isdir) {
				$new{$dst_abs} = undef;
				return 1;
			} else {
				$new{$dst_abs} = $src_abs;
				push @{$pkg{$pkg}}, $dst_abs;
				return 0;
			}
		}
		if(-l _) {
			$link = readlink $dst_abs
				or die "($pkg) Can't read symlink at $dst_abs: $!\n";
		} elsif(!-d _) {
			die "($pkg) $dst_abs is in the way\n";
		}
		$old{$dst_abs} = $link;
	}

	# uh oh, it already exists. perhaps it's ok the way it is?
	my $info;
	if(defined $link) {
		# the existing item is a symlink
		if(!$isdir && $link eq $src_abs) {
			warn "($pkg) $src_abs $verb installed already\n";
			return 0;
		}
		# ok, not good. give some info then die.
		my $info = symlink_pkg($link);
		if(defined $info) {
			die "($pkg) $dst_abs (from $info package) $verb in the way\n";
		} else {
			die "($pkg) $dst_abs (a symlink pointing to $link) $verb in the way\n";
		}
	} else {
		return 1 if $isdir;
		die "($pkg) $dst_abs (a directory) $verb in the way\n";
	}
}

sub create_parents {
	my $pkg = shift;
	my $dir = shift;
	$dir =~ s,/[^/]*$,,;
	return unless exists $new{$dir};
	create_parents($pkg, $dir);
	info(2, 'mkdir', $dir);
	$dryrun or mkdir $dir
		or die "($pkg) Can't make a directory at $dir: $!\n";
	delete $new{$dir};
	undef $old{$dir};
}

sub install_pkgs {
	foreach my $pkg (@_) {
		foreach my $dst_abs (@{$pkg{$pkg}}) {
			next unless exists $new{$dst_abs};
			my $src_abs = $new{$dst_abs};
			delete $new{$dst_abs};
			$old{dst_abs} = $src_abs;

			create_parents($pkg, $dst_abs);

			info(1, 'symlink', $src_abs, $dst_abs);
			$dryrun or symlink $src_abs, $dst_abs
				or die "($pkg) Can't make a symlink at $dst_abs: $!\n";
		}
	}
}

sub do_remove {
	my ($pkgs, $ent, $count, $total, $islink) = @_;

	my $dst_abs = "$dst/$ent";

	if(defined $count) {
		if($count && $count == $total) {
			info(2, 'rmdir', $dst_abs);
			$dryrun or rmdir $dst_abs
				or warn "Can't remove empty directory $dst_abs: $!";
			return 1;
		}
	} elsif($islink) {
		my $link = readlink $dst_abs
			or die "Can't read value of symlink at $dst_abs: $!\n";

		# is it managed by us?
		my $rel = chop_prefix($src.'/', $link);
		return 0 unless defined $rel;
		
		# is it one of the packages we're removing?
		my $pkg;
		if(exists $pkgs->{$rel}) {
			$pkg = $rel;
			warn "($pkg) $dst_abs is a direct link to $link\n";
		} else {
			my $sub = $rel;
			$sub =~ s,/.*,,;
			return 0 unless exists $pkgs->{$sub};
			$pkg = $sub;
		}
		# all lights green, let's remove it.
		info(1, 'unlink', $dst_abs);
		$dryrun or unlink $dst_abs
			or warn "($pkg) Can't delete $dst_abs: $!\n";
		return 1;
	}
	return 0;
}

sub do_list {
	my ($pkgs, $ent, $count, $total, $islink) = @_;

	return 0 unless $islink;

	my $dst_abs = "$dst/$ent";

	my $link = readlink $dst_abs
		or die "Can't read value of symlink at $dst_abs: $!\n";

	# is it managed by us?
	my $pkg = chop_prefix($src.'/', $link);
	unless(defined $pkg) {
		warn "unmanaged symlink '$dst_abs' ($link) found\n"
			if $verbose > 1;
		return 0;
	}
	
	my $sub = $pkg =~ s,/.*,,;

	if($pkg eq '' || $pkg =~ /$dotdot/o) {
		warn "malformed symlink '$dst_abs' ($link) found\n"
			if $verbose;
		return 0;
	}

	unless($sub) {
		warn "($pkg) $dst_abs is a direct link to $link\n"
			if $verbose > 1;
	}

	undef $pkgs->{$pkg};

	return 0;
}

sub print_version {
	my $fh = shift;
	binmode $fh, ':utf8';
	print $fh "$PACKAGE $VERSION, © 2008,2012 Wessel Dankers <wsl\@fruit.je>\n"
		or die "print: $!\n";
}

sub version {
	print_version *STDOUT;
	exit 0;
}

sub usage {
	my $fh = shift;
	binmode $fh, ':utf8';
	print $fh "Usage: $0 [options] pkg [pkg ...]\n",
			" -V, --version        Show version information\n",
			" -h, --help           Show usage information\n",
			" -v, --verbose        Show what happens\n",
			" -l, --list           Remove the package\n",
			" -D, --remove         Remove the package\n",
			" -d, --dir <dir>      Source directory (/opt)\n",
			" -t, --target <dir>   Destination directory (/usr/local)\n",
			" -n, --dryrun         Simulate only; don't change anything\n"
		or die "print: $!\n";
}

sub usage_error {
	usage(*STDERR);
	exit 1;
}

sub help {
	print_version(*STDOUT);
	usage(*STDOUT);
	exit 0;
}

unless(GetOptions(
	'V|version' => \&version,
	'h|help' => \&help,
	'v|verbose+' => \$verbose,
	'l|list' => sub { $mode = 'list' },
	'D|remove' => sub { $mode = 'remove' },
	'd|dir=s' => \$src,
	't|target=s' => \$dst,
	'n|dryrun' => \$dryrun,
)) {
	usage *STDERR;
	exit 1;
}

die "No source directory at $src\n" unless -d $src;
die "No target directory at $dst\n" unless -d $dst;

if($mode eq 'remove') {
	usage_error() unless @ARGV;
	recurse_dst(\&do_remove, hashify(@ARGV));
} elsif($mode eq 'list') {
	my %list;
	recurse_dst(\&do_list, \%list);
	my $prefixes = join('|', map { quotemeta($_) } @ARGV);
	my $match = qr{^(?:$prefixes)};
	my @list = sort { vcmp($a, $b) } grep { /$match/o } keys(%list);
	foreach my $pkg (@list) {
		print "$pkg\n" or die "print: $!\n";
	}
} else {
	usage_error() unless @ARGV;
	foreach(@ARGV) {
		die "($_) package name may not contain slashes\n" if m{/};
		die "($_) invalid package name\n" if /$dotdot/o;
	}
	recurse_src(\&prepare_install, @ARGV);
	install_pkgs(@ARGV);
}

exit($warned > 0);
