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