#!/usr/bin/perl -wT
#
# EMULAB-COPYRIGHT
# Copyright (c) 2005 University of Utah and the Flux Group.
# All rights reserved.
#
# XXX Need to deal with locking at some point ...
#
package libArchive;

use strict;
use Exporter;
use vars qw(@ISA @EXPORT);

@ISA    = "Exporter";
@EXPORT = qw ( );

# Must come after package declaration!
use lib '@prefix@/lib';
use libdb;
use libtestbed;
use English;
use File::stat;
use File::Basename;
use POSIX qw(strftime);
use Time::HiRes qw(gettimeofday);

# Configure variables
my $TB		= "@prefix@";
my $MAINSITE    = @TBMAINSITE@;
my $ALLOWEDPID  = "testbed";
# XXX
my $ARCHIVEDIR  = "/usr/testbed/exparchive";
my $TESTMODE    = @TESTMODE@;
my $TBOPS       = "@TBOPSEMAIL@";
my $ELABINELAB  = @ELABINELAB@;
my $MD5		= "/sbin/md5";
my $MKDIR       = "/bin/mkdir";
my $CHMOD       = "/bin/chmod";
my $TAR		= "/usr/bin/tar";
my $RM		= "/bin/rm";
my $SVN         = "/usr/local/bin/svn";
my $SVNADMIN    = "/usr/local/bin/svnadmin";
my $IMPORTER    = "$TB/sbin/svn_load_dirs.pl";
my $inittag     = 'root';
my $defaultview = 'head';
my $debug       = 1;
my $svnopt      = ($debug ? "" : "-q");

# Little helper and debug function.
sub mysystem($)
{
    my ($command) = @_;

    print STDERR "Running '$command'\n"
	if ($debug);
    system($command);
}

#
# Create a new archive. Returns -1 if any error. Otherwise return
# the new record index.
# 
sub ArchiveCreate(;$$)
{
    my ($tag, $view) = @_;
    
    my $idx;
    my $dir;

    $tag = $inittag
	if (!defined($tag));
    $view = $defaultview
	if (!defined($view));

    # Tags cannot must start with a letter.
    if ($tag =~ /^\d+/) {
	$tag = "T" . $tag;
    }

    #
    # Need to create the directory for it, once we have the index.
    # 
    my $query_result =
	DBQueryWarn("insert into archives set ".
		    "  idx=NULL, ".
		    "  date_created=UNIX_TIMESTAMP(now())");

    return -1
	if (!$query_result);

    $idx = $query_result->insertid;
    $dir = "$ARCHIVEDIR/$idx";

    #
    # Create the directory and store the absolute path into the new record.
    # This should probably be a privledged operation at some point.
    # 
    mysystem("$MKDIR $dir") == 0 or goto bad;
    mysystem("$CHMOD 775 $dir") == 0 or goto bad;

    DBQueryWarn("update archives set directory='$dir' where idx='$idx'")
	or goto bad;

    #
    # Make subdirs. One to hold the control tree, and the other
    # to hold currently checked out versions of the tree. Lastly, we
    # need a place to copyin files before they are added to the repo.
    #
    my $repodir   = "$dir/repo";
    my $checkouts = "$dir/checkouts";
    my $checkins  = "$dir/checkins";

    if (! mkdir("$repodir", 0777)) {
	print STDERR "ArchiveCreate: Could not mkdir $repodir: $!\n";
	goto bad;
    }
    if (! chmod(0777, "$repodir")) {
	print STDERR "ArchiveCreate: Could not chmod $repodir: $!\n";
	goto bad;
    }
    if (! mkdir("$checkouts", 0777)) {
	print STDERR "ArchiveCreate: Could not mkdir $checkouts: $!\n";
	goto bad;
    }
    if (! chmod(0777, "$checkouts")) {
	print STDERR "ArchiveCreate: Could not chmod $checkouts: $!\n";
	goto bad;
    }
    if (! mkdir("$checkins", 0777)) {
	print STDERR "ArchiveCreate: Could not mkdir $checkins: $!\n";
	goto bad;
    }
    if (! chmod(0777, "$checkins")) {
	print STDERR "ArchiveCreate: Could not chmod $checkins: $!\n";
	goto bad;
    }
    if (! mkdir("$checkins/$view", 0777)) {
	print STDERR "ArchiveCreate: Could not mkdir $checkins/$view: $!\n";
	goto bad;
    }
    if (! chmod(0777, "$checkins/$view")) {
	print STDERR "ArchiveCreate: Could not chmod $checkins/$view: $!\n";
	goto bad;
    }
    # Initialize the repo.
    mysystem("$SVNADMIN create $repodir") == 0
	or goto bad;
    
    # Create an stub directory tree and import it as "root"
    mysystem("cd $dir; mkdir ignore; cd ignore; mkdir $view; ".
             "         mkdir $view/trunk $view/savepoint $view/tags; ".
	     "         mkdir $view/history; ".
	     "$SVN import -m 'ArchiveCreate' $view file://$repodir/$view")
	== 0 or goto bad;

    # Create a branch tag in the tags directory to base differences against.
    mysystem("$SVN copy -m 'ArchiveCreate Branch' ".
	     "          file://$repodir/$view/trunk ".
	     "          file://$repodir/$view/tags/${tag}-branch")
	== 0 or goto bad;
    
    # Now check it out. This creates the $checkouts/$view directory.
    mysystem("cd $checkouts; ".
	     "$SVN checkout $svnopt file://$repodir/$view")
	== 0 or goto bad;

    # Now enter the default view (okay, branch) of this archive.
    DBQueryWarn("insert into archive_views set ".
		"  current_tag='$tag', archive_idx='$idx', view='$view', ".
		"  date_created=UNIX_TIMESTAMP(now())") or goto bad;
    
    # Now enter an initial tag for the tree. Nothing actually gets tagged.
    DBQueryWarn("insert into archive_tags set idx=NULL, ".
		"  tag='$tag', archive_idx='$idx', ".
		"  date_created=UNIX_TIMESTAMP(now())") or goto bad;
    
    return $idx;

  bad:
#    mysystem("$RM -rf $dir")
#        if (defined($dir));
    DBQueryFatal("delete from archive_views ".
		 "where view='$view' and archive_idx='$idx'")
	if (defined($idx));
    DBQueryFatal("delete from archives where idx='$idx'")
	if (defined($idx));
    return -1;
}

