testrunner: add support for --timeout option on Windows

Use Win32::Job to safely terminate a process (and all child processes)
after a timeout.  Special care is taken to try to preserve argument
processing to be as close as possible to a plain system(@args).

Change-Id: I9b552587787f1a4bec3015f985fac27951d8fa05
Reviewed-on: http://codereview.qt.nokia.com/2157
Reviewed-by: Qt Sanity Bot <qt_sanity_bot@ovi.com>
Reviewed-by: Kalle Lehtonen <kalle.ju.lehtonen@nokia.com>
Reviewed-by: Sergio Ahumada <sergio.ahumada@nokia.com>
Reviewed-by: Rohan McGovern <rohan.mcgovern@nokia.com>

1 files changed, 98 insertions, 2 deletions

diff --git a/scripts/lib/perl5/QtQA/Proc/Reliable/Win32.pm b/scripts/lib/perl5/QtQA/Proc/Reliable/Win32.pm
index ce2a27b..ac2dd96 100644
--- a/scripts/lib/perl5/QtQA/Proc/Reliable/Win32.pm
+++ b/scripts/lib/perl5/QtQA/Proc/Reliable/Win32.pm
@@ -3,13 +3,35 @@ use strict;
 use warnings;
 
 use Capture::Tiny qw( tee );
+use Carp;
+use Data::Dumper;
+use English qw( -no_match_vars );
+use MIME::Base64;
+use Readonly;
+use Storable qw( thaw freeze );
+
+BEGIN {
+    if ($OSNAME =~ m{win32}i) {
+        require Win32::Job;
+        Win32::Job->import( );
+    }
+}
+
+# special key which, if present in $ENV, means we should simply run
+# and exit a given command (for win32 support)
+Readonly my $ENV_EXEC_KEY => q{__QTQA_PROC_RELIABLE_EXEC};
+
+# a long time, but not forever
+Readonly my $LONG_TIME => 60*60*24*7;
 
 sub new
 {
     my ($class) = @_;
 
     return bless {
-        status => -1,
+        status  => -1,
+        msg     => q{},
+        maxtime => $LONG_TIME,
     }, $class;
 }
 
@@ -17,10 +39,63 @@ sub run
 {
     my ($self, $command_ref) = @_;
 
+    # This convoluted setup aims to solve these problems:
+    #
+    #  - We want to use exactly the same algorithm for turning a list of
+    #    arguments into a single command string as perl uses itself in system()
+    #
+    #  - We want to be able to timeout and kill the child process, and system()
+    #    can't do this.
+    #
+    # We use Win32::Job to achieve the timeout/kill requirement.
+    #
+    # To achieve the system() compatibility, we pass the command array
+    # through an environment variable into an intermediate perl process.
+    #
+    # This intermediate process is a new perl instance, which simply loads
+    # this file again with $ENV_EXEC_KEY set.
+
+    my $self_pm = $INC{ 'QtQA/Proc/Reliable/Win32.pm' };
+
+    # May happen if the module was included in an odd way
+    if (!defined( $self_pm )) {
+        confess 'package '.__PACKAGE__." cannot find its own .pm file!\n"
+               ."%INC: ".Dumper(\%INC);
+    }
+    if (! -e $self_pm) {
+        confess 'package '.__PACKAGE__." should be located at $self_pm, but "
+               .'that file does not exist!';
+    }
+
+    local $ENV{ $ENV_EXEC_KEY } = encode_base64( freeze( $command_ref ), undef );
+    my $cmd = qq{"$EXECUTABLE_NAME" "$self_pm"};
+
+    my $job = Win32::Job->new( );
+    my $timeout = $self->{ maxtime };
+    my $pid;
+    my $exited_normally;
+
     my ($stdout, $stderr) = tee {
-        $self->{ status } = system( @{$command_ref} );
+        $pid = $job->spawn( $EXECUTABLE_NAME, $cmd );
+        $exited_normally = $job->run( $timeout );
     };
 
+    if (!$exited_normally) {
+        # The docs for Win32::Job state that a timeout is the only
+        # reason that run() will return false
+        $self->{ msg } .= "Timed out after $timeout seconds\n";
+    }
+
+    my $exitcode = $job->status()->{ $pid }{ exitcode };
+
+    if ( ! defined $exitcode) {
+        # I think that this will never happen ...
+        $self->{ msg } .= "Win32::Job did not report an exit code for the process\n";
+        $exitcode = 294;
+    }
+
+    $self->{ status } = ($exitcode << 8);
+
     if ($self->{ stdout_cb }) {
         $self->_activate_callback( $self->{ stdout_cb }, $stdout );
     }
@@ -56,6 +131,20 @@ sub stderr_cb
     return;
 }
 
+sub msg {
+    my ($self) = @_;
+
+    return $self->{ msg };
+}
+
+sub maxtime {
+    my ($self, $maxtime) = @_;
+
+    $self->{ maxtime } = $maxtime;
+
+    return;
+}
+
 sub _activate_callback
 {
     my ($self, $cb, $text) = @_;
@@ -72,6 +161,13 @@ sub _activate_callback
     return;
 }
 
+# Helper for win32 support; if signalled by the presence of this environment
+# variable, just run a command and exit.
+if (!caller && exists( $ENV{ $ENV_EXEC_KEY } )) {
+    my $command = delete $ENV{ $ENV_EXEC_KEY };
+    $command = thaw decode_base64 $command;
+    exit( system( @{$command} ) >> 8);
+}
 
 =head1 NAME