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 qw( 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 ($run_success_cb, $run_fail_cb, $load_next);
 135
 136     # search manually, starting with "current" and proceeding through nslots-1
 137     # loads of "next"
 138
 139     # TODO: support the case where nslots == -1
 140
 141     $run_success_cb = sub {
 142         my ($slot, $rest) = @_;
 143
 144         my $device = Amanda::Device->new($rest);
 145         if ($device and $device->configure(1)
 146                     and $device->read_label() == $DEVICE_STATUS_SUCCESS
 147                     and $device->volume_label() eq $params{'label'}) {
 148             # we found the correct slot
 149             my $res = Amanda::Changer::compat::Reservation->new($self, $slot, $rest);
 150             Amanda::MainLoop::call_later($params{'res_cb'}, undef, $res);
 151             return;
 152         }
 153
 154         $load_next->();
 155     };
 156
 157     $run_fail_cb = sub {
 158         my ($exitval, $message) = @_;
 159
 160         # don't continue scanning after a fatal error
 161         if ($exitval > 1) {
 162             Amanda::MainLoop::call_later($params{'res_cb'}, $message, undef);
 163             return;
 164         }
 165
 166         $load_next->();
 167     };
 168
 169     $load_next = sub {
 170         # if we've scanned all nslots, we haven't found the label.
 171         if (++$nchecked >= $self->{'nslots'}) {
 172             Amanda::MainLoop::call_later($params{'res_cb'},
 173                     "Volume '$params{label}' not found", undef);
 174             return;
 175         }
 176
 177         $self->_run_tpchanger($run_success_cb, $run_fail_cb, "-slot", "next");
 178     };
 179
 180     $self->_run_tpchanger($run_success_cb, $run_fail_cb, "-slot", "current");
 181 }
 182
 183 sub info {
 184     my $self = shift;
 185     my %params = @_;
 186     my %results;
 187
 188     die "no info_cb supplied" unless (exists $params{'info_cb'});
 189     die "no info supplied" unless (exists $params{'info'});
 190
 191     # make sure the info is loaded, and re-call info() if we have to wait
 192     if (!defined($self->{'nslots'}) && grep(/^num_slots$/, @{$params{'info'}})) {
 193         $self->_get_info(
 194             sub {
 195                 my ($err) = @_;
 196                 $self->info(%params);
 197             },
 198             sub {
 199                 my ($msg) = @_;
 200                 $params{'info_cb'}->($msg);
 201             });
 202         return;
 203     }
 204
 205     # ok, info is loaded, so call back with the results
 206     for my $inf (@{$params{'info'}}) {
 207         if ($inf eq 'num_slots') {
 208             $results{$inf} = $self->{'nslots'};
 209         } else {
 210             warn "Ignoring request for info key '$inf'";
 211         }
 212     }
 213
 214     Amanda::MainLoop::call_later($params{'info_cb'}, undef, %results);
 215 }
 216
 217 # run a simple op -- no arguments, no slot returned
 218 sub _simple_op {
 219     my $self = shift;
 220     my $op = shift;
 221     my %params = @_;
 222
 223     Amanda::Debug::debug("running simple op '$op'");
 224     my $run_success_cb = sub {
 225         Amanda::Debug::debug("simple op '$op' ok");
 226         if (exists $params{'finished_cb'}) {
 227             $params{'finished_cb'}->(undef);
 228         }
 229     };
 230     my $run_fail_cb = sub {
 231         my ($exitval, $message) = @_;
 232         Amanda::Debug::debug("simple op '$op' failed: $message");
 233         if (exists $params{'finished_cb'}) {
 234             $params{'finished_cb'}->($message);
 235         }
 236     };
 237     $self->_run_tpchanger($run_success_cb, $run_fail_cb, "-$op");
 238 }
 239
 240 sub reset {
 241     my $self = shift;
 242     my %params = @_;
 243
 244     $self->_simple_op("reset", %params);
 245 }
 246
 247 sub clean {
 248     my $self = shift;
 249     my %params = @_;
 250
 251     # note: parameter 'drive' is ignored
 252     $self->_simple_op("clean", %params);
 253 }
 254
 255 sub eject {
 256     my $self = shift;
 257     my %params = @_;
 258
 259     # note: parameter 'drive' is ignored
 260     $self->_simple_op("eject", %params);
 261 }
 262
 263 sub update {
 264     my $self = shift;
 265     my %params = @_;
 266
 267     # TODO: not implemented
 268     # -- need to shuffle the driver over every slot
 269     if (exists $params{'finished_cb'}) {
 270         $params{'finished_cb'}->(undef);
 271     }
 272 }
 273
 274 # Internal function to call the script's -info, store the results in $self, and
 275 # call either $success_cb (with no arguments) or $error_cb (with an error
 276 # message).
 277 sub _get_info {
 278     my ($self, $success_cb, $error_cb) = @_;
 279
 280     my $run_success_cb = sub {
 281         my ($slot, $rest) = @_;
 282         # old, unsearchable changers don't return the third result, so it's
 283         # optional in the regex
 284         $rest =~ /(\d+) (\d+) ?(\d+)?/ or
 285             croak("Malformed response from changer -info: $rest");
 286
 287         $self->{'nslots'} = $1;
 288         $self->{'backward'} = $2;
 289         $self->{'searchable'} = $3? 1:0;
 290
 291         $success_cb->();
 292     };
 293     my $run_fail_cb = sub {
 294         my ($exitval, $message) = @_;
 295         $error_cb->($message);
 296     };
 297     $self->_run_tpchanger($run_success_cb, $run_fail_cb, "-info");
 298 }
 299
 300 # Internal function to create a temporary configuration directory, which persists
 301 # for the duration of this changer's lifetime (and beyond, TODO)
 302 sub _make_cfg_dir {
 303     my ($self, $cc) = @_;
 304
 305     if (defined $cc) {
 306         my $cfg_name = Amanda::Config::get_config_name();
 307         my $changer_name = changer_config_name($cc);
 308         my $tapedev = changer_config_getconf($cc, $CHANGER_CONFIG_TAPEDEV);
 309         my $tpchanger = changer_config_getconf($cc, $CHANGER_CONFIG_TPCHANGER);
 310         my $changerdev = changer_config_getconf($cc, $CHANGER_CONFIG_CHANGERDEV);
 311         my $changerfile = changer_config_getconf($cc, $CHANGER_CONFIG_CHANGERFILE);
 312
 313         my $cfg_dir = "$AMANDA_TMPDIR/Amanda::Changer::compat/$cfg_name-$changer_name";
 314
 315         if (-d $cfg_dir) {
 316             rmtree($cfg_dir)
 317                 or die("Could not delete '$cfg_dir'");
 318         }
 319
 320         mkpath($cfg_dir)
 321             or die("Could not create '$cfg_dir'");
 322
 323         # Write an amanda.conf
 324         open(my $amconf, ">", "$cfg_dir/amanda.conf")
 325             or die ("Could not write '$cfg_dir/amanda.conf'");
 326
 327         print $amconf "# automatically generated by Amanda::Changer::compat\n";
 328         print $amconf 'org "', getconf($CNF_ORG), "\"\n"
 329             if getconf_seen($CNF_ORG);
 330         print $amconf 'mailto "', getconf($CNF_MAILTO), "\"\n"
 331             if getconf_seen($CNF_MAILTO);
 332         print $amconf 'mailer "', getconf($CNF_MAILER), "\"\n"
 333             if getconf_seen($CNF_MAILER);
 334         print $amconf "tapedev \"$tapedev\"\n"
 335             if defined($tapedev);
 336         print $amconf "tpchanger \"$tpchanger\"\n"
 337             if defined($tpchanger);
 338         print $amconf "changerdev \"$changerdev\"\n"
 339             if defined($changerdev);
 340         print $amconf "changerfile \"",
 341                 Amanda::Config::config_dir_relative($changerfile),
 342                 "\"\n"
 343             if defined($changerfile);
 344
 345         # TODO: device_property, tapetype, and the tapetype def
 346
 347         close $amconf;
 348
 349         $self->{'cfg_dir'} = $cfg_dir;
 350     } else {
 351         # for the default changer, we don't need to invent a config..
 352         $self->{'cfg_dir'} = Amanda::Config::get_config_dir();
 353     }
 354
 355 }
 356
 357 # Internal-use function to actually invoke a changer script and parse
 358 # its output.
 359 #
 360 # @param $success_cb: called with ($slot, $rest) on success
 361 # @param $failure_cb: called with ($exitval, $message) on any failure
 362 # @params @args: command-line arguments to follow the name of the changer
 363 # @returns: array ($error, $slot, $rest), where $error is an error message if
 364 #       a benign error occurred, or 0 if no error occurred
 365 sub _run_tpchanger {
 366     my ($self, $success_cb, $failure_cb, @args) = @_;
 367
 368     if ($self->{'busy'}) {
 369         croak("Changer is already in use");
 370     }
 371
 372     my ($readfd, $writefd) = POSIX::pipe();
 373     if (!defined($writefd)) {
 374         croak("Error creating pipe to run changer script: $!");
 375     }
 376
 377     my $pid = fork();
 378     if (!defined($pid) or $pid < 0) {
 379         croak("Can't fork to run changer script: $!");
 380     }
 381
 382     if (!$pid) {
 383         ## child
 384
 385         # get our file-handle house in order
 386         POSIX::close($readfd);
 387         POSIX::dup2($writefd, 1);
 388         POSIX::close($writefd);
 389
 390         # cd into the config dir
 391         if (!chdir($self->{'cfg_dir'})) {
 392             print "<error> Could not chdir to '" . $self->{cfg_dir} . "'\n";
 393             exit(2);
 394         }
 395
 396         %ENV = Amanda::Util::safe_env();
 397
 398         my $script = $self->{'script'};
 399         unless (-x $script) {
 400             $script = "$amlibexecdir/$script";
 401         }
 402         { exec { $script } $script, @args; } # braces protect against warning
 403
 404         my $err = "<error> Could not exec $script: $!\n";
 405         POSIX::write($writefd, $err, length($err));
 406         exit 2;
 407     }
 408
 409     ## parent
 410
 411     # clean up file descriptors from the fork
 412     POSIX::close($writefd);
 413
 414     # mark this object as "busy", so we can't begin another operation
 415     # until this one is finished.
 416     $self->{'busy'} = 1;
 417
 418     # the callbacks that follow share these lexical variables
 419     my $child_eof = 0;
 420     my $child_output = '';
 421     my $child_dead = 0;
 422     my $child_exit_status = 0;
 423     my ($fdsrc, $cwsrc);
 424     my ($maybe_finished, $fd_source_cb, $child_watch_source_cb);
 425
 426     # Perl note: we have to use anonymous subs here, as they are instantiated
 427     # at runtime, rather than at compile time.
 428
 429     $maybe_finished = sub {
 430         return unless $child_eof;
 431         return unless $child_dead;
 432
 433         # everything is finished -- process the results and invoke the callback
 434         chomp $child_output;
 435
 436         # mark this object as no longer busy.  This frees the
 437         # object up to begin the next operation, which may happen
 438         # during the invocation of the callback
 439         $self->{'busy'} = 0;
 440
 441         # handle unexpected exit status as a fatal error
 442         if (!POSIX::WIFEXITED($child_exit_status) || POSIX::WEXITSTATUS($child_exit_status) > 2) {
 443             $failure_cb->(POSIX::WEXITSTATUS($child_exit_status),
 444                 "Fatal error from changer script: ".$child_output);
 445             return;
 446         }
 447
 448         # parse the child's output
 449         my @child_output = split '\n', $child_output;
 450         if (@child_output < 1) {
 451             $failure_cb->(2, "Malformed output from changer script -- no output");
 452             return;
 453         }
 454         if (@child_output > 1) {
 455             $failure_cb->(2, "Malformed output from changer script -- too many lines");
 456             return;
 457         }
 458         if ($child_output[0] !~ /\s*([^\s]+)(?:\s+(.+))?/) {
 459             $failure_cb->(2, "Malformed output from changer script: '$child_output[0]'");
 460             return;
 461         }
 462         my ($slot, $rest) = ($1, $2);
 463
 464         # let the callback take care of any further interpretation
 465         my $exitval = POSIX::WEXITSTATUS($child_exit_status);
 466         if ($exitval == 0) {
 467             $success_cb->($slot, $rest);
 468         } else {
 469             $failure_cb->($exitval, $rest);
 470         }
 471     };
 472
 473     $fd_source_cb = sub {
 474         my ($fdsrc) = @_;
 475         my ($len, $bytes);
 476         $len = POSIX::read($readfd, $bytes, 1024);
 477
 478         # if we got an EOF, shut things down.
 479         if ($len == 0) {
 480             $child_eof = 1;
 481             POSIX::close($readfd);
 482             $fdsrc->remove();
 483             $fdsrc = undef; # break a reference loop
 484             $maybe_finished->();
 485         } else {
 486             # otherwise, just keep the bytes
 487             $child_output .= $bytes;
 488         }
 489     };
 490     $fdsrc = Amanda::MainLoop::fd_source($readfd, $G_IO_IN | $G_IO_ERR | $G_IO_HUP);
 491     $fdsrc->set_callback($fd_source_cb);
 492
 493     $child_watch_source_cb = sub {
 494         my ($cwsrc, $got_pid, $got_status) = @_;
 495         $cwsrc->remove();
 496         $cwsrc = undef; # break a reference loop
 497         $child_dead = 1;
 498         $child_exit_status = $got_status;
 499
 500         $maybe_finished->();
 501     };
 502     $cwsrc = Amanda::MainLoop::child_watch_source($pid);
 503     $cwsrc->set_callback($child_watch_source_cb);
 504 }
 505
 506 package Amanda::Changer::compat::Reservation;
 507 use vars qw( @ISA );
 508 @ISA = qw( Amanda::Changer::Reservation );
 509
 510 use Amanda::Debug qw( :logging );
 511
 512 sub new {
 513     my $class = shift;
 514     my ($chg, $slot, $device_name) = @_;
 515     my $self = Amanda::Changer::Reservation::new($class);
 516
 517     $self->{'chg'} = $chg;
 518
 519     $self->{'device_name'} = $device_name;
 520     $self->{'this_slot'} = $slot;
 521     $self->{'next_slot'} = "next"; # clever, no?
 522
 523     # mark the changer as reserved
 524     $self->{'chg'}->{'reserved'} = $device_name;
 525
 526     return $self;
 527 }
 528
 529 sub do_release {
 530     my $self = shift;
 531     my %params = @_;
 532
 533     my $finished = sub {
 534         my ($msg) = @_;
 535
 536         $self->{'chg'}->{'reserved'} = 0;
 537
 538         if (exists $params{'finished_cb'}) {
 539             Amanda::MainLoop::call_later($params{'finished_cb'}, $msg);
 540         }
 541     };
 542
 543     if (exists $params{'eject'} && $params{'eject'}) {
 544         $self->{'chg'}->eject(finished_cb => $finished);
 545     } else {
 546         $finished->(undef);
 547     }
 548 }
 549
 550 sub set_label {
 551     my $self = shift;
 552     my %params = @_;
 553
 554     # non-searchable changers don't get -label, except that chg-zd-mtx needs
 555     # it to maintain its slotinfofile (this is a hack)
 556     if (!$self->{'chg'}->{'searchable'}
 557         && $self->{'chg'}->{'script'} !~ /chg-zd-mtx$/) {
 558         if (exists $params{'finished_cb'}) {
 559             Amanda::MainLoop::call_later($params{'finished_cb'}, undef);
 560         }
 561         return;
 562     }
 563
 564     my $run_success_cb = sub {
 565         if (exists $params{'finished_cb'}) {
 566             Amanda::MainLoop::call_later($params{'finished_cb'}, undef);
 567         }
 568     };
 569     my $run_fail_cb = sub {
 570         my ($exitval, $message) = @_;
 571         if (exists $params{'finished_cb'}) {
 572             Amanda::MainLoop::call_later($params{'finished_cb'}, $message);
 573         }
 574     };
 575     $self->{'chg'}->_run_tpchanger(
 576         $run_success_cb, $run_fail_cb, "-label", $params{'label'});
 577 }
 578
 579 1;