1# Copyright (c) 2007-2013 Zmanda, Inc. All Rights Reserved. 2# 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. 7# 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 11# for more details. 12# 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 16# 17# Contact information: Zmanda Inc., 465 S. Mathilda Ave., Suite 300 18# Sunnyvale, CA 94085, USA, or: http://www.zmanda.com 19 20package Amanda::Changer; 21 22use strict; 23use warnings; 24use Carp qw( confess cluck ); 25use POSIX (); 26use Fcntl qw( O_RDWR O_CREAT LOCK_EX LOCK_NB ); 27use Data::Dumper; 28use vars qw( @ISA ); 29 30use Amanda::Paths; 31use Amanda::Util; 32use Amanda::Config qw( :getconf ); 33use Amanda::Device qw( :constants ); 34use Amanda::Debug qw( debug ); 35use Amanda::MainLoop; 36 37=head1 NAME 38 39Amanda::Changer -- interface to changer scripts 40 41=head1 SYNOPSIS 42 43 use Amanda::Changer; 44 45 my $chg = Amanda::Changer->new(); # loads the default changer; OR 46 $chg = Amanda::Changer->new("somechanger"); # references a defined changer in amanda.conf 47 48 $chg->load( 49 label => "TAPE-012", 50 mode => "write", 51 res_cb => sub { 52 my ($err, $reservation) = @_; 53 if ($err) { 54 die $err->{message}; 55 } 56 $dev = $reservation->{'device'}; 57 # use device.. 58 }); 59 60 # later.. 61 $reservation->release(finished_cb => $start_next_volume); 62 63 # later.. 64 $chg->quit(); 65 66=head1 INTERFACE 67 68All operations in the module return immediately, and take as an argument a 69callback function which will indicate completion of the changer operation -- a 70kind of continuation. The caller should run a main loop (see 71L<Amanda::MainLoop>) to allow the interactions with the changer script to 72continue. 73 74A new object is created with the C<new> function as follows: 75 76 my $chg = Amanda::Changer->new($changer_name, 77 tapelist => $tapelist, 78 labelstr => $labelstr, 79 autolabel => $autolabel, 80 meta_autolabel => $meta_autolabel); 81 82to create a named changer (a name provided by the user, either specifying a 83changer directly or specifying a changer definition), or 84 85 my $chg = Amanda::Changer->new(undef, 86 tapelist => $tapelist, 87 labelstr => $labelstr, 88 autolabel => $autolabel, 89 meta_autolabel => $meta_autolabel); 90 91to run the default changer. This function handles the many ways a user can 92configure a changer. 93 94If there is a problem creating the new object, then the resulting object will 95be a fatal C<Error> object (described below). Thus the usual recipe for 96creating a new changer is 97 98 my $chg = Amanda::Changer->new($changer_name); 99 if ($chg->isa("Amanda::Changer::Error")) { 100 die("Error creating changer $changer_name: $chg"); 101 } 102 103C<tapelist> must be an Amanda::Tapelist object. It is required if you want to 104use $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(). 107C<labelstr> must be like getconf($CNF_LABELSTR), that value is used if C<labelstr> is not set. 108C<autolabel> must be like getconf($CNF_AUTOLABEL), that value is used if C<autolabel> is not set. 109C<meta_autolabel> must be like getconf($CNF_META_AUTOLABEL), that value is used if C<meta_autolabel> is not set. 110=head2 MEMBER VARIABLES 111 112Note that these variables are not set until after the subclass constructor is 113finished. 114 115=over 4 116 117=item C<< $chg->{'chg_name'} >> 118 119Gives the name of the changer. This name will make sense to the user, but will 120not necessarily form a valid changer specification. It should be used to 121describe the changer in messages to the user. 122 123=back 124 125=head2 CALLBACKS 126 127All changer callbacks take an error object as the first parameter. If no error 128occurred, then this parameter is C<undef> and the remaining parameters are 129defined. 130 131A res_cb C<$cb> is called back as: 132 133 $cb->($error, undef); 134 135in the event of an error, or 136 137 $cb->(undef, $reservation); 138 139with a successful reservation. res_cb must always be specified. A finished_cb 140C<$cb> is called back as 141 142 $cb->($error); 143 144in the event of an error, or 145 146 $cb->(undef); 147 148on success. A finished_cb may be omitted if no notification of completion is 149required. 150 151Other callback types are defined below. 152 153=head2 ERRORS 154 155When a callback is made with an error, it is an object of type 156C<Amanda::Changer::Error>. When interpolated into a string, this object turns 157into a simple error message. However, it has some additional methods that can 158be used to determine how to respond to the error. First, the error message is 159available explicitly as C<< $err->message >>. The error type is available as 160C<< $err->{'type'} >>, although checks for particular error types should use 161the C<TYPE> methods instead, as perl is better able to detect typos with this 162syntax: 163 164 if ($err->failed) { ... } 165 166The error types are: 167 168 fatal Changer is no longer useable 169 failed Operation failed, but the changer is OK 170 171The API may add other error types in the future (for example, to indicate 172that a required resource is already reserved). 173 174Errors of the type C<fatal> indicate that the changer should not be used any 175longer, and in most cases the caller should terminate abnormally. For example, 176configuration or hardware errors are generally fatal. 177 178If an operation fails, but the changer remains viable, then the error type is 179C<failed>. The reason for the failure is usually clear to the user from the 180message, but for callers who may need to distinguish, C<< $err->{'reason'} >> 181has one of the following values: 182 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 191 192Like types, checks for particular reasons should use the methods, to avoid 193undetected typos: 194 195 if ($err->failed and $err->notimpl) { ... } 196 197Other reasons may be added in the future, so a caller should check for the 198reasons it expects, and treat any other failures as of unknown cause. 199 200When the desired slot cannot be loaded because it is already in use, the 201C<volinuse> error comes with an extra parameter, C<slot>, giving the slot in 202question. This parameter is not defined for other cases. 203 204=head2 CURRENT SLOT 205 206Changers maintain a global concept of a "current" slot, for compatibility with 207Amanda algorithms such as the taperscan. However, it is not compatible with 208concurrent use of the same changer, and may be inefficient for some changers, 209so new algorithms should avoid using it, preferring instead to load the correct 210tape immediately (with C<load>), and to progress from tape to tape using the 211C<relative_slot> parameter to C<load>. 212 213=head2 CHANGER OBJECTS 214 215=head3 quit 216 217To terminate a changer object. 218 219=head3 load 220 221The most common operation with a tape changer is to load a volume. The C<load> 222method is heavily overloaded to support a number of different ways to specify a 223volume. 224 225In general, the method takes a C<res_cb> giving a callback that will receive 226the reservation. If set_current is specified and true, then the changer's 227current slot should be updated to correspond to C<$slot>. If not, then the changer 228should not update its current slot (but some changers will anyway - 229specifically, chg-compat). 230 231The load method always read the label if it succeed to load a volume. 232 233The optional C<mode> describes the intended use of the volume by the caller, 234and should be one of C<"read"> (the default) or C<"write">. Changers managing 235WORM media may use this parameter to provide a fresh volume for writing, but to 236search for already-written volumes when reading. 237 238The load method has a number of permutations: 239 240 $chg->load(res_cb => $cb, 241 label => $label, 242 mode => $mode, 243 set_current => $sc) 244 245Load and reserve a volume with the given label. This may leverage any barcodes 246or other indices that the changer has available. 247 248Note that the changer I<tries> to load the requested volume, but it's a mean 249world out there, and you may not get what you want, so check the label on the 250loaded volume before getting started. 251 252 $chg->load(res_cb => $cb, 253 slot => $slot, 254 mode => $mode, 255 set_current => $sc) 256 257Load and reserve the volume in the given slot. C<$slot> is a string specifying the slot 258to load, provided by the user or from some other invocation of this changer. 259Note that slots are not necessarily numeric, so performing arithmetic on this 260value is an error. 261 262If the slot does not exist, C<res_cb> will be called with a C<notfound> error. 263Empty slots are considered empty. 264 265 $chg->load(res_cb => $cb, 266 relative_slot => "current", 267 mode => $mode) 268 269Reserve the volume in the "current" slot. This is used by the traditional 270taperscan algorithm to begin its search. 271 272 $chg->load(res_cb => $cb, 273 relative_slot => "next", 274 slot => $slot, 275 except_slots => { %except_slots }, 276 mode => $mode, 277 set_current => $sc) 278 279Reserve the volume that follows the given slot or, if C<slot> is omitted, the 280volume that follows the current slot. This will skip empty slots as if they 281were not present in the changer. 282 283The optional C<except_slots> argument specifies a hash of slots that should 284I<not> be loaded. Keys are slot names, and the hash values are ignored. This 285is useful as a termination condition when scanning all of the slots in a 286changer: keep a hash of all slots already loaded, and pass that hash in 287C<except_slots>. When the load operation returns a C<notfound> error, the scan 288is complete. 289 290=head3 info 291 292 $chg->info(info_cb => $cb, 293 info => [ $key1, $key2, .. ]) 294 295Query the changer for miscellaneous information. Any number of keys may be 296specified. The C<info_cb> is called with C<$error> as the first argument, 297much like a C<res_cb>, but the remaining arguments form a hash giving values 298for all of the requested keys that are supported by the changer. The preamble 299to such a callback is usually 300 301 info_cb => sub { 302 my ($error, %results) = @_; 303 # .. 304 } 305 306Supported keys are: 307 308=over 2 309 310=item num_slots 311 312The 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 314device that names slots by timestamp could potentially run until the heat-death 315of the universe). 316 317=item vendor_string 318 319A string describing the name and model of the changer device. 320 321=item fast_search 322 323If true, then this changer implements searching (loading by label) with 324something more efficient than a sequential scan through the volumes. This 325information affects some taperscan algorithms and recovery programs, which may 326choose to do their own manual scan instead of invoking many potentially slow 327searches. 328 329=back 330 331=head3 reset 332 333 $chg->reset(finished_cb => $cb) 334 335Reset the changer to a "base" state. This will generally reset the "current" 336slot to something the user would think of as the "first" tape, unload any 337loaded drives, etc. It is an error to call this while any reservations are 338outstanding. 339 340=head3 clean 341 342 $chg->clean(finished_cb => $cb, 343 drive => $drivename) 344 345Clean a drive, if the changer supports it. Drivename can be omitted for devices 346with only one drive, or can be an arbitrary string from the user (e.g., an 347amtape argument). Note that some changers cannot detect the completion of a 348cleaning cycle; in this case, the user will just need to delay further Amanda 349activities until the cleaning is complete. 350 351=head3 eject 352 353 $chg->eject(finished_cb => $cb, 354 drive => $drivename) 355 356Eject the volume in a drive, if the changer supports it. Drivename is as 357specified to C<clean>. If possible, applications should prefer to eject a 358reserved volume when finished with it (C<< $res->release(eject => 1) >>), to 359ensure that the correct volume is ejected from a multi-drive changer. 360 361=head3 update 362 363 $chg->update(finished_cb => $cb, 364 user_msg_fn => $fn, 365 changed => $changed) 366 367The user has changed something -- loading or unloading tapes, reconfiguring the 368changer, etc. -- that may have invalidated the database. C<$changed> is a 369changer-specific string indicating what has changed; if it is omitted, the 370changer will check everything. 371 372Since updates can take a long time, and users often want to know what's going 373on, the update method will call C<user_msg_fn>, if specified, with 374user-oriented messages appropriate to the changer. 375 376=head3 inventory 377 378 $chg->inventory(inventory_cb => $cb) 379 380The C<inventory_cb> is called with an error object as the first parameter, or 381C<undef> if no error occurs. The second parameter is an arrayref containing an 382ordered list of information about the slots in the changer. The order never 383change, but some entries can be added or removed. 384 385Each slot is represented by a hash with the following keys: 386 387=over 4 388 389=item slot 390 391The slot name 392 393=item current 394 395Set to C<1> if it is the current slot. 396 397=item state 398 399Set to C<SLOT_FULL> if the slot is full, C<SLOT_EMPTY> if the slot is empty (no 400volume in slot), C<SLOT_UNKNOWN> if the changer doesn't know if the slot is full 401or not (but it can know), or undef if the changer can't know if the slot is full or not. 402A changer that doesn't keep state must set it to undef, like chg-single. 403These constants are available in the C<:constants> export tag. 404 405A blank or erased volume is not the same as an empty slot. 406 407=item device_status 408 409The device status after the open or read_label, undef if device status is unknown. 410 411=item f_type 412 413The file header type as returned by read_label, only if device_status is DEVICE_STATUS_SUCCESS. 414 415=item label 416 417The label on the volume in this slot, can be set by barcode or by read_label if f_type is Amanda::Header::F_TAPESTART. 418 419=item barcode (optional) 420 421The barcode for the volume in this slot, if barcodes are available. 422 423=item reserved 424 425Set to C<1> if this slot is reserved, either by this process or another 426process. This is only set for I<exclusive> reservations, meaning that loading 427the slot would result in an C<volinuse> error. Devices which can support 428concurrent access will never set this flag. 429 430=item loaded_in (optional) 431 432For changers which have distinct user-visible drives, this gives the drive 433currently accessing the volume in this slot. 434 435=item import_export (optional) 436 437Set to C<1> if this is an import-export slot -- a slot in which the user can 438easily add or remove volumes. This information may be useful for operations to 439bulk-import newly-inserted tapes or bulk-export a set of tapes. 440 441=back 442 443=head3 make_new_tape_label 444 445 $chg->make_new_tape_label(barcode => $barcode, 446 slot => $slot, 447 meta => $meta); 448 449To devise a new name for a volume using the C<barcode> and C<meta> arguments. 450This will return C<undef> if no label could be created. 451 452=head3 make_new_meta_label 453 454 $chg->make_new_meta_label(); 455 456To devise a new meta name for a meta volume. 457This will return C<undef> if no label could be created. 458 459=head3 have_inventory 460 461 $chg->have_inventory() 462 463Return True if the changer have the inventory method. 464 465=head3 volume_is_labelable 466 467 $chg->volume_is_labelable($device_status, $f_type, $label); 468 469Return 1 if the volume is labelable acording to the autolabel setting. 470 471=head3 move 472 473 $chg->move(finished_cb => $cb, 474 from_slot => $from, 475 to_slot => $to) 476 477Move a volume between two slots in the changer. These slots are provided by the 478user, and have meaning for the changer. 479 480=head2 RESERVATION OBJECTS 481 482=head3 Methods 483 484=head3 $res->{'chg'} 485 486This is the changer object. 487 488=head3 $res->{'device'} 489 490This is the fully configured device for the reserved volume. The device is not 491started. 492 493=head3 $res->{'this_slot'} 494 495This is the name of this slot. It is an arbitrary string which will 496have some meaning to the changer's C<load()> method. It is safe to 497access this field after the reservation has been released. 498 499=head3 $res->{'barcode'} 500 501If this changer supports barcodes, then this is the barcode of the reserved 502volume. This can be helpful for labeling tapes using their barcode. 503 504=head3 $label = $res->make_new_tape_label() 505 506To devise a new name for a volume. 507This will return C<undef> if no label could be created. 508 509=head3 $meta = $res->make_new_meta_label() 510 511To devise a new meta name for a meta volume. 512This will return C<undef> if no label could be created. 513 514=head3 $res->release(finished_cb => $cb, eject => $eject) 515 516This is how an Amanda application indicates that it no longer needs the 517reserved volume. The callback is called after any related operations are 518complete -- 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 520the tape drive to eject the tape, while a tape robot can move a tape back to 521storage, leaving the drive empty. If the eject parameter is given and true, it 522indicates that Amanda is done with the volume and has reason to believe the 523user is done with the volume, too -- for example, when a tape has been written 524completely. 525 526A reservation will be released automatically when the object is destroyed, but 527in this case no finished_cb is given, so the release operation may not complete 528before the process exits. Wherever possible, reservations should be explicitly 529released. 530 531=head3 $res->set_label(finished_cb => $cb, label => $label) 532 533This is how Amanda indicates to the changer that the volume in the device has 534been (re-)labeled. Changers can keep a database of volume labels by slot or by 535barcode, or just ignore this function and call $cb immediately. Note that the 536reservation must still be held when this function is called. 537 538=head1 SUBCLASS HELPERS 539 540C<Amanda::Changer> implements some methods and attributes to help subclass 541implementers. 542 543=head2 INFO 544 545Implementing the C<info> method can be tricky, because it can potentially request 546a number of keys that require asynchronous access. The C<info> implementation in 547this class may make the process a bit easier. 548 549First, if the method C<info_setup> is defined, C<info> calls it, passing it a 550C<finished_cb> and the list of desired keys, C<info>. This method is useful to 551gather information that is useful for several info keys. 552 553Next, for each requested key, C<info> calls 554 555 $self->info_key($key, %params) 556 557including a regular C<info_cb> callback. The C<info> method will wait for 558all C<info_key> invocations to finish, then collect the results or errors that 559occur. 560 561=head2 ERROR HANDLING 562 563To create a new error object, use C<< $self->make_error($type, $cb, %args) >>. 564This method will create a new C<Amanda::Changer::Error> object and optionally 565invoke a callback with it. If C<$type> is C<fatal>, then 566C<< $chg->{'fatal_error'} >> is made a reference to the new error object. The 567callback C<$cb> (which should be made using C<make_cb()> from 568C<Amanda::MainLoop>) is called with the new error object. The C<%args> are 569added to the new error object. In use, this looks something like: 570 571 if (!$success) { 572 return $self->make_error("failed", $params{'res_cb'}, 573 reason => "notfound", 574 message => "Volume '$label' not found"); 575 } 576 577This method can also be called as a class method, e.g., from a constructor. 578In this case, it returns the resulting error object, which should be fatal. 579 580 if (!$config_ok) { 581 return Amanda::Changer->make_error("fatal", undef, 582 message => "config error"); 583 } 584 585For 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 587operation, given a callback and an array of tuples C<[ $description, $err ]> 588for each error. This method uses some heuristics to figure out the 589appropriate type and reason for the combined error. 590 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 ] ]); 595 } 596 597Any additional keyword arguments to C<make_combined_error> are put into the 598combined error; this is useful to set the C<slot> attribute. 599 600The method C<< $self->check_error($cb) >> is a useful method for subclasses to 601avoid doing anything after a fatal error. This method checks 602C<< $self->{'fatal_error'} >>. If the error is defined, the method calls C<$cb> 603and returns true. The usual recipe is 604 605 sub load { 606 my $self = shift; 607 my %params = @_; 608 609 return if $self->check_error($params{'res_cb'}); 610 # ... 611 } 612 613=head2 CONFIG 614 615C<Amanda::Changer->new> calls subclass constructors with two parameters: a 616configuration object and a changer specification. The changer specification is 617the string that led to creation of this changer device. The configuration 618object is of type C<Amanda::Changer::Config>, and can be treated as a hashref 619with the following keys: 620 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 629 630The four parameters are just as supplied by the user, either in the global 631config or in a changer section. Changer authors are cautioned not to try to 632override any of these parameters as previous changers have done (e.g., 633C<changerfile> specifying both configuration and state files). Use properties 634instead. 635 636The C<properties> and C<device_properties> parameters are in the format 637provided by C<Amanda::Config>. If C<is_global> is true, then 638C<device_properties> will include any device properties specified globally, as 639well as properties culled from the global tapetype. 640 641The C<configure_device> method generally takes care of the intricacies of 642handling device properties. Pass it a newly opened device and it will apply 643the relevant properties, returning undef on success or an error message on 644failure. 645 646The C<get_property> method is a shortcut method to get the value of a changer 647property, ignoring its the priority and other attributes. In a list context, 648it returns all values for the property; in a scalar context, it returns the 649first value specified. 650 651Many properties are boolean, and Amanda has a habit of accepting a number of 652different ways of writing boolean values. The method 653C<< $config->get_boolean_property($prop, $default) >> will parse such a 654property, returning 0 or 1 if the property is specified, C<$default> if it is 655not specified, or C<undef> if the property cannot be parsed. 656 657=head2 PERSISTENT STATE AND LOCKING 658 659Many changer subclasses need to track state across invocations and between 660different processes, and to ensure that the state is read and written 661atomically. The C<with_locked_state> provides this functionality by 662locking a statefile, only unlocking it after any changes have been written back 663to it. Subclasses can use this method both for mutual exclusion (ensuring that 664only one changer operation is in progress at any time) and for atomic state 665storage. 666 667The C<with_locked_state> method works like C<synchronized> (in 668L<Amanda::MainLoop>), but with some extra arguments: 669 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: 674 $some_cb->(...); 675 }); 676 677The callback C<$some_cb> is assumed to take a changer error as its first 678argument, and if there are any errors locking the statefile, they will be 679reported directly to this callback. Otherwise, a wrapped version of 680C<$some_cb> is passed to the inner C<sub>. When this wrapper is invoked, the 681state will be written to disk and unlocked before the original callback is 682invoked. 683 684The state itself begins as an empty hashref, but subclasses can add arbitrary 685keys to the hash. Serialization is currently handled with L<Data::Dumper>. 686 687=head2 PARAMETER VALIDATION 688 689The C<validate_params> method is useful to make sure that the proper parameters 690are present for a particular method, dying if not. Call it like this: 691 692 $self->validate_params("load", \%params); 693 694The method currently only supports the "load" method, but can be expanded to 695cover other methods. 696 697=head1 SEE ALSO 698 699The Amanda Wiki (http://wiki.zmanda.com) has a higher-level description of the 700changer model implemented by this package. 701 702See amanda-changers(7) for user-level documentation of the changer implementations. 703 704=cut 705 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 708 709# slot is known to contain a volume 710use constant SLOT_FULL => 1; 711 712# slot is known to contain no volume 713use constant SLOT_EMPTY => 2; 714 715# don't known if slot contains a volume 716use constant SLOT_UNKNOWN => 3; 717 718our @EXPORT_OK = qw( SLOT_FULL SLOT_EMPTY SLOT_UNKNOWN ); 719our %EXPORT_TAGS = ( 720 constants => [ qw( SLOT_FULL SLOT_EMPTY SLOT_UNKNOWN ) ], 721); 722 723# this is a "virtual" constructor which instantiates objects of different 724# classes based on its argument. Subclasses should not try to chain up! 725sub new { 726 shift eq 'Amanda::Changer' 727 or die("Do not call the Amanda::Changer constructor from subclasses"); 728 my ($name) = shift; 729 my %params = @_; 730 my ($uri, $cc); 731 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); 737 } 738 739 # maybe a straight-up changer URI? 740 if (_uri_to_pkgname($name)) { 741 return _new_from_uri($name, undef, $name, %params); 742 } 743 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); 752 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); 756 } 757 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"); 766 } 767 768 # maybe a changer alias? 769 if (($uri,$cc) = _changer_alias_to_uri($tpchanger)) { 770 return _new_from_uri($uri, $cc, $tpchanger, %params); 771 } 772 773 # maybe a straight-up changer URI? 774 if (_uri_to_pkgname($tpchanger)) { 775 return _new_from_uri($tpchanger, undef, $tpchanger, %params); 776 } 777 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); 782 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); 786 } 787 788 # maybe a straight-up changer URI? 789 if (_uri_to_pkgname($tapedev)) { 790 return _new_from_uri($tapedev, undef, $tapedev, %params); 791 } 792 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); 797 } else { 798 return Amanda::Changer::Error->new('fatal', 799 message => "You must specify one of 'tapedev' or 'tpchanger'"); 800 } 801 } 802} 803 804sub DESTROY { 805 my $self = shift; 806 807 debug("Changer '$self->{'chg_name'}' not quit") if defined $self->{'chg_name'}; 808} 809 810# do nothing in quit 811sub quit { 812 my $self = shift; 813 814 foreach (keys %$self) { 815 delete $self->{$_}; 816 } 817} 818 819# helper functions for new 820 821sub _changer_alias_to_uri { 822 my ($name) = @_; 823 824 my $cc = Amanda::Config::lookup_changer_config($name); 825 if ($cc) { 826 my $tpchanger = changer_config_getconf($cc, $CHANGER_CONFIG_TPCHANGER); 827 if ($tpchanger) { 828 if (my $uri = _old_script_to_uri($tpchanger)) { 829 return ($uri, $cc); 830 } 831 } 832 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"); 839 } 840 if (!$seen_tpchanger and !$seen_tapedev) { 841 return Amanda::Changer::Error->new('fatal', 842 message => "You must specify one of 'tapedev' or 'tpchanger'"); 843 } 844 $tpchanger ||= changer_config_getconf($cc, $CHANGER_CONFIG_TAPEDEV); 845 846 if (_uri_to_pkgname($tpchanger)) { 847 return ($tpchanger, $cc); 848 } else { 849 die "Changer '$name' specifies invalid tpchanger '$tpchanger'"; 850 } 851 } 852 853 # not an alias 854 return; 855} 856 857sub _old_script_to_uri { 858 my ($name) = @_; 859 860 die("empty changer script name") unless $name; 861 862 if ((-x "$amlibexecdir/$name") or (($name =~ qr{^/}) and (-x $name))) { 863 return "chg-compat:$name" 864 } 865 866 # not an old script 867 return; 868} 869 870# try to load the package for the given URI. $@ is set properly 871# if this function returns a false value. 872sub _uri_to_pkgname { 873 my ($name) = @_; 874 875 my ($type) = ($name =~ /^chg-([A-Za-z_]+):/); 876 if (!defined $type) { 877 $@ = "'$name' is not a changer URI"; 878 return 0; 879 } 880 881 $type =~ tr/A-Z-/a-z_/; 882 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; 887 $filename .= '.pm'; 888 return $pkgname if (exists $INC{$filename}); 889 890 # try loading it 891 eval "use $pkgname;"; 892 if ($@) { 893 my $err = $@; 894 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/) { 898 die($err); 899 } 900 901 return 0; 902 } 903 904 return $pkgname; 905} 906 907sub _new_from_uri { # (note: this sub is patched by the installcheck) 908 my $uri = shift; 909 my $cc = shift; 910 my $name = shift; 911 my %params = @_; 912 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 915 # easily 916 if (ref $uri and $uri->isa("Amanda::Changer::Error")) { 917 return $uri; 918 } 919 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 922 # as keys 923 my $uri_cc = "$uri\n"; 924 if (defined $cc) { 925 $uri_cc = $uri_cc . changer_config_name($cc); 926 } 927 928 # return a pre-existing changer, if possible 929 930 # look up the type and load the class 931 my $pkgname = _uri_to_pkgname($uri); 932 if (!$pkgname) { 933 die $@; 934 } 935 936 my $rv = eval {$pkgname->new(Amanda::Changer::Config->new($cc), $uri);}; 937 die "$pkgname->new failed: $@" 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")); 940 941 if ($rv->isa("Amanda::Changer::Error")) { 942 return $rv; 943 } 944 945 if ($rv->isa("Amanda::Changer")) { 946 # add an instance variable or two 947 $rv->{'fatal_error'} = undef; 948 } 949 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; 961 return $rv; 962} 963 964# method stubs that return a "notimpl" error 965 966sub _stubop { 967 my ($op, $cbname, $self, %params) = @_; 968 return if $self->check_error($params{$cbname}); 969 970 my $class = ref($self); 971 my $chg_foo = "chg-" . ($class =~ /Amanda::Changer::(.*)/)[0]; 972 return $self->make_error("failed", $params{$cbname}, 973 reason => "notimpl", 974 message => "'$chg_foo:' does not support $op"); 975} 976 977sub load { _stubop("loading volumes", "res_cb", @_); } 978sub reset { _stubop("reset", "finished_cb", @_); } 979sub clean { _stubop("clean", "finished_cb", @_); } 980sub eject { _stubop("eject", "finished_cb", @_); } 981sub update { _stubop("update", "finished_cb", @_); } 982sub inventory { _stubop("inventory", "inventory_cb", @_); } 983sub move { _stubop("move", "finished_cb", @_); } 984sub set_meta_label { _stubop("set_meta_label", "finished_cb", @_); } 985sub get_meta_label { _stubop("get_meta_label", "finished_cb", @_); } 986sub verify { _stubop("verify", "finished_cb", @_); } 987 988sub have_inventory { 989 my $self = shift; 990 991 return $self->can("inventory") ne \&Amanda::Changer::inventory; 992} 993 994# info calls out to info_setup and info_key; see POD above 995sub info { 996 my $self = shift; 997 my %params = @_; 998 999 if (!$self->can('info_key')) { 1000 my $class = ref($self); 1001 $params{'info_cb'}->("$class does not support info()"); 1002 return; 1003 } 1004 1005 my ($do_setup, $start_keys, $all_done); 1006 1007 $do_setup = sub { 1008 if ($self->can('info_setup')) { 1009 $self->info_setup(info => $params{'info'}, 1010 finished_cb => sub { 1011 my ($err) = @_; 1012 if ($err) { 1013 $params{'info_cb'}->($err); 1014 } else { 1015 $start_keys->(); 1016 } 1017 }); 1018 } else { 1019 $start_keys->(); 1020 } 1021 }; 1022 1023 $start_keys = sub { 1024 my $remaining_keys = 1; 1025 my %key_results; 1026 1027 my $maybe_done = sub { 1028 return if (--$remaining_keys); 1029 $all_done->(%key_results); 1030 }; 1031 1032 for my $key (@{$params{'info'}}) { 1033 $remaining_keys++; 1034 $self->info_key($key, info_cb => sub { 1035 $key_results{$key} = [ @_ ]; 1036 $maybe_done->(); 1037 }); 1038 } 1039 1040 # we started with $remaining_keys = 1, so decrement it now 1041 $maybe_done->(); 1042 }; 1043 1044 $all_done = sub { 1045 my %key_results = @_; 1046 1047 # if there are *any* errors, handle them 1048 my @annotated_errs = 1049 map { [ sprintf("While getting info key '%s'", $_), $key_results{$_}->[0] ] } 1050 grep { defined($key_results{$_}->[0]) } 1051 sort keys %key_results; 1052 1053 if (@annotated_errs) { 1054 return $self->make_combined_error( 1055 $params{'info_cb'}, [ @annotated_errs ]); 1056 } 1057 1058 # no errors, so combine the results and return them 1059 my %info; 1060 while (my ($key, $result) = each(%key_results)) { 1061 my ($err, %key_info) = @$result; 1062 if (exists $key_info{$key}) { 1063 $info{$key} = $key_info{$key}; 1064 } else { 1065 warn("No value available for $key"); 1066 } 1067 } 1068 1069 $params{'info_cb'}->(undef, %info); 1070 }; 1071 1072 $do_setup->(); 1073} 1074 1075# subclass helpers 1076 1077sub make_error { 1078 my $self = shift; 1079 my ($type, $cb, %args) = @_; 1080 1081 my $classmeth = $self eq "Amanda::Changer"; 1082 1083 if ($classmeth and $type ne 'fatal') { 1084 cluck("type must be fatal when calling make_error as a class method"); 1085 $type = 'fatal'; 1086 } 1087 1088 my $err = Amanda::Changer::Error->new($type, %args); 1089 1090 if (!$classmeth) { 1091 $self->{'fatal_error'} = $err 1092 if ($err->fatal); 1093 1094 $cb->($err) if $cb; 1095 } 1096 1097 return $err; 1098} 1099 1100sub make_combined_error { 1101 my $self = shift; 1102 my ($cb, $suberrors, %extra_args) = @_; 1103 my $err; 1104 1105 if (@$suberrors == 0) { 1106 die("make_combined_error called with no errors"); 1107 } 1108 1109 my $classmeth = $self eq "Amanda::Changer"; 1110 1111 # if there's only one suberror, just use it directly 1112 if (@$suberrors == 1) { 1113 $err = $suberrors->[0][1]; 1114 die("$err is not an Error object") 1115 unless defined($err) and $err->isa("Amanda::Changer::Error"); 1116 1117 $err = Amanda::Changer::Error->new( 1118 $err->{'type'}, 1119 reason => $err->{'reason'}, 1120 message => $suberrors->[0][0] . ": " . $err->{'message'}); 1121 } else { 1122 my $fatal = $classmeth or grep { $_->[1]{'fatal'} } @$suberrors; 1123 1124 my $reason; 1125 if (!$fatal) { 1126 my %reasons = 1127 map { ($_->[1]{'reason'}, undef) } 1128 grep { $_->[1]{'reason'} } 1129 @$suberrors; 1130 if ((keys %reasons) == 1) { 1131 $reason = (keys %reasons)[0]; 1132 } else { 1133 $reason = 'unknown'; # multiple or 0 "source" reasons 1134 } 1135 } 1136 1137 my $message = join("; ", 1138 map { sprintf("%s: %s", @$_) } 1139 @$suberrors); 1140 1141 my %errargs = ( message => $message, %extra_args ); 1142 $errargs{'reason'} = $reason unless ($fatal); 1143 $err = Amanda::Changer::Error->new( 1144 $fatal? "fatal" : "failed", 1145 %errargs); 1146 } 1147 1148 if (!$classmeth) { 1149 $self->{'fatal_error'} = $err 1150 if ($err->fatal); 1151 1152 $cb->($err) if $cb; 1153 } 1154 1155 return $err; 1156} 1157 1158sub check_error { 1159 my $self = shift; 1160 my ($cb) = @_; 1161 1162 if (defined $self->{'fatal_error'}) { 1163 $cb->($self->{'fatal_error'}) if $cb; 1164 return 1; 1165 } 1166} 1167 1168sub lock_statefile { 1169 my $self = shift; 1170 my %params = @_; 1171 1172 my $statefile = $params{'statefile_filename'}; 1173 my $lock_cb = $params{'lock_cb'}; 1174 Amanda::Changer::StateFile->new($statefile, $lock_cb); 1175} 1176 1177sub with_locked_state { 1178 my $self = shift; 1179 my ($statefile, $cb, $sub) = @_; 1180 my ($filelock, $STATE); 1181 my $poll = 0; # first delay will be 0.1s; see below 1182 my $time; 1183 1184 if (defined $self->{'lock-timeout'}) { 1185 $time = time() + $self->{'lock-timeout'}; 1186 } else { 1187 $time = time() + 1000; 1188 } 1189 1190 my $steps = define_steps 1191 cb_ref => \$cb; 1192 1193 step open => sub { 1194 $filelock = Amanda::Util::file_lock->new($statefile); 1195 1196 $steps->{'lock'}->(); 1197 }; 1198 1199 step lock => sub { 1200 my $rv = $filelock->lock(); 1201 my $error = $!; 1202 if ($rv == 1 && time() < $time) { 1203 # loop until we get the lock, increasing $poll to 10s 1204 $poll += 100 unless $poll >= 10000; 1205 return Amanda::MainLoop::call_after($poll, $steps->{'lock'}); 1206 } elsif ($rv == 1) { 1207 return $self->make_error("fatal", $cb, 1208 message => "Timeout trying to lock '$statefile': $error"); 1209 } elsif ($rv == -1) { 1210 return $self->make_error("fatal", $cb, 1211 message => "Error locking '$statefile': $error"); 1212 } 1213 1214 $steps->{'read'}->(); 1215 }; 1216 1217 step read => sub { 1218 my $contents = $filelock->data(); 1219 if ($contents) { 1220 eval $contents; 1221 if ($@) { 1222 # $fh goes out of scope here, and is thus automatically 1223 # unlocked 1224 debug("error reading '$statefile': $@"); 1225 $STATE = {}; 1226 } 1227 if (!defined $STATE or ref($STATE) ne 'HASH') { 1228 debug("'$statefile' did not define \$STATE properly"); 1229 $STATE = {}; 1230 } 1231 } else { 1232 # initial state (blank file) 1233 $STATE = {}; 1234 } 1235 1236 $sub->($STATE, $steps->{'cb_wrap'}); 1237 }; 1238 1239 step cb_wrap => sub { 1240 my @args = @_; 1241 1242 my $dumper = Data::Dumper->new([ $STATE ], ["STATE"]); 1243 $dumper->Purity(1); 1244 $filelock->write($dumper->Dump); 1245 $filelock->unlock(); 1246 1247 # call through to the original callback with the original 1248 # arguments 1249 $cb->(@args); 1250 }; 1251} 1252 1253sub validate_params { 1254 my ($self, $op, $params) = @_; 1255 1256 if ($op eq 'load') { 1257 unless(exists $params->{'label'} || exists $params->{'slot'} || 1258 exists $params->{'relative_slot'}) { 1259 confess "Invalid parameters to 'load'"; 1260 } 1261 } else { 1262 confess "don't know how to validate '$op'"; 1263 } 1264} 1265 1266sub make_new_tape_label { 1267 my $self = shift; 1268 my %params = @_; 1269 1270 my $tl = $self->{'tapelist'}; 1271 die ("make_new_tape_label: no tapelist") if !$tl; 1272 if (!defined $self->{'autolabel'}) { 1273 return (undef, "autolabel not set"); 1274 } 1275 if (!defined $self->{'autolabel'}->{'template'}) { 1276 return (undef, "template is not set, you must set autolabel"); 1277 } 1278 if (!defined $self->{'labelstr'}) { 1279 return (undef, "labelstr not set"); 1280 } 1281 my $template = $self->{'autolabel'}->{'template'}; 1282 my $labelstr = $self->{'labelstr'}; 1283 my $slot_digit = 1; 1284 1285 $template =~ s/\$\$/SUBSTITUTE_DOLLAR/g; 1286 $template =~ s/\$b/SUBSTITUTE_BARCODE/g; 1287 $template =~ s/\$m/SUBSTITUTE_META/g; 1288 $template =~ s/\$o/SUBSTITUTE_ORG/g; 1289 $template =~ s/\$c/SUBSTITUTE_CONFIG/g; 1290 if ($template =~ /\$([0-9]*)s/) { 1291 $slot_digit = $1; 1292 $slot_digit = 1 if $slot_digit < 1; 1293 $template =~ s/\$[0-9]*s/SUBSTITUTE_SLOT/g; 1294 } 1295 1296 my $org = getconf($CNF_ORG); 1297 my $config = Amanda::Config::get_config_name(); 1298 my $barcode = $params{'barcode'}; 1299 $barcode = '' if !defined $barcode; 1300 my $meta = $params{'meta'}; 1301 my $slot = $params{'slot'}; 1302 $slot = '' if !defined $slot; 1303 $meta = $self->make_new_meta_label(%params) if !defined $meta; 1304 $meta = '' if !defined $meta; 1305 1306 $template =~ s/SUBSTITUTE_DOLLAR/\$/g; 1307 $template =~ s/SUBSTITUTE_ORG/$org/g; 1308 $template =~ s/SUBSTITUTE_CONFIG/$config/g; 1309 $template =~ s/SUBSTITUTE_META/$meta/g; 1310 # Do not susbtitute the barcode and slot now 1311 1312 (my $npercents = 1313 $template) =~ s/[^%]*(%+)[^%]*/length($1)/e; 1314 $npercents = 0 if $npercents eq $template; 1315 1316 my $label; 1317 if ($npercents == 0) { 1318 $label = $template; 1319 $label =~ s/SUBSTITUTE_BARCODE/$barcode/g; 1320 if ($template =~ /SUBSTITUTE_SLOT/) { 1321 my $slot_label = sprintf("%0*d", $slot_digit, $slot); 1322 $label =~ s/SUBSTITUTE_SLOT/$slot_label/g; 1323 } 1324 if ($template =~ /SUBSTITUTE_BARCODE/ && !defined $barcode) { 1325 return (undef, "Can't generate new label because volume has no barcode"); 1326 } elsif ($template =~ /SUBSTITUTE_SLOT/ && !defined $slot) { 1327 return (undef, "Can't generate new label because volume has no slot"); 1328 } elsif ($label eq $template) { 1329 return (undef, "autolabel require at least one '%'"); 1330 } elsif ($tl->lookup_tapelabel($label)) { 1331 return (undef, "Label '$label' already exists"); 1332 } 1333 } else { 1334 # make up a sprintf pattern 1335 (my $sprintf_pat = 1336 $template) =~ s/(%+)/"%0" . length($1) . "d"/e; 1337 1338 my %existing_labels; 1339 for my $tle (@{$tl->{'tles'}}) { 1340 if (defined $tle && defined $tle->{'label'}) { 1341 my $tle_label = $tle->{'label'}; 1342 my $tle_barcode = $tle->{'barcode'}; 1343 if (defined $tle_barcode) { 1344 $tle_label =~ s/$tle_barcode/SUBSTITUTE_BARCODE/g; 1345 } 1346 $existing_labels{$tle_label} = 1 if defined $tle_label; 1347 } 1348 } 1349 1350 my $nlabels = 10 ** $npercents; 1351 my ($i); 1352 for ($i = 1; $i < $nlabels; $i++) { 1353 $label = sprintf($sprintf_pat, $i); 1354 last unless (exists $existing_labels{$label}); 1355 } 1356 1357 # susbtitute the barcode and slot 1358 $label =~ s/SUBSTITUTE_BARCODE/$barcode/g; 1359 if ($template =~ /SUBSTITUTE_SLOT/) { 1360 my $slot_label = sprintf("%0*d", $slot_digit, $slot); 1361 $label =~ s/SUBSTITUTE_SLOT/$slot_label/g; 1362 } 1363 1364 # bail out if we didn't find an unused label 1365 return (undef, "Can't label unlabeled volume: All label used") 1366 if ($i >= $nlabels); 1367 } 1368 1369 # verify $label matches $labelstr 1370 if ($label !~ /$labelstr/) { 1371 return (undef, "Newly-generated label '$label' does not match labelstr '$labelstr'"); 1372 } 1373 1374 if (!$label) { 1375 return (undef, "Generated label is empty"); 1376 } 1377 1378 return $label; 1379} 1380 1381sub make_new_meta_label { 1382 my $self = shift; 1383 my %params = @_; 1384 1385 my $tl = $self->{'tapelist'}; 1386 die ("make_new_meta_label: no tapelist") if !$tl; 1387 return undef if !defined $self->{'meta_autolabel'}; 1388 my $template = $self->{'meta_autolabel'}; 1389 return if !defined $template; 1390 1391 if (!$template) { 1392 return (undef, "template is not set, you must set meta-autolabel"); 1393 } 1394 $template =~ s/\$\$/SUBSTITUTE_DOLLAR/g; 1395 $template =~ s/\$o/SUBSTITUTE_ORG/g; 1396 $template =~ s/\$c/SUBSTITUTE_CONFIG/g; 1397 1398 my $org = getconf($CNF_ORG); 1399 my $config = Amanda::Config::get_config_name(); 1400 1401 $template =~ s/SUBSTITUTE_DOLLAR/\$/g; 1402 $template =~ s/SUBSTITUTE_ORG/$org/g; 1403 $template =~ s/SUBSTITUTE_CONFIG/$config/g; 1404 1405 (my $npercents = 1406 $template) =~ s/[^%]*(%+)[^%]*/length($1)/e; 1407 $npercents = 0 if $npercents eq $template; 1408 my $nlabels = 10 ** $npercents; 1409 1410 # make up a sprintf pattern 1411 (my $sprintf_pat = $template) =~ s/(%+)/"%0" . length($1) . "d"/e; 1412 1413 my %existing_meta_labels = 1414 map { $_->{'meta'} => 1 } grep { defined $_->{'meta'} } @{$tl->{'tles'}}; 1415 1416 my ($i, $meta); 1417 for ($i = 1; $i < $nlabels; $i++) { 1418 $meta = sprintf($sprintf_pat, $i); 1419 last unless (exists $existing_meta_labels{$meta}); 1420 } 1421 1422 # bail out if we didn't find an unused label 1423 return (undef, "Can't label unlabeled meta volume: All meta label used") 1424 if ($i >= $nlabels); 1425 1426 if (!$meta) { 1427 return (undef, "Generated meta-label is empty"); 1428 } 1429 1430 return $meta; 1431} 1432 1433sub volume_is_labelable { 1434 my $self = shift; 1435 my $dev_status = shift; 1436 my $f_type = shift; 1437 my $label = shift; 1438 my $autolabel = $self->{'autolabel'}; 1439 1440 if (!defined $dev_status) { 1441 return 0; 1442 } elsif ($dev_status & $DEVICE_STATUS_VOLUME_UNLABELED and 1443 defined $f_type and 1444 $f_type == $Amanda::Header::F_EMPTY) { 1445 return 0 if (!$autolabel->{'empty'}); 1446 } elsif ($dev_status & $DEVICE_STATUS_VOLUME_UNLABELED and 1447 defined $f_type and 1448 $f_type == $Amanda::Header::F_WEIRD) { 1449 return 0 if (!$autolabel->{'non_amanda'}); 1450 } elsif ($dev_status & $DEVICE_STATUS_VOLUME_ERROR) { 1451 return 0 if (!$autolabel->{'volume_error'}); 1452 } elsif ($dev_status != $DEVICE_STATUS_SUCCESS) { 1453 return 0; 1454 } elsif ($dev_status & $DEVICE_STATUS_SUCCESS and 1455 $f_type == $Amanda::Header::F_TAPESTART and 1456 $label !~ /$self->{'labelstr'}/) { 1457 return 0 if (!$autolabel->{'other_config'}); 1458 } 1459 1460 return 1; 1461} 1462 1463package Amanda::Changer::Error; 1464use Amanda::Debug qw( :logging ); 1465use Carp qw( cluck ); 1466use Amanda::Debug; 1467use overload 1468 '""' => sub { $_[0]->{'message'}; }, 1469 'cmp' => sub { $_[0]->{'message'} cmp $_[1]; }; 1470 1471my %known_err_types = map { ($_, 1) } qw( fatal failed ); 1472my %known_err_reasons = map { ($_, 1) } qw( notfound invalid notimpl driveinuse volinuse unknown device empty ); 1473 1474sub new { 1475 my $class = shift; # ignore class 1476 my ($type, %info) = @_; 1477 1478 my $reason = ""; 1479 $reason = ", reason='$info{reason}'" if $type eq "failed"; 1480 debug("new Amanda::Changer::Error: type='$type'$reason, message='$info{message}'"); 1481 1482 $info{'type'} = $type; 1483 1484 # do some sanity checks. Note that these sanity checks issue a warning 1485 # with cluck, but add default values to the error. This is in the hope 1486 # that an unusual Amanda error is not obscured by a problem in the 1487 # make_error invocation. The stack trace produced by cluck should help to 1488 # track down the bad make_error invocation. 1489 1490 if (!exists $info{'message'}) { 1491 cluck("no message given to A::C::make_error"); 1492 $info{'message'} = "unknown error"; 1493 } 1494 1495 if (!exists $known_err_types{$type}) { 1496 cluck("invalid Amanda::Changer::Error type '$type'"); 1497 $type = 'fatal'; 1498 } 1499 1500 if ($type eq 'failed' and !exists $info{'reason'}) { 1501 cluck("no reason given to A::C::make_error"); 1502 $info{'reason'} = "unknown"; 1503 } 1504 1505 if ($type eq 'failed' and !exists $known_err_reasons{$info{'reason'}}) { 1506 cluck("invalid Amanda::Changer::Error reason '$info{reason}'"); 1507 $info{'reason'} = 'unknown'; 1508 } 1509 1510 return bless (\%info, $class); 1511} 1512 1513# do nothing in quit 1514sub quit {} 1515 1516# types 1517sub fatal { $_[0]->{'type'} eq 'fatal'; } 1518sub failed { $_[0]->{'type'} eq 'failed'; } 1519 1520# reasons 1521sub notfound { $_[0]->failed && $_[0]->{'reason'} eq 'notfound'; } 1522sub invalid { $_[0]->failed && $_[0]->{'reason'} eq 'invalid'; } 1523sub notimpl { $_[0]->failed && $_[0]->{'reason'} eq 'notimpl'; } 1524sub driveinuse { $_[0]->failed && $_[0]->{'reason'} eq 'driveinuse'; } 1525sub volinuse { $_[0]->failed && $_[0]->{'reason'} eq 'volinuse'; } 1526sub unknown { $_[0]->failed && $_[0]->{'reason'} eq 'unknown'; } 1527sub empty { $_[0]->failed && $_[0]->{'reason'} eq 'empty'; } 1528sub device { $_[0]->failed && $_[0]->{'reason'} eq 'device'; } 1529 1530# slot accessor 1531sub slot { $_[0]->{'slot'}; } 1532 1533package Amanda::Changer::Reservation; 1534# this is a simple base class with stub method or two. 1535use Amanda::Config qw( :getconf ); 1536 1537sub new { 1538 my $class = shift; 1539 my $self = { 1540 released => 0, 1541 }; 1542 return bless ($self, $class) 1543} 1544 1545sub DESTROY { 1546 my ($self) = @_; 1547 if (!$self->{'released'}) { 1548 if (defined $self->{this_slot}) { 1549 Amanda::Debug::warning("Changer reservation for slot '$self->{this_slot}' has " . 1550 "gone out of scope without release"); 1551 } else { 1552 Amanda::Debug::warning("Changer reservation for unknown slot has " . 1553 "gone out of scope without release"); 1554 } 1555 } 1556} 1557 1558sub set_label { 1559 my $self = shift; 1560 my %params = @_; 1561 1562 # nothing to do by default: just call the finished callback 1563 if (exists $params{'finished_cb'}) { 1564 $params{'finished_cb'}->(undef) if $params{'finished_cb'}; 1565 } 1566} 1567 1568sub release { 1569 my $self = shift; 1570 my %params = @_; 1571 1572 if ($self->{'released'}) { 1573 $params{'finished_cb'}->(undef) if exists $params{'finished_cb'}; 1574 return; 1575 } 1576 1577 # always finish the device on release; it's illegal for anything 1578 # else to use the device after this point, anyway, so we want to 1579 # release the device's resources immediately 1580 if (defined $self->{'device'}) { 1581 $self->{'device'}->finish(); 1582 } 1583 1584 $self->{'released'} = 1; 1585 $self->do_release(%params); 1586} 1587 1588sub do_release { 1589 my $self = shift; 1590 my %params = @_; 1591 1592 # this is the one subclasses should override 1593 1594 if (exists $params{'finished_cb'}) { 1595 $params{'finished_cb'}->(undef) if $params{'finished_cb'}; 1596 } 1597} 1598 1599sub get_meta_label { 1600 my $self = shift; 1601 my %params = @_; 1602 1603 # this is the one subclasses should override 1604 1605 if (exists $params{'finished_cb'}) { 1606 $params{'finished_cb'}->(undef) if $params{'finished_cb'}; 1607 } 1608} 1609 1610sub set_meta_label { 1611 my $self = shift; 1612 my %params = @_; 1613 1614 # this is the one subclasses should override 1615 1616 if (exists $params{'finished_cb'}) { 1617 $params{'finished_cb'}->(undef) if $params{'finished_cb'}; 1618 } 1619} 1620 1621sub make_new_tape_label { 1622 my $self = shift; 1623 my %params = @_; 1624 1625 $params{'barcode'} = $self->{'barcode'} if !defined $params{'barcode'}; 1626 $params{'meta'} = $self->{'meta'} if !defined $params{'meta'}; 1627 $params{'slot'} = $self->{'this_slot'} if !defined $params{'slot'}; 1628 return $self->{'chg'}->make_new_tape_label(%params); 1629} 1630 1631 1632sub make_new_meta_label { 1633 my $self = shift; 1634 my %params = @_; 1635 1636 return $self->{'chg'}->make_new_meta_label(%params); 1637} 1638 1639package Amanda::Changer::Config; 1640use Amanda::Config qw( :getconf string_to_boolean ); 1641use Amanda::Device qw( :constants ); 1642 1643sub new { 1644 my $class = shift; 1645 my ($cc) = @_; 1646 1647 my $self = bless {}, $class; 1648 1649 if (defined $cc) { 1650 $self->{'name'} = changer_config_name($cc); 1651 $self->{'is_global'} = 0; 1652 1653 $self->{'tapedev'} = changer_config_getconf($cc, $CHANGER_CONFIG_TAPEDEV); 1654 $self->{'tpchanger'} = changer_config_getconf($cc, $CHANGER_CONFIG_TPCHANGER); 1655 $self->{'changerdev'} = changer_config_getconf($cc, $CHANGER_CONFIG_CHANGERDEV); 1656 $self->{'changerfile'} = changer_config_getconf($cc, $CHANGER_CONFIG_CHANGERFILE); 1657 1658 $self->{'properties'} = changer_config_getconf($cc, $CHANGER_CONFIG_PROPERTY); 1659 $self->{'device_properties'} = changer_config_getconf($cc, $CHANGER_CONFIG_DEVICE_PROPERTY); 1660 } else { 1661 $self->{'name'} = "default"; 1662 $self->{'is_global'} = 1; 1663 1664 $self->{'tapedev'} = getconf($CNF_TAPEDEV); 1665 $self->{'tpchanger'} = getconf($CNF_TPCHANGER); 1666 $self->{'changerdev'} = getconf($CNF_CHANGERDEV); 1667 $self->{'changerfile'} = getconf($CNF_CHANGERFILE); 1668 1669 # no changer or device properties, since there's no changer definition to use 1670 $self->{'properties'} = {}; 1671 $self->{'device_properties'} = {}; 1672 } 1673 return $self; 1674} 1675 1676sub configure_device { 1677 my $self = shift; 1678 my ($device) = @_; 1679 1680 # we'll accumulate properties in this hash *overwriting* previous properties 1681 # instead of appending to them 1682 my %properties; 1683 1684 # always use implicit properties 1685 %properties = ( %properties, %{ $self->_get_implicit_properties() } ); 1686 1687 # always use global properties 1688 %properties = ( %properties, %{ getconf($CNF_DEVICE_PROPERTY) } ); 1689 1690 # if this is a device alias, add properties from its device definition 1691 if (my $dc = lookup_device_config($device->device_name)) { 1692 %properties = ( %properties, 1693 %{ device_config_getconf($dc, $DEVICE_CONFIG_DEVICE_PROPERTY); } ); 1694 } 1695 1696 # finally, add any props from the changer config 1697 %properties = ( %properties, %{ $self->{'device_properties'} } ); 1698 1699 while (my ($propname, $propinfo) = each(%properties)) { 1700 for my $value (@{$propinfo->{'values'}}) { 1701 if (!$device->property_set($propname, $value)) { 1702 my $msg; 1703 if ($device->status == $DEVICE_STATUS_SUCCESS) { 1704 $msg = "Error setting '$propname' on device '".$device->device_name."'"; 1705 } else { 1706 $msg = $device->error() . " on device '".$device->device_name."'"; 1707 } 1708 if (exists $propinfo->{'optional'}) { 1709 if ($propinfo->{'optional'} eq 'warn') { 1710 warn("$msg (ignored)"); 1711 } 1712 } else { 1713 return $msg; 1714 } 1715 } 1716 } 1717 } 1718 1719 return undef; 1720} 1721 1722sub get_property { 1723 my $self = shift; 1724 my ($property) = @_; 1725 1726 my $prophash = $self->{'properties'}->{$property}; 1727 return undef unless defined($prophash); 1728 1729 return wantarray? @{$prophash->{'values'}} : $prophash->{'values'}->[0]; 1730} 1731 1732sub get_boolean_property { 1733 my ($self) = shift; 1734 my ($propname, $default) = @_; 1735 1736 return $default 1737 unless (exists $self->{'properties'}->{$propname}); 1738 1739 my $propinfo = $self->{'properties'}->{$propname}; 1740 return undef unless @{$propinfo->{'values'}} == 1; 1741 return string_to_boolean($propinfo->{'values'}->[0]); 1742} 1743 1744sub _get_implicit_properties { 1745 my $self = shift; 1746 my $props = {}; 1747 1748 my $tapetype_name = getconf($CNF_TAPETYPE); 1749 return unless defined($tapetype_name); 1750 1751 my $tapetype = lookup_tapetype($tapetype_name); 1752 return unless defined($tapetype); 1753 1754 # The property hashes used here add the 'optional' key, which indicates 1755 # that the property is implicit and that a failure to set it is not fatal. 1756 # The flag is used by configure_device. 1757 if (tapetype_seen($tapetype, $TAPETYPE_LENGTH)) { 1758 $props->{Amanda::Config::amandaify_property_name('max-volume-usage')} = { 1759 optional => 1, 1760 priority => 0, 1761 append => 0, 1762 values => [ 1763 tapetype_getconf($tapetype, $TAPETYPE_LENGTH) * 1024, 1764 ]}; 1765 } 1766 1767 if (tapetype_seen($tapetype, $TAPETYPE_READBLOCKSIZE)) { 1768 $props->{Amanda::Config::amandaify_property_name('read-block-size')} = { 1769 optional => "warn", # optional, but give a warning 1770 priority => 0, 1771 append => 0, 1772 values => [ 1773 tapetype_getconf($tapetype, $TAPETYPE_READBLOCKSIZE) * 1024, 1774 ]}; 1775 } 1776 1777 if (tapetype_seen($tapetype, $TAPETYPE_BLOCKSIZE)) { 1778 $props->{Amanda::Config::amandaify_property_name('block-size')} = { 1779 optional => 0, 1780 priority => 0, 1781 append => 0, 1782 values => [ 1783 # convert the length from kb to bytes here 1784 tapetype_getconf($tapetype, $TAPETYPE_BLOCKSIZE) * 1024, 1785 ]}; 1786 } 1787 1788 return $props; 1789} 1790 17911; 1792