git.gag.com Git - debian/amanda/blob - installcheck/Installcheck/Application.pm

   1 # vim:ft=perl
   2 # Copyright (c) 2009-2012 Zmanda, Inc.  All Rights Reserved.
   3 #
   4 # This program is free software; you can redistribute it and/or
   5 # modify it under the terms of the GNU General Public License
   6 # as published by the Free Software Foundation; either version 2
   7 # of the License, or (at your option) any later version.
   8 #
   9 # This program is distributed in the hope that it will be useful, but
  10 # WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
  11 # or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  12 # for more details.
  13 #
  14 # You should have received a copy of the GNU General Public License along
  15 # with this program; if not, write to the Free Software Foundation, Inc.,
  16 # 59 Temple Place, Suite 330, Boston, MA  02111-1307 USA
  17 #
  18 # Contact information: Zmanda Inc, 465 S. Mathilda Ave., Suite 300
  19 # Sunnyvale, CA 94086, USA, or: http://www.zmanda.com
  20
  21 package Installcheck::Application;
  22
  23 use Amanda::MainLoop qw( :GIOCondition );
  24 use Amanda::Paths;
  25 use Carp;
  26 use Fcntl;
  27 use IO::Handle;
  28 use POSIX qw( :errno_h :fcntl_h );
  29 use POSIX qw( EAGAIN );
  30
  31 use strict;
  32 use warnings;
  33
  34 =head1 NAME
  35
  36 Installcheck::Application - driver Application API programs and scripts
  37
  38 =head1 SYNOPSIS
  39
  40   use Installcheck::Application;
  41
  42   my $app = Installcheck::Application->new('myapp');
  43
  44   $app->add_property('foo' => 'bar');
  45   $app->add_property('baz');
  46   $app->add_property('bat', 1, 2, 3);
  47   $app->delete_property('foo');
  48   $app->get_property('foo');
  49   $app->set_property('foo', ['bar', '']);
  50   my @props = $app->list_properties();
  51
  52   my $feats = $app->support('config' => 'TESTCONF', 'temp-prop' => 1);
  53   die "need calcsize support" unless ($feats{'CALCSIZE'});
  54
  55   my $backup = $app->backup('device' => 'file:/path', 'level' => 0);
  56   die join("\n", @{$backup->{'errors'}}) if $backup->{'errors'};
  57   print STDERR join("\n", @{$backup->{'index'}});
  58   print $backup->{'data'};
  59
  60 =head1 USAGE
  61
  62 =over
  63
  64 =item C< new($app_name) >
  65
  66 Create a new C< Installcheck::Application > object that will run C< $app_name >.
  67
  68 =back
  69
  70 =head2 PROPERTIES
  71
  72 Properties are automatically passed as arguments to any command.
  73 Their names will be lowercase.
  74
  75 =over
  76
  77 =item C< add_property($prop_name, 'val1', 'val2') >
  78
  79 Add one or more values for property C< $prop_name >.
  80
  81 =item C< delete_property($prop_name) >
  82
  83 Delete all values for property C< $prop_name >.
  84
  85 =item C< get_property($prop_name) >
  86
  87 Get all values for property C< $prop_name >.
  88
  89 =item C< set_property($prop_name, 'val1', 'val2') >
  90
  91 Set the values for property C< $prop_name >, removing any previous values.
  92
  93 =item C< list_properties() >
  94
  95 Returns all properties that have a value.
  96
  97 =back
  98
  99 =head2 COMMANDS
 100
 101 =over
 102
 103 =item C< support() >
 104
 105 Runs the C< support > command and returns the output as a hashref,
 106 with all keys in uppercase.
 107
 108 =item C<< backup('disk' => '/some/path', 'device' => '/some/path, 'level' => 0) >>
 109
 110 Runs the C< backup() > command on the given device.
 111 If a C< disk > argument is not given, it defaults to the C< device >.
 112 Returns a hashref:
 113
 114 =over
 115
 116 =item C< data >
 117
 118 The data stream produced by the application
 119
 120 =item C< index >
 121
 122 An array of index lines produced by the application
 123
 124 =item C< size >
 125
 126 The size of the backup (C< data >)
 127
 128 =item C< info >
 129
 130 Any normal/informative messages
 131
 132 =item C< errors >
 133
 134 Any error messages
 135
 136 =item C< unknowns >
 137
 138 Any 'unknown' output
 139
 140 =item C< exit_status >
 141
 142 The exit status of the application
 143
 144 =back
 145
 146 =item C<< restore('data' => $data_from_backup, 'objects' => ['a', 'b'], 'level' => 0) >>
 147
 148 Runs the C< restore > command to restore the C< objects > to the
 149 current working directory, supplying it with C< data >.
 150 The optional C< level > argument (defaulting to 0) specifies the level of the backup
 151 Returns a hashref:
 152
 153 =over
 154
 155 =item C< msgs >
 156
 157 Any output from the application
 158
 159 =item C< exit_status >
 160
 161 The exit status of the application
 162
 163 =back
 164
 165 =item C<< estimate('device' => '/some/path, 'level' => 0) >>
 166
 167 Returns a hashref:
 168
 169 =over
 170
 171 =item C< level >
 172
 173 The level of the backup that would result
 174
 175 =item C< size >
 176
 177 The size of the backup that would result
 178
 179 =item C< exit_status >
 180
 181 The exit status of the application
 182
 183 =back
 184
 185 =item C<< selfcheck('device' => '/some/path, 'disk' => '/some/path') >>
 186
 187 Runs the C< selfcheck > command on the given device.
 188 If a C< disk > argument is not given, it defaults to the C< device >.)
 189 Returns a hashref:
 190
 191 =over
 192
 193 =item C< oks >
 194
 195 OK messages
 196
 197 =item C< errors >
 198
 199 ERROR messages
 200
 201 =item C< exit_status >
 202
 203 The exit status of the application
 204
 205 =back
 206
 207 =back
 208
 209 =cut
 210
 211 sub new {
 212     my ($class, $app_name) = @_;
 213
 214     my $self = {
 215         'app_name' => $app_name,
 216         'props' => {},
 217     };
 218
 219     bless($self, $class);
 220     $self;
 221 }
 222
 223 sub _propify {
 224     my $str = shift @_;
 225     $str = lc($str);
 226     $str =~ s/_/-/;
 227     $str;
 228 }
 229
 230 sub add_property {
 231     my $self = shift @_;
 232     my $name = _propify(shift @_);
 233     my @values = @_;
 234
 235     $self->{'props'}->{$name} ||= [];
 236     push @{$self->{'props'}->{$name}}, @values;
 237 }
 238
 239 sub delete_property {
 240     my $self = shift @_;
 241     my $name = _propify(shift @_);
 242
 243     delete $self->{'props'}->{$name};
 244 }
 245
 246 sub get_property {
 247     my $self = shift @_;
 248     my $name = _propify(shift @_);
 249
 250     defined($self->{'props'}->{$name}) ? @{$self->{'props'}->{$name}} : ();
 251 }
 252
 253 sub set_property {
 254     my $self = shift @_;
 255     my $name = _propify(shift @_);
 256     my @values = @_;
 257
 258     @{$self->{'props'}->{$name}} = @values;
 259 }
 260
 261 sub list_properties {
 262     my $self = shift @_;
 263
 264     my @prop_names = keys %{$self->{'props'}};
 265     # return only non-empty properties
 266     grep { $self->{'props'}->{$_} } @prop_names;
 267 }
 268
 269 # setup and run the application
 270 # $cmd - the command to give the application
 271 # $extra_args - an arrayref of additional arguments
 272 # $fds - a hashref of hashrefs specifying file descriptors
 273 #   The key specifies the target file descriptor number in the child process.
 274 #   Each hashref can have:
 275 #     'child_mode' - 'r' or 'w', how the fd will be used in the child process
 276 #     'cb' - an explicit callback to use when the fd is ready for reading/writing
 277 #     'write' - a string to write out. An appropriate callback will be generated
 278 #     'save_to' - a scalarref to save output to. An appropriate callback will be generated
 279 #   For each key in $fds, a pipe will be setup.
 280 #   Additional keys will be added:
 281 #     'child_fd' - the file descriptor used by the child
 282 #     'parent_fd' - the file descriptor used by the parent
 283 #     'handle' - an anonymous filehandle (IO::Handle) for 'parent_fd'
 284 #     'src' - the event source (for Amanda::MainLoop)
 285 #     'done' - a callback (coderef) that must be called when you're done with the fd
 286 # returns child exit status
 287 sub _exec {
 288     my ($self, $cmd, $extra_args, $fds) = @_;
 289     confess 'must have a command' unless $cmd;
 290
 291     my $fdn; # file descriptor number
 292     my $exit_status;
 293
 294     my $all_done = sub {
 295         if (defined($exit_status)) {
 296             # check fds
 297             my $really_done = 1;
 298             foreach $fdn (keys %$fds) {
 299                 my $fd = $fds->{$fdn};
 300                 if (($fd->{'child_mode'} eq 'w') and ref($fd->{'done'})) {
 301                     $really_done = 0;
 302                     last;
 303                 }
 304             }
 305             Amanda::MainLoop::quit() if $really_done;
 306         }
 307     };
 308
 309     # start setting up pipes
 310     foreach $fdn (keys %$fds) {
 311         my $fd = $fds->{$fdn};
 312         confess "mode must be either 'r' or 'w'" unless $fd->{'child_mode'} =~ /^r|w$/;
 313         my ($fd0, $fd1) = POSIX::pipe();
 314         my ($c_fd, $p_fd, $p_mode);
 315         if ($fd->{'child_mode'} eq 'r') {
 316             $p_fd = $fd->{'parent_fd'} = $fd1;
 317             $p_mode = 'w';
 318             $c_fd = $fd->{'child_fd'} = $fd0;
 319         } else {
 320             $p_fd = $fd->{'parent_fd'} = $fd0;
 321             $p_mode = 'r';
 322             $c_fd = $fd->{'child_fd'} = $fd1;
 323         }
 324
 325         my $p_handle = $fd->{'handle'} = IO::Handle->new_from_fd($p_fd, $p_mode);
 326         confess "unable to fdopen $p_fd with mode $p_mode" unless $p_handle;
 327
 328         if ($fd->{'save_to'}) {
 329             $fd->{'cb'} = _make_save_cb($fd->{'save_to'}, $fd);
 330         } elsif ($fd->{'write'}) {
 331             $fd->{'cb'} = _make_write_cb($fd->{'write'}, $fd);
 332         }
 333         $fd->{'done'} = _make_done_cb($fd, $all_done);
 334
 335         my $events = ($fd->{'child_mode'} eq 'r') ? $G_IO_OUT : ($G_IO_IN|$G_IO_HUP);
 336         $fd->{'src'} = Amanda::MainLoop::fd_source($p_handle, $events);
 337         $fd->{'src'}->set_callback($fd->{'cb'}) if $fd->{'cb'};
 338     }
 339
 340     # build arguments
 341     $extra_args ||= [];
 342     my @args = ($cmd, @$extra_args);
 343     foreach my $name (keys %{$self->{'props'}}) {
 344         $self->{'props'}->{$name} ||= [];
 345         foreach my $val (@{$self->{'props'}->{$name}}) {
 346             push @args, "--$name", "$val";
 347         }
 348     }
 349
 350     my $pid = fork();
 351     if ($pid) { # in parent
 352         # parent shouldn't use child_fd
 353         foreach $fdn (keys %$fds) {
 354             my $fd = $fds->{$fdn};
 355             POSIX::close($fd->{'child_fd'});
 356         }
 357         my $wait_src = Amanda::MainLoop::child_watch_source($pid);
 358         $wait_src->set_callback(sub {
 359             $exit_status = $_[2];
 360             $all_done->();
 361         });
 362
 363         Amanda::MainLoop::run();
 364
 365         # cleanup
 366         # don't need to remove wait_src, that's done automatically
 367         foreach $fdn (keys %$fds) {
 368             my $fd = $fds->{$fdn};
 369             $fd->{'src'}->remove();
 370             POSIX::close($fd->{'parent_fd'});
 371         }
 372     } else { # in child
 373         # juggle fd numbers
 374         my @child_fds = keys %$fds;
 375         foreach $fdn (@child_fds) {
 376             my $fd = $fds->{$fdn};
 377             confess "failed to call dup2($fd->{'child_fd'}, $fdn)"
 378                 unless POSIX::dup2($fd->{'child_fd'}, $fdn);
 379             POSIX::close($fd->{'child_fd'})
 380                 unless grep {$_ == $fd->{'child_fd'}} @child_fds;
 381             POSIX::close($fd->{'parent_fd'})
 382                 unless grep {$_ == $fd->{'parent_fd'}} @child_fds;
 383         }
 384
 385         # doesn't return
 386         exec "$APPLICATION_DIR/$self->{'app_name'}", @args;
 387     }
 388
 389     $exit_status;
 390 }
 391
 392 # given a fd hashref, make a callback that will make the fd non-blocking
 393 sub _make_nonblock_cb {
 394     my $fd = shift @_;
 395     confess "a hash reference (representing a fd) is required" unless $fd;
 396     my $nonblock = 0;
 397
 398     sub {
 399         unless ($nonblock) {
 400             my $flags = 0;
 401             fcntl($fd->{'handle'}, F_GETFL, $flags)
 402                 or confess "Couldn't get flags: $!\n";
 403             $flags |= O_NONBLOCK;
 404             fcntl($fd->{'handle'}, F_SETFL, $flags)
 405                 or confess "Couldn't set flags: $!\n";
 406
 407             $nonblock = 1;
 408         }
 409     }
 410 }
 411
 412 # given a scalar/string and a fd hashref,
 413 # make a callback that will write the string to the fd
 414 sub _make_write_cb {
 415     my ($data, $fd) = @_;
 416     confess "a hash reference (representing a fd) is required" unless $fd;
 417     my $len = length($data);
 418     my $offset = 0;
 419     my $nonblock_cb = _make_nonblock_cb($fd);
 420
 421     my $BYTES_TO_WRITE = 4096;
 422     sub {
 423         my $src = shift @_;
 424         $nonblock_cb->();
 425
 426         # this shouldn't happen since the src is removed once we're done (below)
 427         confess "offset greater than length" if $offset >= $len;
 428
 429         my $rv = $fd->{'handle'}->syswrite($data, $BYTES_TO_WRITE, $offset);
 430         if (!defined($rv)) {
 431             confess "Error writing: $!" unless $! == EAGAIN;
 432         }
 433         $offset += $rv;
 434
 435         $fd->{'done'}->() if ($offset >= $len);
 436     }
 437 }
 438
 439
 440 # given a scalarref and a fd hashref,
 441 # make a callback that will save bytes from fd in scalarref
 442 sub _make_save_cb {
 443     my ($store, $fd) = @_;
 444     confess "a scalar reference is required" unless ref($store) eq "SCALAR";
 445     confess "a hash reference (representing a fd) is required" unless $fd;
 446     $$store = '';
 447     my $offset = 0;
 448     my $nonblock_cb = _make_nonblock_cb($fd);
 449
 450     my $BYTES_TO_READ = 4096;
 451     sub {
 452         my $src = shift @_;
 453         $nonblock_cb->();
 454
 455         my $rv = $fd->{'handle'}->sysread($$store, $BYTES_TO_READ, $offset);
 456         if (defined($rv)) {
 457             $fd->{'done'}->() if (0 == $rv);
 458         } else {
 459             confess "Error reading: $!" unless $! == EAGAIN;
 460         }
 461         $offset += $rv;
 462     }
 463 }
 464
 465 sub _make_done_cb {
 466     my ($fd, $all_done) = @_;
 467     sub {
 468         $fd->{'src'}->remove();
 469         $fd->{'handle'}->close();
 470         $fd->{'done'} = 1;
 471         $all_done->();
 472     }
 473 }
 474
 475 # parse the size string output by various commands, returning the number of bytes
 476 sub _parse_size {
 477     my $sstr = shift @_;
 478
 479     confess "failed to parse size" unless ($sstr =~ /^(\d+)(\D?)$/i);
 480     my $size = 0 + $1;
 481     my $suf = lc($2);
 482
 483     $suf = 'k' unless $suf;
 484     my %suf_pows = ('k' => 10, 'm' => 20, 'g' => 30);
 485     confess "invalid suffix $suf" unless $suf_pows{$suf};
 486     $size *= 1 << $suf_pows{$suf};
 487
 488     $size;
 489 }
 490
 491 sub support {
 492     my $self = shift @_;
 493
 494     my $sup_str;
 495     _exec($self, 'support', undef, {
 496         1 => {'child_mode' => 'w', 'save_to' => \$sup_str},
 497     });
 498
 499     my %sup = split(/\s+/, $sup_str);
 500     # fold into uppercase
 501     foreach my $k (keys %sup) {
 502         my $v = $sup{$k};
 503         delete $sup{$k};
 504         $sup{uc($k)} = $v;
 505     }
 506
 507     \%sup;
 508 }
 509
 510 sub backup {
 511     my $self = shift @_;
 512     my %nargs = @_;
 513
 514     foreach my $k ( qw(device level) ) {
 515         confess "$k required" unless defined($nargs{$k});
 516     }
 517     $nargs{'disk'} ||=  $nargs{'device'};
 518
 519     my @args = map {my $k = $_; ("--$k", $nargs{$k}) } keys(%nargs);
 520
 521     my ($data, $msg_str, $index_str);
 522     my $exit_status = _exec($self, 'backup', \@args,
 523         {
 524             1 => {'child_mode' => 'w', 'save_to' => \$data},
 525             3 => {'child_mode' => 'w', 'save_to' => \$msg_str},
 526             4 => {'child_mode' => 'w', 'save_to' => \$index_str},
 527         }
 528     );
 529
 530     my @index = split(/\n/, $index_str);
 531
 532
 533     # parse messages
 534     my ($size, @infos, @errors, @unknowns);
 535     foreach my $l (split(/\n/, $msg_str)) {
 536         if ($l =~ /^([|?&]) (.*)$/) {
 537             my ($sym, $rem) = ($1, $2);
 538             my $arr_ref;
 539             if ($sym eq '|') {
 540                 push(@infos, $rem);
 541             } elsif ($sym eq '?') {
 542                 push(@errors, $rem);
 543             } elsif ($sym eq '&') {
 544                 push(@unknowns, $rem);
 545             } else {
 546                 confess "should not be reached";
 547             }
 548         } elsif ($l =~ /^sendbackup: (.*)$/) {
 549             my $rem = $1;
 550             if ($rem =~ /^size (\d+)$/i) {
 551                 $size = _parse_size($1);
 552             } elsif (lc($rem) eq 'end') {
 553                 # do nothing
 554             } else {
 555                 confess "failed to parse: $l";
 556             }
 557         } else {
 558             confess "failed to parse: $l";
 559         }
 560     }
 561
 562     {'data' => $data, 'index' => \@index, 'size' => $size,
 563      'infos' => \@infos, 'errors' => \@errors, 'unknowns' => \@unknowns,
 564      'exit_status' => $exit_status};
 565 }
 566
 567 sub restore {
 568     my $self = shift @_;
 569     my %args = @_;
 570
 571     foreach my $k ( qw(objects data) ) {
 572         confess "'$k' required" unless defined($args{$k});
 573     }
 574     $args{'level'} ||= 0;
 575
 576     my $msgs;
 577     my $exit_status = _exec($self, 'restore', ['--level', $args{'level'}, @{$args{'objects'}}], {
 578         0 => {'child_mode' => 'r', 'write' => $args{'data'}},
 579         1 => {'child_mode' => 'w', 'save_to' => \$msgs},
 580     });
 581
 582     {'msgs' => $msgs, 'exit_status' => $exit_status};
 583 }
 584
 585 # XXX: index?
 586
 587 sub estimate {
 588     my $self = shift @_;
 589     my %nargs = @_;
 590
 591     foreach my $k ( qw(device level) ) {
 592         confess "$k required" unless defined($nargs{$k});
 593     }
 594     $nargs{'disk'} ||=  $nargs{'device'};
 595     my $calcsize = $nargs{'calcsize'};
 596     delete $nargs{'calcsize'};
 597
 598     my @args = map {my $k = $_; ("--$k", $nargs{$k}) } keys(%nargs);
 599     push @args, '--calcsize' if $calcsize;
 600
 601     my $est;
 602     my $exit_status = _exec($self, 'estimate', \@args,
 603         {
 604             1 => {'child_mode' => 'w', 'save_to' => \$est},
 605         }
 606     );
 607     $est =~ /^(\d+) (\d+) 1\n$/;
 608     my ($level, $size) = ($1, $2);
 609     $level = 0 + $level;
 610     $size = ($size eq '-1')? -1 : _parse_size($size);
 611
 612     {'level' => $level, 'size' => $size, 'exit_status' => $exit_status};
 613 }
 614
 615 sub selfcheck {
 616     my $self = shift @_;
 617     my %nargs = @_;
 618
 619     foreach my $k ( qw(device) ) {
 620         confess "$k required" unless defined($nargs{$k});
 621     }
 622     $nargs{'disk'} ||=  $nargs{'device'};
 623
 624     my @args = map {my $k = $_; ("--$k", $nargs{$k}) } keys(%nargs);
 625
 626     my $msg_str;
 627     my $exit_status = _exec($self, 'selfcheck', \@args,
 628         {
 629             1 => {'child_mode' => 'w', 'save_to' => \$msg_str},
 630         }
 631     );
 632
 633     my (@oks, @errors);
 634     foreach my $l (split(/\n/, $msg_str)) {
 635         confess "invalid line: $l" unless $l =~ /^(OK|ERROR) (.*)$/;
 636         my ($type, $rem) = ($1, $2);
 637         if ($type eq 'OK') {
 638             push(@oks, $rem);
 639         } elsif ($type eq 'ERROR') {
 640             push(@errors, $rem);
 641         } else {
 642             confess "should not be reached";
 643         }
 644     }
 645
 646     {'oks' => \@oks, 'errors' => \@errors, 'exit_status' => $exit_status};
 647 }
 648
 649 # XXX: print?
 650
 651 1;