#
# Add a file to an archive. Returns -1 if any error. Otherwise return 0.
# All this does is copy the file (and its directory structure) into the
# temporary store. Later, after all the files are in the tree, must
# commit it to the repo. 
#
sub ArchiveAdd($$;$)
{
    my ($archive_idx, $pathname, $view) = @_;

    $view = $defaultview
	if (!defined($view));

    if (! -e $pathname || ! -r $pathname) {
	print STDERR "ArchiveFile: $pathname cannot be read!\n";
	return -1;
    }

    if (! -f $pathname) {
	print STDERR "ArchiveFile: $pathname must be a plain file!\n";
	return -1;
    }
    #
    # Check that the path does not contain an links to files outside
    # the directory space the user is allowed to access.
    #
    my $realpath = `realpath $pathname`;
    if ($realpath =~ /^([-\w\/\.\+\@,]+)$/) {
	$realpath = $1;
    }
    else {
	print STDERR "ArchiveFile: ".
	    "Bad data returned by realpath: $realpath\n";
    }
    #
    # The file must reside in /proj, /groups, or /users. 
    #
    if (! ($realpath =~ /^\/proj/) &&
	! ($realpath =~ /^\/groups/) &&
	! ($realpath =~ /^\/users/)) {
	print STDERR "ArchiveFile: ".
	    "$realpath does not resolve to an allowed directory!\n";
	return -1;
    }
    
    # Strip leading / from the pathname, and taint check it. 
    if ($pathname =~ /^[\/]+([-\w\/\.\+\@,]+)$/) {
	$pathname = $1;
    }
    else {
	print STDERR "ArchiveFile: Illegal characters in pathname $pathname\n";
	return -1;
    }

    #
    # See if the archive exists and if it does, get the pathname to it.
    #
    my $directory;
    if (GetArchiveDirectory($archive_idx, \$directory) < 0) {
	print STDERR "ArchiveFile: ".
	    "Archive '$archive_idx' does not exist in the DB!\n";
	return -1;
    }
    if (! -d $directory || ! -w $directory) {
	print STDERR "ArchiveFile: $directory cannot be written!\n";
	return -1;
    }
    my $repodir   = "$directory/repo";
    my $checkout  = "$directory/checkouts/$view";
    my $checkin   = "$directory/checkins/$view";
    
    #
    # See if the file is already in the archive. We currently deal with
    # just files; directories are gonna be a pain in the butt.
    #
    my $target_path = "$checkin/$pathname";

    #
    # The file should not already exist in the temporary store. 
    #
    if (-e $target_path) {
	print STDERR "ArchiveFile: ".
	    "WARNING: $pathname already exists in archive '$archive_idx'!\n";
    }

    #
    # Not in the archive. Copy the file in. We use tar cause we
    # want to retain the directory structure and mode bits, etc.
    #
    mysystem("$TAR cf - -C / $pathname | tar xf - -C $checkin");
    if ($?) {
	print STDERR "ArchiveFile: Could not copy in /$pathname\n";
	return -1;
    }
    return 0;
}

