Timing Windows commands

[eyepopslikeamosquito]

A while back I did Timing and timing out Unix commands to run commands, timing how long they took to run. Now they want a Windows version.

I don't think fork or signals will cut it on Windows, due to limitations and general weirdness of perlfork emulation under Windows. So I've basically rewritten it, as shown below. Update: See reply below for a better Windows version using Win32::Job.

Though simpler than the Unix version, it's currently unable to compute the child process CPU time. :-( This is because the Benchmark module on Windows always returns zero for this. I'm pretty sure the root cause of this is the lack of the Unix times function on Windows; its emulation in the win32_times function in win32/win32.c always returning zero for tms_cutime and tms_cstime. I'd like to work around this by calling the Win32 GetProcessTimes function, but that function is not supported by Win32::Process.

Suggestions welcome.

use strict;
use Time::HiRes qw(time sleep);
use Win32::Process;

select(STDERR);$|=1;select(STDOUT);$|=1;   # autoflush
### save original stdout and stderr
open(SAVEOUT, ">&STDOUT"); open(SAVEERR, ">&STDERR");

my $SysDir = "$ENV{SystemRoot}\\system32";  # is there a better way?
my $Outf   = "out-$$.tmp";
my $Errf   = "err-$$.tmp";

sub slurp_file {
  my $file = shift;
  local $/;
  open(my $fh, $file) or die "error:open '$file': $!";
  <$fh>;
}

sub write_result {
  my ($pid, $rc, $elap) = @_;
  warn "pid=$pid, rc=$rc, elapsed=$elap\n";
  my $outstr = slurp_file($Outf);
  my $errstr = slurp_file($Errf);
  unlink($Outf) or die "error: unlink '$Outf': $!";
  unlink($Errf) or die "error: unlink '$Errf': $!";
  warn "cmd stdout='$outstr'\n";
  warn "cmd stderr='$errstr'\n";
}

# Run command $cmd, timing out after $timeout seconds.
sub run_for {
  my ($cmd, $timeout) = @_;
  $timeout *= 1000;   # convert to millisecs
  warn "run $cmd->[0] ($cmd->[1]) at " . scalar(localtime) . "\n";
  my $t0 = time();
  ### redirect stdout and stderr
  open(STDOUT, '>'.$Outf) or die "error create '$Outf': $!";
  open(STDERR, '>'.$Errf) or die "error create '$Errf': $!";
  Win32::Process::Create(my $hProc,             # process object
                         $cmd->[0],             # executable
                         $cmd->[1],             # command line
                         1,                     # inherit handles
                         NORMAL_PRIORITY_CLASS, # priority
                         '.')                   # working dir
     or die "error create process: $!";
  ### parent continues (redirect back to original) ...
  close(STDOUT); close(STDERR);
  open(STDOUT, ">&SAVEOUT"); open(STDERR, ">&SAVEERR");
  my $pid = $hProc->GetProcessID();
  warn "in run_for, waiting for pid=$pid\n";
  $hProc->Wait($timeout) or $hProc->Kill(42), $hProc->Wait(INFINITE);
  $hProc->GetExitCode(my $rc) or warn "error GetExitCode: $!\n";
  my $t1 = time();
  write_result($pid, $rc, $t1 - $t0);
}

my @cmds = (
 [ "$SysDir\\netstat.exe", 'netstat -na'                           ],
 [ $^X,                    'perl -e "print STDERR Hello;sleep 15"' ],
 [ "$SysDir\\cmd.exe",     'cmd /c DIR'                            ],
);

for my $cmd (@cmds) {
  run_for($cmd, 10);
}