File Coverage

blib/lib/Bio/Tools/EUtilities/EUtilParameters.pm

Criterion	Covered	Total	%
statement	147	368	39.9
branch	57	218	26.1
condition	43	237	18.1
subroutine	26	56	46.4
pod	16	46	34.7
total	289	925	31.2

package Bio::Tools::EUtilities::EUtilParameters;
$Bio::Tools::EUtilities::EUtilParameters::VERSION = '1.77';
use utf8;
use strict;
use warnings;
use base qw(Bio::Root::Root Bio::ParameterBaseI);
use URI;
use HTTP::Request;
use Bio::Root::IO;

# ABSTRACT: Manipulation of NCBI eutil-based parameters for remote database requests.
# AUTHOR:   Chris Fields
# OWNER:    2006-2013 Chris Fields
# LICENSE:  Perl_5


# eutils only has one hostbase URL

# mode : GET or POST (HTTP::Request)
# location : CGI location
# params : allowed parameters for that eutil
my %MODE = (
    'einfo'     => {
        'mode'     => ['GET'],
        'location' => 'einfo.fcgi',
        'params'   => [qw(db tool email api_key)],
                   },
    'epost'     => {
        'mode'     => ['POST','GET'],
        'location' => 'epost.fcgi',
        'params'   => [qw(db retmode id tool email api_key idtype WebEnv query_key)],
                   },
    'efetch'    => {
        'mode'     => ['GET','POST'],
        'location' => 'efetch.fcgi',
        'params'   => [qw(db retmode id retmax retstart rettype strand seq_start
                       seq_stop complexity report tool email api_key idtype WebEnv query_key)],
                   },
    'esearch'   => {
        'mode'     => ['GET','POST'],
        'location' => 'esearch.fcgi',
        'params'   => [qw(db retmode usehistory term field reldate mindate
                       maxdate datetype retmax retstart rettype sort tool email api_key idtype
                       WebEnv query_key)],
                   },
    'esummary'  => {
        'mode'     => ['GET','POST'],
        'location' => 'esummary.fcgi',
        'params'   => [qw(db retmode id retmax retstart rettype tool email api_key idtype
                       version WebEnv query_key)],
                   },
    'elink'     => {
        'mode'     => ['GET','POST'],
        'location' => 'elink.fcgi',
        'params'   => [qw(db retmode id reldate mindate maxdate datetype term
                    dbfrom holding cmd version tool email api_key idtype linkname WebEnv
                    query_key)],
                   },
    'egquery'   => {
        'mode'     => ['GET','POST'],
        'location' => 'egquery.fcgi',
        'params'   => [qw(term retmode tool email api_key)],
                   },
    'espell'    => {
        'mode'     => ['GET','POST'],
        'location' => 'espell.fcgi',
        'params'   => [qw(db retmode term tool email api_key )],
                   }
);

my @PARAMS;

# generate getter/setters (will move this into individual ones at some point)

BEGIN {
    @PARAMS = qw(db id email api_key retmode rettype usehistory term field tool
    reldate mindate maxdate datetype retstart retmax sort seq_start seq_stop
    strand complexity report dbfrom cmd holding version linkname WebEnv
    query_key idtype);
    for my $method (@PARAMS) {
        eval <
sub $method {
    my (\$self, \$val) = \@_;
    if (defined \$val) {
        if ((!defined \$self->{'_$method'}) ||
        (defined \$self->{'_$method'} && \$self->{'_$method'} ne \$val)) {
            \$self->{'_statechange'} = 1;
            \$self->{'_$method'} = \$val;
        }
    }
    return \$self->{'_$method'};
}
END
    }
}

sub new {
    my ($class, @args) = @_;
    my $self = $class->SUPER::new(@args);
    my ($retmode) = $self->_rearrange(["RETMODE"],@args);
    # order is important here, eutil must be set first so that proper error
    # checking occurs for the later attributes
    $self->_set_from_args(\@args,
        -methods => [@PARAMS, qw(eutil history correspondence id_file request_mode)]);
    $self->eutil() || $self->eutil('efetch');
    $self->tool() || $self->tool('BioPerl');
    # set default retmode if not explicitly set
    $self->set_default_retmode if (!$retmode);
    $self->{'_statechange'} = 1;
    return $self;
}


sub set_parameters {
    my ($self, @args) = @_;
    # allow automated resetting; must check to ensure that retmode isn't explicitly passed
    my ($newmode,$file) = $self->_rearrange([qw(RETMODE ID_FILE)],@args);
    $self->_set_from_args(\@args, -methods => [@PARAMS, qw(eutil correspondence history)]);
    # set default retmode if not explicitly passed
    $self->set_default_retmode unless $newmode;
    $file && $self->id_file($file);
    return;
}