#
# Bring the current contents of the temporary store into the archive as a
# checkpoint (or a savepoint I guess). Implementationlly, its really a
# branch off the current import revision, since it does not become a new
# head revision until the entire branch (all the savepoints) is committed
# later, say when the experiment is swapped out.
#
sub ArchiveSavePoint($;$$)
{
    my ($archive_idx, $savetag, $view) = @_;
    my $cwd;

    $view = $defaultview
	if (!defined($view));

    return -1
	if (TBScriptLock("archive_${archive_idx}", 0, 120) !=
	    TBSCRIPTLOCK_OKAY());

    #
    # See if the archive exists and if it does, get the pathname to it.
    #
    my $directory;
    if (GetArchiveDirectory($archive_idx, \$directory) < 0) {
	print STDERR "ArchiveSavePoint: ".
	    "Archive '$archive_idx' does not exist in the DB!\n";
	goto bad;
    }
    if (! -d $directory || ! -w $directory) {
	print STDERR "ArchiveSavePoint: $directory cannot be written!\n";
	goto bad;
    }
    my $repodir   = "$directory/repo";
    my $checkout  = "$directory/checkouts/$view";
    my $checkin   = "$directory/checkins/$view";

    # Need to remember where we came from!
    chomp($cwd = `pwd`);
    # Must do the taint check too.
    if ($cwd =~ /^([-\w\.\/]+)$/) {
	$cwd = $1;
    }
    else {
	print STDERR "ArchiveSavePoint: Bad data in $cwd!\n";
	goto bad;
    }

    # Get the current tag for the archive.
    my ($archive_tag);
    if (GetArchiveCurrentTags($archive_idx, $view, \$archive_tag) < 0) {
	print STDERR "ArchiveSavePoint: ".
	    "Archive '$archive_idx' does not have a current tag!\n";
	goto bad;
    }

    # Make up a savetag if one not provided.
    if (!defined($savetag)) {
	my ($seconds, $microseconds) = gettimeofday();
	
	$savetag  = POSIX::strftime("T20%y%m%d-%H%M%S-", localtime());
	$savetag .= $microseconds;
	$savetag .= "_savepoint";
    }

    # Tags must start with a letter.
    if ($savetag =~ /^\d+/) {
	$savetag = "T" . $savetag;
    }
    
    #
    # Use svn import command. This is nice cause it handles all the
    # subdirs and stuff in one shot, instead of trying to deal with
    # each file and directory individually.
    #
    if (! chdir("$checkin")) {
	print STDERR "ArchiveSavePoint: Cannot chdir to $checkin!\n";
	goto bad;
    }
    mysystem("$IMPORTER -no_user_input file://$repodir ".
	     "          $view/savepoint . ")
	== 0 or goto bad;

    #
    # Create the tag for this savepoint. 
    # 
    mysystem("$SVN copy -m 'ArchiveCreate Branch' ".
	     "          file://$repodir/$view/savepoint ".
	     "          file://$repodir/$view/tags/${savetag}")
	== 0 or goto bad;
    

    #
    # And record the new tag. 
    # 
    DBQueryWarn("insert into archive_tags set idx=NULL, ".
		"  tag='$savetag', ".
		"  archive_idx='$archive_idx', ".
		"  date_created=UNIX_TIMESTAMP(now())") or goto bad;

  okay:
    TBScriptUnlock();
    chdir($cwd)
	if (defined($cwd));
    return 0;

  bad:
    TBScriptUnlock();
    chdir($cwd)
	if (defined($cwd));
    return -1;
}

