#! /usr/local/bin/perl -w

# cvsmv - recursively add and remove CVS entries so as to move a tree.
# Copyright (C) 2000 John Tobey.  All rights reserved.
# Distribute under the terms of the Perl v5.6.0 license or later.
# Send bug reports to <jtobey@john-edwin-tobey.org>.

# v0.1  Wed Apr  5 15:21:25 EDT 2000

# TO DO:
#   Handle cvs options.
#   Lock stuff.
#   See if everything is according to spec.
#   Add robustness and verbosity for errors resulting in inconsistency.
#   Don't fail when moving added but uncommitted files.
#   Document with pod.

use 5.006;

sub usage {
    return <<USAGE;
Usage:
  cvsmv FILE NEW      - do this after mv FILE NEW
  cvsmv DIR NEW       - do *NOT* first mv DIR NEW
  cvsmv ... DIR       - do this after moving files, but not dirs, to DIR

You move the files, I move the directories, I move stuff in CVS.
I commit every move so I can add appropriate log messages.
USAGE
}

use strict;
use File::Spec::Functions;
use File::Path;

$| = 1;
our $opt_cvs = "cvs";
our @opt_cvsopts = ();
our $opt_quiet = 0;
#our $opt_verbose = 0;

sub runcvs {
    my (@cmd) = ($opt_cvs, @opt_cvsopts, @_);
    print join (' ', map { /\s/ ? "'$_'" : $_ } @cmd), "\n" unless $opt_quiet;
    system (@cmd);
    if ($?) {
	die "The following command failed with status ".($? >> 8).":\n@cmd\n";
    }
}

# could do a getopt here.

my $dest = pop @ARGV;
my @src = @ARGV;

if (@src < 1) {
    die usage();
}
if (my @funny = grep { -e && !-d(_) && !-f(_) } @src, $dest) {
    die "Can't move nodes of unusual type: ".join(', ', @funny)."\n";
}
if (@src > 1 && !-d($dest)) {
    die "$0: When moving multiple files, last argument must be a directory.\n";
}
if (@src == 1 && -d($src[0]) && !-e($dest)) {
    rename_dir ($src[0], $dest);
    exit;
}
if (!-e($dest)) {
    die "$0: Target $dest does not exist.\n";
}
if (my @still_there = grep -f, @src) {
    my ($msg);
    # This behavior could be friendlier, but it's consistent with that of
    # standard cvs commands.
    if (@still_there == 1) {
	$msg = "$still_there[0] still exists; move it first.";
    } else {
	$msg = join ("\n\t", "Move these files first:", @still_there);
    }
    die "$0: $msg\n";
}

if (-f($dest)) {
    if (-d($src[0])) {
	die "$0: Can't move directory onto a file.\n";
    }
    rename_file ($src[0], $dest);
    exit;
}

move_to_dir ($dest, @src);
exit;

# Move some files and directories to an existing directory.
sub move_to_dir {
    my ($dir, @args) = @_;
    my (@targets);

    if (!-d(catdir ($dir, 'CVS'))) {
	runcvs ('add', catdir ($dir, 'CVS'));
    }

    foreach my $arg (@args) {
	my ($target);

	$target = canonpath (catfile ($dir,
				      (File::Spec->splitpath ($arg))[2]));
	push @targets, $target;

	# -f($arg) has been ruled out.
	if (-d($arg)) {
	    if (-e($target)) {
		die "$0: Can't overwrite $target.  Move it out of the way.\n";
	    }
	} else {
	    if (!-f($target)) {
		if (-e $target) {
		    die "$0: $target is not a regular file.\n";
		} else {
		    die "$0: $target does not exist.\n";
		}
	    }
	}
    }
    while (@args) {
	my $arg = shift @args;
	my $target = shift @targets;

	if (-f($target)) {
	    rename_file ($arg, $target);
	} else {
	    rename_dir ($arg, $target);
	}
    }
}

sub rename_file {
    my ($oldname, $newname) = @_;

    # XXX CVS manual says this won't work if $newname contains /, but
    # experiment with version 1.10.7 shows otherwise.
    runcvs ('add', $newname);
    runcvs ('commit', "-mRenamed file $newname, formerly $oldname", $newname);
    runcvs ('remove', $oldname);
    runcvs ('commit', "-mRenamed from $oldname to $newname", $oldname);
}

# Return lists of the dirs, files, and uncommitted files under CVS in dir.
# XXX This implementation is based on experiment, not looking at docs.
sub cvs_ls {
    my ($dir) = @_;
    my (@dirs, @files, @uncommitted);

    open my $entries, catfile ($dir, 'CVS', 'Entries')
	or die "$0: Can't read entries file in $dir: $!";

    while (defined (my $line = <$entries>)) {
	if ($line =~ m,^/([^/]+)/0/,) {
	    push @uncommitted, $1;
	} elsif ($line =~ m,^/([^/]+)/\d,) {
	    push @files, $1;
	} elsif ($line =~ m,^D/([^/]+)/,) {
	    push @dirs, $1;
	}
    }
    return (\@dirs, \@files, \@uncommitted);
}

sub rename_dir {
    my ($oldname, $newname) = @_;
    my ($dirs, $files, $uncommitted);

    ($dirs, $files, $uncommitted) = cvs_ls ($oldname);

    print "mkdir $newname\n" unless $opt_quiet;
    mkdir $newname, 0777
	or die "$0: Can't create directory $newname: $!\n";

    runcvs ('add', $newname);
    foreach my $entry (@$dirs) {
	rename_dir (catdir ($oldname, $entry), catdir ($newname, $entry));
    }
    foreach my $entry (@$files) {
	my $oldfile = catfile ($oldname, $entry);
	my $newfile = catfile ($newname, $entry);

	rename $oldfile, $newfile
	    or die "$0: Can't rename $oldfile as $newfile: $!\n";
	rename_file ($oldfile, $newfile);
    }
    foreach my $entry (@$uncommitted) {
	my $oldfile = catfile ($oldname, $entry);
	my $newfile = catfile ($newname, $entry);

	rename $oldfile, $newfile
	    or die "$0: Can't rename $oldfile as $newfile: $!\n";
	runcvs ('add', $newfile);
	runcvs ('remove', $oldfile);
    }
    runcvs ('remove', $oldname);

    # If we can move all the non-CVS stuff, delete the old dir.
    # Otherwise, issue a warning.
    if (opendir my $olddir, $oldname) {
	my @nonentries = no_upwards (readdir $olddir);
	my $all_gone = 1;

	foreach my $nonentry (@nonentries) {
	    next if $nonentry eq 'CVS';

	    my $oldfile = catfile ($oldname, $nonentry);
	    my $newfile = catfile ($newname, $nonentry);

	    if (rename ($oldfile, $newfile)) {
		print "mv $oldfile $newfile\n" unless $opt_quiet;
	    } else {
		$all_gone = 0;
		if (! $opt_quiet) {
		    print STDERR "Warning: Could not rename $oldfile to";
		    print STDERR " $newfile: $!\n";
		}
	    }
	}
	if ($all_gone) {
	    print "rm -rf $oldname\n" unless $opt_quiet;
	    rmtree ([$oldname]);
	}
    } else {
	print STDERR "Warning: Could not open directory $oldname: $!\n";
    }
}