#!/usr/bin/perl -w
#
# $Date: 2011/09/10 17:08:18 $
#
# Keep a local mirror of a cvs repository.
# see lcvs(1) and lcvs-files(1) for a documentation.
#
# If you received this file without a man page, see
# http://www.linta.de/~aehlig/cvsq/ 

use strict;
use Cwd;
use Getopt::Long qw(:config require_order);

my $lcvs= ".lcvs";

my $home=$ENV{'HOME'};
defined $home && -d $home
	or die "Invalid home directory.\n";

-d "$home/$lcvs" or mkdir "$home/$lcvs", 0700 or die "Unable to create directory '$home/$lcvs' ($!)\n";

my $keepfallback = 1;

GetOptions(
		   'nofallback' => sub {$keepfallback =0},
		   );


@ARGV != 0 or die "some command has to be provided\n";
for (shift @ARGV) {
	/^get$/          && do { @ARGV == 1 or die "usage: get <cvsroot>\n"; 
							 get_copy($ARGV[0]); last };
	/^pre-recv$/     && do { @ARGV == 1 or die "usage: pre-recv <cvsroot>\n"; 
							 pre_recv($ARGV[0]); last };
	/^recv$/         && do { @ARGV == 2 or die "usage: recv <cvsroot> <tmpdir>\n"; 
							 do_recv($ARGV[0],$ARGV[1]); last };
	/^push$/         && do { @ARGV == 4 or die "usage: push <srcdir> <user> <host> <cvsroot>\n";
							 do_push($ARGV[0],$ARGV[1],$ARGV[2],$ARGV[3]); last};
	/^sync$/         && do {  @ARGV== 0 or @ARGV== 1 or die "usage: sync [substring]\n";
							  defined $ARGV[0] or $ARGV[0] = "";
							  do_sync($ARGV[0]); last };
    /^mirror$/       && do {  @ARGV== 0 or @ARGV== 1 or die "usage: mirror [substring]\n";
							  defined $ARGV[0] or $ARGV[0] = "";
							  do_mirror($ARGV[0]); last };
	/^checkout$/     && do { @ARGV == 2 or die "usage: checkout <cvsroot> <module>\n"; 
							 do_checkout($ARGV[0],$ARGV[1]); last };
	/^list$/         && do { list_repositories($ARGV[0]); last};
	/^ls$/           && do { @ARGV == 1 or die "usage: ls <cvsroot>\n";
							 list_modules($ARGV[0]); last};
	/^make-global$/  && do { make_global(); last };
	/^force-global$/  && do { force_global(); last };

	(/^l$/ ||
	 /^do-local$/)   && do { my $i=0;
							 /^-/ || last, $i++ for @ARGV;
							 print "local command $ARGV[$i]\n";
							 $ARGV[$i] =~ /^(log|diff|update|status|annotate)$/ 
								 or die "be careful with local commands!\n"; 
	
							 $ARGV[$i] eq "update"
								 and verify_cvsq();

							 make_local();
							 system "cvs",@ARGV;
							 printf "\n\n[returnvalue %d]\n",($?>>8);
							 make_global();
							 $ARGV[$i] eq "update" and do {
								 ## check for the -d option, and if so, run force-global
								 for (; $i< @ARGV; $i++) {
									 $ARGV[$i] eq "-d" and do {
										 force_global();
										 last;
									 };
								 };
							 };
						   last };

	/^force-action$/ && do { make_local();
							 system "cvs",@ARGV;
							 printf "\n\n[returnvalue %d]\n",($?>>8);
							 make_global();
							 last };
							 
	die "command $_ not supported. Did you mead $0 do-local $_?\n";
}

