run_program: add optional callback when waiting for program to terminate

This allows GUI applications to respond to check-alive pings (mga#31105)

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);