File Coverage

blib/lib/Bio/Tools/EUtilities.pm

Criterion	Covered	Total	%
statement	224	384	58.3
branch	110	258	42.6
condition	24	70	34.2
subroutine	43	63	68.2
pod	50	51	98.0
total	451	826	54.6

package Bio::Tools::EUtilities;
$Bio::Tools::EUtilities::VERSION = '1.77';
use utf8;
use strict;
use warnings;
use base qw(Bio::Root::IO Bio::Tools::EUtilities::EUtilDataI);
use XML::Simple;

# ABSTRACT: NCBI eutil XML parsers.
# AUTHOR:   Chris Fields
# OWNER:    2006-2013 Chris Fields
# LICENSE:  Perl_5




{

my %DATA_MODULE = (
    'esearch'   => 'Query',
    'egquery'   => 'Query',
    'espell'    => 'Query',
    'epost'     => 'Query',
    'elink'     => 'Link',
    'einfo'     => 'Info',
    'esummary'  => 'Summary',
    );

sub new {
    my($caller,@args) = @_;
    my $class = ref $caller || $caller;
    if ($class =~ m{Bio::Tools::EUtilities::(\S+)}) {
        my ($self) = $class->SUPER::new(@args);
        $self->_initialize(@args);
        return $self;
    } else {
        my %param = @args;
        @param{ map { lc $_ } keys %param } = values %param; # lowercase keys
        my $eutil = $param{'-eutil'} || $class->throw("Need eutil to make instance");
        return unless( $class->_load_eutil_module( $DATA_MODULE{$eutil}) );
        return "Bio::Tools::EUtilities::$DATA_MODULE{$eutil}"->new(-datatype => lc $DATA_MODULE{$eutil},
                                                                   -eutil => $eutil,
                                                                   @args);
    }
}

sub _initialize {
    my ($self, @args) = @_;
    my ($response, $pobj, $type, $eutil, $cache, $lazy) =
    $self->_rearrange([qw(RESPONSE
                       PARAMETERS
                       DATATYPE
                       EUTIL
                       CACHE_RESPONSE
                       LAZY)], @args);
    $lazy ||= 0;
    $cache ||= 0;
    $self->datatype($type);
    $self->eutil($eutil);
    # lazy parsing only implemented for elink and esummary (where returned data
    # can be quite long).  Also, no point to parsing lazily when the data is
    # already in memory in an HTTP::Response object, so turn it off and chunk
    # the Response object after parsing.
    $response  && $self->response($response);
    $pobj && $self->parameter_base($pobj);
    $self->cache_response($cache);
    $lazy = 0 if ($response) || ($eutil ne 'elink' && $eutil ne 'esummary');
    # setting parser to 'lazy' mode is permanent (can't reset later)
    $self->{'_lazy'} = $lazy;
    $self->{'_parsed'} = 0;
}

}


sub cache_response {
    my ($self, $cache) = @_;
    if (defined $cache) {
        $self->{'_cache_response'} = ($cache) ? 1 : 0;
    }
    return $self->{'_cache_response'};
}


sub response {
    my ($self, $response) = @_;
    if ($response) {
        $self->throw('Not an HTTP::Response object') unless (ref $response && $response->isa('HTTP::Response'));
        $self->{'_response'} = $response;
    }
    return $self->{'_response'};
}


sub parameter_base {
    my ($self, $pb) = @_;
    if ($pb) {
        $self->throw('Not an Bio::ParameterBaseI object') unless (ref $pb && $pb->isa('Bio::ParameterBaseI'));
        $self->warn('Not an Bio::Tools::EUtilities::EUtilParameters object; may experience some turbulence...') unless (ref $pb && $pb->isa('Bio::Tools::EUtilities::EUtilParameters'));
        $self->{'_parameter_base'} = $pb;
    }
    return $self->{'_parameter_base'};
}


sub data_parsed {
    return shift->{'_parsed'};
}


