Permalink
Switch branches/tags
Nothing to show
Find file Copy path
Fetching contributors…
Cannot retrieve contributors at this time
401 lines (287 sloc) 8.86 KB
###########################################
package Cache::Historical;
###########################################
use strict;
use warnings;
use Rose::DB::Object::Loader;
use File::Basename;
use File::Path;
use Log::Log4perl qw(:easy);
use DBI;
use DateTime::Format::Strptime;
our $VERSION = "0.05";
###########################################
sub new {
###########################################
my($class, %options) = @_;
my($home) = glob "~";
my $default_cache_dir = "$home/.cache-historical";
my $self = {
sqlite_file => "$default_cache_dir/cache-historical.dat",
%options,
};
my $cache_dir = dirname( $self->{sqlite_file} );
if(! -d $cache_dir ) {
mkpath [ $cache_dir ] or
die "Cannot mktree $cache_dir ($!)";
}
bless $self, $class;
$self->{dsn} = "dbi:SQLite:dbname=$self->{sqlite_file}";
if(! -f $self->{sqlite_file}) {
$self->db_init();
}
my $loader =
Rose::DB::Object::Loader->new(
db_dsn => $self->{dsn},
db_options => { AutoCommit => 1, RaiseError => 1 },
class_prefix => 'Cache::Historical',
with_managers => 1,
);
$loader->make_classes();
$self->{loader} = $loader;
return $self;
}
###########################################
sub make_modules {
###########################################
my($self, @options) = @_;
DEBUG "Making modules in @options";
$self->{loader}->make_modules( @options );
}
###########################################
sub dbh {
###########################################
my($self) = @_;
if(! $self->{dbh} ) {
$self->{dbh} = DBI->connect($self->{dsn}, "", "");
}
return $self->{dbh};
}
###########################################
sub db_init {
###########################################
my($self) = @_;
my $dbh = $self->dbh();
DEBUG "Creating new SQLite db $self->{sqlite_file}";
$dbh->do(<<'EOT');
CREATE TABLE vals (
id INTEGER PRIMARY KEY,
date DATETIME,
upd_time DATETIME,
key TEXT,
value TEXT,
UNIQUE(date, key)
);
EOT
$dbh->do(<<'EOT');
CREATE INDEX vals_date_idx ON vals(date);
EOT
$dbh->do(<<'EOT');
CREATE INDEX vals_key_idx ON vals(key);
EOT
return 1;
}
###########################################
sub set {
###########################################
my($self, $dt, $key, $value) = @_;
DEBUG "Setting $dt $key => $value";
my $r = Cache::Historical::Val->new();
$r->key( $key );
$r->date( $dt );
$r->upd_time( DateTime->now() );
$r->load( speculative => 1 );
$r->value( $value );
$r->save();
}
###########################################
sub get {
###########################################
my($self, $dt, $key, $interpolate) = @_;
my @date_query = (date => $dt);
@date_query = (date => {le => $dt}) if $interpolate;
my $values = Cache::Historical::Val::Manager->get_vals(
query => [
@date_query,
key => $key,
],
sort_by => "date DESC",
limit => 1,
);
if(@$values) {
my $value = $values->[0]->value();
DEBUG "Getting $dt $key => $value";
return $value;
}
return undef;
}
###########################################
sub keys {
###########################################
my($self) = @_;
my @keys;
my $keys = Cache::Historical::Val::Manager->get_vals(
distinct => 1,
select => [ 'key' ],
);
for(@$keys) {
push @keys, $_->key();
}
return @keys;
}
###########################################
sub values {
###########################################
my($self, $key) = @_;
my @values = ();
my @key = ();
@key = (key => $key) if defined $key;
my $values = Cache::Historical::Val::Manager->get_vals(
query => [ @key ],
sort_by => ['date'],
);
for(@$values) {
push @values, [$_->date(), $_->value()];
}
return @values;
}
###########################################
sub last_update {
###########################################
my($self, $key) = @_;
my @key = ();
@key = (key => $key) if defined $key;
my $values = Cache::Historical::Val::Manager->get_vals(
query => [ @key ],
sort_by => ['upd_time DESC'],
limit => 1,
);
if(@$values) {
my $date = $values->[0]->upd_time();
return $date;
}
return undef;
}
###########################################
sub since_last_update {
###########################################
my($self, $key) = @_;
my $date = $self->last_update($key);
if(defined $date) {
return DateTime->now() - $date;
}
return undef;
}
###########################################
sub get_interpolated {
###########################################
my($self, $dtp, $key) = @_;
return $self->get($dtp, $key, 1);
}
my $date_fmt = DateTime::Format::Strptime->new(
pattern => "%Y-%m-%d %H:%M:%S");
###########################################
sub time_range {
###########################################
my($self, $key) = @_;
my $dbh = $self->dbh();
my($from, $to) = $dbh->selectrow_array(
"SELECT MIN(date), MAX(date) FROM vals WHERE key = " .
$dbh->quote( $key ));
$from = $date_fmt->parse_datetime( $from );
$to = $date_fmt->parse_datetime( $to );
return($from, $to);
}
###########################################
sub clear {
###########################################
my($self, $key) = @_;
my @params = (all => 1);
if(defined $key) {
@params = ("where" => [ key => $key ]);
}
my $values = Cache::Historical::Val::Manager->delete_vals( @params );
}
1;
__END__
=head1 NAME
Cache::Historical - Cache historical values
=head1 SYNOPSIS
use Cache::Historical;
my $cache = Cache::Historical->new();
# Set a key's value on a specific date
$cache->set( $dt, $key, $value );
# Get a key's value on a specific date
my $value = $cache->get( $dt, $key );
# Same as 'get', but if we don't have a value at $dt, but we
# do have values for dates < $dt, return the previous
# historic value.
$cache->get_interpolated( $dt, $key );
=head1 DESCRIPTION
Cache::Historical caches historical values by key and date. If you have
something like historical stock quotes, for example
2008-01-02 msft 35.22
2008-01-03 msft 35.37
2008-01-04 msft 34.38
2008-01-07 msft 34.61
then you can store them in Cache::Historical like
my $cache = Cache::Historical->new();
my $fmt = DateTime::Format::Strptime->new(
pattern => "%Y-%m-%d");
$cache->set( $fmt->parse_datetime("2008-01-02"), "msft", 35.22 );
$cache->set( $fmt->parse_datetime("2008-01-03"), "msft", 35.37 );
$cache->set( $fmt->parse_datetime("2008-01-04"), "msft", 34.38 );
$cache->set( $fmt->parse_datetime("2008-01-07"), "msft", 34.61 );
and retrieve them later by date:
my $dt = $fmt->parse_datetime("2008-01-03");
# Returns 35.37
my $value = $cache->get( $dt, "msft" );
Even if there's no value available for a given date, but there are historical
values that predate the requested date, C<get_interpolated()> will return
the next best historical value:
my $dt = $fmt->parse_datetime("2008-01-06");
# Returns undef, no value available for 2008-01-06
my $value = $cache->get( $dt, "msft" );
# Returns 34.48, the value for 2008-01-04, instead.
$value = $cache->get_interpolated( $dt, "msft" );
=head2 Methods
=over 4
=item new()
Creates the object. Takes the SQLite file to put the date into as
an additional parameter:
my $cache = Cache::Historical->new(
sqlite_file => "/tmp/mydata.dat",
);
The SQLite file defaults to
$HOME/.cache-historical/cache-historical.dat
so if you have multiple caches, you need to use different
SQLite files.
=item time_range()
# List the time range for which we have values for $key
my($from, $to) = $cache->time_range( $key );
=item keys()
# List all keys
my @keys = $cache->keys();
=item values()
# List all the values we have for $key, sorted by date
# ([$dt, $value], [$dt, $value], ...)
my @results = $cache->values( $key );
=item clear()
# Remove all values for a specific key
$cache->clear( $key );
# Clear the entire cache
$cache->clear();
=item last_update()
# Return a DateTime object of the last update of a given key
my $when = $cache->last_update( $key );
=item since_last_update()
# Return a DateTime::Duration object since the time of the last
# update of a given key.
my $since = $cache->since_last_update( $key );
=back
=head1 LEGALESE
Copyright 2007-2011 by Mike Schilli, all rights reserved.
This program is free software, you can redistribute it and/or
modify it under the same terms as Perl itself.
=head1 AUTHOR
2007, Mike Schilli <cpan@perlmeister.com>