#
# Commit the current contents of the temporary store to the archive.
# Returns -1 if any error. Otherwise return 0.
#
sub ArchiveCommit($;$$$)
{
    my ($archive_idx, $newtag, $view, $altdir) = @_;
    my $noactivity = 0;
    my $cwd;

    $view = $defaultview
	if (!defined($view));

    return -1
	if (TBScriptLock("archive_${archive_idx}", 0, 120) !=
	    TBSCRIPTLOCK_OKAY());

    #
    # See if the archive exists and if it does, get the pathname to it.
    #
    my $directory;
    if (GetArchiveDirectory($archive_idx, \$directory) < 0) {
	print STDERR "ArchiveCommit: ".
	    "Archive '$archive_idx' does not exist in the DB!\n";
	goto bad;
    }
    if (! -d $directory || ! -w $directory) {
	print STDERR "ArchiveCommit: $directory cannot be written!\n";
	goto bad;
    }
    my $repodir   = "$directory/repo";
    my $checkout  = "$directory/checkouts/$view";
    my $checkin   = (defined($altdir) ? $altdir : "$directory/checkins/$view");

    # Need to remember where we came from!
    chomp($cwd = `pwd`);
    # Must do the taint check too.
    if ($cwd =~ /^([-\w\.\/]+)$/) {
	$cwd = $1;
    }
    else {
	print STDERR "ArchiveSavePoint: Bad data in $cwd!\n";
	goto bad;
    }

    if (! chdir("$checkin")) {
	print STDERR "ArchiveCommit: Cannot chdir to $checkin!\n";
	goto bad;
    }

    # Get the current tags for the archive.
    my ($archive_tag, $previous_tag);
    if (GetArchiveCurrentTags($archive_idx, $view, \$archive_tag,
			      \$previous_tag) < 0) {
	print STDERR "ArchiveCommit: ".
	    "Archive '$archive_idx' does not have a current tag!\n";
	goto bad;
    }

    #
    # Form new tag.
    # 
    my ($seconds, $microseconds) = gettimeofday();
    my $import_tag  = POSIX::strftime("T20%y%m%d-%H%M%S-", localtime());
    $import_tag    .= $microseconds;

    if (!defined($newtag)) {
	$newtag = $import_tag . "_commit";
    }

    # Tags cannot must start with a letter.
    if ($newtag =~ /^\d+/) {
	$newtag = "T" . $newtag;
    }

    #
    # Lets see if there has been any action since the last commit.
    # Check for new tags, and if nothing has happened, just drop a
    # new set of tags in and return.
    #
    my $query_result =
	DBQueryWarn("select tag from archive_tags ".
		    "where archive_idx='$archive_idx' ".
		    "order by idx desc limit 1");
    goto bad
	if (!$query_result || !$query_result->numrows);
    
    my ($tmptag) = $query_result->fetchrow_array();
    if ($tmptag eq $archive_tag) {
	print "ArchiveCommit: Archive is clean; no need to commit.\n";
	$noactivity = 1;
    }
    
    # Clean the temp dir for next phase.
    mysystem("/bin/rm -rf $checkin/*");
    if ($?) {
	print STDERR "ArchiveCommit: Could not clean $checkin!\n";
	goto bad;
    }

    #
    # Okay, do the commit to the trunk for this view.
    # 
    if (! $noactivity) {
	#
	# Check out the current trunk.
	#
	mysystem("$SVN checkout $svnopt file://$repodir/$view/trunk")
	    == 0 or goto bad;

	#
	# Do a merge from the branch off the previous commit tag, with
	# the savepoint. This is merged into the working directory we
	# just checked out above. This will do the work of scheduling
	# additions and deletions.
	#
	mysystem("$SVN merge $svnopt ".
		 "     file://$repodir/$view/tags/${archive_tag}-branch ".
		 "     file://$repodir/$view/savepoint ".
		 "     trunk")
	    == 0 or goto bad;

	#
	# Now commit to the trunk!
	#
	mysystem("$SVN commit $svnopt ".
		 "     -m 'Commit merge of ${archive_tag} to trunk' trunk")
	    == 0 or goto bad;
    }

    # Create a tag in the tags directory for the commit.
    mysystem("$SVN copy -m 'ArchiveCommit' ".
	     "          file://$repodir/$view/trunk ".
	     "          file://$repodir/$view/tags/${newtag}")
	== 0 or goto bad;
    
    # Create a tag in the history directory for the commit. The
    # history directory has just the commit tags, so its easy to go
    # back in time.
    mysystem("$SVN copy -m 'ArchiveCommit' ".
	     "          file://$repodir/$view/trunk ".
	     "          file://$repodir/$view/history/${newtag}")
	== 0 or goto bad;
    
    # Create a branch tag in the tags directory to base differences against.
    mysystem("$SVN copy -m 'ArchiveCommit Branch' ".
	     "          file://$repodir/$view/trunk ".
	     "          file://$repodir/$view/tags/${newtag}-branch")
	== 0 or goto bad;
    
    DBQueryWarn("insert into archive_tags set idx=NULL, ".
		"  tag='$newtag', ".
		"  archive_idx='$archive_idx', ".
		"  date_created=UNIX_TIMESTAMP(now())")
	or goto bad;

    DBQueryWarn("update archive_views set ".
		"  current_tag='$newtag', ".
		"  previous_tag='$archive_tag' ".
		"where archive_idx='$archive_idx' and view='$view'")
	or goto bad;

    # Clean the temp dir for later.
    mysystem("/bin/rm -rf $checkin/*");
    if ($?) {
	print STDERR "ArchiveCommit: Could not clean $checkin!\n";
	goto bad;
    }

    # And now into the checkout dir to checkout a current copy.
    if (! chdir("$checkout")) {
	print STDERR "ArchiveCommit: Cannot chdir to $checkout!\n";
	goto bad;
    }
    mysystem("$SVN $svnopt update trunk");
    if ($?) {
	print STDERR "ArchiveCommit: Could not update head revision!\n";
	goto bad;
    }
  okay:
    TBScriptUnlock();
    chdir($cwd)
	if (defined($cwd));
    return 0;

  bad:
    TBScriptUnlock();
    chdir($cwd)
	if (defined($cwd));
    return -1;
}

