libArchive.pm.in 33.5 KB
Newer Older
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20
#!/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;
21
use libtestbed;
22 23 24 25 26 27 28 29
use English;
use File::stat;
use File::Basename;
use POSIX qw(strftime);
use Time::HiRes qw(gettimeofday);

# Configure variables
my $TB		= "@prefix@";
Leigh B. Stoller's avatar
Leigh B. Stoller committed
30 31
my $MAINSITE    = @TBMAINSITE@;
my $ALLOWEDPID  = "testbed";
32 33 34 35 36 37 38 39 40 41
# 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";
42 43 44
my $SVN         = "/usr/local/bin/svn";
my $SVNADMIN    = "/usr/local/bin/svnadmin";
my $IMPORTER    = "$TB/sbin/svn_load_dirs.pl";
45
my $inittag     = 'root';
46
my $defaultview = 'head';
47
my $debug       = 1;
48
my $svnopt      = ($debug ? "" : "-q");
49 50 51 52 53 54 55 56 57 58 59 60 61 62 63

# 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.
# 
64
sub ArchiveCreate(;$$)
65
{
66
    my ($tag, $view) = @_;
67
    
68 69
    my $idx;
    my $dir;
70 71 72

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

76
    # Tags cannot must start with a letter.
77 78 79
    if ($tag =~ /^\d+/) {
	$tag = "T" . $tag;
    }
80 81 82 83 84

    #
    # Need to create the directory for it, once we have the index.
    # 
    my $query_result =
Leigh B. Stoller's avatar
Leigh B. Stoller committed
85
	DBQueryWarn("insert into archives set ".
86
		    "  idx=NULL, ".
87 88 89 90 91 92 93 94 95 96 97 98 99 100 101
		    "  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;

Leigh B. Stoller's avatar
Leigh B. Stoller committed
102
    DBQueryWarn("update archives set directory='$dir' where idx='$idx'")
103 104 105
	or goto bad;

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

114 115
    if (! mkdir("$repodir", 0777)) {
	print STDERR "ArchiveCreate: Could not mkdir $repodir: $!\n";
116 117
	goto bad;
    }
118 119
    if (! chmod(0777, "$repodir")) {
	print STDERR "ArchiveCreate: Could not chmod $repodir: $!\n";
120 121
	goto bad;
    }
122 123
    if (! mkdir("$checkouts", 0777)) {
	print STDERR "ArchiveCreate: Could not mkdir $checkouts: $!\n";
124 125
	goto bad;
    }
126 127
    if (! chmod(0777, "$checkouts")) {
	print STDERR "ArchiveCreate: Could not chmod $checkouts: $!\n";
128 129
	goto bad;
    }
130 131
    if (! mkdir("$checkins", 0777)) {
	print STDERR "ArchiveCreate: Could not mkdir $checkins: $!\n";
132 133
	goto bad;
    }
134 135 136 137 138 139 140 141 142 143
    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";
144 145
	goto bad;
    }
146 147
    # Initialize the repo.
    mysystem("$SVNADMIN create $repodir") == 0
148
	or goto bad;
149 150 151 152
    
    # 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; ".
Leigh B. Stoller's avatar
Leigh B. Stoller committed
153
	     "         mkdir $view/history; ".
154 155 156 157 158 159 160
	     "$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")
161
	== 0 or goto bad;
162
    
163 164
    # Now check it out. This creates the $checkouts/$view directory.
    mysystem("cd $checkouts; ".
165
	     "$SVN checkout $svnopt file://$repodir/$view")
166 167
	== 0 or goto bad;

168 169 170 171 172
    # 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;
    
173
    # Now enter an initial tag for the tree. Nothing actually gets tagged.
174
    DBQueryWarn("insert into archive_tags set idx=NULL, ".
175
		"  tag='$tag', archive_idx='$idx', ".
176 177 178 179 180 181 182
		"  date_created=UNIX_TIMESTAMP(now())") or goto bad;
    
    return $idx;

  bad:
