view release on metacpan or  search on metacpan

lib/CHI/Driver/SharedMem.pm  view on Meta::CPAN

	my $h = $self->_data();
	$self->_unlock();
	return(keys(%{$h->{$self->namespace()}}));
}

=head2 get_namespaces

Gets a list of the namespaces in the cache

=cut

sub get_namespaces {
	my $self = shift;

	$self->_lock(type => 'read');
	my $rc = $self->_data();
	$self->_unlock();
	# Needs to be sorted for RT89892
	my @rc = sort keys(%{$rc});
	return @rc;
}

=head2 default_discard_policy

Use an LRU algorithm to discard items when the cache can't add anything

=cut

sub default_discard_policy { 'lru' }

=head2 discard_policy_lru

When the Shared memory area is getting close to full, discard the least recently used objects

=cut

sub discard_policy_lru {
	my $self = shift;

	if($ENV{'AUTHOR_TESTING'} && $self->{'is_size_aware'} && (my $timeout = $self->discard_timeout())) {
		# Workaround for test_discard_timeout
		# my $sleep_time = $timeout + 1;
		# open(my $tulip, '>>', '/tmp/tulip');
		# print $tulip "sleeping $sleep_time\n";
		# close $tulip;
		# sleep($sleep_time);
		sleep(1);
	}
	$self->_lock(type => 'read');
	my $last_used_time = $self->_data()->{CHI_Meta_Namespace()}->{last_used_time};
	$self->_unlock();
	my @keys_in_lru_order =
		sort { $last_used_time->{$a} <=> $last_used_time->{$b} } $self->get_keys();
	return sub {
		shift(@keys_in_lru_order);
	};
}

# Internal routines

# The area must be locked by the caller
sub _build_shm {
	my $self = shift;
	my $shm_size = $self->shm_size();

	if((!defined($shm_size)) || ($shm_size == 0)) {
		# Probably some strange condition in cleanup
		# croak 'Size == 0';
		return;
	}
	my $shm = IPC::SharedMem->new($self->shm_key(), $shm_size, S_IRUSR|S_IWUSR);
	unless($shm) {
		$shm = IPC::SharedMem->new($self->shm_key(), $shm_size, S_IRUSR|S_IWUSR|IPC_CREAT);
		unless($shm) {
			croak "Couldn't create a shared memory area of $shm_size bytes with key ",
				$self->shm_key(), ": $!";
			return;
		}
		$shm->write(pack('I', 0), 0, $Config{intsize});
	}
	$shm->attach();
	return $shm;
}

sub _build_lock {
	my $self = shift;

	# open(my $fd, '<', $0) || croak("$0: $!");
	# FIXME: make it unique for each object, not a singleton
	$self->lock_file('/tmp/' . __PACKAGE__);
	# open(my $tulip, '>>', '/tmp/tulip');
	# print $tulip "build_lock\n", $self->lock_file(), "\n";
	open(my $fd, '>', $self->lock_file()) || croak($self->lock_file(), ": $!");
	# close $tulip;
	return $fd;
}

sub _lock {
	my ($self, %params) = @_;

	# open(my $tulip, '>>', '/tmp/tulip');
	# print $tulip $params{'type'}, ' lock ', $self->lock_file(), "\n";
	# my $i = 0;
	# while((my @call_details = (caller($i++)))) {
		# print $tulip "\t", $call_details[1], ':', $call_details[2], ' in function ', $call_details[3], "\n";
	# }
	return unless $self->lock_file();

	if(my $lock = $self->lock_fd()) {
		# print $tulip "locking\n";
		flock($lock, ($params{type} eq 'read') ? Fcntl::LOCK_SH : Fcntl::LOCK_EX);
	} else {
		# print $tulip 'lost lock ', $self->lock_file(), "\n";
		croak('Lost lock: ', $self->lock_file());
	}
	# print $tulip "locked\n";
	# close $tulip;
}

sub _unlock {
	my $self = shift;

	# open(my $tulip, '>>', '/tmp/tulip');
	# print $tulip 'unlock ', $self->lock_file(), "\n";
	# my $i = 0;
	# while((my @call_details = (caller($i++)))) {
		# print $tulip "\t", $call_details[1], ':', $call_details[2], ' in function ', $call_details[3], "\n";
	# }
	if(my $lock = $self->lock_fd()) {
		flock($lock, Fcntl::LOCK_UN);
	} else {
		# print $tulip 'lost lock for unlock ', $self->lock_file(), "\n";
		croak('Lost lock for unlock: ', $self->lock_file());
	}
	# close $tulip;
}

# The area must be locked by the caller
sub _data_size {
	my($self, $value) = @_;

	if(!$self->shm()) {
		croak __PACKAGE__, ': panic: _data_size has lost the shared memory segment';
		return 0;
	}
	if(defined($value)) {
		$self->shm()->write(pack('I', $value), 0, $Config{intsize});
		return $value;
	}
	my $size = $self->shm()->read(0, $Config{intsize});
	unless(defined($size)) {
		return 0;
	}
	return unpack('I', $size);
}

# The area must be locked by the caller
sub _data {
	my($self, $h) = @_;

	# open(my $tulip, '>>', '/tmp/tulip');
	# print $tulip __LINE__, "\n";
	if(defined($h)) {
		my $f = JSON::MaybeXS->new()->ascii(1)->encode($h);
		my $cur_size = length($f);
		# print $tulip __LINE__, " cmp $cur_size > ", $self->shm_size(), "\n";
		if($cur_size > ($self->shm_size() - $Config{intsize})) {
			$self->_unlock();
			croak("Sharedmem set failed - value too large? ($cur_size bytes) > ", $self->shm_size());
		}
		if($f !~ /\}$/) {
			$self->_unlock();
			croak("Encoding failed. ($cur_size bytes: $f) ");
		}
		$self->shm()->write($f, $Config{intsize}, $cur_size);
		$self->_data_size($cur_size);
		# print $tulip "set: $cur_size bytes\n";
		# close $tulip;
		return $h;
	}
	my $cur_size = $self->_data_size();
	# print $tulip "get: $cur_size bytes\n";
	if($cur_size) {
		my $rc;
		eval {
			$rc = JSON::MaybeXS->new()->ascii(1)->decode($self->shm()->read($Config{intsize}, $cur_size));
		};
		if($@) {
			$self->_lock(type => 'write');
			$self->_data_size(0);
			my $foo = $self->shm()->read($Config{intsize}, $cur_size);
			# print $tulip "\tDecode fail $cur_size bytes $@\n\t$foo\n";
			# my $i = 0;
			# while((my @call_details = (caller($i++)))) {
				# print $tulip "\t", $call_details[1], ':', $call_details[2], ' in function ', $call_details[3], "\n";
			# }
			croak($@);
			$self->_unlock();
		}
		return $rc;
		# return JSON::MaybeXS->new()->ascii(1)->decode($self->shm()->read($Config{intsize}, $cur_size));
	}
	# close $tulip;
	return {};
}

=head2 BUILD

Constructor - validate arguments

=cut

sub BUILD {
	my $self = shift;

	unless($self->shm_key()) {
		croak 'CHI::Driver::SharedMem - no shm_key given';