view release on metacpan or  search on metacpan

lib/Cache/AgainstFile/Storable.pm  view on Meta::CPAN

};

use vars qw($VERSION @ISA);
$VERSION = sprintf"%d.%03d", q$Revision: 1.22 $ =~ /: (\d+)\.(\d+)/;
@ISA = qw(Cache::AgainstFile::Base);

#
# Public interface
#

sub new {
	my $class = shift;
	my ($loader, $options) = @_;	
	my $self = $class->SUPER::new(@_);

	my $dir = $self->{options}->{CacheDir} || croak("You must supply a cache directory for caching with Storable");
	check_safe($dir,"w") if(HAVE_FILE_POLICY);
	_create_dir_if_required($dir);
	
	#Select locking implementation
	my $locking = $options->{Locking} || 'AtomicWrite';
	if($locking eq 'Flock') {
		$self->{write} = \&_write_locked;
		$self->{read} = \&_read_locked;
	} elsif ($locking eq 'AtomicWrite') {
		$self->{write} = \&_write_atomic;
		$self->{read} = \&_read;
	} else {
		croak("Unrecognised locking model '$locking'");	
	}

	return $self;
}

sub get
{
	my ($self, $filename, @opts) = @_;

	check_safe($filename,"r") if(HAVE_FILE_POLICY);
	
	my $cache_dir = $self->{options}{CacheDir};
	my $cache_filename = catfile($cache_dir, $self->_filename2cache($filename));
	TRACE("cache get - cache filename is '$cache_filename'");
	my $stale = 0;

	# In some (as yet undetermined) circumstances the cachefile directory
	# can disappear, which causes application errors
	_create_dir_if_required($cache_dir);

	# If cachefile doesn't exist, it won't open, implying staleness.
	my $cache_fh = new FileHandle;
	check_safe($cache_filename,"r") if(HAVE_FILE_POLICY);
	unless ($cache_fh->open($cache_filename)) {
		undef $cache_fh;
		$stale = 1;
	}	

	# Compare file mtimes to check staleness		
	my $file_mtime;
	unless ($self->{options}->{NoStat} && !$stale) {
		$file_mtime = (stat($filename))[9];
		my $cache_mtime = ($cache_fh->stat)[9] if $cache_fh;
		$stale = (!defined $file_mtime) || (!defined $cache_mtime) || ($file_mtime != $cache_mtime);
	}
	TRACE("Cache " . ($stale?"is":"is not") . " stale");

	#Read from cache
	my $data;
	if (!$stale) {
		$data = eval { $self->{read}->($cache_filename, $cache_fh) };
		if ($@) {
			warn "Storable couldn't retrieve $cache_filename: $@";
			$stale = 1;
		}
	}
	$cache_fh->close if $cache_fh;
	
	#Write to cache
	if ($stale) {
		TRACE("writing cache");
		$data = $self->{loader}->($filename, @opts);
		$file_mtime = (stat($filename))[9] unless(defined $file_mtime); #Need mtime now
		$self->{write}->($cache_filename, $data, $file_mtime);
	}
	return $data;
}


sub count {
	my ($self) = shift;
	my $files_in_cache = $self->_cache_files;
	return scalar @$files_in_cache;
}

sub size {
	my ($self) = shift;
	my $cache_dir = $self->{options}{CacheDir};
	my $files_in_cache = $self->_cache_files;
	my $sum = 0;
	foreach(@$files_in_cache) {$sum += -s catfile($cache_dir, $_)}
	return $sum;
}

#
# Protected methods referenced from Base class
# 

sub _remove {
	my($self, $keys) = @_;
	my $cache_dir = $self->{options}{CacheDir};
	foreach(@$keys)
	{
		my $filename = $self->_filename2cache($_);
		TRACE("Deleting cache for $_ ($filename)");
		unlink catfile($cache_dir, $filename);
	}
}

sub _accessed {
	my($self) = @_;
	my $cache_dir = $self->{options}{CacheDir};
	my $files_in_cache = $self->_cache_files;
	my %accessed = map
	{
		my $cache_file = catfile($cache_dir, $_);
		$self->_cache2filename($_) => (stat($cache_file))[8]
	}
	@$files_in_cache;
	return \%accessed;
}

sub _stale {
	my($self) = @_;
	my $cache_dir = $self->{options}{CacheDir};
	my $files_in_cache = $self->_cache_files;
	my @out =
	map
	{
		$self->_cache2filename($_)
	}
	grep
	{
		my $cache_file = catfile($cache_dir, $_);
		my $src_mt   = (stat ($self->_cache2filename($_)))[9];
		my $cache_mt = (stat ($cache_file))[9];
		(!defined $src_mt) || (!defined $cache_mt) || ($src_mt != $cache_mt)
	} @$files_in_cache;
	@out;
}

#
# Private methods
#

sub _cache_files {
	my($self) = @_;
	my $cache_dir = $self->{options}{CacheDir};
	local *FH;
	check_safe($cache_dir,"r") if(HAVE_FILE_POLICY);
	opendir (FH, $cache_dir) or die("unable to open directory $cache_dir - $!");
	my @files = grep {$_ !~ /^\./} readdir(FH);
	closedir FH;
	DUMP("cache files", \@files);
	return \@files;
}

#
# Subroutines
#

sub _read_locked {
	my($cache_filename, $fh) = @_;
	# we don't want the filehandle. Suppose it might need to be closed
	# under Win32? Close it anyway
	$fh->close if $fh;
	check_safe($cache_filename,"r") if(HAVE_FILE_POLICY);
	my $ref_data = lock_retrieve($cache_filename);
	TRACE("Fetched from cache file: $cache_filename");
	return $$ref_data;	
}

sub _write_locked {
	my ($cache_filename, $data, $mtime) = @_;
	check_safe($cache_filename,"w") if(HAVE_FILE_POLICY);
	lock_store(\$data, $cache_filename);
	TRACE("wrote cache file: $cache_filename");