1 # Copyright (c) 2007-2012 Zmanda, Inc. All Rights Reserved.
3 # This program is free software; you can redistribute it and/or
4 # modify it under the terms of the GNU General Public License
5 # as published by the Free Software Foundation; either version 2
6 # of the License, or (at your option) any later version.
8 # This program is distributed in the hope that it will be useful, but
9 # WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
10 # or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
13 # You should have received a copy of the GNU General Public License along
14 # with this program; if not, write to the Free Software Foundation, Inc.,
15 # 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
17 # Contact information: Zmanda Inc., 465 S. Mathilda Ave., Suite 300
18 # Sunnyvale, CA 94085, USA, or: http://www.zmanda.com
20 package Amanda::Changer;
24 use Carp qw( confess cluck );
26 use Fcntl qw( O_RDWR O_CREAT LOCK_EX LOCK_NB );
32 use Amanda::Config qw( :getconf );
33 use Amanda::Device qw( :constants );
34 use Amanda::Debug qw( debug );
39 Amanda::Changer -- interface to changer scripts
45 my $chg = Amanda::Changer->new(); # loads the default changer; OR
46 $chg = Amanda::Changer->new("somechanger"); # references a defined changer in amanda.conf
52 my ($err, $reservation) = @_;
56 $dev = $reservation->{'device'};
61 $reservation->release(finished_cb => $start_next_volume);
68 All operations in the module return immediately, and take as an argument a
69 callback function which will indicate completion of the changer operation -- a
70 kind of continuation. The caller should run a main loop (see
71 L<Amanda::MainLoop>) to allow the interactions with the changer script to
74 A new object is created with the C<new> function as follows:
76 my $chg = Amanda::Changer->new($changer_name,
77 tapelist => $tapelist,
78 labelstr => $labelstr,
79 autolabel => $autolabel,
80 meta_autolabel => $meta_autolabel);
82 to create a named changer (a name provided by the user, either specifying a
83 changer directly or specifying a changer definition), or
85 my $chg = Amanda::Changer->new(undef,
86 tapelist => $tapelist,
87 labelstr => $labelstr,
88 autolabel => $autolabel,
89 meta_autolabel => $meta_autolabel);
91 to run the default changer. This function handles the many ways a user can
94 If there is a problem creating the new object, then the resulting object will
95 be a fatal C<Error> object (described below). Thus the usual recipe for
96 creating a new changer is
98 my $chg = Amanda::Changer->new($changer_name);
99 if ($chg->isa("Amanda::Changer::Error")) {
100 die("Error creating changer $changer_name: $chg");
103 C<tapelist> must be an Amanda::Tapelist object. It is required if you want to
104 use $chg->volume_is_labelable(), $chg->make_new_tape_label(),
105 $chg->make_new_meta_label(), $res->make_new_tape_label() or
106 $res->make_new_meta_label().
107 C<labelstr> must be like getconf($CNF_LABELSTR), that value is used if C<labelstr> is not set.
108 C<autolabel> must be like getconf($CNF_AUTOLABEL), that value is used if C<autolabel> is not set.
109 C<meta_autolabel> must be like getconf($CNF_META_AUTOLABEL), that value is used if C<meta_autolabel> is not set.
110 =head2 MEMBER VARIABLES
112 Note that these variables are not set until after the subclass constructor is
117 =item C<< $chg->{'chg_name'} >>
119 Gives the name of the changer. This name will make sense to the user, but will
120 not necessarily form a valid changer specification. It should be used to
121 describe the changer in messages to the user.
127 All changer callbacks take an error object as the first parameter. If no error
128 occurred, then this parameter is C<undef> and the remaining parameters are
131 A res_cb C<$cb> is called back as:
133 $cb->($error, undef);
135 in the event of an error, or
137 $cb->(undef, $reservation);
139 with a successful reservation. res_cb must always be specified. A finished_cb
140 C<$cb> is called back as
144 in the event of an error, or
148 on success. A finished_cb may be omitted if no notification of completion is
151 Other callback types are defined below.
155 When a callback is made with an error, it is an object of type
156 C<Amanda::Changer::Error>. When interpolated into a string, this object turns
157 into a simple error message. However, it has some additional methods that can
158 be used to determine how to respond to the error. First, the error message is
159 available explicitly as C<< $err->message >>. The error type is available as
160 C<< $err->{'type'} >>, although checks for particular error types should use
161 the C<TYPE> methods instead, as perl is better able to detect typos with this
164 if ($err->failed) { ... }
168 fatal Changer is no longer useable
169 failed Operation failed, but the changer is OK
171 The API may add other error types in the future (for example, to indicate
172 that a required resource is already reserved).
174 Errors of the type C<fatal> indicate that the changer should not be used any
175 longer, and in most cases the caller should terminate abnormally. For example,
176 configuration or hardware errors are generally fatal.
178 If an operation fails, but the changer remains viable, then the error type is
179 C<failed>. The reason for the failure is usually clear to the user from the
180 message, but for callers who may need to distinguish, C<< $err->{'reason'} >>
181 has one of the following values:
183 notfound The requested volume was not found
184 invalid The caller's request was invalid (e.g., bad slot)
185 notimpl The requested operation is not supported
186 volinuse The requested volume or slot is already in use
187 driveinuse All drives are in use
188 unknown Unknown reason
189 empty The slot is empty
190 device Failed to set up the device
192 Like types, checks for particular reasons should use the methods, to avoid
195 if ($err->failed and $err->notimpl) { ... }
197 Other reasons may be added in the future, so a caller should check for the
198 reasons it expects, and treat any other failures as of unknown cause.
200 When the desired slot cannot be loaded because it is already in use, the
201 C<volinuse> error comes with an extra parameter, C<slot>, giving the slot in
202 question. This parameter is not defined for other cases.
206 Changers maintain a global concept of a "current" slot, for compatibility with
207 Amanda algorithms such as the taperscan. However, it is not compatible with
208 concurrent use of the same changer, and may be inefficient for some changers,
209 so new algorithms should avoid using it, preferring instead to load the correct
210 tape immediately (with C<load>), and to progress from tape to tape using the
211 C<relative_slot> parameter to C<load>.
213 =head2 CHANGER OBJECTS
217 To terminate a changer object.
221 The most common operation with a tape changer is to load a volume. The C<load>
222 method is heavily overloaded to support a number of different ways to specify a
225 In general, the method takes a C<res_cb> giving a callback that will receive
226 the reservation. If set_current is specified and true, then the changer's
227 current slot should be updated to correspond to C<$slot>. If not, then the changer
228 should not update its current slot (but some changers will anyway -
229 specifically, chg-compat).
231 The load method always read the label if it succeed to load a volume.
233 The optional C<mode> describes the intended use of the volume by the caller,
234 and should be one of C<"read"> (the default) or C<"write">. Changers managing
235 WORM media may use this parameter to provide a fresh volume for writing, but to
236 search for already-written volumes when reading.
238 The load method has a number of permutations:
240 $chg->load(res_cb => $cb,
245 Load and reserve a volume with the given label. This may leverage any barcodes
246 or other indices that the changer has available.
248 Note that the changer I<tries> to load the requested volume, but it's a mean
249 world out there, and you may not get what you want, so check the label on the
250 loaded volume before getting started.
252 $chg->load(res_cb => $cb,
257 Load and reserve the volume in the given slot. C<$slot> is a string specifying the slot
258 to load, provided by the user or from some other invocation of this changer.
259 Note that slots are not necessarily numeric, so performing arithmetic on this
262 If the slot does not exist, C<res_cb> will be called with a C<notfound> error.
263 Empty slots are considered empty.
265 $chg->load(res_cb => $cb,
266 relative_slot => "current",
269 Reserve the volume in the "current" slot. This is used by the traditional
270 taperscan algorithm to begin its search.
272 $chg->load(res_cb => $cb,
273 relative_slot => "next",
275 except_slots => { %except_slots },
279 Reserve the volume that follows the given slot or, if C<slot> is omitted, the
280 volume that follows the current slot. This will skip empty slots as if they
281 were not present in the changer.
283 The optional C<except_slots> argument specifies a hash of slots that should
284 I<not> be loaded. Keys are slot names, and the hash values are ignored. This
285 is useful as a termination condition when scanning all of the slots in a
286 changer: keep a hash of all slots already loaded, and pass that hash in
287 C<except_slots>. When the load operation returns a C<notfound> error, the scan
292 $chg->info(info_cb => $cb,
293 info => [ $key1, $key2, .. ])
295 Query the changer for miscellaneous information. Any number of keys may be
296 specified. The C<info_cb> is called with C<$error> as the first argument,
297 much like a C<res_cb>, but the remaining arguments form a hash giving values
298 for all of the requested keys that are supported by the changer. The preamble
299 to such a callback is usually
302 my ($error, %results) = @_;
312 The total number of slots in the changer device. If this key is not present or
313 -1, then the device cannot determine its slot count (for example, an archival
314 device that names slots by timestamp could potentially run until the heat-death
319 A string describing the name and model of the changer device.
323 If true, then this changer implements searching (loading by label) with
324 something more efficient than a sequential scan through the volumes. This
325 information affects some taperscan algorithms and recovery programs, which may
326 choose to do their own manual scan instead of invoking many potentially slow
333 $chg->reset(finished_cb => $cb)
335 Reset the changer to a "base" state. This will generally reset the "current"
336 slot to something the user would think of as the "first" tape, unload any
337 loaded drives, etc. It is an error to call this while any reservations are
342 $chg->clean(finished_cb => $cb,
345 Clean a drive, if the changer supports it. Drivename can be omitted for devices
346 with only one drive, or can be an arbitrary string from the user (e.g., an
347 amtape argument). Note that some changers cannot detect the completion of a
348 cleaning cycle; in this case, the user will just need to delay further Amanda
349 activities until the cleaning is complete.
353 $chg->eject(finished_cb => $cb,
356 Eject the volume in a drive, if the changer supports it. Drivename is as
357 specified to C<clean>. If possible, applications should prefer to eject a
358 reserved volume when finished with it (C<< $res->release(eject => 1) >>), to
359 ensure that the correct volume is ejected from a multi-drive changer.
363 $chg->update(finished_cb => $cb,
367 The user has changed something -- loading or unloading tapes, reconfiguring the
368 changer, etc. -- that may have invalidated the database. C<$changed> is a
369 changer-specific string indicating what has changed; if it is omitted, the
370 changer will check everything.
372 Since updates can take a long time, and users often want to know what's going
373 on, the update method will call C<user_msg_fn>, if specified, with
374 user-oriented messages appropriate to the changer.
378 $chg->inventory(inventory_cb => $cb)
380 The C<inventory_cb> is called with an error object as the first parameter, or
381 C<undef> if no error occurs. The second parameter is an arrayref containing an
382 ordered list of information about the slots in the changer. The order never
383 change, but some entries can be added or removed.
385 Each slot is represented by a hash with the following keys:
387 =head3 make_new_tape_label
389 $chg->make_new_tape_label(barcode => $barcode,
393 To devise a new name for a volume using the C<barcode> and C<meta> arguments.
394 This will return C<undef> if no label could be created.
396 =head3 make_new_meta_label
398 $chg->make_new_meta_label();
400 To devise a new meta name for a meta volume.
401 This will return C<undef> if no label could be created.
403 =head3 have_inventory
405 $chg->have_inventory()
407 Return True if the changer have the inventory method.
409 =head3 volume_is_labelable
411 $chg->volume_is_labelable($device_status, $f_type, $label);
413 Return 1 if the volume is labelable acording to the autolabel setting.
423 Set to C<1> if it is the current slot.
427 Set to C<SLOT_FULL> if the slot is full, C<SLOT_EMPTY> if the slot is empty (no
428 volume in slot), C<SLOT_UNKNOWN> if the changer doesn't know if the slot is full
429 or not (but it can know), or undef if the changer can't know if the slot is full or not.
430 A changer that doesn't keep state must set it to undef, like chg-single.
431 These constants are available in the C<:constants> export tag.
433 A blank or erased volume is not the same as an empty slot.
437 The device status after the open or read_label, undef if device status is unknown.
441 The file header type as returned by read_label, only if device_status is DEVICE_STATUS_SUCCESS.
445 The label on the volume in this slot, can be set by barcode or by read_label if f_type is Amanda::Header::F_TAPESTART.
447 =item barcode (optional)
449 The barcode for the volume in this slot, if barcodes are available.
453 Set to C<1> if this slot is reserved, either by this process or another
454 process. This is only set for I<exclusive> reservations, meaning that loading
455 the slot would result in an C<volinuse> error. Devices which can support
456 concurrent access will never set this flag.
458 =item loaded_in (optional)
460 For changers which have distinct user-visible drives, this gives the drive
461 currently accessing the volume in this slot.
463 =item import_export (optional)
465 Set to C<1> if this is an import-export slot -- a slot in which the user can
466 easily add or remove volumes. This information may be useful for operations to
467 bulk-import newly-inserted tapes or bulk-export a set of tapes.
473 $chg->move(finished_cb => $cb,
477 Move a volume between two slots in the changer. These slots are provided by the
478 user, and have meaning for the changer.
480 =head2 RESERVATION OBJECTS
486 This is the changer object.
488 =head3 $res->{'device'}
490 This is the fully configured device for the reserved volume. The device is not
493 =head3 $res->{'this_slot'}
495 This is the name of this slot. It is an arbitrary string which will
496 have some meaning to the changer's C<load()> method. It is safe to
497 access this field after the reservation has been released.
499 =head3 $res->{'barcode'}
501 If this changer supports barcodes, then this is the barcode of the reserved
502 volume. This can be helpful for labeling tapes using their barcode.
504 =head3 $label = $res->make_new_tape_label()
506 To devise a new name for a volume.
507 This will return C<undef> if no label could be created.
509 =head3 $meta = $res->make_new_meta_label()
511 To devise a new meta name for a meta volume.
512 This will return C<undef> if no label could be created.
514 =head3 $res->release(finished_cb => $cb, eject => $eject)
516 This is how an Amanda application indicates that it no longer needs the
517 reserved volume. The callback is called after any related operations are
518 complete -- possibly immediately. Some drives and changers have a notion of
519 "ejecting" a volume, and some don't. In particular, a manual changer can cause
520 the tape drive to eject the tape, while a tape robot can move a tape back to
521 storage, leaving the drive empty. If the eject parameter is given and true, it
522 indicates that Amanda is done with the volume and has reason to believe the
523 user is done with the volume, too -- for example, when a tape has been written
526 A reservation will be released automatically when the object is destroyed, but
527 in this case no finished_cb is given, so the release operation may not complete
528 before the process exits. Wherever possible, reservations should be explicitly
531 =head3 $res->set_label(finished_cb => $cb, label => $label)
533 This is how Amanda indicates to the changer that the volume in the device has
534 been (re-)labeled. Changers can keep a database of volume labels by slot or by
535 barcode, or just ignore this function and call $cb immediately. Note that the
536 reservation must still be held when this function is called.
538 =head1 SUBCLASS HELPERS
540 C<Amanda::Changer> implements some methods and attributes to help subclass
545 Implementing the C<info> method can be tricky, because it can potentially request
546 a number of keys that require asynchronous access. The C<info> implementation in
547 this class may make the process a bit easier.
549 First, if the method C<info_setup> is defined, C<info> calls it, passing it a
550 C<finished_cb> and the list of desired keys, C<info>. This method is useful to
551 gather information that is useful for several info keys.
553 Next, for each requested key, C<info> calls
555 $self->info_key($key, %params)
557 including a regular C<info_cb> callback. The C<info> method will wait for
558 all C<info_key> invocations to finish, then collect the results or errors that
561 =head2 ERROR HANDLING
563 To create a new error object, use C<< $self->make_error($type, $cb, %args) >>.
564 This method will create a new C<Amanda::Changer::Error> object and optionally
565 invoke a callback with it. If C<$type> is C<fatal>, then
566 C<< $chg->{'fatal_error'} >> is made a reference to the new error object. The
567 callback C<$cb> (which should be made using C<make_cb()> from
568 C<Amanda::MainLoop>) is called with the new error object. The C<%args> are
569 added to the new error object. In use, this looks something like:
572 return $self->make_error("failed", $params{'res_cb'},
573 reason => "notfound",
574 message => "Volume '$label' not found");
577 This method can also be called as a class method, e.g., from a constructor.
578 In this case, it returns the resulting error object, which should be fatal.
581 return Amanda::Changer->make_error("fatal", undef,
582 message => "config error");
585 For cases where a number of errors have occurred, it is helpful to make a
586 "combined" error. The method C<make_combined_error> takes care of this
587 operation, given a callback and an array of tuples C<[ $description, $err ]>
588 for each error. This method uses some heuristics to figure out the
589 appropriate type and reason for the combined error.
591 if ($left_err and $right_err) {
592 return $self->make_combined_error($params{'finished_cb'},
593 [ [ "from the left", $left_err ],
594 [ "from the right", $right_err ] ]);
597 Any additional keyword arguments to C<make_combined_error> are put into the
598 combined error; this is useful to set the C<slot> attribute.
600 The method C<< $self->check_error($cb) >> is a useful method for subclasses to
601 avoid doing anything after a fatal error. This method checks
602 C<< $self->{'fatal_error'} >>. If the error is defined, the method calls C<$cb>
603 and returns true. The usual recipe is
609 return if $self->check_error($params{'res_cb'});
615 C<Amanda::Changer->new> calls subclass constructors with two parameters: a
616 configuration object and a changer specification. The changer specification is
617 the string that led to creation of this changer device. The configuration
618 object is of type C<Amanda::Changer::Config>, and can be treated as a hashref
619 with the following keys:
621 name -- name of the changer section (or "default")
622 is_global -- true if this changer is the default changer
623 tapedev -- tapedev parameter
624 tpchanger -- tpchanger parameter
625 changerdev -- changerdev parameter
626 changerfile -- changerfile parameter
627 properties -- all properties for this changer
628 device_properties -- device properties from this changer
630 The four parameters are just as supplied by the user, either in the global
631 config or in a changer section. Changer authors are cautioned not to try to
632 override any of these parameters as previous changers have done (e.g.,
633 C<changerfile> specifying both configuration and state files). Use properties
636 The C<properties> and C<device_properties> parameters are in the format
637 provided by C<Amanda::Config>. If C<is_global> is true, then
638 C<device_properties> will include any device properties specified globally, as
639 well as properties culled from the global tapetype.
641 The C<configure_device> method generally takes care of the intricacies of
642 handling device properties. Pass it a newly opened device and it will apply
643 the relevant properties, returning undef on success or an error message on
646 The C<get_property> method is a shortcut method to get the value of a changer
647 property, ignoring its the priority and other attributes. In a list context,
648 it returns all values for the property; in a scalar context, it returns the
649 first value specified.
651 Many properties are boolean, and Amanda has a habit of accepting a number of
652 different ways of writing boolean values. The method
653 C<< $config->get_boolean_property($prop, $default) >> will parse such a
654 property, returning 0 or 1 if the property is specified, C<$default> if it is
655 not specified, or C<undef> if the property cannot be parsed.
657 =head2 PERSISTENT STATE AND LOCKING
659 Many changer subclasses need to track state across invocations and between
660 different processes, and to ensure that the state is read and written
661 atomically. The C<with_locked_state> provides this functionality by
662 locking a statefile, only unlocking it after any changes have been written back
663 to it. Subclasses can use this method both for mutual exclusion (ensuring that
664 only one changer operation is in progress at any time) and for atomic state
667 The C<with_locked_state> method works like C<synchronized> (in
668 L<Amanda::MainLoop>), but with some extra arguments:
670 $self->with_locked_state($filename, $some_cb, sub {
671 # note: $some_cb shadows outer $some_cb; see Amanda::MainLoop::synchronized
672 my ($state, $some_cb) = @_;
673 # ... and eventually:
677 The callback C<$some_cb> is assumed to take a changer error as its first
678 argument, and if there are any errors locking the statefile, they will be
679 reported directly to this callback. Otherwise, a wrapped version of
680 C<$some_cb> is passed to the inner C<sub>. When this wrapper is invoked, the
681 state will be written to disk and unlocked before the original callback is
684 The state itself begins as an empty hashref, but subclasses can add arbitrary
685 keys to the hash. Serialization is currently handled with L<Data::Dumper>.
687 =head2 PARAMETER VALIDATION
689 The C<validate_params> method is useful to make sure that the proper parameters
690 are present for a particular method, dying if not. Call it like this:
692 $self->validate_params("load", \%params);
694 The method currently only supports the "load" method, but can be expanded to
699 The Amanda Wiki (http://wiki.zmanda.com) has a higher-level description of the
700 changer model implemented by this package.
702 See amanda-changers(7) for user-level documentation of the changer implementations.
706 # constants for the states that slots may be in; note that these states still
707 # apply even if the tape is actually loaded in a drive
709 # slot is known to contain a volume
710 use constant SLOT_FULL => 1;
712 # slot is known to contain no volume
713 use constant SLOT_EMPTY => 2;
715 # don't known if slot contains a volume
716 use constant SLOT_UNKNOWN => 3;
718 our @EXPORT_OK = qw( SLOT_FULL SLOT_EMPTY SLOT_UNKNOWN );
720 constants => [ qw( SLOT_FULL SLOT_EMPTY SLOT_UNKNOWN ) ],
723 # this is a "virtual" constructor which instantiates objects of different
724 # classes based on its argument. Subclasses should not try to chain up!
726 shift eq 'Amanda::Changer'
727 or die("Do not call the Amanda::Changer constructor from subclasses");
732 # creating a named changer is a bit easier
733 if (defined($name)) {
734 # first, is it a changer alias?
735 if (($uri,$cc) = _changer_alias_to_uri($name)) {
736 return _new_from_uri($uri, $cc, $name, %params);
739 # maybe a straight-up changer URI?
740 if (_uri_to_pkgname($name)) {
741 return _new_from_uri($name, undef, $name, %params);
744 # assume it's a device name or alias, and invoke the single-changer
745 return _new_from_uri("chg-single:$name", undef, $name, %params);
746 } else { # !defined($name)
747 if ((getconf_linenum($CNF_TPCHANGER) == -2 ||
748 (getconf_seen($CNF_TPCHANGER) &&
749 getconf_linenum($CNF_TAPEDEV) != -2)) &&
750 getconf($CNF_TPCHANGER) ne '') {
751 my $tpchanger = getconf($CNF_TPCHANGER);
753 # first, is it an old changer script?
754 if ($uri = _old_script_to_uri($tpchanger)) {
755 return _new_from_uri($uri, undef, $tpchanger, %params);
758 # if not, then there had better be no tapdev
759 if (getconf_seen($CNF_TAPEDEV) and getconf($CNF_TAPEDEV) ne '' and
760 ((getconf_linenum($CNF_TAPEDEV) > 0 and
761 getconf_linenum($CNF_TPCHANGER) > 0) ||
762 (getconf_linenum($CNF_TAPEDEV) == -2))) {
763 return Amanda::Changer::Error->new('fatal',
764 message => "Cannot specify both 'tapedev' and 'tpchanger' " .
765 "unless using an old-style changer script");
768 # maybe a changer alias?
769 if (($uri,$cc) = _changer_alias_to_uri($tpchanger)) {
770 return _new_from_uri($uri, $cc, $tpchanger, %params);
773 # maybe a straight-up changer URI?
774 if (_uri_to_pkgname($tpchanger)) {
775 return _new_from_uri($tpchanger, undef, $tpchanger, %params);
778 # assume it's a device name or alias, and invoke the single-changer
779 return _new_from_uri("chg-single:$tpchanger", undef, $tpchanger, %params);
780 } elsif (getconf_seen($CNF_TAPEDEV) and getconf($CNF_TAPEDEV) ne '') {
781 my $tapedev = getconf($CNF_TAPEDEV);
783 # first, is it a changer alias?
784 if (($uri,$cc) = _changer_alias_to_uri($tapedev)) {
785 return _new_from_uri($uri, $cc, $tapedev, %params);
788 # maybe a straight-up changer URI?
789 if (_uri_to_pkgname($tapedev)) {
790 return _new_from_uri($tapedev, undef, $tapedev, %params);
793 # assume it's a device name or alias, and invoke chg-single.
794 # chg-single will check the device immediately and error out
795 # if the device name is invalid.
796 return _new_from_uri("chg-single:$tapedev", undef, $tapedev, %params);
798 return Amanda::Changer::Error->new('fatal',
799 message => "You must specify one of 'tapedev' or 'tpchanger'");
807 debug("Changer '$self->{'chg_name'}' not quit") if defined $self->{'chg_name'};
814 foreach (keys %$self) {
819 # helper functions for new
821 sub _changer_alias_to_uri {
824 my $cc = Amanda::Config::lookup_changer_config($name);
826 my $tpchanger = changer_config_getconf($cc, $CHANGER_CONFIG_TPCHANGER);
828 if (my $uri = _old_script_to_uri($tpchanger)) {
833 my $seen_tpchanger = changer_config_seen($cc, $CHANGER_CONFIG_TPCHANGER);
834 my $seen_tapedev = changer_config_seen($cc, $CHANGER_CONFIG_TAPEDEV);
835 if ($seen_tpchanger and $seen_tapedev) {
836 return Amanda::Changer::Error->new('fatal',
837 message => "Cannot specify both 'tapedev' and 'tpchanger' " .
838 "**unless using an old-style changer script");
840 if (!$seen_tpchanger and !$seen_tapedev) {
841 return Amanda::Changer::Error->new('fatal',
842 message => "You must specify one of 'tapedev' or 'tpchanger'");
844 $tpchanger ||= changer_config_getconf($cc, $CHANGER_CONFIG_TAPEDEV);
846 if (_uri_to_pkgname($tpchanger)) {
847 return ($tpchanger, $cc);
849 die "Changer '$name' specifies invalid tpchanger '$tpchanger'";
857 sub _old_script_to_uri {
860 die("empty changer script name") unless $name;
862 if ((-x "$amlibexecdir/$name") or (($name =~ qr{^/}) and (-x $name))) {
863 return "chg-compat:$name"
870 # try to load the package for the given URI. $@ is set properly
871 # if this function returns a false value.
872 sub _uri_to_pkgname {
875 my ($type) = ($name =~ /^chg-([A-Za-z_]+):/);
876 if (!defined $type) {
877 $@ = "'$name' is not a changer URI";
881 $type =~ tr/A-Z-/a-z_/;
883 # create a package name to see if it's already imported
884 my $pkgname = "Amanda::Changer::$type";
885 my $filename = $pkgname;
886 $filename =~ s|::|/|g;
888 return $pkgname if (exists $INC{$filename});
891 eval "use $pkgname;";
895 # determine whether the module doesn't exist at all, or if there was an
896 # error loading it; die if we found a syntax error
897 if (exists $INC{$filename} or $err =~ /did not return a true value/) {
907 sub _new_from_uri { # (note: this sub is patched by the installcheck)
913 # as a special case, if the URI came back as an error, just pass
914 # that along. This lets the _xxx_to_uri methods return errors more
916 if (ref $uri and $uri->isa("Amanda::Changer::Error")) {
920 # make up a key for our hash of already-instantiated objects,
921 # using a newline as a separator, since perl can't use tuples
923 my $uri_cc = "$uri\n";
925 $uri_cc = $uri_cc . changer_config_name($cc);
928 # return a pre-existing changer, if possible
930 # look up the type and load the class
931 my $pkgname = _uri_to_pkgname($uri);
936 my $rv = eval {$pkgname->new(Amanda::Changer::Config->new($cc), $uri);};
937 die "$pkgname->new return undef" if $@;
938 die "$pkgname->new did not return an Amanda::Changer object or an Amanda::Changer::Error"
939 unless ($rv->isa("Amanda::Changer") or $rv->isa("Amanda::Changer::Error"));
941 if ($rv->isa("Amanda::Changer::Error")) {
945 if ($rv->isa("Amanda::Changer")) {
946 # add an instance variable or two
947 $rv->{'fatal_error'} = undef;
950 $rv->{'tapelist'} = $params{'tapelist'};
951 $rv->{'autolabel'} = $params{'autolabel'};
952 $rv->{'autolabel'} = getconf($CNF_AUTOLABEL)
953 unless defined $rv->{'autolabel'};
954 $rv->{'labelstr'} = $params{'labelstr'};
955 $rv->{'labelstr'} = getconf($CNF_LABELSTR)
956 unless defined $rv->{'labelstr'};
957 $rv->{'meta_autolabel'} = $params{'meta_autolabel'};
958 $rv->{'meta_autolabel'} = getconf($CNF_META_AUTOLABEL)
959 unless defined $rv->{'meta_autolabel'};
960 $rv->{'chg_name'} = $name;
964 # method stubs that return a "notimpl" error
967 my ($op, $cbname, $self, %params) = @_;
968 return if $self->check_error($params{$cbname});
970 my $class = ref($self);
971 my $chg_foo = "chg-" . ($class =~ /Amanda::Changer::(.*)/)[0];
972 return $self->make_error("failed", $params{$cbname},
974 message => "'$chg_foo:' does not support $op");
977 sub load { _stubop("loading volumes", "res_cb", @_); }
978 sub reset { _stubop("reset", "finished_cb", @_); }
979 sub clean { _stubop("clean", "finished_cb", @_); }
980 sub eject { _stubop("eject", "finished_cb", @_); }
981 sub update { _stubop("update", "finished_cb", @_); }
982 sub inventory { _stubop("inventory", "inventory_cb", @_); }
983 sub move { _stubop("move", "finished_cb", @_); }
984 sub set_meta_label { _stubop("set_meta_label", "finished_cb", @_); }
985 sub get_meta_label { _stubop("get_meta_label", "finished_cb", @_); }
990 return $self->can("inventory") ne \&Amanda::Changer::inventory;
993 # info calls out to info_setup and info_key; see POD above
998 if (!$self->can('info_key')) {
999 my $class = ref($self);
1000 $params{'info_cb'}->("$class does not support info()");
1004 my ($do_setup, $start_keys, $all_done);
1007 if ($self->can('info_setup')) {
1008 $self->info_setup(info => $params{'info'},
1009 finished_cb => sub {
1012 $params{'info_cb'}->($err);
1023 my $remaining_keys = 1;
1026 my $maybe_done = sub {
1027 return if (--$remaining_keys);
1028 $all_done->(%key_results);
1031 for my $key (@{$params{'info'}}) {
1033 $self->info_key($key, info_cb => sub {
1034 $key_results{$key} = [ @_ ];
1039 # we started with $remaining_keys = 1, so decrement it now
1044 my %key_results = @_;
1046 # if there are *any* errors, handle them
1047 my @annotated_errs =
1048 map { [ sprintf("While getting info key '%s'", $_), $key_results{$_}->[0] ] }
1049 grep { defined($key_results{$_}->[0]) }
1052 if (@annotated_errs) {
1053 return $self->make_combined_error(
1054 $params{'info_cb'}, [ @annotated_errs ]);
1057 # no errors, so combine the results and return them
1059 while (my ($key, $result) = each(%key_results)) {
1060 my ($err, %key_info) = @$result;
1061 if (exists $key_info{$key}) {
1062 $info{$key} = $key_info{$key};
1064 warn("No value available for $key");
1068 $params{'info_cb'}->(undef, %info);
1078 my ($type, $cb, %args) = @_;
1080 my $classmeth = $self eq "Amanda::Changer";
1082 if ($classmeth and $type ne 'fatal') {
1083 cluck("type must be fatal when calling make_error as a class method");
1087 my $err = Amanda::Changer::Error->new($type, %args);
1090 $self->{'fatal_error'} = $err
1099 sub make_combined_error {
1101 my ($cb, $suberrors, %extra_args) = @_;
1104 if (@$suberrors == 0) {
1105 die("make_combined_error called with no errors");
1108 my $classmeth = $self eq "Amanda::Changer";
1110 # if there's only one suberror, just use it directly
1111 if (@$suberrors == 1) {
1112 $err = $suberrors->[0][1];
1113 die("$err is not an Error object")
1114 unless defined($err) and $err->isa("Amanda::Changer::Error");
1116 $err = Amanda::Changer::Error->new(
1118 reason => $err->{'reason'},
1119 message => $suberrors->[0][0] . ": " . $err->{'message'});
1121 my $fatal = $classmeth or grep { $_->[1]{'fatal'} } @$suberrors;
1126 map { ($_->[1]{'reason'}, undef) }
1127 grep { $_->[1]{'reason'} }
1129 if ((keys %reasons) == 1) {
1130 $reason = (keys %reasons)[0];
1132 $reason = 'unknown'; # multiple or 0 "source" reasons
1136 my $message = join("; ",
1137 map { sprintf("%s: %s", @$_) }
1140 my %errargs = ( message => $message, %extra_args );
1141 $errargs{'reason'} = $reason unless ($fatal);
1142 $err = Amanda::Changer::Error->new(
1143 $fatal? "fatal" : "failed",
1148 $self->{'fatal_error'} = $err
1161 if (defined $self->{'fatal_error'}) {
1162 $cb->($self->{'fatal_error'}) if $cb;
1167 sub lock_statefile {
1171 my $statefile = $params{'statefile_filename'};
1172 my $lock_cb = $params{'lock_cb'};
1173 Amanda::Changer::StateFile->new($statefile, $lock_cb);
1176 sub with_locked_state {
1178 my ($statefile, $cb, $sub) = @_;
1179 my ($filelock, $STATE);
1180 my $poll = 0; # first delay will be 0.1s; see below
1183 if (defined $self->{'lock-timeout'}) {
1184 $time = time() + $self->{'lock-timeout'};
1186 $time = time() + 1000;
1189 my $steps = define_steps
1193 $filelock = Amanda::Util::file_lock->new($statefile);
1195 $steps->{'lock'}->();
1199 my $rv = $filelock->lock();
1200 if ($rv == 1 && time() < $time) {
1201 # loop until we get the lock, increasing $poll to 10s
1202 $poll += 100 unless $poll >= 10000;
1203 return Amanda::MainLoop::call_after($poll, $steps->{'lock'});
1204 } elsif ($rv == 1) {
1205 return $self->make_error("fatal", $cb,
1206 message => "Timeout trying to lock '$statefile'");
1207 } elsif ($rv == -1) {
1208 return $self->make_error("fatal", $cb,
1209 message => "Error locking '$statefile'");
1212 $steps->{'read'}->();
1216 my $contents = $filelock->data();
1220 # $fh goes out of scope here, and is thus automatically
1222 return $cb->("error reading '$statefile': $@", undef);
1224 if (!defined $STATE or ref($STATE) ne 'HASH') {
1225 return $cb->("'$statefile' did not define \$STATE properly", undef);
1228 # initial state (blank file)
1232 $sub->($STATE, $steps->{'cb_wrap'});
1235 step cb_wrap => sub {
1238 my $dumper = Data::Dumper->new([ $STATE ], ["STATE"]);
1240 $filelock->write($dumper->Dump);
1241 $filelock->unlock();
1243 # call through to the original callback with the original
1249 sub validate_params {
1250 my ($self, $op, $params) = @_;
1252 if ($op eq 'load') {
1253 unless(exists $params->{'label'} || exists $params->{'slot'} ||
1254 exists $params->{'relative_slot'}) {
1255 confess "Invalid parameters to 'load'";
1258 confess "don't know how to validate '$op'";
1262 sub make_new_tape_label {
1266 my $tl = $self->{'tapelist'};
1267 die ("make_new_tape_label: no tapelist") if !$tl;
1268 if (!defined $self->{'autolabel'}) {
1269 return (undef, "autolabel not set");
1271 if (!defined $self->{'autolabel'}->{'template'}) {
1272 return (undef, "template is not set, you must set autolabel");
1274 if (!defined $self->{'labelstr'}) {
1275 return (undef, "labelstr not set");
1277 my $template = $self->{'autolabel'}->{'template'};
1278 my $labelstr = $self->{'labelstr'};
1281 $template =~ s/\$\$/SUBSTITUTE_DOLLAR/g;
1282 $template =~ s/\$b/SUBSTITUTE_BARCODE/g;
1283 $template =~ s/\$m/SUBSTITUTE_META/g;
1284 $template =~ s/\$o/SUBSTITUTE_ORG/g;
1285 $template =~ s/\$c/SUBSTITUTE_CONFIG/g;
1286 if ($template =~ /\$([0-9]*)s/) {
1288 $slot_digit = 1 if $slot_digit < 1;
1289 $template =~ s/\$[0-9]*s/SUBSTITUTE_SLOT/g;
1292 my $org = getconf($CNF_ORG);
1293 my $config = Amanda::Config::get_config_name();
1294 my $barcode = $params{'barcode'};
1295 $barcode = '' if !defined $barcode;
1296 my $meta = $params{'meta'};
1297 my $slot = $params{'slot'};
1298 $slot = '' if !defined $slot;
1299 $meta = $self->make_new_meta_label(%params) if !defined $meta;
1300 $meta = '' if !defined $meta;
1302 $template =~ s/SUBSTITUTE_DOLLAR/\$/g;
1303 $template =~ s/SUBSTITUTE_ORG/$org/g;
1304 $template =~ s/SUBSTITUTE_CONFIG/$config/g;
1305 $template =~ s/SUBSTITUTE_META/$meta/g;
1306 # Do not susbtitute the barcode and slot now
1309 $template) =~ s/[^%]*(%+)[^%]*/length($1)/e;
1310 $npercents = 0 if $npercents eq $template;
1313 if ($npercents == 0) {
1315 $label =~ s/SUBSTITUTE_BARCODE/$barcode/g;
1316 if ($template =~ /SUBSTITUTE_SLOT/) {
1317 my $slot_label = sprintf("%0*d", $slot_digit, $slot);
1318 $label =~ s/SUBSTITUTE_SLOT/$slot_label/g;
1320 if ($template =~ /SUBSTITUTE_BARCODE/ && !defined $barcode) {
1321 return (undef, "Can't generate new label because volume has no barcode");
1322 } elsif ($template =~ /SUBSTITUTE_SLOT/ && !defined $slot) {
1323 return (undef, "Can't generate new label because volume has no slot");
1324 } elsif ($label eq $template) {
1325 return (undef, "autolabel require at least one '%'");
1326 } elsif ($tl->lookup_tapelabel($label)) {
1327 return (undef, "Label '$label' already exists");
1330 # make up a sprintf pattern
1332 $template) =~ s/(%+)/"%0" . length($1) . "d"/e;
1334 my %existing_labels;
1335 for my $tle (@{$tl->{'tles'}}) {
1336 if (defined $tle && defined $tle->{'label'}) {
1337 my $tle_label = $tle->{'label'};
1338 my $tle_barcode = $tle->{'barcode'};
1339 if (defined $tle_barcode) {
1340 $tle_label =~ s/$tle_barcode/SUBSTITUTE_BARCODE/g;
1342 $existing_labels{$tle_label} = 1 if defined $tle_label;
1346 my $nlabels = 10 ** $npercents;
1348 for ($i = 1; $i < $nlabels; $i++) {
1349 $label = sprintf($sprintf_pat, $i);
1350 last unless (exists $existing_labels{$label});
1353 # susbtitute the barcode and slot
1354 $label =~ s/SUBSTITUTE_BARCODE/$barcode/g;
1355 if ($template =~ /SUBSTITUTE_SLOT/) {
1356 my $slot_label = sprintf("%0*d", $slot_digit, $slot);
1357 $label =~ s/SUBSTITUTE_SLOT/$slot_label/g;
1360 # bail out if we didn't find an unused label
1361 return (undef, "Can't label unlabeled volume: All label used")
1362 if ($i >= $nlabels);
1365 # verify $label matches $labelstr
1366 if ($label !~ /$labelstr/) {
1367 return (undef, "Newly-generated label '$label' does not match labelstr '$labelstr'");
1371 return (undef, "Generated label is empty");
1377 sub make_new_meta_label {
1381 my $tl = $self->{'tapelist'};
1382 die ("make_new_meta_label: no tapelist") if !$tl;
1383 return undef if !defined $self->{'meta_autolabel'};
1384 my $template = $self->{'meta_autolabel'};
1385 return if !defined $template;
1388 return (undef, "template is not set, you must set meta-autolabel");
1390 $template =~ s/\$\$/SUBSTITUTE_DOLLAR/g;
1391 $template =~ s/\$o/SUBSTITUTE_ORG/g;
1392 $template =~ s/\$c/SUBSTITUTE_CONFIG/g;
1394 my $org = getconf($CNF_ORG);
1395 my $config = Amanda::Config::get_config_name();
1397 $template =~ s/SUBSTITUTE_DOLLAR/\$/g;
1398 $template =~ s/SUBSTITUTE_ORG/$org/g;
1399 $template =~ s/SUBSTITUTE_CONFIG/$config/g;
1402 $template) =~ s/[^%]*(%+)[^%]*/length($1)/e;
1403 $npercents = 0 if $npercents eq $template;
1404 my $nlabels = 10 ** $npercents;
1406 # make up a sprintf pattern
1407 (my $sprintf_pat = $template) =~ s/(%+)/"%0" . length($1) . "d"/e;
1409 my %existing_meta_labels =
1410 map { $_->{'meta'} => 1 } @{$tl->{'tles'}};
1413 for ($i = 1; $i < $nlabels; $i++) {
1414 $meta = sprintf($sprintf_pat, $i);
1415 last unless (exists $existing_meta_labels{$meta});
1418 # bail out if we didn't find an unused label
1419 return (undef, "Can't label unlabeled meta volume: All meta label used")
1420 if ($i >= $nlabels);
1423 return (undef, "Generated meta-label is empty");
1429 sub volume_is_labelable {
1431 my $dev_status = shift;
1434 my $autolabel = $self->{'autolabel'};
1436 if (!defined $dev_status) {
1438 } elsif ($dev_status & $DEVICE_STATUS_VOLUME_UNLABELED and
1440 $f_type == $Amanda::Header::F_EMPTY) {
1441 return 0 if (!$autolabel->{'empty'});
1442 } elsif ($dev_status & $DEVICE_STATUS_VOLUME_UNLABELED and
1444 $f_type == $Amanda::Header::F_WEIRD) {
1445 return 0 if (!$autolabel->{'non_amanda'});
1446 } elsif ($dev_status & $DEVICE_STATUS_VOLUME_ERROR) {
1447 return 0 if (!$autolabel->{'volume_error'});
1448 } elsif ($dev_status != $DEVICE_STATUS_SUCCESS) {
1450 } elsif ($dev_status & $DEVICE_STATUS_SUCCESS and
1451 $f_type == $Amanda::Header::F_TAPESTART and
1452 $label !~ /$self->{'labelstr'}/) {
1453 return 0 if (!$autolabel->{'other_config'});
1459 package Amanda::Changer::Error;
1460 use Amanda::Debug qw( :logging );
1461 use Carp qw( cluck );
1464 '""' => sub { $_[0]->{'message'}; },
1465 'cmp' => sub { $_[0]->{'message'} cmp $_[1]; };
1467 my %known_err_types = map { ($_, 1) } qw( fatal failed );
1468 my %known_err_reasons = map { ($_, 1) } qw( notfound invalid notimpl driveinuse volinuse unknown device empty );
1471 my $class = shift; # ignore class
1472 my ($type, %info) = @_;
1475 $reason = ", reason='$info{reason}'" if $type eq "failed";
1476 debug("new Amanda::Changer::Error: type='$type'$reason, message='$info{message}'");
1478 $info{'type'} = $type;
1480 # do some sanity checks. Note that these sanity checks issue a warning
1481 # with cluck, but add default values to the error. This is in the hope
1482 # that an unusual Amanda error is not obscured by a problem in the
1483 # make_error invocation. The stack trace produced by cluck should help to
1484 # track down the bad make_error invocation.
1486 if (!exists $info{'message'}) {
1487 cluck("no message given to A::C::make_error");
1488 $info{'message'} = "unknown error";
1491 if (!exists $known_err_types{$type}) {
1492 cluck("invalid Amanda::Changer::Error type '$type'");
1496 if ($type eq 'failed' and !exists $info{'reason'}) {
1497 cluck("no reason given to A::C::make_error");
1498 $info{'reason'} = "unknown";
1501 if ($type eq 'failed' and !exists $known_err_reasons{$info{'reason'}}) {
1502 cluck("invalid Amanda::Changer::Error reason '$info{reason}'");
1503 $info{'reason'} = 'unknown';
1506 return bless (\%info, $class);
1509 # do nothing in quit
1513 sub fatal { $_[0]->{'type'} eq 'fatal'; }
1514 sub failed { $_[0]->{'type'} eq 'failed'; }
1517 sub notfound { $_[0]->failed && $_[0]->{'reason'} eq 'notfound'; }
1518 sub invalid { $_[0]->failed && $_[0]->{'reason'} eq 'invalid'; }
1519 sub notimpl { $_[0]->failed && $_[0]->{'reason'} eq 'notimpl'; }
1520 sub driveinuse { $_[0]->failed && $_[0]->{'reason'} eq 'driveinuse'; }
1521 sub volinuse { $_[0]->failed && $_[0]->{'reason'} eq 'volinuse'; }
1522 sub unknown { $_[0]->failed && $_[0]->{'reason'} eq 'unknown'; }
1523 sub empty { $_[0]->failed && $_[0]->{'reason'} eq 'empty'; }
1524 sub device { $_[0]->failed && $_[0]->{'reason'} eq 'device'; }
1527 sub slot { $_[0]->{'slot'}; }
1529 package Amanda::Changer::Reservation;
1530 # this is a simple base class with stub method or two.
1531 use Amanda::Config qw( :getconf );
1538 return bless ($self, $class)
1543 if (!$self->{'released'}) {
1544 if (defined $self->{this_slot}) {
1545 Amanda::Debug::warning("Changer reservation for slot '$self->{this_slot}' has " .
1546 "gone out of scope without release");
1548 Amanda::Debug::warning("Changer reservation for unknown slot has " .
1549 "gone out of scope without release");
1558 # nothing to do by default: just call the finished callback
1559 if (exists $params{'finished_cb'}) {
1560 $params{'finished_cb'}->(undef) if $params{'finished_cb'};
1568 if ($self->{'released'}) {
1569 $params{'finished_cb'}->(undef) if exists $params{'finished_cb'};
1573 # always finish the device on release; it's illegal for anything
1574 # else to use the device after this point, anyway, so we want to
1575 # release the device's resources immediately
1576 if (defined $self->{'device'}) {
1577 $self->{'device'}->finish();
1580 $self->{'released'} = 1;
1581 $self->do_release(%params);
1588 # this is the one subclasses should override
1590 if (exists $params{'finished_cb'}) {
1591 $params{'finished_cb'}->(undef) if $params{'finished_cb'};
1595 sub get_meta_label {
1599 # this is the one subclasses should override
1601 if (exists $params{'finished_cb'}) {
1602 $params{'finished_cb'}->(undef) if $params{'finished_cb'};
1606 sub set_meta_label {
1610 # this is the one subclasses should override
1612 if (exists $params{'finished_cb'}) {
1613 $params{'finished_cb'}->(undef) if $params{'finished_cb'};
1617 sub make_new_tape_label {
1621 $params{'barcode'} = $self->{'barcode'} if !defined $params{'barcode'};
1622 $params{'meta'} = $self->{'meta'} if !defined $params{'meta'};
1623 $params{'slot'} = $self->{'this_slot'} if !defined $params{'slot'};
1624 return $self->{'chg'}->make_new_tape_label(%params);
1628 sub make_new_meta_label {
1632 return $self->{'chg'}->make_new_meta_label(%params);
1635 package Amanda::Changer::Config;
1636 use Amanda::Config qw( :getconf string_to_boolean );
1637 use Amanda::Device qw( :constants );
1643 my $self = bless {}, $class;
1646 $self->{'name'} = changer_config_name($cc);
1647 $self->{'is_global'} = 0;
1649 $self->{'tapedev'} = changer_config_getconf($cc, $CHANGER_CONFIG_TAPEDEV);
1650 $self->{'tpchanger'} = changer_config_getconf($cc, $CHANGER_CONFIG_TPCHANGER);
1651 $self->{'changerdev'} = changer_config_getconf($cc, $CHANGER_CONFIG_CHANGERDEV);
1652 $self->{'changerfile'} = changer_config_getconf($cc, $CHANGER_CONFIG_CHANGERFILE);
1654 $self->{'properties'} = changer_config_getconf($cc, $CHANGER_CONFIG_PROPERTY);
1655 $self->{'device_properties'} = changer_config_getconf($cc, $CHANGER_CONFIG_DEVICE_PROPERTY);
1657 $self->{'name'} = "default";
1658 $self->{'is_global'} = 1;
1660 $self->{'tapedev'} = getconf($CNF_TAPEDEV);
1661 $self->{'tpchanger'} = getconf($CNF_TPCHANGER);
1662 $self->{'changerdev'} = getconf($CNF_CHANGERDEV);
1663 $self->{'changerfile'} = getconf($CNF_CHANGERFILE);
1665 # no changer or device properties, since there's no changer definition to use
1666 $self->{'properties'} = {};
1667 $self->{'device_properties'} = {};
1672 sub configure_device {
1676 # we'll accumulate properties in this hash *overwriting* previous properties
1677 # instead of appending to them
1680 # always use implicit properties
1681 %properties = ( %properties, %{ $self->_get_implicit_properties() } );
1683 # always use global properties
1684 %properties = ( %properties, %{ getconf($CNF_DEVICE_PROPERTY) } );
1686 # if this is a device alias, add properties from its device definition
1687 if (my $dc = lookup_device_config($device->device_name)) {
1688 %properties = ( %properties,
1689 %{ device_config_getconf($dc, $DEVICE_CONFIG_DEVICE_PROPERTY); } );
1692 # finally, add any props from the changer config
1693 %properties = ( %properties, %{ $self->{'device_properties'} } );
1695 while (my ($propname, $propinfo) = each(%properties)) {
1696 for my $value (@{$propinfo->{'values'}}) {
1697 if (!$device->property_set($propname, $value)) {
1699 if ($device->status == $DEVICE_STATUS_SUCCESS) {
1700 $msg = "Error setting '$propname' on device '".$device->device_name."'";
1702 $msg = $device->error() . " on device '".$device->device_name."'";
1704 if (exists $propinfo->{'optional'}) {
1705 if ($propinfo->{'optional'} eq 'warn') {
1706 warn("$msg (ignored)");
1720 my ($property) = @_;
1722 my $prophash = $self->{'properties'}->{$property};
1723 return undef unless defined($prophash);
1725 return wantarray? @{$prophash->{'values'}} : $prophash->{'values'}->[0];
1728 sub get_boolean_property {
1730 my ($propname, $default) = @_;
1733 unless (exists $self->{'properties'}->{$propname});
1735 my $propinfo = $self->{'properties'}->{$propname};
1736 return undef unless @{$propinfo->{'values'}} == 1;
1737 return string_to_boolean($propinfo->{'values'}->[0]);
1740 sub _get_implicit_properties {
1744 my $tapetype_name = getconf($CNF_TAPETYPE);
1745 return unless defined($tapetype_name);
1747 my $tapetype = lookup_tapetype($tapetype_name);
1748 return unless defined($tapetype);
1750 # The property hashes used here add the 'optional' key, which indicates
1751 # that the property is implicit and that a failure to set it is not fatal.
1752 # The flag is used by configure_device.
1753 if (tapetype_seen($tapetype, $TAPETYPE_LENGTH)) {
1754 $props->{'max_volume_usage'} = {
1759 tapetype_getconf($tapetype, $TAPETYPE_LENGTH) * 1024,
1763 if (tapetype_seen($tapetype, $TAPETYPE_READBLOCKSIZE)) {
1764 $props->{'read_block_size'} = {
1765 optional => "warn", # optional, but give a warning
1769 tapetype_getconf($tapetype, $TAPETYPE_READBLOCKSIZE) * 1024,
1773 if (tapetype_seen($tapetype, $TAPETYPE_BLOCKSIZE)) {
1774 $props->{'block_size'} = {
1779 # convert the length from kb to bytes here
1780 tapetype_getconf($tapetype, $TAPETYPE_BLOCKSIZE) * 1024,