File Coverage

blib/lib/Data/Model/Driver/Cache.pm

Criterion	Covered	Total	%
statement	134	149	89.9
branch	37	52	71.1
condition	11	20	55.0
subroutine	24	29	82.7
pod	0	22	0.0
total	206	272	75.7

package Data::Model::Driver::Cache;
use strict;
use warnings;
use base 'Data::Model::Driver';

use Carp ();
$Carp::Internal{(__PACKAGE__)}++;

use Storable ();

sub fallback { shift->{fallback} }
sub cache    { shift->{cache} }

sub _as_sql_hook {
    my $self = shift;
    $self->{fallback}->_as_sql_hook(@_);
}

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 get_multi_from_cache {
    my($self, $keys) = @_;

    my %got;
    while (my($key, $id) = each %{ $keys }) {
        my $obj = $self->get_from_cache($id->[1]) or next;
        $got{$key} = $obj;
    }
    \%got;
}

sub remove_multi_from_cache {
    my($self, $keys) = @_;
    $self->remove_from_cache($_) for @{ $keys };
}

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

# lookupは真面目にキャッシュする
sub lookup {
    my $self = shift;
    return $self->{fallback}->lookup(@_) if $self->{active_transaction};
    my($schema, $id) = @_;

    my $cache_key = $self->cache_key($schema, $id);
    my $ret = $self->get_from_cache($cache_key);
    unless ($ret) {
        $ret = $self->{fallback}->lookup(@_);
        return unless defined $ret;
        $self->add_to_cache($cache_key, $ret);
    }
    return $ret;
}

# 先に get_multi でキャッシュデータを全部取ってきて、キャッシュから取って来れなければfallbackして取得
sub lookup_multi {
    my $self = shift;
    return $self->{fallback}->lookup_multi(@_) if $self->{active_transaction};
    my($schema, $ids) = @_;

    my %cache_keys = map { join("\0", @{ $_ }) => [ $_, $self->cache_key($schema, $_) ] } @{ $ids };
    my $results = $self->get_multi_from_cache(\%cache_keys);
    if (scalar(keys %cache_keys) == scalar(keys %{ $results })) {
        return $results;
    }

    # make lookup id list
    my @lookup_keys;
    while (my($key, $id) = each %cache_keys) {
        next if $results->{$key};
        push @lookup_keys, $id->[0];
    }

    my $fallback_results = $self->{fallback}->lookup_multi($schema, \@lookup_keys);
    return unless scalar(%{ $results }) || scalar(%{ $fallback_results });
    return $results unless scalar(%{ $fallback_results });

    while (my($key, $val) = each %{ $fallback_results }) {
        $self->add_to_cache($cache_keys{$key}->[1], $val) if defined $val;
        $results->{$key} = $val;
    }

    $results;
}

# key 指定の検索でないならキャッシュ処理しない (未実装)
sub get {
    my $self = shift;
    return $self->{fallback}->get(@_) if $self->{active_transaction};
    return $self->{fallback}->get(@_);
    my($schema, $key, $columns, %args) = @_;

    return $self->{fallback}->get(@_) unless $key && !$columns;

    my $cache_key = $self->cache_key($schema, $key);
    my $ret = $self->get_from_cache($cache_key);
    return $self->{fallback}->get(@_) unless $ret;
    return $ret;
}

# insertはキャッシュ処理を通さない
sub set { shift->{fallback}->set(@_) }

# key で cache を delete するのみ
sub replace {
    my $self = shift;
    my($schema, $key, $columns, %args) = @_;

    if (scalar(@{ $key }) == scalar(@{ $schema->key })) {
        my $cache_key = $self->cache_key($schema, $key);
        $self->remove_cache($cache_key);
    }
    $self->{fallback}->replace(@_);
}


# delete / update は key を指定した処理を主なターゲットとして
# udate_all / delete_all 的なのとかのkeyが判らない物は、いったんその条件でgetしてから、個別のobjectを処理する
# なので、直接keyを指定しないと、ここの処理のパフォーマンスはキャッシュ無しのがさらに早くなる
sub update {
    my $self = shift;
    my($schema, $old_key, $key, $old_columns, $columns, $changed_columns, %args) = @_;

    if (scalar(@{ $old_key }) == scalar(@{ $schema->key })) {
        my $cache_key = $self->cache_key($schema, $old_key);
        $self->remove_cache($cache_key);
    }

   $self->{fallback}->update(@_);
}

sub _delete_cache {
    my($self, $schema, $key, $columns, %args) = @_;

    my($it, $it_opt) = $self->{fallback}->get($schema, $key, $columns ? Storable::dclone($columns) : $columns, %args);
    if ($it) {
        while (my $row = $it->()) {
            my $key = $schema->get_key_array_by_hash($row);
            my $cache_key = $self->cache_key($schema, $key);
            $self->remove_cache($cache_key);
        }
        $it_opt->{end}->() if exists $it_opt->{end} && ref($it_opt->{end}) eq 'CODE';
    }
    return 1;
}

sub update_direct {
    my $self = shift;
    my($schema, $key, $query, $columns, %args) = @_;

    if ($key && !$columns && scalar(@{ $key }) == scalar(@{ $schema->key })) {
        my $cache_key = $self->cache_key($schema, $key);
        $self->remove_cache($cache_key);
    } else {
        return unless $self->_delete_cache($schema, $key, $query, %args);
    }
    $self->{fallback}->update_direct(@_);
}

sub delete {
    my $self = shift;
    my($schema, $key, $columns, %args) = @_;

    if ($key && !$columns && scalar(@{ $key }) == scalar(@{ $schema->key })) {
        my $cache_key = $self->cache_key($schema, $key);
        $self->remove_cache($cache_key);
    } else {
        return unless $self->_delete_cache(@_);
    }
    $self->{fallback}->delete($schema, $key, $columns, %args);
}


sub remove_cache {
    my($self, $cache_key) = @_;
    if ($self->{active_transaction}) {
        push @{ $self->{transaction_delete_queue} }, $cache_key;
    } else {
        $self->remove_from_cache($cache_key);
    }
}

# for transactions
sub txn_begin {
    my $self = shift;
    $self->{active_transaction} = 1;
    $self->{transaction_delete_queue} = [];
    $self->{fallback}->txn_begin;
}

sub txn_rollback {
    my $self = shift;
    return unless $self->{active_transaction};
    $self->{fallback}->txn_rollback;

    $self->{transaction_delete_queue} = [];
}

sub txn_commit {
    my $self = shift;
    return unless $self->{active_transaction};
    $self->{fallback}->txn_commit;

    # apply delete queue
    $self->remove_multi_from_cache($self->{transaction_delete_queue});

    $self->{transaction_delete_queue} = [];
}

sub txn_end {
    my $self = shift;
    $self->{fallback}->txn_end;
    $self->{active_transaction} = 0;
    $self->{transaction_delete_queue} = [];
}

1;