#!/usr/bin/perl -wT
#
# EMULAB-COPYRIGHT
# Copyright (c) 2005, 2006, 2007 University of Utah and the Flux Group.
# All rights reserved.
#
package Experiment;

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 libtblog;
use English;
use Data::Dumper;
use File::Basename;
use overload ('""' => 'Stringify');

# Configure variables
my $TB		= "@prefix@";
my $BOSSNODE    = "@BOSSNODE@";
my $CONTROL	= "@USERNODE@";
my $EVENTSYS    = @EVENTSYS@;
my $TEVC	= "$TB/bin/tevc";
my $DBCONTROL   = "$TB/sbin/opsdb_control";
my $RSYNC	= "/usr/local/bin/rsync";
my $MKEXPDIR    = "$TB/libexec/mkexpdir";
my $TBPRERUN    = "$TB/bin/tbprerun";
my $TBSWAP      = "$TB/bin/tbswap";
my $TBREPORT    = "$TB/bin/tbreport";
my $TBEND       = "$TB/bin/tbend";

# Hmm, this is silly. 
if ($EVENTSYS) {
    require event;
    import event;
}

# Cache of instances to avoid regenerating them.
my %experiments   = ();
my $debug	  = 0;

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

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

#
# Lookup an experiment and create a class instance to return.
#
sub Lookup($$$)
{
    my ($class, $pid, $eid) = @_;

    # Look in cache first
    return $experiments{"$pid/$eid"}
        if (exists($experiments{"$pid/$eid"}));
    
    my $query_result =
	DBQueryWarn("select * from experiments ".
		    "where pid='$pid' and eid='$eid'");

    return undef
	if (!$query_result || !$query_result->numrows);

    my $self         = {};
    $self->{'EXPT'}  = $query_result->fetchrow_hashref();

    my $idx = $self->{'EXPT'}->{'idx'};

    $query_result =
	DBQueryWarn("select * from experiment_stats where exptidx='$idx'");
	
    return undef
	if (!$query_result || !$query_result->numrows);
    
    $self->{'STATS'} = $query_result->fetchrow_hashref();
    
    # We get this lazily.
    $self->{'RSRC'}  = undef;

    bless($self, $class);
    
    # Add to cache. 
    $experiments{"$pid/$eid"} = $self;
    
    return $self;
}
# accessors
sub field($$) { return ((! ref($_[0])) ? -1 : $_[0]->{'EXPT'}->{$_[1]}); }
sub stats($$) { return ((! ref($_[0])) ? -1 : $_[0]->{'STATS'}->{$_[1]}); }

sub pid($)	    { return field($_[0], 'pid'); }
sub gid($)	    { return field($_[0], 'gid'); }
sub eid($)	    { return field($_[0], 'eid'); }
sub idx($)	    { return field($_[0], 'idx'); }
sub path($)	    { return field($_[0], 'path'); }
sub state($)	    { return field($_[0], 'state'); }
sub batchstate($)   { return field($_[0], 'batchstate'); }
sub batchmode($)    { return field($_[0], 'batchmode'); }
sub rsrcidx($)      { return stats($_[0], 'rsrcidx'); }
sub creator($)      { return field($_[0], 'expt_head_uid');}
sub canceled($)     { return field($_[0], 'canceled'); }
sub locked($)       { return field($_[0], 'expt_locked'); }
sub elabinelab($)   { return field($_[0], 'elab_in_elab');}
sub lockdown($)     { return field($_[0], 'lockdown'); }
sub created($)      { return field($_[0], 'expt_created'); }
sub swapper($)      { return field($_[0], 'expt_swap_uid');}
sub swappable($)    { return field($_[0], 'swappable');}
sub idleswap($)     { return field($_[0], 'idleswap');}
sub autoswap($)     { return field($_[0], 'autoswap');}
sub noswap_reason($){ return field($_[0], 'noswap_reason');}
sub noidleswap_reason($){ return field($_[0], 'noidleswap_reason');}
sub idleswap_timeout($) { return field($_[0], 'idleswap_timeout');}
sub autoswap_timeout($) { return field($_[0], 'autoswap_timeout');}
sub prerender_pid($)    { return field($_[0], 'prerender_pid');}
sub dpdb($)		{ return field($_[0], 'dpdb');}
sub dpdbname($)         { return field($_[0], 'dpdbname');}
sub dpdbpassword($)     { return field($_[0], 'dpdbpassword');}
sub instance_idx($)     { return field($_[0], 'instance_idx'); }
sub creator_idx($)      { return field($_[0], 'creator_idx');}
sub swapper_idx($)      { return field($_[0], 'swapper_idx');}

