libArchive.pm.in 18.9 KB
Newer Older
1 2 3
#!/usr/bin/perl -wT
#
# EMULAB-COPYRIGHT
4
# Copyright (c) 2005, 2006, 2007 University of Utah and the Flux Group.
5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20
# 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
use Project;
23
use English;
24 25
use Experiment;
use Archive;
26 27 28 29 30 31 32
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
33
my $MAINSITE    = @TBMAINSITE@;
34 35
my $ARCHSUPPORT = @ARCHIVESUPPORT@;
my $USEARCHIVE  = ($MAINSITE || $ARCHSUPPORT);
36
my $ZIPINFO     = "/usr/local/bin/zipinfo";
37
my $TAR		= "/usr/bin/tar";
38

39
sub setdebug($)
40
{
41
    my ($toggle) = @_;
42

43
    Archive::setdebug($toggle);
44 45 46 47 48 49 50
}

#
# 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.
#
51
sub TBExperimentArchive($$$$)
52
{
53
    my ($pid, $eid, $archivep, $viewp) = @_;
54 55

    my $query_result =
56
	DBQueryWarn("select s.archive_idx,e.idx from experiments as e ".
57 58 59 60 61 62
		    "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);

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

65 66 67
    # Need to deal with no archive yet!
    return 1
	if (!defined($archive_idx) || $archive_idx == 0);
68

69 70 71 72 73 74
    my $archive = Archive->Lookup($archive_idx);
    return -1
	if (!defined($archive));

    $$archivep = $archive
	if (defined($archivep));
75 76
    $$viewp = "$exptidx"
	if (defined($viewp));
77
    
78
    return 0;
79 80
}

81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106
#
# Grab the current tag for an experiment.
#
sub TBExperimentArchiveTag($$$)
{
    my ($pid, $eid, $tagp) = @_;

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

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

    my ($archive_tag) = $query_result->fetchrow_array();

    # Need to deal with no archive yet!
    return 1
	if (!defined($archive_tag));

    $$tagp = $archive_tag;
    return 0;
}

107 108 109 110 111 112 113 114 115 116 117
#
# 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
118
    return 0
119 120 121 122 123
	if (!Archive::doarchiving($pid, $eid));

    my $experiment = Experiment->Lookup($pid, $eid);
    return -1
	if (!defined($experiment));
124
    
125 126 127 128 129
    my $exptidx   = $experiment->idx();
    my $rsrcidx   = $experiment->rsrcidx();
    my $group     = $experiment->GetGroup();
    my $unix_name = $group->unix_name();
    my $view      = "$exptidx";
130

131 132 133
    my $archive = Archive->Create($view, $unix_name);
    return -1
	if (!defined($archive));
134

135
    my $archive_idx = $archive->idx();
136

137 138 139 140
    $experiment->TableUpdate("experiment_stats",
			     "archive_idx='$archive_idx'") == 0
	or goto bad;
    
141
    return 0;
142 143

  bad:
144
    $archive->Destroy(1, $view);
145
    return -1;
146 147 148 149 150
}

#
# Add a file to an experiment archive.
#
151
sub TBExperimentArchiveAddFile($$$;$)
152
{
153
    my ($pid, $eid, $pathname, $exact) = @_;
154
    my ($archive, $view);
155

Leigh B. Stoller's avatar
Leigh B. Stoller committed
156
    return 0
157
	if (!Archive::doarchiving($pid, $eid));
158
    
159
    my $rval = TBExperimentArchive($pid, $eid, \$archive, \$view);
160 161
    return 0
	if ($rval > 0);
162
    return -1
163
	if ($rval < 0);
164

165
    return $archive->Add($pathname, $view, $exact);
166 167
}

168 169 170 171
#
# Add files picked up by NFS tracing to an experiment archive.
#
sub TBExperimentArchiveAddTracedFiles($$)
172 173 174 175 176 177 178 179
{
    return 0;
}

