X-Git-Url: https://git.gag.com/?a=blobdiff_plain;f=perl%2FAmanda%2FChanger%2Fcompat.pm;h=c57417b62a049182f1c06b9c79d5b70251dd3572;hb=fd48f3e498442f0cbff5f3606c7c403d0566150e;hp=4b0028b6a4d2d510f220518adeb0df7722c4a74e;hpb=96f35b20267e8b1a1c846d476f27fcd330e0b018;p=debian%2Famanda

diff --git a/perl/Amanda/Changer/compat.pm b/perl/Amanda/Changer/compat.pm
index 4b0028b..c57417b 100644
--- a/perl/Amanda/Changer/compat.pm
+++ b/perl/Amanda/Changer/compat.pm
@@ -1,20 +1,20 @@
-# Copyright (c) 2005-2008 Zmanda, Inc.  All Rights Reserved.
+# Copyright (c) 2008, 2009, 2010 Zmanda, Inc.  All Rights Reserved.
 #
-# This library is free software; you can redistribute it and/or modify it
-# under the terms of the GNU Lesser General Public License version 2.1 as
-# published by the Free Software Foundation.
+# This program is free software; you can redistribute it and/or modify it
+# under the terms of the GNU General Public License version 2 as published
+# by the Free Software Foundation.
 #
-# This library is distributed in the hope that it will be useful, but
+# This program is distributed in the hope that it will be useful, but
 # WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
-# or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Lesser General Public
-# License for more details.
+# or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
+# for more details.
 #
-# You should have received a copy of the GNU Lesser General Public License
-# along with this library; if not, write to the Free Software Foundation,
-# Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307 USA.
+# You should have received a copy of the GNU General Public License along
+# with this program; if not, write to the Free Software Foundation, Inc.,
+# 59 Temple Place, Suite 330, Boston, MA  02111-1307 USA
 #
-# Contact information: Zmanda Inc., 465 S Mathlida Ave, Suite 300
-# Sunnyvale, CA 94086, USA, or: http://www.zmanda.com
+# Contact information: Zmanda Inc., 465 S. Mathilda Ave., Suite 300
+# Sunnyvale, CA 94085, USA, or: http://www.zmanda.com
 
 package Amanda::Changer::compat;
 
@@ -32,6 +32,7 @@ use Amanda::Config qw( :getconf );
 use Amanda::Debug qw( debug );
 use Amanda::Device qw( :constants );
 use Amanda::Changer;
+use Amanda::MainLoop;
 
 =head1 NAME
 
@@ -39,42 +40,55 @@ Amanda::Changer::compat -- run "old" changer scripts
 
 =head1 DESCRIPTION
 
-This package, calls through to old Changer API shell scripts using the new API.
-If necessary, this writes temporary configurations under C<$AMANDA_TMPDIR> and
+This package calls through to old Changer API shell scripts using the new API.
+If necessary, it writes temporary configurations under C<$AMANDA_TMPDIR> and
 invokes the changer there, allowing multiple distinct changers to run within
 the same Amanda process.
 
-=head1 TODO
+See the amanda-changers(7) manpage for usage information.
+
+=head2 NOTE
 
 In-process reservations are handled correctly - only one device may be used at
 a time.  However, the underlying scripts do not support reservations, so
 another application can easily run the script and change the current device.
 Caveat emptor.
 
-Concurrent _run_tpchanger invocations are currently forbidden with a die() --
-that should change to a simple FIFO queue of tpchanger invocations to make.
-
-Clean out old changer temporary directories on object destruction.
-
-Support 'update'
-
 =cut
 
+# TODO
+# Clean out old changer temporary directories on object destruction.
+
 sub new {
     my $class = shift;
-    my ($cc, $tpchanger) = @_;
+    my ($config, $tpchanger) = @_;
     my ($script) = ($tpchanger =~ /chg-compat:(.*)/);
 
+    unless (-e $script) {
+	$script = "$amlibexecdir/$script";
+    }
+
+    if (! -x $script) {
+	return Amanda::Changer->make_error("fatal", undef,
+	    message => "'$script' is not executable");
+    }
+
     my $self = {
         script => $script,
+	config => $config,
 	reserved => 0,
 	nslots => undef,
 	backwards => undef,
 	searchable => undef,
+	lock => [],
+	got_info => 0,
+	info_lock => [],
     };
     bless ($self, $class);
 
-    $self->_make_cfg_dir($cc);
+    $self->_make_cfg_dir($config);
+
+    debug("$class initialized with script $script, temporary directory $self->{cfg_dir}");
 
     return $self;
 }