#    mysystem("$RM -rf $dir")
#        if (defined($dir));
183 184 185
    DBQueryFatal("delete from archive_views ".
		 "where view='$view' and archive_idx='$idx'")
	if (defined($idx));
Leigh B. Stoller's avatar
Leigh B. Stoller committed
186
    DBQueryFatal("delete from archives where idx='$idx'")
187 188 189 190 191 192 193 194 195 196
	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. 
#
197
sub ArchiveAdd($$;$)
198
{
199 200 201 202
    my ($archive_idx, $pathname, $view) = @_;

    $view = $defaultview
	if (!defined($view));
203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257

    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;
    }
258
    my $repodir   = "$directory/repo";
259 260
    my $checkout  = "$directory/checkouts/$view";
    my $checkin   = "$directory/checkins/$view";
261 262 263 264 265
    
    #
    # See if the file is already in the archive. We currently deal with
    # just files; directories are gonna be a pain in the butt.
    #
266
    my $target_path = "$checkin/$pathname";
267 268 269 270 271 272

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

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

#
289 290 291 292 293
# 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.
294
#
295
sub ArchiveSavePoint($;$$)
296
{
297 298 299 300 301 302 303 304 305
    my ($archive_idx, $savetag, $view) = @_;
    my $cwd;

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

    return -1
	if (TBScriptLock("archive_${archive_idx}", 0, 120) !=
	    TBSCRIPTLOCK_OKAY());
306 307 308 309 310 311

    #
    # See if the archive exists and if it does, get the pathname to it.
    #
    my $directory;
    if (GetArchiveDirectory($archive_idx, \$directory) < 0) {
312
	print STDERR "ArchiveSavePoint: ".
313
	    "Archive '$archive_idx' does not exist in the DB!\n";
314
	goto bad;
315 316
    }
    if (! -d $directory || ! -w $directory) {
317
	print STDERR "ArchiveSavePoint: $directory cannot be written!\n";
318
	goto bad;
319
    }
320
    my $repodir   = "$directory/repo";
321 322
    my $checkout  = "$directory/checkouts/$view";
    my $checkin   = "$directory/checkins/$view";
323 324 325 326 327 328

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

335
    # Get the current tag for the archive.
336 337
    my ($archive_tag);
    if (GetArchiveCurrentTags($archive_idx, $view, \$archive_tag) < 0) {
338 339 340 341 342 343 344 345 346 347 348 349 350 351
	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";
    }

352
    # Tags must start with a letter.
353 354 355 356
    if ($savetag =~ /^\d+/) {
	$savetag = "T" . $savetag;
    }
    
357
    #
358
    # Use svn import command. This is nice cause it handles all the
359 360 361
    # subdirs and stuff in one shot, instead of trying to deal with
    # each file and directory individually.
    #
362 363 364 365
    if (! chdir("$checkin")) {
	print STDERR "ArchiveSavePoint: Cannot chdir to $checkin!\n";
	goto bad;
    }
366
    mysystem("$IMPORTER -no_user_input file://$repodir ".
Leigh B. Stoller's avatar
Leigh B. Stoller committed
367
	     "          $view/savepoint . ")
368 369 370 371 372 373 374 375 376 377
	== 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;
    
378 379 380 381

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

387
  okay:
388 389 390
    TBScriptUnlock();
    chdir($cwd)
	if (defined($cwd));
391 392 393
    return 0;

  bad:
394 395 396
    TBScriptUnlock();
    chdir($cwd)
	if (defined($cwd));
397 398 399 400 401 402 403
    return -1;
}

#
# Commit the current contents of the temporary store to the archive.
# Returns -1 if any error. Otherwise return 0.
#
404
sub ArchiveCommit($;$$$)
405
{
406
    my ($archive_idx, $newtag, $view, $altdir) = @_;
407
    my $noactivity = 0;
408 409 410 411 412 413 414 415
    my $cwd;

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

    return -1
	if (TBScriptLock("archive_${archive_idx}", 0, 120) !=
	    TBSCRIPTLOCK_OKAY());
416 417 418 419 420 421 422 423

    #
    # 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";
424
	goto bad;
425 426 427
    }
    if (! -d $directory || ! -w $directory) {
	print STDERR "ArchiveCommit: $directory cannot be written!\n";
428
	goto bad;
429
    }
