File Coverage

blib/lib/Bio/DB/ESoap.pm
Criterion Covered Total %
statement 10 12 83.3
branch n/a
condition n/a
subroutine 4 4 100.0
pod n/a
total 14 16 87.5


line stmt bran cond sub pod time code
1             #
2             # BioPerl module for Bio::DB::ESoap
3             #
4             # Please direct questions and support issues to
5             #
6             # Cared for by Mark A. Jensen
7             #
8             # Copyright Mark A. Jensen
9             #
10             # You may distribute this module under the same terms as perl itself
11              
12             # POD documentation - main docs before the code
13              
14             =head1 NAME
15              
16             Bio::DB::ESoap - Client for the NCBI Entrez EUtilities SOAP server
17              
18             =head1 SYNOPSIS
19              
20             $fac = Bio::DB::ESoap->new( -util => 'esearch' );
21             $som = $fac->run( -db => 'prot', -term => 'HIV and gp120' );
22             $fac->set_parameters( -term => 'HIV2 and gp160' );
23             # accessors corresponding to valid parameters are also created:
24             $fac->db('nuccore');
25             $som = $fac->run;
26              
27             # more later.
28            
29             =head1 DESCRIPTION
30              
31             C provides a basic SOAP interface to the NCBI Entrez Utilities
32             Web Service
33             (L).
34             L handles the SOAP calls. Higher level access, pipelines,
35             BioPerl object I/O and such are provided by
36             L.
37              
38             C complies with L. It depends explicitly
39             on NCBI web service description language files to inform the
40             C method. WSDLs are parsed by a relative
41             lightweight, Entrez-specific module L.
42              
43             The C method returns L (SOAP Message) objects. No
44             fault checking or other parsing is performed in this module.
45              
46             =head1 SEE ALSO
47              
48             L, L,
49             L
50              
51             =head1 FEEDBACK
52              
53             =head2 Mailing Lists
54              
55             User feedback is an integral part of the evolution of this and other
56             Bioperl modules. Send your comments and suggestions preferably to
57             the Bioperl mailing list. Your participation is much appreciated.
58              
59             bioperl-l@bioperl.org - General discussion
60             http://bioperl.org/wiki/Mailing_lists - About the mailing lists
61              
62             =head2 Support
63              
64             Please direct usage questions or support issues to the mailing list:
65              
66             L
67              
68             rather than to the module maintainer directly. Many experienced and
69             reponsive experts will be able look at the problem and quickly
70             address it. Please include a thorough description of the problem
71             with code and data examples if at all possible.
72              
73             =head2 Reporting Bugs
74              
75             Report bugs to the Bioperl bug tracking system to help us keep track
76             of the bugs and their resolution. Bug reports can be submitted via
77             the web:
78              
79             http://redmine.open-bio.org/projects/bioperl/
80              
81             =head1 AUTHOR - Mark A. Jensen
82              
83             Email maj -at- fortinbras -dot- us
84              
85             =head1 APPENDIX
86              
87             The rest of the documentation details each of the object methods.
88             Internal methods are usually preceded with a _
89              
90             =cut
91              
92             # Let the code begin...
93              
94             package Bio::DB::ESoap;
95 2     2   217214 use strict;
  2         3  
  2         46  
96 2     2   5 use warnings;
  2         3  
  2         39  
97              
98 2     2   832 use Bio::Root::Root;
  2         35072  
  2         59  
99 2     2   847 use Bio::DB::ESoap::WSDL;
  0            
  0            
