Rose::DBx::Object::Cached::CHI - Rose::DB::Object Cache using the CHI interface

  package Category;

  use Rose::DBx::Object::Cached::CHI;
  our @ISA = qw(Rose::DBx::Object::Cached::CHI);

  __PACKAGE__->meta->table('categories');

  __PACKAGE__->meta->columns
  (
    id          => { type => 'int', primary_key => 1 },
    name        => { type => 'varchar', length => 255 },
    description => { type => 'text' },
  );

  __PACKAGE__->meta->add_unique_key('name');

  __PACKAGE__->meta->initialize;

  ...

  ## Defaults to an in memory cache that does not expire.

  $cat1 = Category->new(id   => 123,
                        name => 'Art');

  $cat1->save or die $category->error;




  $cat2 = Category->new(id => 123);

  # This will load from the memory cache, not the database
  $cat2->load or die $cat2->error; 

  ...

  ## Set the cache driver for all Rose::DB::Object derived objects
  $Rose::DBx::Object::Cached::CHI::SETTINGS = {
    driver     => 'FastMmap',
    root_dir   => '/tmp/global_fastmmap',
  };

  $cat1 = Category->new(id   => 123,
                        name => 'Art')->save;

  ## In another script

  $Rose::DBx::Object::Cached::CHI::SETTINGS = {
    driver     => 'FastMmap',
    root_dir   => '/tmp/global_fastmmap',
  };

  # This will load from the FastMmap cache, not the database
  $cat2 = Category->new(id   => 123,
                        name => 'Art')->load;

  ...

  ## Set the cache driver for all Category derived objects
  Category->cached_objects_settings(
    driver     => 'FastMmap',
    root_dir   => '/tmp/global_fastmmap',
  );

  ...




  ## Set cache expire time for all Category objects
  Category->cached_objects_expire_in('5 seconds'); 

  ## Set cache expire time for all Rose::DB::Object derived objects
  $Rose::DBx::Object::Cached::CHI::SETTINGS = {
    driver     => 'Memory',
    expires_in    => '15 minutes',
  };

  <OR> 

  $Rose::DBx::Object::Cached::CHI::SETTINGS = {
    driver     => 'FastMmap',
    root_dir   => '/tmp/global_fastmmap',
    expires_in    => '15 minutes',
  };

  ## Any driver for CHI will work.

    package Category;
    use base Rose::DBx::Object::Cached::CHI;

    ... 

    sub default_cached_objects_settings (
        return {
            driver     => 'FastMmap',
            root_dir   => '/tmp/global_fastmmap',
            expires_in    => '15 minutes',
        };
    )

    { driver => 'Memory', global => 1 }

    Kevin C. McGrath
    CPAN ID: KMCGRATH

package Rose::DBx::Object::Cached::CHI;

use strict;

use Carp();

use CHI;
use Storable;
use Rose::DB::Object;
use Rose::DB::Object::Helpers ();
use Rose::DB::Object::Cached;

our @ISA = qw(Rose::DB::Object);

use Rose::DB::Object::Constants qw(STATE_IN_DB);

our $VERSION = '0.17';
our $SETTINGS = undef;
our $Debug = 0;
our $USE_IN_SYNC = 0;

# Use same expiration units from Rose::DB::Object::Cached;
my %Expiration_Units = %Rose::DB::Object::Cached::Expiration_Units;


# Anything that cannot be in a column name will work for these
# Changed to '&' for compatibility with Memcached
use constant PK_SEP => "&";
use constant UK_SEP => "&";
use constant LEVEL_SEP => "&";

# Try to pick a very unlikely value to stand in for undef in
# the stringified multi-column unique key value
use constant UNDEF  => "\1\2undef\2\1";