sub is_lazy {
    return shift->{'_lazy'};
}


{
my %EUTIL_DATA = (
    'esummary'  => [qw(DocSum Item)],
    'epost'     => [],
    'egquery'   => [],
    'einfo'     => [qw(Field Link)],
    'elink'     => [qw(LinkSet LinkSetDb LinkSetDbHistory IdUrlSet
                        Id IdLinkSet ObjUrl Link LinkInfo)],
    'espell'    => [qw(Original Replaced)],
    'esearch'   => [qw(Id ErrorList WarningList)],
    );

sub parse_data {
    my $self = shift;
    my $eutil = $self->eutil;
    my $xs = XML::Simple->new();
    my $response = $self->response ? $self->response :
                   $self->_fh      ? $self->_fh      :
        $self->throw('No response or stream specified');

    my $data;
    if ($eutil eq 'espell') {
        $data = $self->_fix_espell($response);
    } elsif ($response && $response->isa("HTTP::Response")) {
        $data = $response->content;
    } else {
        $data = $response;
    }
    my $simple = $xs->XMLin($data, ForceArray => $EUTIL_DATA{$eutil});

    ## The ERROR element is #PCDATA only, so it can only have one text
    ## element.  However, it can still have zero text elements in
    ## which case it will be a reference to an empty hash.
    if (defined $simple->{ERROR} && ! ref($simple->{ERROR})) {
        ## Some errors may not be fatal but there doesn't seem to be a
        ## way for us to know.  So we warn.
        $self->warn("NCBI $eutil error: " . $simple->{ERROR});
    }


    if ($simple->{InvalidIdList}) {
        $self->warn("NCBI $eutil error: Invalid ID List".$simple->{InvalidIdList});
        return;
    }
    if ($simple->{ErrorList} || $simple->{WarningList}) {
        my @errorlist = @{ $simple->{ErrorList} } if $simple->{ErrorList};
        my @warninglist = @{ $simple->{WarningList} } if $simple->{WarningList};
        my ($err_warn);
        for my $error (@errorlist) {
            my $messages = join("\n\t",map {"$_  [".$error->{$_}.']'}
                                grep {!ref $error->{$_}} keys %$error);
            $err_warn .= "Error : $messages";
        }
        for my $warn (@warninglist) {
            my $messages = join("\n\t",map {"$_  [".$warn->{$_}.']'}
                                grep {!ref $warn->{$_}} keys %$warn);
            $err_warn .= "Warnings : $messages";
        }
        chomp($err_warn);
        $self->warn("NCBI $eutil Errors/Warnings:\n".$err_warn)
        # don't return as some data may still be useful
    }
    delete $self->{'_response'} unless $self->cache_response;
    $self->{'_parsed'} = 1;
    $self->_add_data($simple);
}

# implemented only for elink/esummary, still experimental

sub parse_chunk {
    my $self = shift;
    my $eutil = $self->eutil;
    my $tag = $eutil eq 'elink'    ? 'LinkSet' :
              $eutil eq 'esummary' ? 'DocSum'  :
              $self->throw("Only eutil elink/esummary use parse_chunk()");
    my $xs = XML::Simple->new();
    if ($self->response) {
        $self->throw("Lazy parsing not implemented for HTTP::Response data yet");
        delete $self->{'_response'} if !$self->cache_response && $self->data_parsed;
    } else { # has to be a file/filehandle
        my $fh = $self->_fh;
        my ($chunk, $seendoc, $line);
        CHUNK:
        while ($line = <$fh>) {
            next unless $seendoc || $line =~ m{^<$tag>};
            $seendoc = 1;
            $chunk .= $line;
            last if $line =~ m{^};
        }
        if (!defined $line) {
            $self->{'_parsed'} = 1;
            return;
        }
        $self->_add_data(
            $xs->XMLin($chunk, forcearray => $EUTIL_DATA{$eutil}, KeepRoot => 1)
            );
    }
}

}


