perl/Amanda/Tapelist.pm

# This file was automatically generated by SWIG (http://www.swig.org).
# Version 3.0.7
#
# Do not make changes to this file unless you know what you are doing--modify
# the SWIG interface file instead.

package Amanda::Tapelist;
use base qw(Exporter);
use base qw(DynaLoader);
package Amanda::Tapelistc;
bootstrap Amanda::Tapelist;
package Amanda::Tapelist;
@EXPORT = qw();

# ---------- BASE METHODS -------------

package Amanda::Tapelist;

sub TIEHASH {
    my ($classname,$obj) = @_;
    return bless $obj, $classname;
}

sub CLEAR { }

sub FIRSTKEY { }

sub NEXTKEY { }

sub FETCH {
    my ($self,$field) = @_;
    my $member_func = "swig_${field}_get";
    $self->$member_func();
}

sub STORE {
    my ($self,$field,$newval) = @_;
    my $member_func = "swig_${field}_set";
    $self->$member_func($newval);
}

sub this {
    my $ptr = shift;
    return tied(%$ptr);
}


# ------- FUNCTION WRAPPERS --------

package Amanda::Tapelist;

*get_last_reusable_tape_label = *Amanda::Tapelistc::get_last_reusable_tape_label;
*list_new_tapes = *Amanda::Tapelistc::list_new_tapes;
*C_read_tapelist = *Amanda::Tapelistc::C_read_tapelist;
*C_clear_tapelist = *Amanda::Tapelistc::C_clear_tapelist;

# ------- VARIABLE STUBS --------

package Amanda::Tapelist;


@EXPORT_OK = ();
%EXPORT_TAGS = ();


=head1 NAME

Amanda::Tapelist - manipulate the Amanda tapelist

=head1 SYNOPSIS

    use Amanda::Tapelist;

    # to get a read only copy of the tapelist file:
    my $tl = Amanda::Tapelist->new("/path/to/tapefile");

    # to read/update/write the tapelist file
    # read and take lock
    my $tl = Amanda::Tapelist->new("/path/to/tapefile", 1);
    # modify the memory copy
    $tl->add_tapelabel($datestamp, $label);
    $tl->add_tapelabel($datestamp2, $label2, $comment, 1);
    # write it and unlock
    $tl->write();

    # If you already have a read only copy and want to modify it
    # take a read only copy
    my $tl = Amanda::Tapelist->new("/path/to/tapefile");
    # reload and take lock
    $tl->reload(1);
    # modify the memory copy
    tl->add_tapelabel($datestamp, $label);
    $tl->add_tapelabel($datestamp2, $label2, $comment, 1);
    # write it and unlock
    $tl->write();

=head1 OBJECT-ORIENTED INTERFACE

C<new> returns a hash with no C<tles> set if the tapelist does
not exist. C<tles> is an empty array if the tapelist is empty.
Invalid entries are silently ignored.

=head2 tapelist object

A tapelist object is a hash with the following keys:

=over

=item C<filename>

  The filename of the tapelist file.

=item C<filename_lock>

  The filename of the lock file.

=item C<fl>

  A Amanda::Util::file_lock is the file is locked.

=item C<tles>

A sequence of tapelist elements (referred to as TLEs in this document),
sorted by datestamp from newest to oldest.

=back

=head2 tapelist element

A tapelist elementas a hash with the following keys:

=over

=item C<position>

the one-based position of the TLE in the tapelist

=item C<datestamp>

the datestamp on which this was written, or "0" for an unused tape

=item C<reuse>

true if this tape can be reused when it is no longer active

=item C<label>

tape label

=item C<comment>

the comment for this tape, or undef if no comment was given

=back

=head1 Method

The following methods are available on a tapelist object C<$tl>:

=over

=item C<relod($lock)>

reload the tapelist file, lock it if $lock is set

=item C<lookup_tapelabel($lbl)>

look up and return a reference to the TLE with the given label

=item C<lookup_tapepos($pos)>

look up and return a reference to the TLE in the given position

=item C<lookup_tapedate($date)>

look up and return a reference to the TLE with the given datestamp

=item C<remove_tapelabel($lbl)>

remove the tape with the given label

=item C<add_tapelabel($date, $lbl, $comment, $reuse)>