sub remember
{
  my($self) = shift;
  my $class = ref $self;
  my $meta = $self->meta;
 
  local $Storable::Deparse = 1;

  my $cache = $class->__xrdbopriv_get_cache_handle;

  my $pk = join(PK_SEP, grep { defined } map { $self->$_() } $meta->primary_key_column_accessor_names);

  my $safe_obj = $self->__xrdbopriv_clone->__xrdbopriv_strip;  ## Strip has been fixed so that all CODE REFs are gone
                                                               ## but keeping the clone here so we don't mess with the
                                                               ## object the developer is currently working with

  my $expire_in = ($self->meta->cached_objects_expire_in || $class->cached_objects_settings->{expires_in} || 'never');

  my $successful_set = $cache->set("${class}::Objects_By_Id" . LEVEL_SEP . $pk, $safe_obj,$expire_in);


  my $accessor = $meta->column_accessor_method_names_hash;

  foreach my $cols ($self->meta->unique_keys_column_names)
  {
    my $values_defined = 0;

    my $key_name  = join(UK_SEP, @$cols);
    my $key_value = join(UK_SEP, grep { defined($_) ? $_ : UNDEF }
                         map { my $m = $accessor->{$_}; my $colval = $safe_obj->$m();$values_defined++ if defined($colval);$colval } @$cols);

    next unless $values_defined;

    $cache->set("${class}::Objects_By_Key" . LEVEL_SEP . $key_name . LEVEL_SEP . $key_value, $safe_obj, $expire_in);

    $cache->set("${class}::Objects_Keys" . LEVEL_SEP . $pk . LEVEL_SEP . $key_name, $key_value, $expire_in);
     
  }

  #my $chi_cache_object = $self->{__xrdbopriv_chi_created_at} = $cache->get_object("${class}::Objects_By_Id" . LEVEL_SEP . $pk);
  if ($Rose::DBx::Object::Cached::CHI::USE_IN_SYNC && $successful_set ) {
    my $chi_cache_object = $self->{__xrdbopriv_chi_created_at} = $cache->get_object("${class}::Objects_By_Id" . LEVEL_SEP . $pk);
    $self->{__xrdbopriv_chi_created_at} = $chi_cache_object->created_at();
  } 
  
};


sub __xrdbopriv_get_object
{
  my($class) = ref $_[0] || $_[0];

  local $Storable::Eval = 1;

  my $cache = $class->__xrdbopriv_get_cache_handle;

  if(@_ == 2)
  {
    my($pk) = $_[1];

    my $rose_object = $cache->get("${class}::Objects_By_Id" . LEVEL_SEP . $pk);


    if($rose_object)
    {
      $rose_object->{__xrdbopriv_chi_created_at} = $cache->get_object("${class}::Objects_By_Id" . LEVEL_SEP . $pk)->created_at;
      return $rose_object;
    }

    return undef;
  }
  else
  {
    my($key_name, $key_value) = ($_[1], $_[2]);

    my $rose_object = $cache->get("${class}::Objects_By_Key" . LEVEL_SEP . $key_name . LEVEL_SEP . $key_value);
    if($rose_object)
    {
      $rose_object->{__xrdbopriv_chi_created_at} = $cache->get_object("${class}::Objects_By_Key" . LEVEL_SEP . $key_name . LEVEL_SEP . $key_value)->created_at;
      return $rose_object;
    }

    return undef;
  }
};


sub load
{
  # XXX: Must maintain alias to actual "self" object arg

  my %args = (self => @_); # faster than @_[1 .. $#_];

  my $class = ref $_[0];

  unless(delete $args{'refresh'})
  {
    my $pk = join(PK_SEP, grep { defined } map { $_[0]->$_() } $_[0]->meta->primary_key_column_accessor_names);

    my $object = $pk ? __xrdbopriv_get_object($class, $pk) : undef;

    if($object)
    {
      $_[0] = $object;
      $_[0]->{STATE_IN_DB()} = 1;
      return $_[0] || 1;
    }
    elsif(!(defined $object))
    {
      my $meta = $_[0]->meta;
      my $accessor = $meta->column_accessor_method_names_hash;

      foreach my $cols ($_[0]->meta->unique_keys_column_names)
      {
        my $values_defined = 0;

        no warnings;
        my $key_name  = join(UK_SEP, @$cols);
        my $key_value = join(UK_SEP, grep { defined($_) ? $_ : UNDEF }
                             map { my $m = $accessor->{$_}; my $colval = $_[0]->$m();$values_defined++ if defined($colval);$colval } @$cols);


        next unless $values_defined;

        if(my $object = __xrdbopriv_get_object($class, $key_name, $key_value))
        {
          $_[0] = $object;
          $_[0]->{STATE_IN_DB()} = 1;
          return $_[0] || 1;
        }
      }
    }
  }

  my $ret = $_[0]->SUPER::load(%args);
  $_[0]->remember  if($ret);

  return $ret;
}


sub update {
    my($self) = shift;

    my $ret = $self->SUPER::update(@_);
    return $ret  unless($ret);

    $self->remember;

    return $ret;
}

sub insert {
    my($self) = shift;

    my $ret = $self->SUPER::insert(@_);
    return $ret  unless($ret);

    $self->remember;

    return $ret;
}


sub delete
{
  my($self) = shift;
  my $ret = $self->SUPER::delete(@_);
  $self->forget  if($ret);
  return $ret;
}