430
    my $repodir   = "$directory/repo";
431 432
    my $checkout  = "$directory/checkouts/$view";
    my $checkin   = (defined($altdir) ? $altdir : "$directory/checkins/$view");
433 434 435 436 437 438 439 440 441

    # 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";
442
	goto bad;
443 444
    }

445 446 447
    if (! chdir("$checkin")) {
	print STDERR "ArchiveCommit: Cannot chdir to $checkin!\n";
	goto bad;
448 449 450
    }

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

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

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

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

475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492
    #
    # 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;
    }
    
493
    # Clean the temp dir for next phase.
494
    mysystem("/bin/rm -rf $checkin/*");
495
    if ($?) {
496
	print STDERR "ArchiveCommit: Could not clean $checkin!\n";
497
	goto bad;
498 499 500
    }

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

510
	#
511 512 513 514 515 516 517 518 519 520
	# 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;
521

522 523 524 525 526 527
	#
	# Now commit to the trunk!
	#
	mysystem("$SVN commit $svnopt ".
		 "     -m 'Commit merge of ${archive_tag} to trunk' trunk")
	    == 0 or goto bad;
528
    }
529

530 531 532 533 534 535
    # 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;
    
Leigh B. Stoller's avatar
Leigh B. Stoller committed
536 537 538 539 540 541 542 543
    # 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;
    
544 545 546 547 548 549
    # 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;
    
550
    DBQueryWarn("insert into archive_tags set idx=NULL, ".
551
		"  tag='$newtag', ".
552
		"  archive_idx='$archive_idx', ".
553 554
		"  date_created=UNIX_TIMESTAMP(now())")
	or goto bad;
555

556
    DBQueryWarn("update archive_views set ".
557
		"  current_tag='$newtag', ".
558
		"  previous_tag='$archive_tag' ".
559 560
		"where archive_idx='$archive_idx' and view='$view'")
	or goto bad;
561 562

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

569 570 571
    # And now into the checkout dir to checkout a current copy.
    if (! chdir("$checkout")) {
	print STDERR "ArchiveCommit: Cannot chdir to $checkout!\n";
572
	goto bad;
573
    }
574
    mysystem("$SVN $svnopt update trunk");
575
    if ($?) {
576
	print STDERR "ArchiveCommit: Could not update head revision!\n";
577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596
	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.
#
597
sub ArchiveFork($$;$$$)
598
{
599 600
    my ($archive_idx, $newview, $branchtag, $newtag, $view) = @_;
    my $sourcepoint;
601 602 603 604 605 606 607 608 609 610 611 612 613 614
    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) {
615
	print STDERR "ArchiveCommit: ".
616 617 618 619 620
	    "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";
621
	goto bad;
622
    }
623
    my $repodir     = "$directory/repo";
624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641
    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.
642
    my ($archive_tag, $previous_tag);
643
    if (GetArchiveCurrentTags($archive_idx, $view, \$archive_tag,
644
			      \$previous_tag) < 0) {
645 646 647 648 649
	print STDERR "ArchiveCommit: ".
	    "Archive '$archive_idx' does not have a current tag!\n";
	goto bad;
    }

650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665
    #
    # 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;
    }

666 667 668 669 670 671 672 673 674
    # 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;
    }
675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701

    # 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.
702
    mysystem("cd $checkouts; ".
703
	     "$SVN checkout $svnopt file://$repodir/$newview")
704 705
	== 0 or goto bad;

706 707 708 709 710
    # 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;
711
    
712 713 714 715
    # 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;
716

717
  okay:
718 719 720
    TBScriptUnlock();
    chdir($cwd)
	if (defined($cwd));
721
    return 0;
722 723

  bad:
724 725 726
    TBScriptUnlock();
    chdir($cwd)
	if (defined($cwd));
727
    return -1;
728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752
}

#
# 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;
    }
753
    my $repodir  = "$directory/repo";
754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769

    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.
    #
