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

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