1 # Copyright (c) 2006 Zmanda Inc. All Rights Reserved.
3 # This program is free software; you can redistribute it and/or modify it
4 # under the terms of the GNU General Public License version 2 as published
5 # by the Free Software Foundation.
7 # This program 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 General Public License
12 # You should have received a copy of the GNU General Public License along
13 # with this program; if not, write to the Free Software Foundation, Inc.,
14 # 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
16 # Contact information: Zmanda Inc, 505 N Mathlida Ave, Suite 120
17 # Sunnyvale, CA 94085, USA, or: http://www.zmanda.com
19 package Amanda::Changer;
24 @ISA = qw( Exporter );
27 reset clean eject label
28 query loadslot find scan
33 use Amanda::Device qw( :constants );
34 use Amanda::Config qw( :getconf );
38 Amanda::Changer -- interface to changer scripts
44 my ($error, $slot) = Amanda::Changer::reset();
46 my ($nslots, $curslot, $backwards, $searchable) = Amanda::Changer::query();
48 my ($tpslot, $tpdevice) = Amanda::Changer::find("TAPE018");
51 my ($slot, $device, $error) = @_;
52 if (!$error) print "Slot $slot: $device\n";
55 Amanda::Changer::scan(\&slot_callback);
63 All of these functions return an array of values, beginning with
64 C<$error>, and containing any other results appropriate to the
67 The functions C<croak()> in the event of a serious error (problems
68 running the changer script, or an exit status of 2 or higher).
69 "Benign" errors, corresponding to an exit status of 1 or a slot named
70 "<error>", result in the return of a single-element array containing
71 the error message. Error-handling for calls can be written
73 C<$error> and C<$slot>. The first is false unless a "benign"
74 error, such as a positioning error, has occurred, in which case it
75 contains the message from the changer script, and the other results
76 are undefined. C<$slot> is the first word returned from the changer
77 script, and is usually a number, but occasionally a string such as
84 my ($error, $slot) = reset();
86 Resets the tape changer, if supported, by calling
92 my ($error, $slot) = clean();
94 Triggers a cleaning cycle, if supported, by calling
100 my ($error, $slot) = eject();
102 Ejects the tape in the current slot, if supported, by calling
108 my ($error) = label($label);
110 Inform the changer that the tape in the current slot is labeled C<$label>. Calls
112 $tpchanger -label $label
116 my ($error, $slot, $nslots, $backwards, $searchable) = query();
118 Query the changer to determine the current slot (C<$slot>), the
119 number of slots (C<$nslots>), whether it can move backward through tapes
120 (C<$backwards>), and whether it is searchable (that is, has a barcode
121 reader; C<$searchable>). A changer which cannot move backward through
122 tapes is also known as a gravity feeder.
130 my ($error, $slot, $device) = loadslot($desired_slot);
132 Load the tape in the given slot, returning its slot and device.
133 C<$desired_slot> can be a numeric slot number or one of the symbolic
134 names defined by the changer API, e.g., "next", "current", or "first".
136 $tpchanger -slot $slot
140 my ($error, $tpslot, $tpdevice) = Amanda::Changer::find($label);
142 Search the changer for a tape with the given label, returning with
143 C<$tpslot = "<none>"> if the given label is not found.
145 If the changer is searchable, this function calls
147 $tpchanger -search $label
149 Otherwise it scans all slots in order, beginning with the current slot,
150 until it finds one with a label equal to C<$label> or exhausts all
151 slots. Note that it is considered a fatal error if the label is not
156 my ($error) = Amanda::Changer::scan(\&slot_callback);
158 Call C<slot_callback> for all slots, beginning with the current slot,
159 until C<slot_callback> returns a nonzero value or all slots are
160 exhausted. C<slot_callback> gets three arguments: a slot number, a
161 device name for that slot, and a boolean value which is true if the
162 changer successfully loaded the slot.
167 my ($error, $slot, $rest) = run_tpchanger("-reset");
168 return ($error) if $error;
174 my ($error, $slot, $rest) = run_tpchanger("-clean");
175 return ($error) if $error;
181 my ($error, $slot, $rest) = run_tpchanger("-eject");
182 return ($error) if $error;
190 my ($error, $slot, $rest) = run_tpchanger("-label", $label);
191 return ($error) if $error;
197 my ($error, $slot, $rest) = run_tpchanger("-info");
198 return ($error) if $error;
200 # old, unsearchable changers don't return the third result, so it's optional in the regex
201 $rest =~ /(\d+) (\d+) ?(\d+)?/ or croak("Malformed response from changer -seek: $rest");
203 # return array: error, nslots, curslot, backwards, searchable
204 return (0, $slot, $1, $2, $3?1:0);
208 my ($desired_slot) = @_;
210 my ($error, $slot, $rest) = run_tpchanger("-slot", $desired_slot);
211 return ($error) if $error;
213 return (0, $slot, $rest);
219 my ($error, $curslot, $nslots, $backwards, $searchable) = query();
220 return ($error) if $error;
223 # search using the barcode reader, etc.
224 my ($error, $slot, $rest) = run_tpchanger("-search", $label);
225 return ($error) if $error;
226 return ($error, $slot, $rest);
228 # search manually, starting with "current"
229 my $slotstr = "current";
230 for (my $checked = 0; $checked < $nslots; $checked++) {
231 my ($error, $slot, $rest) = run_tpchanger("-slot", $slotstr);
234 # ignore "benign" errors
237 my $device = Amanda::Device->new($rest);
239 next if ($device->read_label() != $READ_LABEL_STATUS_SUCESS);
242 if ($device->{'volume_label'} eq $label) {
243 return (0, $slot, $rest);
247 croak("Label $label not found in any slot");
252 my ($slot_callback) = @_;
254 my ($error, $curslot, $nslots, $backwards, $searchable) = query();
255 return ($error) if $error;
257 my $slotstr = "current";
259 for (my $checked = 0; $checked < $nslots; $checked++) {
260 my ($error, $slot, $rest) = run_tpchanger("-slot", $slotstr);
264 $done = $slot_callback->(undef, undef, $error);
266 $done = $slot_callback->($slot, $rest, 0);
275 # Internal-use function to actually invoke a changer script and parse
276 # its output. If the script's exit status is neither 0 nor 1, or if an error
277 # occurs running the script, then run_tpchanger croaks with the error message.
279 # @params @args: command-line arguments to follow the name of the changer
280 # @returns: array ($error, $slot, $rest), where $error is an error message if
281 # a benign error occurred, or 0 if no error occurred
285 # get the tape changer and extend it to a full path
286 my $tapechanger = getconf($CNF_TPCHANGER);
287 if ($tapechanger !~ qr(^/)) {
288 $tapechanger = "$amlibexecdir/$tapechanger";
291 my $pid = open(my $child, "-|");
292 if (!defined($pid)) {
293 croak("Can't fork to run changer script: $!");
299 # cd into the config dir, if one exists
300 # TODO: construct a "fake" config dir including any "-o" overrides
301 my $config_dir = Amanda::Config::get_config_dir();
303 if (!chdir($config_dir)) {
304 print "<error> Could not chdir to '$config_dir'\n";
309 %ENV = Amanda::Util::safe_env();
311 exec { $tapechanger } $tapechanger, @args or
312 print "<error> Could not exec $tapechanger: $!\n";
317 my @child_output = <$child>;
319 # close the child and get its exit status
321 if (!close($child)) {
323 croak("Error running changer script: $!");
330 croak("Malformed output from changer script -- no output")
331 if (@child_output < 1);
332 croak("Malformed output from changer script -- too many lines")
333 if (@child_output > 1);
334 croak("Malformed output from changer script: '$child_output[0]'")
335 if ($child_output[0] !~ /\s*([^\s]+)\s+(.+)?/);
336 my ($slot, $rest) = ($1, $2);
338 if ($child_exit == 0) {
339 return (0, $slot, $rest);
340 } elsif (POSIX::WIFEXITED($child_exit) && POSIX::WEXITSTATUS($child_exit) == 1) {
341 return ($rest); # non-fatal error
343 croak("Fatal error from changer script: $rest");