770
    mysystem("$TAR cf - -C $repodir . | tar xf - -C $target");
771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808
    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'") &&
809 810
	 DBQueryWarn("delete from archive_views ".
		     "where archive_idx='$archive_idx'") &&
Leigh B. Stoller's avatar
Leigh B. Stoller committed
811
	 DBQueryWarn("delete from archives ".
812 813 814 815 816 817 818 819 820 821 822 823 824 825
		     "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 =
Leigh B. Stoller's avatar
Leigh B. Stoller committed
826
	DBQueryWarn("select directory from archives where idx='$idx'");
827 828 829 830 831 832 833 834 835 836 837 838 839 840

    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.
#
841
sub GetArchiveCurrentTags($$$;$)
842
{
843
    my ($archive_idx, $view, $tagp, $prevp) = @_;
844 845
    
    my $query_result =
846
	DBQueryWarn("select v.current_tag,v.previous_tag ".
847 848 849 850 851 852
		    "    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'");
853 854 855

    return -1
	if (!$query_result);
856
    my ($tag,$previous) = $query_result->fetchrow_array();
857
    
858 859 860 861
    $$tagp = $tag
	if (defined($tagp));
    $$prevp = $previous
	if (defined($prevp));
862 863 864 865 866 867 868 869
    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.
#
870
sub TBExperimentArchiveInfo($$$$)
871
{
872
    my ($pid, $eid, $idxp, $viewp) = @_;
873 874

    my $query_result =
875
	DBQueryWarn("select s.archive_idx,e.idx from experiments as e ".
876 877 878 879 880 881
		    "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);

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

    return -1
885 886 887 888 889 890
	if (!defined($archive_idx));

    $$idxp = $archive_idx
	if (defined($idxp));
    $$viewp = "$exptidx"
	if (defined($viewp));
891
    
892
    return 0;
893 894 895 896 897 898 899 900 901 902 903 904 905
}

#
# 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) = @_;

Leigh B. Stoller's avatar
Leigh B. Stoller committed
906 907 908
    return 0
	if (!$MAINSITE || $pid ne $ALLOWEDPID);

909 910 911 912 913 914 915 916 917 918
    # 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();
919 920 921 922 923
    my $archive_tag = "T${rsrcidx}";

    #
    # Create the new archive and get back the new index. 
    #
924
    my $archive_idx = ArchiveCreate($archive_tag, "$exptidx");
925 926
    return -1
	if ($archive_idx < 0);
927 928 929 930 931 932

    if (! (DBQueryWarn("update experiment_stats set ".
		       "      archive_idx='$archive_idx' ".
		       "where pid='$pid' and eid='$eid' and ".
		       "      exptidx='$exptidx'") &&
	   DBQueryWarn("update experiment_resources set ".
933
		       "      archive_tag='$archive_tag' ".
934 935 936 937 938 939 940 941 942 943 944 945 946
		       "where idx='$rsrcidx'"))) {
	ArchiveDestroy($archive_idx, 1);
	return -1;
    }
    return 0;
}

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

Leigh B. Stoller's avatar
Leigh B. Stoller committed
949 950 951
    return 0
	if (!$MAINSITE || $pid ne $ALLOWEDPID);

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

955
    return ArchiveAdd($archive_idx, $pathname, $view);
956 957 958
}

#
959
# SavePoint an experiment archive. 
960
#
961 962 963
sub TBExperimentArchiveSavePoint($$$)
{
    my ($pid, $eid, $tagext) = @_;
964
    my ($archive_idx, $view);
965

Leigh B. Stoller's avatar
Leigh B. Stoller committed
966 967 968
    return 0
	if (!$MAINSITE || $pid ne $ALLOWEDPID);

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

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

980
    return ArchiveSavePoint($archive_idx, $newtag, $view);
981 982 983 984 985 986 987 988
}

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

Leigh B. Stoller's avatar
Leigh B. Stoller committed
991 992 993
    return 0
	if (!$MAINSITE || $pid ne $ALLOWEDPID);

994
    return -1
995
	if (TBExperimentArchiveInfo($pid, $eid, \$archive_idx, \$view) < 0);
996 997 998 999 1000 1001 1002 1003 1004 1005 1006

    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;
    }