sub get_copy
{
	my ($root) = @_;

	$root =~ /^:ext:([^@]+)@([^:]+):(.+)/ or die "Cannot parse cvs root";

	my ($user,$host,$rdir) = ($1,$2,$3);
	my $dir = "$home/$lcvs/" . quote($root);
	-d $dir and die "Already got '$root'\n; did you mean sync?\n";

	print "User: $user, host: $host, remote dir: $rdir\n";
	print "local dir: $dir\n";
	
	mkdir $dir or die "couldn't create $dir ($!)\n";
	mkdir "$dir/#lock" or die "couldn't create lock in $dir ($!)\n";

	system "rsync", "-rv", "$user\@$host:$rdir/", "$dir/tmp/"
		and die "rsync failed ($?)\n";

	open my $cvsroot, '>', "$dir/cvsroot"
		or die "couldn't open $dir/cvsroot ($!)\n";
	print $cvsroot $root;
	close $cvsroot or die "couldn't close $dir/cvsroot ($!)\n";

	my $date = `date`; chomp($date);
	
	open my $datefile, '>', "$dir/date"
		or die "couldn't open $dir/date ($!)\n";
	print $datefile $date;
	close $datefile or die "couldn't close $dir/date ($!)\n";

	rename "$dir/tmp", "$dir/root"
		or die "Rename failed ($!)\n";

	rmdir "$dir/#lock"
		or die "Couldn't remove lock ($!)\n";

}

sub pre_recv
{
	my ($root) = @_;

	my $dir = "$home/$lcvs/" . quote($root);
	-d $dir or do { ## ensure that we have something like a valid mirror
		mkdir $dir or die "couldn't create $dir ($!)\n";
		mkdir "$dir/#lock" or die "failed creating lock in newly create dir $dir ($!)\n";

		open my $cvsroot, '>', "$dir/cvsroot"
			or die "couldn't open $dir/cvsroot ($!)\n";
		print $cvsroot $root;
		close $cvsroot or die "couldn't close $dir/cvsroot ($!)\n";

		my $date = "empty generated on " . `date`; chomp($date);
		
		open my $datefile, '>', "$dir/date"
			or die "couldn't open $dir/date ($!)\n";
		print $datefile $date;
		close $datefile or die "couldn't close $dir/date ($!)\n";

		mkdir "$dir/root" or die "couldn't create dir root in $dir ($!)\n";

		rmdir "$dir/#lock"
			or die "Couldn't remove lock ($!)\n";
	};

	## Now generate the new tmp directory.

	my $date = `date -u +%Y-%m-%d-%H%M-%S-%N`; chomp($date);
	my $tmpdir = "tmp-rcv-$date-$$";

	get_lock("$dir/#lock");

	-d "$dir/$tmpdir" and die "tmp dir already exists ($tmpdir)\n";

	system "cp", "-r", "$dir/root", "$dir/$tmpdir"
		and die "cp failed ($?)\n";
	
	rmdir "$dir/#lock"
		or die "Couldn't remove lock ($!)\n";

	print "\n+$dir/$tmpdir";
}

sub do_recv {
	my ($root,$tmpdir) = @_;

	my $dir = "$home/$lcvs/" . quote($root);
	-d $dir or die "no (pre-receive) mirror of the given root present\n";
	-d $tmpdir or die "temp directory does not exists\n";

	get_lock("$dir/#lock");

	rename "$dir/root", "$dir/root-old"
		or die "rename $dir/root $dir/root-old failed ($!)\n";

	rename "$tmpdir", "$dir/root"
		or die "rename $tmpdir $dir/root failed ($!)\n";

	chmod 0700, "$dir/root-old"
		or die "couldn't prepare $dir/root for remoal ($!)\n";

	system "rm", "-rf", "$dir/root-old"
		and die "couldn't remove $dir/root-old";

	my $date = `date`; chomp($date);
	
	open my $datefile, '>', "$dir/date"
		or die "couldn't open $dir/date ($!)\n";
	print $datefile "received on ";
	print $datefile $date;
	close $datefile or die "couldn't close $dir/date ($!)\n";

	-d "$dir/recv-hooks" or do {
		rmdir "$dir/#lock"
			or die "Couldn't remove $dir/#lock ($!)\n";
		
		return;
	};

	opendir my $queue, "$dir/recv-hooks"
		or die "Unable to open pre todo directory `$dir/recv-hooks' ($!)\n";

	my @TASKS = readdir $queue;

	close $queue;

	@TASKS = sort (@TASKS);

	print "Running the recv-hooks in $dir/recv-hooks\n";

	foreach (@TASKS) {
		-f "$dir/recv-hooks/$_" or next;
		print "$_...\n";
		system "/bin/sh", "$dir/recv-hooks/$_";
		printf "\n...[return value %s]\n", $? >> 8;
	}

	rmdir "$dir/#lock"
		or die "Couldn't remove $dir/#lock ($!)\n";
}

