git.gag.com Git - debian/amanda/blob - perl/Amanda/Tapelist.pm

   1 # This file was automatically generated by SWIG (http://www.swig.org).
   2 # Version 1.3.39
   3 #
   4 # Do not make changes to this file unless you know what you are doing--modify
   5 # the SWIG interface file instead.
   6
   7 package Amanda::Tapelist;
   8 use base qw(Exporter);
   9 use base qw(DynaLoader);
  10 package Amanda::Tapelistc;
  11 bootstrap Amanda::Tapelist;
  12 package Amanda::Tapelist;
  13 @EXPORT = qw();
  14
  15 # ---------- BASE METHODS -------------
  16
  17 package Amanda::Tapelist;
  18
  19 sub TIEHASH {
  20     my ($classname,$obj) = @_;
  21     return bless $obj, $classname;
  22 }
  23
  24 sub CLEAR { }
  25
  26 sub FIRSTKEY { }
  27
  28 sub NEXTKEY { }
  29
  30 sub FETCH {
  31     my ($self,$field) = @_;
  32     my $member_func = "swig_${field}_get";
  33     $self->$member_func();
  34 }
  35
  36 sub STORE {
  37     my ($self,$field,$newval) = @_;
  38     my $member_func = "swig_${field}_set";
  39     $self->$member_func($newval);
  40 }
  41
  42 sub this {
  43     my $ptr = shift;
  44     return tied(%$ptr);
  45 }
  46
  47
  48 # ------- FUNCTION WRAPPERS --------
  49
  50 package Amanda::Tapelist;
  51
  52 *get_last_reusable_tape_label = *Amanda::Tapelistc::get_last_reusable_tape_label;
  53 *list_new_tapes = *Amanda::Tapelistc::list_new_tapes;
  54 *C_read_tapelist = *Amanda::Tapelistc::C_read_tapelist;
  55 *C_clear_tapelist = *Amanda::Tapelistc::C_clear_tapelist;
  56
  57 # ------- VARIABLE STUBS --------
  58
  59 package Amanda::Tapelist;
  60
  61
  62 @EXPORT_OK = ();
  63 %EXPORT_TAGS = ();
  64
  65
  66 =head1 NAME
  67
  68 Amanda::Tapelist - manipulate the Amanda tapelist
  69
  70 =head1 SYNOPSIS
  71
  72     use Amanda::Tapelist;
  73
  74     # to get a read only copy of the tapelist file:
  75     my $tl = Amanda::Tapelist->new("/path/to/tapefile");
  76
  77     # to read/update/write the tapelist file
  78     # read and take lock
  79     my $tl = Amanda::Tapelist->new("/path/to/tapefile", 1);
  80     # modify the memory copy
  81     $tl->add_tapelabel($datestamp, $label);
  82     $tl->add_tapelabel($datestamp2, $label2, $comment, 1);
  83     # write it and unlock
  84     $tl->write();
  85
  86     # If you already have a read only copy and want to modify it
  87     # take a read only copy
  88     my $tl = Amanda::Tapelist->new("/path/to/tapefile");
  89     # reload and take lock
  90     $tl->reload(1);
  91     # modify the memory copy
  92     tl->add_tapelabel($datestamp, $label);
  93     $tl->add_tapelabel($datestamp2, $label2, $comment, 1);
  94     # write it and unlock
  95     $tl->write();
  96
  97 =head1 OBJECT-ORIENTED INTERFACE
  98
  99 C<new> returns a hash with no C<tles> set if the tapelist does
 100 not exist. C<tles> is an empty array if the tapelist is empty.
 101 Invalid entries are silently ignored.
 102
 103 =head2 tapelist object
 104
 105 A tapelist object is a hash with the following keys:
 106
 107 =over
 108
 109 =item C<filename>
 110
 111   The filename of the tapelist file.
 112
 113 =item C<filename_lock>
 114
 115   The filename of the lock file.
 116
 117 =item C<fl>
 118
 119   A Amanda::Util::file_lock is the file is locked.
 120
 121 =item C<tles>
 122
 123 A sequence of tapelist elements (referred to as TLEs in this document),
 124 sorted by datestamp from newest to oldest.
 125
 126 =back
 127
 128 =head2 tapelist element
 129
 130 A tapelist elementas a hash with the following keys:
 131
 132 =over
 133
 134 =item C<position>
 135
 136 the one-based position of the TLE in the tapelist
 137
 138 =item C<datestamp>
 139
 140 the datestamp on which this was written, or "0" for an unused tape
 141
 142 =item C<reuse>
 143
 144 true if this tape can be reused when it is no longer active
 145
 146 =item C<label>
 147
 148 tape label
 149
 150 =item C<comment>
 151
 152 the comment for this tape, or undef if no comment was given
 153
 154 =back
 155
 156 =head1 Method
 157
 158 The following methods are available on a tapelist object C<$tl>:
 159
 160 =over
 161
 162 =item C<relod($lock)>
 163
 164 reload the tapelist file, lock it if $lock is set
 165
 166 =item C<lookup_tapelabel($lbl)>
 167
 168 look up and return a reference to the TLE with the given label
 169
 170 =item C<lookup_tapepos($pos)>
 171
 172 look up and return a reference to the TLE in the given position
 173
 174 =item C<lookup_tapedate($date)>
 175
 176 look up and return a reference to the TLE with the given datestamp
 177
 178 =item C<remove_tapelabel($lbl)>
 179
 180 remove the tape with the given label
 181
 182 =item C<add_tapelabel($date, $lbl, $comment, $reuse)>
 183
 184 add a tape with the given date, label, comment and reuse to the end of the
 185 tapelist. reuse can be 1 or undef for a reusable volume, it must be 0 for
 186 a no-reusable volume.
 187
 188 =item C<write()> or C<write($filename)>
 189
 190 write the tapelist out to the same file as when read or to C<$filename> if it
 191 is set, remove the lock if a lock was taken
 192
 193 =item C<unlock()>
 194
 195 remove the lock if a lock was taken
 196
 197 =item C<clear_tapelist()>
 198
 199 remove all tle from the tles.
 200
 201 =back
 202
 203 =head1 INTERACTION WITH C CODE
 204
 205 The C portions of Amanda treat the tapelist as a global variable,
 206 while this package treats it as an object (and can thus handle more
 207 than one tapelist simultaneously).  Every call to C<reload>
 208 fills this global variable with a copy of the tapelist, and likewise
 209 C<clear_tapelist> clears the global.  However, any changes made from
 210 Perl are not reflected in the C copy, nor are changes made by C
 211 modules reflected in the Perl copy.
 212
 213 =cut
 214
 215
 216
 217 use Amanda::Debug qw(:logging);
 218 use Amanda::Config qw( config_dir_relative );
 219 use File::Copy;
 220 use Fcntl qw(:flock); # import LOCK_* constants
 221
 222 ## package functions
 223
 224 sub new {
 225     my ($class)  = shift;
 226     my ($filename, $lock ) = @_;
 227     my $self = {
 228         filename => $filename,
 229         lockname => $filename . '.lock',
 230     };
 231     bless $self, $class;
 232
 233     $self->reload($lock);
 234     return $self;
 235 }
 236
 237 sub clear_tapelist {
 238     my $self = shift;
 239
 240     # clear the C version
 241     C_clear_tapelist();
 242
 243     $self->{'tles'} = [];
 244
 245     return $self;
 246 }
 247
 248 ## methods
 249
 250 sub reload {
 251     my $self = shift;
 252     my ($lock) = @_;
 253
 254     if ($lock) {
 255         $self->_take_lock();
 256     }
 257
 258     # clear the C copy
 259     C_clear_tapelist();
 260
 261     # let C read the file
 262     C_read_tapelist($self->{'filename'});
 263
 264     $self->_read_tapelist();
 265 }
 266
 267 sub lookup_tapelabel {
 268     my $self = shift;
 269     my ($label) = @_;
 270
 271     for my $tle (@{$self->{'tles'}}) {
 272         return $tle if ($tle->{'label'} eq $label);
 273     }
 274
 275     return undef;
 276 }
 277
 278 sub lookup_tapepos {
 279     my $self = shift;
 280     my ($position) = @_;
 281
 282     $self->_update_positions();
 283     return $self->{'tles'}->[$position-1];
 284 }
 285
 286 sub lookup_tapedate {
 287     my $self = shift;
 288     my ($datestamp) = @_;
 289
 290     for my $tle (@{$self->{'tles'}}) {
 291         return $tle if ($tle->{'datestamp'} eq $datestamp);
 292     }
 293
 294     return undef;
 295 }
 296
 297 sub remove_tapelabel {
 298     my $self = shift;
 299     my ($label) = @_;
 300
 301     for (my $i = 0; $i < @{$self->{tles}}; $i++) {
 302         if ($self->{tles}->[$i]->{'label'} eq $label) {
 303             splice @{$self->{tles}}, $i, 1;
 304             $self->_update_positions();
 305             return;
 306         }
 307     }
 308 }
 309
 310 sub add_tapelabel {
 311     my $self = shift;
 312     my ($datestamp, $label, $comment, $reuse, $meta, $barcode) = @_;
 313     $reuse = 1 if !defined $reuse;
 314
 315     # prepend this (presumably new) volume to the beginning of the list
 316     my $tle = {
 317         'datestamp' => $datestamp,
 318         'label'     => $label,
 319         'reuse'     => $reuse,
 320         'barcode'   => $barcode,
 321         'meta'      => $meta,
 322         'comment'   => $comment,
 323     };
 324     my $tles = $self->{'tles'};
 325     if (!defined $tles->[0] ||
 326         $tles->[0]->{'datestamp'} le $datestamp) {
 327         unshift @{$tles}, $tle;
 328     } elsif (defined $tles->[0] &&
 329         $tles->[@$tles-1]->{'datestamp'} gt $datestamp) {
 330         push @{$tles}, $tle;
 331     } else {
 332         my $added = 0;
 333         for my $i (0..(@$tles-1)) {
 334             if ($tles->[$i]->{'datestamp'} le $datestamp) {
 335                 splice @{$tles}, $i, 0, $tle;
 336                 $added = 1;
 337                 last;
 338             }
 339         }
 340         push @{$tles}, $tle if !$added;
 341     }
 342     $self->_update_positions();
 343 }
 344
 345 sub write {
 346     my $self = shift;
 347     my ($filename) = @_;
 348     my $result = TRUE;
 349     $filename = $self->{'filename'} if !defined $filename;
 350
 351     my $new_tapelist_file = $filename . "-new-" . time();
 352
 353     open(my $fhn, ">", $new_tapelist_file) or die("Could not open '$new_tapelist_file' for writing: $!");
 354     for my $tle (@{$self->{tles}}) {
 355         my $datestamp = $tle->{'datestamp'};
 356         my $label = $tle->{'label'};
 357         my $reuse = $tle->{'reuse'} ? 'reuse' : 'no-reuse';
 358         my $barcode = (defined $tle->{'barcode'})? (" BARCODE:" . $tle->{'barcode'}) : '';
 359         my $meta = (defined $tle->{'meta'})? (" META:" . $tle->{'meta'}) : '';
 360         my $comment = (defined $tle->{'comment'})? (" #" . $tle->{'comment'}) : '';
 361         $result &&= print $fhn "$datestamp $label $reuse$barcode$meta$comment\n";
 362     }
 363     my $result_close = close($fhn);
 364     $result &&= $result_close;
 365
 366     return if (!$result);
 367
 368     unless (move($new_tapelist_file, $filename)) {
 369         die ("failed to rename '$new_tapelist_file' to '$filename': $!");
 370     }
 371
 372     # re-read from the C side to synchronize
 373     C_read_tapelist($filename);
 374
 375     $self->unlock();
 376
 377     return undef;
 378 }
 379
 380 sub unlock {
 381     my $self = shift;
 382
 383     return if !exists $self->{'fl'};
 384
 385     $self->{'fl'}->unlock();
 386     delete $self->{'fl'}
 387 }
 388
 389 ## private methods
 390
 391 sub _take_lock {
 392     my $self = shift;
 393
 394     if (!-e $self->{'lockname'}) {
 395         open(my $fhl, ">>", $self->{'lockname'});
 396         close($fhl);
 397     }
 398     my $fl = Amanda::Util::file_lock->new($self->{'lockname'});
 399     while(($r = $fl->lock()) == 1) {
 400         sleep(1);
 401     }
 402     if ($r == 0) {
 403         $self->{'fl'} = $fl;
 404     }
 405 }
 406
 407 sub _read_tapelist {
 408     my $self = shift;
 409
 410     my @tles;
 411     open(my $fh, "<", $self->{'filename'}) or return $self;
 412     while (my $line = <$fh>) {
 413         my ($datestamp, $label, $reuse, $barcode, $meta, $comment)
 414             = $line =~ m/^([0-9]*)\s([^\s]*)\s(reuse|no-reuse)\s*(?:BARCODE:([^\s]*))?\s*(?:META:([^\s]*))?\s*(?:\#(.*))?$/mx;
 415         next if !defined $datestamp; # silently filter out bogus lines
 416         push @tles, {
 417             'datestamp' => $datestamp,
 418             'label' => $label,
 419             'reuse' => ($reuse eq 'reuse'),
 420             'barcode' => $barcode,
 421             'meta' => $meta,
 422             'comment' => $comment,
 423         };
 424     }
 425     close($fh);
 426
 427     # sort in descending order by datestamp, sorting on position, too, to ensure
 428     # that entries with the same datestamp stay in the right order
 429     $self->{'tles'} = \@tles;
 430     $self->_update_positions();
 431     @tles = sort {
 432            $b->{'datestamp'} cmp $a->{'datestamp'}
 433         || $a->{'position'} <=> $b->{'position'}
 434         } @tles;
 435
 436     $self->{'tles'} = \@tles;
 437
 438     # and re-calculate the positions
 439     $self->_update_positions(\@tles);
 440 }
 441
 442 # update the 'position' key for each TLE
 443 sub _update_positions {
 444     my $self = shift;
 445     my $tles = $self->{'tles'};
 446     for (my $i = 0; $i < scalar @$tles; $i++) {
 447         $tles->[$i]->{'position'} = $i+1;
 448     }
 449 }
 450
 451 1;