git.gag.com Git - debian/amanda/blob - installcheck/Amanda_Device.pl

   1 # Copyright (c) 2008, 2009, 2010 Zmanda, Inc.  All Rights Reserved.
   2 #
   3 # This program is free software; you can redistribute it and/or modify it
   4 # under the terms of the GNU General Public License version 2 as published
   5 # by the Free Software Foundation.
   6 #
   7 # This program is distributed in the hope that it will be useful, but
   8 # WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
   9 # or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  10 # for more details.
  11 #
  12 # You should have received a copy of the GNU General Public License along
  13 # with this program; if not, write to the Free Software Foundation, Inc.,
  14 # 59 Temple Place, Suite 330, Boston, MA  02111-1307 USA
  15 #
  16 # Contact information: Zmanda Inc, 465 S. Mathilda Ave., Suite 300
  17 # Sunnyvale, CA 94086, USA, or: http://www.zmanda.com
  18
  19 use Test::More tests => 482;
  20 use File::Path qw( mkpath rmtree );
  21 use Sys::Hostname;
  22 use Carp;
  23 use strict;
  24
  25 use lib "@amperldir@";
  26 use Installcheck;
  27 use Installcheck::Mock;
  28 use Installcheck::Config;
  29 use Amanda::Debug;
  30 use Amanda::Device qw( :constants );
  31 use Amanda::Config qw( :getconf :init );
  32 use Amanda::Xfer qw( :constants );
  33 use Amanda::Header qw( :constants );
  34 use Amanda::Paths;
  35 use Amanda::Tests;
  36 use Amanda::Util;
  37 use Amanda::MainLoop;
  38 use IO::Socket;
  39
  40 my $dev;
  41 my $dev_name;
  42 my ($vtape1, $vtape2);
  43 my ($input_filename, $output_filename) =
  44     ( "$Installcheck::TMP/input.tmp", "$Installcheck::TMP/output.tmp" );
  45 my $taperoot = "$Installcheck::TMP/Amanda_Device_test_tapes";
  46 my $testconf;
  47 my $queue_fd;
  48
  49 # we'll need some vtapes..
  50 sub mkvtape {
  51     my ($num) = @_;
  52
  53     my $mytape = "$taperoot/$num";
  54     if (-d $mytape) { rmtree($mytape); }
  55     mkpath("$mytape/data");
  56     return $mytape;
  57 }
  58
  59
  60 # make up a fake dumpfile_t to write with
  61 my $dumpfile = Amanda::Header->new();
  62 $dumpfile->{type} = $Amanda::Header::F_DUMPFILE;
  63 $dumpfile->{datestamp} = "20070102030405";
  64 $dumpfile->{dumplevel} = 0;
  65 $dumpfile->{compressed} = 1;
  66 $dumpfile->{name} = "localhost";
  67 $dumpfile->{disk} = "/home";
  68 $dumpfile->{program} = "INSTALLCHECK";
  69
  70 # function to set up a queue_fd for a filename
  71 sub make_queue_fd {
  72     my ($filename, $mode) = @_;
  73
  74     open(my $fd, $mode, $filename) or die("Could not open $filename: $!");
  75     return $fd, Amanda::Device::queue_fd_t->new($fd);
  76 }
  77
  78 my $write_file_count = 5;
  79 sub write_file {
  80     my ($seed, $length, $filenum) = @_;
  81
  82     croak ("selected file size $length is *way* too big")
  83         unless ($length < 1024*1024*10);
  84     Amanda::Tests::write_random_file($seed, $length, $input_filename);
  85
  86     $dumpfile->{'datestamp'} = "2000010101010$filenum";
  87
  88     ok($dev->start_file($dumpfile),
  89         "start file $filenum")
  90         or diag($dev->error_or_status());
  91
  92     is($dev->file(), $filenum,
  93         "Device has correct filenum");
  94
  95     my ($input, $queue_fd) = make_queue_fd($input_filename, "<");
  96     ok($dev->write_from_fd($queue_fd),
  97         "write some data")
  98         or diag($dev->error_or_status());
  99     close($input) or die("Error closing $input_filename");
 100
 101     if(ok($dev->in_file(),
 102         "still in_file")) {
 103         ok($dev->finish_file(),
 104             "finish_file")
 105             or diag($dev->error_or_status());
 106     } else {
 107         pass("not in file, so not calling finish_file");
 108     }
 109 }
 110
 111 my $verify_file_count = 5;
 112 sub verify_file {
 113     my ($seed, $length, $filenum) = @_;
 114
 115     ok(my $read_dumpfile = $dev->seek_file($filenum),
 116         "seek to file $filenum")
 117         or diag($dev->error_or_status());
 118     is($dev->file(), $filenum,
 119         "device is really at file $filenum");
 120     ok(header_for($read_dumpfile, $filenum),
 121         "header is correct")
 122         or diag($dev->error_or_status());
 123
 124     my ($output, $queue_fd) = make_queue_fd($output_filename, ">");
 125     ok($dev->read_to_fd($queue_fd),
 126         "read data from file $filenum")
 127         or diag($dev->error_or_status());
 128     close($output) or die("Error closing $output_filename");
 129
 130     ok(Amanda::Tests::verify_random_file($seed, $length, $output_filename, 0),
 131         "verified file contents");
 132 }
 133
 134 sub header_for {
 135     my ($hdr, $filenum) = @_;
 136     return ($hdr and $hdr->{'datestamp'} eq "2000010101010$filenum");
 137 }
 138
 139 # properties test
 140
 141 my @common_properties = (
 142     'appendable',
 143     'block_size',
 144     'canonical_name',
 145     'concurrency',
 146     'max_block_size',
 147     'medium_access_type',
 148     'min_block_size',
 149     'partial_deletion',
 150     'full_deletion',
 151     'streaming',
 152 );
 153
 154 sub properties_include {
 155     my ($got, $should_include, $msg) = @_;
 156     my %got = map { $_->{'name'}, 1 } @$got;
 157     my @missing = grep { !defined($got{$_}) } @$should_include;
 158     if (@missing) {
 159         fail($msg);
 160         diag(" Expected properties: " . join(", ", @$should_include));
 161         diag("      Got properties: " . join(", ", @$got));
 162         diag("  Missing properties: " . join(", ", @missing));
 163     } else {
 164         pass($msg);
 165     }
 166 }
 167
 168 ####
 169 ## get stuff set up
 170
 171 $testconf = Installcheck::Config->new();
 172 $testconf->write();
 173 config_init($CONFIG_INIT_EXPLICIT_NAME, 'TESTCONF') == $CFGERR_OK
 174     or die("Could not load configuration");
 175
 176 # put the debug messages somewhere
 177 Amanda::Debug::dbopen("installcheck");
 178 Installcheck::log_test_output();
 179
 180 ####
 181 ## Test errors a little bit
 182
 183 $dev = Amanda::Device->new("foobar:");
 184 isnt($dev->status(), $DEVICE_STATUS_SUCCESS,
 185     "creation of a bogus 'foobar:' device fails");
 186
 187 $dev = Amanda::Device->new("rait:{{");
 188 isnt($dev->status(), $DEVICE_STATUS_SUCCESS,
 189     "creation of a bogus 'rait:{{' device fails");
 190
 191 $dev = Amanda::Device->new("rait:{a,b");
 192 isnt($dev->status(), $DEVICE_STATUS_SUCCESS,
 193     "creation of a bogus 'rait:{a,b' device fails");
 194
 195 ####
 196 ## first, test out the 'null' device.
 197
 198 $dev_name = "null:";
 199
 200 $dev = Amanda::Device->new($dev_name);
 201 is($dev->status(), $DEVICE_STATUS_SUCCESS,
 202     "create null device")
 203     or diag $dev->error_or_status();
 204 ok($dev->start($ACCESS_WRITE, "NULL1", "19780615010203"),
 205     "start null device in write mode")
 206     or diag $dev->error_or_status();
 207
 208 # try properties
 209 properties_include([ $dev->property_list() ], [ @common_properties ],
 210     "necessary properties listed on null device");
 211 is($dev->property_get("canonical_name"), "null:",
 212     "property_get(canonical_name) on null device");
 213 is($dev->property_get("caNONical-name"), "null:",
 214     "property_get(caNONical-name) on null device (case, dash-insensitivity)");
 215 is_deeply([ $dev->property_get("canonical_name") ],
 216     [ "null:", $PROPERTY_SURETY_GOOD, $PROPERTY_SOURCE_DEFAULT ],
 217     "extended property_get returns correct surety/source");
 218 for my $prop ($dev->property_list()) {
 219     next unless $prop->{'name'} eq 'canonical_name';
 220     is($prop->{'description'},
 221         "The most reliable device name to use to refer to this device.",
 222         "property info for canonical name is correct");
 223 }
 224 ok(!$dev->property_get("full_deletion"),
 225     "property_get(full_deletion) on null device");
 226 is($dev->property_get("comment"), undef,
 227     "no comment by default");
 228 ok($dev->property_set("comment", "well, that was silly"),
 229     "set comment property");
 230 is($dev->property_get("comment"), "well, that was silly",
 231     "comment correctly stored");
 232
 233 # and write a file to it
 234 write_file(0xabcde, 1024*256, 1);
 235
 236 # (don't finish the device, testing the finalize method's cleanup)
 237
 238 ####
 239 ## Now some full device tests
 240
 241 ## VFS device
 242
 243 $vtape1 = mkvtape(1);
 244 $dev_name = "file:$vtape1";
 245
 246 $dev = Amanda::Device->new($dev_name);
 247 is($dev->status(), $DEVICE_STATUS_SUCCESS,
 248     "$dev_name: create successful")
 249     or diag($dev->error_or_status());
 250
 251 properties_include([ $dev->property_list() ],
 252     [ @common_properties, 'max_volume_usage' ],
 253     "necessary properties listed on vfs device");
 254
 255 # play with properties a little bit
 256 ok($dev->property_set("comment", 16),
 257     "set an string property to an integer");
 258
 259 ok($dev->property_set("comment", 16.0),
 260     "set an string property to a float");
 261
 262 ok($dev->property_set("comment", "hi mom"),
 263     "set an string property to a string");
 264
 265 ok($dev->property_set("comment", "32768"),
 266     "set an integer property to a simple string");
 267
 268 ok($dev->property_set("comment", "32k"),
 269     "set an integer property to a string with a unit");
 270
 271 ok($dev->property_set("block_size", 32768),
 272     "set an integer property to an integer");
 273
 274 $dev->read_label();
 275 ok($dev->status() & $DEVICE_STATUS_VOLUME_UNLABELED,
 276     "initially unlabeled")
 277     or diag($dev->error_or_status());
 278
 279 ok($dev->start($ACCESS_WRITE, "TESTCONF13", undef),
 280     "start in write mode")
 281     or diag($dev->error_or_status());
 282
 283 ok(!($dev->status() & $DEVICE_STATUS_VOLUME_UNLABELED),
 284     "not unlabeled anymore")
 285     or diag($dev->error_or_status());
 286
 287 for (my $i = 1; $i <= 3; $i++) {
 288     write_file(0x2FACE, $dev->block_size()*10+17, $i);
 289 }
 290
 291 ok($dev->finish(),
 292     "finish device after write")
 293     or diag($dev->error_or_status());
 294
 295 $dev->read_label();
 296 ok(!($dev->status()),
 297     "no error, at all, from read_label")
 298     or diag($dev->error_or_status());
 299
 300 # append one more copy, to test ACCESS_APPEND
 301
 302 ok($dev->start($ACCESS_APPEND, undef, undef),
 303     "start in append mode")
 304     or diag($dev->error_or_status());
 305
 306 write_file(0xD0ED0E, $dev->block_size()*4, 4);
 307
 308 ok($dev->finish(),
 309     "finish device after append")
 310     or diag($dev->error_or_status());
 311
 312 # try reading the third file back, creating a new device
 313 # object first, and skipping the read-label step.
 314
 315 $dev = undef;
 316 $dev = Amanda::Device->new($dev_name);
 317 is($dev->status(), $DEVICE_STATUS_SUCCESS,
 318     "$dev_name: re-create successful")
 319     or diag($dev->error_or_status());
 320
 321 ok($dev->start($ACCESS_READ, undef, undef),
 322     "start in read mode")
 323     or diag($dev->error_or_status());
 324
 325 verify_file(0x2FACE, $dev->block_size()*10+17, 3);
 326
 327 {
 328     # try two seek_file's in a row
 329     my $hdr = $dev->seek_file(3);
 330     is($hdr? $hdr->{'type'} : -1, $Amanda::Header::F_DUMPFILE, "seek_file the first time");
 331     $hdr = $dev->seek_file(3);
 332     is($hdr? $hdr->{'type'} : -1, $Amanda::Header::F_DUMPFILE, "seek_file the second time");
 333 }
 334
 335 ok($dev->finish(),
 336     "finish device after read")
 337     or diag($dev->error_or_status());
 338
 339 # test erase
 340 ok($dev->erase(),
 341    "erase device")
 342     or diag($dev->error_or_status());
 343
 344 ok($dev->erase(),
 345    "erase device (again)")
 346     or diag($dev->error_or_status());
 347
 348 ok($dev->finish(),
 349    "finish device after erase")
 350     or diag($dev->error_or_status());
 351
 352 ####
 353 ## Test a RAIT device of two vfs devices.
 354
 355 ($vtape1, $vtape2) = (mkvtape(1), mkvtape(2));
 356 $dev_name = "rait:file:{$vtape1,$vtape2}";
 357
 358 $dev = Amanda::Device->new($dev_name);
 359 is($dev->status(), $DEVICE_STATUS_SUCCESS,
 360    "$dev_name: create successful")
 361     or diag($dev->error_or_status());
 362
 363 ok($dev->configure(1), "configure device");
 364
 365 properties_include([ $dev->property_list() ], [ @common_properties ],
 366     "necessary properties listed on rait device");
 367
 368 is($dev->property_get("block_size"), 32768, # (RAIT default)
 369     "rait device calculates a default block size correctly");
 370
 371 ok($dev->property_set("block_size", 32768*16),
 372     "rait device accepts an explicit block size");
 373
 374 is($dev->property_get("block_size"), 32768*16,
 375     "..and remembers it");
 376
 377 $dev->read_label();
 378 ok($dev->status() & $DEVICE_STATUS_VOLUME_UNLABELED,
 379    "initially unlabeled")
 380     or diag($dev->error_or_status());
 381
 382 ok($dev->start($ACCESS_WRITE, "TESTCONF13", undef),
 383    "start in write mode")
 384     or diag($dev->error_or_status());
 385
 386 ok(!($dev->status() & $DEVICE_STATUS_VOLUME_UNLABELED),
 387    "not unlabeled anymore")
 388     or diag($dev->error_or_status());
 389
 390 for (my $i = 1; $i <= 3; $i++) {
 391     write_file(0x2FACE, $dev->block_size()*10+17, $i);
 392 }
 393
 394 ok($dev->finish(),
 395    "finish device after write")
 396     or diag($dev->error_or_status());
 397
 398 $dev->read_label();
 399 ok(!($dev->status()),
 400    "no error, at all, from read_label")
 401     or diag($dev->error_or_status());
 402
 403 # append one more copy, to test ACCESS_APPEND
 404
 405 ok($dev->start($ACCESS_APPEND, undef, undef),
 406    "start in append mode")
 407     or diag($dev->error_or_status());
 408
 409 write_file(0xD0ED0E, $dev->block_size()*4, 4);
 410
 411 ok($dev->finish(),
 412    "finish device after append")
 413     or diag($dev->error_or_status());
 414
 415 # try reading the third file back, creating a new device
 416 # object first, and skipping the read-label step.
 417
 418 $dev = undef;
 419 $dev = Amanda::Device->new($dev_name);
 420 is($dev->status(), $DEVICE_STATUS_SUCCESS,
 421     "$dev_name: re-create successful")
 422     or diag($dev->error_or_status());
 423
 424 ok($dev->start($ACCESS_READ, undef, undef),
 425    "start in read mode")
 426     or diag($dev->error_or_status());
 427
 428 verify_file(0x2FACE, $dev->block_size()*10+17, 3);
 429
 430 ok($dev->finish(),
 431    "finish device after read")
 432     or diag($dev->error_or_status());
 433
 434 ok($dev->start($ACCESS_READ, undef, undef),
 435    "start in read mode after missing volume")
 436     or diag($dev->error_or_status());
 437
 438 # corrupt the device somehow and hope it keeps working
 439 rmtree("$taperoot/1");
 440
 441 verify_file(0x2FACE, $dev->block_size()*10+17, 3);
 442 verify_file(0xD0ED0E, $dev->block_size()*4, 4);
 443 verify_file(0x2FACE, $dev->block_size()*10+17, 2);
 444
 445 ok($dev->finish(),
 446    "finish device read after missing volume")
 447     or diag($dev->error_or_status());
 448
 449 ok(!($dev->start($ACCESS_WRITE, "TESTCONF29", undef)),
 450    "start in write mode fails with missing volume")
 451     or diag($dev->error_or_status());
 452
 453 undef $dev;
 454
 455 $dev_name = "rait:{file:$vtape2,MISSING}";
 456 $dev = Amanda::Device->new($dev_name);
 457
 458 ok($dev->start($ACCESS_READ, undef, undef),
 459    "start in read mode with MISSING")
 460     or diag($dev->error_or_status());
 461
 462 verify_file(0x2FACE, $dev->block_size()*10+17, 3);
 463 verify_file(0xD0ED0E, $dev->block_size()*4, 4);
 464 verify_file(0x2FACE, $dev->block_size()*10+17, 2);
 465
 466 ok($dev->finish(),
 467    "finish device read with MISSING")
 468     or diag($dev->error_or_status());
 469
 470 ok(!($dev->start($ACCESS_WRITE, "TESTCONF29", undef)),
 471    "start in write mode fails with MISSING")
 472     or diag($dev->error_or_status());
 473
 474 undef $dev;
 475
 476 $dev = Amanda::Device->new_rait_from_children(
 477     Amanda::Device->new("file:$vtape2"), undef);
 478
 479 ok(!($dev->start($ACCESS_WRITE, "TESTCONF29", undef)),
 480    "start a RAIT device in write mode fails, when created with 'undef'")
 481     or diag($dev->error_or_status());
 482
 483 # Make two devices with different labels, should get a
 484 # message accordingly.
 485 ($vtape1, $vtape2) = (mkvtape(1), mkvtape(2));
 486
 487 my $n = 13;
 488 for $dev_name ("file:$vtape1", "file:$vtape2") {
 489     my $dev = Amanda::Device->new($dev_name);
 490     is($dev->status(), $DEVICE_STATUS_SUCCESS,
 491        "$dev_name: Open successful")
 492         or diag($dev->error_or_status());
 493     ok($dev->start($ACCESS_WRITE, "TESTCONF$n", undef),
 494         "wrote label 'TESTCONF$n'");
 495     ok($dev->finish(), "finished device");
 496     $n++;
 497 }
 498
 499 $dev = Amanda::Device->new_rait_from_children(
 500     Amanda::Device->new("file:$vtape1"),
 501     Amanda::Device->new("file:$vtape2"));
 502 is($dev->status(), $DEVICE_STATUS_SUCCESS,
 503    "new_rait_from_children: Open successful")
 504     or diag($dev->error_or_status());
 505
 506 $dev->read_label();
 507 ok($dev->status() & $DEVICE_STATUS_VOLUME_ERROR,
 508    "Label mismatch error handled correctly")
 509     or diag($dev->error_or_status());
 510
 511 # Use some config to set a block size on a child device
 512 ($vtape1, $vtape2) = (mkvtape(1), mkvtape(2));
 513 $dev_name = "rait:{file:$vtape1,mytape2}";
 514
 515 $testconf = Installcheck::Config->new();
 516 $testconf->add_device("mytape2", [
 517     "tapedev" => "\"file:$vtape2\"",
 518     "device_property" => "\"BLOCK_SIZE\" \"64k\""
 519 ]);
 520 $testconf->write();
 521 config_init($CONFIG_INIT_EXPLICIT_NAME, 'TESTCONF') == $CFGERR_OK
 522     or die("Could not load configuration");
 523
 524 $dev = Amanda::Device->new($dev_name);
 525 is($dev->status(), $DEVICE_STATUS_SUCCESS,
 526    "$dev_name: create successful")
 527     or diag($dev->error_or_status());
 528
 529 ok($dev->configure(1), "configure device");
 530
 531 is($dev->property_get("block_size"), 65536,
 532     "rait device calculates a block size from its children correctly");
 533
 534 # Test an S3 device if the proper environment variables are set
 535 my $S3_SECRET_KEY = $ENV{'INSTALLCHECK_S3_SECRET_KEY'};
 536 my $S3_ACCESS_KEY = $ENV{'INSTALLCHECK_S3_ACCESS_KEY'};
 537 my $DEVPAY_SECRET_KEY = $ENV{'INSTALLCHECK_DEVPAY_SECRET_KEY'};
 538 my $DEVPAY_ACCESS_KEY = $ENV{'INSTALLCHECK_DEVPAY_ACCESS_KEY'};
 539 my $DEVPAY_USER_TOKEN = $ENV{'INSTALLCHECK_DEVPAY_USER_TOKEN'};
 540
 541 my $run_s3_tests = defined $S3_SECRET_KEY && defined $S3_ACCESS_KEY;
 542 my $run_devpay_tests = defined $DEVPAY_SECRET_KEY &&
 543     defined $DEVPAY_ACCESS_KEY && $DEVPAY_USER_TOKEN;
 544
 545 my $s3_make_device_count = 6;
 546 sub s3_make_device($$) {
 547     my ($dev_name, $kind) = @_;
 548     $dev = Amanda::Device->new($dev_name);
 549     is($dev->status(), $DEVICE_STATUS_SUCCESS,
 550        "$dev_name: create successful")
 551         or diag($dev->error_or_status());
 552
 553     my @s3_props = ( 's3_access_key', 's3_secret_key' );
 554     push @s3_props, 's3_user_token' if ($kind eq "devpay");
 555     properties_include([ $dev->property_list() ], [ @common_properties, @s3_props ],
 556         "necessary properties listed on s3 device");
 557
 558     ok($dev->property_set('BLOCK_SIZE', 32768*2),
 559         "set block size")
 560         or diag($dev->error_or_status());
 561
 562     if ($kind eq "s3") {
 563         # use regular S3 credentials
 564         ok($dev->property_set('S3_ACCESS_KEY', $S3_ACCESS_KEY),
 565            "set S3 access key")
 566         or diag($dev->error_or_status());
 567
 568         ok($dev->property_set('S3_SECRET_KEY', $S3_SECRET_KEY),
 569            "set S3 secret key")
 570             or diag($dev->error_or_status());
 571
 572         pass("(placeholder)");
 573     } elsif ($kind eq "devpay") {
 574         # use devpay credentials
 575         ok($dev->property_set('S3_ACCESS_KEY', $DEVPAY_ACCESS_KEY),
 576            "set devpay access key")
 577         or diag($dev->error_or_status());
 578
 579         ok($dev->property_set('S3_SECRET_KEY', $DEVPAY_SECRET_KEY),
 580            "set devpay secret key")
 581             or diag($dev->error_or_status());
 582
 583         ok($dev->property_set('S3_USER_TOKEN', $DEVPAY_USER_TOKEN),
 584            "set devpay user token")
 585             or diag($dev->error_or_status());
 586     } else {
 587         croak("didn't recognize the device kind, so no credentials were set");
 588     }
 589     return $dev;
 590 }
 591
 592 my $base_name;
 593
 594 SKIP: {
 595     skip "define \$INSTALLCHECK_S3_{SECRET,ACCESS}_KEY to run S3 tests",
 596             67 +
 597             1 * $verify_file_count +
 598             4 * $write_file_count +
 599             10 * $s3_make_device_count
 600         unless $run_s3_tests;
 601
 602     $dev_name = "s3:";
 603     $dev = Amanda::Device->new($dev_name);
 604     isnt($dev->status(), $DEVICE_STATUS_SUCCESS,
 605          "creating $dev_name fails miserably");
 606
 607     $dev_name = "s3:foo";
 608     $dev = Amanda::Device->new($dev_name);
 609
 610     ok($dev->property_get("full_deletion"),
 611        "property_get(full_deletion) on s3 device");
 612
 613     # test parsing of boolean values
 614     # (s3 is the only device driver that has a writable boolean property at the
 615     # moment)
 616
 617     my @verbose_vals = (
 618         {'val' => '1', 'true' => 1},
 619         {'val' => '0', 'true' => 0},
 620         {'val' => 't', 'true' => 1},
 621         {'val' => 'true', 'true' => 1},
 622         {'val' => 'f', 'true' => 0},
 623         {'val' => 'false', 'true' => 0},
 624         {'val' => 'y', 'true' => 1},
 625         {'val' => 'yes', 'true' => 1},
 626         {'val' => 'n', 'true' => 0},
 627         {'val' => 'no', 'true' => 0},
 628         {'val' => 'on', 'true' => 1},
 629         {'val' => 'off', 'true' => 0},
 630         {'val' => 'oFf', 'true' => 0},
 631         );
 632
 633     foreach my $v (@verbose_vals) {
 634         $dev_name = "s3:foo";
 635         $dev = Amanda::Device->new($dev_name);
 636
 637         $testconf = Installcheck::Config->new();
 638         $testconf->add_param("device_property", "\"verbose\" \"$v->{'val'}\"");
 639         $testconf->write();
 640         config_init($CONFIG_INIT_EXPLICIT_NAME, 'TESTCONF') == $CFGERR_OK
 641             or die("Could not load configuration");
 642
 643         ok($dev->configure(1),
 644            "configured device with verbose set to $v->{'val'}")
 645             or diag($dev->error_or_status());
 646
 647         my $get_val = $dev->property_get('verbose');
 648         # see if truth-iness matches
 649         my $expec = $v->{'true'}? "true" : "false";
 650         is(!!$dev->property_get('verbose'), !!$v->{'true'},
 651            "device_property 'VERBOSE' '$v->{'val'}' => property_get(verbose) returning $expec");
 652     }
 653
 654     # test unparsable property
 655     $dev_name = "s3:foo";
 656     $dev = Amanda::Device->new($dev_name);
 657
 658     $testconf = Installcheck::Config->new();
 659     $testconf->add_param("device_property", "\"verbose\" \"foo\"");
 660     $testconf->write();
 661     config_init($CONFIG_INIT_EXPLICIT_NAME, 'TESTCONF') == $CFGERR_OK
 662         or die("Could not load configuration");
 663
 664     ok(!$dev->configure(1),
 665        "failed to configure device with verbose set to foo");
 666
 667     like($dev->error_or_status(), qr/'verbose'/,
 668          "error message mentions property name");
 669
 670     like($dev->error_or_status(), qr/'foo'/,
 671          "error message mentions property value");
 672
 673     like($dev->error_or_status(), qr/gboolean/,
 674          "error message mentions property type");
 675
 676     my $hostname  = hostname();
 677     $hostname =~ s/\./-/g;
 678     $base_name = "$S3_ACCESS_KEY-installcheck-$hostname";
 679     $dev_name = "s3:$base_name-s3";
 680     $dev = s3_make_device($dev_name, "s3");
 681     $dev->read_label();
 682     my $status = $dev->status();
 683     # this test appears very liberal, but catches the case where setup_handle fails without
 684     # giving false positives
 685     ok(($status == $DEVICE_STATUS_SUCCESS) || (($status & $DEVICE_STATUS_VOLUME_UNLABELED) != 0),
 686        "status is either OK or possibly unlabeled")
 687         or diag($dev->error_or_status());
 688
 689     ok($dev->start($ACCESS_WRITE, "TESTCONF13", undef),
 690        "start in write mode")
 691         or diag($dev->error_or_status());
 692
 693     ok(!($dev->status() & $DEVICE_STATUS_VOLUME_UNLABELED),
 694        "it's labeled now")
 695         or diag($dev->error_or_status());
 696
 697     for (my $i = 1; $i <= 3; $i++) {
 698         write_file(0x2FACE, $dev->block_size()*10, $i);
 699     }
 700
 701     ok($dev->finish(),
 702        "finish device after write")
 703         or diag($dev->error_or_status());
 704
 705     $dev->read_label();
 706     ok(!($dev->status()),
 707        "no error, at all, from read_label")
 708         or diag($dev->error_or_status());
 709
 710     # append one more copy, to test ACCESS_APPEND
 711
 712     ok($dev->start($ACCESS_APPEND, undef, undef),
 713        "start in append mode")
 714         or diag($dev->error_or_status());
 715
 716     write_file(0xD0ED0E, $dev->block_size()*10, 4);
 717
 718     ok($dev->finish(),
 719        "finish device after append")
 720         or diag($dev->error_or_status());
 721
 722     # try reading the third file back
 723
 724     ok($dev->start($ACCESS_READ, undef, undef),
 725        "start in read mode")
 726         or diag($dev->error_or_status());
 727
 728     verify_file(0x2FACE, $dev->block_size()*10, 3);
 729
 730     # test EOT indications on reading
 731     my $hdr = $dev->seek_file(4);
 732     is($hdr->{'type'}, $Amanda::Header::F_DUMPFILE,
 733         "file 4 has correct type F_DUMPFILE");
 734
 735     $hdr = $dev->seek_file(5);
 736     is($hdr->{'type'}, $Amanda::Header::F_TAPEEND,
 737         "file 5 has correct type F_TAPEEND");
 738
 739     $hdr = $dev->seek_file(6);
 740     is($hdr, undef, "seek_file returns undef for file 6");
 741
 742     ok($dev->finish(),
 743        "finish device after read")
 744         or diag($dev->error_or_status());    # (note: we don't use write_max_size here, as the maximum for S3 is very large)
 745
 746     ok($dev->erase(),
 747        "erase device")
 748        or diag($dev->error_or_status());
 749
 750     ok($dev->erase(),
 751        "erase device (again)")
 752        or diag($dev->error_or_status());
 753
 754     ok($dev->finish(),
 755        "finish device after erase")
 756         or diag($dev->error_or_status());
 757
 758     $dev->read_label();
 759     $status = $dev->status();
 760     ok($status & $DEVICE_STATUS_VOLUME_UNLABELED,
 761        "status is unlabeled after an erase")
 762         or diag($dev->error_or_status());
 763
 764     $dev = s3_make_device($dev_name, "s3");
 765
 766     ok($dev->erase(),
 767        "erase device right after creation")
 768        or diag($dev->error_or_status());
 769
 770     # try with empty user token
 771     $dev_name = lc("s3:$base_name-s3");
 772     $dev = s3_make_device($dev_name, "s3");
 773     ok($dev->property_set('S3_USER_TOKEN', ''),
 774        "set devpay user token")
 775         or diag($dev->error_or_status());
 776
 777     $dev->read_label();
 778     $status = $dev->status();
 779     ok(($status == $DEVICE_STATUS_SUCCESS) || (($status & $DEVICE_STATUS_VOLUME_UNLABELED) != 0),
 780        "status is either OK or possibly unlabeled")
 781         or diag($dev->error_or_status());
 782
 783     # try a eu-constrained bucket
 784     $dev_name = lc("s3:$base_name-s3-eu");
 785     $dev = s3_make_device($dev_name, "s3");
 786     ok($dev->property_set('S3_BUCKET_LOCATION', 'EU'),
 787        "set S3 bucket location to 'EU'")
 788         or diag($dev->error_or_status());
 789
 790     ok($dev->start($ACCESS_WRITE, "TESTCONF13", undef),
 791        "start in write mode")
 792         or diag($dev->error_or_status());
 793
 794     is($dev->status(), $DEVICE_STATUS_SUCCESS,
 795        "status is OK")
 796         or diag($dev->error_or_status());
 797
 798     $dev->finish();
 799
 800     # try a wildcard-constrained bucket
 801     $dev_name = lc("s3:$base_name-s3-wild");
 802     $dev = s3_make_device($dev_name, "s3");
 803     ok($dev->property_set('S3_BUCKET_LOCATION', '*'),
 804        "set S3 bucket location to ''")
 805         or diag($dev->error_or_status());
 806
 807     ok($dev->start($ACCESS_WRITE, "TESTCONF13", undef),
 808        "start in write mode")
 809         or diag($dev->error_or_status());
 810
 811     is($dev->status(), $DEVICE_STATUS_SUCCESS,
 812        "status is OK")
 813         or diag($dev->error_or_status());
 814
 815     $dev->finish();
 816
 817     # test again with invalid ca_info
 818     $dev = s3_make_device($dev_name, "s3");
 819     SKIP: {
 820         skip "SSL not supported; can't check SSL_CA_INFO", 2
 821             unless $dev->property_get('S3_SSL');
 822
 823         ok($dev->property_set('SSL_CA_INFO', '/dev/null'),
 824            "set invalid SSL/TLS CA certificate")
 825             or diag($dev->error_or_status());
 826
 827         ok(!$dev->start($ACCESS_WRITE, "TESTCONF13", undef),
 828            "start in write mode")
 829             or diag($dev->error_or_status());
 830
 831         isnt($dev->status(), $DEVICE_STATUS_SUCCESS,
 832            "status is OK")
 833             or diag($dev->error_or_status());
 834
 835         $dev->finish();
 836     }
 837
 838     # test again with our own CA bundle
 839     $dev = s3_make_device($dev_name, "s3");
 840     SKIP: {
 841         skip "SSL not supported; can't check SSL_CA_INFO", 4
 842             unless $dev->property_get('S3_SSL');
 843         ok($dev->property_set('SSL_CA_INFO', 'data/aws-bundle.crt'),
 844            "set our own SSL/TLS CA certificate bundle")
 845             or diag($dev->error_or_status());
 846
 847         ok($dev->erase(),
 848            "erase device")
 849             or diag($dev->error_or_status());
 850
 851         ok($dev->start($ACCESS_WRITE, "TESTCONF13", undef),
 852            "start in write mode")
 853             or diag($dev->error_or_status());
 854
 855         is($dev->status(), $DEVICE_STATUS_SUCCESS,
 856            "status is OK")
 857             or diag($dev->error_or_status());
 858     }
 859
 860     # bucket names incompatible with location constraint
 861     $dev_name = "s3:-$base_name-s3-eu";
 862     $dev = s3_make_device($dev_name, "s3");
 863
 864     ok($dev->property_set('S3_BUCKET_LOCATION', ''),
 865        "should be able to set an empty S3 bucket location with an incompatible name")
 866         or diag($dev->error_or_status());
 867
 868     $dev_name = "s3:$base_name-s3.eu";
 869     $dev = s3_make_device($dev_name, "s3");
 870
 871     ok($dev->property_set('S3_BUCKET_LOCATION', ''),
 872        "should be able to set an empty S3 bucket location with an incompatible name")
 873         or diag($dev->error_or_status());
 874
 875     $dev_name = "s3:-$base_name-s3-eu";
 876     $dev = s3_make_device($dev_name, "s3");
 877
 878     ok(!$dev->property_set('S3_BUCKET_LOCATION', 'EU'),
 879        "should not be able to set S3 bucket location with an incompatible name")
 880         or diag($dev->error_or_status());
 881 }
 882
 883 SKIP: {
 884     # in this case, most of our code has already been exercised
 885     # just make sure that authentication works as a basic sanity check
 886     skip "skipping abbreviated devpay tests", $s3_make_device_count + 1
 887         unless $run_devpay_tests;
 888     $dev_name = "s3:$base_name-devpay";
 889     $dev = s3_make_device($dev_name, "devpay");
 890     $dev->read_label();
 891     my $status = $dev->status();
 892     # this test appears very liberal, but catches the case where setup_handle fails without
 893     # giving false positives
 894     ok(($status == 0) || (($status & $DEVICE_STATUS_VOLUME_UNLABELED) != 0),
 895        "status is either OK or possibly unlabeled")
 896         or diag($dev->error_or_status());
 897 }
 898
 899 # Test a tape device if the proper environment variables are set
 900 my $TAPE_DEVICE = $ENV{'INSTALLCHECK_TAPE_DEVICE'};
 901 my $run_tape_tests = defined $TAPE_DEVICE;
 902 SKIP: {
 903     skip "define \$INSTALLCHECK_TAPE_DEVICE to run tape tests",
 904             30 +
 905             7 * $verify_file_count +
 906             5 * $write_file_count
 907         unless $run_tape_tests;
 908
 909     $dev_name = "tape:$TAPE_DEVICE";
 910     $dev = Amanda::Device->new($dev_name);
 911     is($dev->status(), $DEVICE_STATUS_SUCCESS,
 912         "$dev_name: create successful")
 913         or diag($dev->error_or_status());
 914
 915     my $status = $dev->read_label();
 916     ok(($status == $DEVICE_STATUS_SUCCESS) || (($status & $DEVICE_STATUS_VOLUME_UNLABELED) != 0),
 917        "status is either OK or possibly unlabeled")
 918         or diag($dev->error_or_status());
 919
 920     ok($dev->start($ACCESS_WRITE, "TESTCONF13", undef),
 921         "start in write mode")
 922         or diag($dev->error_or_status());
 923
 924     ok(!($dev->status() & $DEVICE_STATUS_VOLUME_UNLABELED),
 925         "not unlabeled anymore")
 926         or diag($dev->error_or_status());
 927
 928     for (my $i = 1; $i <= 4; $i++) {
 929         write_file(0x2FACE+$i, $dev->block_size()*10+17, $i);
 930     }
 931
 932     ok($dev->finish(),
 933         "finish device after write")
 934         or diag($dev->error_or_status());
 935
 936     $dev->read_label();
 937     ok(!($dev->status()),
 938         "no error, at all, from read_label")
 939         or diag($dev->error_or_status());
 940
 941     is($dev->volume_label(), "TESTCONF13",
 942         "read_label reads the correct label")
 943         or diag($dev->error_or_status());
 944
 945     # append one more copy, to test ACCESS_APPEND
 946
 947     # if final_filemarks is 1, then the tape device will use F_NOOP,
 948     # inserting an extra file, and we'll be appending at file number 6.
 949     my $append_fileno = ($dev->property_get("FINAL_FILEMARKS") == 2)? 5:6;
 950
 951     SKIP: {
 952         skip "APPEND not supported", $write_file_count + 2
 953             unless $dev->property_get("APPENDABLE");
 954
 955         ok($dev->start($ACCESS_APPEND, undef, undef),
 956             "start in append mode")
 957             or diag($dev->error_or_status());
 958
 959         write_file(0xD0ED0E, $dev->block_size()*4, $append_fileno);
 960
 961         ok($dev->finish(),
 962             "finish device after append")
 963             or diag($dev->error_or_status());
 964     }
 965
 966     # try reading the second and third files back, creating a new
 967     # device object first, and skipping the read-label step.
 968
 969     $dev = undef;
 970     $dev = Amanda::Device->new($dev_name);
 971     is($dev->status(), $DEVICE_STATUS_SUCCESS,
 972         "$dev_name: re-create successful")
 973         or diag($dev->error_or_status());
 974
 975     # use a big read_block_size, checking that it's also settable
 976     # via read_buffer_size
 977     ok($dev->property_set("read_buffer_size", 256*1024),
 978         "can set read_buffer_size");
 979     is($dev->property_get("read_block_size"), 256*1024,
 980         "and its value is reflected in read_block_size");
 981     ok($dev->property_set("read_block_size", 32*1024),
 982         "can set read_block_size");
 983
 984     ok($dev->start($ACCESS_READ, undef, undef),
 985         "start in read mode")
 986         or diag($dev->error_or_status());
 987
 988     # now verify those files in a particular order to trigger all of the
 989     # seeking edge cases
 990
 991     verify_file(0x2FACE+1, $dev->block_size()*10+17, 1);
 992     verify_file(0x2FACE+2, $dev->block_size()*10+17, 2);
 993     verify_file(0x2FACE+4, $dev->block_size()*10+17, 4);
 994     verify_file(0x2FACE+3, $dev->block_size()*10+17, 3);
 995     verify_file(0x2FACE+1, $dev->block_size()*10+17, 1);
 996
 997     # try re-seeking to the same file
 998     ok(header_for($dev->seek_file(2), 2), "seek to file 2 the first time");
 999     verify_file(0x2FACE+2, $dev->block_size()*10+17, 2);
1000     ok(header_for($dev->seek_file(2), 2), "seek to file 2 the third time");
1001
1002     # and seek through the same pattern *without* reading to EOF
1003     ok(header_for($dev->seek_file(1), 1), "seek to file 1");
1004     ok(header_for($dev->seek_file(2), 2), "seek to file 2");
1005     ok(header_for($dev->seek_file(4), 4), "seek to file 4");
1006     ok(header_for($dev->seek_file(3), 3), "seek to file 3");
1007     ok(header_for($dev->seek_file(1), 1), "seek to file 1");
1008
1009     SKIP: {
1010         skip "APPEND not supported", $verify_file_count
1011             unless $dev->property_get("APPENDABLE");
1012         verify_file(0xD0ED0E, $dev->block_size()*4, $append_fileno);
1013     }
1014
1015     ok($dev->finish(),
1016         "finish device after read")
1017         or diag($dev->error_or_status());
1018
1019     # tickle a regression in improperly closing fd's
1020     ok($dev->finish(),
1021         "finish device again after read")
1022         or diag($dev->error_or_status());
1023
1024     ok($dev->read_label() == $DEVICE_STATUS_SUCCESS,
1025         "read_label after second finish (used to fail)")
1026         or diag($dev->error_or_status());
1027
1028     # finally, run the device with FSF and BSF set to "no", to test the
1029     # fallback schemes for this condition
1030
1031     $dev = undef;
1032     $dev = Amanda::Device->new($dev_name);
1033     is($dev->status(), $DEVICE_STATUS_SUCCESS,
1034         "$dev_name: re-create successful")
1035         or diag($dev->error_or_status());
1036     $dev->property_set("fsf", "no");
1037     $dev->property_set("bsf", "no");
1038
1039     ok($dev->start($ACCESS_READ, undef, undef),
1040         "start in read mode")
1041         or diag($dev->error_or_status());
1042
1043     ok(header_for($dev->seek_file(1), 1), "seek to file 1");
1044     ok(header_for($dev->seek_file(4), 4), "seek to file 4");
1045     ok(header_for($dev->seek_file(2), 2), "seek to file 2");
1046
1047     ok($dev->finish(),
1048         "finish device after read")
1049         or diag($dev->error_or_status());
1050 }
1051
1052 SKIP: {
1053     skip "not built with ndmp and server", 77 unless
1054         Amanda::Util::built_with_component("ndmp") and
1055         Amanda::Util::built_with_component("server");
1056
1057     my $dev;
1058     my $testconf = Installcheck::Config->new();
1059     $testconf->write();
1060
1061     my $cfg_result = config_init($CONFIG_INIT_EXPLICIT_NAME, 'TESTCONF');
1062     if ($cfg_result != $CFGERR_OK) {
1063         my ($level, @errors) = Amanda::Config::config_errors();
1064         die(join "\n", @errors);
1065     }
1066
1067     my $ndmp = Installcheck::Mock::NdmpServer->new();
1068     my $ndmp_port = $ndmp->{'port'};
1069     my $drive = $ndmp->{'drive'};
1070     pass("started ndmjob in daemon mode");
1071
1072     # set up a header for use below
1073     my $hdr = Amanda::Header->new();
1074     $hdr->{type} = $Amanda::Header::F_DUMPFILE;
1075     $hdr->{datestamp} = "20070102030405";
1076     $hdr->{dumplevel} = 0;
1077     $hdr->{compressed} = 1;
1078     $hdr->{name} = "localhost";
1079     $hdr->{disk} = "/home";
1080     $hdr->{program} = "INSTALLCHECK";
1081
1082     $dev = Amanda::Device->new("ndmp:127.0.0.1:9i1\@foo");
1083     isnt($dev->status(), $DEVICE_STATUS_SUCCESS,
1084         "creation of an ndmp device fails with invalid port");
1085
1086     $dev = Amanda::Device->new("ndmp:127.0.0.1:90000\@foo");
1087     isnt($dev->status(), $DEVICE_STATUS_SUCCESS,
1088         "creation of an ndmp device fails with too-large port");
1089
1090     $dev = Amanda::Device->new("ndmp:127.0.0.1:$ndmp_port");
1091     isnt($dev->status(), $DEVICE_STATUS_SUCCESS,
1092         "creation of an ndmp device fails without ..\@device_name");
1093
1094     $dev = Amanda::Device->new("ndmp:127.0.0.1:$ndmp_port\@$drive");
1095     is($dev->status(), $DEVICE_STATUS_SUCCESS,
1096         "creation of an ndmp device succeeds with correct syntax");
1097
1098     ok($dev->property_set("ndmp_username", "foo"),
1099         "set ndmp_username property");
1100     is($dev->property_get("ndmp_username"), "foo",
1101         "..and get the value back");
1102     ok($dev->property_set("ndmp_password", "bar"),
1103         "set ndmp_password property");
1104     is($dev->property_get("ndmp_password"), "bar",
1105         "..and get the value back");
1106
1107     ok($dev->property_set("verbose", 1),
1108         "set VERBOSE");
1109
1110     # set 'em back to the defaults
1111     $dev->property_set("ndmp_username", "ndmp");
1112     $dev->property_set("ndmp_password", "ndmp");
1113
1114     # ok, let's fire the thing up
1115     ok($dev->start($ACCESS_WRITE, "TEST1", "20090915000000"),
1116         "start device in write mode")
1117         or diag $dev->error_or_status();
1118
1119     ok($dev->start_file($hdr),
1120         "start_file");
1121
1122     {   # write to the file
1123         my $xfer = Amanda::Xfer->new([
1124                 Amanda::Xfer::Source::Random->new(32768*21, 0xBEEFEE00),
1125                 Amanda::Xfer::Dest::Device->new($dev, 32768*5) ]);
1126         $xfer->start(make_cb(xmsg_cb => sub {
1127             my ($src, $msg, $xfer) = @_;
1128             if ($msg->{'type'} == $XMSG_ERROR) {
1129                 die $msg->{'elt'} . " failed: " . $msg->{'message'};
1130             } elsif ($msg->{'type'} == $XMSG_DONE) {
1131                 Amanda::MainLoop::quit();
1132             }
1133         }));
1134
1135         Amanda::MainLoop::run();
1136         pass("wrote 21 blocks");
1137     }
1138
1139     ok($dev->finish(),
1140         "finish device")
1141         or diag $dev->error_or_status();
1142
1143     is($dev->read_label(), $DEVICE_STATUS_SUCCESS,
1144         "read label from (same) device")
1145         or diag $dev->error_or_status();
1146
1147     is($dev->volume_label, "TEST1",
1148         "volume label read back correctly");
1149
1150     ## label a device and check the label, but open a new device in between
1151
1152     # Write a label
1153     $dev = Amanda::Device->new("ndmp:127.0.0.1:$ndmp_port\@$drive");
1154     is($dev->status(), $DEVICE_STATUS_SUCCESS,
1155         "creation of an ndmp device succeeds with correct syntax");
1156     $dev->property_set("ndmp_username", "ndmp");
1157     $dev->property_set("ndmp_password", "ndmp");
1158     $dev->property_set("verbose", 1);
1159
1160     # Write the label
1161     ok($dev->start($ACCESS_WRITE, "TEST2", "20090915000000"),
1162         "start device in write mode")
1163         or diag $dev->error_or_status();
1164     ok($dev->finish(),
1165         "finish device")
1166         or diag $dev->error_or_status();
1167
1168     # Read the label with a new device.
1169     $dev = Amanda::Device->new("ndmp:127.0.0.1:$ndmp_port\@$drive");
1170     is($dev->status(), $DEVICE_STATUS_SUCCESS,
1171         "creation of an ndmp device succeeds with correct syntax");
1172     $dev->property_set("ndmp_username", "ndmp");
1173     $dev->property_set("ndmp_password", "ndmp");
1174     $dev->property_set("verbose", 1);
1175
1176     # read the label
1177     is($dev->read_label(), $DEVICE_STATUS_SUCCESS,
1178         "read label from device")
1179         or diag $dev->error_or_status();
1180     is($dev->volume_label, "TEST2",
1181         "volume label read back correctly");
1182     ok($dev->finish(),
1183         "finish device")
1184         or diag $dev->error_or_status();
1185
1186     #
1187     # test the directtcp-target implementation
1188     #
1189
1190     {
1191         ok($dev->directtcp_supported(), "is a directtcp target");
1192
1193         my $addrs = $dev->listen(1);
1194         ok($addrs, "listen returns successfully") or die($dev->error_or_status());
1195
1196         # set up an xfer to write to the device
1197         my $xfer = Amanda::Xfer->new([
1198                 Amanda::Xfer::Source::Random->new(32768*34, 0xB00),
1199                 Amanda::Xfer::Dest::DirectTCPConnect->new($addrs) ]);
1200
1201         my @messages;
1202         $xfer->start(make_cb(xmsg_cb => sub {
1203             my ($src, $msg, $xfer) = @_;
1204             if ($msg->{'type'} == $XMSG_ERROR) {
1205                 die $msg->{'elt'} . " failed: " . $msg->{'message'};
1206             } elsif ($msg->{'type'} == $XMSG_DONE) {
1207                 Amanda::MainLoop::quit();
1208             }
1209         }));
1210
1211         # write files from the connection until EOF
1212         my $num_files;
1213         my $conn;
1214         my ($call_accept, $start_device, $write_file_cb);
1215
1216         $call_accept = make_cb(call_accept => sub {
1217             $conn = $dev->accept();
1218             Amanda::MainLoop::call_later($start_device);
1219         });
1220
1221         $start_device = make_cb(start_device => sub {
1222             ok($dev->start($ACCESS_WRITE, "TEST2", "20090915000000"),
1223                 "start device in write mode")
1224                 or diag $dev->error_or_status();
1225
1226             Amanda::MainLoop::call_later($write_file_cb);
1227         });
1228
1229         $write_file_cb = make_cb(write_file_cb => sub {
1230             ++$num_files < 20 or die "I seem to be in a loop!";
1231
1232             ok($dev->start_file($hdr), "start file $num_files for writing");
1233             is($dev->file, $num_files, "..file number is correct");
1234
1235             my ($ok, $size) = $dev->write_from_connection(32768*15);
1236             push @messages, sprintf("WRITE-%s-%d-%s-%s",
1237                 $ok?"OK":"ERR", $size,
1238                 $dev->is_eof()? "EOF":"!eof",
1239                 $dev->is_eom()? "EOM":"!eom");
1240             ok($ok, "..write from connection succeeds");
1241             my $eof = $dev->is_eof();
1242
1243             ok($dev->finish_file(), "..finish file after writing");
1244
1245             if (!$eof) {
1246                 Amanda::MainLoop::call_later($write_file_cb);
1247             }
1248         });
1249
1250         Amanda::MainLoop::call_later($call_accept);
1251         Amanda::MainLoop::run();
1252         is_deeply([@messages], [
1253                 'WRITE-OK-491520-!eof-!eom',
1254                 'WRITE-OK-491520-!eof-!eom',
1255                 'WRITE-OK-131072-EOF-!eom',
1256             ],
1257             "a sequence of write_from_connection calls works correctly");
1258
1259         $dev->finish();
1260
1261         if (my $err = $conn->close()) {
1262             die $err;
1263         }
1264     }
1265
1266     #
1267     # Test indirecttcp
1268     #
1269
1270     {
1271         ok($dev->directtcp_supported(), "is a directtcp target");
1272
1273         $dev->property_set("_force_indirecttcp", 1);
1274
1275         my $addrs = $dev->listen(1);
1276         is_deeply([ scalar @$addrs, $addrs->[0][0] ],
1277             [ 1, '255.255.255.255' ],
1278             "listen returns successfully with indirecttcp sentinel")
1279             or die($dev->error_or_status());
1280
1281         # fork off to evaluate the indirecttcp addresses and then set up an
1282         # xfer to write to the device
1283         if (POSIX::fork() == 0) {
1284             # NOTE: do not use IO::Socket in normal Amanda code - it is diabolically
1285             # not threadsafe!  It's OK here since this is just a test script and
1286             # since we're in a subprocess
1287             use IO::Socket;
1288             my $sock = new IO::Socket::INET(
1289                     PeerAddr => '127.0.0.1',
1290                     PeerPort => $addrs->[0][1],
1291                     Proto => 'tcp')
1292                 or die("Could not create connecting socket");
1293             $sock->shutdown(1); # send EOF
1294             my $sockresult = <$sock>;
1295             $sock->close();
1296
1297             my @sockresult = map { [ split(/:/, $_) ] } split(/ /, $sockresult);
1298             $addrs = [ map { $_->[1] = int($_->[1]); $_ } @sockresult ];
1299
1300             my $xfer = Amanda::Xfer->new([
1301                     Amanda::Xfer::Source::Random->new(32768*34, 0xB00),
1302                     Amanda::Xfer::Dest::DirectTCPConnect->new($addrs) ]);
1303
1304             $xfer->start(make_cb(xmsg_cb => sub {
1305                 my ($src, $msg, $xfer) = @_;
1306                 if ($msg->{'type'} == $XMSG_ERROR) {
1307                     die $msg->{'elt'} . " failed: " . $msg->{'message'};
1308                 } elsif ($msg->{'type'} == $XMSG_DONE) {
1309                     Amanda::MainLoop::quit();
1310                 }
1311             }));
1312
1313             Amanda::MainLoop::run();
1314
1315             # exit without doing any of perl's cleanup
1316             POSIX::_exit(0);
1317         }
1318
1319         # write files from the connection until EOF
1320         my @messages;
1321         my $num_files;
1322         my $conn;
1323         my ($call_accept, $start_device, $write_file_cb);
1324
1325         $call_accept = make_cb(call_accept => sub {
1326             $conn = $dev->accept();
1327             Amanda::MainLoop::call_later($start_device);
1328         });
1329
1330         $start_device = make_cb(start_device => sub {
1331             ok($dev->start($ACCESS_WRITE, "TEST2", "20090915000000"),
1332                 "start device in write mode")
1333                 or diag $dev->error_or_status();
1334
1335             Amanda::MainLoop::call_later($write_file_cb);
1336         });
1337
1338         $write_file_cb = make_cb(write_file_cb => sub {
1339             ++$num_files < 20 or die "I seem to be in a loop!";
1340
1341             ok($dev->start_file($hdr), "start file $num_files for writing");
1342             is($dev->file, $num_files, "..file number is correct");
1343
1344             my ($ok, $size) = $dev->write_from_connection(32768*15);
1345             push @messages, sprintf("WRITE-%s-%d-%s-%s",
1346                 $ok?"OK":"ERR", $size,
1347                 $dev->is_eof()? "EOF":"!eof",
1348                 $dev->is_eom()? "EOM":"!eom");
1349             ok($ok, "..write from connection succeeds");
1350             my $eof = $dev->is_eof();
1351
1352             ok($dev->finish_file(), "..finish file after writing");
1353
1354             if (!$eof) {
1355                 Amanda::MainLoop::call_later($write_file_cb);
1356             } else {
1357                 Amanda::MainLoop::quit();
1358             }
1359         });
1360
1361         Amanda::MainLoop::call_later($call_accept);
1362         Amanda::MainLoop::run();
1363         is_deeply([@messages], [
1364                 'WRITE-OK-491520-!eof-!eom',
1365                 'WRITE-OK-491520-!eof-!eom',
1366                 'WRITE-OK-131072-EOF-!eom',
1367             ],
1368             "a sequence of write_from_connection calls works correctly");
1369
1370         $dev->finish();
1371
1372         if (my $err = $conn->close()) {
1373             die $err;
1374         }
1375     }
1376
1377     # now try reading that back piece by piece
1378
1379     {
1380         my $filename = "$Installcheck::TMP/Amanda_Device_ndmp.tmp";
1381         open(my $dest_fh, ">", $filename);
1382
1383         ok($dev->start($ACCESS_READ, undef, undef),
1384             "start device in read mode")
1385             or diag $dev->error_or_status();
1386
1387         my $file;
1388         for ($file = 1; $file <= 3; $file++) {
1389             ok($dev->seek_file($file),
1390                 "seek_file $file");
1391             is($dev->file, $file, "..file num is correct");
1392             is($dev->block, 0, "..block num is correct");
1393
1394             # read the file, writing to our temp file.  We'll check that the byte
1395             # sequence is correct later
1396             my $xfer = Amanda::Xfer->new([
1397                     Amanda::Xfer::Source::Device->new($dev),
1398                     Amanda::Xfer::Dest::Fd->new($dest_fh) ]);
1399
1400             $xfer->start(make_cb(xmsg_cb => sub {
1401                 my ($src, $msg, $xfer) = @_;
1402                 if ($msg->{'type'} == $XMSG_ERROR) {
1403                     die $msg->{'elt'} . " failed: " . $msg->{'message'};
1404                 } elsif ($msg->{'type'} == $XMSG_DONE) {
1405                     Amanda::MainLoop::quit();
1406                 }
1407             }));
1408             Amanda::MainLoop::run();
1409
1410             pass("read back file " . $file);
1411         }
1412
1413         $dev->finish();
1414         close $dest_fh;
1415
1416         # now read back and verify that file
1417         open(my $src_fh, "<", $filename);
1418         my $xfer = Amanda::Xfer->new([
1419                 Amanda::Xfer::Source::Fd->new($src_fh),
1420                 Amanda::Xfer::Dest::Null->new(0xB00) ]);
1421
1422         $xfer->start(make_cb(xmsg_cb => sub {
1423             my ($src, $msg, $xfer) = @_;
1424             if ($msg->{'type'} == $XMSG_ERROR) {
1425                 die $msg->{'elt'} . " failed: " . $msg->{'message'};
1426             } elsif ($msg->{'type'} == $XMSG_DONE) {
1427                 Amanda::MainLoop::quit();
1428             }
1429         }));
1430         Amanda::MainLoop::run();
1431
1432         pass("data in the three parts is correct");
1433         unlink $filename;
1434     }
1435
1436     ####
1437     # Test read_to_connection
1438     #
1439     # This requires something that can connect to a device and read from
1440     # it; the XFA does not have an XFER_MECH_DIRECTTCP_CONNECT, so we fake
1441     # it by manually connecting and then setting up an xfer with a regular
1442     # XferSourceFd.  This works because the NDMP server will accept an
1443     # incoming connection before the Device API accept() method is called;
1444     # this trick may not work with other DirectTCP-capable devices.  Also,
1445     # this doesn't work so well if there's an error in the xfer (e.g., a
1446     # random value mismatch).  But tests are supposed to succeed!
1447
1448     sub test_read2conn {
1449         my ($finished_cb) = @_;
1450         my @events;
1451         my $file = 1;
1452         my ($conn, $sock);
1453
1454         my $steps = define_steps
1455             cb_ref => \$finished_cb;
1456
1457         step setup => sub {
1458             my $addrs = $dev->listen(0);
1459
1460             # now connect to that
1461             $sock = IO::Socket::INET->new(
1462                 Proto => "tcp",
1463                 PeerHost => $addrs->[0][0],
1464                 PeerPort => $addrs->[0][1],
1465                 Blocking => 1,
1466             );
1467
1468             # and set up a transfer to read from that socket
1469             my $xfer = Amanda::Xfer->new([
1470                     Amanda::Xfer::Source::Fd->new($sock),
1471                     Amanda::Xfer::Dest::Null->new(0xB00) ]);
1472
1473             $xfer->start(make_cb(xmsg_cb => sub {
1474                 my ($src, $msg, $xfer) = @_;
1475                 if ($msg->{'type'} == $XMSG_ERROR) {
1476                     die $msg->{'elt'} . " failed: " . $msg->{'message'};
1477                 }
1478                 if ($msg->{'type'} == $XMSG_DONE) {
1479                     push @events, "DONE";
1480                     $steps->{'quit'}->();
1481                 }
1482             }));
1483
1484             $steps->{'accept'}->();
1485         };
1486
1487         step accept => sub {
1488             $conn = $dev->accept();
1489             die $dev->error_or_status() unless ($conn);
1490
1491             Amanda::MainLoop::call_later($steps->{'start_dev'});
1492         };
1493
1494         step start_dev => sub {
1495             ok($dev->start($ACCESS_READ, undef, undef),
1496                 "start device in read mode")
1497                 or diag $dev->error_or_status();
1498
1499             Amanda::MainLoop::call_later($steps->{'read_part_cb'});
1500         };
1501
1502         step read_part_cb => sub {
1503             my $hdr = $dev->seek_file($file);
1504             die $dev->error_or_status() unless ($hdr);
1505             my $size = $dev->read_to_connection(0);
1506             push @events, "READ-$size";
1507
1508             if (++$file <= 3) {
1509                 Amanda::MainLoop::call_later($steps->{'read_part_cb'});
1510             } else {
1511                 # close the connection, which will end the xfer, which will
1512                 # result in a call to finished_cb.  So there.
1513                 push @events, "CLOSE";
1514                 $conn->close();
1515             }
1516         };
1517
1518         step quit => sub {
1519             close $sock or die "close: $!";
1520
1521             is_deeply([@events],
1522                 [ "READ-491520", "READ-491520", "READ-131072", "CLOSE", "DONE" ],
1523                 "sequential read_to_connection operations read the right amounts " .
1524                 "and bytestream matches");
1525
1526             $finished_cb->();
1527         };
1528     }
1529     test_read2conn(\&Amanda::MainLoop::quit);
1530     Amanda::MainLoop::run();
1531
1532     # try two seek_file's in a row
1533     $hdr = $dev->seek_file(2);
1534     is($hdr? $hdr->{'type'} : -1, $Amanda::Header::F_DUMPFILE, "seek_file the first time");
1535     $hdr = $dev->seek_file(2);
1536     is($hdr? $hdr->{'type'} : -1, $Amanda::Header::F_DUMPFILE, "seek_file the second time");
1537
1538     ## test seek_file's handling of EOM
1539
1540     $hdr = $dev->seek_file(3);
1541     is($hdr->{type}, $Amanda::Header::F_DUMPFILE, "file 3 is a dumpfile");
1542     $hdr = $dev->seek_file(4);
1543     is($hdr->{type}, $Amanda::Header::F_TAPEEND, "file 4 is tapeend");
1544     $hdr = $dev->seek_file(5);
1545     is($hdr, undef, "file 5 is an error");
1546     $hdr = $dev->seek_file(6);
1547     is($hdr, undef, "file 6 is an error");
1548
1549     $ndmp->cleanup();
1550 }
1551 unlink($input_filename);
1552 unlink($output_filename);
1553 rmtree($taperoot);