sub reset_parameters {
    my ($self, @args) = @_;
    # is there a better way of doing this?  probably, but this works...
    my ($retmode,$file) = $self->_rearrange([qw(RETMODE ID_FILE)],@args);
    map { defined $self->{"_$_"} && undef $self->{"_$_"} } (@PARAMS, qw(eutil correspondence history_cache request_cache));
    $self->_set_from_args(\@args, -methods => [@PARAMS, qw(eutil correspondence history)]);
    $self->eutil() || $self->eutil('efetch');
    $self->set_default_retmode unless $retmode;
    $file && $self->id_file($file);
    $self->{'_statechange'} = 1;
}


sub carryover {
    my ($self, $params, $mode) = @_;
    my %allowed = map {$_ => 1} (@PARAMS, qw(eutil history correspondence));
    if ($params) {
        $self->throw("Must pass in an array ref of parameters") unless
            ref($params) eq 'ARRAY';
        my $mode ||= 'add';
        $self->throw("Mode must be 'add' or 'delete'") unless $mode eq 'add' || $mode eq 'delete';
        if (!scalar(@$params)) { # empty array ref
            $self->{_carryover} = {};
        } else {
            for my $p (@$params) {
                if (!exists $allowed{$p}) {
                    $self->warn("$p is not a recognized eutil parameter");
                    next;
                }
                if ($mode eq 'add') {
                    $self->{_carryover}->{$p} = 1;
                } else {
                    delete $self->{_carryover}->{$p} if exists
                        $self->{_carryover}->{$p};
                }
            }
        }
    }
    sort keys %{$self->{_carryover}} || ();
}

sub _reset_except_carryover {
    my $self = shift;
    #for my $p (@PARAMS, qw(eutil correspondence history_cache request_cache)) {
    #    undef $self->{"_$p"} if defined $self->{"_$p"};
    #}
}


sub request_mode {
    my ($self, $mode) = @_;
    $mode = uc $mode if defined $mode;
    my $eutil = $self->eutil;
    if ($mode) {
        my %valid = map {$_ => 1} @{$MODE{$eutil}{mode}};
        $self->throw("Mode $mode not supported for $eutil") unless
            exists $valid{$mode};
        $self->{_request_mode} = $mode;
    }
    return $self->{_request_mode} if $self->{_request_mode};
    # let's try to make this a bit smarter...

    # If not explicitly set, in cases where
    # the number of IDs is greater than 200, or the search term is longer than
    # 200, use POST when available

    if (scalar(@{$MODE{$eutil}{mode}}) > 1) { # allows both GET and POST
        my ($id, $term) = ($self->id || [], $self->term || '');
        if (ref $id eq 'ARRAY' && scalar(@$id) > 200 || CORE::length($term) > 300) {
            return 'POST'
        }
    }
    # otherwise, fallback to default
    $MODE{$eutil}{mode}[0]; # first is default
}


sub parameters_changed {
    my ($self) = @_;
    $self->{'_statechange'};
}


sub available_parameters {
    my ($self, $type) = @_;
    $type ||= 'all';
    if ($type eq 'all') {
        return @PARAMS;
    } else {
        $self->throw("$type parameters not supported") if !exists $MODE{$type};
        return @{$MODE{$type}->{params}};
    }
}


sub get_parameters {
    my ($self, @args) = @_;
    my ($type, $list, $join) = $self->_rearrange([qw(TYPE LIST JOIN_IDS)], @args);
    $self->throw("Parameter list not an array ref") if $list && ref $list ne 'ARRAY';
    $type ||= '';
    my @final = $list ? grep {$self->can($_)} @{$list} : $self->available_parameters($type);
    my @p;
    for my $param (@final) {
        if ($param eq 'id' && $self->id && $join) {
            my $id = $self->id;
            if ($self->correspondence && $self->eutil eq 'elink') {
                for my $id_group (@{ $id }) {
                    if (ref($id_group) eq 'ARRAY') {
                        push @p, ('id' => join(q(,), @{ $id_group }));
                    }
                    elsif (!ref($id_group)) {
                        push @p, ('id'  => $id_group);
                    }
                    else {
                        $self->throw("Unknown ID type: $id_group");
                    }
                }
            } else {
                # add a check for undef
                push @p, ref $id eq 'ARRAY' ?
                ($param => join(',', grep {defined($_)} @{ $id })):
                ($param => $id);
            }
        }
        elsif ($param eq 'db' && $self->db && $join) {
            my $db = $self->db;
            push @p, (ref $db eq 'ARRAY') ?
                ($param => join(',', @{ $db })) :
                ($param => $db) ;
        }
        else {
            push @p, ($param => $self->{"_$param"}) if defined $self->{"_$param"};
        }
    }
    return @p;
}