sub to_string {
    my $self = shift;
    $self->parse_data if ($self->can('parse_data') && !$self->data_parsed);
    return sprintf("%-20s:%s\n\n", 'EUtil', $self->eutil);
}


sub print_all {
    my ($self, @args) = @_;
    $self->_print_handler(@args);
}




sub get_ids {
    my ($self, $request) = @_;
    my $eutil = $self->eutil;
    if ($self->is_lazy) {
        $self->warn('get_ids() not implemented when using lazy mode');
        return;
    }
    $self->parse_data unless $self->data_parsed;
    if ($eutil eq 'esearch') {
        return $self->{'_id'} ? @{ $self->{'_id'} } : ();
    } elsif ($eutil eq 'elink')  {
        my @ids;
        if ($request) {
            if (ref $request eq 'CODE') {
                push @ids, map {$_->get_ids }
                    grep { $request->($_) } $self->get_LinkSets;
            } else {
                push @ids,
                    map { @{$_->[0]} }
                    grep {grep { $_ eq $request } @{$_->[1]}}
                    map {[[$_->get_ids], [$_->get_databases]]} $self->get_LinkSets;
            }
        } else {
            $self->warn('Multiple database present, IDs will be globbed together')
                if $self->get_linked_databases > 1;
            push @ids, map {$_->get_ids } $self->get_LinkSets;
        }
        return @ids;
    } elsif ($eutil eq 'esummary') {
        unless (exists $self->{'_id'}) {
            push @{$self->{'_id'}}, map {$_->get_id } $self->get_DocSums;
        }
        return @{$self->{'_id'}};
    } elsif (my $pb = $self->parameter_base) {
        my $ids = $pb->id;
        return $ids ? @{$ids} : ();
    } else {
        return ()
    }
}


sub get_database {
    return ($_[0]->get_databases)[0];
}


sub get_db {
    return shift->get_database;
}


sub get_databases {
    my ($self, $db) = @_;
    $self->parse_data unless $self->data_parsed;
    my $eutil = $self->eutil;
    my @dbs;
    if ($eutil eq 'einfo' || $eutil eq 'espell') {
        @dbs = $self->{'_dbname'} ||
        $self->{'_database'} ||
        $self->get_available_databases;
    } elsif ($eutil eq 'egquery') {
        @dbs = map {$_->get_database} ($self->get_GlobalQueries);
    } elsif ($eutil eq 'elink') {
        # only unique dbs
        my %tmp;
        @dbs = sort grep {!$tmp{$_}++}
            map {($_->get_databases)} $self->get_LinkSets;
    } elsif ($self->parameter_base) {
        if ($self->parameter_base->eutil eq 'elink') {
            @dbs = $self->parameter_base->dbfrom;
        } else {
            @dbs = $self->parameter_base->db;
        }
    }
    return @dbs;
}


sub get_dbs {
    return shift->get_databases;
}


sub next_History {
    my $self = shift;
    $self->parse_data unless $self->data_parsed;
    $self->{'_histories_it'} = $self->generate_iterator('histories')
        if (!exists $self->{'_histories_it'});
    my $hist =  $self->{'_histories_it'}->();
}


sub next_cookie {
    return shift->next_History;
}


sub get_Histories {
    my $self = shift;
    $self->parse_data unless $self->data_parsed;
    ref $self->{'_histories'} ? return @{ $self->{'_histories'} } : return ();
}


sub get_count {
    my ($self, $db) = @_;
    $self->parse_data unless $self->data_parsed;
    # egquery
    if ($self->datatype eq 'multidbquery') {
        if (!$db) {
            $self->warn('Must specify database to get count from');
            return;
        }
        my ($gq) = grep {$_->get_database eq $db} $self->get_GlobalQueries;
        $gq && return $gq->get_count;
        $self->warn("Unknown database $db");
        return;
    } else {
        return $self->{'_count'} || scalar($self->get_ids);
    }
}


