view release on metacpan or  search on metacpan

lib/IPC/LockTicket.pm  view on Meta::CPAN

	return(true);
	}

# Returns an array of integers which represents all registered PIDs of current lock file
sub _GetPIDs {
	my $objSelf		= shift;

	try {
		$objSelf->{_harData}	= lock_retrieve($objSelf->{_uriPath});
		}
	catch ($strError) {
		carp qq{"$objSelf->{_uriPath}": Mailformed shared memory file.\n$strError\n};
		return(undef);
		}

	return(@{$objSelf->{_harData}{arePIDs}});
	}

# Save a array of integer
sub _SetPIDs {
	my $objSelf		= shift;
	my @intPIDs		= @_;

	if ( open(my $fh, "<", $objSelf->{_uriPath}) ) {
		flock($fh, 2);

		$objSelf->{_harData}			= retrieve($objSelf->{_uriPath});

		$objSelf->{_harData}{arePIDs}	= [ @intPIDs ];

		store($objSelf->{_harData}, $objSelf->{_uriPath});

		my $strCaller	= (caller(0))[3];
		close($fh) or die qq{$strCaller(): Unable to close "$objSelf->{_uriPath}" properly\n};
		}

	return(true);
	}

# Returns boolean value
sub _MultipleAllowed {
	my $objSelf			= shift;

	try {
		$objSelf->{_harData}	= lock_retrieve($objSelf->{_uriPath});
		}
	catch ($strError) {
		carp qq{"$objSelf->{_uriPath}": Mailformed shared memory file.\n$strError\n};
		return(undef);
		}

	return($objSelf->{_harData}{bolAllowMultiple});
	}

=head3 C<MainLock>

 my $bolSuccess		= $object->MainLock();
 my $bolSuccess		= $object->MainLock(1);

Checks if a lock file exists and creates it if not. Fails if file exists and process stored within is alive.
If a C<true> value is supplied, locking is non-exclusive but shared. If the file exists and was also created non-exclusively, locking is successful. This way the lock file is shared with several processes, requesting non-exclusive mode.
If C<false> is returned from C<MainLock> no lock file was created/claimed.
Meaning:

 ____________________________________________________________________________________________________________________________________
 | Call mode        | MainLock() | MainLock() | MainLock() | MainLock()   | MainLock(1) | MainLock(1) | MainLock(1)  | MainLock(1)  |
 | Lock file        | empty*     | shared     | exclusive  | non-existent | empty*      | shared      | exclusive    | non-existent |
 | MainLock returns | false      | false      | false      | true         | false       | true        | false        | true         |
 ¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯Â...

*= empty or any other non-Storable data.

=cut

