package Win32::Timeout; use strict; use warnings; use Win32::Mutex; use Exporter (); our ($VERSION, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS); $VERSION = 0.03; @ISA = qw(Exporter); @EXPORT = qw(&timeout); #%EXPORT_TAGS = ( ); # eg: TAG => [ qw!name1 name2! ], sub timeout { my $time = time; my %params=@_; my ($timeout, $code, $fallback); if ($params{timeout} > 100) # correct timeout factor, due to microsleep while waiting for +Mutex { $timeout = $params{timeout}-100; } else { $timeout=100 }; if (ref ($code=$params{code}) ne "CODE") { die "Expected code refe +rence" } $fallback = $params{fallback} || undef; my ($uid) = $code=~/\((.*)\)/; my $rand = int( rand() * 16000); my $mutex_name = "${uid}_${time}_${rand}"; my $pid=fork; if ($pid) { # Parent select(undef, undef, undef, 0.10); # e.g. microsleep for just enough time for the # child to create the Mutex object. # this could probably be done better my $mutex = Win32::Mutex->open($mutex_name) or die "$mutex_nam +e not available"; if ($mutex->wait($timeout)) { $mutex->release or warn "Couldn't release $mutex_name"; undef $mutex; # select(undef, undef, undef, 0.10); # Not needed # die "PARENT: $mutex_name returned. Handing over to child + $pid"; exit; } else { # warn "PARENT: Timed out $mutex_name. Reaping child $pid. +\n"; undef $mutex; kill 'INT', $pid; if (kill 0, $pid) { die "PARENT: Woops $mutex_name my child $pid is still +there."; } # select(undef, undef, undef, 0.10); # Not needed return $fallback; } } else { # Child my $mutex = Win32::Mutex->new(1,$mutex_name) or die "Couldn't +create Mutex!"; my $result = $code->(); $mutex->release or do { warn "CHILD: Couldn't release Mutex $mutex_name"; $mutex->wait; print "$mutex\n"; $mutex->release or die; }; undef $mutex; select(undef, undef, undef, 0.001); # This microsleep appears to be necessary otherwise multiple p +rocesses spawned... return $result; } } __END__ =head1 NAME Win32::Timeout - timeout function for Windows =head1 SYNOPSIS use Win32::Timeout; my $result = timeout ( timeout =>1000, code =>\&code, fallback=>"Timed out"); =head1 DESCRIPTION As alarm() isn't implemented in Win32, this is a (probably buggy) work +around to the problem of timing out anything other than a separate process. =head1 EXPORTED FUNCTIONS =head2 C<timeout()> Takes the named parameters =item C<timeout> Time in Milliseconds =item C<code> The code reference that will be run =item C<fallback> What will be returned by the sub in the case that it times out. =head1 EXAMPLE use Win32::Timeout; my $i; for ($i=980; $i<=1020; $i+=10) { print "\tTimeout: $i\n"; print timeout ( timeout => $i, code => \&test_sub, fallback=> "Timed out after $i", ); print "\n"; } sub test_sub { sleep 1; return "That was a good sleep!"; } =head1 AUTHOR osfameron (hakim@earthling.net) Thanks to those kind folks at www.perlmonks.com for their advice and h +elp. This module may be distributed etc. under the same terms as Perl. =head1 BUGS Still very early prototype - so there will be many. 1) The timeout figure doesn't quite correspond to reality. For exampl +e, 'sleep 1' can be completed within 950 milliseconds... FIXED: modified $timeout to make this more reasonable 2) If the timeout is very near to the completion time, both threads ma +y remain open: e.g. the function will both timeout AND return! This + may be sorted with a cleverer use of the synchronisation functions. WIP. 3) Every second timeout fails sometimes. FIXED in 0.02 (needed unique UID...) 4) If the sub to timeout is a system call, timeout will kill the Perl +process, but not the system process... WIP: suggestions welcome... Also, documentation is scrappy. Will be updated as soon as I can. =head1 VERSION 0.03, 22 June 2001 =head1 HISTORY 0.01, 21 June 2001 0.02, 21 June 2001: made UID more unique... 0.03, 22 June 2001: Added another microsleep as a workaround (prevent +s multiple processes co-existing. Really need to check the logic of +the synchronisation instead though.) =cut
In reply to Win32::Timeout (for review etc.) by osfameron
| For: | Use: | ||
| & | & | ||
| < | < | ||
| > | > | ||
| [ | [ | ||
| ] | ] |