sub do_push {
	my ($src,$user,$host,$root) = @_;

	my $answer = `ssh -l '$user' '$host' lcvs pre-recv '$root'`;
	
	print "Got answer:\n$answer\n";

	$answer =~ /\n\+(.*)$/m or die "No temp directory in found in answer";

	my $tmpdir = $1;

	print "Will transfer to remote directory $tmpdir\n";

	system "rsync", "-rcv", "--delete", "$src/", "$user\@$host:$tmpdir/"
		and die "rsync failed ($?)\n";

	system "ssh", "-l", $user, $host, "lcvs", "recv", $root, $tmpdir
		and die "ssh call to lcvs recv failed($?)\n";

	print "\ndone.\n";

}

## The whole trick of accessing the local copy of the repository is the following.
## we recursively access in each directory die CVS directory, rename Root in .lcvs-Root
## and create a new file Root with the path to the local directory. Then we can just execute
## the cvs command.
## 
## By renaming back the .lcvs-Root's we can undo these changes and have, again, a standard working directory.


sub make_local
{
	my @cvsDirs = `find . -name CVS`;
	
	foreach(@cvsDirs) {
		chomp;
		-f "$_/Root" or next;
		my $root = `cat \Q$_\E/Root`; chomp($root);
		my $qroot = quote($root);
		-d "$home/$lcvs/$qroot" or do {
			print "\n\nWARNING! don't have a local copy of '$root'. Undoing changes.\n";
			make_global();
			die "Can only work local, if repositories are present.\n";
		};
		rename "$_/Root", "$_/.lcvs-Root"
			or die "couldn't rename $_/Root in $_/.lcvs-Root ($!)\n";
		open my $rootfile, '>', "$_/Root"
			or die "couldn't open $_/Root ($!)\n";
		print $rootfile "$home/$lcvs/$qroot/root";
		close $rootfile or die "couldn't close $_/Root ($!)\n";
	}
}


sub make_global
{
        my @cvsDirs = `find . -name CVS`;

        foreach(@cvsDirs) {
                chomp;
                -f "$_/.lcvs-Root" or next;

                unlink "$_/Root" or die "couldn't unlink $_/Root ($!)\n";
                rename "$_/.lcvs-Root", "$_/Root" or die "couldn't rename $_/.lcvs-Root $_/Root ($!)\n";
        }
}


## Since any local checkout is uniquely related to a global directory, we still can render
## a local checkout global---just replace every local cvsroot by the associated global cvsroot.
##
## This trick allows for completely local checkouts and makes 'lcvs l update -d' work correctly.


sub force_global
{
	my ($relpath) = @_;
	defined($relpath) or $relpath = '.';
	my @cvsDirs = `find \Q$relpath\E -name CVS`;

	foreach(@cvsDirs) {
		chomp;
		my $lcvsroot = `cat \Q$_\E/Root`; chomp($lcvsroot);
		index($lcvsroot, "$home/$lcvs")==0 or next;
		-f "$lcvsroot/../cvsroot" or next;
		unlink "$_/Root" or die "couldn't unlink $_/Root ($!)\n";
		system "cp", "$lcvsroot/../cvsroot", "$_/Root" 
			and die "couldn't copy $lcvsroot/../cvsroot to $_/Root ($?)\n";
	}
}