1007 1008
    my $checkin    = "$directory/checkins/$view";
    my $preswapdir = "${checkin}.preswap";
1009 1010

    #
1011
    # Derive a tag that says something useful?
1012 1013 1014 1015 1016 1017 1018 1019 1020 1021
    #
    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
1022
	if (ArchiveSavePoint($archive_idx, $newtag, $view) != 0);
1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045

    #
    # 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;
    }
    
1046
    mysystem("$TAR cf - -C $checkin . | tar xf - -C $preswapdir");
1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070
    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) = @_;
1071
    my ($archive_idx, $view);
1072

Leigh B. Stoller's avatar
Leigh B. Stoller committed
1073 1074 1075
    return 0
	if (!$MAINSITE || $pid ne $ALLOWEDPID);

1076
    return -1
1077
	if (TBExperimentArchiveInfo($pid, $eid, \$archive_idx, \$view) < 0);
1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088

    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;
    }
1089 1090
    my $checkin    = "$directory/checkins/$view";
    my $preswapdir = "${checkin}.preswap";
1091 1092 1093 1094 1095 1096 1097 1098

    # 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.
    #
1099 1100 1101
    if (-e $checkin) {
	system("/bin/rm -rf $checkin");
	if (-e $checkin) {
1102 1103 1104 1105 1106
	    print STDERR
		"ArchiveRollBack: Could not delete old preswap dir!\n";
	    return -1;
	}
    }
1107
    system("/bin/mv -f $preswapdir $checkin");
1108 1109
    if ($?) {
	print STDERR "ArchiveRollBack: ".
1110
	    "Could not mv $preswapdir to $checkin\n";
1111 1112 1113 1114 1115 1116 1117 1118 1119 1120
	return -1;
    }
    return 0;
}

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

Leigh B. Stoller's avatar
Leigh B. Stoller committed
1125 1126 1127
    return 0
	if (!$MAINSITE || $pid ne $ALLOWEDPID);

1128
    return -1
1129
	if (TBExperimentArchiveInfo($pid, $eid, \$archive_idx, \$view) < 0);
1130 1131 1132

    my $directory;
    if (GetArchiveDirectory($archive_idx, \$directory) < 0) {
Leigh B. Stoller's avatar
Leigh B. Stoller committed
1133
	print STDERR "ArchiveSwapModCommit: ".
1134 1135 1136 1137
	    "Archive '$archive_idx' does not exist in the DB!\n";
	return -1;
    }
    if (! -d $directory || ! -w $directory) {
Leigh B. Stoller's avatar
Leigh B. Stoller committed
1138
	print STDERR "ArchiveSwapModCommit: $directory cannot be written!\n";
1139 1140
	return -1;
    }
1141 1142
    my $checkin    = "$directory/checkins/$view";
    my $preswapdir = "${checkin}.preswap";
1143 1144

    #
1145
    # We need this below.
1146 1147 1148 1149 1150 1151 1152 1153 1154 1155
    #
    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();

1156 1157 1158
    #
    # Derive a useful tag.
    # 
1159 1160 1161
    my ($seconds, $microseconds) = gettimeofday();
    my $newtag  = POSIX::strftime("T20%y%m%d-%H%M%S-", localtime());
    $newtag .= int($microseconds / 1000);
Leigh B. Stoller's avatar
Leigh B. Stoller committed
1162
    $newtag .= "_postswapmod";
1163 1164

    return -1
1165
	if (ArchiveCommit($archive_idx, $newtag, $view, $preswapdir) != 0);
1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178

    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 ($?) {
Leigh B. Stoller's avatar
Leigh B. Stoller committed
1179
	print STDERR "*** ArchiveSwapModCommit: Could not rm $preswapdir\n";
1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190
    }

    return 0;
}

#
# Commit an experiment archive. 
#
sub TBCommitExperimentArchive($$$)
{
    my ($pid, $eid, $tagext) =