#! /usr/bin/perl -w
#
# `cvs-work-backup'
#
# $Id: cvs-work-backup,v 1.10 2001/05/30 06:10:02 karlheg Exp $
#
# Copyright © 1998-2001, Karl M. Hegbloom <karlheg@microsharp.com>
# GPL forever.  Long live GNU.
#
require v5.6;
use strict;

use Getopt::Mixed;

use Fcntl;
use Cwd;
use File::Find;

use Compress::Zlib ();
use Archive::Tar;

my $n_errors = 0;

our ($opt_h, $opt_v, $opt_n, $opt_d);

Getopt::Mixed::getOptions
  (qw (h   help>h
       v   verbose>v
       n=i number-of-rotations>n
       d=s backup-dir>d
       ));

$opt_n = 3 unless $opt_n;
$opt_d = getcwd unless $opt_d;

$| = 1 if $opt_v;

if ($opt_h
    or 0 == scalar @ARGV
    or 0 == scalar grep {-d $_} @ARGV)
  {
    print STDERR << "EOF";
Usage: cvs-work-backup [<args>] work_checkout_directory ...
          [-n int | --n-rotations int] (3)
          [-d dir | --backup-dir dir]  (PWD)
          [-v | --verbose]             (no)
          [-h | --help]

\`cvs-work-backup\' will back up the files you have modified since the
last \`cvs commit\', as well as any files in your checkout directory
that are not under CVS control.  It is designed to be called from a
developer\'s \`.crontab\'.

EOF
    exit 1;
  }

unless (-d $opt_d and -w _ and -x _)
  {
    warn "--backup-dir ($opt_d) must exist, be accessible, and writeable.\n";
    exit 1;
  }

my $orig_cwd = getcwd;

WORK_DIR:
foreach my $work_dir_name (@ARGV)
  {
    my $cwd;

    chdir $orig_cwd;

    unless (-d $work_dir_name)
      {
	warn "Error: '$work_dir_name' does not exist : $! : Skipping.\n";
	$n_errors++;
	next WORK_DIR;
      }

    my ($work_dir_uid, $work_dir_gid) = (stat (_))[4,5];

    unless (-r _)
      {
	warn "Error: $work_dir_name is not readable: $! : Skipping.\n";
	$n_errors++;
	next WORK_DIR;
      }

    unless (chdir ($work_dir_name) and $cwd = getcwd)
      {
	warn "Error: chdir failed. ($work_dir_name): $! : Skipping.\n";
	$n_errors++;
	next WORK_DIR;
      }

    unless (-d "./CVS/" && -f "./CVS/Entries")
      {
	warn "Error: Skipping non CVS-checkout directory: $work_dir_name\n";
	$n_errors++;
	next WORK_DIR;
      }

    my $volume_name = $work_dir_name;
    $volume_name =~ s,/$,,;
    $volume_name =~ s,^/,,;
    $volume_name =~ s,/,_,g;

    my $login = (getpwuid ($work_dir_uid))[0];

    if (! $login)
      {
	warn "UID $work_dir_uid does not have a login ID. Using UID.\n";
	++$n_errors;
	$login = $work_dir_uid;
      }

    # Archives are named starting with $login so they sort by owner.
    $volume_name = "$opt_d/$login.$volume_name.tar.gz";

    my $found_newer = undef;
    if (-e $volume_name)
      {
	if (! -f $volume_name )
	  {
	    warn "Error: $volume_name is not a regular file!  Skipping $work_dir_name.\n";
	    ++$n_errors;
	    next WORK_DIR;
	  }
	else
	  {
	    print "Looking for files that are have been modified since the last archive was made... "
	      if $opt_v;
	    my ($st_mtime) = (stat (_))[9];
	    eval {
	      find (sub {
		      my ($_st_mtime) = (stat ($_))[9];
		      if ($_st_mtime > $st_mtime)
			{
			  die 'found_newer';
			}
		      else
			{
			  return 0;
			}
		    }, $cwd);
	    };
	    $found_newer++ if $@;
	    print "done.\n" if $opt_v;
	  }

	unless ($found_newer)
	  {
	    print "Backup archive is up to date.  Skipping $work_dir_name.\n" if $opt_v;
	    next WORK_DIR;
	  }
      }

    print "Checking for changed or non-CVS-controlled files in $cwd ... " if $opt_v;

    my ($ra_modified_CVS, $ra_removed_CVS, $ra_non_CVS) = eval { cvs_modified ($cwd) };

    if ($@)
      {
	warn "\n" . $@ . "Skipping $work_dir_name.\n";
	++$n_errors;
	next WORK_DIR;
      }

    print "done.\n" if $opt_v;

    my $old_cwd = getcwd;

    unless (chdir '..' and $cwd = getcwd)
      {
	warn "Error: cannot chdir .. : $!\n";
	++$n_errors;
	next WORK_DIR;
      }

    my $len = length $cwd;

    my $prefix = substr $old_cwd, ++$len;

    my @backup = map {$prefix . '/' . $_} @$ra_modified_CVS, @$ra_non_CVS;

    unless (scalar @backup)
      {
	print "No files needing archived\n" if $opt_v;
	next WORK_DIR;
      }

    if (-f $volume_name )
      {
	print "Rotating $volume_name\n" if $opt_v;

	for (my $i = $opt_n; $i >= 1; $i--)
	  {
	    my $next = $volume_name;
	    $next =~ s,\.tar\.gz$,,;
	    my $prev = $next;
	    $next = $next . '.' . $i . '.tar.gz';
	    $prev = $prev . '.' . ($i - 1) . '.tar.gz';
	    if (-r $prev && -f $prev)
	      {
		print "$prev to $next\n" if $opt_v;
		unless (rename ($prev, $next))
		  {
		    warn "Error: rename failed: ($prev, $next): $!\n";
		    ++$n_errors;
		    next WORK_DIR;
		  }
	      }
	  }

	my $dot_zero = $volume_name;
	$dot_zero =~ s,\.tar\.gz$,,;
	$dot_zero = $dot_zero . '.0.tar.gz';

	print "$volume_name to $dot_zero\n" if $opt_v;

	unless (rename ($volume_name, $dot_zero))
	  {
	    warn "Error: rename failed: ($volume_name, $dot_zero): $!\n";
	    ++$n_errors;
	    next WORK_DIR;
	  }
      }

    print "Adding files to $volume_name:\n" if $opt_v;
    print join "\n", @backup if $opt_v;
    print "\n" if $opt_v;

    Archive::Tar->create_archive ($volume_name, 9, @backup);

    unless (chown ($>, $work_dir_gid, $volume_name))
      {
	warn "Error: chown failed ($>, $work_dir_gid, $volume_name): $!\n";
	++$n_errors;
	next WORK_DIR;
      }

    unless (chmod (0640, $volume_name))
      {
	warn "Error: chmod failed (0640, $volume_name): $!\n";
	++$n_errors;
	next WORK_DIR;
      }

    next WORK_DIR;
  }

exit ($n_errors);

sub cvs_modified
# Returns: An array of references to 3 arrays:
#
# \@modified_CVS -- Files under CVS control that are ostensibly
#                   locally-modified; ie, they have an st_mtime newer
#                   than the timestamp recorded in the CVS/Entries
#                   file.
#
# \@removed_CVS -- Files listed as being under CVS control that are
#                  not present in the filesystem.
#
# \@non_CVS -- Files extant in the filesystem that are NOT listed as
#              being under CVS control.
#
#
# Adapted from a script sent to the <xemacs-beta@xemacs.org> mailing
# list by Martin Buchholz.
#
  {
    my $dir = shift;

    my @all_found_non_CVS;
    my %CVS_controlled_files;

    my @modified_CVS;
    my @removed_CVS;
    my @non_CVS;

    my $popd = getcwd();
    die "cvs_modified: Cannot chdir($dir)" unless chdir ($dir);

    my $cwd = getcwd();
    die "cvs_modified: Cannot stat $cwd/CVS/Entries" unless (-r "$cwd/CVS/Entries");

    my $wanted = sub
      {
	my $cwd_relative_name;

	if ($File::Find::name =~ m,/CVS/Entries$,)
	  {
	    die "cvs_modified: Cannot open $File::Find::name"
	      unless open (ENTRIES, $File::Find::name);

	    (my $dotdot = $File::Find::dir) =~ s{/CVS/?}{};

	    while (<ENTRIES>)
	      {
		next unless m{^/};

		my ($name, $revision, $timestamp) = (split ('/'))[1,2,3];
		
		($cwd_relative_name = "$dotdot/$name") =~ s{$cwd/}{};
		
		$CVS_controlled_files{$cwd_relative_name} = 1;
		
		my ($st_mtime) = (stat ("$dotdot/$name"))[9];
		unless (defined $st_mtime)
		  {
		    push (@removed_CVS, $cwd_relative_name);
		    next;
		  }
		
		my $file_timestamp = scalar gmtime ($st_mtime);
		next if $timestamp eq $file_timestamp;
		
		push (@modified_CVS, $cwd_relative_name);
	      }
	    close (ENTRIES);
	  }
	elsif (! -d $File::Find::name)
	  {
	    ($cwd_relative_name = $File::Find::name) =~ s{$cwd/}{};
	    push (@all_found_non_CVS, $cwd_relative_name);
	  }
      };

    find ( $wanted, $cwd );

    @non_CVS = grep {! exists $CVS_controlled_files{$_}} @all_found_non_CVS;

    die "cvs_modified: Cannot chdir ($popd)" unless chdir ($popd);

    return (\@modified_CVS, \@removed_CVS, \@non_CVS);
  }
