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.13';

our $SETTINGS = undef;

our $Debug = 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
use constant PK_SEP => "\0\0";
use constant UK_SEP => "\0\0";
use constant LEVEL_SEP => "\0\0";

# 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;
 
  local $Storable::Deparse = 1;

  my $cache = $class->__xrdbopriv_get_cache_handle;

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

  my $safe_obj = $self->__xrdbopriv_clone->__xrdbopriv_strip;
  #my $safe_obj = $self->__xrdbopriv_strip;

  my $successful_set = $cache->set("${class}::Objects_By_Id" . LEVEL_SEP . $pk, $safe_obj,($self->meta->cached_objects_expire_in || $class->cached_objects_settings->{expires_in} || 'never'));


  foreach my $cols ($self->meta->unique_keys_column_names)
  {
    my $key_name  = join(UK_SEP, @$cols);
    my $key_value = join(UK_SEP, grep { defined($_) ? $_ : UNDEF }
                         map { $self->$_() } @$cols);

    $cache->set("${class}::Objects_By_Key" . LEVEL_SEP . $key_name . LEVEL_SEP . $key_value, $safe_obj, ($self->meta->cached_objects_expire_in || $class->cached_objects_settings->{expires_in} || 'never'));

    $cache->set("${class}::Objects_Keys" . LEVEL_SEP . $pk . LEVEL_SEP . $key_name, $key_value, ($self->meta->cached_objects_expire_in || $class->cached_objects_settings->{expires_in} || 'never'));
     
  }

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

};


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_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))
    {
      foreach my $cols ($_[0]->meta->unique_keys_column_names)
      {
        no warnings;
        my $key_name  = join(UK_SEP, @$cols);
        my $key_value = join(UK_SEP, grep { defined($_) ? $_ : UNDEF }
                             map { $_[0]->$_() } @$cols);

        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 save
#{
#  my($self) = shift;
#
#  my $ret = $self->SUPER::save(@_);
#  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_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_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;

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

}


sub default_cached_objects_settings {
    my $class = shift;

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


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__


=head1 NAME

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

=head1 SYNOPSIS

  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.
  


=head1 DESCRIPTION

This module intends to extend the caching ability in Rose::DB::Object 
allowing objects to be cached by any driver that can be used with 
the CHI interface. This opens the possibility to cache objects across 
scripts or even servers by opening up methods of caching such as 
FastMmap and memcached.

Most of the code is taken straight from L<Rose::DB::Object::Cached>.
This does not extend Rose::DB::Object::Cached because function calls and
how the cache is accessed needed to be changed thoughout the code.

=head1 MAJOR DIFFERENCE from L<Rose::DB::Object::Cached>

All objects derived from a L<Rose::DBx::Object::Cached> class are 
set and retrieved from CHI, therefore 2 objects that are
loaded with the same parameters are not the same code reference.

=over 4

=item B<In L<Rose::DB::Object::Cached>>

=over 4

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

  $cat1->save;

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

  print $cat1->name; # prints "Art"

  print $cat2->name; # prints "Art"

  $cat1->name('Blah');

  print $cat2->name; # prints "Blah"

=back

=item  B<In L<Rose::DBx::Object::Cached>>

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

  $cat1->save;

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

  $cat2->load;

  print $cat1->name; # prints "Art"
  print $cat2->name; # prints "Art"

  $cat1->name('Blah');
  print $cat2->name; # prints "Art"

=back
 

=back

=head1 GLOBALS

=over 4

=item B<$SETTINGS>

This global is used to set CHI settings for all objects derived from L<Rose::DBx::Object::Cached::CHI>.  Any settings here will override any default settings, but will conceded to settings configured by the class method L<cached_objects_settings|/cached_objects_settings>

=over 4

Example:

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


=back


=back



=head1 CLASS METHODS

Only class methods that do not exist in L<Rose::DB::Object::Cached> are listed here.

=over 4

=item B<cached_objects_settings [PARAMS]>

If called with no arguments this will return the current cache settings.  PARAMS are any valid options for the L<CHI> constructor.

    Example:

    Category->cached_objects_settings (
        driver     => 'FastMmap',
        root_dir   => '/tmp/global_fastmmap',
        expires_in    => '15 minutes',
    )


=back

=item B<default_cached_objects_settings [PARAMS]>

Returns the default CHI settings for the class.  This method should be implemented by a sub class if custom settings are required. 

=over 4

    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',
        };
    )

=back

If this method is not implemented in a sub class it will return the following:

=over 4

    { driver => 'Memory' }

=back



=back



=head1 OBJECT METHODS

Only object methods that do not exist in L<Rose::DB::Object::Cached> are listed here.

=over 4

=item B<is_cache_in_sync>

Because the cache is only updated when loading and saving this method will return weather the cache has been updated since the object was last loaded.

Returns true if the object is in sync with what exists in the cache.  Returns false if the cache has been updated since the object was loaded.

=back

=head1 PRIVATE METHODS

=over 4

=item B<__xrdbopriv_clone>

Calls the L<__xrdbopriv_clone|Rose::DB::Object::Helpers/__xrdbopriv_clone> method in L<Rose::DB::Object::Helpers>

=over 4

Because of the nature of L<Storable> all objects set to cache are set by $object->__xrdbopriv_clone->__xrdbopriv_strip

=back

=item B<__xrdbopriv_strip>

Calls the L<__xrdbopriv_strip|Rose::DB::Object::Helpers/__xrdbopriv_strip> method in L<Rose::DB::Object::Helpers>

=over 4

Because of the nature of L<Storable> all objects set to cache are set by $object->__xrdbopriv_clone->__xrdbopriv_strip

=back



=back


=head1 TODO

=over 4

=item B<Tests>

Currently tests only exist for MySQL.  Almost all of these have been copied directly from the tests that exist for L<Rose::DB::Object>.

=back



=head1 SUPPORT

Right now you can email kmcgrath@baknet.com.

=head1 AUTHOR

    Kevin C. McGrath
    CPAN ID: KMCGRATH
    kmcgrath@baknet.com

=head1 COPYRIGHT

This program is free software; you can redistribute
it and/or modify it under the same terms as Perl itself.

The full text of the license can be found in the
LICENSE file included with this module.


=head1 SEE ALSO

perl(1).

=cut

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


