diff options
Diffstat (limited to 'perl-install')
| -rw-r--r-- | perl-install/NEWS | 3 | ||||
| -rw-r--r-- | perl-install/run_program.pm | 57 |
2 files changed, 58 insertions, 2 deletions
diff --git a/perl-install/NEWS b/perl-install/NEWS index 8a27d3d7c..cab9f1e85 100644 --- a/perl-install/NEWS +++ b/perl-install/NEWS @@ -1,3 +1,6 @@ +- run_program: + o add optional callback when waiting for program to terminate + * this allows GUI applications to respond to check-alive pings (mga#31105) - make installer routines for selecting a mirror and downloader available for use by draklive-install - use better algorithm for determining nearest mirror (taken from urpmi) diff --git a/perl-install/run_program.pm b/perl-install/run_program.pm index f323bace6..5ac4bf972 100644 --- a/perl-install/run_program.pm +++ b/perl-install/run_program.pm @@ -7,6 +7,7 @@ use c; use MDK::Common; use common; # for get_parent_uid() use log; +use Time::HiRes qw(ualarm); =head1 SYNOPSYS @@ -63,6 +64,30 @@ sub set_default_timeout { $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. @@ -231,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); |