#
# Fork an archive (okay, branch) for use in separate development. Note that
# once forked, there is no join, as that would be impossibly hard to deal
# with cause of conflicts.
#
sub ArchiveFork($$;$$$)
{
    my ($archive_idx, $newview, $branchtag, $newtag, $view) = @_;
    my $sourcepoint;
    my $cwd;

    $view = $defaultview
	if (!defined($view));

    return -1
	if (TBScriptLock("archive_${archive_idx}", 0, 120) !=
	    TBSCRIPTLOCK_OKAY());

    #
    # See if the archive exists and if it does, get the pathname to it.
    #
    my $directory;
    if (GetArchiveDirectory($archive_idx, \$directory) < 0) {
	print STDERR "ArchiveCommit: ".
	    "Archive '$archive_idx' does not exist in the DB!\n";
	goto bad;
    }
    if (! -d $directory || ! -w $directory) {
	print STDERR "ArchiveCommit: $directory cannot be written!\n";
	goto bad;
    }
    my $repodir     = "$directory/repo";
    my $checkouts   = "$directory/checkouts";
    my $checkout    = "$directory/checkouts/$view";
    my $checkin     = "$directory/checkins/$view";
    my $newcheckout = "$directory/checkouts/$newview";
    my $newcheckin  = "$directory/checkins/$newview";

    # Need to remember where we came from!
    chomp($cwd = `pwd`);
    # Must do the taint check too.
    if ($cwd =~ /^([-\w\.\/]+)$/) {
	$cwd = $1;
    }
    else {
	print STDERR "ArchiveSavePoint: Bad data in $cwd!\n";
	goto bad;
    }

    # Get the current tags for the archive.
    my ($archive_tag, $previous_tag);
    if (GetArchiveCurrentTags($archive_idx, $view, \$archive_tag,
			      \$previous_tag) < 0) {
	print STDERR "ArchiveCommit: ".
	    "Archive '$archive_idx' does not have a current tag!\n";
	goto bad;
    }

    #
    # Form new tag.
    # 
    my ($seconds, $microseconds) = gettimeofday();
    my $import_tag  = POSIX::strftime("T20%y%m%d-%H%M%S-", localtime());
    $import_tag    .= $microseconds;

    if (!defined($newtag)) {
	$newtag = $import_tag . "_fork";
    }

    # Tags cannot must start with a letter.
    if ($newtag =~ /^\d+/) {
	$newtag = "T" . $newtag;
    }

    # Create new view directories and checkout.
    if (! mkdir("$newcheckin", 0777)) {
	print STDERR "ArchiveCreate: Could not mkdir $newcheckin: $!\n";
	goto bad;
    }
    if (! chmod(0777, "$newcheckin")) {
	print STDERR "ArchiveCreate: Could not chmod $newcheckin: $!\n";
	goto bad;
    }

    # Create newview directory in the repo.
    mysystem("$SVN mkdir -m 'ArchiveFork' ".
	     "          file://$repodir/$newview")
	== 0 or goto bad;

    # Split at the trunk if no branchpoint provided.
    if (defined($branchtag)) {
	$sourcepoint = "tags/$branchtag";
    }
    else {
	$sourcepoint = "trunk"
    }

    # Copy the trunk of the old view.
    mysystem("$SVN copy $svnopt -m 'ArchiveFork' ".
	     "          file://$repodir/$view/$sourcepoint ".
	     "          file://$repodir/$newview/trunk")
	== 0 or goto bad;

    # Do not want to copy the tags/savepoints directories. Add new ones.
    mysystem("$SVN mkdir -m 'ArchiveFork' ".
	     "          file://$repodir/$newview/savepoint ".
	     "          file://$repodir/$newview/tags")
	== 0 or goto bad;

    # Now check it out. This creates the checkouts/$newview directory.
    mysystem("cd $checkouts; ".
	     "$SVN checkout $svnopt file://$repodir/$newview")
	== 0 or goto bad;

    # Now enter the newview (okay, branch) of this archive.
    DBQueryWarn("insert into archive_views set ".
		"  current_tag='$newtag', archive_idx='$archive_idx', ".
		"  view='$newview', ".
		"  date_created=UNIX_TIMESTAMP(now())") or goto bad;
    
    # Now enter an initial tag for the new view. Nothing actually gets tagged.
    DBQueryWarn("insert into archive_tags set idx=NULL, ".
		"  tag='$newtag', archive_idx='$archive_idx', ".
		"  date_created=UNIX_TIMESTAMP(now())") or goto bad;

  okay:
    TBScriptUnlock();
    chdir($cwd)
	if (defined($cwd));
    return 0;

  bad:
    TBScriptUnlock();
    chdir($cwd)
	if (defined($cwd));
    return -1;
}

#
# Archive the Archive, moving it into the expinfo directory.
# I intend this to be run only when an experiment is terminated.
# No need to have two copies.
#
sub ArchiveArchive($$)
{
    my ($archive_idx, $dirpath) = @_;
    my $target = "$dirpath/Archive";

    #
    # See if the archive exists and if it does, get the pathname to it.
    #
    my $directory;
    if (GetArchiveDirectory($archive_idx, \$directory) < 0) {
	print STDERR "ArchiveCommit: ".
	    "Archive '$archive_idx' does not exist in the DB!\n";
	return -1;
    }
    if (! -d $directory || ! -w $directory) {
	print STDERR "ArchiveFile: $directory cannot be written!\n";
	return -1;
    }
    my $repodir  = "$directory/repo";

    if (! -e $target) {
	if (! mkdir("$target", 0777)) {
	    print STDERR "ArchiveArchive: Could not mkdir $target: $!\n";
	    return -1;
	}
	if (! chmod(0777, "$target")) {
	    print STDERR "ArchiveArchive: ".
		"Could not chmod directory $target: $!\n";
	    return -1;
	}
    }    

    #
    # Tar up the whole thing and move it across.
    #
    mysystem("$TAR cf - -C $repodir . | tar xf - -C $target");
    if ($?) {
	print STDERR "ArchiveArchive: Could not copy in $directory\n";
	return -1;
    }
    return 0;
}

