view release on metacpan or  search on metacpan

lib/Bio/Graphics/Browser2/CachedTrack.pm  view on Meta::CPAN

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