From dc450ece8ff68c4a459fd47654c11ab28ddc0cc5 Mon Sep 17 00:00:00 2001 From: "Kevin M. Rosenberg" Date: Thu, 31 Oct 2002 19:42:26 +0000 Subject: [PATCH] r3259: *** empty log message *** --- debian/changelog | 10 ++ pubmed.lisp | 339 ++++++++++++++++++++++++++--------------------- 2 files changed, 200 insertions(+), 149 deletions(-) diff --git a/debian/changelog b/debian/changelog index 0295279..20f2cad 100644 --- a/debian/changelog +++ b/debian/changelog @@ -1,3 +1,13 @@ +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 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 diff --git a/pubmed.lisp b/pubmed.lisp index 6b397a8..c20d111 100644 --- a/pubmed.lisp +++ b/pubmed.lisp @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Jun 2001 ;;;; -;;;; $Id: pubmed.lisp,v 1.2 2002/10/31 02:01:07 kevin Exp $ +;;;; $Id: pubmed.lisp,v 1.3 2002/10/31 19:42:26 kevin Exp $ ;;;; ;;;; This file, part of cl-pubmed, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; @@ -22,16 +22,46 @@ (defpackage #:pubmed (:use #:common-lisp #:kmrcl) - (:export #:pm-search - #:disp-article - #:disp-articleset - #:fetch-pmids - #:total-count - #:article-count - #:articles - )) - -(in-package :pubmed) + (:export + + ;; Conditions + #:pubmed-condition + #:pubmed-server-error + + ;; Query functions + #:pm-query + #:pm-fetch-ids + + ;; Print functions + #:print-article + #:print-article-set + + ; Classes + #:pm-article + #:pm-article-set + + ;; pm-article-set accessors + #:articles + #:articles-query + #:articles-total + #:articles-count + #:articles-start + + ;; article accessors + #:article-pmid + #:article-title + #:article-authors + #:article-affiliation + #:article-journal + #:article-date + #:article-volume + #:article-issue + #:article-pages + #:article-abstract + #:article-mesh-headings + )) + +(in-package #:pubmed) (defparameter +pubmed-host+ "www.ncbi.nlm.nih.gov") @@ -39,193 +69,204 @@ (defparameter +pubmed-fetch-url+ "/entrez/utils/pmfetch.fcgi") -;;; ArticleSet and Article Classes - -(defclass pmsearch () - ((search-str :type string :accessor search-str) - (date :type string :accessor date) - (user-id :type fixnum :accessor user-id)) - (:documentation "Pubmed Stored Search Class")) - -(defclass pmarticleset () - ((search-str :type string :initarg :search-str :accessor search-str) - (total-count :type fixnum :initarg :total-count :accessor total-count) - (article-count :type fixnum :initarg :article-count :accessor article-count) - (article-start :type fixnum :initarg :article-start :accessor article-start) - (articles :type list :initarg :articles :accessor articles)) +(define-condition pubmed-condition () + ()) + + +(define-condition pubmed-server-error (error pubmed-condition) + ((response :initarg :response + :initform nil + :reader pubmed-server-error-response)) + (:report (lambda (c stream) + (format stream "A PubMed server error occurred.") + (awhen (pubmed-server-error-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-count 0 :article-start 0 :article-count 0 - :search-str nil :articles nil)) + (:default-initargs :total 0 :start 0 :count 0 + :query nil :articles nil)) -(defclass pmarticle () +(defclass pm-article () ( - (pmid :type integer :accessor pmid) - (title :type string :accessor title) - (authors :type list :accessor authors) - (affiliation :type string :accessor affiliation) - (journal :type string :accessor journal) - (pub-date :type string :accessor pub-date) - (volume :type string :accessor volume) - (issue :type string :accessor issue) - (pages :type string :accessor pages) - (abstract :type string :accessor abstract) - (mesh-headings :type list :accessor mesh-headings)) + (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 pmarticleset) (s stream)) +(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" - (total-count obj) - (article-count obj) - (article-start obj) + (articles-total obj) + (articles-count obj) + (articles-start obj) ))) -(defmethod print-object ((obj pmarticle) (s stream)) +(defmethod print-object ((obj pm-article) (s stream)) (print-unreadable-object (obj s :type t :identity t) - (format s "pmid:~d" (pmid obj)))) -;; (disp-article obj :os s :format :text) + (format s "pmid: ~d" (article-pmid obj)))) -(defun pmarticle-pubdata (art) +(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 ((pubdata "")) - (awhen (pub-date art) - (string-append pubdata (format nil "~a; " it))) - (awhen (volume art) - (string-append pubdata it)) - (awhen (issue art) - (string-append pubdata (format nil "(~a)" it))) - (awhen (pages art) - (string-append pubdata (format nil ":~a" it))) - pubdata)) - -(defmethod disp-articleset ((artset pmarticleset) &key (os *standard-output*) (format :text) - (complete nil) (disp-link t)) + (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 t)) "Display an article set to specified stream in specified format" - (dotimes (i (article-count artset)) - (disp-article (nth i (articles artset)) :os os :format format - :complete complete :disp-link disp-link))) + (dotimes (i (articles-count artset)) + (print-article (nth i (articles artset)) :os os :format format + :complete complete :print-link print-link))) -(defmethod disp-article ((art pmarticle) &key (os *standard-output*) (format :text) - (complete nil) (disp-link t)) +(defmethod print-article ((art pm-article) &key (os *standard-output*) (format :text) + (complete nil) (print-link t)) "Display an article" (if (eql format :text) (format os "~a~%~a~%~a~a ~a~%~a~%" - (title art) - (list-to-delimited-string (authors art) ", ") - (aif (affiliation art) + (article-title art) + (list-to-delimited-string (article-authors art) ", ") + (aif (article-affiliation art) (format nil "~a~%" it) "") - (journal art) (pmarticle-pubdata art) - (if (abstract art) + (article-journal art) (article-ref art) + (aif (article-abstract art) (if complete - (abstract art) + it "Abstract available") "No abstract available") (when complete - (format os "~a~%" (mesh-headings art)))) + (format os "~a~%" (article-mesh-headings art)))) - (let ((has-link (or (abstract art) (mesh-headings art)))) - (when (and disp-link has-link) - (format os "" (make-url "disp-article") (pmid art))) - (format os "
~a
~%" (title art)) - (when (and disp-link has-link) + (let ((has-link (or (article-abstract art) (article-mesh-headings art)))) + (when (and print-link has-link) + (format os "" (make-url "print-article") (article-pmid art))) + (format os "
~a
~%" (article-title art)) + (when (and print-link has-link) (format os "")) (format os "
~a
~%" - (list-to-delimited-string (authors art) ", ")) + (list-to-delimited-string (article-authors art) ", ")) (format os "
~a ~a
~%" - (journal art) (pmarticle-pubdata art)) - (when (and complete (abstract art)) + (article-journal art) (article-ref art)) + (when (and complete (article-abstract art)) (format os "
~a
~%" - (abstract art))) - (when (and complete (mesh-headings art)) + (article-abstract art))) + (when (and complete (article-mesh-headings art)) (format os "
Mesh Headings:
") - (dolist (mh (mesh-headings art)) + (dolist (mh (article-mesh-headings art)) (format os "
~a
~%" mh))) (format os "

~%")))) -;;; PubMed Search Functions +;;; PubMed Query Functions -(defun pm-search (searchstr &key disp-max disp-start) - "Performs PubMed query and fetch and returns articleset structure" +(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 :disp-max disp-max :disp-start disp-start) - (if (xml-tag-contents "Count" status) - (let ((as (make-instance 'pmarticleset))) + (pubmed-search-xml searchstr :maximum maximum :start start) + (when (xml-tag-contents "Count" status) + (let ((as (make-instance 'pm-article-set))) (setf - (total-count as) (parse-integer (xml-tag-contents "Count" status)) - (search-str as) searchstr - (article-start as) (parse-integer (xml-tag-contents "DispStart" status)) - (article-count as) (parse-integer (xml-tag-contents "DispMax" status)) - (articles as) (extract-articleset results)) - as) - nil))) - -(defun fetch-pmids (pmids) - "Fetchs list of Pubmed ID's and returns articleset class" + (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))) - (if (xml-tag-contents "Error" results) - nil - (let ((as (make-instance 'pmarticleset))) + (unless (xml-tag-contents "Error" results) + (let ((as (make-instance 'pm-article-set))) (setf - (total-count as) (length pmids) - (search-str as) (list-to-delimited-string pmids #\,) - (article-start as) 0 - (article-count as) (length pmids) - (articles as) (extract-articleset results)) + (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 disp-max disp-start) +(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 :disp-max disp-max :disp-start disp-start) + (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 disp-max disp-start) +(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 :disp-max disp-max :disp-start disp-start) + (pubmed-query-xml searchstr :maximum maximum :start start) (values (pubmed-fetch-pmids-xml pmids) search-status))) -(defun pubmed-query-xml (searchstr &key disp-max disp-start) +(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 :disp-max disp-max :disp-start disp-start))) + (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 disp-max disp-start) +(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 disp-max (push (cons "dispmax" disp-max) query-alist)) - (when disp-start (push (cons "dispstart" disp-start) query-alist)) - (net.aserve.client:do-http-request (format nil "http://~a~a" +pubmed-host+ +pubmed-query-url+) - :method :get - :query query-alist))) + (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))) (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 - (if 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 #\,)))))) + (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 #\,)))))) ;;; XML Extraction Routines -(defun extract-articleset (results) - "Extract article set from PubMed XML string, return results in pmarticleset class" +(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)) @@ -246,24 +287,24 @@ XML string of PubMed search results and XML search status" (nreverse articles))))) (defun extract-article (xmlstr a-start a-end) - "Extract article contents from PubMed XML string and return results in pmarticle class" - (let ((article (make-instance 'pmarticle))) + "Extract article contents from PubMed XML string and return results in pm-article class" + (let ((article (make-instance 'pm-article))) (setf - (pmid article) (parse-integer (xml-tag-contents "PMID" xmlstr a-start)) - (title article) (xml-tag-contents "ArticleTitle" xmlstr a-start) - (journal article) (xml-tag-contents "MedlineTA" xmlstr a-start) - (pages article) (xml-tag-contents "MedlinePgn" xmlstr a-start) - (affiliation article) (xml-tag-contents "Affiliation" xmlstr a-start) - (abstract article) (xml-tag-contents "AbstractText" xmlstr a-start)) + (article-pmid article) (parse-integer (xml-tag-contents "PMID" xmlstr a-start)) + (article-title article) (xml-tag-contents "ArticleTitle" xmlstr a-start) + (article-journal article) (xml-tag-contents "MedlineTA" xmlstr a-start) + (article-pages article) (xml-tag-contents "MedlinePgn" xmlstr a-start) + (article-affiliation article) (xml-tag-contents "Affiliation" xmlstr a-start) + (article-abstract article) (xml-tag-contents "AbstractText" xmlstr a-start)) (multiple-value-bind (ji-start ji-end ji-next) (positions-xml-tag-contents "JournalIssue" xmlstr a-start a-end) (declare (ignore ji-next)) (setf - (volume article) (xml-tag-contents "Volume" xmlstr ji-start ji-end) - (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 (pub-date article) it) - (setf (pub-date article) + (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) @@ -272,8 +313,8 @@ XML string of PubMed search results and XML search status" (multiple-value-bind (al-start al-end al-next) (positions-xml-tag-contents "AuthorList" xmlstr a-start a-end) (declare (ignore al-next)) - (setf (authors article) - (if al-start + (setf (article-authors article) + (when al-start (let ((done nil) (authors '()) (pos al-start)) @@ -286,14 +327,13 @@ XML string of PubMed search results and XML search status" (push (extract-author xmlstr au-start au-end) authors) (setq pos au-next)) (setq done t)))) - (nreverse authors)) - nil))) + (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 (mesh-headings article) - (if mhl-start + (setf (article-mesh-headings article) + (when mhl-start (let ((done nil) (mesh-headings '()) (pos mhl-start)) @@ -307,8 +347,8 @@ XML string of PubMed search results and XML search status" (setq pos mh-next) ) (setq done t)))) - (nreverse mesh-headings)) - nil))) + (nreverse mesh-headings))))) + article)) (defun extract-author (xmlstr start end) @@ -327,8 +367,9 @@ XML string of PubMed search results and XML search status" (defun extract-pmid-list (results) "Returns list of PubMed ID's from XML result string" - (if (search "" results) - nil + (if (or (search "" results) + (search "

Server Error

" results)) + (error 'pubmed-server-error :response results) (awhen (xml-tag-contents "Id" results) (delimited-string-to-list it #\space)))) -- 2.34.1