sub get_term {
    my ($self, @args) = @_;
    $self->parse_data unless $self->data_parsed;
    $self->{'_term'}  ? $self->{'_term'}  :
    $self->{'_query'} ? $self->{'_query'} :
    $self->parameter_base ? $self->parameter_base->term :
    return;
}


sub get_translation_from {
    my $self = shift;
    $self->parse_data unless $self->data_parsed;
    return $self->{'_translation'}->{'From'};
}


sub get_translation_to {
    my $self = shift;
    $self->parse_data unless $self->data_parsed;
    return $self->{'_translation'}->{'To'};
}


sub get_retstart {
    my $self = shift;
    $self->parse_data unless $self->data_parsed;
    return $self->{'_retstart'};
}


sub get_retmax {
    my $self = shift;
    $self->parse_data unless $self->data_parsed;
    return $self->{'_retmax'};
}


sub get_query_translation {
    my $self = shift;
    $self->parse_data unless $self->data_parsed;
    return $self->{'_querytranslation'};
}


sub get_corrected_query {
    my $self = shift;
    $self->parse_data unless $self->data_parsed;
    return $self->{'_correctedquery'};
}


sub get_replaced_terms {
    my $self = shift;
    $self->parse_data unless $self->data_parsed;
    if ($self->{'_spelledquery'} && $self->{'_spelledquery'}->{Replaced}) {
        ref $self->{'_spelledquery'}->{Replaced} ?
        return @{ $self->{'_spelledquery'}->{Replaced} } : return ();
    }
}


sub next_GlobalQuery {
    my $self = shift;
    $self->parse_data unless $self->data_parsed;
    $self->{'_globalqueries_it'} = $self->generate_iterator('globalqueries')
        if (!exists $self->{'_globalqueries_it'});
    $self->{'_globalqueries_it'}->();
}


sub get_GlobalQueries {
    my $self = shift;
    $self->parse_data unless $self->data_parsed;
    ref $self->{'_globalqueries'} ? return @{ $self->{'_globalqueries'} } : return ();
}


sub print_GlobalQueries {
    my ($self, @args) = @_;
    $self->_print_handler(@args, -type => 'GlobalQuery');
}


sub next_DocSum {
    my $self = shift;
    if(!$self->data_parsed && !$self->is_lazy) {
        $self->parse_data;
    }
    $self->{'_docsums_it'} = $self->generate_iterator('docsums')
        if (!exists $self->{'_docsums_it'});
    $self->{'_docsums_it'}->();
}


sub get_DocSums {
    my $self = shift;
    if ($self->is_lazy) {
        $self->warn('get_DocSums() not implemented when using lazy mode');
        return ();
    }
    $self->parse_data unless $self->data_parsed;
    return ref $self->{'_docsums'} ? @{ $self->{'_docsums'} } : return ();
}


sub print_DocSums {
    my ($self, @args) = @_;
    $self->_print_handler(@args, -type => 'DocSum');
}


sub get_available_databases {
    my $self = shift;
    $self->parse_data unless $self->data_parsed;
    ($self->{'_available_databases'}) ?
        return @{($self->{'_available_databases'})} :
        return ();
}


sub get_record_count {
    my $self = shift;
    $self->parse_data unless $self->data_parsed;
    return $self->{'_count'}
}


sub get_last_update {
    my $self = shift;
    $self->parse_data unless $self->data_parsed;
    return $self->{'_lastupdate'}
}


sub get_menu_name {
    my $self = shift;
    $self->parse_data unless $self->data_parsed;
    exists $self->{'_menuname'} ? return $self->{'_menuname'} :
    exists $self->{'_menu'} ? return $self->{'_menu'} :
    return;
}


sub get_description {
    my $self = shift;
    $self->parse_data unless $self->data_parsed;
    return $self->{'_description'};
}


