File Coverage

blib/lib/Apache/Cache.pm

Criterion	Covered	Total	%
statement	10	12	83.3
branch			n/a
condition			n/a
subroutine	4	4	100.0
pod			n/a
total	14	16	87.5

package Apache::Cache;
#$Id: Cache.pm,v 1.24 2001/09/27 12:56:27 rs Exp $

=pod

=head1 NAME

Apache::Cache - Cache data accessible between Apache childrens

=head1 SYNOPSIS

    use Apache::Cache qw(:status);

    my $cache = new Apache::Cache(default_expires_in=>"5 minutes");

    # if the if the next line is called within 10 minutes, then this
    # will return the cache value overwise, this will return undef and the
    # status method will be equal to the constant EXPIRED (exported by Apache::Cache
    # on demande via the :status tag)

    # the next line try to get the data from the cache, if the data is stored in
    # in the cache and if it not expired, then this return the data. Otherwise
    # if data have never been store in the cache, or if it's expired, this will
    # return undef and the status() method will be equal to constant EXPIRED (exported
    # by Apache::Cache on demand, via the :status tag)

    my $value = $cache->get('Key');

    if($cache->status eq EXPIRED)
    {
        # can't get the data from the cache, we will need to get it by the normal way
        # (via database, from file...)
        $value = get_my_data('Key'); # here, the get_my_data() function is a function of your
                                     # programe that generate a fresh value

        # this data have to expires in 30 secondes
        my $expires_in = '30 secondes';
        $cache->set(Key => $value, $expires_in);
    }
    elsif($cache->status eq FAILURE)
    {
        # don't use cache, cache maybe busy by another child or something goes wrong
        $value = get_my_data('Key');
    }

=head1 DESCRIPTION

This module allows you to cache data easily through shared memory. Whithin the framework
of an apache/mod_perl use, this cache is accessible from any child process. The data
validity is managed in the Cache::Cache model, but as well based on time than on size
or number of keys.

Additionnally, you can implement a cache with Apache::Cache in your module without the risk
of namespace clash because Apache::Cache is enclosed in the constructor's package's caller
(see L for more details).

=head1 USAGE

For mod_perl users:

in your httpd.conf, put this directive:

    PerlAddVar PROJECT_DOCUMENT_ROOT /path/to/your/project/root/

and in your startup.pl:

    use Apache::Cache ();

See L for more details.

=cut

BEGIN
{
    use strict;
    use 5.005;
    use Carp;
    use Apache::SharedMem qw(:all);
    use Time::ParseDate;

    use base qw(Apache::SharedMem Exporter);

    %Apache::Cache::EXPORT_TAGS =
    (
        all       => [qw(EXPIRED SUCCESS FAILURE EXPIRES_NOW EXPIRES_NEVER LOCK_EX LOCK_SH LOCK_UN LOCK_NB)],
        expires   => [qw(EXPIRES_NOW EXPIRES_NEVER)],
        status    => [qw(SUCCESS FAILURE EXPIRED)],
        lock      => [qw(LOCK_EX LOCK_SH LOCK_UN LOCK_NB)],
    );
    @Apache::Cache::EXPORT_OK   = @{$Apache::Cache::EXPORT_TAGS{'all'}};

    # SUCCESS => 1
    # FAILURE => 2
    use constant EXPIRED        => 4;

    use constant EXPIRES_NOW    => 1;
    use constant EXPIRES_NEVER  => 0;

    $Apache::Cache::VERSION     = '0.05';
}

=pod

=head1 METHODS

=head2 new  (cachename=> 'cachename', default_expires_in=> '1 second', max_keys=> 50, max_size=> 1_000)

Constuct a new Apache::Cache's instance.

=over 4

=item *

C optional, date

The default data expiration time for objects place in the cache. Integers is interpreted in seconds, constant
EXPIRES_NOW make data expire imédiately and constant EXPIRES_NEVER make the data never expire. The
timeout can also be in a human readable format, see L for this format specification.

Defaults to constant EXPIRES_NEVER if not explicitly set.

=item *

C optional, integer

If you set more than C keys, olders are automatically removed. Usefull to control the cache's grow.
NOTE: if you know the exact length of your keys, use this option to control the cache size instead of the
C option.

Defaults to no max_keys

=item *

C optional, integer

no yet implemented

=item *

C optional, string

The namespace associated with this cache.

Defaults to "Default" if not explicitly set.

=item *

C optional, integer

Number of second(s) to wait for locks used each time manipulating data in the shared memory.

Defaults to not waiting. This means a get() - for expample - on a temporary locked
key - certainely by another process - will return a FAILED status.

=back

Additionnaly, all Apache::SharedMem parameters are also customizable. See L.

=cut