#
# Lookup an experiment given an experiment index.
#
sub LookupByIndex($$)
{
    my ($class, $exptidx) = @_;

    my $query_result =
	DBQueryWarn("select pid,eid from experiments ".
		    "where idx='$exptidx'");

    return undef
	if (! $query_result || !$query_result->numrows);

    my ($pid, $eid) = $query_result->fetchrow_array();

    return Experiment->Lookup($pid, $eid);
}

#
# LockTables simple locks the given tables, and then refreshes the
# experiment instance (thereby getting the data from the DB after
# the tables are locked).
#
sub LockTables($;$)
{
    my ($self, $spec) = @_;

    # Must be a real reference. 
    return -1
	if (! ref($self));

    $spec  = "experiments write"
	if (!defined($spec));
    $spec .= ", experiment_stats read";
    
    DBQueryWarn("lock tables $spec")
	or return -1;
	
    return $self->Refresh();
}
sub UnLockTables($)
{
    my ($self) = @_;

    # Must be a real reference. 
    return -1
	if (! ref($self));

    DBQueryWarn("unlock tables")
	or return -1;
    return 0;
}

#
# Create a new experiment. This installs the new record in the DB,
# and returns an instance. There is some bookkeeping along the way.
#
sub Create($$$$)
{
    my ($class, $pid, $eid, $argref) = @_;
    my $exptidx;
    my $now = time();

    return undef
	if (ref($class));

    #
    # The pid/eid has to be unique, so lock the table for the check/insert.
    #
    DBQueryWarn("lock tables experiments write, ".
		"            experiment_stats write, ".
		"            experiment_resources write, ".
		"            emulab_indicies write, ".
		"            testbed_stats read")
	or return undef;

    my $query_result =
	DBQueryWarn("select pid,eid from experiments ".
		    "where eid='$eid' and pid='$pid'");

    if ($query_result->numrows) {
	DBQueryWarn("unlock tables");
	tberror("Experiment $eid in project $pid already exists!");
	return undef;
    }

    #
    # Grab the next highest index to use. We used to use an auto_increment
    # field in the table, but if the DB is ever "dropped" and recreated,
    # it will reuse indicies that are crossed referenced in the other two
    # tables.
    #
    $query_result = 
	DBQueryWarn("select idx from emulab_indicies ".
		    "where name='next_exptidx'");

    if (!$query_result) {
	DBQueryWarn("unlock tables");
	return undef;
    }

    # Seed with a proper value.
    if (! $query_result->num_rows) {
	$query_result =
	    DBQueryWarn("select MAX(exptidx) + 1 from experiment_stats");

	if (!$query_result) {
	    DBQueryWarn("unlock tables");
	    return undef;
	}
	($exptidx) = $query_result->fetchrow_array();

	# First ever experiment!
	$exptidx = 1
	    if (!defined($exptidx));

	if (! DBQueryWarn("insert into emulab_indicies (name, idx) ".
			  "values ('next_exptidx', $exptidx)")) {
	    DBQueryWarn("unlock tables");
	    return undef;
	}

    }
    else {
	($exptidx) = $query_result->fetchrow_array();
    }
    my $nextidx = $exptidx + 1;
    
    if (! DBQueryWarn("update emulab_indicies set idx='$nextidx' ".
		      "where name='next_exptidx'")) {
	DBQueryWarn("unlock tables");
	return undef;
    }

    #
    # Lets be really sure!
    #
    foreach my $table ("experiments", "experiment_stats",
		       "experiment_resources", "testbed_stats") {

	my $slot = (($table eq "experiments") ? "idx" : "exptidx");
	
	$query_result =
	    DBQueryWarn("select * from $table where ${slot}=$exptidx");

	if (! $query_result) {
	    DBQueryWarn("unlock tables");
	    return undef;
	}
	if ($query_result->numrows) {
	    DBQueryWarn("unlock tables");
	    tberror("Experiment index $exptidx exists in $table; ".
		    "this is bad!");
	    return undef;
	}
    }

    #
    # Insert the record. This reserves the pid/eid for us. 
    #
    # Some fields special cause of quoting.
    #
    my $description = DBQuoteSpecial($argref->{'expt_name'});
    delete($argref->{'expt_name'});
    my $noswap_reason = DBQuoteSpecial($argref->{'noswap_reason'});
    delete($argref->{'noswap_reason'});
    my $noidleswap_reason = DBQuoteSpecial($argref->{'noidleswap_reason'});
    delete($argref->{'noidleswap_reason'});

    # we override this below
    delete($argref->{'idx'})
	if (exists($argref->{'idx'}));

    my $query = "insert into experiments set ".
	join(",", map("$_='" . $argref->{$_} . "'", keys(%{$argref})));

    # Append the rest
    $query .= ",expt_created=FROM_UNIXTIME('$now')";
    $query .= ",expt_locked=now(),pid='$pid',eid='$eid'";
    $query .= ",expt_name=$description";
    $query .= ",noswap_reason=$noswap_reason";
    $query .= ",noidleswap_reason=$noidleswap_reason";
    $query .= ",idx=$exptidx";

    if (! DBQueryWarn($query)) {
	DBQueryWarn("unlock tables");
	tberror("Error inserting experiment record for $pid/$eid!");	
	return undef;
    }

    #
    # Create an experiment_resources record for the above record.
    #
    $query_result =
	DBQueryWarn("insert into experiment_resources (tstamp, exptidx) ".
		    "values (FROM_UNIXTIME('$now'), $exptidx)");

    if (!$query_result) {
	DBQueryWarn("delete from experiments where pid='$pid' and eid='$eid'");
	DBQueryWarn("unlock tables");
	tberror("Error inserting experiment resources record for $pid/$eid!");
	return undef;
    }
    my $rsrcidx     = $query_result->insertid;
    my $creator_uid = $argref->{'expt_head_uid'};
    my $creator_idx = $argref->{'creator_idx'};
    my $gid         = $argref->{'gid'};
    my $batchmode   = $argref->{'batchmode'};

    #
    # Now create an experiment_stats record to match.
    #
    if (! DBQueryWarn("insert into experiment_stats ".
		      "(eid, pid, creator, creator_idx, gid, created, ".
		      " batch, exptidx, rsrcidx) ".
		      "values('$eid', '$pid', '$creator_uid', '$creator_idx',".
		      "       '$gid', FROM_UNIXTIME('$now'), ".
		      "        $batchmode, $exptidx, $rsrcidx)")) {
	DBQueryWarn("delete from experiments where pid='$pid' and eid='$eid'");
	DBQueryWarn("delete from experiment_resources where idx=$rsrcidx");
	DBQueryWarn("unlock tables");
	tberror("Error inserting experiment stats record for $pid/$eid!");
	return undef;
    }

    #
    # Safe to unlock; all tables consistent.
    #
    if (! DBQueryWarn("unlock tables")) {
	DBQueryWarn("delete from experiments where pid='$pid' and eid='$eid'");
	DBQueryWarn("delete from experiment_resources where idx=$rsrcidx");
	DBQueryWarn("delete from experiment_stats where exptidx=$exptidx");
	tberror("Error unlocking tables!");
	return undef
    }

    return Experiment->Lookup($pid, $eid);
}