sub verify_cvsq
{
	my $pwd = cwd();
	my @queued = `cvsq queue`;

	print "Current directory: $pwd\n";
	foreach(@queued) {
		$_ =~ /^\s*[0-9]+\s+(\S+)/ or next;
		substr($1, 0,length $pwd) eq $pwd
			and die "You already have a local commit here; " .
			"don't do any update any more in this working directory!\n";
		substr($pwd, 0, length $1) eq $1
			and die "You already have a local commit here;" .
			"don't do any update any more in this working directory!\n";
	}
}

sub do_mirror
{
	my ($name) = @_;

	print "Collecting from mirror (where appropriate) all repositories with >$name< in their name\n";

	opendir my $lcvsdir, "$home/$lcvs"
		or die "Unable to open '$home/$lcvs' ($!)\n";

	my @TASKS = readdir $lcvsdir;

	close $lcvsdir;

	foreach (@TASKS) {
		/ext/ or next;
		my $dir = "$home/$lcvs/$_";
		-f "$dir/cvsroot" or do {
			print "\n\nWarning! skipping $_; doesn't have a file cvsroot\n\n";
			next;
		};
		my $root = `cat \Q$dir\E/cvsroot`;
		chomp($root);
		index($root,$name) >= 0 or next;

		-f "$dir/mirrortarball" or next;

        my $tarball = `cat \Q$dir/mirrortarball\E`; chomp($tarball);

		-f $tarball or do {
			print "Warning! skipping $_ as $tarball does not exist";
			next;
		};

		print "\n\ngetting my copy of >$root< from >$tarball<\n";
		get_lock("$dir/#lock",1) or next;

		system "rm", "-rf", "$dir/tmp"
			and die "couldn't remove $dir/tmp ($?)\n";

		mkdir "$dir/tmp";

		system "cd \Q$dir/tmp\E " . ' && tar xvf ' . "\Q$tarball\E"
			and do {
				print "Warning, tar failed ($?)\n";
				unlink "$dir/#lock"
					or die "Couldn't release the lock";
				next;
		};

		rename "$dir/root", "$dir/root-old"
			or die "rename $dir/root $dir/root-old failed ($!)\n";

		rename "$dir/tmp", "$dir/root"
			or die "rename $dir/tmp $dir/root failed ($!)\n";

		my $date = `date`; chomp($date);
	
		open my $datefile, '>', "$dir/date"
			or die "couldn't open $dir/date ($!)\n";
		print $datefile "Taken from mirror at $date";
		close $datefile or die "couldn't close $dir/date ($!)\n";

		system "rm", "-rf", "$dir/root-old"
			and die "Coudln't remove $dir/root-old ($!)\n";

		rmdir "$dir/#lock"
			or die "Couldn't remove $dir/#lock ($!)\n";
	
	}
}

