view release on metacpan or  search on metacpan

lib/Forks/Super/Sync/Win32.pm  view on Meta::CPAN

package Forks::Super::Sync::Win32;
use strict;
use warnings;
use Carp;
use Time::HiRes;
use POSIX ':sys_wait_h';
use Win32::Semaphore;

our @ISA = qw(Forks::Super::Sync);
our $VERSION = '0.97';
our $NOWAIT_YIELD_DURATION = 250;
my @RELEASE_ON_EXIT = ();

# Something we have to watch out for is a process dying without
# releasing the resources that it possessed. We have three
# defences against this issue below.
#
# 1. call CORE::kill 0, ... to see if other proc is still alive
# 2. check $!{EINVAL} (Win) and $!{ESRCH} (Cyg) to see if wait call failed
# 3. release resources in a DESTROY block (and  remove  func, though that
#    probably doesn't help that much)

$Forks::Super::Config::CONFIG{'Win32::Semaphore'} = 1;

my $sem_id = 0;

sub new {
    my ($pkg, $count, @initial) = @_;
    my $self = bless {}, $pkg;
    $self->{count} = $count;
    $self->{initial} = [ @initial ];
    $self->{id} = $sem_id++;

    # initial value of 1 means that resource is available
    $self->{sem} = [ map { Win32::Semaphore->new(1,1) } 1..$count ];

    $self->{ppid} = $$;
    $self->{acquired} = [];
    $self->{invalid} = [];

    return $self;
}

sub _releaseAfterFork {
    my ($self, $childPid) = @_;

    $self->{childPid} = $childPid;
    my $label = $$ == $self->{ppid} ? 'P' : 'C';

    for my $i (0 .. $self->{count} - 1) {
	if ($self->{initial}[$i] ne $label) {
	    $self->release($i);
	} else {
	    $self->acquire($i,0);
	}
    }
    return;
}

# more robust version of Win32::Semaphore->wait.
# detects when partner process has died without releasing the semaphore
# return true if successfully waited on lock
sub _wait_on {
    my ($self, $n, $expire) = @_;
    return 1 if !$self->{sem};
    my $partner = $$ == $self->{ppid} ? $self->{childPid} : $self->{ppid};
    while (1) {
	local $! = 0;
	my $nk = CORE::kill 0, $partner;
	if (!$nk) {
	    carp "sync::_wait_on thinks $partner is gone";
	    $self->{skip_wait_on} = 1;
	    delete $self->{sem};
	    return $Forks::Super::Sync::SYNC_PARTNER_GONE;
	}

	my $z = $self->{sem} && $self->{sem}[$n]->wait($NOWAIT_YIELD_DURATION);
	if ($z) {