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