#
# Delete experiment. Optional purge argument says to remove all trace
# (typically, the stats are kept).
#
sub Delete($;$)
{
    my ($self, $purge) = @_;

    return -1
	if (! ref($self));

    my $pid = $self->pid();
    my $eid = $self->eid();

    $purge = 0
	if (!defined($purge));

    TBExptDestroy($pid, $eid);

    return 0
	if (! $purge);
    
    #
    # Now we can clean up the stats records. 
    #
    my $exptidx = $self->idx();
    my $rsrcidx = $self->rsrcidx();
    
    DBQueryWarn("DELETE from experiment_resources ".
		"WHERE idx=$rsrcidx")
	if (defined($rsrcidx) && $rsrcidx);
	
    DBQueryWarn("DELETE from testbed_stats ".
		"WHERE exptidx=$exptidx");

    # This must be last cause it provides the unique exptidx above.
    DBQueryWarn("DELETE from experiment_stats ".
		"WHERE eid='$eid' and pid='$pid' and exptidx=$exptidx");

    return 0;
}

#
# Refresh a class instance by reloading from the DB.
#
sub Refresh($)
{
    my ($self) = @_;

    return -1
	if (! ref($self));

    my $pid = $self->pid();
    my $eid = $self->eid();
    
    my $query_result =
	DBQueryWarn("select * from experiments ".
		    "where pid='$pid' and eid='$eid'");

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

    $self->{'EXPT'}  = $query_result->fetchrow_hashref();

    my $idx = $self->{'EXPT'}->{'idx'};

    $query_result =
	DBQueryWarn("select * from experiment_stats where exptidx='$idx'");
	
    return -1
	if (!$query_result || !$query_result->numrows);
    
    $self->{'STATS'} = $query_result->fetchrow_hashref();

    # And this is lazy again.
    $self->{'RSRC'}  = undef;
    return 0;
}