#
# Add all files from the experiment directory to the archive.
#
sub TBExperimentArchiveAddUserFiles($$)
180 181
{
    my ($pid, $eid) = @_;
182
    my ($archive, $view);
183 184

    return 0
185
	if (!Archive::doarchiving($pid, $eid));
186
    
187
    my $rval = TBExperimentArchive($pid, $eid, \$archive, \$view);
188 189 190 191 192
    return 0
	if ($rval > 0);
    return -1
	if ($rval < 0);

193
    my $userdir = TBExptUserDir($pid, $eid);
Timothy Stack's avatar
Timothy Stack committed
194

195 196
    if (-e $userdir) {
	$rval = $archive->Add("$userdir/.", $view, 1, 1);
197 198 199 200 201 202 203

	return $rval
	    if ($rval != 0);
    }
    return 0;
}

204
#
205
# Check for differences in the user files to see if we need a commit.
206
#
207
sub TBExperimentArchiveDiffUserFiles($$)
208 209
{
    my ($pid, $eid) = @_;
210
    my ($archive, $view);
211

Leigh B. Stoller's avatar
Leigh B. Stoller committed
212
    return 0
213
	if (!Archive::doarchiving($pid, $eid));
214
    
215
    my $rval = TBExperimentArchive($pid, $eid, \$archive, \$view);
Leigh B. Stoller's avatar
Leigh B. Stoller committed
216 217 218 219 220
    return 0
	if ($rval > 0);
    return -1
	if ($rval < 0);

221
    my $userdir = TBExptUserDir($pid, $eid);
Leigh B. Stoller's avatar
Leigh B. Stoller committed
222

223
    if (-e $userdir) {
224
	$rval = $archive->Diff("$userdir/.", $view);
Leigh B. Stoller's avatar
Leigh B. Stoller committed
225 226 227 228 229 230 231

	return $rval
	    if ($rval != 0);
    }
    return 0;
}

232
#
233
# SavePoint an experiment archive. 
234
#
235
sub TBExperimentArchiveSavePoint($$;$)
236
{
237
    return 0;
238 239 240 241 242 243 244 245
}

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

Leigh B. Stoller's avatar
Leigh B. Stoller committed
248
    return 0
249
	if (!Archive::doarchiving($pid, $eid));
250
    
251
    my $rval = TBExperimentArchive($pid, $eid, \$archive, \$view);
252 253
    return 0
	if ($rval > 0);
254
    return -1
255
	if ($rval < 0);
256

257
    my $directory = $archive->directory();
258 259 260 261
    if (! -d $directory || ! -w $directory) {
	print STDERR "ArchivePreSwapMod: $directory cannot be written!\n";
	return -1;
    }
262
    my $checkin    = "$directory/checkins/$view";
Leigh B. Stoller's avatar
Leigh B. Stoller committed
263
    my $preswapdir = "${checkin}.preswapmod";
264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286

    #
    # 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;
    }
    
287
    mysystem("$TAR cf - -C $checkin . | tar xf - -C $preswapdir");
288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305
    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;
}

