Add entrez package, not currently working
authorKevin M. Rosenberg <kevin@rosenberg.net>
Tue, 9 Apr 2013 19:36:23 +0000 (13:36 -0600)
committerKevin M. Rosenberg <kevin@rosenberg.net>
Tue, 9 Apr 2013 19:36:23 +0000 (13:36 -0600)
13 files changed:
README
debian/README.Debian
debian/changelog
debian/control
debian/copyright
debian/rules
debian/upload.sh
debian/watch
entrez.asd [new file with mode: 0644]
entrez.lisp [new file with mode: 0644]
package.lisp
pubmed-src.lisp [deleted file]
pubmed.asd [deleted file]

diff --git a/README b/README
index 7334158..18755e9 100644 (file)
--- a/README
+++ b/README
@@ -1,9 +1,9 @@
-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.b9.com/
+The web site for this package is http://entrez.b9.com/
 
 
 Prerequisites
@@ -19,17 +19,17 @@ Prerequisites
 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
index 841ad31..bf068dd 100644 (file)
@@ -1,6 +1,6 @@
 To use this package in Debian, execute
 
-(clc:require 'pubmed
+(clc:require 'entrez
 
 in your Lisp environment.
 
index 0daa711..81b0a0d 100644 (file)
@@ -1,102 +1,5 @@
-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
index fca7f11..e4de648 100644 (file)
@@ -1,18 +1,18 @@
-Source: cl-pubmed
+Source: cl-entrez
 Section: lisp
 Priority: optional
 Maintainer: Kevin M. Rosenberg <kmr@debian.org>
 Build-Depends-Indep: dh-lisp
 Build-Depends: debhelper (>= 7.0.0)
 Standards-Version: 3.8.2.0
-Homepage: http://files.b9.com/pubmed/
-Vcs-Git: git://git.b9.com/pubmed.git
-Vcs-Browser: http://git.b9.com/?p=pubmed.git
+Homepage: http://files.b9.com/entrez/
+Vcs-Git: git://git.b9.com/entrez.git
+Vcs-Browser: http://git.b9.com/?p=entrez.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
+Description: Common Lisp package to query Entrez medical literature database
+ This library has functions for querying the Entrez medical literature
  database and parsing the XML results into Common Lisp objects. This package
  uses the cl-aserve for HTTP fetches.
index b4bd7ea..8418831 100644 (file)
@@ -1,11 +1,11 @@
 This package was debianized by Kevin M. Rosenberg <kmr@debian.org> in
 October 2002.
 
-The upstream source was downloaded from http://pubmed.b9.com/
+The upstream source was downloaded from http://entrez.b9.com/
 
 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
index b98847e..a10399d 100755 (executable)
@@ -1,7 +1,7 @@
 #!/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
@@ -19,7 +19,7 @@ install: build
        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
index 49ec2ff..4be6929 100755 (executable)
@@ -1,4 +1,4 @@
 #!/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 $*
 
index 83f0bcf..b8109e0 100644 (file)
@@ -1,2 +1,2 @@
 version=3
-http://files.b9.com/pubmed/pubmed-([\d\.]*)\.tar\.gz
+http://files.b9.com/entrez/entrez-([\d\.]*)\.tar\.gz
diff --git a/entrez.asd b/entrez.asd
new file mode 100644 (file)
index 0000000..727617a
--- /dev/null
@@ -0,0 +1,36 @@
+;;;; -*- 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))
diff --git a/entrez.lisp b/entrez.lisp
new file mode 100644 (file)
index 0000000..89db4c7
--- /dev/null
@@ -0,0 +1,376 @@
+;;;; -*- 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)))))
index b7bfe49..9bb14c6 100644 (file)
@@ -3,13 +3,11 @@
 ;;;; 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
diff --git a/pubmed-src.lisp b/pubmed-src.lisp
deleted file mode 100644 (file)
index ad18ca9..0000000
+++ /dev/null
@@ -1,355 +0,0 @@
-;;;; -*- 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)))))
-
-
-
diff --git a/pubmed.asd b/pubmed.asd
deleted file mode 100644 (file)
index b794be8..0000000
+++ /dev/null
@@ -1,43 +0,0 @@
-;;;; -*- 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))
-
-
-