#
# Perform some updates ...
#
sub Update($$)
{
    my ($self, $argref) = @_;

    # Must be a real reference. 
    return -1
	if (! ref($self));

    my $pid = $self->pid();
    my $eid = $self->eid();

    my $query = "update experiments set ".
	join(",", map("$_='" . $argref->{$_} . "'", keys(%{$argref})));

    $query .= " where pid='$pid' and eid='$eid'";

    return -1
	if (! DBQueryWarn($query));

    return Refresh($self);
}

#
# Stringify for output.
#
sub Stringify($)
{
    my ($self) = @_;
    
    my $pid   = $self->pid();
    my $eid   = $self->eid();

    return "[Experiment: $pid/$eid]";
}

#
# Check permissions
#
sub AccessCheck($$$)
{
    my ($self, $uid, $access_type) = @_;

    # Must be a real reference. 
    return -1
	if (! ref($self));

    my $pid = $self->pid();
    my $eid = $self->eid();

    return TBExptAccessCheck($uid, $pid, $eid, $access_type);
}

#
# Create the directory structure. A template_mode experiment is the one
# that is created for the template wrapper, not one created for an
# instance of the experiment. The path changes slightly, although that
# happens down in the mkexpdir script.
#
sub CreateDirectory($)
{
    my ($self) = @_;

    # Must be a real reference. 
    return -1
	if (! ref($self));

    my $pid = $self->pid();
    my $eid = $self->eid();
    my $gid = $self->gid();

    mysystem("$MKEXPDIR $pid $gid $eid");
    return -1
	if ($?);
    # mkexpdir sets the path in the DB. 
    return Refresh($self)
}

#
# Return the user and work directories. The workdir in on boss and where
# scripts chdir to when they run. The userdir is across NFS on ops, and
# where files are copied to. 
#
sub WorkDir($)
{
    my ($self) = @_;

    # Must be a real reference. 
    return -1
	if (! ref($self));

    my $pid = $self->pid();
    my $eid = $self->eid();

    return TBDB_EXPT_WORKDIR() . "/${pid}/${eid}";
}
sub UserDir($)
{
    my ($self) = @_;

    # Must be a real reference. 
    return -1
	if (! ref($self));

    return $self->path();
}

# Event/Web key filenames.
sub EventKeyPath($)
{
    my ($self) = @_;

    # Must be a real reference. 
    return -1
	if (! ref($self));

    return UserDir($self) . "/tbdata/eventkey"; 
}
sub WebKeyPath($)
{
    my ($self) = @_;

    # Must be a real reference. 
    return -1
	if (! ref($self));

    return UserDir($self) . "/tbdata/webkey"; 
}

#
# Add an environment variable.
#
sub AddEnvVariable($$$;$)
{
    my ($self, $name, $value, $index) = @_;

    # Must be a real reference. 
    return -1
	if (! ref($self));

    my $pid = $self->pid();
    my $eid = $self->eid();

    if (defined($value)) {
	$value = DBQuoteSpecial($value);
    }
    else {
	$value = "''";
    }

    #
    # Look to see if the variable exists, since a replace will actually
    # create a new row cause there is an auto_increment in the table that
    # is used to maintain order of the variables as specified in the NS file.
    #
    my $query_result =
	DBQueryWarn("select idx from virt_user_environment ".
		    "where name='$name' and pid='$pid' and eid='$eid'");

    return -1
	if (!$query_result);

    if ($query_result->numrows) {
	my $idx = (defined($index) ? $index :
		   ($query_result->fetchrow_array())[0]);
	    
	DBQueryWarn("replace into virt_user_environment set ".
		    "   name='$name', value=$value, idx=$idx, ".
		    "   pid='$pid', eid='$eid'")
	    or return -1;
    }
    else {
	DBQueryWarn("insert into virt_user_environment set ".
		    "   name='$name', value=$value, idx=NULL, ".
		    "   pid='$pid', eid='$eid'")
	    or return -1;
    }
    
    return 0;
}

#
# Write the environment strings into a little script in the user directory.
#
sub WriteEnvVariables($)
{
    my ($self) = @_;

    # Must be a real reference. 
    return -1
	if (! ref($self));

    my $pid = $self->pid();
    my $eid = $self->eid();

    my $query_result =
	DBQueryWarn("select name,value from virt_user_environment ".
		    "where  pid='$pid' and eid='$eid' order by idx");
    return -1
	if (!defined($query_result));

    my $userdir = $self->UserDir();
    my $envfile = "$userdir/tbdata/environment";

    if (!open(FP, "> $envfile")) {
	print "Could not open $envfile for writing: $!\n";
	return -1;
    }
    while (my ($name,$value) = $query_result->fetchrow_array()) {
	print FP "${name}=\"$value\"\n";
    }
    if (! close(FP)) {
	print "Could not close $envfile: $!\n";
	return -1;
    }
    
    return 0;
}