Leigh B. Stoller's avatar
Leigh B. Stoller committed
306 307 308 309 310 311
#
# Next phase of a swapmod; do another snapshot after the swapout completes.
#
sub TBExperimentArchiveSwapModSwapOut($$)
{
    my ($pid, $eid) = @_;
312
    my ($archive, $view);
Leigh B. Stoller's avatar
Leigh B. Stoller committed
313 314

    return 0
315
	if (!Archive::doarchiving($pid, $eid));
316
    
317
    my $rval = TBExperimentArchive($pid, $eid, \$archive, \$view);
Leigh B. Stoller's avatar
Leigh B. Stoller committed
318 319 320 321 322
    return 0
	if ($rval > 0);
    return -1
	if ($rval < 0);

323
    my $directory = $archive->directory();
Leigh B. Stoller's avatar
Leigh B. Stoller committed
324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390
    if (! -d $directory || ! -w $directory) {
	print STDERR "ArchiveSwapmodswapout: $directory cannot be written!\n";
	return -1;
    }
    my $checkin    = "$directory/checkins/$view";
    my $preswapdir = "${checkin}.swapmodswapout";

    #
    # Grab the user specified files. 
    #
    if (TBExperimentArchiveAddUserFiles($pid, $eid) < 0) {
	print STDERR "ArchiveSwapmodswapout: ".
	    "Failed to add user specified files to the experiment archive!\n";
	return -1;
    }
    
    #
    # Add the files that have been detected by tracing to the archive.
    #
    if (TBExperimentArchiveAddTracedFiles($pid, $eid) < 0) {
	print STDERR "ArchiveSwapmodswapout: ".
	    "Failed to add traced files to the experiment archive!\n";
	return -1;
    }

    #
    # Make a copy of the current tree; This is the tree that will be
    # committed as the swapout if the swapmod completes okay.
    #
    if (-e $preswapdir) {
	system("/bin/rm -rf $preswapdir");
	if (-e $preswapdir) {
	    print STDERR
		"ArchiveSwapmodswapout: Could not delete old preswap dir!\n";
	    return -1;
	}
    }
    if (! mkdir("$preswapdir", 0777)) {
	print STDERR
	    "ArchiveSwapmodswapout: Could not mkdir $preswapdir: $!\n";
	return -1;
    }
    if (! chmod(0777, "$preswapdir")) {
	print STDERR "ArchiveSwapmodswapout: ".
	    "Could not chmod directory $preswapdir: $!\n";
	goto bad;
    }
    
    mysystem("$TAR cf - -C $checkin . | tar xf - -C $preswapdir");
    if ($?) {
	print STDERR "ArchiveSwapmodswapout: 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
		"ArchiveSwapmodswapout: Could not delete new preswap dir!\n";
	}
    }
    return -1;
}

391 392 393 394 395 396
#
# Rollback from a failed swapmod.
#
sub TBExperimentArchiveRollBack($$)
{
    my ($pid, $eid) = @_;
397
    my ($archive, $view);
398

Leigh B. Stoller's avatar
Leigh B. Stoller committed
399
    return 0
400
	if (!Archive::doarchiving($pid, $eid));
401
    
402
    my $rval = TBExperimentArchive($pid, $eid, \$archive, \$view);
403 404
    return 0
	if ($rval > 0);
405
    return -1
406
	if ($rval < 0);
407

408
    my $directory = $archive->directory();
409 410 411 412
    if (! -d $directory || ! -w $directory) {
	print STDERR "ArchiveRollBack: $directory cannot be written!\n";
	return -1;
    }
Leigh B. Stoller's avatar
Leigh B. Stoller committed
413 414 415
    my $checkin        = "$directory/checkins/$view";
    my $preswapdir     = "${checkin}.preswapmod";
    my $swapmodswapout = "${checkin}.swapmodswapout";
416 417 418 419 420 421 422 423

    # 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.
    #
424 425 426
    if (-e $checkin) {
	system("/bin/rm -rf $checkin");
	if (-e $checkin) {
427
	    print STDERR
Leigh B. Stoller's avatar
Leigh B. Stoller committed
428 429 430 431 432 433 434 435 436
		"ArchiveRollBack: Could not delete $checkin!\n";
	    return -1;
	}
    }
    if (-e $swapmodswapout) {
	system("/bin/rm -rf $swapmodswapout");
	if (-e $swapmodswapout) {
	    print STDERR
		"ArchiveRollBack: Could not delete $swapmodswapout!\n";
437 438 439
	    return -1;
	}
    }
440
    system("/bin/mv -f $preswapdir $checkin");
441 442
    if ($?) {
	print STDERR "ArchiveRollBack: ".
443
	    "Could not mv $preswapdir to $checkin\n";
444 445 446 447 448 449 450 451 452
	return -1;
    }
    return 0;
}

