view release on metacpan or  search on metacpan

lib/Apache/XPP/Cache.pm  view on Meta::CPAN

=cut

=item new( $name, $group, \%instance_data, [ $storetype, @store_options ], [ $expiretype, @expire_options ] )

Creates a new Cache object using the specified Store and Expire types.

=cut
{# BEGIN PRIVATE CODE BLOCK
my %cache;
sub new {
#	Apache::XPP::Cache->new( 're4sidebar', 'games', { r => $r }, [ 'File', $content ], [ 'Duration', '2h' ] );
	my $proto		= shift;
	my $class		= ref($proto) || $proto;
	my $name		= shift;
	my $group		= shift;
	my $instance	= shift;
	my $self;

	my $specifier	= unpack("%32C*", $name . $group) % 65535;
	if ($cache{ $specifier }) {
		warn "cache: using cached object (in new)" . ($debuglines ? '' : "\n") if ($debug);
		$self		= $cache{ $specifier };
	} else {
		warn "cache: creating new object (in new)" . ($debuglines ? '' : "\n") if ($debug);
		my $store		= shift;
		my $expire		= shift;

		$self			= bless( { %{ ref($instance) ? $instance : {} } }, $class );

		foreach my $part ( {Store => $store}, {Expire => $expire} ) {

			my ($label, $inputs) = %{$part};
			my $type	= shift( @{ $inputs } );
			if (my $thisclass = $class->install_module( (($label eq 'Expire') ? 'Expiry' : $label), $type )) {
				my $obj	= $thisclass->new( $name, $group, { r => $self->r }, @{ $inputs } );
				if (ref($obj)) {
					my $meth = $label . 'Type';
					$self->$meth( $type );		# StoreType/ExpireType
					$meth = $label . 'Object';
					$self->$meth( $obj );		# StoreObject/ExpireObject
				} else {
					return undef;
				}
			} else {
				carp "Specified $label type ($type) is not registered as available!";
				return undef;
			}

		}

		$cache{ $specifier }	= $self;
	}
} # END constructor new
} # END private code block for %cache

=item C<install_module> ( ('Store'|'Expiry'), $name )

Installs the $name store or expiry module, and returns the associated class name.

=cut
sub install_module {			# shamelessly snagged from DBI
	my $class	= shift;
	my $type	= shift;
	my $name	= shift;
	
	$type		= 'Expiry' unless ($type eq 'Store');
	my $mod;
	
	# already installed
	return $mod if ($mod = $Apache::XPP::installed{ $type }{ $name });
	
	# --- load the code
	$mod		= "Apache::XPP::Cache::${type}::${name}";
	eval "package Apache::XPP::Cache::_firesafe; require $mod";
	if ($@) {
		warn "require of ($mod) failed! $@";
		return undef;
	}
	
	$Apache::XPP::installed{ $type }{ $name }	= $mod;
}

sub store {
	my $self	= shift;
	return undef unless ref($self);
	return $self->{ 'StoreObject' };
} # END method store

sub expire {
	my $self	= shift;
	return undef unless ref($self);
	return $self->{ 'ExpireObject' };
} # END method expire


=item C<is_expired> (  )

Returns a true value if the current cache has expired, otherwise returns false.

=cut
sub is_expired {
	my $self	= shift;
	return undef unless ref($self);
	if ($self->expire->is_expired( $self->store )) {
		$self->store->is_expired;
		return 1;
	} else {
		return 0;
	}
} # END method is_expired

=item C<content> (  )

Returns the content of the current cache.

=cut
sub content {
	my $self	= shift;
	return ref($self) ? $self->store->content : undef;
} # END method content