#
# Destroy an archive. The DB state is retained unless optional flag says
# to clean it.
#
sub ArchiveDestroy($;$)
{
    my ($archive_idx, $clean) = @_;

    #
    # See if the archive exists and if it does, get the pathname to it.
    #
    my $directory;
    if (GetArchiveDirectory($archive_idx, \$directory) < 0) {
	print STDERR "ArchiveDestroy: ".
	    "Archive '$archive_idx' does not exist in the DB!\n";
	return -1;
    }
    if (! -d $directory || ! -w $directory) {
	print STDERR "ArchiveDestroy: $directory does not exist!\n";
	return 0;
    }

    mysystem("/bin/rm -rf $directory");
    if ($?) {
	print STDERR "ArchiveDestroy: ".
	    "Could not remove contents of $directory!\n";
	return -1;
    }
    if (defined($clean) && $clean) {
	(DBQueryWarn("delete from archive_tags ".
		     "where archive_idx='$archive_idx'") &&
	 DBQueryWarn("delete from archive_views ".
		     "where archive_idx='$archive_idx'") &&
	 DBQueryWarn("delete from archives ".
		     "where idx='$archive_idx'")) || return -1;
    }
    return 0;
}

#
# Get the directory for an archive, given its index. Returns -1 on error,
# zero otherwise. 
#
sub GetArchiveDirectory($$)
{
    my ($idx, $rvalp) = @_;
    
    my $query_result =
	DBQueryWarn("select directory from archives where idx='$idx'");

    return -1
	if (!$query_result || !$query_result->numrows);
    my ($dir) = $query_result->fetchrow_array();

    $$rvalp = $dir
	if (defined($rvalp));
    return 0;
}

#
# Get the current tag for an archive, given its index. Returns -1 on error,
# zero otherwise. Place tag in the return pointer.
#
sub GetArchiveCurrentTags($$$;$)
{
    my ($archive_idx, $view, $tagp, $prevp) = @_;
    
    my $query_result =
	DBQueryWarn("select v.current_tag,v.previous_tag ".
		    "    from archive_views as v ".
		    "left join archive_tags as t on ".
		    "     t.archive_idx=v.archive_idx and ".
		    "     t.tag=v.current_tag ".
		    "where v.archive_idx='$archive_idx' and ".
		    "      v.view='$view'");

    return -1
	if (!$query_result);
    my ($tag,$previous) = $query_result->fetchrow_array();
    
    $$tagp = $tag
	if (defined($tagp));
    $$prevp = $previous
	if (defined($prevp));
    return 0;
}

#
# Get the archive index for an experiment. The index is kept in the historical
# experiment_stats table, not the current experiments table. That is cause
# we keep the archive and its DB info around forever with the stats.
#
sub TBExperimentArchiveInfo($$$$)
{
    my ($pid, $eid, $idxp, $viewp) = @_;

    my $query_result =
	DBQueryWarn("select s.archive_idx,e.idx from experiments as e ".
		    "left join experiment_stats as s on s.exptidx=e.idx ".
		    "where e.pid='$pid' and e.eid='$eid'");

    return -1
	if (!$query_result || $query_result->numrows == 0);

    my ($archive_idx,$exptidx) = $query_result->fetchrow_array();

    return -1
	if (!defined($archive_idx));

    $$idxp = $archive_idx
	if (defined($idxp));
    $$viewp = "$exptidx"
	if (defined($viewp));
    
    return 0;
}

#
# Create a new archive for an experiment. This has to update the
# experiment_stats table with the newly created archive index.
# Then we have to set the current tag for the experiment in the
# resources table for the experiment.
# Returns zero on success, -1 on failure.
#
sub TBCreateExperimentArchive($$)
{
    my ($pid, $eid) = @_;

    return 0
	if (!$MAINSITE || $pid ne $ALLOWEDPID);

    # Grab experiment indicies we need,
    my $query_result =
	DBQueryWarn("select e.idx,s.rsrcidx from experiments as e ".
		    "left join experiment_stats as s on e.idx=s.exptidx ".
		    "where e.pid='$pid' and e.eid='$eid'");
    if (!$query_result || !$query_result->numrows) {
	return -1;
    }

    my ($exptidx,$rsrcidx) = $query_result->fetchrow_array();
    my $archive_tag = "T${rsrcidx}";

    #
    # Create the new archive and get back the new index. 
    #
    my $archive_idx = ArchiveCreate($archive_tag, "$exptidx");
    return -1
	if ($archive_idx < 0);

    if (! (DBQueryWarn("update experiment_stats set ".
		       "      archive_idx='$archive_idx' ".
		       "where pid='$pid' and eid='$eid' and ".
		       "      exptidx='$exptidx'") &&
	   DBQueryWarn("update experiment_resources set ".
		       "      archive_tag='$archive_tag' ".
		       "where idx='$rsrcidx'"))) {
	ArchiveDestroy($archive_idx, 1);
	return -1;
    }
    return 0;
}

