diff options
Diffstat (limited to 'perl-install/run_program.pm')
| -rw-r--r-- | perl-install/run_program.pm | 246 |
1 files changed, 235 insertions, 11 deletions
diff --git a/perl-install/run_program.pm b/perl-install/run_program.pm index a45b5b79b..b3a65d13a 100644 --- a/perl-install/run_program.pm +++ b/perl-install/run_program.pm @@ -1,4 +1,4 @@ -package run_program; # $Id: run_program.pm 266118 2010-02-11 14:57:12Z pterjan $ +package run_program; use diagnostics; use strict; @@ -7,25 +7,123 @@ use c; use MDK::Common; use common; # for get_parent_uid() use log; +use Time::HiRes qw(ualarm); + +=head1 SYNOPSYS + +B<run_program> enables to: + +=over 4 + +=item * run programs in foreground or in background, + +=item * to retrieve their stdout or stderr + +=item * ... + +=back + +Most functions exits in a normal form & a rooted one. e.g.: + +=over 4 + +=item * C<run()> & C<rooted()> + +=item * C<get_stdout()> & C<rooted_get_stdout()> + +=back + +Most functions exits in a normal form & one that die. e.g.: + +=over 4 + +=item * C<run()> & C<run_or_die()> + +=item * C<rooted()> & C<rooted_or_die()> + +=back + +=head1 Functions + +=over + +=cut 1; my $default_timeout = 10 * 60; +=item set_default_timeout($seconds) + +Alters defaults timeout (eg for harddrake service) + +=cut + sub set_default_timeout { my ($seconds) = @_; $default_timeout = $seconds; } +my $callback_routine; +my $callback_interval = 1 * 1000; + +=item set_wait_loop_callback($routine, $o_interval) + +Sets a callback routine that will be called at regular intervals whilst +waiting for a program being run in the foreground. Optionally sets the +interval in milliseconds between callbacks. If not set, the interval is +1 second. + +The callback routine will be passed one argument which is the pid of +the program being run. + +The callback routine should not call sleep() or abort(), as that may +prevent it being called again. + +=cut + +sub set_wait_loop_callback { + my ($routine, $o_interval) = @_; + $callback_routine = $routine; + $callback_interval = $o_interval if $o_interval; +} + +=item run_or_die($name, @args) + +Runs $name with @args parameterXs. Dies if it exit code is not 0. + +=cut + sub run_or_die { my ($name, @args) = @_; run($name, @args) or die "$name failed\n"; } + +=item rooted_or_die($root, $name, @args) + +Similar to run_or_die() but runs in chroot in $root + +=cut + sub rooted_or_die { my ($root, $name, @args) = @_; rooted($root, $name, @args) or die "$name failed\n"; } +=item get_stdout($name, @args) + +Similar to run_or_die() but return stdout of program: + +=over 4 + +=item * a list of lines in list context + +=item * a string of concatenated lines in scalar context + +=back + +=cut + sub get_stdout { my ($name, @args) = @_; my @r; @@ -33,6 +131,12 @@ sub get_stdout { wantarray() ? @r : join('', @r); } +=item get_stdout_raw($options, $name, @args) + +Similar to get_stdout() but allow to pass options to raw() + +=cut + sub get_stdout_raw { my ($options, $name, @args) = @_; my @r; @@ -40,6 +144,12 @@ sub get_stdout_raw { wantarray() ? @r : join('', @r); } +=item rooted_get_stdout($root, $name, @args) + +Similar to get_stdout() but runs in chroot in $root + +=cut + sub rooted_get_stdout { my ($root, $name, @args) = @_; my @r; @@ -47,13 +157,61 @@ sub rooted_get_stdout { wantarray() ? @r : join('', @r); } +=item run($name, @args) + +Runs $name with @args parameters. + +=cut + sub run { raw({}, @_) } +=item rooted($root, $name, @args) + +Similar to run() but runs in chroot in $root + +=cut + sub rooted { my ($root, $name, @args) = @_; raw({ root => $root }, $name, @args); } +=item raw($options, $name, @args) + +The function used by all the other, making every combination possible. +Runs $name with @args parameters. $options is a hash ref that can contains: + +=over 4 + +=item * B<root>: $name will be chrooted in $root prior to run + +=item * B<as_user>: $name will be run as $ENV{PKEXEC_UID} or with the UID of parent process. Implies I<setuid> + +=item * B<sensitive_arguments>: parameters will be hidden in logs (b/c eg there's a password) + +=item * B<detach>: $name will be run in the background. Default is foreground + +=item * B<chdir>: $name will be run in a different default directory + +=item * B<setuid>: a UID; $name will be with droped privileges ; +make sure environment is set right and keep a copy of the X11 cookie + +=item * B<timeout>: execution of $name will be aborted after C<timeout> seconds + +=back + +eg: + +=over 4 + +=item * C<< run_program::raw({ root => $::prefix, sensitive_arguments => 1 }, "echo -e $user->{password} | cryptsetup luksFormat $device"); >> + +=item * C<< run_program::raw({ detach => 1 }, '/etc/rc.d/init.d/dm', '>', '/dev/null', '2>', '/dev/null', 'restart'); >> + +=back + +=cut + sub raw { my ($options, $name, @args) = @_; my $root = $options->{root} || ''; @@ -65,14 +223,8 @@ sub raw { my $home; if ($options->{as_user}) { - my $uid; - $uid = $ENV{USERHELPER_UID} && getpwuid($ENV{USERHELPER_UID}); - $uid ||= common::get_parent_uid(); - $options->{setuid} = getpwnam($uid) if $uid; - my ($full_user) = grep { $_->[2] eq $uid } list_passwd(); - $home = $full_user->[7] if $full_user; + $options->{setuid} = $ENV{PKEXEC_UID} ||= common::get_parent_uid();; } - local $ENV{HOME} = $home if $home; my $args = $options->{sensitive_arguments} ? '<hidden arguments>' : join(' ', @args); log::explanations("running: $real_name $args" . ($root ? " with root $root" : "")); @@ -104,19 +256,47 @@ sub raw { } else { my $ok; add2hash_($options, { timeout => $default_timeout }); + + my $remaining = $options->{timeout} if $options->{timeout} ne 'never'; + #- We count in milliseconds when using a callback routine. + $remaining *= 1000 if $remaining && $callback_routine; + + #- Preserve any pre-existing alarm. + my $old_remaining = alarm(0) if $remaining; + + wait_again: + eval { local $SIG{ALRM} = sub { die "ALARM" }; - my $remaining = $options->{timeout} && $options->{timeout} ne 'never' && alarm($options->{timeout}); + if ($callback_routine) { + ualarm($callback_interval * 1000); + } elsif ($remaining) { + alarm($remaining); + } waitpid $pid, 0; $ok = $? == -1 || ($? >> 8) == 0; - alarm $remaining; + if ($callback_routine) { + ualarm(0); + } elsif ($remaining) { + alarm(0); + } }; if ($@) { + if ($@ =~ /^ALARM/ && $callback_routine) { + $callback_routine->($pid); + $remaining -= $callback_interval if $remaining; + goto wait_again if !defined $remaining || $remaining > 0; + } log::l("ERROR: killing runaway process (process=$real_name, pid=$pid, args=@args, error=$@)"); kill 9, $pid; + #- Restore any pre-existing alarm. + alarm($old_remaining) if $old_remaining; return; } + #- Restore any pre-existing alarm. + alarm($old_remaining) if $old_remaining; + if ($stdout_raw && ref($stdout_raw)) { if (ref($stdout_raw) eq 'ARRAY') { @$stdout_raw = cat_($stdout); @@ -140,6 +320,7 @@ sub raw { require POSIX; my ($logname, $home) = (getpwuid($options->{setuid}))[0,7]; $ENV{LOGNAME} = $logname if $logname; + $ENV{HOME} = $home if $home; # if we were root and are going to drop privilege, keep a copy of the X11 cookie: if (!$> && $home) { @@ -187,9 +368,42 @@ sub raw { } -# run in background a sub that give back data through STDOUT a la run_program::get_stdout but w/ arbitrary perl code instead of external program +=item terminate($pid, $o_timeout) + +Sends the TERM signal to the process identified by $pid and waits for it +to terminate. If it hasn't terminated in $o_timeout seconds, sends the +KILL signal and returns without waiting. If $o_timeout is not specified, +the default timeout is 5 seconds. If $o_timeout is less than or equal to +zero, the TERM signal is not sent and the process is killed immediately. + +=cut + +sub terminate { + my ($pid, $o_timeout) = @_; + + if (!defined $o_timeout || $o_timeout > 0) { + kill 'TERM', $pid; + eval { + local $SIG{ALRM} = sub { die "ALARM" }; + my $old_remaining = alarm($o_timeout || 5); + waitpid $pid, 0; + alarm($old_remaining); + }; + return if !$@; + log::l("ERROR: killing runaway process (pid=$pid, error=$@)"); + } + kill 'KILL', $pid; +} + package bg_command; +=item bg_command::new($class, $sub) + +Runs in background a sub that give back data through STDOUT a la run_program::get_stdout +but w/ arbitrary perl code instead of external program + +=cut + sub new { my ($class, $sub) = @_; my $o = bless {}, $class; @@ -202,12 +416,22 @@ sub new { } } +=item bg_command::DESTROY($o) + +When undefined (either explicitly or at end of lexical scope), close the fd and wait for the child process. + +=cut + sub DESTROY { my ($o) = @_; close $o->{fd} or warn "kid exited $?"; waitpid $o->{pid}, 0; } +=back + +=cut + 1; #- Local Variables: |