#
# Swapmod completed okay. Need to commit the old preswap directory and
# move forward. 
#
Leigh B. Stoller's avatar
Leigh B. Stoller committed
453
sub TBExperimentArchiveSwapModCommit($$$)
454
{
Leigh B. Stoller's avatar
Leigh B. Stoller committed
455
    my ($pid, $eid, $swapped) = @_;
456
    my ($archive, $view);
457

Leigh B. Stoller's avatar
Leigh B. Stoller committed
458
    return 0
459
	if (!Archive::doarchiving($pid, $eid));
460
    
461
    my $rval = TBExperimentArchive($pid, $eid, \$archive, \$view);
462 463
    return 0
	if ($rval > 0);
464
    return -1
465
	if ($rval < 0);
466

467
    my $directory = $archive->directory();
468
    if (! -d $directory || ! -w $directory) {
Leigh B. Stoller's avatar
Leigh B. Stoller committed
469
	print STDERR "ArchiveSwapModCommit: $directory cannot be written!\n";
470 471
	return -1;
    }
Leigh B. Stoller's avatar
Leigh B. Stoller committed
472 473 474 475 476 477 478 479 480
    my $checkin        = "$directory/checkins/$view";
    my $preswapdir     = "${checkin}.preswapmod";
    my $swapmodswapout = "${checkin}.swapmodswapout";

    #
    # Where we get the previous stuff depends on whether the modify is
    # of a swapped in or swapped out experiment.
    #
    my $location = ($swapped ? $preswapdir : $swapmodswapout);
481 482

    #
483
    # We need this below.
484 485 486 487 488 489 490 491 492 493
    #
    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();

494 495 496
    #
    # Derive a useful tag.
    # 
497 498 499
    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
500
    $newtag .= "_preswapmod";
501

Leigh B. Stoller's avatar
Leigh B. Stoller committed
502
    print "Doing a commit on the experiment archive ...\n";
503
    return -1
504
	if ($archive->Commit($newtag, undef, $view, $location) != 0);
505 506 507 508 509 510 511 512 513 514 515 516 517

    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
518
	print STDERR "*** ArchiveSwapModCommit: Could not rm $preswapdir\n";
519
    }
Leigh B. Stoller's avatar
Leigh B. Stoller committed
520 521 522 523 524 525
    # Ditto.
    system("/bin/rm -rf $swapmodswapout");
    if ($?) {
	print STDERR
	    "*** ArchiveSwapModCommit: Could not rm $swapmodswapout\n";
    }
526 527 528 529 530 531 532

    return 0;
}

#
# Commit an experiment archive. 
#
533
sub TBCommitExperimentArchive($$$;$$)
534
{
535
    my ($pid, $eid, $tagext, $usertagged, $mfile) = @_;
536
    my ($archive, $view);
537

Leigh B. Stoller's avatar
Leigh B. Stoller committed
538
    return 0
539
	if (!Archive::doarchiving($pid, $eid));
540
    
541
    my $rval = TBExperimentArchive($pid, $eid, \$archive, \$view);
542 543
    return 0
	if ($rval > 0);
544
    return -1
545
	if ($rval < 0);
546

547 548 549 550 551 552
    my $experiment = Experiment->Lookup($pid, $eid);
    return -1
	if (!defined($experiment));

    my $rsrcidx     = $experiment->rsrcidx();
    my $archive_idx = $archive->idx();
553

554
    #
555 556
    # Derive a tag, unless its a user specified tag. In that case it
    # has to be unique cause we are going to use the whole thing as is.
557
    #
558 559 560 561 562 563 564 565 566 567
    my $newtag;
    if (! $usertagged) {
	my ($seconds, $microseconds) = gettimeofday();
	$newtag  = POSIX::strftime("T20%y%m%d-%H%M%S-", localtime());
	$newtag .= int($microseconds / 1000);
	$newtag .= "_${tagext}";
    }
    else {
	$newtag = $tagext;

568
	my $unique = $archive->IsTagUnique($newtag, $view);
569
	return -1
570
	    if (!defined($unique));
571 572 573 574 575 576

	if (! $unique) {
	    print STDERR "*** ArchiveCommit: Duplicate user tag: $newtag\n";
	    return -1;
	}
    }
577 578

    return -1
579 580 581 582 583
	if ($archive->Commit($newtag, $mfile, $view) != 0);

    $experiment->TableUpdate("experiment_resources",
			     "archive_tag='$newtag'", "idx='$rsrcidx'") == 0
	or goto bad;
584

585 586 587 588
    # A user specified tag is updated.
    if ($usertagged) {
	my $query_result =
	    DBQueryWarn("update archive_tags set ".
589
			"  tagtype='$Archive::TAGTYPE_USER' ".
590 591 592 593 594 595 596 597 598
			"where archive_idx='$archive_idx' and ".
			"      view='$view' and tag='$newtag'");
	return -1
	    if (!$query_result);
	if (!$query_result->affectedrows) {
	    print STDERR "*** ArchiveCommit: ".
		"Could not update user tag: $newtag\n";
	}
    }
599 600 601
    return 0;
}

