view release on metacpan or  search on metacpan

lib/DBIx/MoCo.pm  view on Meta::CPAN

sub cache {
    my $class = shift;
    $class = ref($class) if ref($class);

    ## It is no matter costs of creating Dummy objects because it is a singleton.
    my $cache = $class->cache_object || DBIx::MoCo::Cache::Dummy->instance;

    my ($k,$v,$ex) = @_;
    # warn "$cache in $class";
    my $s = $class->is_in_session;
    if (defined $v) {
        $ex ||= $class->default_cache_expiration;
        $ex = "+$ex" if ($ex && ref($cache) eq 'Cache::Memory');
        if ($v eq '') {
            if ($cache->can('remove')) {
                $cache->remove($k);
            }
            if ($s) {
                delete $s->{cache}->{$k} if $k;
            }
        } else {
            if ($class->cache_cols_only && ref($v) &&
                    ref($v) =~ /::/ && $v->isa($class)) {
                # remove additional elements
                my @cols = @{$v->columns};
                for (qw(changed_cols to_be_updated object_id)) {
                    push @cols, $_ if (defined $v->{$_});
                }
                my $hash = {map {$_ => $v->{$_}} @cols};
                my $o = bless $hash, $class;
                $cache->set($k,$o,$ex);
                $s->{cache}->{$k} = $o if $s;
            } else {
                $cache->set($k,$v,$ex);
                $s->{cache}->{$k} = $v if $s;
            }
        }
        # warn $cache . '->set(' . $k . ')';
        return $v;
    } elsif ($k) {
        # warn "hit session cache for $k" if ($s && $s->{cache}->{$k});
        return $s->{cache}->{$k} || $cache->get($k);
    }
}

sub flush_belongs_to {} # it's delivered from MoCo::Relation

sub flush_self_cache {
    my ($class, $self) = @_;
    if (!$self && ref $class) {
        $self = $class;
        $class = ref $self;
    }
    $self or confess '$self is not specified';

    return unless $class->cache_object;

    my $rm = $class->cache_object->can('remove') ? 'remove' : 'delete';
    for (@{$self->object_ids}) {
        # warn "flush $_";
        #weaken($class->cache($_));
        $class->cache_object->$rm($_);
    }
}

sub store_self_cache {
    my ($class, $self) = @_;
    if (!$self && ref $class) {
        $self = $class;
        $class = ref $self;
    }
    $self or confess '$self is not specified';
    # warn "store $_" for @{$self->object_ids};
    my $icache = $self->icache;
    $self->flush_icache;
    $class->cache($_, $self) for @{$self->object_ids};
    $self->icache($icache) if $icache;
}

sub icache {
    my $self = shift;
    if ($_[0]) {
        $self->{_icache} = shift;
    } else {
        my $ex = $self->icache_expiration;
        $ex > 0 or return;
        if (!$self->{_icache} ||
                ($self->{_icache}->{_created} + $ex < time())) {
            $self->{_icache} = {_created => time()};
        }
    }
    return $self->{_icache};
}

sub flush_icache {
    my $self = shift;
    $self->{_icache} or return;
    if ($_[0]) {
        # warn "flush icache $_[0] for " . $self;
        delete $self->{_icache}->{$_[0]};
    } else {
        $self->{_icache} = undef;
    }
}

sub has_many_keys_cache_name {
    my $self = shift;
    my $attr = shift or return;
    my $oid = $self->object_id or return;
    return sprintf('%s-%s_keys', $oid, $attr);
}

sub flush_has_many_keys {
    my $self = shift;
    my $attr = shift or return;
    # $self->flush($self->has_many_keys_name($attr));
    # $self->flush($self->has_many_max_offset_name($attr));
    my $key = $self->has_many_keys_cache_name($attr);
    $self->cache($key, '');
}