package Bio::Graphics::Browser2::CachedTrack;
# $Id$
# This package defines a Bio::Graphics::Browser2::Track option that manages
# the caching of track images and imagemaps.
use strict;
use warnings;
use Carp;
use Fcntl ':flock';
use File::Spec;
use File::Path;
use IO::File;
use Digest::MD5 'md5_hex';
use Storable qw(:DEFAULT freeze thaw);
# pending requests get 1 minute before they are considered likely to be defunct
use constant DEFAULT_REQUEST_TIME => 60;
use constant DEFAULT_CACHE_TIME => 60*60; # 1 hour
# constructor:
# Bio::Graphics::Browser2::CachedTrack->new($cache_base_directory,$key_data)
# If $key_data is a scalar, then it is taken to be the literal key.
# Otherwise if it is an arrayref, it is an array of arguments that will be
# converted into the key.
sub new {
my $self = shift;
my %args = @_;
my $cache_base = $args{-cache_base};
my $panel_args = $args{-panel_args};
my $track_args = $args{-track_args};
my $extra_args = $args{-extra_args};
my $cache_time = $args{-cache_time};
my $key = $args{-key};
-d $cache_base && -w _ or croak "$cache_base is not writable";
# If next argument is a scalar, then it is our key to use.
# Otherwise, it is the data to use to generate a key.
unless ($key) {
$key = $self->generate_cache_key(@$panel_args,@$track_args,@$extra_args);
}
my $obj = bless {
cache_base => $cache_base ,
key => $key,
panel_args => $panel_args,
track_args => $track_args,
extra_args => $extra_args,
cache_time => defined $cache_time ? $cache_time : DEFAULT_CACHE_TIME,
},ref $self || $self;
return $obj;
}
sub cache_base { shift->{cache_base} }
sub lock_base { shift->{lock_base} }
sub key { shift->{key} }
sub panel_args { shift->{panel_args} }
sub track_args { shift->{track_args} }
sub extra_args { shift->{extra_args} }
sub max_time {
my $self = shift;
$self->{max_time} = shift if @_;
return $self->{max_time} || DEFAULT_REQUEST_TIME;
}
sub cache_time {
my $self = shift;
my $d = $self->{cache_time};
$self->{cache_time} = shift if @_;
return $d;
}
sub cachedir {
my $self = shift;
my $key = $self->key;
my @comp = $key =~ /(..)/g;
my $path = File::Spec->catfile($self->cache_base,@comp[0..2],$key);
mkpath ($path) unless -e $path;
die "Can't mkpath($path): $!" unless -d $path;
return $path;
}
sub dotfile {
my $self = shift;
return File::Spec->catfile($self->cachedir,'.lock');
}
sub tsfile {
my $self = shift;
return File::Spec->catfile($self->cachedir,'.ts');
}
sub datafile {
my $self = shift;
return File::Spec->catfile($self->cachedir,'data');
}
sub errorfile {
my $self = shift;
return File::Spec->catfile($self->cachedir,'error');
}
# given an arbitrary set of arguments, make a unique cache key
sub generate_cache_key {
my $self = shift;
my @args = map {$_ || ''} grep {!ref($_)} @_; # the map gets rid of uninit variable warnings
return md5_hex(sort @args);
}
# lock the cache -- indicates that an update is in process
# we use simple dotfile locking
sub lock {
my $self = shift;
my $dotfile = $self->dotfile;
my $tsfile = $self->tsfile;
if (-e $dotfile) { # if it exists, then either we are in process or something died
return if $self->status eq 'PENDING';
}
my $f = IO::File->new(">$dotfile") or die "Can't open $dotfile for writing: $!";
flock $f,LOCK_EX;
$f->print($$,' ',time()); # PID<sp>timestamp
$f->close;
return 1;
}
sub unlock {
my $self = shift;
my $dotfile = $self->dotfile;
unlink $dotfile;
}
sub flag_error {
my $self = shift;
my $msg = shift;
my $errorfile = $self->errorfile;
open my $fh,'>',$errorfile or die;
print $fh $msg;
close $fh;
$self->unlock;
}
sub errstr {
my $self = shift;
my $errorfile = $self->errorfile;
open my $fh,'<',$errorfile or return;
while (my $msg = <$fh>) {
chomp $msg;
next if $msg =~ /EXCEPTION/; # bioperl error header
$msg =~ s/MSG://; # more bioperl cruft
return $msg if $msg;
}
return 'unknown';
}
sub put_data {
my $self = shift;
my ($gd,$map,$titles) = @_;
$self->{data}{gd} = $gd->can('gd2') ? $gd->gd2 : $gd;
$self->{data}{map} = $map;
$self->{data}{titles} = $titles;
my $datafile = $self->datafile;
store $self->{data},$datafile;
$self->unlock;
unlink $self->errorfile if -e $self->errorfile;
return;
}
sub get_data {
my $self = shift;
my $ignore_expires = shift;
return $self->{data} if $self->{data};
my $status = $self->status;
if ( ($status eq 'AVAILABLE') or
($status eq 'EXPIRED' && $ignore_expires)) {
return $self->_get_data();
} else {
return;
}
}
sub _get_data {
my $self = shift;
my $datafile = $self->datafile;
$self->{data} = retrieve($datafile);
return $self->{data};
}
sub gd {
my $self = shift;
my $data = $self->get_data or return;
# The ? statement here accomodates the storage of GD::SVG objects,
# which do not support the call to newFromPngData.
my $gd = (ref($data->{gd})
&& ref($data->{gd})=~/^GD/)
? $data->{gd}
: GD::Image->newFromGd2Data($data->{gd});
return $gd;
}
sub map {
my $self = shift;
my $data = $self->get_data or return;
return $data->{map};
}
sub titles {
my $self = shift;
my $data = $self->get_data or return;
return $data->{titles};
}
sub width {
my $self = shift;
my $gd = $self->gd or return;
return ($gd->getBounds)[0];
}
sub height {
my $self = shift;
my $gd = $self->gd or return;
return ($gd->getBounds)[1];
}
# status returns one of four states
# 'EMPTY' no data available and no requests are pending
# 'PENDING' a request for the data is pending - current contents invalid
# 'AVAILABLE' data is available and no requests are pending
# 'DEFUNCT' a request for the data has timed out - current contents invalid
# 'EXPIRED' there is data, but it has expired
# 'ERROR' an error occurred, and data will never be available
sub status {
my $self = shift;
my $dir = $self->cachedir;
my $dotfile = $self->dotfile;
my $tsfile = $self->tsfile;
my $datafile = $self->datafile;
my $errorfile = $self->errorfile;
# if a dotfile exists then either we are in the midst of updating the
# contents of the directory, or something has gone wrong and we are
# waiting forever.
if (-e $dotfile) {
-s _ or return 'PENDING'; # size zero means that dotfile has been created but not locked
my $f = IO::File->new($dotfile)
or return 'AVAILABLE'; # dotfile disappeared, so data has just become available
flock $f,LOCK_SH;
my ($pid,$timestamp) = split /\s+/,$f->getline();
$f->close;
return 'DEFUNCT' unless $timestamp;
unless (kill 0=>$pid) {
$self->flag_error('the rendering process crashed');
return 'ERROR';
}
return 'PENDING' if time()-$timestamp < $self->max_time;
$self->flag_error('timeout; try viewing a smaller region');
return 'ERROR';
} elsif (-e $datafile) {
return $self->expired($datafile) ? 'EXPIRED' : 'AVAILABLE';
} elsif (-e $errorfile) {
return 'ERROR';
} else {
return 'EMPTY';
}
}
sub needs_refresh {
my $self = shift;
my $status = $self->status;
return 1 if $status eq 'EMPTY';
return 1 if $status eq 'EXPIRED';
return 1 if $status eq 'DEFUNCT';
return;
}
sub expired {
my $self = shift;
my $datafile = shift;
my $cache_time= $self->cache_time;
my $time = time();
my $mtime = (stat($datafile))[9];
my $elapsed = $time-$mtime;
return 0 if ( $mtime and not $cache_time);
return $elapsed > $cache_time;
}
1;