Skip to content
GitLab
Menu
Projects
Groups
Snippets
/
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in / Register
Toggle navigation
Menu
Open sidebar
emulab
emulab-devel
Commits
421c0edf
Commit
421c0edf
authored
Nov 03, 2005
by
Leigh B. Stoller
Browse files
Commit my prototype archive library. A work in progress, incomplete,
not ready for primetime, or even late night TV.
parent
9b2c1e26
Changes
1
Hide whitespace changes
Inline
Side-by-side
tbsetup/libArchive.pm.in
0 → 100644
View file @
421c0edf
#
!/usr/bin/perl -wT
#
#
EMULAB
-
COPYRIGHT
#
Copyright
(
c
)
2005
University
of
Utah
and
the
Flux
Group
.
#
All
rights
reserved
.
#
#
XXX
Need
to
deal
with
locking
at
some
point
...
#
package
libArchive
;
use
strict
;
use
Exporter
;
use
vars
qw
(@
ISA
@
EXPORT
);
@
ISA
=
"Exporter"
;
@
EXPORT
=
qw
(
);
#
Must
come
after
package
declaration
!
use
lib
'@prefix@/lib'
;
use
libdb
;
use
English
;
use
File
::
stat
;
use
File
::
Basename
;
use
POSIX
qw
(
strftime
);
use
Time
::
HiRes
qw
(
gettimeofday
);
#
Configure
variables
my
$
TB
=
"@prefix@"
;
#
XXX
my
$
ARCHIVEDIR
=
"/usr/testbed/exparchive"
;
my
$
TESTMODE
=
@
TESTMODE
@;
my
$
TBOPS
=
"@TBOPSEMAIL@"
;
my
$
ELABINELAB
=
@
ELABINELAB
@;
my
$
MD5
=
"/sbin/md5"
;
my
$
MKDIR
=
"/bin/mkdir"
;
my
$
CHMOD
=
"/bin/chmod"
;
my
$
TAR
=
"/usr/bin/tar"
;
my
$
RM
=
"/bin/rm"
;
my
$
CVSBIN
=
"/usr/bin/cvs"
;
my
$
inittag
=
'created'
;
my
$
debug
=
1
;
#
Little
helper
and
debug
function
.
sub
mysystem
($)
{
my
($
command
)
=
@
_
;
print
STDERR
"Running '$command'
\n
"
if
($
debug
);
system
($
command
);
}
#
#
Create
a
new
archive
.
Returns
-
1
if
any
error
.
Otherwise
return
#
the
new
record
index
.
#
sub
ArchiveCreate
()
{
my
$
idx
;
my
$
dir
;
my
$
tag
=
$
inittag
;
#
#
Need
to
create
the
directory
for
it
,
once
we
have
the
index
.
#
my
$
query_result
=
DBQueryWarn
(
"insert into file_archives set "
.
" idx=NULL, current_tag='created', "
.
" date_created=UNIX_TIMESTAMP(now())"
);
return
-
1
if
(
!$query_result);
$
idx
=
$
query_result
->
insertid
;
$
dir
=
"$ARCHIVEDIR/$idx"
;
#
#
Create
the
directory
and
store
the
absolute
path
into
the
new
record
.
#
This
should
probably
be
a
privledged
operation
at
some
point
.
#
mysystem
(
"$MKDIR $dir"
)
==
0
or
goto
bad
;
mysystem
(
"$CHMOD 775 $dir"
)
==
0
or
goto
bad
;
DBQueryWarn
(
"update file_archives set directory='$dir' where idx='$idx'"
)
or
goto
bad
;
#
#
Make
two
subdirs
.
One
to
hold
the
CVS
control
tree
,
and
the
other
#
to
hold
the
currently
checked
out
version
of
the
tree
.
#
my
$
cvsdir
=
"$dir/repo"
;
my
$
root
=
"$dir/root"
;
my
$
temp
=
"$dir/tmp"
;
if
(
! mkdir("$cvsdir", 0777)) {
print
STDERR
"ArchiveCreate: Could not mkdir $cvsdir: $!
\n
"
;
goto
bad
;
}
if
(
! chmod(0777, "$cvsdir")) {
print
STDERR
"ArchiveCreate: Could not chmod directory $cvsdir: $!
\n
"
;
goto
bad
;
}
if
(
! mkdir("$root", 0777)) {
print
STDERR
"ArchiveCreate: Could not mkdir $root: $!
\n
"
;
goto
bad
;
}
if
(
! chmod(0777, "$root")) {
print
STDERR
"ArchiveCreate: Could not chmod directory $root: $!
\n
"
;
goto
bad
;
}
if
(
! mkdir("$temp", 0777)) {
print
STDERR
"ArchiveCreate: Could not mkdir $temp: $!
\n
"
;
goto
bad
;
}
if
(
! chmod(0777, "$temp")) {
print
STDERR
"ArchiveCreate: Could not chmod directory $temp: $!
\n
"
;
goto
bad
;
}
#
Init
the
CVS
control
files
.
mysystem
(
"$CVSBIN -d $cvsdir init"
)
==
0
or
goto
bad
;
#
Create
an
stub
directory
and
import
it
as
"root"
mysystem
(
"cd $dir; mkdir ignore; cd ignore; "
.
"$CVSBIN -d $cvsdir import -m 'Initial Revision' root root $tag"
)
==
0
or
goto
bad
;
#
Now
check
it
out
.
mysystem
(
"cd $dir; $CVSBIN -d $cvsdir checkout root"
)
==
0
or
goto
bad
;
#
Now
enter
an
initial
tag
for
the
tree
.
Nothing
actually
gets
tagged
.
DBQueryWarn
(
"insert into archive_tags set "
.
" tag='$tag', "
.
" archive_idx='$idx', "
.
" date_created=UNIX_TIMESTAMP(now())"
)
or
goto
bad
;
return
$
idx
;
bad
:
#
mysystem
(
"$RM -rf $dir"
)
#
if
(
defined
($
dir
));
DBQueryFatal
(
"delete from file_archives where idx='$idx'"
)
if
(
defined
($
idx
));
return
-
1
;
}
#
#
Add
a
file
to
an
archive
.
Returns
-
1
if
any
error
.
Otherwise
return
0.
#
All
this
does
is
copy
the
file
(
and
its
directory
structure
)
into
the
#
temporary
store
.
Later
,
after
all
the
files
are
in
the
tree
,
must
#
commit
it
to
the
repo
.
#
sub
ArchiveAdd
($$)
{
my
($
archive_idx
,
$
pathname
)
=
@
_
;
if
(
! -e $pathname || ! -r $pathname) {
print
STDERR
"ArchiveFile: $pathname cannot be read!
\n
"
;
return
-
1
;
}
if
(
! -f $pathname) {
print
STDERR
"ArchiveFile: $pathname must be a plain file!
\n
"
;
return
-
1
;
}
#
#
Check
that
the
path
does
not
contain
an
links
to
files
outside
#
the
directory
space
the
user
is
allowed
to
access
.
#
my
$
realpath
=
`
realpath
$
pathname
`;
if
($
realpath
=~
/^([-\
w
\/\.\+\@,]+)$/)
{
$
realpath
=
$
1
;
}
else
{
print
STDERR
"ArchiveFile: "
.
"Bad data returned by realpath: $realpath
\n
"
;
}
#
#
The
file
must
reside
in
/
proj
,
/
groups
,
or
/
users
.
#
if
(
! ($realpath =~ /^\/proj/) &&
! ($realpath =~ /^\/groups/) &&
! ($realpath =~ /^\/users/)) {
print
STDERR
"ArchiveFile: "
.
"$realpath does not resolve to an allowed directory!
\n
"
;
return
-
1
;
}
#
Strip
leading
/
from
the
pathname
,
and
taint
check
it
.
if
($
pathname
=~
/^[\/]+([-\
w
\/\.\+\@,]+)$/)
{
$
pathname
=
$
1
;
}
else
{
print
STDERR
"ArchiveFile: Illegal characters in pathname $pathname
\n
"
;
return
-
1
;
}
#
#
See
if
the
archive
exists
and
if
it
does
,
get
the
pathname
to
it
.
#
my
$
directory
;
if
(
GetArchiveDirectory
($
archive_idx
,
\$
directory
)
<
0
)
{
print
STDERR
"ArchiveFile: "
.
"Archive '$archive_idx' does not exist in the DB!
\n
"
;
return
-
1
;
}
if
(
! -d $directory || ! -w $directory) {
print
STDERR
"ArchiveFile: $directory cannot be written!
\n
"
;
return
-
1
;
}
my
$
cvsdir
=
"$directory/repo"
;
my
$
rootdir
=
"$directory/root"
;
my
$
tmpdir
=
"$directory/tmp"
;
#
#
See
if
the
file
is
already
in
the
archive
.
We
currently
deal
with
#
just
files
;
directories
are
gonna
be
a
pain
in
the
butt
.
#
my
$
target_path
=
"$tmpdir/$pathname"
;
#
#
The
file
should
not
already
exist
in
the
temporary
store
.
#
if
(-
e
$
target_path
)
{
print
STDERR
"ArchiveFile: "
.
"$pathname already exists in archive '$archive_idx'!
\n
"
;
return
-
1
;
}
#
#
Not
in
the
archive
.
Copy
the
file
in
.
We
use
tar
cause
we
#
want
to
retain
the
directory
structure
and
mode
bits
,
etc
.
#
mysystem
(
"$TAR cf - /$pathname | tar xf - -C $tmpdir"
);
if
($?)
{
print
STDERR
"ArchiveFile: Could not copy in /$pathname
\n
"
;
return
-
1
;
}
return
0
;
}
#
#
Commit
the
current
contents
of
the
temporary
store
to
the
archive
.
#
Returns
-
1
if
any
error
.
Otherwise
return
0.
#
sub
ArchiveCommit
($;$)
{
my
($
archive_idx
,
$
newtag
)
=
@
_
;
#
#
See
if
the
archive
exists
and
if
it
does
,
get
the
pathname
to
it
.
#
my
$
directory
;
if
(
GetArchiveDirectory
($
archive_idx
,
\$
directory
)
<
0
)
{
print
STDERR
"ArchiveCommit: "
.
"Archive '$archive_idx' does not exist in the DB!
\n
"
;
return
-
1
;
}
if
(
! -d $directory || ! -w $directory) {
print
STDERR
"ArchiveFile: $directory cannot be written!
\n
"
;
return
-
1
;
}
my
$
cvsdir
=
"$directory/repo"
;
my
$
rootdir
=
"$directory/root"
;
my
$
tmpdir
=
"$directory/tmp"
;
#
Get
the
current
tag
for
the
archive
.
my
$
archive_tag
;
if
(
GetArchiveCurrentTag
($
archive_idx
,
\$
archive_tag
)
<
0
)
{
print
STDERR
"ArchiveCommit: "
.
"Archive '$archive_idx' does not have a current tag!
\n
"
;
return
-
1
;
}
if
(
!defined($newtag)) {
my
($
seconds
,
$
microseconds
)
=
gettimeofday
();
$
newtag
=
POSIX
::
strftime
(
"T20%y%m%d-%H%M%S"
,
localtime
());
$
newtag
.=
$
microseconds
;
}
my
$
import_tag
=
$
newtag
.
"_import"
;
my
$
commit_tag
=
$
newtag
.
"_commit"
;
if
(
! chdir("$tmpdir")) {
print
STDERR
"ArchiveCommit: "
.
"Cannot chdir to $tmpdir!
\n
"
;
return
-
1
;
}
#
#
Use
cvs
import
command
.
This
is
nice
cause
it
handles
all
the
#
subdirs
and
stuff
in
one
shot
,
instead
of
trying
to
deal
with
#
each
file
and
directory
individually
.
#
mysystem
(
"$CVSBIN -d $cvsdir import "
.
"-m 'Import new version' root root $import_tag"
);
if
($?)
{
print
STDERR
"ArchiveCommit: "
.
"Could not import from $tmpdir!
\n
"
;
return
-
1
;
}
DBQueryWarn
(
"insert into archive_tags set "
.
" tag='$newtag', "
.
" archive_idx='$archive_idx', "
.
" date_created=UNIX_TIMESTAMP(now())"
)
or
return
-
1
;
DBQueryWarn
(
"update file_archives set "
.
" current_tag='$newtag' "
.
"where idx='$archive_idx'"
);
#
Clean
the
temp
dir
for
next
phase
.
mysystem
(
"/bin/rm -rf $tmpdir/*"
);
if
($?)
{
print
STDERR
"ArchiveCommit: "
.
"Could not remove contents of $tmpdir!
\n
"
;
return
-
1
;
}
#
#
If
this
is
the
first
commit
,
then
we
are
done
cause
there
is
nothing
#
to
merge
with
.
#
return
0
if
($
archive_tag
eq
$
inittag
);
#
#
Need
to
merge
.
Do
a
fresh
checkout
,
merging
this
latest
tag
with
#
the
previous
tag
.
#
mysystem
(
"$CVSBIN -d $cvsdir checkout "
.
"-j ${archive_tag}_import -j $import_tag root"
);
if
($?)
{
print
STDERR
"ArchiveCommit: "
.
"Could not checkout and merge $archive_tag with $newtag!
\n
"
;
return
-
1
;
}
#
And
then
commit
it
back
to
the
head
revision
.
mysystem
(
"$CVSBIN -d $cvsdir commit "
.
"-m 'Merged ${archive_tag}_import with $import_tag'"
);
if
($?)
{
print
STDERR
"ArchiveCommit: "
.
"Could not commit merge back to the repository!
\n
"
;
return
-
1
;
}
#
Clean
the
temp
dir
for
next
phase
.
mysystem
(
"/bin/rm -rf $tmpdir/*"
);
if
($?)
{
print
STDERR
"ArchiveCommit: "
.
"Could not remove contents of $tmpdir!
\n
"
;
return
-
1
;
}
#
And
lets
tag
the
tree
for
good
measure
with
a
commit
tag
.
mysystem
(
"$CVSBIN -d $cvsdir rtag $commit_tag root"
);
if
($?)
{
print
STDERR
"ArchiveCommit: "
.
"Could not rtag with $commit_tag!
\n
"
;
return
-
1
;
}
#
And
now
into
the
root
dir
to
checkout
a
current
copy
.
if
(
! chdir("$rootdir")) {
print
STDERR
"ArchiveCommit: "
.
"Cannot chdir to $rootdir!
\n
"
;
return
-
1
;
}
mysystem
(
"$CVSBIN -d $cvsdir checkout root"
);
if
($?)
{
print
STDERR
"ArchiveCommit: "
.
"Could not checkout head revision!
\n
"
;
return
-
1
;
}
return
0
;
}
#
#
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
;
}
if
(
! -e $target) {
if
(
! mkdir("$target", 0777)) {
print
STDERR
"ArchiveArchive: Could not mkdir $target: $!
\n
"
;
return
-
1
;
}
if
(
! chmod(0777, "$target")) {
print
STDERR
"ArchiveArchive: "
.
"Could not chmod directory $target: $!
\n
"
;
return
-
1
;
}
}
#
#
Tar
up
the
whole
thing
and
move
it
across
.
#
mysystem
(
"$TAR cf - -C $directory . | tar xf - -C $target"
);
if
($?)
{
print
STDERR
"ArchiveArchive: Could not copy in $directory
\n
"
;
return
-
1
;
}
return
0
;
}
#
#
Destroy
an
archive
.
The
DB
state
is
retained
unless
optional
flag
says
#
to
clean
it
.
#
sub
ArchiveDestroy
($;$)
{
my
($
archive_idx
,
$
clean
)
=
@
_
;
#
#
See
if
the
archive
exists
and
if
it
does
,
get
the
pathname
to
it
.
#
my
$
directory
;
if
(
GetArchiveDirectory
($
archive_idx
,
\$
directory
)
<
0
)
{
print
STDERR
"ArchiveDestroy: "
.
"Archive '$archive_idx' does not exist in the DB!
\n
"
;
return
-
1
;
}
if
(
! -d $directory || ! -w $directory) {
print
STDERR
"ArchiveDestroy: $directory does not exist!
\n
"
;
return
0
;
}
mysystem
(
"/bin/rm -rf $directory"
);
if
($?)
{
print
STDERR
"ArchiveDestroy: "
.
"Could not remove contents of $directory!
\n
"
;
return
-
1
;
}
if
(
defined
($
clean
)
&&
$
clean
)
{
(
DBQueryWarn
(
"delete from archive_tags "
.
"where archive_idx='$archive_idx'"
)
&&
DBQueryWarn
(
"delete from file_archives "
.
"where idx='$archive_idx'"
))
||
return
-
1
;
}
return
0
;
}
#
#
Get
the
directory
for
an
archive
,
given
its
index
.
Returns
-
1
on
error
,
#
zero
otherwise
.
#
sub
GetArchiveDirectory
($$)
{
my
($
idx
,
$
rvalp
)
=
@
_
;
my
$
query_result
=
DBQueryWarn
(
"select directory from file_archives where idx='$idx'"
);
return
-
1
if
(
!$query_result || !$query_result->numrows);
my
($
dir
)
=
$
query_result
->
fetchrow_array
();
$$
rvalp
=
$
dir
if
(
defined
($
rvalp
));
return
0
;
}
#
#
Get
the
current
tag
for
an
archive
,
given
its
index
.
Returns
-
1
on
error
,
#
zero
otherwise
.
Place
tag
in
the
return
pointer
.
#
sub
GetArchiveCurrentTag
($$)
{
my
($
archive_idx
,
$
rvalp
)
=
@
_
;
my
$
query_result
=
DBQueryWarn
(
"select current_tag from file_archives "
.
"where idx='$archive_idx'"
);
return
-
1
if
(
!$query_result);
my
($
tag
)
=
$
query_result
->
fetchrow_array
();
$$
rvalp
=
$
tag
if
(
defined
($
rvalp
));
return
0
;
}
#
#
Get
the
archive
index
for
an
experiment
.
The
index
is
kept
in
the
historical
#
experiment_stats
table
,
not
the
current
experiments
table
.
That
is
cause
#
we
keep
the
archive
and
its
DB
info
around
forever
with
the
stats
.
#
sub
TBExperimentArchiveIDX
($$)
{
my
($
pid
,
$
eid
)
=
@
_
;
my
$
query_result
=
DBQueryWarn
(
"select s.archive_idx from experiments as e "
.
"left join experiment_stats as s on s.exptidx=e.idx "
.
"where e.pid='$pid' and e.eid='$eid'"
);
return
-
1
if
(
!$query_result || $query_result->numrows == 0);
my
($
idx
)
=
$
query_result
->
fetchrow_array
();
return
-
1
if
(
!defined($idx));
return
$
idx
;
}
#
#
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
)
=
@
_
;
#
#
Create
the
new
archive
and
get
back
the
new
index
.
#
my
$
archive_idx
=
ArchiveCreate
();
return
-
1
if
($
archive_idx
<
0
);
#
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) {
ArchiveDestroy
($
archive_idx
,
1
);
return
-
1
;
}
my
($
exptidx
,$
rsrcidx
)
=
$
query_result
->
fetchrow_array
();
if
(
! (DBQueryWarn("update experiment_stats set ".
" archive_idx='$archive_idx' "
.
"where pid='$pid' and eid='$eid' and "
.
" exptidx='$exptidx'"
)
&&
DBQueryWarn
(
"update experiment_resources set "
.
" archive_tag='$inittag' "
.
"where idx='$rsrcidx'"
)))
{
ArchiveDestroy
($
archive_idx
,
1
);
return
-
1
;
}
return
0
;
}
#
#
Add
a
file
to
an
experiment
archive
.
#
sub
TBExperimentArchiveAddFile
($$$)
{
my
($
pid
,
$
eid
,
$
pathname
)
=
@
_
;
my
$
archive_idx
=
TBExperimentArchiveIDX
($
pid
,
$
eid
);
return
-
1
if
($
archive_idx
<
0
);
return
ArchiveAdd
($
archive_idx
,
$
pathname
);
}
#
#
Commit
an
experiment
archive
.
#
sub
TBExperimentArchiveCommit
($$)
{
my
($
pid
,
$
eid
)
=
@
_
;
my
$
archive_idx
=
TBExperimentArchiveIDX
($
pid
,
$
eid
);
return
-
1
if
($
archive_idx
<
0
);
#
#
Derive
a
tag
that
indicates
what
experiment
resource
entry
it
came
from
.
#
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
();
my
$
newtag
=
"T$rsrcidx"
;
return
ArchiveCommit
($
archive_idx
,
$
newtag
);
}
#
#
Delete
an
experiment
archive
.
This
just
deletes
it
from
the
active
area
.
#
Its
historical
DB
state
is
retained
.
#
sub
TBDeleteExperimentArchive
($$)
{
my
($
pid
,
$
eid
)
=
@
_
;
my
$
archive_idx
=
TBExperimentArchiveIDX
($
pid
,
$
eid
);
return
0
if
($
archive_idx
<
0
);
return
ArchiveDestroy
($
archive_idx
,
0
);