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);
}
-
Are you posting in the right place? Check out Where do I post X? to know for sure.
-
Posts may use any of the Perl Monks Approved HTML tags. Currently these include the following:
<code> <a> <b> <big>
<blockquote> <br /> <dd>
<dl> <dt> <em> <font>
<h1> <h2> <h3> <h4>
<h5> <h6> <hr /> <i>
<li> <nbsp> <ol> <p>
<small> <strike> <strong>
<sub> <sup> <table>
<td> <th> <tr> <tt>
<u> <ul>
-
Snippets of code should be wrapped in
<code> tags not
<pre> tags. In fact, <pre>
tags should generally be avoided. If they must
be used, extreme care should be
taken to ensure that their contents do not
have long lines (<70 chars), in order to prevent
horizontal scrolling (and possible janitor
intervention).
-
Want more info? How to link
or How to display code and escape characters
are good places to start.