#
# Experiment locking and state changes.
#
sub Unlock($;$)
{
    my ($self, $newstate) = @_;

    # Must be a real reference. 
    return -1
	if (! ref($self));

    my $pid = $self->pid();
    my $eid = $self->eid();
    my $sclause = (defined($newstate) ? ",state='$newstate' " : "");

    my $query_result =
	DBQueryWarn("update experiments set expt_locked=NULL $sclause ".
		    "where eid='$eid' and pid='$pid'");

    if (! $query_result ||
	$query_result->numrows == 0) {
	return -1;
    }
    
    if (defined($newstate)) {
	$self->{'EXPT'}->{'state'} = $newstate;

	if ($EVENTSYS) {
	    EventSendWarn(objtype   => libdb::TBDB_TBEVENT_EXPTSTATE(),
			  objname   => "$pid/$eid",
			  eventtype => $newstate,
			  expt      => "$pid/$eid",
			  host      => $BOSSNODE);
	}
    }
    
    return 0;
}

sub Lock(;$)
{
    my ($self, $newstate) = @_;

    # Must be a real reference. 
    return -1
	if (! ref($self));

    my $pid = $self->pid();
    my $eid = $self->eid();
    my $sclause = (defined($newstate) ? ",state='$newstate' " : "");

    my $query_result =
	DBQueryWarn("update experiments set expt_locked=now() $sclause ".
		    "where eid='$eid' and pid='$pid'");

    if (! $query_result ||
	$query_result->numrows == 0) {
	return -1;
    }
    
    if (defined($newstate)) {
	$self->{'EXPT'}->{'state'} = $newstate;

	if ($EVENTSYS) {
	    EventSendWarn(objtype   => libdb::TBDB_TBEVENT_EXPTSTATE(),
			  objname   => "$pid/$eid",
			  eventtype => $newstate,
			  expt      => "$pid/$eid",
			  host      => $BOSSNODE);
	}
    }
    return 0;
}

sub SetState($$)
{
    my ($self, $newstate) = @_;

    # Must be a real reference. 
    return -1
	if (! ref($self));

    my $pid = $self->pid();
    my $eid = $self->eid();

    my $query_result =
	DBQueryWarn("update experiments set state='$newstate' ".
		    "where eid='$eid' and pid='$pid'");

    if (! $query_result ||
	$query_result->numrows == 0) {
	return -1;
    }
    
    if (defined($newstate)) {
	$self->{'EXPT'}->{'state'} = $newstate;

	if ($EVENTSYS) {
	    EventSendWarn(objtype   => libdb::TBDB_TBEVENT_EXPTSTATE(),
			  objname   => "$pid/$eid",
			  eventtype => $newstate,
			  expt      => "$pid/$eid",
			  host      => $BOSSNODE);
	}
    }
    
    return 0;
}

#
# Logfiles. This all needs to change.
#
# Open a new logfile and return its name.
#
sub CreateLogFile($$$)
{
    my ($self, $prefix, $pref) = @_;

    # Must be a real reference. 
    return -1
	if (! ref($self));

    my $pid = $self->pid();
    my $eid = $self->eid();

    # Need to deal with errors.
    $$pref = TBExptCreateLogFile($pid, $eid, $prefix);
    return 0;
}

#
# Set the experiment to use the logfile. It becomes the "current" spew.
#
sub SetLogFile($$)
{
    my ($self, $logname) = @_;

    # Must be a real reference. 
    return -1
	if (! ref($self));

    my $pid = $self->pid();
    my $eid = $self->eid();

    TBExptSetLogFile($pid, $eid, $logname);    
    return 0;
}

#
# Mark the log as open so that the spew keeps looking for more output.
# 
sub OpenLogFile($)
{
    my ($self) = @_;

    # Must be a real reference. 
    return -1
	if (! ref($self));

    my $pid = $self->pid();
    my $eid = $self->eid();

    TBExptOpenLogFile($pid, $eid);    
    return 0;
}

#
# And close it ...
#
sub CloseLogFile($)
{
    my ($self) = @_;

    # Must be a real reference. 
    return -1
	if (! ref($self));

    my $pid = $self->pid();
    my $eid = $self->eid();

    TBExptCloseLogFile($pid, $eid);    
    return 0;
}

#
# And clear it ...
#
sub ClearLogFile($)
{
    my ($self) = @_;

    # Must be a real reference. 
    return -1
	if (! ref($self));

    my $pid = $self->pid();
    my $eid = $self->eid();

    TBExptClearLogFile($pid, $eid);    
    return 0;
}