sub next_FieldInfo {
    my $self = shift;
    $self->parse_data unless $self->data_parsed;
    $self->{'_fieldinfo_it'} = $self->generate_iterator('fieldinfo')
        if (!exists $self->{'_fieldinfo_it'});
    $self->{'_fieldinfo_it'}->();
}


sub get_FieldInfo {
    my $self = shift;
    $self->parse_data unless $self->data_parsed;
    return ref $self->{'_fieldinfo'} ? @{ $self->{'_fieldinfo'} } : return ();
}

*get_FieldInfos = \&get_FieldInfo;


sub next_LinkInfo {
    my $self = shift;
    $self->parse_data unless $self->data_parsed;
    $self->{'_linkinfo_it'} = $self->generate_iterator('linkinfo')
        if (!exists $self->{'_linkinfo_it'});
    $self->{'_linkinfo_it'}->();
}


sub get_LinkInfo {
    my $self = shift;
    $self->parse_data unless $self->data_parsed;
    return ref $self->{'_linkinfo'} ? @{ $self->{'_linkinfo'} } : return ();
}

*get_LinkInfos = \&get_LinkInfo;


sub print_FieldInfo {
    my ($self, @args) = @_;
    $self->_print_handler(@args, -type => 'FieldInfo');
}


sub print_LinkInfo {
    my ($self, @args) = @_;
    $self->_print_handler(@args, -type => 'LinkInfo');
}


sub next_LinkSet {
    my $self = shift;
    #$self->parse_data unless $self->data_parsed;
    if(!$self->data_parsed && !$self->is_lazy) {
        $self->parse_data;
    }
    $self->{'_linksets_it'} = $self->generate_iterator('linksets')
        if (!exists $self->{'_linksets_it'});
    $self->{'_linksets_it'}->();
}


# add support for retrieval of data if lazy parsing is enacted

sub get_LinkSets {
    my $self = shift;
    if ($self->is_lazy) {
        $self->warn('get_LinkSets() not implemented when using lazy mode');
        return ();
    }
    $self->parse_data unless $self->data_parsed;
    return ref $self->{'_linksets'} ? @{ $self->{'_linksets'} } : return ();
}


sub print_LinkSets {
    my ($self, @args) = @_;
    $self->_print_handler(@args, -type => 'LinkSet');
}


sub get_linked_databases {
    my $self = shift;
    return $self->get_databases if $self->eutil eq 'elink';
    return ();
}


{
    my %VALID_ITERATORS = (
        'globalqueries' => 'globalqueries',
        'fieldinfo' =>  'fieldinfo',
        'fieldinfos' => 'fieldinfo',
        'linkinfo' =>  'linkinfo',
        'linkinfos' => 'linkinfo',
        'linksets' => 'linksets',
        'docsums' => 'docsums',
        'histories' => 'histories'
        );


sub rewind {
    my ($self, $arg) = ($_[0], lc $_[1]);
    my $eutil = $self->eutil;
    if ($self->is_lazy) {
        $self->warn('rewind() not implemented yet when running in lazy mode');
        return;
    }
    $arg ||= 'all';
    if (exists $VALID_ITERATORS{$arg}) {
        delete $self->{'_'.$arg.'_it'};
    } elsif ($arg eq 'all') {
        for my $it (values %VALID_ITERATORS){
            delete $self->{'_'.$it.'_it'} if
                exists $self->{'_'.$it.'_it'};
            map {$_->rewind('all')} $self->get_LinkSets;
            map {$_->rewind('all')} $self->get_DocSums;
        }
    }
}


sub generate_iterator {
    my ($self, $obj) = @_;
    if (!$obj) {
        $self->throw('Must provide object type to iterate');
    } elsif (!exists $VALID_ITERATORS{$obj}) {
        $self->throw("Unknown object type [$obj]");
    }
    my $cb = $self->callback;
    if ($self->is_lazy) {
        my $type = $self->eutil eq 'esummary' ? '_docsums' : '_linksets';
        $self->{$type} = [];
        return sub {
            if (!@{$self->{$type}}) {
                $self->parse_chunk; # fill the queue
            }
            while (my $obj = shift @{$self->{$type}}) {
                if ($cb) {
                    ($cb->($obj)) ? return $obj : next;
                } else {
                    return $obj;
                }
            }
            undef;
        }
    } else {
        my $loc = '_'.$VALID_ITERATORS{$obj};
        my $index = $#{$self->{$loc}};
        my $current = 0;
        return sub {
            while ($current <= $index) {
                if ($cb) {
                    if (my $d = $cb->($self->{$loc}->[$current])) {
                        return $self->{$loc}->[$current++] }
                    else {
                        $current++;
                        next;
                    }
                } else {
                    return $self->{$loc}->[$current++]
                }
            }
            undef;
        }
    }
}

}


