fix timeout message when killing for other reason

3 files changed, 29 insertions, 7 deletions

diff --git a/NEWS b/NEWS
index 82d25c1..b122951 100644
--- a/NEWS
+++ b/NEWS
@@ -1,3 +1,5 @@
+- fix timeout message when killing for other reason
+
 0.7.8.1
 - no changes, fixing bad release
 
diff --git a/iurt b/iurt
index 95aa89c..9008bdf 100755
--- a/iurt
+++ b/iurt
@@ -40,7 +40,7 @@ use URPM;
 
 use Iurt::Urpmi;
 use Iurt::Chroot qw(add_local_user create_temp_chroot remove_chroot create_build_chroot clean_chroot);
-use Iurt::Process qw(perform_command kill_for_good sudo);
+use Iurt::Process qw(perform_command kill_for_good set_alarm_message sudo);
 use Iurt::Mail qw(sendmail);
 use Iurt::Util qw(plog_init plog);
 use File::NCopy qw(copy);
@@ -1082,9 +1082,11 @@ sub check_pid {
 	    my $state = `ps h -o state $pid`;
 	    chomp $state;
 	    if ($time < time()-36000 || $state eq 'Z') {
-		plog("an other iurt pid $pid is running for a very long time or is zombie, killing it");
+		my $msg = "an other iurt pid $pid is running for a very long time or is zombie, killing it";
+		plog($msg);
 		my $i;
 		while ($i < 5 && getpgrp $pid != -1) {
+		    set_alarm_message($msg);
 		    kill_for_good($pid);
 		    $i++;
 		    sleep 1;
diff --git a/lib/Iurt/Process.pm b/lib/Iurt/Process.pm
index dc25f99..46b8de2 100644
--- a/lib/Iurt/Process.pm
+++ b/lib/Iurt/Process.pm
@@ -14,6 +14,7 @@ our @EXPORT = qw(
     clean_process
     check_pid
     perform_command
+    set_alarm_message
     sudo
 );
 
@@ -58,7 +59,9 @@ sub check_pid {
 	    if ($time < time()-7200 || $state eq 'Z') {
 		my $i;
 
-		plog('WARN', "another instance [$pid] is too old, killing it");
+		my $msg = "another instance [$pid] is too old, killing it";
+		set_alarm_message($msg);
+		plog('WARN', $msg);
 
 		while ($i < 5 && getpgrp $pid != -1) {
 		    kill_for_good($pid);
@@ -102,14 +105,18 @@ sub fork_to_monitor {
 	    my (@stat) = stat $logfile;
 	    if ($stat[7] > $size_limit) {
 		# FIXME: we left runaway processes (eg: urpmi)
-		plog('ERROR', "Killing current command because of log size exceeding limit ($stat[7] > $config->{log_size_limit})");
+		my $msg = "Killing current command because of log size exceeding limit ($stat[7] > $config->{log_size_limit})";
+		set_alarm_message($msg);
+		plog('ERROR', $msg);
 		kill 14, "-$parent_pid";
 		exit();
 	    }
 	    if ($opt{stalled_timeout} && $stat[9] && $stat[9] + $opt{stalled_timeout} < time()) {
 		# If nothing was written to the logfile for more than stalled_timeout, check if the system seems busy
 		if ((getload())[1] < 0.5) {
-		    plog('ERROR', "Killing current command because it seems blocked");
+		    my $msg = "Killing current command because it seems blocked";
+		    set_alarm_message($msg);
+		    plog('ERROR', $msg);
 		    kill 14, "-$parent_pid";
 		    exit();
 		}
@@ -118,7 +125,8 @@ sub fork_to_monitor {
 	    my $df = df $opt{log};
 	    if ($df->{per} >= 99) {
 		# FIXME: we left runaway processes (eg: urpmi)
-		plog('ERROR', "Killing current command because running out of disk space at $opt{log} (only $df->{bavail}KB left)");
+		set_alarm_message(my $msg = "Killing current command because running out of disk space at $opt{log} (only $df->{bavail}KB left)");
+		plog('ERROR', $msg);
 		kill 14, "-$parent_pid";
 		exit();
 	    }
@@ -202,6 +210,13 @@ sub generate_comment {
     }
 }
 
+my $alarm_message;
+
+sub set_alarm_message {
+    my ($msg) = @_;
+    $alarm_message = $msg;
+}
+
 =head2 perform_command($command, $run, $config, %opt)
 
 Run a command and check various running parameters such as log size, timeout...
@@ -253,8 +268,9 @@ sub perform_command {
 
 	eval {
 	    # handle timeout:
+	    set_alarm_message("Timeout! (timeout was $opt{timeout})");
 	    local $SIG{ALRM} = sub {
-		print "Timeout! (timeout was $opt{timeout})\n";
+		print $alarm_message, "\n";
 		$kill = 1;
 		die "alarm\n";  # NB: \n required
 	    };
@@ -290,6 +306,7 @@ sub perform_command {
 	$err = 0 if any { $_ == $err } @{$opt{error_ok}};
 
 	# kill pid watching log file size
+	set_alarm_message("kill pid watching log file size");
 	kill_for_good($pid) if $pid;
 
 	if ($perl_err) {	# timed out
@@ -365,6 +382,7 @@ sub kill_for_good {
     my ($pid) = @_;
 
     # try SIGALARM first:
+    set_alarm_message("Killing current command because it seems blocked");
     kill 14, $pid;
     sleep 1;
     waitpid(-1, POSIX::WNOHANG);