#
# Run scripts over an experiment.
#
sub PreRun($;$$)
{
    my ($self, $nsfile, $options) = @_;

    # Must be a real reference. 
    return -1
	if (! ref($self));

    my $pid = $self->pid();
    my $eid = $self->eid();

    $nsfile = ""
	if (!defined($nsfile));
    $options = ""
	if (!defined($options));

    print "Running 'tbprerun $options $pid $eid $nsfile'\n";
    mysystem("$TBPRERUN $options $pid $eid $nsfile");
    return -1
	if ($?);
    return 0;
}

sub Swap($;$$)
{
    my ($self, $direction, $options) = @_;

    # Must be a real reference. 
    return -1
	if (! ref($self));

    my $pid = $self->pid();
    my $eid = $self->eid();

    $options = ""
	if (!defined($options));

    print "Running 'tbswap $direction $options $pid $eid'\n";
    mysystem("$TBSWAP $direction $options $pid $eid");
    return -1
	if ($?);
    return 0;
}

sub End($;$)
{
    my ($self, $options) = @_;

    # Must be a real reference. 
    return -1
	if (! ref($self));

    my $pid = $self->pid();
    my $eid = $self->eid();

    $options = ""
	if (!defined($options));

    print "Running 'tbend $options $pid $eid'\n";
    mysystem("$TBEND $options $pid $eid");
    return -1
	if ($?);
    return 0;
}

sub Report($;$$)
{
    my ($self, $filename, $options) = @_;

    # Must be a real reference. 
    return -1
	if (! ref($self));

    my $pid = $self->pid();
    my $eid = $self->eid();

    $options = ""
	if (!defined($options));

    mysystem("$TBREPORT $options $pid $eid 2>&1 > $filename");
    return -1
	if ($?);
    return 0;
}

#
# Return list of local nodes.
# 
sub LocalNodeList($$)
{
    my ($self, $lref) = @_;

    # Must be a real reference. 
    return -1
	if (! ref($self));

    my $pid = $self->pid();
    my $eid = $self->eid();

    @$lref = ExpNodes($pid, $eid, 1, 0);
    return 0;
}

#
# Copy log files to long term storage.
#
sub SaveLogFiles($)
{
    my ($self) = @_;

    # Must be a real reference. 
    return -1
	if (! ref($self));

    my $pid = $self->pid();
    my $eid = $self->eid();
    my $workdir = $self->WorkDir();
    my $logdir  = TBExptLogDir($pid, $eid);

    # What the hell is this file! Very annoying.
    if (-e "$workdir/.rnd") {
	mysystem("/bin/rm -f $workdir/.rnd");
    }
    mysystem("/bin/cp -Rpf $workdir/ $logdir");
    return 0;
}

#
# Remove old logfiles from the wordir.
#
sub CleanLogFiles($)
{
    my ($self) = @_;

    # Must be a real reference. 
    return -1
	if (! ref($self));

    my $workdir = $self->WorkDir();
    
    opendir(DIR, $workdir) or
	return -1;
    my @files   = readdir(DIR);
    my @delete  = ();
    closedir(DIR);

    foreach my $file (@files) {
	# Just in case ...
	next
	    if ($file =~ /^.*\.ns$/);
	
	push(@delete, "${workdir}/$1")
	    if ($file =~ /^(.*\.(log|ptop|top|assign))$/);

	push(@delete, "${workdir}/$1")
	    if ($file =~ /^((swap|start|cancel|newrun).*\..*)$/);
    }
    mysystem("/bin/rm -f @delete") == 0
	or return -1;

    return 0;
}

#
# Copy log files to user visible space. Maybe not such a good idea anymore?
#
sub CopyLogFiles($;@)
{
    my ($self, @files) = @_;

    # Must be a real reference. 
    return -1
	if (! ref($self));

    my $pid = $self->pid();
    my $eid = $self->eid();
    my $workdir = $self->WorkDir();
    my $userdir = $self->UserDir();

    # Specific files, then return.
    if (@files) {
	mysystem("/bin/cp -fp @files $userdir/tbdata");
	return 0;
    }

    opendir(DIR, $workdir) or
	return -1;
    @files  = readdir(DIR);
    closedir(DIR);
    my @copy   = ();

    foreach my $file (@files) {
	push(@copy, "${workdir}/$1")
	    if ($file =~ /^(.*\.(log|report|ns|png))$/);
    }

    mysystem("/bin/cp -fp @copy $userdir/tbdata");
    return 0;
}

#
# Backup the user directory for debugging. 
#
sub BackupUserData($)
{
    my ($self) = @_;
    
    # Must be a real reference. 
    return -1
	if (! ref($self));

    my $userdir = $self->UserDir();
    my $path    = dirname($userdir);
    my $dir     = basename($userdir);
    my $backup  = "${path}/.${dir}-failed";

    if (-e $backup) {
	mysystem("/bin/rm -rf $backup");
    }
    mysystem("/bin/mv $userdir $backup");
    return 0;
}

