;;;; 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
+;;;; as governed by the terms of the GNU Lesser General Public License
;;;; (http://www.gnu.org/licenses/lgpl.html)
;;;; *************************************************************************
(define-condition pubmed-condition ()
())
-
+
(define-condition pubmed-server-error (error pubmed-condition)
((response :initarg :response
- :initform nil
- :reader pubmed-condition-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)))))
+ (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))
+ :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)))))
-
+ (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 ()
(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))
+ :query nil :articles nil))
(defclass pm-article ()
(
(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)
- )))
+ (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))))
+ (article-title obj))))
(defun article-equal-p (a b)
(check-type a pm-article)
"Return a string of publication data for an article"
(let ((ref ""))
(awhen (article-date art)
- (string-append ref (format nil "~a; " it)))
+ (string-append ref (format nil "~a; " it)))
(awhen (article-volume art)
- (string-append ref it))
+ (string-append ref it))
(awhen (article-issue art)
- (string-append ref (format nil "(~a)" it)))
+ (string-append ref (format nil "(~a)" it)))
(awhen (article-pages art)
- (string-append ref (format nil ":~a" it)))
+ (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))
+ &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)
+ (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))
+ (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)))))
+ (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/>~%"))))
+ (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)
(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)
+ (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))))
+ (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"
(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))))
+ (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:
+ "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 (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:
+ "Performs a Pubmed search and returns two values:
XML string of PubMed search results and XML search status"
- (multiple-value-bind
+ (multiple-value-bind
(pmids search-status)
(pubmed-query-xml searchstr :maximum maximum :start start)
(values (pubmed-fetch-pmids-xml pmids) search-status)))
(net.aserve.client:do-http-request
(format nil "http://~a~a" +pubmed-host+ +pubmed-fetch-url+)
:method :get
- :query
+ :query
`(("db" . "PubMed") ("report" . "xml") ("mode" . "text")
- ("id" . ,(list-to-delimited-string pmids #\,)))
+ ("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)
+ (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)))))
+ (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))
+ (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)
+ (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))
+ (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)
- "")))))
-
+ (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)
+ (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)))))
+ (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)
+ (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)))))
+ (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)))
+ (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)))
+ (sh (xml-tag-contents "SubHeading" xmlstr start end)))
(if sh
- (format nil "~a(~a)" desc sh)
+ (format nil "~a(~a)" desc sh)
desc)))
(defun extract-pmid-list (results)
(error 'pubmed-server-error :response results))
(t
(awhen (xml-tag-contents "Id" results)
- (delimited-string-to-list it #\space)))))
+ (delimited-string-to-list it #\space)))))
projects / pubmed.git / blobdiff