view release on metacpan or  search on metacpan

lib/Cache/SimpleDir.pm  view on Meta::CPAN

				unless ( unlink "$self->{__dir}/lock" ) {
				$ERROR = "Could not remove lock \"$self->{__dir}/lock\" because \"$!\"";
				@{$self}{qw/error error_msg/}=(14,$ERROR);
				return undef
				}
			}
			else {

				if (open __LOCK, '<', "$self->{__dir}/lock") {
				$self->{__tmp} = readline __LOCK;
				close __LOCK;

					unless (-d "/proc/$self->{__tmp}") {
					print "Removing lock file \"$self->{__dir}/lock\" of non existing process \"$self->{__tmp}\"\n" if $self->{verbose};

						unless ( unlink "$self->{__dir}/lock" ) {
						$ERROR = "Could not remove lock \"$self->{__dir}/lock\" of non existing process \"$self->{__tmp}\" because \"$!\"";
						@{$self}{qw/error error_msg/}=(15,$ERROR);
						return undef
						}							
					}
				}
				else {
				$ERROR = "Could not read lock file \"$self->{__dir}/lock\" because \"$!\"\n";
				@{$self}{qw/error error_msg/}=(16,$ERROR);
				return undef
				}
			}
		}

	unless (opendir CACHE, $self->{__dir}) {$ERROR="Could not read cache directory \"$self->{__dir}\" because \"$!\""; @{$self}{qw/error error_msg/}=(17,$ERROR); return undef}

		while (my $node = readdir CACHE) {
			if ((-d "$self->{__dir}/$node") && ($node=~/^\d+$/)) {
			$self->{__record} = $node;
			last
			}
		}

	closedir CACHE
	}
	else {

		unless ( File::Path::Tiny::mk $self->{__dir} ) {
		$ERROR = "Could not create the top cache directory \"$self->{__dir}\" because \"$!\"";
		@{$self}{qw/error error_msg/}=(18,$ERROR);
		return undef
		}
	}

bless $self, $class
}



#	Called automatically when a subroutine called functional instead of OO
sub __NOT_AN_OBJECT
{
my ($class,$method)	= shift =~/^(.*?)::(.*)/;
my $user = $ENV{USERNAME} // [getpwuid $>]->[0];
my $args = join ', ', @_;

print STDOUT<<STOP;
Hello $user,

$class\::$method method did not called as an object, change your code similar to

  use $class;
  my \$obj = $class->new( ... );
     \$obj->$method($args);

STOP
exit 20
}



#	Put new data at the cache if the previous is expired
#	This subroutine is called automatically as needed
#	On error make it return undef of 0
#	Its first called with the 2 guaranteed arguments
#
#	$_[0]  The cache directory to put your data (automatically created)
#
#   And any other arguments you passed at the    $foo->data('a', 'b', ...)
#
sub __NEW_RECORD
{
my $dir = shift;
open  FILE,'>',"$dir/example.txt" or return undef;
print FILE 'A callback example using arguments : '. join(',', @_);
close FILE
}



#	Insert to cache new data using the function $obj->{callback}
#	It is called automatically as needed
#	On success returns the record
#
sub __CACHE_DATA
{
my $obj = ((exists $_[0]) && (__PACKAGE__ eq ref $_[0])) ? shift : __NOT_AN_OBJECT([caller 0]->[3],@_);
my $time= time;

	unless (-d "$obj->{__dir}/$time") {

		if (-f "$obj->{__dir}/lock") {

			if (open __LOCK, '<', "$obj->{__dir}/lock") {
			$obj->{__tmp} = readline __LOCK;
			close __LOCK;
			$ERROR = "An other process \"$obj->{__tmp}\" is trying to get new cache data write now\n";
			@{$obj}{qw/error error_msg/}=(2000,$ERROR);
			return undef
			}
			else {
			$ERROR = "Could not read lock file \"$obj->{__dir}/lock\" because \"$!\"\n";
			@{$obj}{qw/error error_msg/}=(20,$ERROR);
			return undef