File Coverage

blib/lib/Bio/Tools/EUtilities/Link.pm
Criterion Covered Total %
statement 41 51 80.3
branch 14 16 87.5
condition 6 8 75.0
subroutine 6 7 85.7
pod 1 1 100.0
total 68 83 81.9


line stmt bran cond sub pod time code
1             package Bio::Tools::EUtilities::Link;
2             $Bio::Tools::EUtilities::Link::VERSION = '1.77';
3 7     7   4503 use utf8;
  7         18  
  7         40  
4 7     7   226 use strict;
  7         16  
  7         136  
5 7     7   32 use warnings;
  7         20  
  7         194  
6 7     7   34 use base qw(Bio::Tools::EUtilities Bio::Tools::EUtilities::EUtilDataI);
  7         13  
  7         772  
7 7     7   3901 use Bio::Tools::EUtilities::Link::LinkSet;
  7         19  
  7         3177  
8              
9             # ABSTRACT: General API for accessing data retrieved from elink queries.
10             # AUTHOR: Chris Fields
11             # OWNER: 2006-2013 Chris Fields
12             # LICENSE: Perl_5
13              
14              
15              
16             # private EUtilDataI method
17              
18             {
19             my %SUBCLASS = (
20             'LinkSetDb' => 'dblink',
21             'LinkSetDbHistory' => 'history',
22             'IdUrlList' => 'urllink',
23             'IdCheckList' => 'idcheck',
24             'NoLinks' => 'nolinks',
25             );
26              
27             sub _add_data {
28 13     13   41 my ($self, $data) = @_;
29             # divide up per linkset
30 13 50       45 if (!exists $data->{LinkSet}) {
31 0         0 $self->warn("No linksets returned");
32 0         0 return;
33             }
34 13         27 for my $ls (@{ $data->{LinkSet} }) {
  13         45  
35 28         45 my $subclass;
36             # attempt to catch linkset errors
37 28 50       83 if (exists $ls->{ERROR}) {
38 0         0 my ($error, $dbfrom) = ($ls->{ERROR},$ls->{DbFrom});
39 0         0 $self->warn("NCBI LinkSet error: $dbfrom: $error\n");
40             # try to save the rest of the data, if any
41 0         0 next;
42             }
43             # caching for efficiency; no need to recheck
44 28 100       81 if (!exists $self->{'_subclass_type'}) {
45 13         40 ($subclass) = grep { exists $ls->{$_} } qw(LinkSetDb LinkSetDbHistory IdUrlList IdCheckList);
  52         129  
46 13   50     52 $subclass ||= 'NoLinks';
47 13         41 $self->{'_subclass_type'} = $subclass;
48             } else {
49 15         27 $subclass = $self->{'_subclass_type'};
50             }
51             # split these up by ID, since using correspondence() clobbers them...
52 28 100 100     127 if ($subclass eq 'IdUrlList' || $subclass eq 'IdCheckList') {
53             my $list = $subclass eq 'IdUrlList' ? 'IdUrlSet' :
54 17 100 66     76 $subclass eq 'IdCheckList' && exists $ls->{$subclass}->{IdLinkSet} ? 'IdLinkSet' :
    100          
55             'Id';
56 17         43 $ls->{$subclass} = $ls->{$subclass}->{$list};
57             }
58             # divide up linkset per link
59 28         71 for my $ls_sub (@{ $ls->{$subclass} }) {
  28         76  
60 50         100 for my $key (qw(WebEnv DbFrom IdList)) {
61 150 100       365 $ls_sub->{$key} = $ls->{$key} if exists $ls->{$key};
62             }
63             my $obj = Bio::Tools::EUtilities::Link::LinkSet->new(-eutil => 'elink',
64 50         205 -datatype => $SUBCLASS{$subclass},
65             -verbose => $self->verbose);
66 50         175 $obj->_add_data($ls_sub);
67 50         94 push @{$self->{'_linksets'}}, $obj;
  50         143  
68             # push only potential history-carrying objects into history queue
69 50 100       301 if ($subclass eq 'LinkSetDbHistory') {
70 8         13 push @{$self->{'_histories'}}, $obj;
  8         39  
71             }
72             }
73             }
74             }
75              
76             }
77              
78              
79             sub to_string {
80 0     0 1   my $self = shift;
81 0           my $string = $self->SUPER::to_string;
82 0           while (my $ls = $self->next_LinkSet) {
83 0           $string .= $ls->to_string;
84             }
85 0           return $string;
86             }
87              
88             1;
89              
90             __END__