100             use SOAP::Lite;
101              
102             use base qw(Bio::Root::Root Bio::ParameterBaseI);
103              
104             =head2 new
105              
106             Title : new
107             Usage : my $obj = new Bio::DB::ESoap();
108             Function: Builds a new Bio::DB::ESoap factory
109             Returns : an instance of Bio::DB::ESoap
110             Args :
111              
112             =cut
113              
114             sub new {
115             my ($class,@args) = @_;
116             my $self = $class->SUPER::new(@args);
117             my ($util, $fetch_db, $wsdl) = $self->_rearrange( [qw( UTIL FETCH_DB WSDL_FILE )], @args );
118             $self->throw("Argument -util must be specified") unless $util;
119             my @wsdl_pms;
120             if ($wsdl) {
121             @wsdl_pms = ( '-wsdl' => $wsdl );
122             }
123             else {
124             $fetch_db ||= 'seq';
125             my $url = ($util =~ /fetch/ ? 'f_'.$fetch_db : 'eutils');
126             $url = $NCBI_BASEURL.$WSDL{$url};
127             @wsdl_pms = ( '-url' => $url );
128             }
129             $self->_wsdl(Bio::DB::ESoap::WSDL->new(@wsdl_pms));
130             $self->_operation($util);
131             $self->_init_parameters;
132             $self->_client( SOAP::Lite->new( proxy => $self->_wsdl->service ) );
133            
134             return $self;
135             }
136              
137             =head2 _wsdl()
138              
139             Title : _wsdl
140             Usage : $obj->_wsdl($newval)
141             Function: Bio::DB::ESoap::WSDL object associated with
142             this factory
143             Example :
144             Returns : value of _wsdl (object)
145             Args : on set, new value (object or undef, optional)
146              
147             =cut
148              
149             sub _wsdl {
150             my $self = shift;
151            
152             return $self->{'_wsdl'} = shift if @_;
153             return $self->{'_wsdl'};
154             }
155              
156             =head2 _client()
157              
158             Title : _client
159             Usage : $obj->_client($newval)
160             Function: holds a SOAP::Lite object
161             Example :
162             Returns : value of _client (a SOAP::Lite object)
163             Args : on set, new value (a SOAP::Lite object or undef, optional)
164              
165             =cut
166              
167             sub _client {
168             my $self = shift;
169             return $self->{'_client'} = shift if @_;
170             return $self->{'_client'};
171             }
172              
173             =head2 _operation()
174              
175             Title : _operation
176             Alias : util
177             Usage :
178             Function: check and convert the requested operation based on the wsdl
179             Returns :
180             Args : operation (scalar string)
181              
182             =cut
183              
184             sub _operation {
185             my $self = shift;
186             my $util = shift;
187             return $self->{'_operation'} unless $util;
188             $self->throw("WSDL not yet initialized") unless $self->_wsdl;
189             my $opn = $self->_wsdl->operations;
190             if ( grep /^$util$/, keys %$opn ) {
191             return $self->{'_operation'} = $util;
192             }
193             elsif ( grep /^$util$/, values %$opn ) {
194             my @a = grep { $$opn{$_} eq $util } keys %$opn;
195             return $self->{'_operation'} = $a[0];
196             }
197             else {
198             $self->throw("Utility '$util' is not recognized");
199             }
200             }
201              
202             sub util { shift->_operation(@_) }
203              
204             =head2 action()
205              
206             Title : action
207             Usage :
208             Function: return the soapAction associated with the factory's utility
209             Returns : scalar string
210             Args : none
211              
212             =cut
213              
214             sub action {
215             my $self = shift;
216             return $self->{_action} if $self->{_action};
217             return $self->{_action} = ${$self->_wsdl->operations}{$self->util};
218             }
219              
220              
221              
222             =head2 wsdl_file()
223              
224             Title : wsdl_file
225             Usage :
226             Function: get filename of the local WSDL XML copy
227             Returns : filename (scalar string)
228             Args : none
229              
230             =cut
231              
232             sub wsdl_file {
233             my $self = shift;
234             if (ref ($self->_wsdl->wsdl) eq 'File::Temp') {
235             return $self->_wsdl->wsdl->filename;
236             }
237             return $self->_wsdl->wsdl;
238             }
239              
240             =head2 run()
241              
242             Title : _run
243             Usage : $som = $self->_run(@optional_setting_args)
244             Function: Call the SOAP service with the factory-associated utility
245             and parameters
246             Returns : SOAP::SOM (SOAP Message) object
247             Args : named parameters appropriate for the utility
248             Note : no fault checking here
249              
250             =cut
251              
252             sub run {
253             my $self = shift;
254             my @args = @_;
255             $self->throw("SOAP::Lite client not initialized") unless
256             $self->_client;
257             $self->throw("run requires named args") if @args % 2;
258             $self->set_parameters(@args) if scalar @args;
259             my %args = $self->get_parameters;
260             my @soap_data;
261             for my $k (keys %args) {
262             ## kludges for NCBI inconsistencies:
263             my $k_ncbi;
264             for ($k) {
265             /QueryKey/ && do {
266             $k_ncbi = 'query_key';
267             last;
268             };
269             /RetMax/ && do {
270             $k_ncbi = 'retmax';
271             last;
272             };
273             $k_ncbi = $k;
274             }
275             my $data = $args{$k};
276             next unless defined $data;
277             for (ref $data) {
278             /^$/ && do {
279             push @soap_data, SOAP::Data->name($k_ncbi)->value($data);
280             last;
281             };
282             /ARRAY/ && do {
283             push @soap_data, SOAP::Data->name($k_ncbi)->value(join(',',@$data));
284             last;
285             };
286             /HASH/ && do {
287             # for adding multiple data items with the same message
288             # key (id lists for elink, e.g.)
289             # see ...::SoapEUtilities, c. line 151
290             push @soap_data, map {
291             SOAP::Data->name($k_ncbi)->value($_)
292             } keys %$data;
293             };
294             }
295             }
296             $self->_client->on_action( sub { $self->action } );
297             my $som = $self->_client->call( $self->util,
298             @soap_data );
299            
300             return $som;
301             }
302              
303             sub _result_elt_name { my $s=shift; (keys %{$s->_wsdl->response_parameters($s->util)})[0] };
304             sub _response_elt_name { shift->_result_elt_name }
305             sub _request_elt_name { my $s=shift; (keys %{$s->_wsdl->request_parameters($s->util)})[0] };
306              
307             =head2 Bio::ParameterBaseI compliance
308              
309             =cut
310              
311             sub available_parameters {
312             my $self = shift;
313             my @args = @_;
314             return @{$self->_init_parameters};
315             }
316              
317             sub set_parameters {
318             my $self = shift;
319             my @args = @_;
320             $self->throw("set_parameters requires named args") if @args % 2;
321             ($_%2 ? 1 : $args[$_] =~ s/^-//) for (0..$#args);
322             my %args = @args;
323              
324             # special translations :
325             if ( defined $args{'usehistory'} ) {
326             $args{'usehistory'} = ($args{'usehistory'} ? 'y' : undef);
327             }
328              
329             $self->_set_from_args(\%args, -methods=>$self->_init_parameters);
330             return $self->parameters_changed(1);
331              
332             }
333              
334             sub get_parameters {
335             my $self = shift;
336             my @ret;
337             foreach (@{$self->_init_parameters}) {
338             next unless defined $self->$_();
339             push @ret, ($_, $self->$_());
340             }
341             return @ret;
342             }
343              
344             sub reset_parameters {
345             my $self = shift;
346             my @args = @_;
347             $self->throw("reset_parameters requires named args") if @args % 2;
348             ($_%2 ? 1 : $args[$_] =~ s/^-//) for (0..$#args);
349             my %args = @args;
350             my %reset;
351             @reset{@{$self->_init_parameters}} = (undef) x @{$self->_init_parameters};
352             $reset{$_} = $args{$_} for keys %args;
353             $self->_set_from_args( \%reset, -methods => $self->_init_parameters );
354             $self->parameters_changed(1);
355             return 1;
356             }
357              
358             =head2 parameters_changed()
359              
360             Title : parameters_changed
361             Usage : $obj->parameters_changed($newval)
362             Function: flag to indicate, well, you know
363             Example :
364             Returns : value of parameters_changed (a scalar)
365             Args : on set, new value (a scalar or undef, optional)
366              
367             =cut
368              
369             sub parameters_changed {
370             my $self = shift;
371             return $self->{'parameters_changed'} = shift if @_;
372             return $self->{'parameters_changed'};
373             }
374              
375             =head2 _init_parameters()
376              
377             Title : _init_parameters
378             Usage : $fac->_init_parameters
379             Function: identify the available input parameters
380             using the wsdl object
381             Returns : arrayref of parameter names (scalar strings)
382             Args : none
383              
384             =cut
385              
386             sub _init_parameters {
387             my $self = shift;
388             return $self->{_params} if $self->{_params};
389             $self->throw("WSDL not yet initialized") unless $self->_wsdl;
390             my $phash = {};
391             my $val = (values %{$self->_wsdl->request_parameters($self->util)})[0];
392             $$phash{$_} = undef for map { keys %$_ } @{$val};
393             my $params =$self->{_params} = [sort keys %$phash];
394             # create parm accessors
395             $self->_set_from_args( $phash,
396             -methods => $params,
397             -create => 1,
398             -code =>
399             'my $self = shift;
400             if (@_) {
401             $self->parameters_changed(1);
402             return $self->{\'_\'.$method} = shift;
403             }
404             $self->parameters_changed(0);
405             return $self->{\'_\'.$method};' );
406             $self->parameters_changed(1);
407             return $self->{_params};
408             }
409              
410             1;