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 reference" }
	$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_name 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 processes 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) workaround
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 help.
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 example, '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 may 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 (prevents multiple processes co-existing.  Really need to check the logic of the synchronisation instead though.)

=cut