#
# Add a file to an experiment archive.
#
sub TBExperimentArchiveAddFile($$$)
{
    my ($pid, $eid, $pathname) = @_;
    my ($archive_idx, $view);

    return 0
	if (!$MAINSITE || $pid ne $ALLOWEDPID);

    return -1
	if (TBExperimentArchiveInfo($pid, $eid, \$archive_idx, \$view) < 0);

    return ArchiveAdd($archive_idx, $pathname, $view);
}

#
# SavePoint an experiment archive. 
#
sub TBExperimentArchiveSavePoint($$$)
{
    my ($pid, $eid, $tagext) = @_;
    my ($archive_idx, $view);

    return 0
	if (!$MAINSITE || $pid ne $ALLOWEDPID);

    return -1
	if (TBExperimentArchiveInfo($pid, $eid, \$archive_idx, \$view) < 0);

    #
    # Derive a tag that contains some useful info?
    #
    my ($seconds, $microseconds) = gettimeofday();
    my $newtag  = POSIX::strftime("T20%y%m%d-%H%M%S-", localtime());
    $newtag .= int($microseconds / 1000);
    $newtag .= "_${tagext}";

    return ArchiveSavePoint($archive_idx, $newtag, $view);
}

#
# Setup for a swapmod. A pain in the butt!
#
sub TBExperimentArchivePreSwapMod($$)
{
    my ($pid, $eid) = @_;
    my ($archive_idx, $view);

    return 0
	if (!$MAINSITE || $pid ne $ALLOWEDPID);

    return -1
	if (TBExperimentArchiveInfo($pid, $eid, \$archive_idx, \$view) < 0);

    my $directory;
    if (GetArchiveDirectory($archive_idx, \$directory) < 0) {
	print STDERR "ArchivePreSwapMod: ".
	    "Archive '$archive_idx' does not exist in the DB!\n";
	return -1;
    }
    if (! -d $directory || ! -w $directory) {
	print STDERR "ArchivePreSwapMod: $directory cannot be written!\n";
	return -1;
    }
    my $checkin    = "$directory/checkins/$view";
    my $preswapdir = "${checkin}.preswap";

    #
    # Derive a tag that says something useful?
    #
    my ($seconds, $microseconds) = gettimeofday();
    my $newtag  = POSIX::strftime("T20%y%m%d-%H%M%S-", localtime());
    $newtag .= int($microseconds / 1000);
    $newtag .= "_preswapmod";

    #
    # Do a savepoint just for grins,
    #
    return -1
	if (ArchiveSavePoint($archive_idx, $newtag, $view) != 0);

    #
    # Make a copy of the current tree, since its easier to rollback
    # if I just wait before doing a commit (until swapmod really finishes).
    #
    if (-e $preswapdir) {
	system("/bin/rm -rf $preswapdir");
	if (-e $preswapdir) {
	    print STDERR
		"ArchivePreSwapMod: Could not delete old preswap dir!\n";
	    return -1;
	}
    }
    if (! mkdir("$preswapdir", 0777)) {
	print STDERR "ArchivePreSwapMod: Could not mkdir $preswapdir: $!\n";
	return -1;
    }
    if (! chmod(0777, "$preswapdir")) {
	print STDERR "ArchivePreSwapMod: ".
	    "Could not chmod directory $preswapdir: $!\n";
	goto bad;
    }
    
    mysystem("$TAR cf - -C $checkin . | tar xf - -C $preswapdir");
    if ($?) {
	print STDERR "ArchivePreSwapMod: Could not copy to $preswapdir\n";
	goto bad;
    }
    return 0;

  bad:
    # Be sure to remove the new directory!
    if (-e $preswapdir) {
	system("/bin/rm -rf $preswapdir");
	if (-e $preswapdir) {
	    print STDERR
		"ArchivePreSwapMod: Could not delete new preswap dir!\n";
	}
    }
    return -1;
}

#
# Rollback from a failed swapmod.
#
sub TBExperimentArchiveRollBack($$)
{
    my ($pid, $eid) = @_;
    my ($archive_idx, $view);

    return 0
	if (!$MAINSITE || $pid ne $ALLOWEDPID);

    return -1
	if (TBExperimentArchiveInfo($pid, $eid, \$archive_idx, \$view) < 0);

    my $directory;
    if (GetArchiveDirectory($archive_idx, \$directory) < 0) {
	print STDERR "ArchiveRollBack: ".
	    "Archive '$archive_idx' does not exist in the DB!\n";
	return -1;
    }
    if (! -d $directory || ! -w $directory) {
	print STDERR "ArchiveRollBack: $directory cannot be written!\n";
	return -1;
    }
    my $checkin    = "$directory/checkins/$view";
    my $preswapdir = "${checkin}.preswap";

    # In case we bailed out really early in the swapmod path.
    return 0
	if (! -e $preswapdir);

    #
    # Restore the old (preswap) tree to the current tree.
    #
    if (-e $checkin) {
	system("/bin/rm -rf $checkin");
	if (-e $checkin) {
	    print STDERR
		"ArchiveRollBack: Could not delete old preswap dir!\n";
	    return -1;
	}
    }
    system("/bin/mv -f $preswapdir $checkin");
    if ($?) {
	print STDERR "ArchiveRollBack: ".
	    "Could not mv $preswapdir to $checkin\n";
	return -1;
    }
    return 0;
}

