Ongoing cleanup of the code and conversion to perl objects. Its a

thankless job but someone has to do it. I'm expecting to finish by the
time Bush 43 leaves office.

bugdb/addbugdbproj.in

 #!/usr/bin/perl -wT
 #
 # EMULAB-COPYRIGHT
-# Copyright (c) 2005, 2006 University of Utah and the Flux Group.
+# Copyright (c) 2005, 2006, 2007 University of Utah and the Flux Group.
 # All rights reserved.
 #
+use strict;
 use English;
 use Getopt::Std;
 
@@ -49,6 +50,7 @@ sub fatal($);
 use lib "@prefix@/lib";
 use libdb;
 use libtestbed;
+use Project;
 
 #
 # We don't want to run this script unless its the real version.
@@ -79,7 +81,7 @@ if (! $BUGDBSUPPORT) {
 # Parse command arguments. Once we return from getopts, all that should be
 # left are the required arguments.
 #
-%options = ();
+my %options = ();
 if (! getopts($optlist, \%options)) {
     usage();
 }
@@ -89,22 +91,11 @@ if (defined($options{"d"})) {
 if (@ARGV != 1) {
     usage();
 }
-my $pid = $ARGV[0];
-
-#
-# Untaint args.
-#
-if ($pid =~ /^([-\w]+)$/) {
-    $pid = $1;
-}
-else {
-    die("Bad data in pid: $pid");
-}
-
-# Valid project?
-if (! ProjLeader($pid)) {
-    fatal("No such project $pid!");
+my $project = Project->Lookup($ARGV[0]);
+if (!defined($project)) {
+    fatal("No such project $ARGV[0]!");
 }
+my $pid = $project->pid();
 
 #
 # This script always does the right thing, so no permission checks.

collab/jabber/modjabberbuddies.in

 #!/usr/bin/perl -wT
 #
 # EMULAB-COPYRIGHT
-# Copyright (c) 2005 University of Utah and the Flux Group.
+# Copyright (c) 2005-2007 University of Utah and the Flux Group.
 # All rights reserved.
 #
 use English;
@@ -141,14 +141,6 @@ else {
     die("Bad user name: $user.");
 }
 
-#
-# Get user DB uid.
-#
-#if (! UNIX2DBUID($UID, \$dbuid)) {
-#    die("*** $0:\n".
-#        "    You do not exist in the Emulab Database!\n");
-#}
-
 #
 # Permission checks. Do this later.
 #

collab/mailman/addmmlist.in

 #!/usr/bin/perl -wT
 #
 # EMULAB-COPYRIGHT
-# Copyright (c) 2005, 2006 University of Utah and the Flux Group.
+# Copyright (c) 2005, 2006, 2007 University of Utah and the Flux Group.
 # All rights reserved.
 #
 use English;
@@ -22,7 +22,6 @@ sub usage()
 my $optlist   = "daur";
 my $debug     = 0;
 my $reconfig  = 0;
-my $dbuid;
 my $listtype;
 my $listname;
 my $listowner;
@@ -62,6 +61,7 @@ $| = 1;
 use lib "@prefix@/lib";
 use libdb;
 use libtestbed;
+use User;
 
 #
 # We don't want to run this script unless its the real version.
@@ -89,12 +89,13 @@ if (! $MAILMANSUPPORT) {
 }
 
 #
-# Get user DB uid.
+# Verify user and get his DB uid and other info for later.
 #
-if (! UNIX2DBUID($UID, \$dbuid)) {
-    die("*** $0:\n".
-        "    You do not exist in the Emulab Database!\n");
+my $this_user = User->ThisUser();
+if (! defined($this_user)) {
+    tbdie("You ($UID) do not exist!");
 }
+my $user_uid   = $this_user->uid();
 
 #
 # Parse command arguments. Once we return from getopts, all that should be
@@ -203,7 +204,7 @@ if ($CONTROL ne $BOSSNODE) {
     }
     if (! $reconfig) {
 	SENDMAIL($TBAUDIT, "Mailman list created",
-		 "Mailman list '$listname' has been created by '$dbuid'",
+		 "Mailman list '$listname' has been created by '$user_uid'",
 		 $TBOPS);
     }
 }

collab/mailman/delmmlist.in

 #!/usr/bin/perl -wT
 #
 # EMULAB-COPYRIGHT
-# Copyright (c) 2005 University of Utah and the Flux Group.
+# Copyright (c) 2005-2007 University of Utah and the Flux Group.
 # All rights reserved.
 #
 use English;
@@ -17,7 +17,6 @@ sub usage()
 }
 my $optlist = "dau";
 my $debug   = 0;
-my $dbuid;
 my $listtype;
 my $listname;
 my $listowner;
@@ -57,6 +56,7 @@ $| = 1;
 use lib "@prefix@/lib";
 use libdb;
 use libtestbed;
+use User;
 
 #
 # We don't want to run this script unless its the real version.
@@ -84,12 +84,13 @@ if (! $MAILMANSUPPORT) {
 }
 
 #
-# Get user DB uid.
+# Verify user and get his DB uid and other info for later.
 #
-if (! UNIX2DBUID($UID, \$dbuid)) {
-    die("*** $0:\n".
-        "    You do not exist in the Emulab Database!\n");
+my $this_user = User->ThisUser();
+if (! defined($this_user)) {
+    tbdie("You ($UID) do not exist!");
 }
+my $user_uid   = $this_user->uid();
 
 #
 # Parse command arguments. Once we return from getopts, all that should be
@@ -142,7 +143,7 @@ if ($CONTROL ne $BOSSNODE) {
     }
     
     SENDMAIL($TBAUDIT, "Mailman list deleted",
-	     "Mailman list '$listname' has been deleted by '$dbuid'",
+	     "Mailman list '$listname' has been deleted by '$user_uid'",
 	     $TBOPS);
 }
 exit(0);

collab/mailman/setmmpasswd.in

 #!/usr/bin/perl -wT
 #
 # EMULAB-COPYRIGHT
-# Copyright (c) 2005 University of Utah and the Flux Group.
+# Copyright (c) 2005, 2007 University of Utah and the Flux Group.
 # All rights reserved.
 #
 use English;
@@ -19,7 +19,6 @@ sub usage()
 }
 my $optlist = "dau";
 my $debug   = 0;
-my $dbuid;
 my $listtype;
 my $listname;
 my $listowner;
@@ -59,6 +58,7 @@ $| = 1;
 use lib "@prefix@/lib";
 use libdb;
 use libtestbed;
+use User;
 
 #
 # We don't want to run this script unless its the real version.
@@ -86,12 +86,13 @@ if (! $MAILMANSUPPORT) {
 }
 
 #
-# Get user DB uid.
+# Verify user and get his DB uid and other info for later.
 #
-if (! UNIX2DBUID($UID, \$dbuid)) {
-    die("*** $0:\n".
-        "    You do not exist in the Emulab Database!\n");
+my $this_user = User->ThisUser();
+if (! defined($this_user)) {
+    tbdie("You ($UID) do not exist!");
 }
+my $user_uid   = $this_user->uid();
 
 #
 # Parse command arguments. Once we return from getopts, all that should be
@@ -187,7 +188,7 @@ if ($CONTROL ne $BOSSNODE) {
 
     SENDMAIL($TBAUDIT, "Mailman list password changed",
 	     "The mailman list password for list '$listname' has been ".
-	     "changed by '$dbuid'",
+	     "changed by '$user_uid'",
 	     $TBOPS);
 }
 exit(0);

db/Experiment.pm.in

@@ -34,6 +34,8 @@ use vars qw($EXPT_PRELOAD $EXPT_START $EXPT_SWAPIN
 my $TB		= "@prefix@";
 my $BOSSNODE    = "@BOSSNODE@";
 my $CONTROL	= "@USERNODE@";
+my $TBOPS       = "@TBOPSEMAIL@";
+my $PROJROOT    = "@PROJROOT_DIR@";
 my $EVENTSYS    = @EVENTSYS@;
 my $STAMPS      = @STAMPS@;
 my $TEVC	= "$TB/bin/tevc";
@@ -218,6 +220,8 @@ sub swapper_idx($)      { return field($_[0], 'swapper_idx');}
 sub use_ipassign($)     { return field($_[0], 'use_ipassign');}
 sub ipassign_args($)    { return field($_[0], 'ipassign_args');}
 sub security_level($)   { return field($_[0], 'security_level');}
+sub linktest_pid($)     { return field($_[0], 'linktest_pid');}
+sub linktest_level($)   { return field($_[0], 'linktest_level');}
 sub archive_idx($)	{ return stats($_[0], 'archive_idx'); }
 sub swapin_count($)	{ return stats($_[0], 'swapin_count'); }
 sub destroyed($)	{ return stats($_[0], 'destroyed'); }
@@ -260,6 +264,35 @@ sub AllActive($)
     return @result;
 }
 
+#
+# All experiments for a particular user. Class method.
+#
+sub UserExperimentList($$$)
+{
+    my ($class, $user, $plist) = @_;
+    my @result  = ();
+    my $uid_idx = $user->uid_idx();
+    
+    my $query_result =
+	DBQueryWarn("select idx from experiments ".
+		    "where creator_idx='$uid_idx' or swapper_idx='$uid_idx'");
+    return -1
+	if (! $query_result);
+
+    while (my ($idx) = $query_result->fetchrow_array()) {
+	my $experiment = Experiment->Lookup($idx);
+
+	if (!defined($experiment)) {
+	    print STDERR "Experiment::UserExperimentList: ".
+		"No object for $idx!\n";
+	    return -1;
+	}
+	push(@result, $experiment);
+    }
+    @$plist = @result;
+    return 0;
+}
+
 # This is needed a lot.
 sub unix_gid($)
 {
@@ -527,11 +560,44 @@ sub Delete($;$)
     my $pid     = $self->pid();
     my $eid     = $self->eid();
     my $exptidx = $self->idx();
+    my $workdir = $self->WorkDir();
+    my $userdir = $self->UserDir();
 
     $purge = 0
 	if (!defined($purge));
 
-    TBExptDestroy($pid, $eid);
+    #
+    # Try to remove experiment directory. We allow for it not being there
+    # cause we often run the tb programs directly. We also allow for not
+    # having permission, in the case that an admin type is running this,
+    # in which case it won't be allowed cause of directory permissions. Thats
+    # okay since admin types should rarely end experiments in other projects.
+    #
+    print "Removing experiment directories ... \n";
+    if (defined($userdir) && system("/bin/rm -rf $userdir")) {
+	print "*** WARNING: Not able to remove $userdir\n";
+	print "             Someone will need to do this by hand.\n";
+	# NFS errors usually the result. Sometimes its cause there is
+	# someone in the directory, so its being held open.
+        libtestbed::SENDMAIL($TBOPS,
+			     "Experiment::Delete: Could not remove directory",
+			     "Could not remove $userdir.\n".
+			     "Someone will need to do this by hand.\n");
+    }
+    if (system("/bin/rm -rf $workdir")) {
+	print "*** WARNING: Not able to remove $workdir\n";
+	print "             Someone will need to do this by hand.\n";
+    }
+    # Yuck.
+    if ($pid ne $self->gid()) {
+	my $eidlink = "$PROJROOT/$pid/exp/$eid";
+	unlink($eidlink)
+	    if (-l $eidlink);
+    }
+    libArchive::TBDeleteExperimentArchive($pid, $eid);
+
+    DBQueryWarn("DELETE from experiments ".
+		"WHERE eid='$eid' and pid='$pid'");
 
     #
     # Mark experiment destroyed. This is a backup to End() below.
@@ -900,11 +966,42 @@ sub AccessCheck($$$)
     return -1
 	if (! ref($self));
 
-    my $uid = (ref($user) ? $user->uid() : $user);
-    my $pid = $self->pid();
-    my $eid = $self->eid();
+    if ($access_type < TB_EXPT_MIN ||
+	$access_type > TB_EXPT_MAX) {
+	die("*** Invalid access type: $access_type!");
+    }
+
+    # Admins do whatever they want.
+    return 1
+	if ($user->IsAdmin());
+
+    my $group = $self->GetGroup();
+    return 0
+	if (!defined($group));
+    my $project = $self->GetProject();
+    return 0
+	if (!defined($project));
+
+    #
+    # An experiment may be destroyed by the experiment creator or the
+    # project/group leader.
+    #
+    my $mintrust;
+    
+    if ($access_type == TB_EXPT_READINFO) {
+	$mintrust = PROJMEMBERTRUST_USER;
+    }
+    else {
+	$mintrust = PROJMEMBERTRUST_LOCALROOT;
+    }
 
-    return TBExptAccessCheck($uid, $pid, $eid, $access_type);
+    #
+    # Either proper permission in the group, or group_root in the project.
+    # This lets group_roots muck with other people's experiments, including
+    # those in groups they do not belong to.
+    #
+    return TBMinTrust($group->Trust($user), $mintrust) ||
+	TBMinTrust($project->Trust($user), PROJMEMBERTRUST_GROUPROOT);
 }
 
 #
@@ -938,7 +1035,7 @@ sub GetProject($)
     my ($self) = @_;
 
     # Must be a real reference. 
-    return -1
+    return undef
 	if (! ref($self));
 
     my $project = Project->Lookup($self->pid_idx());
@@ -958,7 +1055,7 @@ sub GetGroup($)
     my ($self) = @_;
 
     # Must be a real reference. 
-    return -1
+    return undef
 	if (! ref($self));
 
     my $group = Group->Lookup($self->gid_idx());
@@ -1292,6 +1389,27 @@ sub SetLogFile($$)
     return 0;
 }
 
+#
+# Get the experiment logfile.
+#
+sub GetLogFile($$$)
+{
+    my ($self, $lognamep, $isopenp) = @_;
+
+    # Must be a real reference. 
+    return -1
+	if (! ref($self));
+
+    my $pid = $self->pid();
+    my $eid = $self->eid();
+
+    $$lognamep = undef;
+
+    TBExptGetLogFile($pid, $eid, $lognamep, $isopenp)
+	or return -1;
+    return 0;
+}
+
 #
 # Mark the log as open so that the spew keeps looking for more output.
 # 
@@ -1602,6 +1720,9 @@ sub PostSwap($$$$)
     return -1
 	if (! ref($self));
 
+    $flags = 0
+	if (!defined($flags));
+
     my $exptidx  = $self->idx();
     my $rsrcidx  = $self->rsrcidx();
     my $lastrsrc = $self->lastrsrc();
@@ -1622,11 +1743,11 @@ sub PostSwap($$$$)
     my $duration     = 0;
     my $prev_uid_idx = 0;
     my $prev_swapper = $swapper;
+    my $query_result;
 
     if ($which eq $EXPT_SWAPOUT ||
 	($which eq $EXPT_SWAPMOD &&
 	 $self->state() eq libdb::EXPTSTATE_ACTIVE())) {
-	my $query_result;
 	
 	#
 	# If this is a swapout, we use the current resource record. If this
@@ -1704,7 +1825,7 @@ sub PostSwap($$$$)
 	$which eq $EXPT_SWAPIN ||
 	($which eq $EXPT_SWAPMOD &&
 	 $self->state() eq libdb::EXPTSTATE_ACTIVE())) {
-	my $query_result =
+	$query_result =
 	    DBQueryWarn("select r.node_id,n.type,r.erole, ".
 			"     r.vname,n.phys_nodeid ".
 			"  from reserved as r ".
@@ -2124,7 +2245,7 @@ sub SetSwapInfo($$)
     my $pid = $self->pid();
     my $eid = $self->eid();
     
-    TBSetExpSwapTime($pid, $eid);
+    $self->SetSwapTime();
     $self->SetSwapper($user);
     return $self->Refresh();