File Coverage

blib/lib/Bio/GMOD/Util/CheckVersions.pm

Criterion	Covered	Total	%
statement	13	15	86.6
branch			n/a
condition			n/a
subroutine	5	5	100.0
pod			n/a
total	18	20	90.0

package Bio::GMOD::Util::CheckVersions;
use strict;

use Bio::GMOD;
use Bio::GMOD::Util::Rearrange;
use LWP::UserAgent;
use XML::Simple;

use vars qw/@ISA/;

@ISA = qw/Bio::GMOD/;

sub live_version {
  my ($self,@p) = @_;
  my $adaptor = $self->adaptor;
  my $response = $self->_check_version($adaptor->live_url,$adaptor->version_live);
  # Save the current live version
  $adaptor->{defaults}->{live_version} = $response->{version};
  return (wantarray ? %$response : $response->{version});
}


sub development_version {
  my ($self,@p) = @_;
  my $adaptor = $self->adaptor;
  unless ($adaptor->development_url) {
    return (wantarray ? ( site => 'no development server specified' ) : 'no development server specified');
  }
  my $response = $self->_check_version($adaptor->development_url,$adaptor->version_dev);
  # Save the current dev version
  $adaptor->{defaults}->{dev_version} = $response->{version};
  return (wantarray ? %$response : $response->{version});
}

sub mirror_version {
  my ($self,@p) = @_;
  my ($site,$cgi) = rearrange([qw/SITE CGI/],@p);
  my $adaptor = $self->adaptor;
  $site =~ s/\/$//;
  my $response = $self->_check_version($site,"$site/$cgi");
  return (wantarray ? %$response : $response->{version});
}

# Local version should be supplied by subclass
# We not yet have instantiated a CheckVersions::* object
# if we have come from, say, Update::*
# Instantiate now, and pass the parent class for the adaptor
# Exceptionally poor design flaw.
sub local_version {
  my $self = shift;
  my $mod  = $self->mod;
  my $subclass = "Bio::GMOD::Util::CheckVersions::$mod";
  eval "require $subclass" or $self->logit(-msg=>"Could not subclass $subclass: $!",-die=>1);
  my %response = $subclass->local_version(-parent => $self);
  return (wantarray ? %response : $response{version});
}

# Placeholder - not sure if I am going to implement this
#sub package_version {
#}

# Read the contents of a provided symlink (or path) to parse out a version
# Returning the full path the symlink points at, the installed version
# and its modtime
sub read_symlink {
  my ($self,$path) = @_;
  my $realdir = -l $path ? readlink $path : $path;
  my ($root) = $path =~ /(.*\/).*/;
  my $full_path = $root . "/$realdir";
  my @temp = stat($full_path);
  my $modtime = localtime($temp[9]);
  return ($realdir,$modtime);
}




##################################
# PRIVATE METHODS
##################################
sub _check_version {
  my ($self,$site,$url) = @_;
  # Version script holds a simple cgi that dumps out the
  # title, release date, and version of the database
  $url ||= $site;
  my $version = $self->biogmod_version;
  my $ua  = LWP::UserAgent->new();
  $ua->agent("Bio::GMOD::Util::CheckVersions/$version");
  my $request = HTTP::Request->new('GET',$url);
  my $response = $ua->request($request);
  my %response;
  if ($response->is_success) {
    # Parse out the content
    my $content = $response->content;
    my $parsed = XMLin($content);
    foreach (keys %{$parsed}) {
      $response{$_} = $parsed->{$_};
    }
    $response{status} = "SUCCESS";
  } else {
    $response{error} = "FAILURE: Couldn't check version: " . $response->status_line;
  }
  $response{url} = $site;
  return \%response;
}



__END__