602 603 604 605 606 607 608 609
#
# Tag an experiment archive. 
#
sub TBTagExperimentArchive($$$;$$)
{
    return 0;
}

610 611 612
#
# Checkout a copy of an experiment archive, optionally at a branch.
# 
613
sub TBCheckoutExperimentArchive($$$;$$)
614
{
615
    my ($pid, $eid, $path, $tag, $subdir) = @_;
616
    my ($archive, $view);
617 618

    return 0
619
	if (!Archive::doarchiving($pid, $eid));
620
    
621
    my $rval = TBExperimentArchive($pid, $eid, \$archive, \$view);
622 623 624 625 626
    return 0
	if ($rval > 0);
    return -1
	if ($rval < 0);

627
    return $archive->Checkout($path, $view, $tag, $subdir);
628 629
}

Leigh B. Stoller's avatar
Leigh B. Stoller committed
630 631 632
#
# Checkout a copy of an experiment archive, optionally at a branch.
# 
633
sub TBCheckoutExperimentArchivebyExptIDX($$;$$)
Leigh B. Stoller's avatar
Leigh B. Stoller committed
634
{
635
    my ($exptidx, $path, $tag, $subdir) = @_;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
636 637

    return 0
638
	if (!$USEARCHIVE);
Leigh B. Stoller's avatar
Leigh B. Stoller committed
639 640

    my $query_result =
641 642
	DBQueryWarn("select archive_idx from experiment_stats ".
		    "where exptidx='$exptidx'");
Leigh B. Stoller's avatar
Leigh B. Stoller committed
643
    return -1
644 645 646 647
	if (!$query_result || !$query_result->numrows);
    
    my ($archive_idx) = $query_result->fetchrow_array();
    
Leigh B. Stoller's avatar
Leigh B. Stoller committed
648
    return 0
649
	if (!$archive_idx);
Leigh B. Stoller's avatar
Leigh B. Stoller committed
650

651 652 653
    my $archive = Archive->Lookup($archive_idx);
    return -1
	if (!defined($archive));
Leigh B. Stoller's avatar
Leigh B. Stoller committed
654

655
    return $archive->Checkout($path, $exptidx, $tag, $subdir);
Leigh B. Stoller's avatar
Leigh B. Stoller committed
656 657
}

658 659 660 661 662 663
#
# Archive an experiment archive to the save area.
# 
sub TBArchiveExperimentArchive($$)
{
    my ($pid, $eid) = @_;
664
    my ($archive, $view);
665

Leigh B. Stoller's avatar
Leigh B. Stoller committed
666
    return 0
667
	if (!Archive::doarchiving($pid, $eid));
668
    
669
    my $rval = TBExperimentArchive($pid, $eid, \$archive, \$view);
670 671
    return 0
	if ($rval > 0);
672
    return -1
673
	if ($rval < 0);
674

675
    return $archive->Archive($view);
676 677 678 679 680 681 682 683 684
}

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

Leigh B. Stoller's avatar
Leigh B. Stoller committed
687
    return 0
688
	if (!Archive::doarchiving($pid, $eid));
689
    
690
    my $rval = TBExperimentArchive($pid, $eid, \$archive, \$view);
691 692
    return 0
	if ($rval > 0);
693
    return -1
694
	if ($rval < 0);
695

696
    return $archive->Destroy(0, $view);
697 698 699 700 701 702 703 704
}

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

