OpenInteract::Cache - Caches objects to avoid database hits and content to avoid template processing

 # In $WEBSITE_DIR/conf/server.ini

 [cache_info data]
 default_expire = 600
 use            = 0
 use_spops      = 0
 class          = OpenInteract::Cache::File
 max_size       = 2000000

 # Use implicitly with built-in content caching

 sub listing {
     my ( $class, $p ) = @_;
     my %params = ( cache_key  => 'mypkg::myhandler::listing',
                    cache_time => 1800 );
     ...
     return $R->template->handler(
               {}, \%params, { name => 'mypkg::listing' } );
 }

 # Explicitly expire a cached item

 sub edit {
     my ( $class, $p ) = @_;
     ...
     eval { $object->save };
     if ( $@ ) {
         # set error message
     }
     else {
         $R->cache->clear({ key => 'mypkg::myhandler::listing' });
     }
 }

 cache_info->default_expire - Default expiration time for items
 cache_info->max_size       - Maximum size (in bytes) of cache
 dir->cache_content         - Root directory for content cache

package OpenInteract::Cache;

# $Id: Cache.pm,v 1.6 2003/04/07 02:55:57 lachoy Exp $

use strict;

# Returns: caching object (implementation-neutral)

sub new {
    my ( $pkg, @params ) = @_;
    my $class = ref $pkg || $pkg;
    my $self = bless( {}, $class );
    $self->{_cache_object} = $self->initialize( @params );
    return $self;
}


# Returns: data from the cache

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

    # if the cache hasn't been initialized, bail
    return undef unless ( $self->{_cache_object} );

    my $key       = $p->{key};
    my $is_object = 0;
    my $obj_class = undef;
    my $R = OpenInteract::Request->instance;
    if ( ! $key and $p->{class} and $p->{object_id} ) {
        $key = _make_spops_idx( $p->{class}, $p->{object_id} );
        $R->DEBUG && $R->scrib( 3, "Created class+id key [$key]" );
        $obj_class = $p->{class};
        $is_object++;
        return undef  unless ( $obj_class->pre_cache_get( $p->{object_id} ) );
    }
    unless ( $key ) {
        $R->DEBUG && $R->scrib( 2, "Cache MISS (no key)" );
        return undef;
    }

    my $data = $self->get_data( $self->{_cache_object}, $key );
    unless ( $data ) {
        $R->DEBUG && $R->scrib( 2, "Cache MISS [$key]" );
        return undef;
    }

    $R->DEBUG && $R->scrib( 2, "Cache HIT [$key]" );
    if ( $is_object ) {
        return undef unless ( $obj_class->post_cache_get( $data ) );
    }
    return $data;
}

sub set {
    my ( $self, $p ) = @_;

    # if the cache hasn't been initialized, bail
    return undef unless ( $self->{_cache_object} );

    my $is_object = 0;
    my $key  = $p->{key};
    my $data = $p->{data};
    my ( $obj );
    my $R = OpenInteract::Request->instance;
    if ( _is_object( $data ) ) {
        $obj = $data;
        $key = _make_spops_idx( ref $obj, scalar( $obj->id ) );
        $R->DEBUG && $R->scrib( 2, "Created class/id key [$key]" );
        $is_object++;
        return undef  unless ( $obj->pre_cache_save );
        $data = $obj->as_data_only;
    }
    $self->set_data( $self->{_cache_object}, $key, $data, $p->{expire} );
    if ( $obj and $obj->can( 'post_cache_save' ) ) {
        return undef  if ( $obj->post_cache_save );
    }
    return 1;
}

sub clear {
    my ( $self, $p ) = @_;

    # if the cache hasn't been initialized, bail
    return undef unless ( $self->{_cache_object} );

    my $key = $p->{key};
    if ( ! $key and _is_object( $p->{data} ) ) {
        $key = _make_spops_idx( ref $p->{data}, scalar( $p->{data}->id ) );
    }
    elsif ( ! $key and $p->{class} and $p->{object_id} ) {
        $key = _make_spops_idx( $p->{class}, $p->{object_id} );
    }
    my $R = OpenInteract::Request->instance;
    $R->DEBUG && $R->scrib( 2, "Trying to clear cache of [$key]" );
    return $self->clear_data( $self->{_cache_object}, $key );
}


sub purge {
    my ( $self ) = @_;

    # if the cache hasn't been initialized, bail
    return undef unless ( $self->{_cache_object} );

    my $R = OpenInteract::Request->instance;
    $R->DEBUG && $R->scrib( 2, "Trying to purge cache of all objects" );
    return $self->purge_all( $self->{_cache_object} );
}


sub _is_object {
    my ( $item ) = @_;
    my $typeof = ref $item;
    return undef if ( ! $typeof );
    return undef if ( $typeof =~ /^(HASH|ARRAY|SCALAR)$/ );
    return 1;
}

sub _make_spops_idx {
    return join '--', $_[0], $_[1];
}

########################################
# SUBCLASS TO OVERRIDE

sub initialize  { die "Subclass must define initialize()\n" }
sub get_data    { die "Subclass must define get_data()\n" }
sub set_data    { die "Subclass must define set_data()\n" }
sub clear_data  { die "Subclass must define clear_data()\n" }
sub purge_all   { die "Subclass must define purge_all()\n" }

1;

__END__