#!/bin/sh
# -*- perl -*-
# This code allows us to start perl from our path or an environment variable
# rather than hardcoding a path into the #! line.  It works from sh or csh.
(exit $?0) && eval 'exec ${QPERLQ-perl} -x $0 ${1+"$@"}'
if (! $?QPERLQ) setenv QPERLQ perl
exec $QPERLQ -x $0 $argv:q

#!/usr/local/bin/perl -w
#
# $Id: rcs_freeze,v 1.3 1997/03/30 01:36:43 ejb Exp $
# $Source: /home/ejb/scripts/RCS/rcs_freeze,v $
# $Author: ejb $
#
# See usage() for details.
#

require 5.002;
use strict;

package OnExit;
my $package = "OnExit";

# Field names
my $f_function = "function";
my $f_args = "args";

# Routines

sub new
{
    my $class = shift;
    my $rep = +{$package => {} };
    $rep->{$package}{$f_function} = shift;
    $rep->{$package}{$f_args} = shift;
    bless $rep, $class;
}

sub DESTROY
{
    my $rep = shift;
    my $function = ($rep->{$package}{$f_function});
    my $args = ($rep->{$package}{$f_args});
    &{$function}(@{$args});
}

package main;

my $whoami = ($0 =~ m,([^/\\]*)$,) ? $1 : $0;
#my $dirname = ($0 =~ m,(.*)[/\\][^/\\]+$,) ? $1 : ".";

my $tar_command = (system("gtar --version >/dev/null 2>&1") == 0)
    ? "gtar" : "tar";
if (system("$tar_command --version >/dev/null 2>&1") != 0)
{
    die "$whoami: this program requires gnu tar.\n";
}

my $errors = 0;

$| = 1; # unbuffered output for tail -f...

my @dirs = ();
my $destdir = undef;
my $verbose = 0;
my $check_only = 0;

&usage() if ((@ARGV == 0) || ($ARGV[0] eq "--help"));

my $arg;
while (@ARGV)
{
    $arg = shift(@ARGV);
    {
	if ($arg eq "-src")
	{
	    &usage() unless (@ARGV);
	    my $t = shift(@ARGV);
	    $t =~ s,/$,,;
	    push(@dirs, $t);
	}
	elsif ($arg eq "-dest")
	{
	    &usage() unless (@ARGV);
	    if (defined $destdir)
	    {
		die "$whoami: -dest may be given only once\n";
	    }
	    my $t = shift(@ARGV);
	    $t =~ s,/$,,;
	    $destdir = $t;
	}
	elsif ($arg eq "-check")
	{
	    my $check_only = 1;
	}
	elsif ($arg =~ m/^-v+$/)
	{
	    $verbose = (length $_) - 1;
	}
    }
}

die "$whoami: -dest must be specified\n" unless defined $destdir;
die "$whoami: at least one -src must be specified\n" unless (@dirs);

if (-e $destdir)
{
    if (&yn("$whoami: $destdir exists; delete? "))
    {
	if (system("rm -rf $destdir") != 0)
	{
	    die "$whoami: rm -rf $destdir failed\n";
	}
	elsif (-e $destdir)
	{
	    die "$whoami: $destdir exists after removal attempt\n";
	}
    }
    else
    {
	die "$whoami: $destdir exists; exiting\n";
    }
}
mkdir $destdir, 0777 or die "$whoami: mkdir $destdir failed: $!\n";

my %files = ();
my %logs = ();
while (@dirs)
{
    my $dir = shift(@dirs);
    opendir(D, "$dir") or die "$whoami: opendir $dir failed: $!\n";
    my @entries = readdir(D) or die "$whoami: readdir $dir failed: $!\n";
    closedir(D);
    my $entry;
    foreach $entry (@entries)
    {
	next if (($entry eq ".") || ($entry eq ".."));
	my $file = "$dir/$entry";
	if (-l $file)
	{
	    &error("$file is a symbolic link");
	}
	elsif (-d $file)
	{
	    push(@dirs, $file);
	}
	elsif (-f $file)
	{
	    if (-w $file)
	    {
		&error("$file is writable");
	    }
	    if ($file =~ s:(.*)/RCS/([^/]+),v:$1/$2:)
	    {
		$logs{$file} = 1;
	    }
	    else
	    {
		$files{$file} = 1;
	    }
	}
	else
	{
	    &error("$file is neither a file nor a directory");
	}
    }
}