sub new
{
    my $pkg     = shift;
    my $class   = ref($pkg) || $pkg;

    my $options =
    {
        namespace           => (caller())[0],
        cachename           => 'Default',
        default_expires_in  => EXPIRES_NEVER,
        max_keys            => undef(),
        max_size            => undef(),
        default_lock_timeout=> undef(),
    };

    croak("odd number of arguments for object construction")
      if(@_ % 2);
    my @del;
    for(my $x = 0; $x < $#_; $x += 2)
    {
        if(exists($options->{lc($_[$x])}))
        {
            $options->{lc($_[$x])} = $_[($x + 1)];
            # We split off this parameter from the main argument list.
            # Remaining arguments will be send to Apache::SharedMem
            splice(@_, $x, 2);
            $x -= 2;
        }
    }

    foreach my $name (qw(cachename namespace))
    {
        croak("$pkg object creation missing $name parameter.")
          unless(defined($options->{$name}) && $options->{$name} ne '');
    }

    my $self = $class->SUPER::new(@_, namespace=>$options->{namespace});
    return(undef()) unless(defined($self));
    $self->{cache_options} = $options;

    unless($self->SUPER::exists($options->{cachename}, $self->_lock_timeout))
    {
        return(undef()) if($self->SUPER::status eq FAILURE);
        $self->_init_cache || return undef;
    }

    bless($self, $class);
    return($self);
}

=pod

=head2 set (identifier => data, [timeout])

    $cache->set(mykey=>'the data to cache', '15 minutes');
    if($cache->status & FAILURE)
    {
        warn("can't save data to cache: $cache->error");
    }

Store an item in the cache.

=over 4

=item *

C required, string

A string uniquely identifying the data.

=item *

C required, scalar or reference to any perl data type, except CODE and GLOB

The data to store in the cache.

=item *

C optional, date

The data expiration time for objects place in the cache. Integers is interpreted in seconds, constant
EXPIRES_NOW make data expire imédiately and constant EXPIRES_NEVER make the data never expire. The
timeout can also be in a human readable format, see L for this format specification.

=back

On failure this method return C and set status to FAILURE, see status() method below

status : FAILURE SUCCESS

=cut

sub set
{
    my $self         = shift;
    my $key          = defined($_[0]) && $_[0] ne '' ? shift : croak(defined($_[0]) ? 'Not enough arguments for set method' : 'Invalid argument "" for set method');
    my $value        = defined($_[0]) ? shift : croak('Not enough arguments for set method');
    my $time         = defined($_[0]) ? shift : $self->{cache_options}->{default_expires_in};
    my $lock_timeout = $self->{cache_options}->{default_lock_timeout};
    croak('Too many arguments for set method') if(@_);
    $self->_unset_error;
    $self->_debug;

    if($key eq '_cache_metadata')
    {
        $self->_set_status(FAILURE);
        $self->_set_error("$key: reserved key");
        return(undef());
    }

    my $timeout;
    if($time)
    {
        if($time =~ m/\D/)
        {
            $timeout = parsedate($time, TIMEFIRST=>1, PREFER_FUTURE=>1);
            unless(defined $timeout)
            {
                $self->_set_error("error on timeout string decoding. time string requested: $time");
                $self->_set_status(FAILURE);
                return(undef());
            }
        }
        elsif($time eq EXPIRES_NOW)
        {
            $timeout = EXPIRES_NOW;
        }
        else
        {
            $timeout = time() + $time;
        }
    }
    else
    {
        $timeout = EXPIRES_NEVER;
    }

    $self->_debug('timeout is set for expires in ', ($timeout - time()), ' seconds');

    if(defined $lock_timeout ? $self->lock(LOCK_EX, $lock_timeout) : $self->lock(LOCK_EX|LOCK_NB))
    {
        my $data = $self->_get_datas || return(undef());
        $data->{$key} = $value;
        $data->{'_cache_metadata'}->{'timestamps'}->{$key} = $timeout;
        push(@{$data->{'_cache_metadata'}->{'queue'}}, $key);

        $self->_check_keys($data);
        $self->_check_size($data);

        $self->SUPER::set($self->{cache_options}->{cachename}=>$data, NOWAIT);
        my $rv = $self->status; # saving returned status
        $self->unlock; # don't wait for Apache::SharedMem to auto unlock on destroy
        return(undef()) if($rv eq FAILURE);

        return($value);
    }
    else
    {
        $self->_set_error('can\'t get exclusive lock for "set" method');
        $self->_set_status(FAILURE);
        return(undef());
    }
}

=pod

=head2 get (identifier)

    my $value = $cache->get('Key');

    if($cache->status & (EXPIRED | FAILURE)) # if status is EXPIRED or FAILURE
    {
        $value = 'fresh value';
    }

Fetch the data specified. If data where never set, or if data have expired, this method return
C and status is set to EXPIRED.

=over 4

=item *

C required, string

A string uniquely identifying the data.

=back

status : FAILURE SUCCESS EXPIRED

=cut

sub get
{
    if(@_ != 2)
    {
        confess('Apache::Cache: Too many arguments for "get" method') if(@_ > 2);
        confess('Apache::Cache: Not enough arguments for "get" method') if(@_ < 2);
    }
    my($self, $key) = @_;

    my $data    = $self->_get_datas || return(undef());
    unless(exists $data->{$key})
    {
        $self->_set_status(EXPIRED);
        return(undef());
    }
    my $value   = $data->{$key};
    my $timeout = $data->{_cache_metadata}->{timestamps}->{$key};

    if(!defined $timeout || $timeout == EXPIRES_NOW || ($timeout != EXPIRES_NEVER && $timeout <= time()))
    {
        $self->_set_error("data was expired");
        $self->delete($key); # if delete failed, error string will be its own but not status
        $self->_set_status(EXPIRED);
        return(undef());
    }
    else
    {
        $self->_set_status(SUCCESS);
        return($value);
    }
}

=pod

=head2 delete (identifier)

Delete the data associated with the identifier from the cache.

=over 4

=item *

C required, string

A string uniquely identifying the data.

=back

status: SUCCESS FAILURE

=cut

sub delete
{
    if(@_ != 2)
    {
        confess('Apache::Cache: Too many arguments for "delete" method') if(@_ > 2);
        confess('Apache::Cache: Not enough arguments for "delete" method') if(@_ < 2);
    }
    my($self, $key)  = @_;
    my $lock_timeout = $self->{cache_options}->{default_lock_timeout};

    my $rv = undef;
    if(defined $lock_timeout ? $self->lock(LOCK_EX, $lock_timeout) : $self->lock(LOCK_EX|LOCK_NB))
    {
        my $data = $self->_get_datas || return(undef());
        if(exists $data->{$key})
        {
            $rv = delete($data->{$key});
            delete($data->{_cache_metadata}->{timestamps}->{$key});
            $data->{_cache_metadata}->{queue} = \@{grep($_ ne $key, @{$data->{_cache_metadata}->{queue}})};
            $self->SUPER::set($self->{cache_options}->{cachename}=>$data);
            return(undef()) if($self->status & FAILURE);
        }
        $self->unlock;
    }
    return($rv);
}

=head2 clear

Remove all objects from the namespace associated with this cache instance.

status: SUCCESS FAILURE

=cut

sub clear
{
    my $self = shift;
    $self->_init_cache;
}

# inherited from Apache::SharedMem

=head2 status

Return the last called method status. This status should be used with bitmask operators
&, ^, ~ and | like this :

    # is last method failed ?
    if($object->status & FAILURE) {something to do on failure}

    # is last method don't succed ?
    if($object->status ^ SUCCESS) {something to do on failure}

    # is last method failed or expired ?
    if($object->status & (FAILURE | EXPIRED)) {something to do on expired or failure}

It's not recommended to use equality operator (== and !=) or (eq and ne), they may don't
work in future versions.

To import status' constants, you have to use the :status import tag, like below :

    use Apache::Cache qw(:status);

=cut


sub _check_keys
{
    my($self, $data) = @_;

    my $max_keys = $self->{cache_options}->{max_keys};
    return() unless(defined $max_keys && $max_keys);
    my $metadata = $data->{_cache_metadata};
    my $nkeys    = @{$metadata->{queue}};
    $self->_debug("cache have now $nkeys keys");
    if($nkeys > $max_keys)
    {
        my $time = time();
        my $nkeys_target = int($max_keys - ($max_keys/10));
        $self->_debug("cache is full, max_key: $max_keys, current key counts: $nkeys, cleaning ", $nkeys - $nkeys_target, " keys");
        # cheching for expired datas
        for(my $i = $nkeys - 1; $i >= 0; $i--)
        {
            if($metadata->{timestamps}->{$metadata->{queue}->[$i]} > $time)
            {
                my $key = $metadata->{queue}->[$i];
                $self->_debug("$key is out of date, discarding");
                delete($data->{$key});
                delete($metadata->{timestamps}->{$key});
                @{$metadata->{queue}} = grep($_ ne $key, @{$metadata->{queue}});
                last if(--$nkeys <= $nkeys_target);
            }
        }
        if($nkeys > $nkeys_target)
        {
            # splice of delete candidates
            my @key2del = splice(@{$metadata->{queue}}, 0, ($nkeys - $nkeys_target - 1));
            $self->_debug('cleaning not timed out keys: ', join(', ', @key2del));
            delete(@$data{@key2del});
            delete(@{$metadata->{timestamps}}{@key2del});
        }
    }
}

sub _check_size
{
    my($self, $data) = @_;

    my $max_size = $self->{cache_options}->{max_keys};
    return() unless(defined $max_size && $max_size);
}

sub _init_cache
{
    my $self = shift;
    my $cache_registry =
    {
        _cache_metadata =>
        {
            timestamps  => {},
            queue       => [],
        }
    };
    $self->SUPER::set($self->{cache_options}->{cachename}=>$cache_registry, $self->_lock_timeout);

    return($self->SUPER::status eq FAILURE ? undef : 1);
}

sub _lock_timeout
{
    my $self         = shift;
    my $lock_timeout = $self->{cache_options}->{default_lock_timeout};
    return(defined $lock_timeout ? $lock_timeout : NOWAIT);
}

sub _get_datas
{
    my $self = shift;

    my $data = $self->SUPER::get($self->{cache_options}->{cachename}, $self->_lock_timeout);
    if($self->status eq FAILURE)
    {
        $self->_set_error("can't get the cacheroot: ", $self->error);
        return(undef());
    }

    croak("Apache::Cache: wrong data format.")
      if(ref($data) ne 'HASH' || ! exists $data->{_cache_metadata});

    return($data);
}

1;

=pod

=head1 EXPORTS

=head2 Default exports

None.

=head2 Available exports

Following constant is available for exports : EXPIRED SUCCESS FAILURE
EXPIRES_NOW EXPIRES_NEVER LOCK_EX LOCK_SH LOCK_UN.

=head2 Export tags defined

The tag ":all" will get all of the above exports.
Following tags are also available :

=over 4

=item

:status

Contents: SUCCESS FAILURE EXPIRED

This tag is really recommended to the importation all the time.

=item

:expires

Contents: EXPIRES_NOW EXPIRES_NEVER

=item

:lock

Contents: LOCK_EX LOCK_SH LOCK_UN LOCK_NB

=back

=head1 KNOW BUGS

Under mod_perl, with eavy load, this error may occured some time:

    Apache::SharedMem object initialization: Unable to initialize root ipc shared memory
    segment: File exists at /usr/local/lib/perl5/site_perl/5.005/Apache/SharedMem.pm line 929

We not really understand the probleme source, so any help will be appreciated. For fixing
this problem when it occured, you should stop apache, clean the ipc segment and restart
apache.

=head1 AUTHOR

Olivier Poitrey [e-mail]

=head1 LICENCE

This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or (at
your option) any later version.

This program is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
General Public License for more details.

You should have received a copy of the GNU General Public License
along with the program; if not, write to the Free Software
Foundation, Inc. :

59 Temple Place, Suite 330, Boston, MA 02111-1307

=head1 COPYRIGHT

Copyright (C) 2001 - Olivier Poitrey

=head1 PREREQUISITES

Apache::Cache needs Apache::SharedMem available from the CPAN.

=head1 SEE ALSO

L

=head1 HISTORY

$Log: Cache.pm,v $
Revision 1.24  2001/09/27 12:56:27  rs
documentation upgrade

Revision 1.23  2001/09/24 08:18:20  rs
status now return bitmask values

Revision 1.22  2001/09/21 16:24:13  rs
new method clear
new private methods _init_cache and _lock_timeout
new constructor parameter 'default_lock_timeout'

Revision 1.21  2001/09/21 12:42:53  rs
adding pod section KNOW BUGS

Revision 1.20  2001/09/20 12:40:18  rs
Documentation update: add an EXPORTS section

Revision 1.19  2001/09/19 16:22:38  rs
fixe a pod bug

Revision 1.18  2001/09/19 15:34:17  rs
major doc update (METHOD section)

Revision 1.17  2001/09/19 13:37:43  rs
0.04 => 0.05

Revision 1.16  2001/09/19 13:37:09  rs
- constructor have now a default value for "cachename", and the 'cachename'
parameter is now optional

- Documentation upgrade (SINOPSYS simplified)

Revision 1.15  2001/08/29 07:45:32  rs
add mod_perl specifique documentation

Revision 1.14  2001/08/28 13:22:46  rs
major bugfix: _check_keys method wasn't clean keys correctly

Revision 1.13  2001/08/28 08:42:38  rs
set method wasn't unlock on exit !

Revision 1.12  2001/08/17 13:26:36  rs
some minor pod modifications

Revision 1.11  2001/08/17 13:20:45  rs
- fix major bug in "get" method: on first timeout, status was set to
  "delete" method's status (often SUCCESS) instead of EXPIRED
- add some sections to pod documentation