#
# Swapinfo accounting stuff.
#
sub SetSwapInfo($$)
{
    my ($self, $user) = @_;

    # Must be a real reference. 
    return -1
	if (! ref($self));

    my $pid = $self->pid();
    my $eid = $self->eid();
    
    TBSetExpSwapTime($pid, $eid);
    $self->SetSwapper($user);
    return $self->Refresh();
}

#
# Just the swap uid.
#
sub SetSwapper($$)
{
    my ($self, $user) = @_;

    # Must be a real reference. 
    return -1
	if (! ref($self));

    my $pid  = $self->pid();
    my $eid  = $self->eid();
    my $uid  = $user->uid();
    my $dbid = $user->dbid();

    DBQueryWarn("update experiments set ".
		"   expt_swap_uid='$uid', swapper_idx='$dbid' ".
		"where pid='$pid' and eid='$eid'");

    return $self->Refresh();
}

#
# Just the swap time.
#
sub SetSwapTime($)
{
    my ($self) = @_;

    # Must be a real reference. 
    return -1
	if (! ref($self));

    my $pid = $self->pid();
    my $eid = $self->eid();
    
    TBSetExpSwapTime($pid, $eid);
    return 0;
}

#
# Set the cancel flag.
#
sub SetCancelFlag($$)
{
    my ($self, $flag) = @_;

    # Must be a real reference. 
    return -1
	if (! ref($self));

    my $pid = $self->pid();
    my $eid = $self->eid();
    
    TBSetCancelFlag($pid, $eid, $flag);
    return $self->Refresh();
}

#
# Clear the panic bit.
#
sub ClearPanicBit($)
{
    my ($self) = @_;

    # Must be a real reference. 
    return -1
	if (! ref($self));

    my $pid = $self->pid();
    my $eid = $self->eid();
    
    TBExptClearPanicBit($pid, $eid);
    return 0;
}

#
# Is experiment firewalled?
#
sub IsFirewalled($)
{
    my ($self) = @_;

    # Must be a real reference. 
    return -1
	if (! ref($self));

    my $pid = $self->pid();
    my $eid = $self->eid();

    return TBExptFirewall($pid, $eid);
}

#
# Update the idleswap timeout. Why?
#
sub UpdateIdleSwapTime($$)
{
    my ($self, $newtimeout) = @_;

    # Must be a real reference. 
    return -1
	if (! ref($self));

    my $pid = $self->pid();
    my $eid = $self->eid();

    DBQueryWarn("update experiments set idleswap_timeout='$newtimeout' ".
		"where eid='$eid' and pid='$pid'")
	or return -1;

    return 0;
}

#
# Experiment tables.
#
sub BackupVirtualState($)
{
    my ($self) = @_;

    # Must be a real reference. 
    return -1
	if (! ref($self));

    my $pid = $self->pid();
    my $eid = $self->eid();

    return -1
	if (TBExptBackupVirtualState($pid, $eid));

    return 0;
}
sub RemoveVirtualState($)
{
    my ($self) = @_;

    # Must be a real reference. 
    return -1
	if (! ref($self));

    my $pid = $self->pid();
    my $eid = $self->eid();

    return -1
	if (TBExptRemoveVirtualState($pid, $eid));

    return 0;
}
sub RestoreVirtualState($)
{
    my ($self) = @_;

    # Must be a real reference. 
    return -1
	if (! ref($self));

    my $pid = $self->pid();
    my $eid = $self->eid();

    return -1
	if (TBExptRestoreVirtualState($pid, $eid));

    return 0;
}
sub ClearBackupState($)
{
    my ($self) = @_;

    # Must be a real reference. 
    return -1
	if (! ref($self));

    my $pid = $self->pid();
    my $eid = $self->eid();

    TBExptClearBackupState($pid, $eid);
    return 0;
}
sub RemovePhysicalState($)
{
    my ($self) = @_;

    # Must be a real reference. 
    return -1
	if (! ref($self));

    my $pid = $self->pid();
    my $eid = $self->eid();

    return -1
	if (TBExptRemovePhysicalState($pid, $eid));

    return 0;
}

#
# The port registration table is special, and needs to be cleared only
# at certain times. See tbswap.
#
sub ClearPortRegistration($)
{
    my ($self) = @_;

    # Must be a real reference. 
    return -1
	if (! ref($self));

    my $pid = $self->pid();
    my $eid = $self->eid();

    return -1
	if (! DBQueryWarn("delete from port_registration ".
			  "where pid='$pid' and eid='$eid'"));

    return 0;
}