@@ -83,135 +97,232 @@ sub load {
     my $self = shift;
     my %params = @_;
 
-    die "no callback supplied" unless (exists $params{'res_cb'});
-    my $cb = $params{'res_cb'};
+    $self->validate_params('load', \%params);
+    return if $self->check_error($params{'res_cb'});
 
     if ($self->{'reserved'}) {
-	$cb->("Changer is already reserved: '" . $self->{'reserved'} . "'", undef);
-	return;
+	return $self->make_error("failed", $params{'res_cb'},
+	    reason => "driveinuse",
+	    message => "Changer is already reserved: '" . $self->{'reserved'}->device_name . "'");
     }
 
+    my $steps = define_steps
+	cb_ref => \$params{'res_cb'};
+
     # make sure the info is loaded, and re-call load() if we have to wait
-    if (!defined($self->{'nslots'})) {
-	$self->_get_info(
-	    sub {
-                my ($err) = @_;
-		$self->load(%params);
-	    },
-	    sub {
-		my ($msg) = @_;
-		$cb->($msg, undef);
-	    });
-	return;
-    }
+    step get_info => sub {
+	$self->_get_info($steps->{'got_info'});
+    };
 
-    my $run_success_cb = sub {
-        my ($slot, $rest) = @_;
-        my $res = Amanda::Changer::compat::Reservation->new($self, $slot, $rest);
-        $cb->(undef, $res);
+    step got_info => sub {
+	my ($exitval, $message) = @_;
+	if (defined $exitval) { # error
+	    # this is always fatal - we can't load without info
+	    return $self->make_error("fatal", $params{'res_cb'},
+		message => $message);
+	}
+
+	$steps->{'start_load'}->();
     };
-    my $run_fail_cb = sub {
-        my ($exitval, $message) = @_;
-        $cb->($message, undef);
+
+    step start_load => sub {
+	if (exists $params{'label'}) {
+	    if ($self->{'searchable'}) {
+		$self->_run_tpchanger($steps->{'load_run_done'}, "-search", $params{'label'});
+	    } else {
+		# not searchable -- run a manual scan
+		$self->_manual_scan(%params);
+	    }
+	} elsif (exists $params{'relative_slot'}) {
+	    # if there is an explicit $slot, then just hope it's the same as the current
+	    # slot, or we're in trouble.  We don't know what the current slot is, so we
+	    # can't verify, but the current slot is set on *every* load, so this works.
+
+	    # if we've already seen nslots slots, then the next slot is
+	    # certainly one of them, so the iteration should terminate.
+	    # However, not all changers will return nslots distinct slots
+	    # (chg-zd-mtx skips empty slots, for example), so we will need to
+	    # protect against except_slots in other ways, too.
+	    if (exists $params{'except_slots'} and (keys %{$params{'except_slots'}}) == $self->{'nslots'}) {
+		return $self->make_error("failed", $params{'res_cb'},
+		    reason => 'notfound',
+		    message => "all slots have been loaded");
+	    }
+
+	    $self->_run_tpchanger($steps->{'load_run_done'}, "-slot", $params{'relative_slot'});
+	} elsif (exists $params{'slot'}) {
+	    $self->_run_tpchanger($steps->{'load_run_done'}, "-slot", $params{'slot'});
+	}
     };
 
-    if (exists $params{'label'}) {
-        if ($self->{'searchable'}) {
-            $self->_run_tpchanger($run_success_cb, $run_fail_cb, "-search", $params{'label'});
-        } else {
-            # not searchable -- run a manual scan
-            $self->_manual_scan(%params);
-        }
-    } elsif (exists $params{'slot'}) {
-        $self->_run_tpchanger($run_success_cb, $run_fail_cb, "-slot", $params{'slot'});
-    }
+    step load_run_done => sub {
+	my ($exitval, $slot, $rest) = @_;
+	if ($exitval == 0) {
+	    if (!$rest) {
+		return $self->make_error("fatal", $params{'res_cb'},
+		    message => "changer script did not provide a device name");
+	    }
+	} elsif ($exitval >= 2) {
+		return $self->make_error("fatal", $params{'res_cb'},
+		    message => $rest);
+	} else {
+	    return $self->make_error("failed", $params{'res_cb'},
+		reason => "notfound",
+		message => $rest);
+	}
+
+	# re-check except_slots, and return 'notfound' if we've loaded a
+	# forbidden slot.  This will generally happen when scanning, and when
+	# the underlying changer script has "skipped" some slots and looped
+	# around earlier than we expected.
+	if (exists $params{'except_slots'} and exists $params{'except_slots'}{$slot}) {
+	    return $self->make_error("failed", $params{'res_cb'},
+		reason => 'notfound',
+		message => "all slots have been loaded");
+	}
+
+	return $self->_make_res($params{'res_cb'}, $slot, $rest, undef);
+    };
 }
 
 sub _manual_scan {
     my $self = shift;
     my %params = @_;
     my $nchecked = 0;
-    my ($run_success_cb, $run_fail_cb, $load_next);
+    my ($get_info, $got_info, $run_cb, $load_next);
+    my $first_scanned_slot = -1;
+
+    my $user_msg_fn = $params{'user_msg_fn'};
+    $user_msg_fn ||= sub { Amanda::Debug::info("chg-compat: " . $_[0]); };
 
     # search manually, starting with "current" and proceeding through nslots-1
-    # loads of "next"
+    # loads of "next".  This doesn't use the except_slots iteration mechanism as
+    # that would just add extra layers of complexity with no benefit
 
-    # TODO: support the case where nslots == -1
+    $get_info = sub {
+	$self->_get_info($got_info);
+    };
 
-    $run_success_cb = sub {
-        my ($slot, $rest) = @_;
+    $got_info = sub {
+	$user_msg_fn->("beginning manual scan of $self->{nslots} slots");
+	$self->_run_tpchanger($run_cb, "-slot", "current");
+    };
+    $run_cb = sub {
+        my ($exitval, $slot, $rest) = @_;
 
-	my $device = Amanda::Device->new($rest);
-	if ($device and $device->configure(1)
-		    and $device->read_label() == $DEVICE_STATUS_SUCCESS
-		    and $device->volume_label() eq $params{'label'}) {
-            # we found the correct slot
-	    my $res = Amanda::Changer::compat::Reservation->new($self, $slot, $rest);
-            Amanda::MainLoop::call_later($params{'res_cb'}, undef, $res);
-            return;
-        }
+	if ($slot == $first_scanned_slot) {
+	    $nchecked = $self->{'nslots'};
+	    return $load_next->();
+	}
 
-        $load_next->();
-    };
+	$first_scanned_slot = $slot if $first_scanned_slot == -1;
 
-    $run_fail_cb = sub {
-	my ($exitval, $message) = @_;
+	$user_msg_fn->("updated slot $slot");
+	if ($exitval == 0) {
+	    # if we're looking for a label, check what we got
+	    if (defined $params{'label'}) {
+		my $device = Amanda::Device->new($rest);
+		if ($device and $device->configure(1)
+			    and $device->read_label() == $DEVICE_STATUS_SUCCESS
+			    and $device->volume_label() eq $params{'label'}) {
+		    # we found the correct slot
+		    $self->_make_res($params{'res_cb'}, $slot, $rest, $device);
+		    return;
+		}
+	    }
+
+	    return $load_next->();
+	} else {
+	    # don't continue scanning after a fatal error
+	    if ($exitval >= 2) {
+		return $self->make_error("fatal", $params{'res_cb'},
+		    message => $rest);
+	    }
 
-	# don't continue scanning after a fatal error
-        if ($exitval > 1) {
-	    Amanda::MainLoop::call_later($params{'res_cb'}, $message, undef);
-	    return;
+	    return $load_next->();
 	}
-
-	$load_next->();
     };
 
     $load_next = sub {
 	# if we've scanned all nslots, we haven't found the label.
         if (++$nchecked >= $self->{'nslots'}) {
-            Amanda::MainLoop::call_later($params{'res_cb'},
-                    "Volume '$params{label}' not found", undef);
-            return;
+	    if (defined $params{'label'}) {
+		return $self->make_error("failed", $params{'res_cb'},
+		    reason => "notfound",
+		    message => "Volume '$params{label}' not found");
+	    } else {
+		return $params{'res_cb'}->(undef, undef);
+	    }
 	}
 
-	$self->_run_tpchanger($run_success_cb, $run_fail_cb, "-slot", "next");
+	$self->_run_tpchanger($run_cb, "-slot", "next");
     };
 
-    $self->_run_tpchanger($run_success_cb, $run_fail_cb, "-slot", "current");
+    $get_info->();
 }
 
-sub info {
+# takes $res_cb, $slot and $rest; creates and configures the device, and calls
+# $res_cb with the results.
+sub _make_res {
     my $self = shift;
-    my %params = @_;
-    my %results;
+    my ($res_cb, $slot, $rest, $device) = @_;
+    my $res;
+
+    if (!defined $device) {
+	$device = Amanda::Device->new($rest);
+	if ($device->status != $DEVICE_STATUS_SUCCESS) {
+	    return $self->make_error("failed", $res_cb,
+		    reason => "device",
+		    message => "opening '$rest': " . $device->error_or_status());
+	}
+    }
 
-    die "no info_cb supplied" unless (exists $params{'info_cb'});
-    die "no info supplied" unless (exists $params{'info'});
-
-    # make sure the info is loaded, and re-call info() if we have to wait
-    if (!defined($self->{'nslots'}) && grep(/^num_slots$/, @{$params{'info'}})) {
-	$self->_get_info(
-	    sub {
-                my ($err) = @_;
-		$self->info(%params);
-	    },
-	    sub {
-		my ($msg) = @_;
-		$params{'info_cb'}->($msg);
-	    });
-	return;
+    if (my $err = $self->{'config'}->configure_device($device)) {
+	return $self->make_error("failed", $res_cb,
+		reason => "device",
+		message => $err);
     }
 
-    # ok, info is loaded, so call back with the results
-    for my $inf (@{$params{'info'}}) {
-        if ($inf eq 'num_slots') {
-            $results{$inf} = $self->{'nslots'};
-        } else {
-            warn "Ignoring request for info key '$inf'";
-        }
+    $res = Amanda::Changer::compat::Reservation->new($self, $slot, $device);
+    $device->read_label();
+
+    $res_cb->(undef, $res);
+}
+
+sub info_setup {
+    my $self = shift;
+    my %params = @_;
+
+    $self->_get_info(sub {
+	my ($exitval, $message) = @_;
+	if (defined $exitval) { # error
+	    if ($exitval >= 2) {
+		return $self->make_error("fatal", $params{'finished_cb'},
+		    message => $message);
+	    } else {
+		return $self->make_error("failed", $params{'finished_cb'},
+		    reason => "notfound",
+		    message => $message);
+	    }
+	}
+
+	# no error, so we're done with setup
+	$params{'finished_cb'}->();
+    });
+}
+
+sub info_key {
+    my $self = shift;
+    my ($key, %params) = @_;
+    my %results;
+
+    if ($key eq 'num_slots') {
+	$results{$key} = $self->{'nslots'};
+    } elsif ($key eq 'fast_search') {
+	$results{$key} = $self->{'searchable'};
     }
 
-    Amanda::MainLoop::call_later($params{'info_cb'}, undef, %results);
+    $params{'info_cb'}->(undef, %results) if $params{'info_cb'};
 }
 
 # run a simple op -- no arguments, no slot returned
@@ -220,21 +331,24 @@ sub _simple_op {
     my $op = shift;
     my %params = @_;
 
-    Amanda::Debug::debug("running simple op '$op'");
-    my $run_success_cb = sub {
-	Amanda::Debug::debug("simple op '$op' ok");
-        if (exists $params{'finished_cb'}) {
-            $params{'finished_cb'}->(undef);
-        }
-    };
-    my $run_fail_cb = sub {
-	my ($exitval, $message) = @_;
-	Amanda::Debug::debug("simple op '$op' failed: $message");
-        if (exists $params{'finished_cb'}) {
-            $params{'finished_cb'}->($message);
-        }
+    my $run_cb = sub {
+	my ($exitval, $slot, $rest) = @_;
+	if ($exitval == 0) {
+	    if (exists $params{'finished_cb'}) {
+		$params{'finished_cb'}->(undef);
+	    }
+	} else {
+	    if ($exitval >= 2) {
+		return $self->make_error("fatal", $params{'finished_cb'},
+		    message => $rest);
+	    } else {
+		return $self->make_error("failed", $params{'finished_cb'},
+		    reason => "unknown",
+		    message => $rest);
+	    }
+	}
     };
-    $self->_run_tpchanger($run_success_cb, $run_fail_cb, "-$op");
+    $self->_run_tpchanger($run_cb, "-$op");
 }
 
 sub reset {
@@ -264,51 +378,84 @@ sub update {
     my $self = shift;
     my %params = @_;
 
-    # TODO: not implemented
-    # -- need to shuffle the driver over every slot
-    if (exists $params{'finished_cb'}) {
-	$params{'finished_cb'}->(undef);
+    if ($params{'changed'}) {
+	return $self->make_error("failed", $params{'finished_cb'},
+	    reason => 'invalid',
+	    message => 'chg-compat does not support specifying what has changed');
     }
+
+    my $scan_done_cb = make_cb(scan_done_cb => sub {
+	my ($err, $res) = @_;
+	if ($err) {
+	    return $params{'finished_cb'}->($err);
+	}
+
+	# we didn't search for a label, so we don't get a reservation
+	$params{'finished_cb'}->(undef);
+    });
+
+    # for compat changers, "update" just entails scanning the whole changer
+    $self->_manual_scan(
+	res_cb => $scan_done_cb,
+	label => undef, # search forever
+	user_msg_fn => $params{'user_msg_fn'},
+    );
 }
 
-# Internal function to call the script's -info, store the results in $self, and
-# call either $success_cb (with no arguments) or $error_cb (with an error
-# message).
+# Internal function to call the script's -info and store the results in $self.
+# If this returns true, then the info is loaded; otherwise, got_info_cb will be
+# called either with no arguments (success) or ($exitval, $message) on error.
 sub _get_info {
-    my ($self, $success_cb, $error_cb) = @_;
+    my ($self, $got_info_cb) = @_;
 
-    my $run_success_cb = sub {
-	my ($slot, $rest) = @_;
-	# old, unsearchable changers don't return the third result, so it's
-	# optional in the regex
-	$rest =~ /(\d+) (\d+) ?(\d+)?/ or
-	    croak("Malformed response from changer -info: $rest");
+    Amanda::MainLoop::synchronized($self->{'info_lock'}, $got_info_cb, sub {
+	my ($got_info_cb) = @_;
 
-	$self->{'nslots'} = $1;
-	$self->{'backward'} = $2;
-	$self->{'searchable'} = $3? 1:0;
+	# if we've already got info, just call back right away
+	if ($self->{'got_info'}) {
+	    return $got_info_cb->();
+	}
 
-	$success_cb->();
-    };
-    my $run_fail_cb = sub {
-	my ($exitval, $message) = @_;
-	$error_cb->($message);
-    };
-    $self->_run_tpchanger($run_success_cb, $run_fail_cb, "-info");
+	my $run_cb = sub {
+	    my ($exitval, $slot, $rest) = @_;
+	    if ($exitval == 0) {
+		# old, unsearchable changers don't return the third result, so it's
+		# optional in the regex
+		unless ($rest =~ /(\d+) (\d+) ?(\d+)?/) {
+		    return $got_info_cb->(2,
+			    "Malformed response from changer -info: $rest");
+		}
+
+		$self->{'nslots'} = $1;
+		$self->{'backward'} = $2;
+		$self->{'searchable'} = $3? 1:0;
+
+		$self->{'got_info'} = 1;
+		return $got_info_cb->(undef, undef);
+	    } else {
+		return $got_info_cb->($exitval, $rest);
+	    }
+	};
+
+	$self->_run_tpchanger($run_cb, "-info");
+    });
 }
 
 # Internal function to create a temporary configuration directory, which persists
 # for the duration of this changer's lifetime (and beyond, TODO)
 sub _make_cfg_dir {
-    my ($self, $cc) = @_;
+    my ($self, $config) = @_;
 
-    if (defined $cc) {
+    if ($config->{'is_global'}) {
+	# for the default changer, we don't need to invent a config..
+	$self->{'cfg_dir'} = Amanda::Config::get_config_dir();
+    } else {
 	my $cfg_name = Amanda::Config::get_config_name();
-	my $changer_name = changer_config_name($cc);
-	my $tapedev = changer_config_getconf($cc, $CHANGER_CONFIG_TAPEDEV);
-	my $tpchanger = changer_config_getconf($cc, $CHANGER_CONFIG_TPCHANGER);
-	my $changerdev = changer_config_getconf($cc, $CHANGER_CONFIG_CHANGERDEV);
-	my $changerfile = changer_config_getconf($cc, $CHANGER_CONFIG_CHANGERFILE);
+	my $changer_name = $config->{'name'};
+	my $tapedev = $config->{'tapedev'};
+	my $tpchanger = $config->{'tpchanger'};
+	my $changerdev = $config->{'changerdev'};
+	my $changerfile = $config->{'changerfile'};
 
 	my $cfg_dir = "$AMANDA_TMPDIR/Amanda::Changer::compat/$cfg_name-$changer_name";
 
@@ -347,9 +494,6 @@ sub _make_cfg_dir {
 	close $amconf;
 
 	$self->{'cfg_dir'} = $cfg_dir;
-    } else {
-	# for the default changer, we don't need to invent a config..
-	$self->{'cfg_dir'} = Amanda::Config::get_config_dir();
     }
 
 }
@@ -357,171 +501,155 @@ sub _make_cfg_dir {
 # Internal-use function to actually invoke a changer script and parse
 # its output.
 #
-# @param $success_cb: called with ($slot, $rest) on success
-# @param $failure_cb: called with ($exitval, $message) on any failure
+# @param $run_cb: called with ($exitval, $slot, $rest)
 # @params @args: command-line arguments to follow the name of the changer
-# @returns: array ($error, $slot, $rest), where $error is an error message if
-#       a benign error occurred, or 0 if no error occurred
 sub _run_tpchanger {
-    my ($self, $success_cb, $failure_cb, @args) = @_;
-
-    if ($self->{'busy'}) {
-	croak("Changer is already in use");
-    }
-
-    my ($readfd, $writefd) = POSIX::pipe();
-    if (!defined($writefd)) {
-	croak("Error creating pipe to run changer script: $!");
-    }
-
-    my $pid = fork();
-    if (!defined($pid) or $pid < 0) {
-        croak("Can't fork to run changer script: $!");
-    }
+    my ($self, $run_cb, @args) = @_;
 
-    if (!$pid) {
-        ## child
-
-	# get our file-handle house in order
-	POSIX::close($readfd);
-	POSIX::dup2($writefd, 1);
-	POSIX::close($writefd);
-
-        # cd into the config dir
-        if (!chdir($self->{'cfg_dir'})) {
-            print "<error> Could not chdir to '" . $self->{cfg_dir} . "'\n";
-            exit(2);
-        }
-
-        %ENV = Amanda::Util::safe_env();
-
-	my $script = $self->{'script'};
-        unless (-x $script) {
-            $script = "$amlibexecdir/$script";
-        }
-        { exec { $script } $script, @args; } # braces protect against warning
-
-	my $err = "<error> Could not exec $script: $!\n";
-	POSIX::write($writefd, $err, length($err));
-        exit 2;
-    }
+    Amanda::MainLoop::synchronized($self->{'lock'}, $run_cb, sub {
+	my ($run_cb) = @_;
+	debug("Amanda::Changer::compat: invoking $self->{script} with " . join(" ", @args));
 
-    ## parent
-
-    # clean up file descriptors from the fork
-    POSIX::close($writefd);
+	my ($readfd, $writefd) = POSIX::pipe();
+	if (!defined($writefd)) {
+	    croak("Error creating pipe to run changer script: $!");
+	}
 
-    # mark this object as "busy", so we can't begin another operation
-    # until this one is finished.
-    $self->{'busy'} = 1;
+	my $pid = fork();
+	if (!defined($pid) or $pid < 0) {
+	    croak("Can't fork to run changer script: $!");
+	}
 
-    # the callbacks that follow share these lexical variables
-    my $child_eof = 0;
-    my $child_output = '';
-    my $child_dead = 0;
-    my $child_exit_status = 0;
-    my ($fdsrc, $cwsrc);
-    my ($maybe_finished, $fd_source_cb, $child_watch_source_cb);
+	if (!$pid) {
+	    ## child
 
-    # Perl note: we have to use anonymous subs here, as they are instantiated
-    # at runtime, rather than at compile time.
+	    # get our file-handle house in order
+	    POSIX::close($readfd);
+	    POSIX::dup2($writefd, 1);
+	    POSIX::close($writefd);
 
-    $maybe_finished = sub {
-	return unless $child_eof;
-	return unless $child_dead;
+	    # cd into the config dir
+	    if (!chdir($self->{'cfg_dir'})) {
+		print "<error> Could not chdir to '" . $self->{cfg_dir} . "'\n";
+		exit(2);
+	    }
 
-	# everything is finished -- process the results and invoke the callback
-	chomp $child_output;
+	    %ENV = Amanda::Util::safe_env();
 
-	# mark this object as no longer busy.  This frees the
-	# object up to begin the next operation, which may happen
-	# during the invocation of the callback
-	$self->{'busy'} = 0;
+	    my $script = $self->{'script'};
+	    { exec { $script } $script, @args; } # braces protect against warning
 
-	# handle unexpected exit status as a fatal error
-	if (!POSIX::WIFEXITED($child_exit_status) || POSIX::WEXITSTATUS($child_exit_status) > 2) {
-	    $failure_cb->(POSIX::WEXITSTATUS($child_exit_status),
-		"Fatal error from changer script: ".$child_output);
-	    return;
+	    my $err = "<error> Could not exec $script: $!\n";
+	    POSIX::write($writefd, $err, length($err));
+	    exit 2;
 	}
 
-	# parse the child's output
-	my @child_output = split '\n', $child_output;
-	if (@child_output < 1) {
-	    $failure_cb->(2, "Malformed output from changer script -- no output");
-	    return;
-	}
-	if (@child_output > 1) {
-	    $failure_cb->(2, "Malformed output from changer script -- too many lines");
-	    return;
-	}
-	if ($child_output[0] !~ /\s*([^\s]+)(?:\s+(.+))?/) {
-	    $failure_cb->(2, "Malformed output from changer script: '$child_output[0]'");
-	    return;
-	}
-	my ($slot, $rest) = ($1, $2);
+	## parent
 
-	# let the callback take care of any further interpretation
-	my $exitval = POSIX::WEXITSTATUS($child_exit_status);
-	if ($exitval == 0) {
-	    $success_cb->($slot, $rest);
-	} else {
-	    $failure_cb->($exitval, $rest);
-	}
-    };
+	# clean up file descriptors from the fork
+	POSIX::close($writefd);
 
-    $fd_source_cb = sub {
-	my ($fdsrc) = @_;
-	my ($len, $bytes);
-	$len = POSIX::read($readfd, $bytes, 1024);
+	# the callbacks that follow share these lexical variables
+	my $child_eof = 0;
+	my $child_output = '';
+	my $child_dead = 0;
+	my $child_exit_status = 0;
+	my ($fdsrc, $cwsrc);
+	my ($maybe_finished, $fd_source_cb, $child_watch_source_cb);
+
+	# Perl note: we have to use anonymous subs here, as they are instantiated
+	# at runtime, rather than at compile time.
+
+	$maybe_finished = sub {
+	    return unless $child_eof;
+	    return unless $child_dead;
+
+	    # everything is finished -- process the results and invoke the callback
+	    chomp $child_output;
+
+	    # handle unexpected exit status as a fatal error
+	    if (!POSIX::WIFEXITED($child_exit_status) || POSIX::WEXITSTATUS($child_exit_status) > 2) {
+		$run_cb->(POSIX::WEXITSTATUS($child_exit_status), undef,
+		    "Fatal error from changer script: ".$child_output);
+		return;
+	    }
+
+	    # parse the child's output
+	    my @child_output = split '\n', $child_output;
+	    my $exitval = POSIX::WEXITSTATUS($child_exit_status);
+
+	    debug("Amanda::Changer::compat: Got response '$child_output' with exit status $exitval");
+	    if (@child_output < 1) {
+		$run_cb->(2, undef, "Malformed output from changer script -- no output");
+		return;
+	    }
+	    my $slotline = shift @child_output;
+	    if ($slotline !~ /\s*([^\s]+)(?:\s+(.+))?/) {
+		$run_cb->(2, undef, "Malformed output from changer script: '$slotline'");
+		return;
+	    }
+	    my ($slot, $rest) = ($1, $2);
+
+	    # append any additional lines to $rest
+	    if (@child_output) {
+		$rest .= "\n" . join("\n", @child_output);
+	    }
+
+	    # let the callback take care of any further interpretation
+	    $run_cb->($exitval, $slot, $rest);
+	};
+
+	$fd_source_cb = sub {
+	    my ($fdsrc) = @_;
+	    my ($len, $bytes);
+	    $len = POSIX::read($readfd, $bytes, 1024);
+
+	    # if we got an EOF, shut things down.
+	    if ($len == 0) {
+		$child_eof = 1;
+		POSIX::close($readfd);
+		$fdsrc->remove();
+		$fdsrc = undef; # break a reference loop
+		$maybe_finished->();
+	    } else {
+		# otherwise, just keep the bytes
+		$child_output .= $bytes;
+	    }
+	};
+	$fdsrc = Amanda::MainLoop::fd_source($readfd, $G_IO_IN | $G_IO_ERR | $G_IO_HUP);
+	$fdsrc->set_callback($fd_source_cb);
+
+	$child_watch_source_cb = sub {
+	    my ($cwsrc, $got_pid, $got_status) = @_;
+	    $cwsrc->remove();
+	    $cwsrc = undef; # break a reference loop
+	    $child_dead = 1;
+	    $child_exit_status = $got_status;
 
-	# if we got an EOF, shut things down.
-	if ($len == 0) {
-	    $child_eof = 1;
-	    POSIX::close($readfd);
-	    $fdsrc->remove();
-	    $fdsrc = undef; # break a reference loop
 	    $maybe_finished->();
-	} else {
-	    # otherwise, just keep the bytes
-	    $child_output .= $bytes;
-	}
-    };
-    $fdsrc = Amanda::MainLoop::fd_source($readfd, $G_IO_IN | $G_IO_ERR | $G_IO_HUP);
-    $fdsrc->set_callback($fd_source_cb);
-
-    $child_watch_source_cb = sub {
-	my ($cwsrc, $got_pid, $got_status) = @_;
-	$cwsrc->remove();
-	$cwsrc = undef; # break a reference loop
-	$child_dead = 1;
-	$child_exit_status = $got_status;
-
-	$maybe_finished->();
-    };
-    $cwsrc = Amanda::MainLoop::child_watch_source($pid);
-    $cwsrc->set_callback($child_watch_source_cb);
+	};
+	$cwsrc = Amanda::MainLoop::child_watch_source($pid);
+	$cwsrc->set_callback($child_watch_source_cb);
+    });
 }
 
 package Amanda::Changer::compat::Reservation;
 use vars qw( @ISA );
+use Amanda::Debug qw( debug );
 @ISA = qw( Amanda::Changer::Reservation );
 
-use Amanda::Debug qw( :logging );
-
 sub new {
     my $class = shift;
-    my ($chg, $slot, $device_name) = @_;
+    my ($chg, $slot, $device) = @_;
     my $self = Amanda::Changer::Reservation::new($class);
 
     $self->{'chg'} = $chg;
 
-    $self->{'device_name'} = $device_name;
+    $self->{'device'} = $device;
     $self->{'this_slot'} = $slot;
-    $self->{'next_slot'} = "next"; # clever, no?
 
     # mark the changer as reserved
-    $self->{'chg'}->{'reserved'} = $device_name;
+    $self->{'chg'}->{'reserved'} = $device;
 
     return $self;
 }
@@ -531,13 +659,14 @@ sub do_release {
     my %params = @_;
 
     my $finished = sub {
-	my ($msg) = @_;
+	my ($message) = @_;
 
 	$self->{'chg'}->{'reserved'} = 0;
 
-	if (exists $params{'finished_cb'}) {
-	    Amanda::MainLoop::call_later($params{'finished_cb'}, $msg);
-	}
+	# unref the device, for good measure
+	$self->{'device'} = undef;
+
+	$params{'finished_cb'}->($message) if $params{'finished_cb'};
     };
 
     if (exists $params{'eject'} && $params{'eject'}) {
@@ -555,25 +684,28 @@ sub set_label {
     # it to maintain its slotinfofile (this is a hack)
     if (!$self->{'chg'}->{'searchable'}
 	&& $self->{'chg'}->{'script'} !~ /chg-zd-mtx$/) {
-        if (exists $params{'finished_cb'}) {
-            Amanda::MainLoop::call_later($params{'finished_cb'}, undef);
-        }
+	debug("Amanda::Changer::compat - changer script is not searchable, so not invoking -label for set_label");
+        $params{'finished_cb'}->(undef) if $params{'finished_cb'};
         return;
     }
 
-    my $run_success_cb = sub {
-        if (exists $params{'finished_cb'}) {
-            Amanda::MainLoop::call_later($params{'finished_cb'}, undef);
-        }
-    };
-    my $run_fail_cb = sub {
-	my ($exitval, $message) = @_;
-        if (exists $params{'finished_cb'}) {
-            Amanda::MainLoop::call_later($params{'finished_cb'}, $message);
-        }
+    my $run_cb = sub {
+	my ($exitval, $slot, $rest) = @_;
+	if ($exitval == 0) {
+	    $params{'finished_cb'}->(undef) if $params{'finished_cb'};
+	} else {
+	    if ($exitval >= 2) {
+		return $self->{'chg'}->make_error("fatal", $params{'finished_cb'},
+		    message => $rest);
+	    } else {
+		return $self->{'chg'}->make_error("failed", $params{'finished_cb'},
+		    reason => "unknown",
+		    message => $rest);
+	    }
+	}
     };
     $self->{'chg'}->_run_tpchanger(
-        $run_success_cb, $run_fail_cb, "-label", $params{'label'});
+        $run_cb, "-label", $params{'label'});
 }
 
 1;