git.maemo.org Git - maemian/blob - lib/Maemian/Command.pm

   1 # Copyright © 2008 Frank Lichtenheld <frank@lichtenheld.de>
   2 #
   3 # This program is free software; you can redistribute it and/or modify
   4 # it under the terms of the GNU General Public License as published by
   5 # the Free Software Foundation; either version 2 of the License, or
   6 # (at your option) any later version.
   7 #
   8 # This program is distributed in the hope that it will be useful,
   9 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  10 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  11 # GNU General Public License for more details.
  12 #
  13 # You should have received a copy of the GNU General Public License
  14 # along with this program.  If not, you can find it on the World Wide
  15 # Web at http://www.gnu.org/copyleft/gpl.html, or write to the Free
  16 # Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
  17 # MA 02110-1301, USA.
  18
  19 package Maemian::Command;
  20 use strict;
  21 use warnings;
  22
  23 BEGIN {
  24     # Disabling IPC::Run::Debug saves tons of useless calls.
  25     $ENV{'IPCRUNDEBUG'} = 'none';
  26 }
  27
  28 use base qw(Exporter);
  29 our @EXPORT = ();
  30 our @EXPORT_OK = qw(spawn reap kill);
  31
  32 use IPC::Run qw(run harness kill_kill);
  33
  34 =head1 NAME
  35
  36 Lintian::Command - Utilities to execute other commands from lintian code
  37
  38 =head1 SYNOPSIS
  39
  40     use Lintian::Command qw(spawn);
  41
  42     # simplest possible call
  43     my $success = spawn({}, ['command']);
  44
  45     # catch output
  46     my $opts = {};
  47     $success = spawn($opts, ['command']);
  48     if ($success) {
  49         print "STDOUT: $opts->{out}\n";
  50         print "STDERR: $opts->{err}\n";
  51     }
  52
  53     # from file to file
  54     $opts = { in => 'infile.txt', out => 'outfile.txt' };
  55     $success = spawn($opts, ['command']);
  56
  57     # piping
  58     $success = spawn({}, ['command'], "|", ['othercommand']);
  59
  60 =head1 DESCRIPTION
  61
  62 Lintian::Command is a thin wrapper around IPC::Run, that catches exception
  63 and implements a useful default behaviour for input and output redirection.
  64
  65 Lintian::Command provides a function spawn() which is a wrapper
  66 around IPC::Run::run() resp. IPC::Run::start() (depending on whether a
  67 pipe is requested).  To wait for finished child processes, it also
  68 provides the reap() function as a wrapper around IPC::Run::finish().
  69
  70 =head2 C<spawn($opts, @cmds)>
  71
  72 The @cmds array is given to IPC::Run::run() (or ::start()) unaltered, but
  73 should only be used for commands and piping symbols (i.e. all of the elements
  74 should be either an array reference, a code reference, '|', or '&').  I/O
  75 redirection is handled via the $opts hash reference. If you need more fine
  76 grained control than that, you should just use IPC::Run directly.
  77
  78 $opts is a hash reference which can be used to set options and to retrieve
  79 the status and output of the command executed.
  80
  81 The following hash keys can be set to alter the behaviour of spawn():
  82
  83 =over 4
  84
  85 =item in
  86
  87 STDIN for the first forked child.  Defaults to C<\undef>.
  88
  89 =item pipe_in
  90
  91 Use a pipe for STDIN and start the process in the background.
  92 You will need to close the pipe after use and call $opts->{harness}->finish
  93 in order for the started process to end properly.
  94
  95 =item out
  96
  97 STDOUT of the last forked child.  Will be set to a newly created
  98 scalar reference by default which can be used to retrieve the output
  99 after the call.
 100
 101 =item pipe_out
 102
 103 Use a pipe for STDOUT and start the process in the background.
 104 You will need to call $opts->{harness}->finish in order for the started
 105 process to end properly.
 106
 107 =item err
 108
 109 STDERR of all forked childs.  Defaults to STDERR of the parent.
 110
 111 =item pipe_err
 112
 113 Use a pipe for STDERR and start the process in the background.
 114 You will need to call $opts->{harness}->finish in order for the started
 115 process to end properly.
 116
 117 =item fail
 118
 119 Configures the behaviour in case of errors. The default is 'exception',
 120 which will cause spawn() to die in case of exceptions thrown by IPC::Run.
 121 If set to 'error' instead, it will also die if the command exits
 122 with a non-zero error code.  If exceptions should be handled by the caller,
 123 setting it to 'never' will cause it to store the exception in the
 124 C<exception> key instead.
 125
 126 =back
 127
 128 The following additional keys will be set during the execution of spawn():
 129
 130 =over 4
 131
 132 =item harness
 133
 134 Will contain the IPC::Run object used for the call which can be used to
 135 query the exit values of the forked programs (E.g. with results() and
 136 full_results()) and to wait for processes started in the background.
 137
 138 =item exception
 139
 140 If an exception is raised during the execution of the commands,
 141 and if C<fail> is set to 'never', the exception will be caught and
 142 stored under this key.
 143
 144 =item success
 145
 146 Will contain the return value of spawn().
 147
 148 =back
 149
 150 =cut
 151
 152 sub spawn {
 153     my ($opts, @cmds) = @_;
 154
 155     if (ref($opts) ne 'HASH') {
 156         $opts = {};
 157     }
 158     $opts->{fail} ||= 'exception';
 159
 160     my ($out, $background);
 161     my (@out, @in, @err);
 162     if ($opts->{pipe_in}) {
 163         @in = ('<pipe', $opts->{pipe_in});
 164         $background = 1;
 165     } else {
 166         $opts->{in} ||= \undef;
 167         @in = ('<', $opts->{in});
 168     }
 169     if ($opts->{pipe_out}) {
 170         @out = ('>pipe', $opts->{pipe_out});
 171         $background = 1;
 172     } else {
 173         $opts->{out} ||= \$out;
 174         @out = ('>', $opts->{out});
 175     }
 176     if ($opts->{pipe_err}) {
 177         @err = ('2>pipe', $opts->{pipe_err});
 178         $background = 1;
 179     } else {
 180         $opts->{err} ||= \*STDERR;
 181         @err = ('2>', $opts->{err});
 182     }
 183
 184 #    use Data::Dumper;
 185 #    print STDERR Dumper($opts, \@cmds);
 186     eval {
 187         if (@cmds == 1) {
 188             my $cmd = pop @cmds;
 189             my $last = pop @$cmd;
 190             # Support shell-style "command &"
 191             if ($last eq '&') {
 192                 $background = 1;
 193             } else {
 194                 push @$cmd, $last;
 195             }
 196             $opts->{harness} = harness($cmd, @in, @out, @err);
 197         } else {
 198             my ($first, $last) = (shift @cmds, pop @cmds);
 199             # Support shell-style "command &"
 200             if ($last eq '&') {
 201                 $background = 1;
 202             } else {
 203                 push @cmds, $last;
 204             }
 205             $opts->{harness} = harness($first, @in, @cmds, @out, @err);
 206         }
 207         if ($background) {
 208             $opts->{success} = $opts->{harness}->start;
 209         } else {
 210             $opts->{success} = $opts->{harness}->run;
 211         }
 212     };
 213     if ($@) {
 214         require Util;
 215         Util::fail($@) if $opts->{fail} ne 'never';
 216         $opts->{success} = 0;
 217         $opts->{exception} = $@;
 218     } elsif ($opts->{fail} eq 'error'
 219              and !$opts->{success}) {
 220         require Util;
 221         if ($opts->{description}) {
 222             Util::fail("$opts->{description} failed with error code ".
 223                        $opts->{harness}->result);
 224         } elsif (@cmds == 1) {
 225             Util::fail("$cmds[0][0] failed with error code ".
 226                        $opts->{harness}->result);
 227         } else {
 228             Util::fail("command failed with error code ".
 229                        $opts->{harness}->result);
 230         }
 231     }
 232 #    print STDERR Dumper($opts, \@cmds);
 233     return $opts->{success};
 234 }
 235
 236 =head2 C<reap($opts[, $opts[,...]])>
 237
 238 If you used one of the C<pipe_*> options to spawn() or used the shell-style "&"
 239 operator to send the process to the background, you will need to wait for your
 240 child processes to finish.  For this you can use the reap() function,
 241 which you can call with the $opts hash reference you gave to spawn() and which
 242 will do the right thing. Multiple $opts can be passed.
 243
 244 Note however that this function will not close any of the pipes for you, so
 245 you probably want to do that first before calling this function.
 246
 247 The following keys of the $opts hash have roughly the same function as
 248 for spawn():
 249
 250 =over 4
 251
 252 =item harness
 253
 254 =item fail
 255
 256 =item success
 257
 258 =item exception
 259
 260 =back
 261
 262 All other keys are probably just ignored.
 263
 264 =cut
 265
 266 sub reap {
 267     my $status = 1;
 268     while (my $opts = shift @_) {
 269         next unless defined($opts->{harness});
 270
 271         eval {
 272             $opts->{success} = $opts->{harness}->finish;
 273         };
 274         if ($@) {
 275             require Util;
 276             Util::fail($@) if $opts->{fail} ne 'never';
 277             $opts->{success} = 0;
 278             $opts->{exception} = $@;
 279         } elsif ($opts->{fail} eq 'error'
 280                  and !$opts->{success}) {
 281             require Util;
 282             if ($opts->{description}) {
 283                 Util::fail("$opts->{description} failed with error code ".
 284                            $opts->{harness}->result);
 285             } else {
 286                 Util::fail("command failed with error code ".
 287                            $opts->{harness}->result);
 288             }
 289         }
 290         $status &&= $opts->{success};
 291     }
 292     return $status;
 293 }
 294
 295 =head2 C<kill($opts[, $opts[, ...]])>
 296
 297 This is a simple wrapper around the kill_kill function. It doesn't allow
 298 any customisation, but takes an $opts hash ref and SIGKILLs the process
 299 two seconds after SIGTERM is sent. If multiple hash refs are passed it
 300 executes kill_kill on each of them. The return status is the ORed value of
 301 all the executions of kill_kill.
 302
 303 =cut
 304
 305 sub kill {
 306     my $status = 1;
 307     while (my $opts = shift @_) {
 308         $status &&= kill_kill($opts->{'harness'}, grace => 2);
 309     }
 310     return $status;
 311 }
 312
 313 1;
 314 __END__
 315
 316 =head1 EXPORTS
 317
 318 Lintian::Command exports nothing by default, but you can export the
 319 spawn() and reap() functions.
 320
 321 =head1 AUTHOR
 322
 323 Originally written by Frank Lichtenheld <djpig@debian.org> for Lintian.
 324
 325 =head1 SEE ALSO
 326
 327 lintian(1), IPC::Run
 328
 329 =cut