———————package
Bio::Phylo::PhyloWS::Client;
use
strict;
use
Bio::Phylo::Factory;
{
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(
'-base_uri' => 'http://nexml-dev.nescent.org/nexml/phylows/tolweb/phylows/',
'-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/
&
;/&/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;