view release on metacpan or  search on metacpan

lib/Data/ObjectDriver/Driver/BaseCache.pm  view on Meta::CPAN

# $Id$

package Data::ObjectDriver::Driver::BaseCache;
use strict;
use warnings;

use base qw( Data::ObjectDriver Class::Accessor::Fast
             Class::Data::Inheritable );

use Carp ();

__PACKAGE__->mk_accessors(qw( cache fallback txn_buffer));
__PACKAGE__->mk_classdata(qw( Disabled ));

sub deflate { $_[1] }
sub inflate { $_[2] }

# subclasses must override these:
sub add_to_cache            { Carp::croak("NOT IMPLEMENTED") }
sub update_cache            { Carp::croak("NOT IMPLEMENTED") }
sub remove_from_cache       { Carp::croak("NOT IMPLEMENTED") }
sub get_from_cache          { Carp::croak("NOT IMPLEMENTED") }

sub init {
    my $driver = shift;
    $driver->SUPER::init(@_);
    my %param = @_;
    $driver->cache($param{cache})
        or Carp::croak("cache is required");
    $driver->fallback($param{fallback})
        or Carp::croak("fallback is required");
    $driver->txn_buffer([]);
    $driver;
}

sub begin_work {
    my $driver = shift;
    my $rv = $driver->fallback->begin_work(@_);
    $driver->SUPER::begin_work(@_);
    return $rv;
}

sub commit {
    my $driver = shift;
    return unless $driver->txn_active;

    my $rv = $driver->fallback->commit(@_);

    $driver->debug(sprintf("%14s", "COMMIT(" . scalar(@{$driver->txn_buffer}) . ")") . ": driver=$driver");
    while (my $cb = shift @{$driver->txn_buffer}) {
        $cb->();
    }
    $driver->SUPER::commit(@_);

    return $rv;
}

sub rollback {
    my $driver = shift;
    return unless $driver->txn_active;
    my $rv = $driver->fallback->rollback(@_);

    $driver->debug(sprintf("%14s", "ROLLBACK(" . scalar(@{$driver->txn_buffer}) . ")") . ": driver=$driver");
    $driver->txn_buffer([]);

    $driver->SUPER::rollback(@_);

    return $rv;
}

sub cache_object {
    my $driver = shift;
    my($obj) = @_;
    return $driver->fallback->cache_object($obj)
        if $driver->Disabled;
    ## If it's already cached in this layer, assume it's already cached in
    ## all layers below this, as well.
    unless (exists $obj->{__cached} && $obj->{__cached}{ref $driver}) {
        $driver->modify_cache(sub {
            $driver->add_to_cache(

lib/Data/ObjectDriver/Driver/BaseCache.pm  view on Meta::CPAN

        }
    }

    \@got;
}

## We fallback by default
sub fetch_data {
    my $driver = shift;
    my ($obj) = @_;
    return $driver->fallback->fetch_data($obj);
}

sub search {
    my $driver = shift;
    return $driver->fallback->search(@_)
        if $driver->Disabled;
    my($class, $terms, $args) = @_;

    ## If the caller has asked only for certain columns, assume that
    ## he knows what he's doing, and fall back to the backend.
    return $driver->fallback->search(@_)
        if $args->{fetchonly};

    ## Tell the fallback driver to fetch only the primary columns,
    ## then run the search using the fallback.
    local $args->{fetchonly} = $class->primary_key_tuple;
    ## Disable triggers for this load. We don't want the post_load trigger
    ## being called twice.
    local $args->{no_triggers} = 1;
    my @objs = $driver->fallback->search($class, $terms, $args);

    my $windowed = (!wantarray) && $args->{window_size};

    if ( $windowed ) {
        my @window;
        my $window_size = $args->{window_size};
        my $iter = sub {
            my $d = $driver;
            while ( (!@window) && @objs ) {
                my $objs = $driver->lookup_multi(
                    $class,
                    [ map { $_->primary_key }
                          splice( @objs, 0, $window_size ) ]
                );
                # A small possibility exists that we may fetch
                # some IDs here that no longer exist; grep these out
                @window = grep { defined $_ } @$objs if $objs;
            }
            return @window ? shift @window : undef;
        };
        return Data::ObjectDriver::Iterator->new($iter, sub { @objs = (); @window = () });
    } else {
        ## Load all of the objects using a lookup_multi, which is fast from
        ## cache.
        my $objs = $driver->lookup_multi($class, [ map { $_->primary_key } @objs ]);
        return $driver->list_or_iterator($objs);
    }
}

sub update {
    my $driver = shift;
    my($obj) = @_;
    return $driver->fallback->update($obj)
        if $driver->Disabled;
    my $ret = $driver->fallback->update(@_);
    my $key = $driver->cache_key(ref($obj), $obj->primary_key);
    $driver->modify_cache(sub {
        $driver->uncache_object($obj);
    });
    return $ret;
}

sub replace {
    my $driver = shift;
    my($obj) = @_;
    return $driver->fallback->replace($obj)
        if $driver->Disabled;

    # Collect this logic before $obj changes on the next line via 'replace'
    my $has_pk = ref $obj && $obj->has_primary_key;
    my $ret = $driver->fallback->replace($obj);
    if ($has_pk) {
        my $key = $driver->cache_key(ref($obj), $obj->primary_key);
        $driver->modify_cache(sub {
            $driver->update_cache($key, $driver->deflate($obj));
        });
    }
    return $ret;
}

sub remove {
    my $driver = shift;
    my($obj) = @_;
    return $driver->fallback->remove(@_)
        if $driver->Disabled;

    if ($_[2] && $_[2]->{nofetch}) {
        ## since direct_remove isn't an object method, it can't benefit
        ## from inheritance, we're forced to keep things a bit obfuscated here
        ## (I'd rather have a : sub direct_remove { die "unavailable" } in the driver
        Carp::croak("nofetch option isn't compatible with a cache driver");
    }
    if (ref $obj) {
        $driver->uncache_object($obj);
    }
    $driver->fallback->remove(@_);
}

sub uncache_object {
    my $driver = shift;
    my($obj) = @_;
    my $key = $driver->cache_key(ref($obj), $obj->primary_key);
    return $driver->modify_cache(sub {
        delete $obj->{__cached};
        $driver->remove_from_cache($key);
        $driver->fallback->uncache_object($obj);
    });
}

sub cache_key {