Leigh B. Stoller's avatar
Leigh B. Stoller committed
707
    return 0
708
	if (!Archive::doarchiving($pid, $eid));
709
    
710
    my $rval = TBExperimentArchive($pid, $eid, \$archive, \$view);
711 712
    return 0
	if ($rval > 0);
713
    return -1
714
	if ($rval < 0);
715

716
    return $archive->Destroy(1, $view);
717 718 719 720 721 722 723 724 725
}

#
# Branch an experiment archive. Only an existing experiment can be
# branched, but that will probably change later. 
#
sub TBForkExperimentArchive($$$$$)
{
    my ($pid, $eid, $copypid, $copyeid, $copytag) = @_;
726
    my ($archive, $copyview);
727 728

    return 0
729
	if (!Archive::doarchiving($pid, $eid));
730
    
731 732
    my $rval = TBExperimentArchive($copypid, $copyeid,
				   \$archive, \$copyview);
733 734 735 736 737
    return 0
	if ($rval > 0);
    return -1
	if ($rval < 0);

738 739 740 741 742 743 744 745
    my $experiment = Experiment->Lookup($pid, $eid);
    return -1
	if (!defined($experiment));

    my $archive_idx = $archive->idx();
    my $rsrcidx     = $experiment->rsrcidx();
    my $archive_tag = "F${rsrcidx}";
    my $newview     = $experiment->idx();
746 747

    return -1
748 749 750 751 752 753 754 755 756 757 758
	if ($archive->Fork($newview, $archive_tag, $copyview) < 0);

    $experiment->TableUpdate("experiment_resources",
			     "archive_tag='$archive_tag'",
			     "idx='$rsrcidx'") == 0
	or goto bad;

    $experiment->TableUpdate("experiment_stats",
			     "archive_idx='$archive_idx'") == 0
	or goto bad;

759
    return 0;
760 761 762 763 764 765

  bad:
    # Its a shared resource, but ArchiveDestroy() checks.
    $archive->Destroy(1, $newview)
	if (defined($archive));
    return -1;
766 767
}

768 769 770 771 772 773
#
# Check that a tag is unique.
#
sub TBIsTaqUnique($$$$)
{
    my ($pid, $eid, $tag, $prval) = @_;
774
    my ($archive, $view);
775 776
    
    return 0
777
	if (!Archive::doarchiving($pid, $eid));
778
    
779
    my $rval = TBExperimentArchive($pid, $eid, \$archive, \$view);
780 781 782 783 784
    return 0
	if ($rval > 0);
    return -1
	if ($rval < 0);

785 786 787 788 789
    my $unique = $archive->IsTagUnique($tag, $view);
    return -1
	if (!defined($unique));
    $$prval = $unique;
    return 0;
790 791
}

792 793 794 795
#
# Return a list of files in a particular spot in the archive. This avoids
# having to check it out.
#
796
sub TBListExperimentArchive($$$;$$$)
797
{
798 799
    my ($pid, $eid, $prval, $long, $tag, $root, $subdir) = @_;
    my ($archive, $view);
800 801

    return 0
802
	if (!Archive::doarchiving($pid, $eid));
803
    
804
    my $rval = TBExperimentArchive($pid, $eid, \$archive, \$view);
805 806 807 808 809
    return 0
	if ($rval > 0);
    return -1
	if ($rval < 0);

810
    return $archive->List($prval, $view, $long, $tag, $subdir);
811 812
}

813
#
814 815
# Return a list of files in a particular spot in the archive. This avoids
# having to check it out.
816 817 818 819
#
sub TBDUExperimentArchive($$$)
{
    my ($pid, $eid, $prval) = @_;
820
    my ($archive, $view);
821 822 823

    $$prval = 0;
    return 0
824
	if (!Archive::doarchiving($pid, $eid));
825
    
826
    my $rval = TBExperimentArchive($pid, $eid, \$archive, \$view);
827 828 829 830 831
    return 0
	if ($rval > 0);
    return -1
	if ($rval < 0);

832
    return $archive->DU($prval);
833 834
}

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