sub callback {
    my ($self, $cb) = @_;
    if ($cb) {
        delete $self->{'_cb'} if ($cb eq 'reset');
        return if ref $cb ne 'CODE';
        $self->{'_cb'} = $cb;
    }
    return $self->{'_cb'};
}

# Object printing methods

{
    my $DEF_HANDLER = sub {
        my $obj = shift;
        return $obj->to_string."\n";
    };

    my %HANDLER = (
        'DocSum'        => 1,
        'FieldInfo'     => 1,
        'LinkInfo'      => 1,
        'GlobalQuery'   => 1,
        'LinkSet'       => 1,
        'all'           => 1,
                   );

    sub _print_handler {
        my $self = shift;
        my ($file, $fh, $cb, $wrap, $type, $all) = $self->_rearrange([qw(FILE FH CB WRAP TYPE ALL)], @_);
        $type ||= 'all';

        # default formatting delegates to_string
        if (!$cb) {
            $self->throw("Type $type not registered with print handler, exiting...")
                if !exists($HANDLER{$type});
            $cb = $DEF_HANDLER;
        } else {
            $self->throw("Callback must be a code reference") if ref $cb ne 'CODE';
        }

        $file ||= $fh;
        $self->throw("Have defined both file and filehandle; only use one!") if $file && $fh;
        my $io = ($file) ? Bio::Root::IO->new(-input => $file, -flush => 1) :
                 Bio::Root::IO->new(-flush => 1); # defaults to STDOUT

        if ($type eq 'all') {
            my $string = $cb->($self);
            $io->_print($string) if $string;
        } else {
            # set up iterator
            my $it = "next_$type";
            $self->throw("Unknown iterator method $it") unless $self->can($it);
            while (my $obj = $self->$it) {
                my $string = $cb->($obj);
                $io->_print($string) if $string;
            }
        }
        $io->close;
    }
}

# Private methods

sub _seekable {
    return shift->{'_seekable'}
}

# fixes odd bad XML issue espell data (still present 6-24-07)

sub _fix_espell {
    my ($self, $response) = @_;
    my $temp;
    my $type = ref($response);
    if ($type eq 'GLOB') {
        $temp .= $_ for <$response>;
    } elsif ($type eq 'HTTP::Response') {
        $temp = $response->content;
    } else {
        $self->throw("Unrecognized ref type $type");
    }
    if ($temp =~ m{^}) {
        $self->throw("NCBI espell nonrecoverable error: HTML content returned")
    }
    $temp =~ s{(.*?)}{$1};
    return $temp;
}

sub _load_eutil_module {
    my ($self, $class) = @_;
    my $ok;
    my $module = "Bio::Tools::EUtilities::" . $class;

    eval {
        $ok = $self->_load_module($module);
    };
    if ( $@ ) {
        print STDERR <
$self: data module $module cannot be found
Exception $@
For more information about the EUtilities system please see the EUtilities docs.
END
       ;
    }
    return $ok;
}

1;

__END__