summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
-rw-r--r--perl-install/NEWS3
-rw-r--r--perl-install/run_program.pm57
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);