#
# Swapmod completed okay. Need to commit the old preswap directory and
# move forward. 
#
sub TBExperimentArchiveSwapModCommit($$)
{
    my ($pid, $eid) = @_;
    my ($archive_idx, $view);

    return 0
	if (!$MAINSITE || $pid ne $ALLOWEDPID);

    return -1
	if (TBExperimentArchiveInfo($pid, $eid, \$archive_idx, \$view) < 0);

    my $directory;
    if (GetArchiveDirectory($archive_idx, \$directory) < 0) {
	print STDERR "ArchiveSwapModCommit: ".
	    "Archive '$archive_idx' does not exist in the DB!\n";
	return -1;
    }
    if (! -d $directory || ! -w $directory) {
	print STDERR "ArchiveSwapModCommit: $directory cannot be written!\n";
	return -1;
    }
    my $checkin    = "$directory/checkins/$view";
    my $preswapdir = "${checkin}.preswap";

    #
    # We need this below.
    #
    my $query_result =
	DBQueryWarn("select s.rsrcidx from experiments as e ".
		    "left join experiment_stats as s on e.idx=s.exptidx ".
		    "where e.pid='$pid' and e.eid='$eid'");
    if (!$query_result || !$query_result->numrows) {
	return -1;
    }
    my ($rsrcidx) = $query_result->fetchrow_array();

    #
    # Derive a useful tag.
    # 
    my ($seconds, $microseconds) = gettimeofday();
    my $newtag  = POSIX::strftime("T20%y%m%d-%H%M%S-", localtime());
    $newtag .= int($microseconds / 1000);
    $newtag .= "_postswapmod";

    return -1
	if (ArchiveCommit($archive_idx, $newtag, $view, $preswapdir) != 0);

    if (!DBQueryWarn("update experiment_resources set ".
		     "      archive_tag='$newtag' ".
		     "where idx='$rsrcidx'")) {
	return -1;
    }

    #
    # Remove the preswap dir, but if it fails keep going. Will catch it
    # next time above.
    # 
    system("/bin/rm -rf $preswapdir");
    if ($?) {
	print STDERR "*** ArchiveSwapModCommit: Could not rm $preswapdir\n";
    }

    return 0;
}

#
# Commit an experiment archive. 
#
sub TBCommitExperimentArchive($$$)
{
    my ($pid, $eid, $tagext) = @_;
    my ($archive_idx, $view);

    return 0
	if (!$MAINSITE || $pid ne $ALLOWEDPID);

    return -1
	if (TBExperimentArchiveInfo($pid, $eid, \$archive_idx, \$view) < 0);

    #
    # Need this below.
    #
    my $query_result =
	DBQueryWarn("select s.rsrcidx from experiments as e ".
		    "left join experiment_stats as s on e.idx=s.exptidx ".
		    "where e.pid='$pid' and e.eid='$eid'");
    if (!$query_result || !$query_result->numrows) {
	return -1;
    }
    my ($rsrcidx) = $query_result->fetchrow_array();

    #
    # Derive a tag.
    #
    my ($seconds, $microseconds) = gettimeofday();
    my $newtag  = POSIX::strftime("T20%y%m%d-%H%M%S-", localtime());
    $newtag .= int($microseconds / 1000);
    $newtag .= "_${tagext}";

    return -1
	if (ArchiveCommit($archive_idx, $newtag, $view) != 0);

    if (!DBQueryWarn("update experiment_resources set ".
		     "      archive_tag='$newtag' ".
		     "where idx='$rsrcidx'")) {
	return -1;
    }
    return 0;
}

#
# Archive an experiment archive to the save area.
# 
sub TBArchiveExperimentArchive($$)
{
    my ($pid, $eid) = @_;
    my ($archive_idx, $view);

    return 0
	if (!$MAINSITE || $pid ne $ALLOWEDPID);

    return -1
	if (TBExperimentArchiveInfo($pid, $eid, \$archive_idx, \$view) < 0);

    return ArchiveArchive($archive_idx, TBExptLogDir($pid, $eid));
}

#
# Delete an experiment archive. This just deletes it from the active area.
# Its historical DB state is retained.
#
sub TBDeleteExperimentArchive($$)
{
    my ($pid, $eid) = @_;
    my ($archive_idx, $view);

    return 0
	if (!$MAINSITE || $pid ne $ALLOWEDPID);

    return -1
	if (TBExperimentArchiveInfo($pid, $eid, \$archive_idx, \$view) < 0);

    return ArchiveDestroy($archive_idx, 0);
}

#
# Destroy an experiment archive. Totally flush it from the system.
#
sub TBDestroyExperimentArchive($$)
{
    my ($pid, $eid) = @_;
    my ($archive_idx, $view);

    return 0
	if (!$MAINSITE || $pid ne $ALLOWEDPID);

    return -1
	if (TBExperimentArchiveInfo($pid, $eid, \$archive_idx, \$view) < 0);

    return ArchiveDestroy($archive_idx, 1);
}

# _Always_ make sure that this 1 is at the end of the file...
1;