add a tape with the given date, label, comment and reuse to the end of the
tapelist. reuse can be 1 or undef for a reusable volume, it must be 0 for
a no-reusable volume.

=item C<write()> or C<write($filename)>

write the tapelist out to the same file as when read or to C<$filename> if it
is set, remove the lock if a lock was taken

=item C<unlock()>

remove the lock if a lock was taken

=item C<clear_tapelist()>

remove all tle from the tles.

=back

=head1 INTERACTION WITH C CODE

The C portions of Amanda treat the tapelist as a global variable,
while this package treats it as an object (and can thus handle more
than one tapelist simultaneously).  Every call to C<reload>
fills this global variable with a copy of the tapelist, and likewise
C<clear_tapelist> clears the global.  However, any changes made from
Perl are not reflected in the C copy, nor are changes made by C
modules reflected in the Perl copy.

=cut


use Amanda::Debug qw(:logging);
use Amanda::Config qw( config_dir_relative );
use File::Copy;
use Fcntl qw(:flock); # import LOCK_* constants

## package functions

sub new {
    my ($class)  = shift;
    my ($filename, $lock ) = @_;
    my $self = {
	filename => $filename,
	lockname => $filename . '.lock',
    };
    bless $self, $class;

    $self->reload($lock);
    return $self;
}

sub clear_tapelist {
    my $self = shift;

    # clear the C version
    C_clear_tapelist();

    $self->{'tles'} = [];

    return $self;
}

## methods

sub reload {
    my $self = shift;
    my ($lock) = @_;

    if ($lock) {
	$self->_take_lock();
    }

    # clear the C copy
    C_clear_tapelist();

    # let C read the file
    C_read_tapelist($self->{'filename'});

    $self->_read_tapelist();
}

sub lookup_tapelabel {
    my $self = shift;
    my ($label) = @_;

    for my $tle (@{$self->{'tles'}}) {
	return $tle if ($tle->{'label'} eq $label);
    }

    return undef;
}

sub lookup_by_barcode {
    my $self = shift;
    my ($barcode) = @_;

    for my $tle (@{$self->{'tles'}}) {
	return $tle if (defined $tle->{'barcode'} and
			$tle->{'barcode'} eq $barcode);
    }

    return undef;
}

sub lookup_tapepos {
    my $self = shift;
    my ($position) = @_;

    $self->_update_positions();
    return $self->{'tles'}->[$position-1];
}

sub lookup_tapedate {
    my $self = shift;
    my ($datestamp) = @_;

    for my $tle (@{$self->{'tles'}}) {
	return $tle if ($tle->{'datestamp'} eq $datestamp);
    }

    return undef;
}

sub remove_tapelabel {
    my $self = shift;
    my ($label) = @_;

    for (my $i = 0; $i < @{$self->{tles}}; $i++) {
	if ($self->{tles}->[$i]->{'label'} eq $label) {
	    splice @{$self->{tles}}, $i, 1;
	    $self->_update_positions();
	    return;
	}
    }
}

sub add_tapelabel {
    my $self = shift;
    my ($datestamp, $label, $comment, $reuse, $meta, $barcode, $blocksize) = @_;
    $reuse = 1 if !defined $reuse;

    # prepend this (presumably new) volume to the beginning of the list
    my $tle = {
        'datestamp' => $datestamp,
        'label'     => $label,
        'reuse'     => $reuse,
        'barcode'   => $barcode,
        'meta'      => $meta,
        'blocksize' => $blocksize,
        'comment'   => $comment,
    };
    my $tles = $self->{'tles'};
    if (!defined $tles->[0] ||
	$tles->[0]->{'datestamp'} le $datestamp) {
	unshift @{$tles}, $tle;
    } elsif (defined $tles->[0] &&
	$tles->[@$tles-1]->{'datestamp'} gt $datestamp) {
	push @{$tles}, $tle;
    } else {
	my $added = 0;
	for my $i (0..(@$tles-1)) {
	    if ($tles->[$i]->{'datestamp'} le $datestamp) {
		splice @{$tles}, $i, 0, $tle;
		$added = 1;
		last;
	    }
	}
	push @{$tles}, $tle if !$added;
    }
    $self->_update_positions();
}

