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

   1 # Copyright (c) 2009,2010 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. Mathilda Ave., Suite 300
  17 # Sunnyvale, CA 94086, USA, or: http://www.zmanda.com
  18
  19 package Amanda::Changer::robot;
  20
  21 use strict;
  22 use warnings;
  23 use Carp;
  24 use vars qw( @ISA );
  25 @ISA = qw( Amanda::Changer );
  26
  27 use Data::Dumper;
  28 use File::Path;
  29 use Amanda::Paths;
  30 use Amanda::MainLoop qw( :GIOCondition make_cb define_steps step );
  31 use Amanda::Config qw( :getconf );
  32 use Amanda::Debug qw( debug warning );
  33 use Amanda::Device qw( :constants );
  34 use Amanda::Changer;
  35 use Amanda::Constants;
  36
  37 =head1 NAME
  38
  39 Amanda::Changer::robot -- control a physical tape changer
  40
  41 =head1 DESCRIPTION
  42
  43 This package controls a physical tape changer via 'mtx'.
  44
  45 See the amanda-changers(7) manpage for usage information.
  46
  47 =cut
  48
  49 # NOTES
  50 #
  51 # This is one of the more sophisticated changers.  Here are some notes that may
  52 # help while reading the source code.
  53
  54 # STATE
  55 #
  56 # The device state is shared between all changers accessing the same library.
  57 # It is a hash with keys:
  58 #   slots - see below
  59 #   drives - see below
  60 #   drive_lru - recently used drives, least recent first
  61 #   bc2lb - hash mapping known barcodes to known labels
  62 #   current_slot - the current slot
  63 #   last_operation_time - time the last operation finished
  64 #   last_operation_delay - required delay for that operation
  65 #   last_status - last time a 'status' command finished
  66 #
  67 # The 'slots' key is a hash, with slot numbers as keys and hashes
  68 # as values.  Each slot's hash has keys
  69 #   state - SLOT_FULL/SLOT_EMPTY/SLOT_UNKNOWN
  70 #   device_status - the status of the device
  71 #   f_type - The f_type of the header
  72 #   label - volume label, if known
  73 #   barcode - volume barcode, if available
  74 #   loaded_in - drive this volume is loaded in
  75 #   ie - 1 if this is an import/export slot
  76 # note that this state pretends that a tape physically located
  77 # in a tape drive is still located in its original slot.
  78 #
  79 # The 'drives' key is also a hash by drive numbere, the values of
  80 # which are hashes with keys
  81 #   state - SLOT_FULL/SLOT_EMPTY/SLOT_UNKNOWN
  82 #   label - volume label
  83 #   barcode - volume barcode
  84 #   orig_slot - slot from which this tape was loaded
  85
  86 # LOCKING
  87 #
  88 # This package uses Amanda::Changer's with_locked_state to lock a statefile and
  89 # load its contents.  Every time the state is locked, the package also
  90 # considers running 'status' to update the state; the status_interval protects
  91 # against running status too often.
  92 #
  93 # Each changer method has an "_unlocked" version that does the actual work, and
  94 # is called with an additional 'state' parameter containing the locked state.
  95 # This is particularly useful when the load method calls the eject method to
  96 # empty a drive that it wants to use.
  97
  98 # RESERVATIONS
  99 #
 100 # Reservations are currently represented by a PID in the state file.  If that
 101 # pid is no longer running, then the reservation is considered stale and is
 102 # discarded (with a warning).
 103 #
 104 # Reservation objects defer most of the interesting operations back to the
 105 # changer itself, since the operations require locked access to the state.
 106
 107 # INTERFACE
 108 #
 109 # All of the operating-system-specific functionality is abstracted into the
 110 # Interface class.  This is written in such a way that it could be replaced
 111 # by a direct SCSI interface.
 112
 113 sub new {
 114     my $class = shift;
 115     my ($config, $tpchanger) = @_;
 116
 117     # strip the "chg-foo:" prefix from $tpchanger
 118     my $device_name = $tpchanger;
 119     $device_name =~ s/^[^:]*://;
 120
 121     # get the 'chg-foo' form of this changer script
 122     my $class_name = $class;
 123     $class_name =~ s/Amanda::Changer::/chg-/;
 124
 125     my $self = {
 126         interface => undef,
 127         device_name => $device_name,
 128         config => $config,
 129
 130         # set below from properties
 131         statefile => undef,
 132         drive2device => {}, # { drive => device name }
 133         driveorder => [], # order of tape-device properties
 134         drive_choice => 'lru',
 135         eject_before_unload => 0,
 136         fast_search => 1,
 137         use_slots => undef,
 138         status_interval => 2, # in seconds
 139         load_poll => [0, 2, 120], # delay, poll, until
 140         eject_delay => 0, # in seconds
 141         unload_delay => 0, # in seconds
 142         class_name => $class_name,
 143     };
 144     bless ($self, $class);
 145
 146     # handle some config and properties
 147     my $properties = $config->{'properties'};
 148
 149     if (defined $config->{'changerdev'} and $config->{'changerdev'} ne '') {
 150         return Amanda::Changer->make_error("fatal", undef,
 151             message => "'changerdev' is not allowed with $self->{class_name}");
 152     }
 153
 154     if ($config->{'changerfile'}) {
 155         $self->{'statefile'} = Amanda::Config::config_dir_relative($config->{'changerfile'});
 156     } else {
 157         my $safe_filename = "$self->{class_name}:$device_name";
 158         $safe_filename =~ tr/a-zA-Z0-9/-/cs;
 159         $safe_filename =~ s/^-*//;
 160         $self->{'statefile'} = "$localstatedir/amanda/$safe_filename";
 161     }
 162     $self->_debug("using statefile '$self->{statefile}'");
 163
 164     # figure out the drive number to device name mapping
 165     if (exists $config->{'tapedev'}
 166             and $config->{'tapedev'} ne ''
 167             and !exists $properties->{'tape-device'}) {
 168         # if the tapedev points to us (the changer), then give an error
 169         if ($config->{'tapedev'} eq $tpchanger) {
 170             return Amanda::Changer->make_error("fatal", undef,
 171                 message => "must specify a tape-device property");
 172         }
 173         $self->{'drive2device'} = { '0' => $config->{'tapedev'} };
 174         push @{$self->{'driveorder'}}, '0';
 175     } else {
 176         if (!exists $properties->{'tape-device'}) {
 177             return Amanda::Changer->make_error("fatal", undef,
 178                 message => "no 'tape-device' property specified");
 179         }
 180         for my $pval (@{$properties->{'tape-device'}->{'values'}}) {
 181             my ($drive, $device);
 182             unless (($drive, $device) = ($pval =~ /(\d+)=(.*)/)) {
 183                 return Amanda::Changer->make_error("fatal", undef,
 184                     message => "invalid 'tape-device' property '$pval'");
 185             }
 186             if (exists $self->{'drive2device'}->{$drive}) {
 187                 return Amanda::Changer->make_error("fatal", undef,
 188                     message => "tape-device drive $drive defined more than once");
 189             }
 190             $self->{'drive2device'}->{$drive} = $device;
 191             push @{$self->{'driveorder'}}, $drive;
 192         }
 193     }
 194
 195     # eject-before-unload
 196     my $ebu = $self->{'config'}->get_boolean_property(
 197                                             "eject-before-unload", 0);
 198     if (!defined $ebu) {
 199         return Amanda::Changer->make_error("fatal", undef,
 200             message => "invalid 'eject-before-unload' value");
 201     }
 202     $self->{'eject_before_unload'} = $ebu;
 203
 204     # fast-search
 205     my $fast_search = $self->{'config'}->get_boolean_property(
 206                                                 "fast-search", 1);
 207     if (!defined $fast_search) {
 208         return Amanda::Changer->make_error("fatal", undef,
 209             message => "invalid 'fast-search' value");
 210     }
 211     $self->{'fast_search'} = $fast_search;
 212
 213     # use-slots
 214     if (exists $properties->{'use-slots'}) {
 215         $self->{'use_slots'} = join ",", @{$properties->{'use-slots'}->{'values'}};
 216         if ($self->{'use_slots'} !~ /\d+(-\d+)?(,\d+(-\d+)?)*/) {
 217             return Amanda::Changer->make_error("fatal", undef,
 218                 message => "invalid 'use-slots' value '$self->{use_slots}'");
 219         }
 220     }
 221
 222     # drive-choice
 223     if (exists $properties->{'drive-choice'}) {
 224         my $pval = $properties->{'drive-choice'}->{'values'}->[0];
 225         if (!grep { lc($_) eq $pval } ('lru', 'firstavail')) {
 226             return Amanda::Changer->make_error("fatal", undef,
 227                 message => "invalid 'drive-choice' value '$pval'");
 228         }
 229         $self->{'drive_choice'} = $pval;
 230     }
 231
 232     # load-poll
 233     {
 234         next unless exists $config->{'properties'}->{'load-poll'};
 235         if (@{$config->{'properties'}->{'load-poll'}->{'values'}} > 1) {
 236             return Amanda::Changer->make_error("fatal", undef,
 237                 message => "only one value allowed for 'load-poll'");
 238         }
 239         my $propval = $config->{'properties'}->{'load-poll'}->{'values'}->[0];
 240         my ($delay, $delayu, $poll, $pollu, $until, $untilu) = ($propval =~ /^
 241                 (\d+)\s*([ms]?)
 242                 (?:
 243                   \s+poll\s+
 244                   (\d+)\s*([ms]?)
 245                   (?:
 246                     \s+until\s+
 247                     (\d+)\s*([ms]?)
 248                   )?
 249                 )?
 250                 $/ix);
 251
 252         if (!defined $delay) {
 253             return Amanda::Changer->make_error("fatal", undef,
 254                 message => "invalid delay value '$propval' for 'load-poll'");
 255         }
 256
 257         $delay *= 60 if (defined $delayu and $delayu =~ /m/i);
 258
 259         $poll = 0 unless defined $poll;
 260         $poll *= 60 if (defined $pollu and $pollu =~ /m/i);
 261
 262         $until = 0 unless defined $until;
 263         $until *= 60 if (defined $untilu and $untilu =~ /m/i);
 264
 265         $self->{'load_poll'} = [ $delay, $poll, $until ];
 266     }
 267
 268     # status-interval, eject-delay, unload-delay
 269     for my $propname qw(status-interval eject-delay unload-delay) {
 270         next unless exists $config->{'properties'}->{$propname};
 271         if (@{$config->{'properties'}->{$propname}->{'values'}} > 1) {
 272             return Amanda::Changer->make_error("fatal", undef,
 273                 message => "only one value allowed for $propname");
 274         }
 275         my $propval = $config->{'properties'}->{$propname}->{'values'}->[0];
 276         my ($time, $timeu) = ($propval =~ /^(\d+)([ms]?)/ix);
 277
 278         if (!defined $time) {
 279             return Amanda::Changer->make_error("fatal", undef,
 280                 message => "invalid time value '$propval' for '$propname'");
 281         }
 282
 283         $time *= 60 if (defined $timeu and $timeu =~ /m/i);
 284
 285         my $key = $propname;
 286         $key =~ s/-/_/;
 287         $self->{$key} = $time;
 288     }
 289
 290     my $ignore_barcodes = $self->{'config'}->get_boolean_property(
 291                                             "ignore-barcodes", 0);
 292     if (!defined $ignore_barcodes) {
 293         return Amanda::Changer->make_error("fatal", undef,
 294             message => "invalid 'ignore-barcodes' value");
 295     }
 296
 297     # get the interface, returning an error if we get one
 298     $self->{'interface'} = $self->get_interface($device_name, $ignore_barcodes);
 299     return $self->{'interface'}
 300         if ($self->{'interface'}->isa("Amanda::Changer::Error"));
 301
 302     return $self;
 303 }
 304
 305 sub load {
 306     my $self = shift;
 307     my %params = @_;
 308     $self->validate_params('load', \%params);
 309
 310     return if $self->check_error($params{'res_cb'});
 311
 312     $self->_with_updated_state(\%params, 'res_cb', sub { $self->load_unlocked(@_) });
 313 }
 314
 315 sub load_unlocked {
 316     my $self = shift;
 317     my %params = @_;
 318     my ($slot, $drive, $need_unload);
 319     my $state = $params{'state'};
 320
 321     my $steps = define_steps
 322         cb_ref => \$params{'res_cb'};
 323
 324     step calculate_slot => sub {
 325         # make sure the slot is numeric
 326         if (exists $params{'slot'}) {
 327             if ($params{'slot'} =~ /^\d+$/) {
 328                 $params{'slot'} = $params{'slot'}+0;
 329             } else {
 330                 return $self->make_error("failed", $params{'res_cb'},
 331                         reason => "invalid",
 332                         message => "invalid slot '$params{slot}'");
 333             }
 334         }
 335
 336         if (exists $params{'relative_slot'}) {
 337             if ($params{'relative_slot'} eq "next") {
 338                 if (exists $params{'slot'}) {
 339                     $slot = $self->_get_next_slot($state, $params{'slot'});
 340                     $self->_debug("loading next relative to $params{slot}: $slot");
 341                 } else {
 342                     $slot = $self->_get_next_slot($state, $state->{'current_slot'});
 343                     $self->_debug("loading next relative to current slot: $slot");
 344                 }
 345                 if ($slot == -1) {
 346                     return $self->make_error("failed", $params{'res_cb'},
 347                             reason => "invalid",
 348                             message => "could not find next slot");
 349                 }
 350             } elsif ($params{'relative_slot'} eq "current") {
 351                 $slot = $state->{'current_slot'};
 352                 if ($slot == -1) {
 353                     # seek to the first slot
 354                     $slot = $self->_get_next_slot($state, $state->{'current_slot'});
 355                 }
 356                 if ($slot == -1) {
 357                     return $self->make_error("failed", $params{'res_cb'},
 358                             reason => "invalid",
 359                             message => "no current slot");
 360                 }
 361             } else {
 362                 return $self->make_error("failed", $params{'res_cb'},
 363                         reason => "invalid",
 364                         message => "invalid relative_slot '$params{relative_slot}'");
 365             }
 366
 367         } elsif (exists $params{'slot'}) {
 368             $slot = $params{'slot'};
 369             $self->_debug("loading slot '$params{slot}'");
 370
 371             if (!defined $slot or !exists $state->{'slots'}->{$slot}) {
 372                 return $self->make_error("failed", $params{'res_cb'},
 373                         reason => "invalid",
 374                         message => "invalid slot '$slot'");
 375             }
 376
 377         } elsif (exists $params{'label'}) {
 378             $self->_debug("loading label '$params{label}'");
 379             while (my ($sl, $info) = each(%{$state->{'slots'}})) {
 380                 if (defined $info->{'label'} and $info->{'label'} eq $params{'label'}) {
 381                     $slot = $sl;
 382                     last;
 383                 }
 384             }
 385
 386             if (!defined $slot) {
 387                 return $self->make_error("failed", $params{'res_cb'},
 388                         reason => "notfound",
 389                         message => "label '$params{label}' not recognized or not found");
 390             }
 391
 392         } else {
 393             return $self->make_error("failed", $params{'res_cb'},
 394                     reason => "invalid",
 395                     message => "no 'slot' or 'label' specified to load()");
 396         }
 397
 398         if (!$self->_is_slot_allowed($slot)) {
 399             if (exists $params{'label'}) {
 400                 return $self->make_error("failed", $params{'res_cb'},
 401                         reason => "invalid",
 402                         message => "label '$params{label}' is in slot $slot, which is " .
 403                                    "not in use-slots ($self->{use_slots})");
 404             } else {
 405                 return $self->make_error("failed", $params{'res_cb'},
 406                         reason => "invalid",
 407                         message => "slot $slot not in use-slots ($self->{use_slots})");
 408             }
 409         }
 410
 411         if (exists $params{'except_slots'} and exists $params{'except_slots'}->{$slot}) {
 412             return $self->make_error("failed", $params{'res_cb'},
 413                 reason => "notfound",
 414                 message => "all slots have been loaded");
 415         }
 416
 417         if ($state->{'slots'}->{$slot}->{'state'} eq Amanda::Changer::SLOT_EMPTY) {
 418             return $self->make_error("failed", $params{'res_cb'},
 419                     reason => "empty",
 420                     message => "slot $slot is empty");
 421         }
 422
 423         return $steps->{'calculate_drive'}->();
 424     };
 425
 426     step calculate_drive => sub {
 427         # $slot is set
 428         $need_unload = 0;
 429
 430         # see if the tape is already in a drive
 431         $drive = $state->{'slots'}->{$slot}->{'loaded_in'};
 432         if (defined $drive) {
 433             $self->_debug("requested volume is already in drive $drive");
 434             my $info = $state->{'drives'}->{$drive};
 435
 436             # if it's reserved, it can't be used
 437             if ($info->{'res_info'} and $self->_res_info_verify($info->{'res_info'})) {
 438                 return $self->make_error("failed", $params{'res_cb'},
 439                         reason => "volinuse",
 440                         slot => $slot,
 441                         message => "the requested volume is in use (drive $drive)");
 442             }
 443
 444             # if it's not reserved, but not in our list of drives, well, it still
 445             # can't be used
 446             if (!exists $self->{'drive2device'}->{$drive}) {
 447                 return $self->make_error("failed", $params{'res_cb'},
 448                         # not 'volinuse' because we can't expect the tape to be magically
 449                         # unloaded any time soon -- it's not actually in use, just inaccessible
 450                         reason => "invalid",
 451                         message => "the requested volume is in drive $drive, which this " .
 452                                    "changer instance cannot access");
 453             }
 454
 455             # otherwise, we can jump all the way to the end of this process
 456             return $steps->{'start_polling'}->();
 457         }
 458
 459         # here is where we implement each of the drive-selection algorithms
 460         my @check_order;
 461         if ($self->{'drive_choice'} eq 'lru') {
 462             my %lru = map { $_, 1 } @{$state->{'drive_lru'}};
 463             my @unused = grep { ! exists $lru{$_} } @{$self->{'driveorder'}};
 464
 465             # search through unused drives, then the LRU list
 466             @check_order = (@unused, @{$state->{'drive_lru'}});
 467         } elsif ($self->{'drive_choice'} eq 'firstavail') {
 468             # just the drive order, so we tend to prefer the first drive in
 469             # this order
 470             @check_order = (@{$self->{'driveorder'}});
 471         } else {
 472             # the constructor should detect this circumstance
 473             die "invalid drive_choice";
 474         }
 475
 476         my %checked;
 477         for my $dr (@check_order) {
 478             my $info = $state->{'drives'}->{$dr};
 479             next unless defined $info;
 480             next if exists $checked{$dr}; # don't check drives repeatedly
 481             $checked{$dr} = 1;
 482
 483             # skip drives we don't have rights to use
 484             next unless exists $self->{'drive2device'}->{$dr};
 485
 486             # skip reserved drives
 487             if ($info->{'res_info'}) {
 488                 if ($self->_res_info_verify($info->{'res_info'})) {
 489                     # this is a valid reservation -> skip this drive
 490                     $self->_debug("skipping drive $dr - already reserved");
 491                     next;
 492                 } else {
 493                     warning("invalidating stale reservation on drive $dr");
 494                     $info->{'res_info'} = undef;
 495                 }
 496             }
 497
 498             # otherwise, the drive is available, so use it (whether it contains
 499             # a volume or not)
 500             $drive = $dr;
 501             if ($info->{'state'} != Amanda::Changer::SLOT_EMPTY) {
 502                 $need_unload = 1;
 503             }
 504             last;
 505         }
 506
 507         if (!defined $drive) {
 508             return $self->make_error("failed", $params{'res_cb'},
 509                     reason => "driveinuse",
 510                     message => "no drives available");
 511         }
 512
 513         # remove this drive from the lru and put it at the end
 514         $state->{'drive_lru'} = [ grep { $_ ne $drive } @{$state->{'drive_lru'}} ];
 515         push @{$state->{'drive_lru'}}, $drive;
 516
 517         $self->_debug("using drive $drive");
 518
 519         $steps->{'wait_to_start'}->();
 520     };
 521
 522     step wait_to_start => sub {
 523         $self->_after_delay($state, $steps->{'start_operation'});
 524     };
 525
 526     step start_operation => sub {
 527         # $need_unload is set in $steps->{calculate_drive}
 528         if ($need_unload) {
 529             $steps->{'start_eject'}->();
 530         } else {
 531             $steps->{'start_load'}->();
 532         }
 533     };
 534
 535     step start_eject => sub {
 536         # we use the 'eject' method to unload here -- it ejects the volume
 537         # if the configuration calls for it, then puts the volume away in its
 538         # original slot.
 539         $self->eject_unlocked(
 540                 finished_cb => $steps->{'eject_finished'},
 541                 drive => $drive,
 542                 state => $state);
 543     };
 544
 545     step eject_finished => sub {
 546         my ($err) = @_;
 547
 548         if ($err) {
 549            return $params{'res_cb'}->($err);
 550         }
 551
 552         $steps->{'wait_to_load'}->();
 553     };
 554
 555     step wait_to_load => sub {
 556         $self->_after_delay($state, $steps->{'start_load'});
 557     };
 558
 559     step start_load => sub {
 560         # $slot and $drive are set
 561         $self->{'interface'}->load($slot, $drive, $steps->{'load_finished'});
 562     };
 563
 564     step load_finished => sub {
 565         # $slot and $drive are set
 566         my ($err) = @_;
 567
 568         if ($err) {
 569             return $self->make_error("failed", $params{'res_cb'},
 570                     reason => "unknown",
 571                     message => $err);
 572         }
 573
 574         $steps->{'start_polling'}->();
 575     };
 576
 577     my ($next_poll, $last_poll);
 578     step start_polling => sub {
 579         my ($delay, $poll, $until) = @{ $self->{'load_poll'} };
 580         my $now = time;
 581         $next_poll = $now + $delay;
 582         $last_poll = $now + $until;
 583
 584         return Amanda::MainLoop::call_after(1000 * ($next_poll - $now), $steps->{'check_device'});
 585     };
 586
 587     step check_device => sub {
 588         my $device_name = $self->{'drive2device'}->{$drive};
 589         die "drive $drive not found in drive2device" unless $device_name; # shouldn't happen
 590
 591         $self->_debug("polling '$device_name' to see if it's ready");
 592
 593         my $device = $self->get_device($device_name);
 594         return $params{'res_cb'}->($device) if $device->isa("Amanda::Changer::Error");
 595
 596         my $label;
 597         $device->read_label();
 598
 599         # see if the device thinks it's possible it's busy or empty
 600         if ($device->status & $DEVICE_STATUS_VOLUME_MISSING
 601             or $device->status & $DEVICE_STATUS_DEVICE_BUSY) {
 602             # device is not ready -- set up for the next polling step
 603             my ($delay, $poll, $until) = @{ $self->{'load_poll'} };
 604             my $now = time;
 605             $next_poll += $poll;
 606             $next_poll = $now + 1 if ($next_poll < $now);
 607             if ($poll != 0 and $next_poll < $last_poll) {
 608                 return Amanda::MainLoop::call_after(
 609                         1000 * ($next_poll - $now), $steps->{'check_device'});
 610             }
 611
 612             # (fall through if we're done polling)
 613         }
 614
 615         if ($device->status == $DEVICE_STATUS_SUCCESS) {
 616             $label = $device->volume_label;
 617         } elsif ($device->status & $DEVICE_STATUS_VOLUME_UNLABELED) {
 618             $label = undef;
 619         } else {
 620             return $self->make_error("fatal", $params{'res_cb'},
 621                     message => "while waiting for '$device_name' to become ready: "
 622                         . $device->error_or_status());
 623         }
 624
 625         # success!
 626         $steps->{'make_res'}->($device, $label);
 627     };
 628
 629     step make_res => sub {
 630         my ($device, $label) = @_;
 631
 632         # check the label against the desired label, in case this isn't the
 633         # desired volume
 634         if ($label and $params{'label'} and $label ne $params{'label'}) {
 635             $self->_debug("Expected label '$params{label}', but got '$label'");
 636
 637             # update metadata with this new information
 638             $state->{'slots'}->{$slot}->{'state'} = Amanda::Changer::SLOT_FULL;
 639             $state->{'slots'}->{$slot}->{'device_status'} = $device->status;
 640             if (defined $device->{'volume_header'}) {
 641                 $state->{'slots'}->{$slot}->{'f_type'} = $device->{'volume_header'}->{type};
 642             } else {
 643                 $state->{'slots'}->{$slot}->{'f_type'} = undef;
 644             }
 645             $state->{'slots'}->{$slot}->{'label'} = $label;
 646             if ($state->{'slots'}->{$slot}->{'barcode'}) {
 647                 $state->{'bc2lb'}->{$state->{'slots'}->{$slot}->{'barcode'}} = $label;
 648             }
 649
 650             return $self->make_error("failed", $params{'res_cb'},
 651                     reason => "notfound",
 652                     message => "Found unexpected tape '$label' while looking " .
 653                                "for '$params{label}'");
 654         }
 655
 656         if (!$label and $params{'label'}) {
 657             $self->_debug("Expected label '$params{label}', but got an unlabeled tape");
 658
 659             # update metadata with this new information
 660             $state->{'slots'}->{$slot}->{'state'} = Amanda::Changer::SLOT_FULL;
 661             $state->{'slots'}->{$slot}->{'device_status'} = $device->status;
 662             if (defined $device->{'volume_header'}) {
 663                 $state->{'slots'}->{$slot}->{'f_type'} = $device->{'volume_header'}->{type};
 664             } else {
 665                 $state->{'slots'}->{$slot}->{'f_type'} = undef;
 666             }
 667             $state->{'slots'}->{$slot}->{'label'} = undef;
 668             if ($state->{'slots'}->{$slot}->{'barcode'}) {
 669                 delete $state->{'bc2lb'}->{$state->{'slots'}->{$slot}->{'barcode'}};
 670             }
 671
 672             return $self->make_error("failed", $params{'res_cb'},
 673                     reason => "notfound",
 674                     message => "Found unlabeled tape while looking for '$params{label}'");
 675         }
 676
 677         my $res = Amanda::Changer::robot::Reservation->new($self, $slot, $drive,
 678                                 $device, $state->{'slots'}->{$slot}->{'barcode'});
 679
 680         # mark this as reserved
 681         $state->{'drives'}->{$drive}->{'res_info'} = $self->_res_info_new();
 682
 683         # update our state before returning
 684         $state->{'slots'}->{$slot}->{'loaded_in'} = $drive;
 685         $state->{'drives'}->{$drive}->{'orig_slot'} = $slot;
 686         $state->{'slots'}->{$slot}->{'label'} = $label;
 687         $state->{'drives'}->{$drive}->{'label'} = $label;
 688         $state->{'drives'}->{$drive}->{'state'} = Amanda::Changer::SLOT_FULL;
 689         $state->{'drives'}->{$drive}->{'barcode'} = $state->{'slots'}->{$slot}->{'barcode'};
 690         #$state->{'slots'}->{$slot}->{'device_status'} = 9;
 691         if ($label and $state->{'slots'}->{$slot}->{'barcode'}) {
 692             $state->{'bc2lb'}->{$state->{'slots'}->{$slot}->{'barcode'}} = $label;
 693         }
 694         if ($params{'set_current'}) {
 695                 $self->_debug("setting current slot to $slot");
 696             $state->{'current_slot'} = $slot;
 697         }
 698
 699         return $params{'res_cb'}->(undef, $res);
 700     };
 701 }
 702
 703 sub info_key {
 704     my $self = shift;
 705     my ($key, %params) = @_;
 706
 707     if ($key eq 'fast_search') {
 708         $self->info_key_fast_search(%params);
 709     } elsif ($key eq 'vendor_string') {
 710         $self->info_key_vendor_string(%params);
 711     } elsif ($key eq 'num_slots') {
 712         $self->info_key_num_slots(%params);
 713     }
 714 }
 715
 716 sub info_key_fast_search {
 717     my $self = shift;
 718     my %params = @_;
 719
 720     $params{'info_cb'}->(undef,
 721         fast_search => $self->{'fast_search'},
 722     );
 723 }
 724
 725 sub info_key_vendor_string {
 726     my $self = shift;
 727     my %params = @_;
 728
 729     $self->{'interface'}->inquiry(make_cb(inquiry_cb => sub {
 730         my ($err, $info) = @_;
 731         return $self->make_error("fatal", $params{'info_cb'},
 732                 message => "$err") if $err;
 733
 734         my $vendor_string = sprintf "%s %s",
 735             ($info->{'vendor id'} or "<unknown>"),
 736             ($info->{'product id'} or "<unknown>");
 737
 738         $params{'info_cb'}->(undef,
 739             vendor_string => $vendor_string,
 740         );
 741     }));
 742 }
 743
 744 sub info_key_num_slots {
 745     my $self = shift;
 746     my %params = @_;
 747
 748     $self->_with_updated_state(\%params, 'info_cb',
 749         sub { $self->info_key_num_slots_unlocked(@_) });
 750 }
 751
 752 sub info_key_num_slots_unlocked {
 753     my $self = shift;
 754     my %params = @_;
 755     my $state = $params{'state'};
 756
 757     my @allowed_slots = grep { $self->_is_slot_allowed($_) }
 758                         keys %{$state->{'slots'}};
 759
 760     $params{'info_cb'}->(undef, num_slots => scalar @allowed_slots);
 761 }
 762
 763 sub get_interface { # (overridden by subclasses)
 764     my $self = shift;
 765     my ($device_name, $ignore_barcodes) = @_;
 766
 767     my $mtx;
 768     if (exists $self->{'config'}->{'properties'}->{'mtx'}) {
 769         if (@{$self->{'config'}->{'properties'}->{'mtx'}->{'values'}} > 1) {
 770             return Amanda::Changer->make_error("fatal", undef,
 771                 message => "only one value allowed for 'mtx'");
 772         }
 773         $mtx = $self->{'config'}->{'properties'}->{'mtx'}->{'values'}->[0];
 774     } else {
 775         $mtx = $Amanda::Constants::MTX;
 776     }
 777
 778     if (!$mtx) {
 779         return Amanda::Changer->make_error("fatal", undef,
 780             message => "no default value for property MTX");
 781     }
 782
 783     return Amanda::Changer::robot::Interface::MTX->new($device_name, $mtx, $ignore_barcodes),
 784 }
 785
 786 # get, configure, and return a new device, or return a changer error
 787 sub get_device { # (overridden by subclasses)
 788     my $self = shift;
 789     my ($device_name) = @_;
 790
 791     my $device = Amanda::Device->new($device_name);
 792     if ($device->status != $DEVICE_STATUS_SUCCESS) {
 793         return Amanda::Changer->make_error("fatal", undef,
 794                 reason => "unknown",
 795                 message => "opening '$device_name': " . $device->error_or_status());
 796     }
 797
 798     if (my $err = $self->{'config'}->configure_device($device)) {
 799         return Amanda::Changer->make_error("fatal", undef,
 800                 reason => "unknown",
 801                 message => $err);
 802     }
 803
 804     return $device;
 805 }
 806
 807 sub _set_label {
 808     my $self = shift;
 809     my %params = @_;
 810
 811     return if $self->check_error($params{'finished_cb'});
 812
 813     $self->_with_updated_state(\%params, 'finished_cb',
 814         sub { $self->_set_label_unlocked(@_); });
 815 }
 816
 817 sub _set_label_unlocked {
 818     my $self = shift;
 819     my %params = @_;
 820     my $state = $params{'state'};
 821
 822     # update all of the various pieces of cached information
 823     my $drive = $params{'drive'};
 824     my $slot = $state->{'drives'}->{$drive}->{'orig_slot'};
 825     my $label = $params{'label'};
 826     my $barcode = $state->{'drives'}->{$drive}->{'barcode'};
 827     my $dev = $params{dev};
 828
 829     $state->{'drives'}->{$drive}->{'label'} = $label;
 830     if (defined $slot) {
 831         delete $state->{'slots'}->{$slot}->{'unkknown_state'};
 832         $state->{'slots'}->{$slot}->{'state'} = Amanda::Changer::SLOT_FULL;
 833         $state->{'slots'}->{$slot}->{'device_status'} = "".$dev->status;
 834         my $volume_header = $dev->volume_header;
 835         if (defined $volume_header) {
 836             $state->{'slots'}->{$slot}->{'f_type'} = "".$volume_header->{type};
 837         } else {
 838             $state->{'slots'}->{$slot}->{'f_type'} = undef;
 839         }
 840         $state->{'slots'}->{$slot}->{'label'} = $label;
 841     }
 842     if (defined $barcode) {
 843         $state->{'bc2lb'}->{$barcode} = $label;
 844     }
 845
 846     $params{'finished_cb'}->(undef);
 847 }
 848
 849 sub _release {
 850     my $self = shift;
 851     my %params = @_;
 852
 853     return if $self->check_error($params{'finished_cb'});
 854
 855     $self->_with_updated_state(\%params, 'finished_cb',
 856         sub { $self->_release_unlocked(@_); });
 857 }
 858
 859 sub _release_unlocked {
 860     my $self = shift;
 861     my %params = @_;
 862     my $state = $params{'state'};
 863     my $drive = $params{'drive'};
 864
 865     # delete the reservation and save the statefile
 866     if (!$self->_res_info_is_mine($state->{'drives'}->{$drive}->{'res_info'})) {
 867         # this should *never* happen
 868         return $self->make_error("fatal", $params{'finished_cb'},
 869                 message => "reservation belongs to another instance");
 870     }
 871     $state->{'drives'}->{$drive}->{'res_info'} = undef;
 872
 873     # bounce off to eject if the user has requested it, using the xx_unlocked
 874     # variant since we've already got the statefile open
 875     if ($params{'eject'}) {
 876         $self->eject_unlocked(
 877             drive => $drive,
 878             finished_cb => $params{'finished_cb'},
 879             state => $state,
 880         );
 881     } else {
 882         $params{'finished_cb'}->();
 883     }
 884 }
 885
 886 sub reset {
 887     my $self = shift;
 888     my %params = @_;
 889
 890     return if $self->check_error($params{'finished_cb'});
 891
 892     $self->_with_updated_state(\%params, 'finished_cb',
 893         sub { $self->reset_unlocked(@_); });
 894 }
 895
 896 sub reset_unlocked {
 897     my $self = shift;
 898     my %params = @_;
 899     my $state = $params{'state'};
 900
 901     $state->{'current_slot'} = $self->_get_next_slot($state, -1);
 902
 903     $params{'finished_cb'}->();
 904 }
 905
 906 sub eject {
 907     my $self = shift;
 908     my %params = @_;
 909
 910     return if $self->check_error($params{'finished_cb'});
 911
 912     $self->_with_updated_state(\%params, 'finished_cb',
 913         sub { $self->eject_unlocked(@_); });
 914 }
 915
 916 sub eject_unlocked {
 917     my $self = shift;
 918     my %params = @_;
 919     my $state = $params{'state'};
 920     my ($drive, $drive_info);
 921
 922     return if $self->check_error($params{'finished_cb'});
 923
 924     my $steps = define_steps
 925         cb_ref => \$params{'finished_cb'};
 926
 927     # note that this changer treats "eject" as "unload", which may also require an eject
 928     # operation if the eject_before_unload property is set
 929
 930     step start => sub {
 931         # if drive isn't specified, see if we only have one
 932         if (!exists $params{'drive'}) {
 933             if ((keys %{$self->{'drive2device'}}) == 1) {
 934                 $params{'drive'} = (keys %{$self->{'drive2device'}})[0];
 935             } else {
 936                 return $self->make_error("failed", $params{'finished_cb'},
 937                         reason => "invalid",
 938                         message => "no drive specified");
 939             }
 940         }
 941         $drive = $params{'drive'};
 942
 943         $self->_debug("unloading drive $drive");
 944         $drive_info = $state->{'drives'}->{$drive};
 945         if (!$drive_info) {
 946             return $self->make_error("failed", $params{'finished_cb'},
 947                     reason => "invalid",
 948                     message => "invalid drive '$drive'");
 949         }
 950
 951         # if the drive exists, but not configured in this changer, then
 952         # bail out.
 953         if (!defined $self->{'drive2device'}->{$drive}) {
 954             return $self->make_error("failed", $params{'finished_cb'},
 955                     reason => "invalid",
 956                     message => "this changer instance is not configured to access drive $drive");
 957         }
 958
 959
 960         # check for a reservation
 961         if ($drive_info->{'res_info'}
 962                     and $self->_res_info_verify($drive_info->{'res_info'})) {
 963             return $self->make_error("failed", $params{'finished_cb'},
 964                     reason => "volinuse",
 965                     message => "tape in drive '$drive' is in use");
 966         }
 967
 968         if ($self->{'eject_before_unload'}) {
 969             $steps->{'wait_to_eject'}->();
 970         } else {
 971             $steps->{'wait_to_unload'}->();
 972         }
 973     };
 974
 975     step wait_to_eject => sub {
 976         $self->_after_delay($state, $steps->{'eject'});
 977     };
 978
 979     step eject => sub {
 980         my $device_name = $self->{'drive2device'}->{$drive};
 981         $self->_debug("ejecting $device_name before unload");
 982
 983         my $device = $self->get_device($device_name);
 984         return $device if $device->isa("Amanda::Changer::Error");
 985
 986         if (!$device->eject()) {
 987             return $self->make_error("failed", $params{'finished_cb'},
 988                     reason => "unknown",
 989                     message => "while ejecting volume: " . $device->error_or_status);
 990         }
 991         undef $device;
 992
 993         $self->_set_delay($state, $self->{'eject_delay'});
 994
 995         $steps->{'wait_to_unload'}->();
 996     };
 997
 998     step wait_to_unload => sub {
 999         $self->_after_delay($state, $steps->{'unload'});
1000     };
1001
1002     step unload => sub {
1003         # find target slot and unload it - note that the target slot may not be
1004         # in the USE-SLOTS list, as it may belong to another config
1005         my $orig_slot = $drive_info->{'orig_slot'};
1006         $self->{'interface'}->unload($drive, $orig_slot, $steps->{'unload_finished'});
1007     };
1008
1009     step unload_finished => sub {
1010         my ($err) = @_;
1011
1012         if ($err) {
1013             return $self->make_error("failed", $params{'finished_cb'},
1014                     reason => "unknown",
1015                     message => $err);
1016         }
1017
1018         $self->_debug("unload complete");
1019         my $orig_slot = $state->{'drives'}->{$drive}->{'orig_slot'};
1020         $state->{'slots'}->{$orig_slot}->{'state'} = $state->{'drives'}->{$drive}->{'state'};
1021         $state->{'slots'}->{$orig_slot}->{'label'} = $state->{'drives'}->{$drive}->{'label'};
1022         $state->{'slots'}->{$orig_slot}->{'barcode'} = $state->{'drives'}->{$drive}->{'barcode'};
1023         $state->{'slots'}->{$orig_slot}->{'loaded_in'} = undef;
1024         $state->{'drives'}->{$drive}->{'state'} = Amanda::Changer::SLOT_EMPTY;
1025         $state->{'drives'}->{$drive}->{'label'} = undef;
1026         $state->{'drives'}->{$drive}->{'barcode'} = undef;
1027         $state->{'drives'}->{$drive}->{'orig_slot'} = undef;
1028
1029         $self->_set_delay($state, $self->{'unload_delay'});
1030         $params{'finished_cb'}->();
1031     };
1032 }
1033
1034 sub update {
1035     my $self = shift;
1036     my %params = @_;
1037
1038     return if $self->check_error($params{'finished_cb'});
1039
1040     $self->_with_updated_state(\%params, 'finished_cb',
1041         sub { $self->update_unlocked(@_); });
1042 }
1043
1044 sub update_unlocked {
1045     my $self = shift;
1046     my %params = @_;
1047     my @slots_to_check;
1048     my $state = $params{'state'};
1049     my $set_to_unknown = 0;
1050
1051     return if $self->check_error($params{'finished_cb'});
1052
1053     my $user_msg_fn = $params{'user_msg_fn'};
1054     $user_msg_fn ||= sub { $self->_debug($_[0]); };
1055
1056     my $steps = define_steps
1057         cb_ref => \$params{'finished_cb'};
1058
1059     step handle_assignment => sub {
1060         # check for the SL=LABEL format, and handle it here
1061         if (exists $params{'changed'} and $params{'changed'} =~ /^\d+=\S+$/) {
1062             my ($slot, $label) = ($params{'changed'} =~ /^(\d+)=(\S+)$/);
1063
1064             # let's list the reasons we *can't* do what the user has asked
1065             my $whynot;
1066             if (!exists $state->{'slots'}) {
1067                 $whynot = "slot $slot does not exist";
1068             } elsif (!$self->_is_slot_allowed($slot)) {
1069                 $whynot = "slot $slot is not used by this changer";
1070             } elsif ($state->{'slots'}->{$slot}->{'state'} ==
1071                      Amanda::Changer::SLOT_EMPTY) {
1072                 $whynot = "slot $slot is empty";
1073             } elsif (defined $state->{'slots'}->{$slot}->{'loaded_in'}) {
1074                 $whynot = "slot $slot is currently loaded";
1075             }
1076
1077             if ($whynot) {
1078                 return $self->make_error("failed", $params{'finished_cb'},
1079                         reason => "unknown", message => $whynot);
1080             }
1081
1082             $user_msg_fn->("recoding volume '$label' in slot $slot");
1083             # ok, now erase all knowledge of that label
1084             while (my ($bc, $lb) = each %{$state->{'bc2lb'}}) {
1085                 if ($lb eq $label) {
1086                     delete $state->{'bc2lb'}->{$bc};
1087                     last;
1088                 }
1089             }
1090             while (my ($sl, $inf) = each %{$state->{'slots'}}) {
1091                 if ($inf->{'label'} and $inf->{'label'} eq $label) {
1092                     delete $inf->{'device_status'};
1093                     delete $inf->{'f_type'};
1094                     delete $inf->{'label'};
1095                 }
1096             }
1097
1098             # and add knowledge of the label to the given slot
1099             #$state->{'slots'}->{$slot}->{'device_status'} = $DEVICE_STATUS_SUCCESS;
1100             #$state->{'slots'}->{$slot}->{'f_type'} = $Amanda::Header::F_TAPESTART;
1101             $state->{'slots'}->{$slot}->{'label'} = $label;
1102             if ($state->{'slots'}->{$slot}->{'barcode'}) {
1103                 my $bc = $state->{'slots'}->{$slot}->{'barcode'};
1104                 $state->{'bc2lb'}->{$bc} = $label;
1105             }
1106
1107             # that's it -- no changer motion required
1108             return $params{'finished_cb'}->(undef);
1109         } elsif (exists $params{'changed'} and
1110                  $params{'changed'} =~ /^(.+)=$/) {
1111             $params{'changed'} = $1;
1112             $set_to_unknown = 1;
1113             $steps->{'calculate_slots'}->($steps->{'set_to_unknown'});
1114         } else {
1115             $steps->{'calculate_slots'}->($steps->{'update_slot'});
1116         }
1117     };
1118
1119     step calculate_slots => sub {
1120         my ($update_slot_cb) = shift @_;
1121         if (exists $params{'changed'}) {
1122             # parse the string just like use-slots, using a hash for uniqueness
1123             my %changed;
1124             for my $range (split ',', $params{'changed'}) {
1125                 my ($first, $last) = ($range =~ /(\d+)(?:-(\d+))?/);
1126                 $last = $first unless defined($last);
1127                 for ($first .. $last) {
1128                     $changed{$_} = undef;
1129                 }
1130             }
1131
1132             @slots_to_check = keys %changed;
1133             @slots_to_check = grep { exists $state->{'slots'}->{$_} } @slots_to_check;
1134         } else {
1135             @slots_to_check = keys %{ $state->{'slots'} };
1136         }
1137
1138         # limit the update to allowed slots, and sort them so we don't confuse
1139         # the user with a "random" order
1140         @slots_to_check = grep { $self->_is_slot_allowed($_) } @slots_to_check;
1141         @slots_to_check = grep { $state->{'slots'}->{$_}->{'state'} == Amanda::Changer::SLOT_FULL} @slots_to_check;
1142         @slots_to_check = sort { $a <=> $b } @slots_to_check;
1143
1144         $update_slot_cb->();
1145     };
1146
1147     step set_to_unknown => sub {
1148         return $steps->{'done'}->() if (!@slots_to_check);
1149
1150         my $slot = shift @slots_to_check;
1151         $user_msg_fn->("Removing entry for slot $slot");
1152         if (!defined $state->{'slots'}->{$slot}->{'barcode'}) {
1153             $state->{'slots'}->{$slot}->{'label'} = undef;
1154             $state->{'slots'}->{$slot}->{'device_status'} = undef;
1155             $state->{'slots'}->{$slot}->{'f_type'} = undef;
1156             if (defined $state->{'slots'}->{$slot}->{'loaded_in'}) {
1157                 my $drive = $state->{'slots'}->{$slot}->{'loaded_in'};
1158                 $state->{'drives'}->{$drive}->{'label'} = undef;
1159                 $state->{'drives'}->{$drive}->{'state'} =
1160                                         Amanda::Changer::SLOT_FULL;
1161             }
1162         }
1163         $steps->{'set_to_unknown'}->();
1164     };
1165
1166     # TODO: parallelize this if multiple drives are available
1167
1168     step update_slot => sub {
1169         return $steps->{'done'}->() if (!@slots_to_check);
1170
1171         my $slot = shift @slots_to_check;
1172         $user_msg_fn->("scanning slot $slot");
1173
1174         $self->load_unlocked(
1175                 slot => $slot,
1176                 res_cb => $steps->{'slot_loaded'},
1177                 state => $state);
1178     };
1179
1180     step slot_loaded => sub {
1181         my ($err, $res) = @_;
1182         if ($err) {
1183             return $params{'finished_cb'}->($err);
1184         }
1185
1186         # load() already fixed up the metadata, so just release; but we have to
1187         # be careful to do an unlocked release.
1188         $res->release(
1189             finished_cb => $steps->{'released'},
1190             unlocked => 1,
1191             state => $state);
1192     };
1193
1194     step released => sub {
1195         my ($err) = @_;
1196         if ($err) {
1197             return $params{'finished_cb'}->($err);
1198         }
1199
1200         $steps->{'update_slot'}->();
1201     };
1202
1203     step done => sub {
1204         $params{'finished_cb'}->(undef);
1205     };
1206 }
1207
1208 sub inventory {
1209     my $self = shift;
1210     my %params = @_;
1211
1212     return if $self->check_error($params{'inventory_cb'});
1213
1214     $self->_with_updated_state(\%params, 'inventory_cb',
1215         sub { $self->inventory_unlocked(@_); });
1216 }
1217
1218 sub inventory_unlocked {
1219     my $self = shift;
1220     my %params = @_;
1221     my $state = $params{'state'};
1222
1223     my @slot_names = sort { $a <=> $b } keys %{ $state->{'slots'} };
1224     my @inv;
1225     for my $slot_name (@slot_names) {
1226         my $i = {};
1227         next unless $self->_is_slot_allowed($slot_name);
1228         my $slot = $state->{'slots'}->{$slot_name};
1229
1230         $i->{'slot'} = $slot_name;
1231         $i->{'state'} = $slot->{'state'};
1232         $i->{'device_status'} = $slot->{'device_status'};
1233         $i->{'f_type'} = $slot->{'f_type'};
1234         $i->{'label'} = $slot->{'label'};
1235         $i->{'barcode'} = $slot->{'barcode'}
1236                 if ($slot->{'barcode'});
1237         if (defined $slot->{'loaded_in'}) {
1238             $i->{'loaded_in'} = $slot->{'loaded_in'};
1239             my $drive = $state->{'drives'}->{$slot->{'loaded_in'}};
1240             if ($drive->{'res_info'} and $self->_res_info_verify($drive->{'res_info'})) {
1241                 $i->{'reserved'} = 1;
1242             }
1243         }
1244         $i->{'import_export'} = 1
1245             if $slot->{'ie'};
1246
1247         $i->{'current'} = 1
1248             if $slot_name eq $state->{'current_slot'};
1249
1250         push @inv, $i;
1251     }
1252
1253     $params{'inventory_cb'}->(undef, \@inv);
1254 }
1255
1256 sub move {
1257     my $self = shift;
1258     my %params = @_;
1259
1260     return if $self->check_error($params{'finished_cb'});
1261
1262     $self->_with_updated_state(\%params, 'finished_cb',
1263         sub { $self->move_unlocked(@_); });
1264 }
1265
1266 sub move_unlocked {
1267     my $self = shift;
1268     my %params = @_;
1269     my $state = $params{'state'};
1270
1271     my $from_slot = $params{'from_slot'};
1272     my $to_slot = $params{'to_slot'};
1273
1274     # make sure this is OK
1275     for ($from_slot, $to_slot) {
1276         if (!$self->_is_slot_allowed($_)) {
1277             return $self->make_error("failed", $params{'finished_cb'},
1278                     reason => "invalid",
1279                     message => "invalid slot $_");
1280         }
1281     }
1282
1283     if ($state->{'slots'}->{$from_slot}->{'state'} == Amanda::Changer::SLOT_EMPTY) {
1284         return $self->make_error("failed", $params{'finished_cb'},
1285                 reason => "invalid",
1286                 message => "slot $from_slot is empty");
1287     }
1288
1289     my $in_drive = $state->{'slots'}->{$from_slot}->{'loaded_in'};
1290     if (defined $in_drive) {
1291         my $info = $state->{'drives'}->{$in_drive};
1292         if ($info->{'res_info'} and $self->_res_info_verify($info->{'res_info'})) {
1293             return $self->make_error("failed", $params{'finished_cb'},
1294                     reason => "invalid",
1295                     message => "slot $from_slot is currently loaded and reserved");
1296         }
1297     }
1298
1299     if ($state->{'slots'}->{$to_slot}->{'state'} == Amanda::Changer::SLOT_FULL) {
1300         return $self->make_error("failed", $params{'finished_cb'},
1301                 reason => "invalid",
1302                 message => "slot $to_slot is not empty");
1303     }
1304
1305     # if the destination slot is loaded, then we could do an "exchange", but
1306     # should we?
1307
1308     my $transfer_complete = make_cb(transfer_complete => sub {
1309         my ($err) = @_;
1310         return $params{'finished_cb'}->($err) if $err;
1311
1312         # update metadata
1313         if ($from_slot ne $to_slot) {
1314             my $f = $state->{'slots'}->{$from_slot};
1315             my $t = $state->{'slots'}->{$to_slot};
1316
1317             $t->{'device_status'} = $f->{'device_status'};
1318             $f->{'device_status'} = undef;
1319
1320             $t->{'state'} = $f->{'state'};
1321             $f->{'state'} = Amanda::Changer::SLOT_EMPTY;
1322
1323             $t->{'f_type'} = $f->{'f_type'};
1324             $f->{'f_type'} = undef;
1325
1326             $t->{'label'} = $f->{'label'};
1327             $f->{'label'} = undef;
1328
1329             $t->{'barcode'} = $f->{'barcode'};
1330             $f->{'barcode'} = undef;
1331         }
1332
1333         # properly represent the unload operation, if it was performed
1334         if (defined $in_drive) {
1335             $state->{'slots'}->{$from_slot}->{'loaded_in'} = undef;
1336             $state->{'slots'}->{$to_slot}->{'loaded_in'} = undef;
1337
1338             $state->{'drives'}->{$in_drive}->{'state'} =
1339                                                     Amanda::Changer::SLOT_EMPTY;
1340             $state->{'drives'}->{$in_drive}->{'label'} = undef;
1341             $state->{'drives'}->{$in_drive}->{'barcode'} = undef;
1342             $state->{'drives'}->{$in_drive}->{'orig_slot'} = undef;
1343         }
1344
1345         $params{'finished_cb'}->();
1346     });
1347
1348     # if the source slot is loaded, then this is just a directed unload operation;
1349     # otherwise, it's a transfer.
1350     if (defined $in_drive) {
1351         Amanda::Debug::debug("move(): unloading drive $in_drive to slot $to_slot");
1352         $self->{'interface'}->unload($in_drive, $to_slot, $transfer_complete);
1353     } else {
1354         $self->{'interface'}->transfer($from_slot, $to_slot, $transfer_complete);
1355     }
1356 }
1357
1358 ##
1359 # Utilities
1360
1361 # calculate the next highest non-empty slot after $slot (assuming that
1362 # the changer status has been updated)
1363 sub _get_next_slot {
1364     my $self = shift;
1365     my ($state, $slot) = @_;
1366
1367     my @nonempty = sort { $a <=> $b } grep {
1368         $state->{'slots'}->{$_}->{'state'} == Amanda::Changer::SLOT_FULL
1369         and $self->_is_slot_allowed($_)
1370     } keys(%{$state->{'slots'}});
1371
1372     my @higher = grep { $_ > $slot } @nonempty;
1373
1374     # return the next higher slot, or the first nonempty slot (to loop around)
1375     return $higher[0] if (@higher);
1376     return $nonempty[0];
1377 }
1378
1379 # is $slot in the slots specified by the use-slots property?
1380 sub _is_slot_allowed {
1381     my $self = shift;
1382     my ($slot) = @_;
1383
1384     # if use-slots is not specified, all slots are available
1385     return 1 unless ($self->{'use_slots'});
1386
1387     for my $range (split ',', $self->{'use_slots'}) {
1388         my ($first, $last) = ($range =~ /(\d+)(?:-(\d+))?/);
1389         $last = $first unless defined($last);
1390         return 1 if ($slot >= $first and $slot <= $last);
1391     }
1392
1393     return 0;
1394 }
1395
1396 # add a prefix and call Amanda::Debug::debug
1397 sub _debug {
1398     my $self = shift;
1399     my ($msg) = @_;
1400     # chg_name is not set until *after* the constructor finishes
1401     my $chg_name = $self->{'chg_name'} || $self->{'class_name'};
1402     debug("$chg_name: $msg");
1403 }
1404
1405 ##
1406 # Timing management
1407
1408 # Wait until the delay from the last operation has expired, and call the
1409 # given callback with the given arguments
1410 sub _after_delay {
1411     my $self = shift;
1412     my ($state, $cb, @args) = @_;
1413
1414     confess("undefined \$cb") unless (defined $cb);
1415
1416     # if the current time is before $start, then we'll perform the action anyway; this
1417     # saves us from long delays when clocks fall out of sync or run backward, but delays
1418     # are short.
1419     my ($start, $end, $now);
1420     $start = $state->{'last_operation_time'};
1421     if (!defined $start) {
1422         return $cb->(@args);
1423     }
1424
1425     $end = $start + $state->{'last_operation_delay'};
1426     $now = time;
1427
1428     if ($now >= $start and $now < $end) {
1429         Amanda::MainLoop::call_after(1000 * ($end - $now), $cb, @args);
1430     } else {
1431         return $cb->(@args);
1432     }
1433 }
1434
1435 # set the delay parameters in the statefile
1436 sub _set_delay {
1437     my $self = shift;
1438     my ($state, $delay) = @_;
1439
1440     $state->{'last_operation_time'} = time;
1441     $state->{'last_operation_delay'} = $delay;
1442 }
1443
1444 ##
1445 # Statefile management
1446
1447 # wrapper around Amanda::Changer's with_locked_state to lock the statefile and
1448 # then update the state with the results of the 'status' command.
1449 #
1450 # Like with_locked_state, this method assumes the keyword-based parameter
1451 # style, and adds a 'state' parameter with the new state.  Also like
1452 # with_locked_state, it replaces the $cbname key with a wrapped version of that
1453 # callback.  It then calls $sub.
1454 sub _with_updated_state {
1455     my $self = shift;
1456     my ($paramsref, $cbname, $sub) = @_;
1457     my %params = %$paramsref;
1458     my $state;
1459
1460     my $steps = define_steps
1461         cb_ref => \$paramsref->{$cbname};
1462
1463     step start => sub {
1464         $self->with_locked_state($self->{'statefile'},
1465             $params{$cbname}, $steps->{'got_lock'});
1466     };
1467
1468     step got_lock => sub {
1469         ($state, my $new_cb) = @_;
1470
1471         # set up params for calling through to $sub later
1472         $params{'state'} = $state;
1473         $params{$cbname} = $new_cb;
1474
1475         if (!keys %$state) {
1476             $state->{'slots'} = {};
1477             $state->{'drives'} = {};
1478             $state->{'drive_lru'} = [];
1479             $state->{'bc2lb'} = {};
1480             $state->{'current_slot'} = -1;
1481         }
1482
1483         # this is for testing ONLY!
1484         $self->{'__last_state'} = $state;
1485
1486         # if it's not time for another run of the status command yet, then just skip to
1487         # the end.
1488         if (defined $state->{'last_status'}
1489             and time < $state->{'last_status'} + $self->{'status_interval'}) {
1490             $self->_debug("too early for another 'status' invocation");
1491             $steps->{'done'}->();
1492         } else {
1493             $steps->{'wait'}->();
1494         }
1495     };
1496
1497     step wait => sub {
1498         $self->_after_delay($state, $steps->{'call_status'});
1499     };
1500
1501     step call_status => sub {
1502         $self->{'interface'}->status($steps->{'status_cb'});
1503     };
1504
1505     step status_cb => sub {
1506         my ($err, $status) = @_;
1507         if ($err) {
1508             return $self->make_error("fatal", $params{$cbname},
1509                 message => $err);
1510         }
1511
1512         $state->{'last_status'} = time;
1513         $self->_debug("updating state");
1514
1515         # process the results; $status can update our slot->label
1516         # mapping, but the barcode->label mapping stays the same.
1517
1518         my $new_slots = {};
1519         my ($drv, $slot, $info);
1520
1521         # note that loaded_in is always undef; it will be set correctly
1522         # when the drives are scanned
1523         while (($slot, $info) = each %{$status->{'slots'}}) {
1524             if ($info->{'empty'}) {
1525                 # empty slot
1526                 $new_slots->{$slot} = {
1527                     state => Amanda::Changer::SLOT_EMPTY,
1528                     device_status => undef,
1529                     f_type => undef,
1530                     label => undef,
1531                     barcode => undef,
1532                     loaded_in => undef,
1533                     ie => $info->{'ie'},
1534                 };
1535                 next;
1536             }
1537
1538             if (defined $info->{'barcode'}) {
1539
1540                 my $label = $state->{'bc2lb'}->{$info->{'barcode'}};
1541
1542                 $new_slots->{$slot} = {
1543                     state => Amanda::Changer::SLOT_FULL,
1544                     device_status => $state->{'slots'}->{$slot}->{device_status},
1545                     f_type => $state->{'slots'}->{$slot}->{f_type},
1546                     label => $label,
1547                     barcode => $info->{'barcode'},
1548                     loaded_in => undef,
1549                     ie => $info->{'ie'},
1550                 };
1551             } else {
1552                 # assume the status of this slot has not changed since the last
1553                 # time we looked at it, although mark it as not loaded in a slot
1554                 if (exists $state->{'slots'}->{$slot}) {
1555                     $new_slots->{$slot} = $state->{'slots'}->{$slot};
1556                     $new_slots->{$slot}->{'loaded_in'} = undef;
1557                 } else {
1558                     $new_slots->{$slot} = {
1559                         state => Amanda::Changer::SLOT_FULL,
1560                         device_status => undef,
1561                         f_type => undef,
1562                         label => undef,
1563                         barcode => undef,
1564                         loaded_in => undef,
1565                         ie => $info->{'ie'},
1566                     };
1567                 }
1568             }
1569         }
1570         my $old_slots_state = $state->{'slots'};
1571         $state->{'slots'} = $new_slots;
1572
1573         # now handle the drives
1574         my $new_drives = {};
1575         while (($drv, $info) = each %{$status->{'drives'}}) {
1576             my $old_drive = $state->{'drives'}->{$drv};
1577
1578             # if this drive still has a valid reservation, don't change it
1579             if (defined $old_drive->{'res_info'}
1580                         and $self->_res_info_verify($old_drive->{'res_info'})) {
1581                 $new_drives->{$drv} = $old_drive;
1582                 next;
1583             }
1584
1585             # if the drive is empty, this is pretty easy
1586             if (!defined $info) {
1587                 $new_drives->{$drv} = {
1588                     state => Amanda::Changer::SLOT_EMPTY,
1589                     label => undef,
1590                     barcode => undef,
1591                     orig_slot => undef,
1592                 };
1593                 next;
1594             }
1595
1596             # trust our own orig_slot over that from the changer, if possible,
1597             # as some changers do not report this information accurately
1598             my ($orig_slot, $label);
1599             if (defined $old_drive->{'orig_slot'}) {
1600                 $orig_slot = $old_drive->{'orig_slot'};
1601                 $label = $old_drive->{'label'};
1602             }
1603
1604             # but don't trust it if the barcode has changed
1605             if (defined $info->{'barcode'}
1606                     and defined $old_drive->{'barcode'}
1607                     and $info->{'barcode'} ne $old_drive->{'barcode'}) {
1608                 $orig_slot = undef;
1609                 $label = undef;
1610             }
1611
1612             # get the robot's notion of the original slot if we don't know ourselves
1613             if (!defined $orig_slot) {
1614                 $orig_slot = $info->{'orig_slot'};
1615             }
1616
1617             # but if there's a tape in that slot, then we've got a problem
1618             if (defined $orig_slot
1619                     and $state->{'slots'}->{$orig_slot}->{'state'} != Amanda::Changer::SLOT_EMPTY) {
1620                 warning("mtx indicates tape in drive $drv should go to slot $orig_slot, " .
1621                         "but that slot is not empty.");
1622                 $orig_slot = undef;
1623                 for my $slot (keys %{ $state->{'slots'} }) {
1624                     if ($state->{'slots'}->{$slot}->{'state'} == Amanda::Changer::SLOT_EMPTY) {
1625                         $orig_slot = $slot;
1626                         last;
1627                     }
1628                 }
1629                 if (!defined $orig_slot) {
1630                     warning("cannot find an empty slot for the tape in drive $drv");
1631                 }
1632             }
1633
1634             # and look up the label by barcode if possible
1635             if (!defined $label && defined $info->{'barcode'}) {
1636                 $label = $state->{'bc2lb'}->{$info->{'barcode'}};
1637             }
1638
1639             $new_drives->{$drv} = {
1640                 state => Amanda::Changer::SLOT_FULL,
1641                 label => $label,
1642                 barcode => $info->{'barcode'},
1643                 orig_slot => $orig_slot,
1644             };
1645         }
1646         $state->{'drives'} = $new_drives;
1647
1648         # update the loaded_in info for the relevant slots
1649         while (($drv, $info) = each %$new_drives) {
1650             # also update the slots with the relevant 'loaded_in' info
1651             if (defined $info->{'orig_slot'}) {
1652                 my $old_state = $old_slots_state->{$info->{'orig_slot'}};
1653                 $state->{'slots'}->{$info->{'orig_slot'}} = {
1654                     state => $info->{'state'},
1655                     device_status => $old_state->{'device_status'},
1656                     f_type => $old_state->{'f_type'},
1657                     label => $info->{'label'},
1658                     barcode => $info->{'barcode'},
1659                     loaded_in => $drv,
1660                 };
1661             }
1662         }
1663
1664         # sanity check that we don't have tape-device info for nonexistent drives
1665         for my $dr (@{$self->{'driveorder'}}) {
1666             if (!exists $state->{'drives'}->{$dr}) {
1667                 warning("tape-device property specified for drive $dr, but no such " .
1668                         "drive exists in the library");
1669             }
1670         }
1671
1672         if ($state->{'current_slot'} == -1) {
1673             $state->{'current_slot'} = $self->_get_next_slot($state, -1);
1674         }
1675
1676         $steps->{'done'}->();
1677     };
1678
1679     step done => sub {
1680         # finally, call through to the user's method; $params{$cbname} has been
1681         # properly patched to release the state lock when this method is done.
1682         $sub->(%params);
1683     };
1684 }
1685
1686 ##
1687 # reservation records
1688
1689 # A reservation record is recorded in the statefile, and is distinct from an
1690 # Amanda::Changer::robot:Reservation object in that it is seen by all users of
1691 # the tape device, whether in this process or another.
1692 #
1693 # This is abstracted out to enable support for a more robust mechanism than
1694 # caching a pid.
1695
1696 sub _res_info_new {
1697     my $self = shift;
1698     return { pid => $$, };
1699 }
1700
1701 sub _res_info_verify {
1702     my $self = shift;
1703     my ($res_info) = @_;
1704
1705     # true if this is our reservation
1706     return 1 if ($res_info->{'pid'} == $$);
1707
1708     # or if the process is dead
1709     return kill 0, $res_info->{'pid'};
1710 }
1711
1712 sub _res_info_is_mine {
1713     my $self = shift;
1714     my ($res_info) = @_;
1715
1716     return 1 if ($res_info and $res_info->{'pid'} == $$);
1717 }
1718
1719 package Amanda::Changer::robot::Reservation;
1720 use vars qw( @ISA );
1721 use Amanda::Debug qw( debug warning );
1722 @ISA = qw( Amanda::Changer::Reservation );
1723
1724 sub new {
1725     my $class = shift;
1726     my ($chg, $slot, $drive, $device, $barcode) = @_;
1727     my $self = Amanda::Changer::Reservation::new($class);
1728
1729     $self->{'chg'} = $chg;
1730
1731     $self->{'drive'} = $drive;
1732     $self->{'device'} = $device;
1733     $self->{'this_slot'} = $slot;
1734     $self->{'barcode'} = $barcode;
1735
1736     return $self;
1737 }
1738
1739 sub do_release {
1740     my $self = shift;
1741     my %params = @_;
1742
1743     # if we're in global cleanup and the changer is already dead,
1744     # then never mind
1745     return unless $self->{'chg'};
1746
1747     # unref the device, for good measure
1748     $self->{'device'} = undef;
1749
1750     # punt this method off to the changer itself, optionally calling
1751     # the unlocked version if we have the 'state' parameter
1752     if (exists $params{'unlocked'} and exists $params{'state'}) {
1753         $self->{'chg'}->_release_unlocked(drive => $self->{'drive'}, %params);
1754     } else {
1755         $self->{'chg'}->_release(drive => $self->{'drive'}, %params);
1756     }
1757 }
1758
1759 sub set_label {
1760     my $self = shift;
1761     my %params = @_;
1762
1763     return unless $self->{'chg'};
1764     $self->{'chg'}->_set_label(drive => $self->{'drive'},
1765                                dev => $self->{device}, %params);
1766 }
1767
1768 package Amanda::Changer::robot::Interface;
1769
1770 # The physical interface to the changer is abstracted out to allow several
1771 # implementations (see chg-ndmp for one of them).  This API is "reasonably
1772 # stable", but is really only known to this changer and its subclasses, so it's
1773 # not documented in POD.  The methods are:
1774 #
1775 #   $iface->inquiry($inquiry_cb);
1776 #
1777 # Inquire as to the relevant information about the changer.  The result is a
1778 # hash table of lowercased key names and values, $info.  The inquiry_cb is
1779 # called as $inquiry_cb->($errmsg, $info).  The resulting strings have quotes
1780 # and whitespace stripped.  Keys include 'vendor id' and 'product id'.
1781 #
1782 #   $iface->status($status_cb)
1783 #
1784 # Get the READ ELEMENT STATUS output for the changer.  The status_cb is called
1785 # as $status_cb->($errmsg, $status).  $status is a hash with keys 'drives' and
1786 # 'slots', each of which is a hash indexed by the element address (note that drive
1787 # element addresses can and usually do overlap with slots.  The values of the slots
1788 # hash are hashes with keys
1789 #  - 'empty' (1 if the slot is empty)
1790 #  - 'barcode' (which may be undef if the changer does not support barcodes)
1791 #  - 'ie' (a boolean indicating whether this is an import/export slot).
1792 # The values of the drives are undef for empty drive, or hashes with keys
1793 #  - 'barcode' (which may be undef if the changer does not support barcodes)
1794 #  - 'orig_slot' (slot from which this volume was taken, if known)
1795 #
1796 #   $iface->load($slot, $drive, $finished_cb)
1797 #
1798 # Load $slot into $drive.  The finished_cb gets a single argument, $error,
1799 # which is only defined if an error occurred.  Note that this does not
1800 # necessarily wait until the load operation is complete (most drives give
1801 # no such indication) (this method also implements unload, if $un=1)
1802 #
1803 #   $iface->unload($drive, $slot, $finished_cb);
1804 #
1805 # Unload $drive into $slot.  Finished_cb is just as for load().
1806 #
1807 #   $iface->eject($drive_name, $finished_cb);
1808 #
1809 # Eject $drive_name (named /dev/whatever, not the drive number), and call finished_cb.
1810 #
1811 #   $iface->transfer($src_slot, $dst_slot, $finished_cb);
1812 #
1813 # Move the tape in $src_slot into $dst_slot.  The finished_cb gets a single
1814 # argument, $error, which is only defined if an error occurred.  Note that this
1815 # does not necessarily wait until the load operation is complete.
1816
1817 package Amanda::Changer::robot::Interface::MTX;
1818
1819 use Amanda::Paths;
1820 use Amanda::Config qw( :getconf );
1821 use Amanda::Debug qw( debug warning );
1822 use Amanda::MainLoop qw( :GIOCondition synchronized make_cb define_steps step );
1823 use Amanda::Device qw( :constants );
1824
1825 sub new {
1826     my $class = shift;
1827     my ($device_name, $mtx, $ignore_barcodes) = @_;
1828
1829     unless (-e $device_name) {
1830         return Amanda::Changer->make_error("fatal", undef,
1831             message => "'$device_name' not found");
1832     }
1833
1834     return bless {
1835         # This object uses a big lock to block *all* operations, not just mtx
1836         # invocations.  This allows us to add delays to certain operations, while still
1837         # holding the lock.
1838         lock => [],
1839         device_name => $device_name,
1840         mtx => $mtx,
1841         ignore_barcodes => $ignore_barcodes,
1842     }, $class;
1843 }
1844
1845 sub inquiry {
1846     my $self = shift;
1847     my ($inquiry_cb) = @_;
1848
1849     synchronized($self->{'lock'}, $inquiry_cb, sub {
1850         my ($inquiry_cb) = @_;
1851         my $sys_cb = make_cb(sys_cb => sub {
1852             my ($exitstatus, $output) = @_;
1853             if ($exitstatus != 0) {
1854                 return $inquiry_cb->("error from mtx: " . $output, {});
1855             } else {
1856                 my %info;
1857                 for my $line (split '\n', $output) {
1858                     if (my ($k, $v) = ($line =~ /^(.*):\s*(.*)$/)) {
1859                         $v =~ s/^'(.*)'$/$1/;
1860                         $v =~ s/\s*$//;
1861                         $info{lc $k} = $v;
1862                     }
1863                 }
1864                 return $inquiry_cb->(undef, \%info);
1865             }
1866
1867         });
1868         $self->_run_system_command($sys_cb,
1869             $self->{'mtx'}, "-f", $self->{'device_name'}, 'inquiry');
1870     });
1871 }
1872
1873 sub status {
1874     my $self = shift;
1875     my ($status_cb) = @_;
1876
1877     synchronized($self->{'lock'}, $status_cb, sub {
1878         my ($status_cb) = @_;
1879
1880         my $sys_cb = make_cb(sys_cb => sub {
1881             my ($exitstatus, $output) = @_;
1882             if ($exitstatus != 0) {
1883                 my $err = $output;
1884                 # if it's a regular SCSI error, just show the sense key
1885                 my ($sensekey) = ($err =~ /mtx: Request Sense: Sense Key=(.*)\n/);
1886                 $err = "SCSI error; Sense Key=$sensekey" if $sensekey;
1887                 return $status_cb->("error from mtx: " . $err, {});
1888             } else {
1889                 my %status;
1890                 for my $line (split '\n', $output) {
1891                     my ($slot, $ie, $slinfo);
1892
1893                     # drives (data transfer elements)
1894                     if (($slot, $slinfo) = ($line =~
1895                                 /^Data Transfer Element\s*(\d+)?\s*:\s*(.*)/i)) {
1896                         # assume 0 when not given a drive #
1897                         $slot = 0 unless defined $slot;
1898                         if ($slinfo =~ /^Empty/i) {
1899                             $status{'drives'}->{$slot} = undef;
1900                         } elsif ($slinfo =~ /^Full/i) {
1901                             my ($barcode, $orig_slot);
1902                             ($barcode) = ($slinfo =~ /:VolumeTag\s*=\s*(\S+)/i);
1903                             ($orig_slot) = ($slinfo =~ /\(Storage Element (\d+) Loaded\)/i);
1904                             $status{'drives'}->{$slot} = {
1905                                 barcode => $barcode,
1906                                 orig_slot => $orig_slot,
1907                             };
1908                         }
1909
1910                     # slots (storage elements)
1911                     } elsif (($slot, $ie, $slinfo) = ($line =~
1912                                 /^\s*Storage Element\s*(\d+)\s*(IMPORT\/EXPORT)?\s*:\s*(.*)/i)) {
1913                         $ie = $ie? 1 : 0;
1914                         if ($slinfo =~ /^Empty/i) {
1915                             $status{'slots'}->{$slot} = {
1916                                 empty => 1,
1917                                 ie => $ie,
1918                             };
1919                         } elsif ($slinfo =~ /^Full/i) {
1920                             my $barcode;
1921                             ($barcode) = ($slinfo =~ /:VolumeTag\s*=\s*(\S+)/i)
1922                                 unless ($self->{'ignore_barcodes'});
1923                             $status{'slots'}->{$slot} = {
1924                                 barcode => $barcode,
1925                                 ie => $ie,
1926                             };
1927                         }
1928                     }
1929                 }
1930
1931                 return $status_cb->(undef, \%status);
1932             }
1933
1934         });
1935         my @nobarcode = ('nobarcode') if $self->{'ignore_barcodes'};
1936         $self->_run_system_command($sys_cb,
1937             $self->{'mtx'}, "-f", $self->{'device_name'}, @nobarcode, 'status');
1938     });
1939 }
1940
1941 sub load {
1942     my $self = shift;
1943     my ($slot, $drive, $finished_cb, $un) = @_;
1944
1945     synchronized($self->{'lock'}, $finished_cb, sub {
1946         my ($finished_cb) = @_;
1947
1948         my $sys_cb = make_cb(sys_cb => sub {
1949             my ($exitstatus, $output) = @_;
1950             if ($exitstatus != 0) {
1951                 return $finished_cb->("error from mtx: " . $output);
1952             } else {
1953                 return $finished_cb->(undef);
1954             }
1955
1956         });
1957
1958         $self->_run_system_command($sys_cb,
1959             $self->{'mtx'}, "-f", $self->{'device_name'},
1960                             $un? 'unload':'load', $slot, $drive);
1961     });
1962 }
1963
1964 sub unload {
1965     my $self = shift;
1966     my ($drive, $slot, $finished_cb) = @_;
1967     return $self->load($slot, $drive, $finished_cb, 1);
1968 }
1969
1970 sub transfer {
1971     my $self = shift;
1972     my ($src_slot, $dst_slot, $finished_cb) = @_;
1973
1974     synchronized($self->{'lock'}, $finished_cb, sub {
1975         my ($finished_cb) = @_;
1976
1977         my $sys_cb = make_cb(sys_cb => sub {
1978             my ($exitstatus, $output) = @_;
1979             if ($exitstatus != 0) {
1980                 return $finished_cb->("error from mtx: " . $output);
1981             } else {
1982                 return $finished_cb->(undef);
1983             }
1984
1985         });
1986         $self->_run_system_command($sys_cb,
1987             $self->{'mtx'}, "-f", $self->{'device_name'},
1988                             'transfer', $src_slot, $dst_slot);
1989     });
1990 }
1991
1992 # Run 'mtx' and capture the output.  Standard output and error
1993 # are lumped together.
1994 #
1995 # @param $sys_cb: called with ($exitstatus, $output)
1996 # @param @args: args to pass to exec()
1997 sub _run_system_command {
1998     my ($self, $sys_cb, @args) = @_;
1999
2000     debug("invoking " . join(" ", @args));
2001
2002     my ($readfd, $writefd) = POSIX::pipe();
2003     if (!defined($writefd)) {
2004         die("Error creating pipe: $!");
2005     }
2006
2007     my $pid = fork();
2008     if (!defined($pid) or $pid < 0) {
2009         die("Can't fork to run changer script: $!");
2010     }
2011
2012     if (!$pid) {
2013         ## child
2014
2015         # get our file-handle house in order
2016         POSIX::close($readfd);
2017         POSIX::dup2($writefd, 1);
2018         POSIX::dup2($writefd, 2);
2019         POSIX::close($writefd);
2020
2021         %ENV = Amanda::Util::safe_env();
2022
2023         { exec { $args[0] } @args; } # braces protect against warning
2024         exit 127;
2025     }
2026
2027     ## parent
2028
2029     # clean up file descriptors from the fork
2030     POSIX::close($writefd);
2031
2032     # the callbacks that follow share these lexical variables
2033     my $child_eof = 0;
2034     my $child_output = '';
2035     my $child_dead = 0;
2036     my $child_exit_status = 0;
2037     my ($fdsrc, $cwsrc);
2038     my $open_sources = 0;
2039
2040     my $steps = define_steps
2041         cb_ref => \$sys_cb;
2042
2043     step setup => sub {
2044         $open_sources++;
2045         Amanda::MainLoop::fd_source($readfd, $G_IO_IN | $G_IO_ERR | $G_IO_HUP)
2046             ->set_callback($steps->{'fd_source_cb'});
2047
2048         $open_sources++;
2049         Amanda::MainLoop::child_watch_source($pid)
2050             ->set_callback($steps->{'child_watch_source_cb'});
2051     };
2052
2053     step immediate => 1,
2054          fd_source_cb => sub {
2055         my ($fdsrc) = @_;
2056         my ($len, $bytes);
2057         $len = POSIX::read($readfd, $bytes, 1024);
2058
2059         # if we got an EOF, shut things down.
2060         if ($len == 0) {
2061             $child_eof = 1;
2062             POSIX::close($readfd);
2063             $fdsrc->remove();
2064             $fdsrc = undef; # break a reference loop
2065             $steps->{'maybe_finished'}->();
2066         } else {
2067             # otherwise, just keep the bytes
2068             $child_output .= $bytes;
2069         }
2070     };
2071
2072     step immediate => 1,
2073          child_watch_source_cb => sub {
2074         my ($cwsrc, $got_pid, $got_status) = @_;
2075         $cwsrc->remove();
2076         $cwsrc = undef; # break a reference loop
2077         $child_dead = 1;
2078         $child_exit_status = $got_status;
2079
2080         $steps->{'maybe_finished'}->();
2081     };
2082
2083     step maybe_finished => sub {
2084         return if --$open_sources;
2085
2086         # everything is finished -- process the results and invoke the callback
2087         chomp $child_output;
2088
2089         # let the callback take care of any further interpretation
2090         my $exitval = POSIX::WEXITSTATUS($child_exit_status);
2091         $sys_cb->($exitval, $child_output);
2092     };
2093 }
2094
2095 1;