pubmed.pm

一个论文管理系统

# $Id: Pubmed.pm,v 1.8 2006/01/26 14:32:03 martin Exp $
#
# Copyright 2005 Nature Publishing Group
# This program is free software; you can redistribute it and/or
# modify it under the terms of the GNU General Public License
# as published by the Free Software Foundation; either version 2
# of the License, or (at your option) any later version.
#
# The Bibliotech::CitationSource::Pubmed class retrieves citation data for articles
# in Pubmed.

use strict;
use Bibliotech::CitationSource;
use Bio::Biblio::IO;

package Bibliotech::CitationSource::Pubmed;
use base 'Bibliotech::CitationSource';
use URI;
use URI::QueryParam;

sub api_version {
  1;
}

sub name {
  'Pubmed';
}

sub version {
  '$Revision: 1.8 $';
}

sub understands {
  my ($self, $uri) = @_;

  return 5 if $uri =~ /^\d+$/;  # not a URL but a raw PMID, number only ... return a true but suboptimal score

  my $scheme = $uri->scheme;
  return 1 if $scheme =~ /^pm(?:id)?$/i;
  return 0 unless $scheme eq 'http';
  
  my $host = $uri->host;
  return 1 if $host =~ /^(?:www|eutils)\.ncbi\.nlm\.nih\.gov$/;
  return 1 if $host =~ /^www\.ncbi\.nlm\.nih\.gov\.proxy\d+\.lib\.umanitoba\.ca$/;  # mirror

  return 0;
}

sub understands_id {
  my ($self, $id_hashref) = @_;
  return 0 unless $id_hashref and ref $id_hashref;
  my $db = $id_hashref->{db} or return 0;
  return 0 unless lc($db) eq 'pubmed';
  my $id = $id_hashref->{pubmed} or return 0;
  return 0 unless $id =~ /^\d+$/;
  return 1;
}

sub filter {
  my ($self, $uri) = @_;
  my $scheme = $uri->scheme;
  return unless $scheme eq 'pm' or $scheme eq 'pmid';
  my $pmid = $uri->opaque;
  $pmid =~ s/\%20//g;
  $pmid =~ s/\D//g;
  return URI->new('http://www.ncbi.nlm.nih.gov/entrez/query.fcgi?cmd=Retrieve&db=pubmed&dopt=Abstract&list_uids='.$pmid);
}

sub citations {
  my ($self, $article_uri) = @_;
  return undef unless $self->understands($article_uri);
  my ($db, $id);
  eval {
    $db = $article_uri->query_param('db') or die "no db parameter\n";
    $id = $article_uri->query_param('list_uids') or die "no list_uids parameter\n";
  };
  die $@ if $@ =~ /at .* line \d+/;
  $self->errstr($@), return undef if $@;
  return $self->citations_id({db => $db, pubmed => $id});
}

sub citations_id {
  my ($self, $id_hashref) = @_;

  my $io;
  eval {
    die "do not understand id\'s\n" unless $self->understands_id($id_hashref);

    my $query_uri = new URI ('http://eutils.ncbi.nlm.nih.gov/entrez/eutils/efetch.fcgi?retmode=xml');
    $query_uri->query_param(db => $id_hashref->{db});
    $query_uri->query_param(id => $id_hashref->{pubmed});

    my $xml = $self->get($query_uri)
	or die "XML retrieval failed\n";

    if ($xml =~ m|<Error[^>]*>(.*)</Error>|si) {
      die "Error message from Pubmed server: $1\n";
    }

    $io = new Bio::Biblio::IO (-data => $xml, -format => 'pubmedxml')
	or die "IO object false\n";
  };
  die $@ if $@ =~ /at .* line \d+/;
  $self->errstr($@), return undef if $@;

  # we cannot simply rebless as I'd prefer because Bioperl uses child classes
  return Bibliotech::CitationSource::Pubmed::ResultList->new ($io);
}

package Bibliotech::CitationSource::Pubmed::ResultList;
use base ('Class::Accessor::Fast', 'Bibliotech::CitationSource::ResultList');

__PACKAGE__->mk_accessors(qw/io/);

sub new {
  my ($class, $io) = @_;
  my $self = bless {}, ref $class || $class;
  $self->io($io);
  return $self;
}

sub fetch {
  my $article = shift->io->next_bibref or return undef;
  # we cannot simply rebless as I'd prefer because Bioperl uses child classes
  return Bibliotech::CitationSource::Pubmed::Result->new ($article);
}

package Bibliotech::CitationSource::Pubmed::Result;
use base ('Class::Accessor::Fast', 'Bibliotech::CitationSource::Result');

__PACKAGE__->mk_accessors(qw/article/);

sub new {
  my ($class, $article) = @_;
  my $self = bless {}, ref $class || $class;
  $self->article($article);
  return $self;
}

sub type {
  'Pubmed';
}

sub source {
  'Pubmed database at eutils.ncbi.nlm.nih.gov';
}

sub identifiers {
  my ($self) = @_;
  my %id;
  foreach (@{$self->article->pubmed_article_id_list}) {
    $id{lc($_->{idType})} = $_->{id};
  }
  return \%id;
}

# base class version would work, this is just an miniscule bit more efficient
sub identifier {
  my ($self, $key) = @_;
  $key = lc $key;
  foreach (@{$self->article->pubmed_article_id_list}) {
    return $_->{id} if lc($_->{idType}) eq $key;
  }
  return undef;
}

sub page   { shift->article->medline_page; }
sub title  { shift->article->title; }
sub volume { shift->article->volume; }
sub issue  { shift->article->issue; }
sub date   { shift->article->date; }
sub last_modified_date { shift->article->last_modified_date; }

sub authors {
  my $authors = shift->article->authors || [];
  my $new_authors = new Bibliotech::CitationSource::Result::AuthorList;
  foreach my $author (@{$authors}) {
    $new_authors->push(Bibliotech::CitationSource::Pubmed::Result::Author->new($author));
  }
  return $new_authors;
}

sub journal {
  my $journal = shift->article->journal or return undef;
  return Bibliotech::CitationSource::Pubmed::Result::Journal->new($journal);
}

package Bibliotech::CitationSource::Pubmed::Result::Author;
use base 'Class::Accessor::Fast';

__PACKAGE__->mk_accessors(qw/author/);

sub new {
  my ($class, $author) = @_;
  my $self = bless {}, ref $class || $class;
  $self->author($author);
  return $self;
}

sub AUTOLOAD {
  (my $name = our $AUTOLOAD) =~ s/.*:://;
  return if $name eq 'DESTROY';
  my $self = shift;
  my $author = $self->author;
  return $author->$name(@_) if $author->can($name);
  no strict 'refs';
  return &{'Bibliotech::CitationSource::Result::Author::'.$name}(@_) if Bibliotech::CitationSource::Result::Author->can($name);
  die "cannot handle $name";
}

package Bibliotech::CitationSource::Pubmed::Result::Journal;
use base 'Class::Accessor::Fast';

__PACKAGE__->mk_accessors(qw/journal/);

sub new {
  my ($class, $journal) = @_;
  my $self = bless {}, ref $class || $class;
  $self->journal($journal);
  return $self;
}

sub AUTOLOAD {
  (my $name = our $AUTOLOAD) =~ s/.*:://;
  return if $name eq 'DESTROY';
  my $self = shift;
  my $journal = $self->journal;
  return $journal->$name(@_) if $journal->can($name);
  no strict 'refs';
  return &{'Bibliotech::CitationSource::Result::Journal::'.$name}(@_) if Bibliotech::CitationSource::Result::Journal->can($name);
  die "cannot handle $name";
}

1;
__END__