sub do_sync
{
	my ($name) = @_;

	print `date`;
	print "Syncing repositories with >$name< in their name\n";

	opendir my $lcvsdir, "$home/$lcvs"
		or die "Unable to open '$home/$lcvs' ($!)\n";

	my @TASKS = readdir $lcvsdir;

	close $lcvsdir;

	foreach (@TASKS) {
		/ext/ or next;
		my $dir = "$home/$lcvs/$_";
		-f "$dir/cvsroot" or do {
			print "\n\nWarning! skipping $_; doesn't have a file cvsroot\n\n";
			next;
		};
		my $root = `cat \Q$dir\E/cvsroot`;
		chomp($root);
		index($root,$name) >= 0 or next;
		print "\n\nupdating my copy of >$root<\n";
		$root =~ /:ext:([^@]+)@([^:]+):(.+)/ or die "Cannot parse cvs root";
		my ($user,$host,$rdir) = ($1,$2,$3);
		print "User: $user, host: $host, remote dir: $rdir\n";
		print "local dir: $dir\n\n";

		get_lock("$dir/#lock",1) or next;
		system "rm", "-rf", "$dir/tmp"
			and die "coudln't remove $dir/tmp ($?)\n";

		system "cp", "-r", "$dir/root", "$dir/tmp"
			and die "couldn't make a working copy of the repository for rsync ($?)\n";

		system "rsync", "-rcv", "--delete", "$user\@$host:$rdir/", "$dir/tmp/"
			and do {
				print "### Rsync failed ($?)\n";
				print "### $root not synchronised.\n";
				print "### Won't clean up $dir/tmp\n";
				print "###    (This will be done in the next sync attempt anyway)\n";
				print "### However, will give up the lock.\n";
				rmdir "$dir/#lock"
					or die "Couldn't remove $dir/#lock ($!)\n";
				next;
			};

		rename "$dir/root", "$dir/root-old"
			or die "rename $dir/root $dir/root-old failed ($!)\n";

		rename "$dir/tmp", "$dir/root"
			or die "rename $dir/tmp $dir/root failed ($!)\n";

		-d "$dir/fallback" and
			(chmod 0700, "$dir/fallback"
			 or die "couldn't prepare $dir/fallback for remoal ($!)\n");
		
		system "rm", "-rf", "$dir/fallback"
			and die "couldn't remove $dir/fallback";
			
		if ($keepfallback) {
			rename "$dir/root-old", "$dir/fallback"
				or die "rename $dir/root-old $dir/fallback failed ($!)\n";
		} else {
			system "rm", "-rf", "$dir/root-old"
				and die "Coudln't remove $dir/root-old ($!)\n";
		}

		my $date = `date`; chomp($date);
	
		open my $datefile, '>', "$dir/date"
			or die "couldn't open $dir/date ($!)\n";
		print $datefile $date;
		close $datefile or die "couldn't close $dir/date ($!)\n";

		rmdir "$dir/#lock"
			or die "Couldn't remove $dir/#lock ($!)\n";
	
	}
}

sub do_checkout
{
	my ($cvsroot,$module) = @_;

	my $qroot = quote($cvsroot);
	-d "$home/$lcvs/$qroot" or die "Don't have a local copy of '$cvsroot'.\n";

	system "cvs", "-d", "$home/$lcvs/$qroot/root", "checkout", "$module"
		and die "cvs checkout failed ($?)\n";
	
	force_global($module);
}

sub list_repositories
{
	my $name = shift;
	defined($name) or $name="";

	if ($name eq "") {
		print "The following repositories are mirrored (and last synchronised at this date).\n\n";
	} else {
		print "The following repositories containing \"$name\" are mirrored (and last synchronised at this date).\n\n";
	}

	opendir my $lcvsdir, "$home/$lcvs"
		or die "Unable to open '$home/$lcvs' ($!)\n";

	my @TASKS = readdir $lcvsdir;

	close $lcvsdir;

	foreach (@TASKS) {
		/ext/ or next;
		
		my $dir = "$home/$lcvs/$_";
		-f "$dir/cvsroot" or do {
			print "\n\nWarning! mirror $_ doesn't have a file cvsroot\n\n";
			next;
		};
		my $root = `cat \Q$dir\E/cvsroot`; chomp($root);
		index($root,$name) >= 0 or next;
		my $date = `cat \Q$dir\E/date`; chomp($date);
		print "$root ($date)\n";
	}
	print "\n";
}

sub list_modules
{
	my $name = shift;
	my $dir = "$home/$lcvs/" . quote($name);

	-d $dir
		or die "don't have a copy of $name\n";

	system("ls -a \Q$dir\E/root/");
	print "\n";
}

# try to crete a new directory $lock; if not wait
# and trie another few times.
sub get_lock
{
	my ($lock,$dont_die_on_failure) = @_;
	defined($dont_die_on_failure) or $dont_die_on_failure = 0;

	my $retries = 12;

	for($retries--;$retries>=0;$retries--) {
		mkdir $lock and return 1;
		print "Failed to create lock $lock ($!)\nWill try another $retries times.\n";
		if ($retries) {
			sleep 2;
			while(int(rand(5))!=0) {
				sleep 1;
			}
		}
	}
	print "Giving up on getting lock $lock.\n";

	die "Can't optain lock $lock.\n"
		unless $dont_die_on_failure;

	return 0;
}

sub quote
{
	my ($name) = @_;

	$name =~ s/([^-a-zA-Z0-9])/"_" . ord ($1) . "_" /eg;
	return $name;
}