sub to_string {
    my ($self, @args) = @_;
    # calling to_uri changes the state
    if ($self->parameters_changed || !defined $self->{'_string_cache'}) {
        my $string = $self->to_request(@args)->uri->as_string;
        $self->{'_statechange'} = 0;
        $self->{'_string_cache'} = $string;
    }
    return $self->{'_string_cache'};
}


sub to_request {
    my ($self, $type) = @_;
    if ($self->parameters_changed || !defined $self->{'_request_cache'}) {
        my $eutil = $self->eutil;
        $self->throw("No eutil set") if !$eutil;
        #set default retmode
        $type ||= $eutil;
        my ($location, $mode) = ($MODE{$eutil}->{location}, $self->request_mode);
        my $request;
        my $uri = URI->new($self->url_base_address . $location);
        if ($mode eq 'GET') {
            $uri->query_form($self->get_parameters(-type => $type, -join_ids => 1) );
            $request = HTTP::Request->new($mode => $uri);
            $self->{'_request_cache'} = $request;
        } elsif ($mode eq 'POST') {
            $request = HTTP::Request->new($mode => $uri->as_string);
            $uri->query_form($self->get_parameters(-type => $type, -join_ids => 1) );
            $request->content_type('application/x-www-form-urlencoded');
            $request->content($uri->query);
            $self->{'_request_cache'} = $request;
        } else {
            $self->throw("Unrecognized request mode: $mode");
        }
        $self->{'_statechange'} = 0;
        $self->{'_request_cache'} = $request;
    }
    return $self->{'_request_cache'};
}


sub eutil {
    my ($self, $eutil) = @_;
    if ($eutil) {
        $self->throw("$eutil not supported") if !exists $MODE{$eutil};
        if (!defined $self->{'_eutil'} || ($self->{'_eutil'} && $self->{'_eutil'} ne $eutil)) {
            $self->{'_eutil'} = $eutil;
            $self->{'_statechange'} = 1;
        }
    }
    return $self->{'_eutil'};
}


sub history {
    my ($self, $history) = @_;
    if ($history) {
        $self->throw('Not a Bio::Tools::EUtilities::HistoryI object!') if
            !$history->isa('Bio::Tools::EUtilities::HistoryI');
        my ($webenv, $qkey) = $history->history;
        $self->WebEnv($webenv);
        $self->query_key($qkey);
        $self->{'_statechange'} = 1;
        $self->{'_history_cache'} = $history;
    }
    return $self->{'_history_cache'};
}


sub correspondence {
    my ($self, $corr) = @_;
    if (defined $corr) {
        $self->{'_correspondence'} = $corr;
        $self->{'_statechange'} = 1;
    }
    return $self->{'_correspondence'};
}


sub id_file {
    my ($self, $file) = @_;
    if ($file) {
        # do this in a way that allows file, fh, IO::Handle
        my $io = $self->_io;
        $io->_initialize_io(-input => $file);
        my @ids;
        while (my $line = $io->_readline) {
            chomp $line;
            push @ids, $line;
        }
        $self->_io->close;
        $self->id(\@ids);
    }
}


{
    my $HOSTBASE = 'https://eutils.ncbi.nlm.nih.gov/entrez/eutils/';

    sub url_base_address {
        my ($self, $address) = @_;
        return $HOSTBASE;
    }
}


{
    # default retmode if one is not supplied
    my %NCBI_DATABASE = (
        'protein'          => 'text',
        'nucleotide'       => 'text',
        'nuccore'          => 'text',
        'nucgss'           => 'text',
        'nucest'           => 'text',
        'structure'        => 'text',
        'genome'           => 'text',
        'gene'             => 'asn1',
        'journals'         => 'text',
    );

    sub set_default_retmode {
        my $self = shift;
        if ($self->eutil eq 'efetch') {
            my $db = $self->db || return; # assume retmode will be set along with db
            my $mode = exists $NCBI_DATABASE{$db} ? $NCBI_DATABASE{$db} : 'xml';
            $self->retmode($mode);
        } else {
            $self->retmode('xml');
        }
    }
}

sub _io {
    my $self = shift;
    if (!defined $self->{'_io'}) {
        $self->{'_io'} = Bio::Root::IO->new();
    }
    return $self->{'_io'};
}

1;

__END__