sub write {
    my $self = shift;
    my ($filename) = @_;
    my $result = TRUE;
    $filename = $self->{'filename'} if !defined $filename;

    my $new_tapelist_file = $filename . "-new-" . time();

    open(my $fhn, ">", $new_tapelist_file) or die("Could not open '$new_tapelist_file' for writing: $!");
    for my $tle (@{$self->{tles}}) {
	my $datestamp = $tle->{'datestamp'};
	my $label = $tle->{'label'};
	my $reuse = $tle->{'reuse'} ? 'reuse' : 'no-reuse';
	my $barcode = (defined $tle->{'barcode'})? (" BARCODE:" . $tle->{'barcode'}) : '';
	my $meta = (defined $tle->{'meta'})? (" META:" . $tle->{'meta'}) : '';
	my $blocksize = (defined $tle->{'blocksize'})? (" BLOCKSIZE:" . $tle->{'blocksize'}) : '';
	my $comment = (defined $tle->{'comment'})? (" #" . $tle->{'comment'}) : '';
	$result &&= print $fhn "$datestamp $label $reuse$barcode$meta$blocksize$comment\n";
    }
    my $result_close = close($fhn);
    $result &&= $result_close;

    return if (!$result);

    unless (move($new_tapelist_file, $filename)) {
	die ("failed to rename '$new_tapelist_file' to '$filename': $!");
    }

    # re-read from the C side to synchronize
    C_read_tapelist($filename);

    $self->unlock();

    return undef;
}

sub unlock {
    my $self = shift;

    return if !exists $self->{'fl'};

    $self->{'fl'}->unlock();
    delete $self->{'fl'}
}

## private methods

sub _take_lock {
    my $self = shift;

    if (!-e $self->{'lockname'}) {
	open(my $fhl, ">>", $self->{'lockname'});
	close($fhl);
    }
    my $fl = Amanda::Util::file_lock->new($self->{'lockname'});
    while(($r = $fl->lock()) == 1) {
	sleep(1);
    }
    if ($r == 0) {
	$self->{'fl'} = $fl;
    }
}

sub _read_tapelist {
    my $self = shift;

    my @tles;
    open(my $fh, "<", $self->{'filename'}) or return $self;
    while (my $line = <$fh>) {
	my ($datestamp, $label, $reuse, $barcode, $meta, $blocksize, $comment)
	    = $line =~ m/^([0-9]+)\s*([^\s]*)\s*(?:(reuse|no-reuse))?\s*(?:BARCODE:([^\s]*))?\s*(?:META:([^\s]*))?\s*(?:BLOCKSIZE:([^\s]*))?\s*(?:\#(.*))?$/mx;
	if (!defined $datestamp) {
	    Amanda::Debug::critical("Bogus line in the tapelist ($self->{'filename'}) file: $line");
	}
	push @tles, {
	    'datestamp' => $datestamp,
	    'label' => $label,
	    'reuse' => (!defined $reuse || $reuse eq 'reuse'),
	    'barcode' => $barcode,
	    'meta' => $meta,
	    'blocksize' => $blocksize,
	    'comment' => $comment,
	};
    }
    close($fh);

    # sort in descending order by datestamp, sorting on position, too, to ensure
    # that entries with the same datestamp stay in the right order
    $self->{'tles'} = \@tles;
    $self->_update_positions();
    @tles = sort {
	   $b->{'datestamp'} cmp $a->{'datestamp'}
	|| $a->{'position'} <=> $b->{'position'}
	} @tles;

    $self->{'tles'} = \@tles;

    # and re-calculate the positions
    $self->_update_positions(\@tles);

    # check for duplicate labels
    my %labels;
    for my $tle (@{$self->{'tles'}}) {
	my $label = $tle->{'label'};
	if (exists $labels{$label}) {
	    debug("Duplicate label '$label' in tapelist file.");
	    die("ERROR: Duplicate label '$label' in tapelist file.");
	}
	$labels{$label} = 1;
    }
}

# update the 'position' key for each TLE
sub _update_positions {
    my $self = shift;
    my $tles = $self->{'tles'};
    for (my $i = 0; $i < scalar @$tles; $i++) {
	$tles->[$i]->{'position'} = $i+1;
    }
}

1;