my @files = ();
for (sort keys %files)
{
    if (exists $logs{$_})
    {
	delete $logs{$_};
	push(@files, $_);
    }
    else
    {
	&error("$_ does not have an RCS log");
    }
}
for (sort keys %logs)
{
    &error("a log for $_ seems to exist, but the file does not");
}

if ($errors)
{
    die "$whoami: errors detected; exiting\n";
}

print "$whoami: there is a one-to-one mapping between files and RCS logs\n"
    if $verbose;

my $file;
foreach $file (@files)
{
    open(RCSDIFF, "rcsdiff $file 2>/dev/null|")
	or die "$whoami: can't run rcsdiff $file: $!\n";
    my @lines = ();
    while (<RCSDIFF>)
    {
	if (m/^[<>] /)
	{
	    s/^[<>] //;
	    push(@lines, $_);
	}
    }
    close(RCSDIFF);
    
    if (scalar(@lines) > 0)
    {
	my $diff_okay = 0;
	my @slines = sort {$a cmp $b} @lines;
	if ((scalar(@slines) % 2) == 0)
	{
	    $diff_okay = 1;
	    my $i;
	    for ($i = 0; $i < scalar(@lines); $i += 2)
	    {
		if ($slines[$i] =~ m/\$([a-zA-Z]+:)/)
		{
		    my $pat = "\\\$" . $1;
		    if ($slines[$i + 1] !~ m/$pat/)
		    {
			$diff_okay = 0;
		    }
		}
		else
		{
		    $diff_okay = 0;
		}
	    }
	}
	if (! $diff_okay)
	{
	    &error("$file is out of date with its RCS log");
	}
    }

    chomp(my $locked = `rlog -l -L -R $file 2>/dev/null | wc -l`);
    if ($?)
    {
	&error("rlog $file failed: $!");
    }
    if ($locked !~ m/\s*0\s*/)
    {
	&error("$file is locked");
    }
}

if ($errors)
{
    die "$whoami: errors detected; exiting\n";
}

print "$whoami: all files are up-to-date\n" if $verbose;

exit 0 if $check_only;

my $tmpfile = "/tmp/$whoami.tarlist.$$";
$SIG{'INT'} = $SIG{'HUP'} = $SIG{'TERM'} = sub { exit 2 };
my $on_exit = new OnExit(sub { unlink @_ }, [$tmpfile]);

open(TMPFILE, ">$tmpfile") or die "$whoami: can't create $tmpfile: $!\n";
map { print TMPFILE $_, "\n" } @files;
close(TMPFILE) or die "$whoami: close of $tmpfile failed: $!\n";

system("$tar_command -c -f - --files-from $tmpfile | " .
       "(cd $destdir; $tar_command xf -)");
if ($? != 0)
{
    die "$whoami: copy failed with status $?\n";
}

sub error
{
    my $msg = shift;
    $errors++;
    warn "$whoami: $msg\n";
}

sub yn
{
    my $prompt = shift;
    my $answer;
    print $prompt;
    do
    {
	chop($answer = <STDIN>);
	if ($answer eq "y")
	{
	    return 1;
	}
	elsif ($answer eq "n")
	{
	    return 0;
	}
	else
	{
	    print "Please enter y or n: ";
	}
    }
    while (($answer ne "y") && ($answer ne "n"));
}

sub usage
{
    print STDERR <<EOF;

Usage: $whoami options

  Options include
    -src source_dir         specifies source directory
    -dest dest_dir	    specifies destination directory
    -check		    means check only; do not copy
    -v[vvv]		    verbose (more v's means more verbose)

  This script takes a directory whose contents are controlled by RCS
  and makes a copy of the files without the RCS logs if the following
  preconditions are met:

   * There are no writable files
   * All files are under RCS control
   * All files match the latest revision on the head branch of the RCS
     logs 
  
EOF
    ;
    exit 2;
}