view release on metacpan or  search on metacpan

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

package DBIx::MoCo;
use strict;
use warnings;
use base qw (Class::Data::Inheritable);

use DBIx::MoCo::Relation;
use DBIx::MoCo::List;
use DBIx::MoCo::Cache;
use DBIx::MoCo::Cache::Dummy;
use DBIx::MoCo::Schema;
use DBIx::MoCo::Column;

use Carp;
use Class::Trigger;
use Tie::IxHash;
use File::Spec;
use UNIVERSAL::require;

our $VERSION = '0.18';
our $AUTOLOAD;

my $cache_status = {
    retrieve_count        => 0,
    retrieve_cache_count  => 0,
    retrieve_icache_count => 0,
    retrieve_all_count    => 0,
    has_many_count        => 0,
    has_many_cache_count  => 0,
    has_many_icache_count => 0,
    retrieved_oids        => [],
};
my ($db,$session,$schema);

__PACKAGE__->mk_classdata($_) for 
    qw(cache_object default_cache_expiration icache_expiration
       cache_null_object table cache_cols_only _db_object save_explicitly list_class);

## NOTE: INIT block does not work well under mod_perl or POE.
## Please set cache_object() explicitly if you want to use transparent caching.
# INIT {
#     unless (defined __PACKAGE__->cache_object) {
#         if (Cache::FastMmap->require) {
#             my $file = File::Spec->catfile('/tmp', __PACKAGE__);

#             File::Spec->require or die $@;
#             __PACKAGE__->cache_object(
#                 Cache::FastMmap->new(
#                     share_file     => $file,
#                     unlink_on_exit => 1,
#                     expire_time    => 600, # sec
#                 ) or die $!
#             );

#             chmod(0666, $file) or die $! if -e $file;
#         } else {
#             warn "Using DBIx::MoCo::Cache is now deprecated because of memory leak."
#                 . "Install Cache::FastMmap instead, or setup cache_object explicitly.";

#             DBIx::MoCo::Cache->require or die $@;
#             __PACKAGE__->cache_object( DBIx::MoCo::Cache->new );
#         }
#     }
# }

__PACKAGE__->default_cache_expiration(60 * 60 * 3); # 3 hours
__PACKAGE__->icache_expiration(0); # Instance cache
__PACKAGE__->cache_null_object(1);

# SESSION & CACHE CONTROLLERS
__PACKAGE__->add_trigger(after_create => sub {
    my ($class, $self) = @_;
    $self or confess '$self is not specified';
    $class->store_self_cache($self);
    $class->flush_belongs_to($self);
});
__PACKAGE__->add_trigger(before_update => sub {
    my ($class, $self) = @_;
    $self or confess '$self is not specified';
    $class->flush_self_cache($self);
});
__PACKAGE__->add_trigger(after_update => sub {
    my ($class, $self) = @_;
    $self or confess '$self is not specified';
    $class->store_self_cache($self);
});
__PACKAGE__->add_trigger(before_delete => sub {
    my ($class, $self) = @_;
    $self or confess '$self is not specified';
    $class->flush_self_cache($self);
    $class->flush_belongs_to($self);
});

sub cache_status { $cache_status }

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;
            }