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

   1 # Copyright (c) 2005-2008 Zmanda, Inc.  All Rights Reserved.
   2 #
   3 # This library is free software; you can redistribute it and/or modify it
   4 # under the terms of the GNU Lesser General Public License version 2.1 as
   5 # published by the Free Software Foundation.
   6 #
   7 # This library is distributed in the hope that it will be useful, but
   8 # WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
   9 # or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Lesser General Public
  10 # License for more details.
  11 #
  12 # You should have received a copy of the GNU Lesser General Public License
  13 # along with this library; if not, write to the Free Software Foundation,
  14 # Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307 USA.
  15 #
  16 # Contact information: Zmanda Inc., 465 S Mathlida Ave, Suite 300
  17 # Sunnyvale, CA 94086, USA, or: http://www.zmanda.com
  18
  19 package Amanda::Changer::compat;
  20
  21 use strict;
  22 use warnings;
  23 use vars qw( @ISA );
  24 @ISA = qw( Amanda::Changer );
  25
  26 use Carp;
  27 use File::Glob qw( :glob );
  28 use File::Path;
  29 use Amanda::Paths;
  30 use Amanda::MainLoop qw( :GIOCondition );
  31 use Amanda::Config qw( :getconf );
  32 use Amanda::Debug;
  33 use Amanda::Device qw( :constants );
  34 use Amanda::Changer;
  35
  36 =head1 NAME
  37
  38 Amanda::Changer::compat -- run "old" changer scripts
  39
  40 =head1 DESCRIPTION
  41
  42 This package, calls through to old Changer API shell scripts using the new API.
  43 If necessary, this writes temporary configurations under C<$AMANDA_TMPDIR> and
  44 invokes the changer there, allowing multiple distinct changers to run within
  45 the same Amanda process.
  46
  47 =head1 TODO
  48
  49 In-process reservations are handled correctly - only one device may be used at
  50 a time.  However, the underlying scripts do not support reservations, so
  51 another application can easily run the script and change the current device.
  52 Caveat emptor.
  53
  54 Concurrent _run_tpchanger invocations are currently forbidden with a die() --
  55 that should change to a simple FIFO queue of tpchanger invocations to make.
  56
  57 Clean out old changer temporary directories on object destruction.
  58
  59 Support 'update'
  60
  61 =cut
  62
  63 sub new {
  64     my $class = shift;
  65     my ($cc, $tpchanger) = @_;
  66     my ($script) = ($tpchanger =~ /chg-compat:(.*)/);
  67
  68     my $self = {
  69         script => $script,
  70         reserved => 0,
  71         nslots => undef,
  72         backwards => undef,
  73         searchable => undef,
  74     };
  75     bless ($self, $class);
  76
  77     $self->_make_cfg_dir($cc);
  78
  79     return $self;
  80 }
  81
  82 sub load {
  83     my $self = shift;
  84     my %params = @_;
  85
  86     die "no callback supplied" unless (exists $params{'res_cb'});
  87     my $cb = $params{'res_cb'};
  88
  89     if ($self->{'reserved'}) {
  90         $cb->("Changer is already reserved: '" . $self->{'reserved'} . "'", undef);
  91         return;
  92     }
  93
  94     # make sure the info is loaded, and re-call load() if we have to wait
  95     if (!defined($self->{'nslots'})) {
  96         $self->_get_info(
  97             sub {
  98                 my ($err) = @_;
  99                 $self->load(%params);
 100             },
 101             sub {
 102                 my ($msg) = @_;
 103                 $cb->($msg, undef);
 104             });
 105         return;
 106     }
 107
 108     my $run_success_cb = sub {
 109         my ($slot, $rest) = @_;
 110         my $res = Amanda::Changer::compat::Reservation->new($self, $slot, $rest);
 111         $cb->(undef, $res);
 112     };
 113     my $run_fail_cb = sub {
 114         my ($exitval, $message) = @_;
 115         $cb->($message, undef);
 116     };
 117
 118     if (exists $params{'label'}) {
 119         if ($self->{'searchable'}) {
 120             $self->_run_tpchanger($run_success_cb, $run_fail_cb, "-search", $params{'label'});
 121         } else {
 122             # not searchable -- run a manual scan
 123             $self->_manual_scan(%params);
 124         }
 125     } elsif (exists $params{'slot'}) {
 126         $self->_run_tpchanger($run_success_cb, $run_fail_cb, "-slot", $params{'slot'});
 127     }
 128 }
 129
 130 sub _manual_scan {
 131     my $self = shift;
 132     my %params = @_;
 133     my $nchecked = 0;
 134     my $check_slot;
 135
 136     # search manually, starting with "current".  This is complicated, because
 137     # it's an event-based loop.
 138
 139     # TODO: support the case where nslots == -1
 140
 141     $check_slot = sub {
 142         my ($err, $res) = @_;
 143
 144         TRYSLOT: {
 145             # ignore "benign" errors
 146             next TRYSLOT if $err;
 147
 148             my $device = Amanda::Device->new($res->{'device_name'});
 149             next TRYSLOT unless $device;
 150             next TRYSLOT if ($device->read_label() != $DEVICE_STATUS_SUCCESS);
 151             next TRYSLOT unless ($device->volume_label() eq $params{'label'});
 152
 153             # we found the correct slot
 154             Amanda::MainLoop::call_later($params{'res_cb'}, undef, $res);
 155             return;
 156         }
 157
 158         # on to the next slot
 159         if (++$nchecked >= $self->{'nslots'}) {
 160             Amanda::MainLoop::call_later($params{'res_cb'},
 161                     "Volume '$params{label}' not found", undef);
 162             return;
 163         } else {
 164             # loop again with the next slot
 165             $res->release(); # we know this completes immediately
 166             $self->load(slot => "next", res_cb => $check_slot);
 167         }
 168     };
 169
 170     # kick off the loop with the current slot
 171     $self->load(slot => "current", res_cb => $check_slot);
 172 }
 173
 174 sub info {
 175     my $self = shift;
 176     my %params = @_;
 177     my %results;
 178
 179     die "no info_cb supplied" unless (exists $params{'info_cb'});
 180     die "no info supplied" unless (exists $params{'info'});
 181
 182     # make sure the info is loaded, and re-call info() if we have to wait
 183     if (!defined($self->{'nslots'}) && grep(/^num_slots$/, @{$params{'info'}})) {
 184         $self->_get_info(
 185             sub {
 186                 my ($err) = @_;
 187                 $self->info(%params);
 188             },
 189             sub {
 190                 my ($msg) = @_;
 191                 $params{'info_cb'}->($msg);
 192             });
 193         return;
 194     }
 195
 196     # ok, info is loaded, so call back with the results
 197     for my $inf (@{$params{'info'}}) {
 198         if ($inf eq 'num_slots') {
 199             $results{$inf} = $self->{'nslots'};
 200         } else {
 201             warn "Ignoring request for info key '$inf'";
 202         }
 203     }
 204
 205     Amanda::MainLoop::call_later($params{'info_cb'}, undef, %results);
 206 }
 207
 208 # run a simple op -- no arguments, no slot returned
 209 sub _simple_op {
 210     my $self = shift;
 211     my $op = shift;
 212     my %params = @_;
 213
 214     my $run_success_cb = sub {
 215         if (exists $params{'finished_cb'}) {
 216             $params{'finished_cb'}->(undef);
 217         }
 218     };
 219     my $run_fail_cb = sub {
 220         my ($exitval, $message) = @_;
 221         if (exists $params{'finished_cb'}) {
 222             $params{'finished_cb'}->($message);
 223         }
 224     };
 225     $self->_run_tpchanger($run_success_cb, $run_fail_cb, "-$op");
 226 }
 227
 228 sub reset {
 229     my $self = shift;
 230     my %params = @_;
 231
 232     $self->_simple_op("reset", %params);
 233 }
 234
 235 sub clean {
 236     my $self = shift;
 237     my %params = @_;
 238
 239     # note: parameter 'drive' is ignored
 240     $self->_simple_op("clean", %params);
 241 }
 242
 243 sub update {
 244     my $self = shift;
 245     my %params = @_;
 246
 247     # TODO: not implemented
 248     # -- need to shuffle the driver over every slot
 249     if (exists $params{'finished_cb'}) {
 250         $params{'finished_cb'}->(undef);
 251     }
 252 }
 253
 254 # Internal function to call the script's -info, store the results in $self, and
 255 # call either $success_cb (with no arguments) or $error_cb (with an error
 256 # message).
 257 sub _get_info {
 258     my ($self, $success_cb, $error_cb) = @_;
 259
 260     my $run_success_cb = sub {
 261         my ($slot, $rest) = @_;
 262         # old, unsearchable changers don't return the third result, so it's
 263         # optional in the regex
 264         $rest =~ /(\d+) (\d+) ?(\d+)?/ or
 265             croak("Malformed response from changer -info: $rest");
 266
 267         $self->{'nslots'} = $1;
 268         $self->{'backward'} = $2;
 269         $self->{'searchable'} = $3? 1:0;
 270
 271         $success_cb->();
 272     };
 273     my $run_fail_cb = sub {
 274         my ($exitval, $message) = @_;
 275         $error_cb->($message);
 276     };
 277     $self->_run_tpchanger($run_success_cb, $run_fail_cb, "-info");
 278 }
 279
 280 # Internal function to create a temporary configuration directory, which persists
 281 # for the duration of this changer's lifetime (and beyond, TODO)
 282 sub _make_cfg_dir {
 283     my ($self, $cc) = @_;
 284
 285     if (defined $cc) {
 286         my $cfg_name = Amanda::Config::get_config_name();
 287         my $changer_name = changer_config_name($cc);
 288         my $tapedev = changer_config_getconf($cc, $CHANGER_CONFIG_TAPEDEV);
 289         my $tpchanger = changer_config_getconf($cc, $CHANGER_CONFIG_TPCHANGER);
 290         my $changerdev = changer_config_getconf($cc, $CHANGER_CONFIG_CHANGERDEV);
 291         my $changerfile = changer_config_getconf($cc, $CHANGER_CONFIG_CHANGERFILE);
 292
 293         my $cfg_dir = "$AMANDA_TMPDIR/Amanda::Changer::compat/$cfg_name-$changer_name";
 294
 295         if (-d $cfg_dir) {
 296             rmtree($cfg_dir)
 297                 or die("Could not delete '$cfg_dir'");
 298         }
 299
 300         mkpath($cfg_dir)
 301             or die("Could not create '$cfg_dir'");
 302
 303         # Write an amanda.conf
 304         open(my $amconf, ">", "$cfg_dir/amanda.conf")
 305             or die ("Could not write '$cfg_dir/amanda.conf'");
 306
 307         print $amconf "# automatically generated by Amanda::Changer::compat\n";
 308         print $amconf 'org "', getconf($CNF_ORG), "\"\n"
 309             if getconf_seen($CNF_ORG);
 310         print $amconf 'mailto "', getconf($CNF_MAILTO), "\"\n"
 311             if getconf_seen($CNF_MAILTO);
 312         print $amconf 'mailer "', getconf($CNF_MAILER), "\"\n"
 313             if getconf_seen($CNF_MAILER);
 314         print $amconf "tapedev \"$tapedev\"\n"
 315             if defined($tapedev);
 316         print $amconf "tpchanger \"$tpchanger\"\n"
 317             if defined($tpchanger);
 318         print $amconf "changerdev \"$changerdev\"\n"
 319             if defined($changerdev);
 320         print $amconf "changerfile \"",
 321                 Amanda::Config::config_dir_relative($changerfile),
 322                 "\"\n"
 323             if defined($changerfile);
 324
 325         # TODO: device_property, tapetype, and the tapetype def
 326
 327         close $amconf;
 328
 329         $self->{'cfg_dir'} = $cfg_dir;
 330     } else {
 331         # for the default changer, we don't need to invent a config..
 332         $self->{'cfg_dir'} = Amanda::Config::get_config_dir();
 333     }
 334
 335 }
 336
 337 # Internal-use function to actually invoke a changer script and parse
 338 # its output.
 339 #
 340 # @param $success_cb: called with ($slot, $rest) on success
 341 # @param $failure_cb: called with ($exitval, $message) on any failure
 342 # @params @args: command-line arguments to follow the name of the changer
 343 # @returns: array ($error, $slot, $rest), where $error is an error message if
 344 #       a benign error occurred, or 0 if no error occurred
 345 sub _run_tpchanger {
 346     my ($self, $success_cb, $failure_cb, @args) = @_;
 347
 348     if ($self->{'busy'}) {
 349         croak("Changer is already in use");
 350     }
 351
 352     my ($readfd, $writefd) = POSIX::pipe();
 353     if (!defined($writefd)) {
 354         croak("Error creating pipe to run changer script: $!");
 355     }
 356
 357     my $pid = fork();
 358     if (!defined($pid) or $pid < 0) {
 359         croak("Can't fork to run changer script: $!");
 360     }
 361
 362     if (!$pid) {
 363         ## child
 364
 365         # get our file-handle house in order
 366         POSIX::close($readfd);
 367         POSIX::dup2($writefd, 1);
 368         POSIX::close($writefd);
 369
 370         # cd into the config dir
 371         if (!chdir($self->{'cfg_dir'})) {
 372             print "<error> Could not chdir to '" . $self->{cfg_dir} . "'\n";
 373             exit(2);
 374         }
 375
 376         %ENV = Amanda::Util::safe_env();
 377
 378         my $script = $self->{'script'};
 379         unless (-x $script) {
 380             $script = "$amlibexecdir/$script";
 381         }
 382         { exec { $script } $script, @args; } # braces protect against warning
 383
 384         my $err = "<error> Could not exec $script: $!\n";
 385         POSIX::write($writefd, $err, length($err));
 386         exit 2;
 387     }
 388
 389     ## parent
 390
 391     # clean up file descriptors from the fork
 392     POSIX::close($writefd);
 393
 394     # mark this object as "busy", so we can't begin another operation
 395     # until this one is finished.
 396     $self->{'busy'} = 1;
 397
 398     # the callbacks that follow share these lexical variables
 399     my $child_eof = 0;
 400     my $child_output = '';
 401     my $child_dead = 0;
 402     my $child_exit_status = 0;
 403     my ($fdsrc, $cwsrc);
 404     my ($maybe_finished, $fd_source_cb, $child_watch_source_cb);
 405
 406     # Perl note: we have to use anonymous subs here, as they are instantiated
 407     # at runtime, rather than at compile time.
 408
 409     $maybe_finished = sub {
 410         return unless $child_eof;
 411         return unless $child_dead;
 412
 413         # everything is finished -- process the results and invoke the callback
 414         chomp $child_output;
 415
 416         # handle fatal errors
 417         if (!POSIX::WIFEXITED($child_exit_status) || POSIX::WEXITSTATUS($child_exit_status) > 1) {
 418             $failure_cb->(POSIX::WEXITSTATUS($child_exit_status),
 419                 "Fatal error from changer script: ".$child_output);
 420             return;
 421         }
 422
 423         # parse the child's output
 424         my @child_output = split '\n', $child_output;
 425         $failure_cb->(2, "Malformed output from changer script -- no output")
 426             if (@child_output < 1);
 427         $failure_cb->(2, "Malformed output from changer script -- too many lines")
 428             if (@child_output > 1);
 429         $failure_cb->(2, "Malformed output from changer script: '$child_output[0]'")
 430             if ($child_output[0] !~ /\s*([^\s]+)(?:\s+(.+))?/);
 431         my ($slot, $rest) = ($1, $2);
 432
 433         # mark this object as no longer busy.  This frees the
 434         # object up to begin the next operation, which may happen
 435         # during the invocation of the callback
 436         $self->{'busy'} = 0;
 437
 438         # let the callback take care of any further interpretation
 439         my $exitval = POSIX::WEXITSTATUS($child_exit_status);
 440         if ($exitval == 0) {
 441             $success_cb->($slot, $rest);
 442         } else {
 443             $failure_cb->($exitval, $rest);
 444         }
 445     };
 446
 447     $fd_source_cb = sub {
 448         my ($fdsrc) = @_;
 449         my ($len, $bytes);
 450         $len = POSIX::read($readfd, $bytes, 1024);
 451
 452         # if we got an EOF, shut things down.
 453         if ($len == 0) {
 454             $child_eof = 1;
 455             POSIX::close($readfd);
 456             $fdsrc->remove();
 457             $fdsrc = undef; # break a reference loop
 458             $maybe_finished->();
 459         } else {
 460             # otherwise, just keep the bytes
 461             $child_output .= $bytes;
 462         }
 463     };
 464     $fdsrc = Amanda::MainLoop::fd_source($readfd, $G_IO_IN | $G_IO_ERR | $G_IO_HUP);
 465     $fdsrc->set_callback($fd_source_cb);
 466
 467     $child_watch_source_cb = sub {
 468         my ($cwsrc, $got_pid, $got_status) = @_;
 469         $cwsrc->remove();
 470         $cwsrc = undef; # break a reference loop
 471         $child_dead = 1;
 472         $child_exit_status = $got_status;
 473
 474         $maybe_finished->();
 475     };
 476     $cwsrc = Amanda::MainLoop::child_watch_source($pid);
 477     $cwsrc->set_callback($child_watch_source_cb);
 478 }
 479
 480 package Amanda::Changer::compat::Reservation;
 481 use vars qw( @ISA );
 482 @ISA = qw( Amanda::Changer::Reservation );
 483
 484 sub new {
 485     my $class = shift;
 486     my ($chg, $slot, $device_name) = @_;
 487     my $self = Amanda::Changer::Reservation::new($class);
 488
 489     $self->{'chg'} = $chg;
 490
 491     $self->{'device_name'} = $device_name;
 492     $self->{'this_slot'} = $slot;
 493     $self->{'next_slot'} = "next"; # clever, no?
 494
 495     # mark the changer as reserved
 496     $self->{'chg'}->{'reserved'} = $device_name;
 497
 498     return $self;
 499 }
 500
 501 sub do_release {
 502     my $self = shift;
 503     my %params = @_;
 504
 505     $self->{'chg'}->{'reserved'} = 0;
 506 }
 507
 508 sub set_label {
 509     my $self = shift;
 510     my %params = @_;
 511
 512     # non-searchable changers don't get -label, except that chg-zd-mtx needs
 513     # it to maintain its slotinfofile (this is a hack)
 514     if (!$self->{'chg'}->{'searchable'}
 515         && $self->{'chg'}->{'script'} !~ /chg-zd-mtx$/) {
 516         if (exists $params{'finished_cb'}) {
 517             Amanda::MainLoop::call_later($params{'finished_cb'}, undef);
 518         }
 519         return;
 520     }
 521
 522     my $run_success_cb = sub {
 523         if (exists $params{'finished_cb'}) {
 524             Amanda::MainLoop::call_later($params{'finished_cb'}, undef);
 525         }
 526     };
 527     my $run_fail_cb = sub {
 528         my ($exitval, $message) = @_;
 529         if (exists $params{'finished_cb'}) {
 530             Amanda::MainLoop::call_later($params{'finished_cb'}, $message);
 531         }
 532     };
 533     $self->{'chg'}->_run_tpchanger(
 534         $run_success_cb, $run_fail_cb, "-label", $params{'label'});
 535 }
 536
 537 1;