-This is the Common Lisp PubMed package.
+This is the Common Lisp Entrez package.
This package is written and Copyright (C) 2000-2002 by
Kevin M. Rosenberg <kevin@rosenberg.net>
The web site for this package is http://pubmed.kpe.io/
-
Prerequisites
=============
- The ASDF system definition facility, available for download at
Installation
============
- Debian:
- evaluate (require 'pubmed)
+ evaluate (require 'entrez)
- Other Operating Systems:
- 1. Install the ASDF, KMRCL, and PubMed packages into directories
+ 1. Install the ASDF, KMRCL, and Entrez packages into directories
of your choice.
2. Load asdf.lisp.
- 3. Push the names of the directories containing the KMRCL and PubMed
+ 3. Push the names of the directories containing the KMRCL and Entrez
files on to the asdf:*central-registry* list.
2. Load kmrcl.asd from the KMRCL package.
- 3. Load pubmed.asd from the PubMed package.
- 4. Evaluate (asdf:oos 'asdf:load-op 'pubmed).
+ 3. Load entrez.asd from the Entrez package.
+ 4. Evaluate (asdf:oos 'asdf:load-op 'entrez).
USAGE
To use this package in Debian, execute
-(clc:require 'pubmed)
+(clc:require 'entrez)
in your Lisp environment.
-cl-pubmed (2.1.3-5) unstable; urgency=low
-
- * Build with debhelper extension dh-lisp
- * control: Add Vcs-Browser field.
-
- -- Kevin M. Rosenberg <kmr@debian.org> Mon, 03 Aug 2009 18:42:04 -0600
-
-cl-pubmed (2.1.3-4) unstable; urgency=low
-
- * control: Really add Vcs-Git and Homepage fields.
-
- -- Kevin M. Rosenberg <kmr@debian.org> Sun, 02 Aug 2009 01:44:07 -0600
-
-cl-pubmed (2.1.3-3) unstable; urgency=low
-
- * debian/watch: New file
- * debian/control: Require debhelper 7. Change to new lisp section.
- Add Vcs-Git and Homepage fields.
- * debian/compat: Update to version 7
- * debian/rules: Update for debhelper 7, architecture-independent build
- * debian/{prerm,postrm}: Remove path from binary function
-
- -- Kevin M. Rosenberg <kmr@debian.org> Sun, 02 Aug 2009 01:41:26 -0600
-
-cl-pubmed (2.1.3-2) unstable; urgency=low
-
- * debian/rules: don't export DH_COMPAT
- * debian/control: Use build-depends, update standards-version
-
- -- Kevin M. Rosenberg <kmr@debian.org> Sun, 09 Sep 2007 19:28:07 -0600
-
-cl-pubmed (2.1.3-1) unstable; urgency=low
-
- * New upstream
-
- -- Kevin M. Rosenberg <kmr@debian.org> Sat, 17 Apr 2004 12:24:07 -0600
-
-cl-pubmed (2.1.2-1) unstable; urgency=low
-
- * Support proxy server
-
- -- Kevin M. Rosenberg <kmr@debian.org> Thu, 15 Apr 2004 00:47:01 -0600
-
-cl-pubmed (2.1.1-1) unstable; urgency=low
-
- * New upstream
-
- -- Kevin M. Rosenberg <kmr@debian.org> Thu, 12 Jun 2003 06:16:58 -0600
-
-cl-pubmed (2.1.0-1) unstable; urgency=low
+cl-entrez (0.1-1) unstable; urgency=low
* New upstream
- -- Kevin M. Rosenberg <kmr@debian.org> Fri, 6 Jun 2003 16:04:55 -0600
-
-cl-pubmed (2.0.2-1) unstable; urgency=low
-
- * Improve .asd file
-
- -- Kevin M. Rosenberg <kmr@debian.org> Tue, 6 May 2003 10:24:12 -0600
-
-cl-pubmed (2.0.1-1) unstable; urgency=low
-
- * Remove 'load-compiled-op from .asd file
-
- -- Kevin M. Rosenberg <kmr@debian.org> Mon, 2 Dec 2002 11:42:38 -0700
-
-cl-pubmed (2.0-1) unstable; urgency=low
-
- * Rename classes and accessors to be more friendly for importing into
- another package. Export more functions.
- * Add article-equal function
- * Add server-error condition
- * Fix bug
-
- -- Kevin M. Rosenberg <kmr@debian.org> Thu, 31 Oct 2002 07:07:34 -0700
-
-cl-pubmed (1.2-1) unstable; urgency=low
-
- * Fix extraneous colon bug and change in XML tag from
- Descriptor to DescriptorName
-
- -- Kevin M. Rosenberg <kmr@debian.org> Wed, 30 Oct 2002 19:01:36 -0700
-
-cl-pubmed (1.1.1-1) unstable; urgency=low
-
- * README: Add prerequisites and installation instructions.
-
- -- Kevin M. Rosenberg <kmr@debian.org> Wed, 30 Oct 2002 18:34:56 -0700
-
-cl-pubmed (1.1-1) unstable; urgency=low
-
- * Fix bug in .asd file
-
- -- Kevin M. Rosenberg <kmr@debian.org> Wed, 30 Oct 2002 14:18:11 -0700
-
-cl-pubmed (1.0-1) unstable; urgency=low
-
- * Initial release (closes: 166482)
-
- -- Kevin M. Rosenberg <kmr@debian.org> Tue, 22 Oct 2002 09:57:38 -0600
-
+ -- Kevin M. Rosenberg <kmr@debian.org> Tue, 09 Apr 2013 13:34:58 -0600
-Source: cl-pubmed
+Source: cl-entrez
Section: lisp
Priority: optional
Maintainer: Kevin M. Rosenberg <kmr@debian.org>
Vcs-Git: git://git.kpe.io/pubmed.git
Vcs-Browser: http://git.kpe.io/?p=pubmed.git
-Package: cl-pubmed
+Package: cl-entrez
Architecture: all
Depends: ${misc:Depends}, cl-kmrcl, cl-aserve
Description: Common Lisp package to query Pubmed medical literature database
- This library has functions for querying the PubMed medical literature
+ This library has functions for querying the Pubmed medical literature
database and parsing the XML results into Common Lisp objects. This package
uses the cl-aserve for HTTP fetches.
Upstream Author: Kevin M. Rosenberg <kevin@rosenberg.net>
-Copyright (c) 2000-2002 Kevin M. Rosenberg
+Copyright (c) 2000-2013 Kevin M. Rosenberg
This code is free software; you can redistribute it and/or modify it
under the terms of the version 2.1 of the GNU Lesser General Public
#!/usr/bin/make -f
-pkg := pubmed
-debpkg := cl-pubmed
+pkg := entrez
+debpkg := cl-entrez
clc-source := usr/share/common-lisp/source
clc-systems := usr/share/common-lisp/systems
dh_testroot
dh_prep
dh_installdirs
- dh_install pubmed.asd $(clc-files)
+ dh_install entrez.asd $(clc-files)
dh_install *.lisp $(clc-files)
binary-indep: install
#!/bin/bash -e
-dup pubmed -Ufiles.med-info.com -D/home/ftp/pubmed -C"(umask 022; cd /opt/apache/htdocs/pubmed; make install)" -su $*
+dup entrez -Ufiles.med-info.com -D/home/ftp/entrez -C"(umask 022; cd /opt/apache/htdocs/entrez; make install)" -su $*
--- /dev/null
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name: entrez.asd
+;;;; Purpose: ASDF definition file for Entrez
+;;;; Programmer: Kevin M. Rosenberg
+;;;; Date Started: Sep 2002
+;;;;
+;;;; This file, part of cl-entrez, is Copyright (c) 2002-2013 by Kevin M. Rosenberg
+;;;;
+;;;; cl-entrez users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the GNU Lesser General Public License
+;;;; (http://www.gnu.org/licenses/lgpl.html)
+;;;; *************************************************************************
+
+(in-package #:cl-user)
+(defpackage #:entrez-system (:use #:asdf #:cl))
+(in-package #:entrez-system)
+
+#+allegro (require :aserve)
+
+;; only define system on implementations that aserve is available
+(defsystem entrez
+ :name "cl-entrez"
+ :author "Kevin M. Rosenberg <kevin@rosenberg.net>"
+ :version "2.1"
+ :maintainer "Kevin M. Rosenberg <kmr@debian.org>"
+ :licence "GNU Lesser General Public License"
+ :description "Library for querying the Entrez medical literature database"
+ :long-description "This library has functions for querying the Entrez medical literature database and parsing the XML results into Common Lisp objects."
+
+ :components ((:file "package")
+ (:file "entrez" :depends-on ("package")))
+
+ :depends-on (:kmrcl #-allegro :aserve))
--- /dev/null
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name: entrez.lisp
+;;;; Purpose: Library to access NCBI Entrez web application
+;;;; Programmer: Kevin M. Rosenberg
+;;;; Date Started: April 2013
+;;;;
+;;;; This file, part of cl-entrez, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;;
+;;;; cl-entrez users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the GNU Lesser General Public License
+;;;; (http://www.gnu.org/licenses/lgpl.html)
+;;;; *************************************************************************
+
+(in-package #:entrez)
+
+
+(defparameter +entrez-host+ "eutils.ncbi.nlm.nih.gov")
+(defparameter +entrez-search-url+ "/entrez/eutils/esearch.fcgi")
+(defparameter +entrez-fetch-url+ "/entrez/eutils/efetch.fcgi")
+(defparameter +entrez-summary-url+ "/entrez/eutils/esummary.fcgi")
+(defparameter *proxy-host* nil)
+
+
+(define-condition entrez-condition ()
+ ())
+
+
+(define-condition entrez-server-error (error entrez-condition)
+ ((response :initarg :response
+ :initform nil
+ :reader entrez-condition-response))
+ (:report (lambda (c stream)
+ (format stream "A Entrez server error occurred.")
+ (awhen (entrez-condition-response c)
+ (format stream " The server response was:~&~S" it)))))
+
+(define-condition entrez-query-error (error entrez-condition)
+ ((response :initarg :response
+ :initform nil
+ :reader entrez-condition-response))
+ (:report (lambda (c stream)
+ (format stream "A Entrez server error occurred.")
+ (awhen (entrez-condition-response c)
+ (format stream " The server response was:~&~S" it)))))
+
+;;; Article-Set and Article Classes
+
+(defclass pm-article-set ()
+ ((query :type string :initarg :query :accessor articles-query)
+ (webenv :type string :initarg :webenv :accessor articles-webenv)
+ (qkey :type string :initarg :qkey :accessor articles-qkey)
+ (articles :type list :initarg :articles :accessor articles)
+ (total :type fixnum :initarg :total :accessor articles-total)
+ (count :type fixnum :initarg :count :accessor articles-count)
+ (start :type fixnum :initarg :start :accessor articles-start))
+ (:documentation "Entrez Article Set Class")
+ (:default-initargs :total 0 :start 0 :count 0 :query nil
+ :articles nil :qkey nil :webenv nil))
+
+(defclass equery ()
+ ((query :type string :initarg :query :accessor query)
+ (wenv :type string :initarg :webenv :accessor wenv)
+ (qkey :type string :initarg :qkey :accessor qkey)
+ (qcount :type fixnum :initarg :qcount :accessor qcount))
+ (:documentation "Entrez EQuery Results Class")
+ (:default-initargs :qcount 0 :query nil :qkey nil :webenv nil))
+
+(defclass pm-article ()
+ (
+ (pmid :type integer :accessor article-pmid)
+ (title :type string :accessor article-title)
+ (authors :type list :accessor article-authors)
+ (affiliation :type string :accessor article-affiliation)
+ (journal :type string :accessor article-journal)
+ (date :type string :accessor article-date)
+ (volume :type string :accessor article-volume)
+ (issue :type string :accessor article-issue)
+ (pages :type string :accessor article-pages)
+ (abstract :type string :accessor article-abstract)
+ (mesh-headings :type list :accessor article-mesh-headings))
+ (:documentation "Entrez Article Class"))
+
+(defmethod print-object ((obj pm-article-set) (s stream))
+ (print-unreadable-object (obj s :type t :identity t)
+ (format s "~d total articles, ~d articles starting at #~d"
+ (articles-total obj)
+ (articles-count obj)
+ (articles-start obj)
+ )))
+
+(defmethod print-object ((obj equery) (s stream))
+ (print-unreadable-object (obj s :type t :identity t)
+ (format s "Found ~d with qkey ~a & wenv ~a"
+ (qcount obj)
+ (qkey obj)
+ (wenv obj))))
+
+(defmethod print-object ((obj pm-article) (s stream))
+ (print-unreadable-object (obj s :type t :identity t)
+ (format s "pmid:~d, title:~S" (article-pmid obj)
+ (article-title obj))))
+
+(defun article-equal-p (a b)
+ (check-type a pm-article)
+ (check-type b pm-article)
+ (eql (article-pmid a) (article-pmid b)))
+
+(defun article-ref (art)
+ "Return a string of publication data for an article"
+ (let ((ref ""))
+ (awhen (article-date art)
+ (string-append ref (format nil "~a; " it)))
+ (awhen (article-volume art)
+ (string-append ref it))
+ (awhen (article-issue art)
+ (string-append ref (format nil "(~a)" it)))
+ (awhen (article-pages art)
+ (string-append ref (format nil ":~a" it)))
+ ref))
+
+(defmethod print-article-set ((artset pm-article-set)
+ &key (os *standard-output*) (format :text)
+ (complete nil) (print-link nil))
+ "Display an article set to specified stream in specified format"
+ (dotimes (i (articles-count artset) artset)
+ (if (nth i (articles artset))
+ (print-article (nth i (articles artset)) :os os :format format
+ :complete complete :print-link print-link)
+ (princ "NULL Article" os))))
+
+(defmethod print-article ((art pm-article) &key (os *standard-output*)
+ (format :text) (complete nil) (print-link nil))
+ "Display an article"
+ (ecase format
+ (:text
+ (format os "~a~%~a~%~a~a ~a~%~a~%"
+ (article-title art)
+ (list-to-delimited-string (article-authors art) ", ")
+ (aif (article-affiliation art)
+ (format nil "~a~%" it) "")
+ (article-journal art) (article-ref art)
+ (aif (article-abstract art)
+ (if complete
+ it
+ "Abstract available")
+ "No abstract available")
+ (when complete
+ (format os "~a~%" (article-mesh-headings art)))))
+ (:html
+ (let ((has-link (or (article-abstract art) (article-mesh-headings art))))
+ (when (and print-link has-link)
+ (format os "<a href=\"~A\">" (funcall print-link
+ (article-pmid art))))
+ (format os "<div class=\"article-title\">~a</div>~%"
+ (article-title art))
+ (when (and print-link has-link)
+ (format os "</a>"))
+ (format os "<div class=\"article-authors\">~a</div>~%"
+ (list-to-delimited-string (article-authors art) ", "))
+ (format os "<div class=\"article-reference\">~a ~a</div>~%"
+ (article-journal art) (article-ref art))
+ (when (and complete (article-abstract art))
+ (format os "<div class=\"article-abstract\">~a</div>~%"
+ (article-abstract art)))
+ (when (and complete (article-mesh-headings art))
+ (format os "<div class=\"mesh-heading-title\">Mesh Headings:</div>")
+ (dolist (mh (article-mesh-headings art))
+ (format os "<div class=\"mesh-heading\">~a</div>~%" mh)))
+ (format os "<p/>~%"))))
+ art)
+
+
+;;; Entrez Query Functions
+
+(defun equery (searchstr &key (db "pubmed") (usehistory t) start max)
+ "Performs Entrez query and returns article-set structure"
+ (multiple-value-bind
+ (xmlres ids) (do-equery searchstr :db db :usehistory usehistory :start start :max max)
+ (when (xml-tag-contents "Count" xmlres)
+ (let ((as (make-instance 'equery)))
+ (setf
+ (qcount as) (parse-integer (xml-tag-contents "Count" xmlres))
+ (query as) searchstr)
+ (kmrcl:awhen (xml-tag-contents "WebEnv" xmlres)
+ (setf (wenv as) kmrcl:it))
+ (kmrcl:awhen (xml-tag-contents "QueryKey" xmlres)
+ (setf (qkey as) kmrcl:it))
+ as))))
+
+(defun esummary (as &key maximum start)
+;; (articles as) (extract-article-set results))
+ as)
+
+(defun pm-fetch-ids (pmids)
+ "Fetchs list of Entrez ID's and returns pm-article-set class"
+ (setq pmids (mklist pmids))
+ (let ((results (entrez-fetch-pmids-xml pmids)))
+ (unless (xml-tag-contents "Error" results)
+ (let ((as (make-instance 'pm-article-set)))
+ (setf
+ (articles-total as) (length pmids)
+ (articles-query as) (list-to-delimited-string pmids #\,)
+ (articles-start as) 0
+ (articles-count as) (length pmids)
+ (articles as) (extract-article-set results))
+ as))))
+
+#+ignore
+(defun entrez-search-tree (searchstr &key maximum start)
+ "Performs a entrez search and returns two values:
+tree of Entrez search results and tree of Entrez search status"
+ (multiple-value-bind
+ (xml-search-results xml-search-status)
+ (entrez-search-xml searchstr :maximum maximum :start start)
+ (if xml-search-results
+ (values (parse-xml-no-ws xml-search-results)
+ (parse-xml-no-ws xml-search-status))
+ (values nil (parse-xml-no-ws xml-search-status)))))
+
+(defun do-equery (term &key (db "pubmed") start max (usehistory t))
+ "Performs a Entrez search and returns two values:
+XML string of Entrez search results and XML search status"
+ (let ((res (http-equery term :start start :max max
+ :usehistory usehistory :db db)))
+ (values res (extract-pmid-list res))))
+
+(defun http-equery (term &key start max (usehistory t)
+ (db "pubmed"))
+ "Performs a Entrez search and returns XML results of Entrez search
+ which contains Entrez ID's and status results"
+ (let* ((alist `(("db" . ,db) ("term" . ,term)))
+ (geturl (format nil "http://~a~a" +entrez-host+ +entrez-search-url+)))
+ (when usehistory
+ (setq alist (acons "usehistory" "y" alist)))
+ (when start
+ (setq alist (acons "retstart" start alist)))
+ (when max
+ (setq alist (acons "retmax" max alist)))
+ (multiple-value-bind (xmlres http-code http-server-alist)
+ (net.aserve.client:do-http-request
+ geturl
+ :method :get
+ :query alist
+ :proxy *proxy-host*)
+ (declare (ignore http-server-alist))
+ (when (not (equal http-code 200))
+ (error "HTTP code performing '~A' was ~D." geturl http-code))
+ xmlres)))
+
+(defun entrez-fetch-pmids-xml (pmids &key (db "pubmed"))
+ "Fetch articles for a list of Entrez ID's and return XML string"
+ (setq pmids (mklist pmids)) ;; Ensure list
+ (when pmids
+ (net.aserve.client:do-http-request
+ (format nil "http://~a~a" +entrez-host+ +entrez-fetch-url+)
+ :method :get
+ :query
+ `(("db" . ,db) ("report" . "xml") ("mode" . "text")
+ ("id" . ,(list-to-delimited-string pmids #\,)))
+ :proxy *proxy-host*)))
+
+;;; XML Extraction Routines
+
+(defun extract-article-set (results)
+ "Extract article set from Entrez XML string, return results in pm-article-set class"
+ (multiple-value-bind (as-start as-end as-next)
+ (positions-xml-tag-contents "PubmedArticleSet" results)
+ (declare (ignore as-end as-next))
+ (when as-start
+ (let ((done nil)
+ (articles '())
+ (pos as-start))
+ (until done
+ (multiple-value-bind
+ (a-start a-end a-next)
+ (positions-xml-tag-contents "PubmedArticle" results pos)
+ (if a-start
+ (progn
+ (push (extract-article results a-start a-end) articles)
+ (setq pos a-next)
+ )
+ (setq done t))))
+ (nreverse articles)))))
+
+(defun extract-article (xmlstr a-start a-end)
+ "Extract article contents from Entrez XML string and return results in pm-article class"
+ (let ((article (make-instance 'pm-article)))
+ (setf
+ (article-pmid article) (parse-integer (xml-tag-contents "PMID" xmlstr a-start a-end))
+ (article-title article) (xml-tag-contents "ArticleTitle" xmlstr a-start a-end)
+ (article-journal article) (xml-tag-contents "MedlineTA" xmlstr a-start a-end)
+ (article-pages article) (xml-tag-contents "MedlinePgn" xmlstr a-start a-end)
+ (article-affiliation article) (xml-tag-contents "Affiliation" xmlstr a-start a-end)
+ (article-abstract article) (xml-tag-contents "AbstractText" xmlstr a-start a-end))
+ (multiple-value-bind (ji-start ji-end ji-next)
+ (positions-xml-tag-contents "JournalIssue" xmlstr a-start a-end)
+ (declare (ignore ji-next))
+ (setf
+ (article-volume article) (xml-tag-contents "Volume" xmlstr ji-start ji-end)
+ (article-issue article) (xml-tag-contents "Issue" xmlstr ji-start ji-end))
+ (aif (xml-tag-contents "MedlineDate" xmlstr ji-start ji-end)
+ (setf (article-date article) it)
+ (setf (article-date article)
+ (concatenate 'string (xml-tag-contents "Year" xmlstr ji-start ji-end)
+ (aif (xml-tag-contents "Month" xmlstr ji-start ji-end)
+ (format nil " ~a" it)
+ "")))))
+
+ (multiple-value-bind (al-start al-end al-next)
+ (positions-xml-tag-contents "AuthorList" xmlstr a-start a-end)
+ (declare (ignore al-next))
+ (setf (article-authors article)
+ (when al-start
+ (let ((done nil)
+ (authors '())
+ (pos al-start))
+ (until done
+ (multiple-value-bind
+ (au-start au-end au-next)
+ (positions-xml-tag-contents "Author" xmlstr pos al-end)
+ (if au-start
+ (progn
+ (push (extract-author xmlstr au-start au-end) authors)
+ (setq pos au-next))
+ (setq done t))))
+ (nreverse authors)))))
+
+ (multiple-value-bind (mhl-start mhl-end mhl-next)
+ (positions-xml-tag-contents "MeshHeadingList" xmlstr a-start a-end)
+ (declare (ignore mhl-next))
+ (setf (article-mesh-headings article)
+ (when mhl-start
+ (let ((done nil)
+ (mesh-headings '())
+ (pos mhl-start))
+ (until done
+ (multiple-value-bind
+ (mh-start mh-end mh-next)
+ (positions-xml-tag-contents "MeshHeading" xmlstr pos mhl-end)
+ (if mh-start
+ (progn
+ (push (extract-mesh-heading xmlstr mh-start mh-end) mesh-headings)
+ (setq pos mh-next)
+ )
+ (setq done t))))
+ (nreverse mesh-headings)))))
+
+ article))
+
+(defun extract-author (xmlstr start end)
+ "Extract author name from XML string"
+ (let ((last-name (xml-tag-contents "LastName" xmlstr start end))
+ (initials (xml-tag-contents "Initials" xmlstr start end)))
+ (concatenate 'string last-name " " initials)))
+
+(defun extract-mesh-heading (xmlstr start end)
+ "Extract and format mesh headings from XML string"
+ (let ((desc (xml-tag-contents "DescriptorName" xmlstr start end))
+ (sh (xml-tag-contents "SubHeading" xmlstr start end)))
+ (if sh
+ (format nil "~a(~a)" desc sh)
+ desc)))
+
+(defun extract-pmid-list (results)
+ "Returns list of Entrez ID's from XML result string"
+ (cond
+ ((search "<ERROR>" results)
+ (error 'entrez-query-error :response results))
+ ((search "<H1>Server Error</H1>" results)
+ (error 'entrez-server-error :response results))
+ (t
+ (awhen (xml-tag-contents "Id" results)
+ (delimited-string-to-list it #\space)))))
;;;; FILE IDENTIFICATION
;;;;
;;;; Name: package.lisp
-;;;; Purpose: Package file for cl-pubmed
+;;;; Purpose: Package file for cl-entrez
;;;; Programmer: Kevin M. Rosenberg
;;;; Date Started: Jun 2001
;;;;
-;;;; $Id$
-;;;;
-;;;; This file, part of cl-pubmed, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;; This file, part of cl-pubmed, is Copyright (c) 2002-2013 by Kevin M. Rosenberg
;;;;
;;;; cl-pubmed users are granted the rights to distribute and use this software
;;;; as governed by the terms of the GNU Lesser General Public License
(in-package #:cl-user)
-(defpackage #:pubmed
+(defpackage #:entrez
(:use #:common-lisp #:kmrcl)
(:export
;; Conditions
- #:pubmed-condition
- #:pubmed-query-error
- #:pubmed-server-error
- #:pubmed-condition-response
+ #:entrez-condition
+ #:entrez-query-error
+ #:entrez-server-error
+ #:entrez-condition-response
;; Query functions
- #:pm-query
+ #:equery
+ #:esummary
+ #:efetch
#:pm-fetch-ids
;; Print functions
+++ /dev/null
-;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
-;;;; *************************************************************************
-;;;; FILE IDENTIFICATION
-;;;;
-;;;; Name: pubmed-src.lisp
-;;;; Purpose: Library to access PubMed web application
-;;;; Programmer: Kevin M. Rosenberg
-;;;; Date Started: Jun 2001
-;;;;
-;;;; $Id$
-;;;;
-;;;; This file, part of cl-pubmed, is Copyright (c) 2002 by Kevin M. Rosenberg
-;;;;
-;;;; cl-pubmed users are granted the rights to distribute and use this software
-;;;; as governed by the terms of the GNU Lesser General Public License
-;;;; (http://www.gnu.org/licenses/lgpl.html)
-;;;; *************************************************************************
-
-(in-package #:pubmed)
-
-
-(defparameter +pubmed-host+ "www.ncbi.nlm.nih.gov")
-(defparameter +pubmed-query-url+ "/entrez/utils/pmqty.fcgi")
-(defparameter +pubmed-fetch-url+ "/entrez/utils/pmfetch.fcgi")
-(defparameter *proxy-host* nil)
-
-
-(define-condition pubmed-condition ()
- ())
-
-
-(define-condition pubmed-server-error (error pubmed-condition)
- ((response :initarg :response
- :initform nil
- :reader pubmed-condition-response))
- (:report (lambda (c stream)
- (format stream "A PubMed server error occurred.")
- (awhen (pubmed-condition-response c)
- (format stream " The server response was:~&~S" it)))))
-
-(define-condition pubmed-query-error (error pubmed-condition)
- ((response :initarg :response
- :initform nil
- :reader pubmed-condition-response))
- (:report (lambda (c stream)
- (format stream "A PubMed server error occurred.")
- (awhen (pubmed-condition-response c)
- (format stream " The server response was:~&~S" it)))))
-
-;;; Article-Set and Article Classes
-
-(defclass pm-article-set ()
- ((query :type string :initarg :query :accessor articles-query)
- (articles :type list :initarg :articles :accessor articles)
- (total :type fixnum :initarg :total :accessor articles-total)
- (count :type fixnum :initarg :count :accessor articles-count)
- (start :type fixnum :initarg :start :accessor articles-start))
- (:documentation "Pubmed Article Set Class")
- (:default-initargs :total 0 :start 0 :count 0
- :query nil :articles nil))
-
-(defclass pm-article ()
- (
- (pmid :type integer :accessor article-pmid)
- (title :type string :accessor article-title)
- (authors :type list :accessor article-authors)
- (affiliation :type string :accessor article-affiliation)
- (journal :type string :accessor article-journal)
- (date :type string :accessor article-date)
- (volume :type string :accessor article-volume)
- (issue :type string :accessor article-issue)
- (pages :type string :accessor article-pages)
- (abstract :type string :accessor article-abstract)
- (mesh-headings :type list :accessor article-mesh-headings))
- (:documentation "Pubmed Article Class"))
-
-(defmethod print-object ((obj pm-article-set) (s stream))
- (print-unreadable-object (obj s :type t :identity t)
- (format s "~d total articles, ~d articles starting at #~d"
- (articles-total obj)
- (articles-count obj)
- (articles-start obj)
- )))
-
-(defmethod print-object ((obj pm-article) (s stream))
- (print-unreadable-object (obj s :type t :identity t)
- (format s "pmid:~d, title:~S" (article-pmid obj)
- (article-title obj))))
-
-(defun article-equal-p (a b)
- (check-type a pm-article)
- (check-type b pm-article)
- (eql (article-pmid a) (article-pmid b)))
-
-(defun article-ref (art)
- "Return a string of publication data for an article"
- (let ((ref ""))
- (awhen (article-date art)
- (string-append ref (format nil "~a; " it)))
- (awhen (article-volume art)
- (string-append ref it))
- (awhen (article-issue art)
- (string-append ref (format nil "(~a)" it)))
- (awhen (article-pages art)
- (string-append ref (format nil ":~a" it)))
- ref))
-
-(defmethod print-article-set ((artset pm-article-set)
- &key (os *standard-output*) (format :text)
- (complete nil) (print-link nil))
- "Display an article set to specified stream in specified format"
- (dotimes (i (articles-count artset) artset)
- (if (nth i (articles artset))
- (print-article (nth i (articles artset)) :os os :format format
- :complete complete :print-link print-link)
- (princ "NULL Article" os))))
-
-(defmethod print-article ((art pm-article) &key (os *standard-output*)
- (format :text) (complete nil) (print-link nil))
- "Display an article"
- (ecase format
- (:text
- (format os "~a~%~a~%~a~a ~a~%~a~%"
- (article-title art)
- (list-to-delimited-string (article-authors art) ", ")
- (aif (article-affiliation art)
- (format nil "~a~%" it) "")
- (article-journal art) (article-ref art)
- (aif (article-abstract art)
- (if complete
- it
- "Abstract available")
- "No abstract available")
- (when complete
- (format os "~a~%" (article-mesh-headings art)))))
- (:html
- (let ((has-link (or (article-abstract art) (article-mesh-headings art))))
- (when (and print-link has-link)
- (format os "<a href=\"~A\">" (funcall print-link
- (article-pmid art))))
- (format os "<div class=\"article-title\">~a</div>~%"
- (article-title art))
- (when (and print-link has-link)
- (format os "</a>"))
- (format os "<div class=\"article-authors\">~a</div>~%"
- (list-to-delimited-string (article-authors art) ", "))
- (format os "<div class=\"article-reference\">~a ~a</div>~%"
- (article-journal art) (article-ref art))
- (when (and complete (article-abstract art))
- (format os "<div class=\"article-abstract\">~a</div>~%"
- (article-abstract art)))
- (when (and complete (article-mesh-headings art))
- (format os "<div class=\"mesh-heading-title\">Mesh Headings:</div>")
- (dolist (mh (article-mesh-headings art))
- (format os "<div class=\"mesh-heading\">~a</div>~%" mh)))
- (format os "<p/>~%"))))
- art)
-
-
-;;; PubMed Query Functions
-
-(defun pm-query (searchstr &key maximum start)
- "Performs PubMed query and fetch and returns article-set structure"
- (multiple-value-bind
- (results status)
- (pubmed-search-xml searchstr :maximum maximum :start start)
- (when (xml-tag-contents "Count" status)
- (let ((as (make-instance 'pm-article-set)))
- (setf
- (articles-total as) (parse-integer (xml-tag-contents "Count" status))
- (articles-query as) searchstr
- (articles-start as) (parse-integer (xml-tag-contents "DispStart" status))
- (articles-count as) (parse-integer (xml-tag-contents "DispMax" status))
- (articles as) (extract-article-set results))
- as))))
-
-(defun pm-fetch-ids (pmids)
- "Fetchs list of Pubmed ID's and returns pm-article-set class"
- (setq pmids (mklist pmids))
- (let ((results (pubmed-fetch-pmids-xml pmids)))
- (unless (xml-tag-contents "Error" results)
- (let ((as (make-instance 'pm-article-set)))
- (setf
- (articles-total as) (length pmids)
- (articles-query as) (list-to-delimited-string pmids #\,)
- (articles-start as) 0
- (articles-count as) (length pmids)
- (articles as) (extract-article-set results))
- as))))
-
-#+ignore
-(defun pubmed-search-tree (searchstr &key maximum start)
- "Performs a pubmed search and returns two values:
-tree of PubMed search results and tree of PubMed search status"
- (multiple-value-bind
- (xml-search-results xml-search-status)
- (pubmed-search-xml searchstr :maximum maximum :start start)
- (if xml-search-results
- (values (parse-xml-no-ws xml-search-results)
- (parse-xml-no-ws xml-search-status))
- (values nil (parse-xml-no-ws xml-search-status)))))
-
-(defun pubmed-search-xml (searchstr &key maximum start)
- "Performs a Pubmed search and returns two values:
-XML string of PubMed search results and XML search status"
- (multiple-value-bind
- (pmids search-status)
- (pubmed-query-xml searchstr :maximum maximum :start start)
- (values (pubmed-fetch-pmids-xml pmids) search-status)))
-
-(defun pubmed-query-xml (searchstr &key maximum start)
- "Performs a Pubmed search and returns two values:
- list of PubMed ID's that match search string and XML search status"
- (let ((search-results (pubmed-query-status searchstr :maximum maximum :start start)))
- (values (extract-pmid-list search-results) search-results)))
-
-(defun pubmed-query-status (searchstr &key start maximum)
- "Performs a Pubmed search and returns XML results of PubMed search
- which contains PubMed ID's and status results"
- (let ((query-alist `(("db" . "m") ("term" . ,searchstr) ("mode" . "xml"))))
- (when maximum (push (cons "dispmax" maximum) query-alist))
- (when start (push (cons "dispstart" start) query-alist))
- (net.aserve.client:do-http-request
- (format nil "http://~a~a" +pubmed-host+ +pubmed-query-url+)
- :method :get
- :query query-alist
- :proxy *proxy-host*)))
-
-(defun pubmed-fetch-pmids-xml (pmids)
- "Fetch articles for a list of PubMed ID's and return XML string"
- (setq pmids (mklist pmids)) ;; Ensure list
- (when pmids
- (net.aserve.client:do-http-request
- (format nil "http://~a~a" +pubmed-host+ +pubmed-fetch-url+)
- :method :get
- :query
- `(("db" . "PubMed") ("report" . "xml") ("mode" . "text")
- ("id" . ,(list-to-delimited-string pmids #\,)))
- :proxy *proxy-host*)))
-
-;;; XML Extraction Routines
-
-(defun extract-article-set (results)
- "Extract article set from PubMed XML string, return results in pm-article-set class"
- (multiple-value-bind (as-start as-end as-next)
- (positions-xml-tag-contents "PubmedArticleSet" results)
- (declare (ignore as-end as-next))
- (when as-start
- (let ((done nil)
- (articles '())
- (pos as-start))
- (until done
- (multiple-value-bind
- (a-start a-end a-next)
- (positions-xml-tag-contents "PubmedArticle" results pos)
- (if a-start
- (progn
- (push (extract-article results a-start a-end) articles)
- (setq pos a-next)
- )
- (setq done t))))
- (nreverse articles)))))
-
-(defun extract-article (xmlstr a-start a-end)
- "Extract article contents from PubMed XML string and return results in pm-article class"
- (let ((article (make-instance 'pm-article)))
- (setf
- (article-pmid article) (parse-integer (xml-tag-contents "PMID" xmlstr a-start a-end))
- (article-title article) (xml-tag-contents "ArticleTitle" xmlstr a-start a-end)
- (article-journal article) (xml-tag-contents "MedlineTA" xmlstr a-start a-end)
- (article-pages article) (xml-tag-contents "MedlinePgn" xmlstr a-start a-end)
- (article-affiliation article) (xml-tag-contents "Affiliation" xmlstr a-start a-end)
- (article-abstract article) (xml-tag-contents "AbstractText" xmlstr a-start a-end))
- (multiple-value-bind (ji-start ji-end ji-next)
- (positions-xml-tag-contents "JournalIssue" xmlstr a-start a-end)
- (declare (ignore ji-next))
- (setf
- (article-volume article) (xml-tag-contents "Volume" xmlstr ji-start ji-end)
- (article-issue article) (xml-tag-contents "Issue" xmlstr ji-start ji-end))
- (aif (xml-tag-contents "MedlineDate" xmlstr ji-start ji-end)
- (setf (article-date article) it)
- (setf (article-date article)
- (concatenate 'string (xml-tag-contents "Year" xmlstr ji-start ji-end)
- (aif (xml-tag-contents "Month" xmlstr ji-start ji-end)
- (format nil " ~a" it)
- "")))))
-
- (multiple-value-bind (al-start al-end al-next)
- (positions-xml-tag-contents "AuthorList" xmlstr a-start a-end)
- (declare (ignore al-next))
- (setf (article-authors article)
- (when al-start
- (let ((done nil)
- (authors '())
- (pos al-start))
- (until done
- (multiple-value-bind
- (au-start au-end au-next)
- (positions-xml-tag-contents "Author" xmlstr pos al-end)
- (if au-start
- (progn
- (push (extract-author xmlstr au-start au-end) authors)
- (setq pos au-next))
- (setq done t))))
- (nreverse authors)))))
-
- (multiple-value-bind (mhl-start mhl-end mhl-next)
- (positions-xml-tag-contents "MeshHeadingList" xmlstr a-start a-end)
- (declare (ignore mhl-next))
- (setf (article-mesh-headings article)
- (when mhl-start
- (let ((done nil)
- (mesh-headings '())
- (pos mhl-start))
- (until done
- (multiple-value-bind
- (mh-start mh-end mh-next)
- (positions-xml-tag-contents "MeshHeading" xmlstr pos mhl-end)
- (if mh-start
- (progn
- (push (extract-mesh-heading xmlstr mh-start mh-end) mesh-headings)
- (setq pos mh-next)
- )
- (setq done t))))
- (nreverse mesh-headings)))))
-
- article))
-
-(defun extract-author (xmlstr start end)
- "Extract author name from XML string"
- (let ((last-name (xml-tag-contents "LastName" xmlstr start end))
- (initials (xml-tag-contents "Initials" xmlstr start end)))
- (concatenate 'string last-name " " initials)))
-
-(defun extract-mesh-heading (xmlstr start end)
- "Extract and format mesh headings from XML string"
- (let ((desc (xml-tag-contents "DescriptorName" xmlstr start end))
- (sh (xml-tag-contents "SubHeading" xmlstr start end)))
- (if sh
- (format nil "~a(~a)" desc sh)
- desc)))
-
-(defun extract-pmid-list (results)
- "Returns list of PubMed ID's from XML result string"
- (cond
- ((search "<ERROR>" results)
- (error 'pubmed-query-error :response results))
- ((search "<H1>Server Error</H1>" results)
- (error 'pubmed-server-error :response results))
- (t
- (awhen (xml-tag-contents "Id" results)
- (delimited-string-to-list it #\space)))))
-
-
-
+++ /dev/null
-;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
-;;;; *************************************************************************
-;;;; FILE IDENTIFICATION
-;;;;
-;;;; Name: pubmed.asd
-;;;; Purpose: ASDF definition file for Pubmed
-;;;; Programmer: Kevin M. Rosenberg
-;;;; Date Started: Sep 2002
-;;;;
-;;;; $Id$
-;;;;
-;;;; This file, part of cl-pubmed, is Copyright (c) 2002 by Kevin M. Rosenberg
-;;;;
-;;;; cl-pubmed users are granted the rights to distribute and use this software
-;;;; as governed by the terms of the GNU Lesser General Public License
-;;;; (http://www.gnu.org/licenses/lgpl.html)
-;;;; *************************************************************************
-
-(in-package #:cl-user)
-(defpackage #:pubmed-system (:use #:asdf #:cl))
-(in-package #:pubmed-system)
-
-
-#+(and allegro common-lisp-controller) (c-l-c::clc-require :aserve)
-#+(and allegro (not common-lisp-controller)) (require :aserve)
-
-;; only define system on implementations that aserve is available
-(defsystem pubmed
- :name "cl-pubmed"
- :author "Kevin M. Rosenberg <kevin@rosenberg.net>"
- :version "2.1"
- :maintainer "Kevin M. Rosenberg <kmr@debian.org>"
- :licence "GNU Lesser General Public License"
- :description "Library for querying the PubMed medical literature database"
- :long-description "This library has functions for querying the PubMed medical literature database and parsing the XML results into Common Lisp objects."
-
- :components ((:file "package")
- (:file "pubmed-src" :depends-on ("package")))
-
- :depends-on (:kmrcl #-allegro :aserve))
-
-
-
projects / pubmed.git / commitdiff