use strict;
use Bio::Phylo::IO 'parse';
use Bio::Phylo::Util::CONSTANT 'looks_like_hash';
use Bio::Phylo::Util::Dependency qw'LWP::UserAgent XML::Twig';
{
my @fields = \( my (%ua) );
my $logger = Bio::Phylo::Util::Logger->new;
my $fac = Bio::Phylo::Factory->new;
=head1 NAME
Bio::Phylo::PhyloWS::Client - Base class for phylogenetic web service clients
=head1 SYNOPSIS
#!/usr/bin/perl
use strict;
use warnings;
use Bio::Phylo::Factory;
my $fac = Bio::Phylo::Factory->new;
my $client = $fac->create_client(
'-authority' => 'uBioNB',
);
my $desc = $client->get_query_result(
'-query' => 'Homo sapiens',
'-section' => 'taxon',
);
for my $res ( @{ $desc->get_entities } ) {
my $proj = $client->get_record( '-guid' => $res->get_guid );
print $proj->to_nexus, "\n";
}
=head1 DESCRIPTION
This is the base class for clients connecting to services that implement
the PhyloWS (L<http://evoinfo.nescent.org/PhyloWS>) recommendations.
=head1 METHODS
=head2 CONSTRUCTOR
=over
=item new()
Type : Constructor
Title : new
Usage : my $phylows = Bio::Phylo::PhyloWS::Client->new( -url => $url );
Function: Instantiates Bio::Phylo::PhyloWS::Client object
Returns : a Bio::Phylo::PhyloWS::Client object
Args : Required: -url => $url
Optional: any number of setters. For example,
Bio::Phylo::PhyloWS->new( -name => $name )
will call set_name( $name ) internally
=cut
sub new {
# could be child class
my $class = shift;
# go up inheritance tree, eventually get an ID
my $self = $class->SUPER::new(@_);
# store a user agent object to delegate http stuff to
if ( not $self->get_ua ) {
my $ua = LWP::UserAgent->new;
$ua->timeout(300);
$ua->env_proxy;
$self->set_ua($ua);
}
return $self;
}
my $ua = sub {
return $ua{ shift->get_id };
};
=back
=head2 MUTATORS
=over
=item set_ua()
Assigns a new L<LWP::UserAgent> object that the client uses to communicate
with the service. Typically you don't have to use this unless you have to
configure a user agent for things such as proxies. Normally a default user
agent is instantiated when the client constructor is called.
Type : Mutator
Title : set_ua
Usage : $obj->set_ua( LWP::UserAgent->new );
Function: Assigns another (non-default) user agent
Returns : $self
Args : An LWP::UserAgent object (or child class)
=cut
sub set_ua {
my $self = shift;
my $arg = shift;
if ( UNIVERSAL::isa( $arg, 'LWP::UserAgent' ) ) {
$ua{ $self->get_id } = $arg;
}
else {
throw 'BadArgs' => "'$arg' is not an LWP::UserAgent";
}
return $self;
}
=back
=head2 ACCESSORS
=over
=item get_query_result()
Gets search query result
Type : Accessor
Title : get_query_result
Usage : my $res = $obj->get_query_result( -query => $query );
Function: Returns Bio::Phylo::PhyloWS::Description object
Returns : A string
Args : Required: -query => $cql_query
Optional: -section, -recordSchema
=cut
my $rss_handler = sub {
my ($create_method,$self,$twig,$elt) = @_;
my %known = (
'title' => '-name',
'description' => '-desc',
'link' => '-link',
);
my ( %args, @meta );
for my $child ( $elt->children ) {
my $tag = $child->tag;
if ( my $key = $known{$tag} ) {
$args{$key} = $child->text;
}
elsif ( $tag ne 'items' ) {
my $predicate = $tag;
my ( $prefix, $namespace, $object );
if ( $tag =~ /(.+?):/ ) {
$prefix = $1;
$namespace = $child->namespace;
}
if ( ! ( $object = $child->att('rdf:about') ) ) {
$object = $child->text;
}
push @meta, $fac->create_meta(
'-namespaces' => { $prefix => $namespace },
'-triple' => { $predicate => $object },
);
}
}
my $obj = $fac->$create_method(%args);
$obj->add_meta($_) for @meta;
my $pre = $self->get_url_prefix;
my $link = $obj->get_link;
$link =~ s/^\Q$pre\E(.+?)?/$1/i;
$obj->set_guid($link);
return $obj;
};
sub get_query_result {
my $self = shift;
if ( my %args = looks_like_hash @_ ) {
# these fields need to be set first before get_url returns
# a sane response
$self->set_query( $args{'-query'} || throw 'BadArgs' => "Need query argument" );
$self->set_section( $args{'-section'} || 'taxon' );
$self->set_format( 'rss1' );
my $rs = $args{'-recordSchema'} || $args{'-section'} || 'taxon';
my $url = $self->get_url( '-recordSchema' => $rs );
$url =~ s/&amp;/&/g;
# do the request
my $response = $ua->($self)->get($url);
if ( $response->is_success ) {
my $content = $response->content;
$self->set_section($rs);
my $desc;
eval {
XML::Twig->new(
'TwigHandlers' => {
'channel' => sub {
$desc = $rss_handler->('create_description',$self,@_);
},
'item' => sub {
my $res = $rss_handler->('create_resource',$self,@_);
$desc->insert($res);
},
}
)->parse($content);
};
if ( $@ ) {
$logger->fatal("Error fetching from $url");
$logger->fatal($content);
throw 'NetworkError' => $@;
}
else {
$self->set_section( $args{'-section'} || 'taxon' );
return $desc;
}
}
else {
throw 'NetworkError' => "Error fetching from $url: "
. $response->status_line;
}
}
}
=item get_record()
Gets a PhyloWS database record
Type : Accessor
Title : get_record
Usage : my $rec = $obj->get_record( -guid => $guid );
Function: Gets a PhyloWS database record
Returns : Bio::Phylo::Project object
Args : Required: -guid => $guid
=cut
sub get_record {
my $self = shift;
if ( my %args = looks_like_hash @_ ) {
$self->set_guid( $args{'-guid'} || throw 'BadArgs' => "Need -guid argument" );
$self->set_query();
my $url = $self->get_url( '-format' => 'nexml' );
$logger->debug($url);
return parse(
'-format' => 'nexml',
'-url' => $url,
'-as_project' => 1,
);
}
}
=item get_ua()
Gets the underlying L<LWP::UserAgent> object that the client uses to communicate with the service
Type : Accessor
Title : get_ua
Usage : my $ua = $obj->get_ua;
Function: Gets user agent
Returns : LWP::UserAgent object
Args : None
=cut
sub get_ua { $ua{ shift->get_id } }
sub _cleanup {
my $self = shift;
my $id = $self->get_id;
for my $field (@fields) {
delete $field->{$id};
}
}
=back
=cut
# podinherit_insert_token
=head1 SEE ALSO
There is a mailing list at L<https://groups.google.com/forum/#!forum/bio-phylo>
for any user or developer questions and discussions.
Also see the manual: L<Bio::Phylo::Manual> and L<http://rutgervos.blogspot.com>
=head1 CITATION
If you use Bio::Phylo in published research, please cite it:
B<Rutger A Vos>, B<Jason Caravas>, B<Klaas Hartmann>, B<Mark A Jensen>
and B<Chase Miller>, 2011. Bio::Phylo - phyloinformatic analysis using Perl.
I<BMC Bioinformatics> B<12>:63.
=cut
}
1;