# Creates the lock file
sub MainLock {
	my $objSelf		= shift;
	my $bolMultipleAllowed	= shift;

	# If the file exists
	if ( -e $objSelf->{_uriPath}
	&& $objSelf->_Check() ) {	# Dies in _Check if failed

		# If multiple is allowed we register our PID
		if ( $bolMultipleAllowed
		&& $objSelf->_MultipleAllowed() ) {
			$objSelf->TokenLock();

			my @intPIDs	= $objSelf->_GetPIDs();

			if ( grep { $_ == $$ } @intPIDs ) {
				carp qq{WARNING: Same process tried to MainLock() again.\n};
				$objSelf->TokenUnlock();
				return(false);
				}
			else {
				$objSelf->_SetPIDs( @intPIDs, $$ );
				}

			$objSelf->TokenUnlock();
			return(true);
			}
		# Or it must be exclusive
		else {
			$objSelf->TokenLock();
			my @intPIDs	  	= $objSelf->_GetPIDs();

			local $SIG{CLD} 	= q{IGNORE};
			local $SIG{CHLD}	= q{IGNORE};

			# Did we lock up?
			if ( grep { $$ == $_ } @intPIDs ) {
				carp qq{WARNING: Same process tried to MainLock() again.\n};
				$objSelf->TokenUnlock();
				return(false);
				}
			# There are processes running on this lock file
			elsif ( grep { kill(0 => $_) } @intPIDs ) {
				$objSelf->TokenUnlock();
				return(false);

lib/IPC/LockTicket.pm  view on Meta::CPAN

		}

	return(true);
	}

=head3 C<MainUnlock>

 $object->MainUnlock();

Removes lock. The lock file is deleted if this is the last process accessing it.
Returns only a true value.

If it is a shared lock and not the last process accessing it, only the PID entries are removed from the lock file.

=cut

# Removes lock file or the PID from those
sub MainUnlock {
	my $objSelf		= shift;

	if ( ! -e $objSelf->{_uriPath} ) {
		my $strCaller	= (caller(0))[3];
		croak qq{$strCaller(): Lock file missing\nHave you ever called MainLock() ?\n};
		}

	if ( $objSelf->_MultipleAllowed() ) {
		my @intPIDs	= ();

		$objSelf->TokenLock();

		@intPIDs	= do {
			local $SIG{CLD}		= q{IGNORE};
			local $SIG{CHLD}	= q{IGNORE};

			grep { kill(0 => $_) } grep { $_ != $$ } $objSelf->_GetPIDs();
			};

		if ( @intPIDs ) {
			$objSelf->_SetPIDs(@intPIDs);
			$objSelf->TokenUnlock();
			}
		else {
			unlink($objSelf->{_uriPath});
			}

		}
	else {
		unlink($objSelf->{_uriPath});
		}

	return(true);
	}

sub _CleanAgentsList (\@) {
	my $areList		= shift;
	my %bolTestedParent	= ();

	local $SIG{CLD}		= q{IGNORE};
	local $SIG{CHLD}	= q{IGNORE};

	#			if parent was not tested yet		test if alive,			but we don't test ourself,	but any other agent
	return(grep { ( $bolTestedParent{$_->{_pidParent}}++ || kill(0 => $_->{_pidParent}) ) && ( $_->{_pidAgent} == $$ || kill(0 => $_->{_pidAgent}) ) } @{$areList});
	}

=head3 C<TokenLock>

 $object->TokenLock();

Can only be called after C<MainLock> and before C<MainUnlock> otherwise C<die>s.
Requests exclusive lock, i.e., any C<TokenLock> is blocking until C<TokenUnlock> was called, or the locking process is dead. Process checks are done to prevent infinite locks through broken children or parents, but this is not proper usage. Don't jus...
Returns a true value or blocks.

=cut

# Integrated lock system
sub TokenLock {
	my $objSelf		= shift;
	my $bolInit		= true;
	my $strCaller		= (caller(0))[3];

	if ( ! -e $objSelf->{_uriPath} ) {
		croak qq{$strCaller(): Lock file missing\nHave you ever called MainLock() ?\n};
		}

	while ( true ) {
		if ( -e $objSelf->{_uriPath}
		&& open(my $fh, "<", $objSelf->{_uriPath}) ) {
			flock($fh, 2);

			# Load current data
			$objSelf->{_harData}			= retrieve($objSelf->{_uriPath});

			@{$objSelf->{_harData}{areToken}}	= _CleanAgentsList(@{$objSelf->{_harData}{areToken}});

			# If we never got a token, we request one
			if ( $bolInit
			&& ! first { $_->{_pidAgent} == $$ } @{$objSelf->{_harData}{areToken}} ) {
				$bolInit	= false;
				push(@{$objSelf->{_harData}{areToken}}, { _pidAgent => $$, _pidParent => $objSelf->{_pidParent} });
				}
			# Die if something strange happened
			elsif ( ! -e $objSelf->{_uriPath}
			|| ( ! $bolInit
			&& ! first { $_->{_pidParent} == $objSelf->{_pidParent} } @{$objSelf->{_harData}{areToken}} ) ) {
				# Parent exited (and maybe we weren't informed to exit)
				close($fh) or die qq{$strCaller(): Unable to close "$objSelf->{_uriPath}" properly\n};
				exit(120);
				}

			store($objSelf->{_harData}, $objSelf->{_uriPath});

			close($fh) or die qq{$strCaller(): Unable to close "$objSelf->{_uriPath}" properly\n};

			# Check if it's our turn
			if ( $objSelf->{_harData}{areToken}[0]{_pidAgent} == $$ ) {
				return(true);
				}
			# Wait if it isn't our turn yet
			else {
				Time::HiRes::sleep(0.01);	# Needed to prevent permanent spamming on CPU and FS
				}