#
# Setup up phony program agent event agents and groups. This is so we
# can talk to the program agent itself, not to the programs the agent
# is responsible for. 
#
sub SetupProgramAgents($)
{
    my ($self) = @_;

    # Must be a real reference. 
    return -1
	if (! ref($self));

    my $pid = $self->pid();
    my $eid = $self->eid();

    my $query_result =
	DBQueryWarn("select distinct vnode from virt_programs ".
		    "where pid='$pid' and eid='$eid'");
    
    return -1
	if (!defined($query_result));
    return 0
	if (! $query_result->numrows);

    while (my ($vnode) = $query_result->fetchrow_array()) {
	DBQueryWarn("replace into virt_agents ".
		     " (pid, eid, vname, vnode, objecttype) ".
		     " select '$pid', '$eid', '__${vnode}_program-agent', ".
		     "   '$vnode', ".
		     "   idx from event_objecttypes where ".
		     "   event_objecttypes.type='PROGRAM'")
	    or return -1;

	DBQueryWarn("replace into event_groups ".
		    " (pid, eid, idx, group_name, agent_name) ".
		    " values ('$pid', '$eid', NULL, ".
		    "         '__all_program-agents', ".
		    "         '__${vnode}_program-agent')")
	    or return -1;
    }
    return 0;
}

#
# Write the virt program data for the program agent that will run on ops.
# Ops does not speak to tmcd for experiments, so need to get this info
# over another way. 
#
sub WriteProgramAgents($)
{
    my ($self) = @_;

    # Must be a real reference. 
    return -1
	if (! ref($self));

    my $pid = $self->pid();
    my $eid = $self->eid();

    my $query_result =
	DBQueryWarn("select vname,command,dir,timeout,expected_exit_code ".
		    "   from virt_programs ".
		    "where vnode='ops' and pid='$pid' and eid='$eid'");

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

    my $userdir  = $self->UserDir();
    my $progfile = "$userdir/tbdata/program_agents";

    if (!open(FP, "> $progfile")) {
	print "Could not open $progfile for writing: $!\n";
	return -1;
    }
    while (my ($name,$command,$dir,$timeout,$expected_exit_code) =
	   $query_result->fetchrow_array()) {
	print FP "AGENT=$name";
	print FP " DIR=$dir"
	    if (defined($dir) && $dir ne "");
	print FP " TIMEOUT=$timeout"
	    if (defined($timeout) && $timeout ne "");
	print FP " EXPECTED_EXIT_CODE=$expected_exit_code"
	    if (defined($expected_exit_code) && $expected_exit_code ne "");
	print FP " COMMAND='$command'\n";
    }
    if (! close(FP)) {
	print "Could not close $progfile: $!\n";
	return -1;
    }
    
    return 0;
}

#
# Return node status list for all nodes in the experiment. Status is defined
# as either up or down, which for now is going to be returned as 0,1.
#
sub NodeStatusList($$)
{
    my ($self, $prval) = @_;

    # Must be a real reference. 
    return -1
	if (! ref($self));

    my %results = ();
    my $pid = $self->pid();
    my $eid = $self->eid();

    my $query_result =
	DBQueryWarn("select r.node_id,n.status from reserved as r ".
		    "left join node_status as n on n.node_id=r.node_id ".
		    "where pid='$pid' and eid='$eid'");

    return -1
	if (!defined($query_result));
    
    while (my ($node_id,$status) = $query_result->fetchrow_array()) {
	# Skip nodes with no status info reported. 
	next
	    if (!defined($status) || $status eq "");
	
	$results{$node_id} = (($status eq "up") ? 1 : 0);
    }
    %$prval = %results;
    return 0;
}

#
# Setup the environment variables for a swapin.
#
sub InitializeEnvVariables($)
{
    my ($self) = @_;

    # Must be a real reference. 
    return -1
	if (! ref($self));

    $self->Refresh() == 0
	or return -1;

    if ($self->dpdb() && $self->dpdbname() && $self->dpdbname() ne "") {
	my $dpdbname     = $self->dpdbname();
	my $dpdbpassword = $self->dpdbpassword();
	my $dpdbuser     = "E" . $self->idx();

	$self->AddEnvVariable("DP_DBNAME", $dpdbname) == 0
	    or return -1;
	
	$self->AddEnvVariable("DP_HOST", $CONTROL) == 0
	    or return -1;

	$self->AddEnvVariable("DP_USER", $dpdbuser) == 0
	    or return -1;

	$self->AddEnvVariable("DP_PASSWORD", $dpdbpassword) == 0
	    or return -1;
    }
    
    return 0;
}

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