sub forget
{
  my($self) = shift;
  my $class = ref $self;

  my $cache = $class->__xrdbopriv_get_cache_handle;

  my $pk = join(PK_SEP, grep { defined } map { $self->$_() } $self->meta->primary_key_column_accessor_names);

  $cache->expire("${class}::Objects_By_Id" . LEVEL_SEP . $pk);

  foreach my $cols ($self->meta->unique_keys_column_names)
  {
    my $key_name  = join(UK_SEP, @$cols);
    my $key_value = $cache->get("${class}::Objects_Keys" . LEVEL_SEP . $pk . LEVEL_SEP . $key_name) || '';
    $cache->expire("${class}::Objects_By_Key" . LEVEL_SEP . $key_name . LEVEL_SEP . $key_value);
  }

  $cache->expire("${class}::Objects_Keys" . LEVEL_SEP . $pk);

  return 1;
}


sub remember_by_primary_key
{
  my($self) = shift;
  my $class = ref $self;

  my $cache = $class->__xrdbopriv_get_cache_handle;

  my $pk = join(PK_SEP, grep { defined } map { $self->$_() } $self->meta->primary_key_column_accessor_names);

  $cache->set("${class}::Objects_By_Id" . LEVEL_SEP . $pk, $self->__xrdbopriv_clone->__xrdbopriv_strip);
}

sub remember_all
{
  my($class) = shift;

  require Rose::DB::Object::Manager;

  my(undef, %args) = Rose::DB::Object::Manager->normalize_get_objects_args(@_);

  my $objects =
    Rose::DB::Object::Manager->get_objects(
      object_class => $class,
      share_db     => 0,
      %args);

  foreach my $object (@$objects)
  {
    $object->remember;
  }

  return @$objects  if(defined wantarray);
}


sub clear_object_cache
{
  my($class) = shift;

  my $cache = $class->__xrdbopriv_get_cache_handle;

  $cache->clear;
}


sub cached_objects_expire_in {
    my $class = shift;
    Rose::DB::Object::Cached::cached_objects_expire_in($class,@_);
}


sub cached_objects_settings {
    my ($class, %params) = @_;;

    no strict 'refs';

    if (keys %params) {

        ${"${class}::CHI_SETTINGS"} = \%params;

    } else {
        if (! defined ${"${class}::CHI_SETTINGS"}) {
            if (defined $SETTINGS) {
                ${"${class}::CHI_SETTINGS"} = $SETTINGS;
            } else {
                ${"${class}::CHI_SETTINGS"} = $class->default_cached_objects_settings;
            }
        }
        return ${"${class}::CHI_SETTINGS"};
    }

}


sub is_cache_in_sync {
    my $self = shift;

    if ($Rose::DBx::Object::Cached::CHI::USE_IN_SYNC) {
        return unless $self->{__xrdbopriv_chi_created_at};
        my $class = ref $self;
        my $cache = $class->__xrdbopriv_get_cache_handle;
        my $pk = join(PK_SEP, grep { defined } map { $self->$_() } $self->meta->primary_key_column_names);
        my $created_at = $cache->get_object("${class}::Objects_By_Id" . LEVEL_SEP . $pk)->created_at;

        if ($created_at) {
            return ($self->{__xrdbopriv_chi_created_at} == $created_at);
        } else {
            if ($_[0]->{STATE_IN_DB()}) {
              # Has been loaded
            } else {
              Carp::cluck "Object never loaded";
            }
            return 0;
        }
    } else {
        warn 'is_cache_in_sync not activated.  Set $Rose::DBx::Object::Cached::CHI::USE_IN_SYNC to a true value';
        return undef;
    }

}


sub default_cached_objects_settings {
    my $class = shift;

    return {
        driver => 'Memory',
	namespace => $class,
        global => 1
    };
}


sub __xrdbopriv_get_cache_handle {
    my $class = shift;

    no strict 'refs';

    if (defined ${"${class}::CHI_CACHE_HANDLE"}) {
        return ${"${class}::CHI_CACHE_HANDLE"};
    } else {
        my $defaults = $class->default_cached_objects_settings();

        my $current_settings = $class->cached_objects_settings;

        my %chi_settings = (
            %$defaults, 
            (defined %$SETTINGS ? %$SETTINGS : ()), 
            %$current_settings
       );

        my $cache = new CHI(%chi_settings);

        ${"${class}::CHI_CACHE_HANDLE"} = $cache;
        return $cache;
    }
}


sub __xrdbopriv_strip {
    my $self = shift;

    Rose::DB::Object::Helpers::strip($self,@_);

    delete $self->{__xrdbopriv_chi_created_at};

    return $self;
}

sub __xrdbopriv_clone {
    my $self = shift;

    Rose::DB::Object::Helpers::clone($self,@_);
}

1;

__END__

#################### main pod documentation end ###################