From d335b5cf5b01963d8d65cefda7906f7df544cf4f Mon Sep 17 00:00:00 2001 From: "Kevin M. Rosenberg" Date: Sat, 26 Oct 2002 17:06:07 +0000 Subject: [PATCH] r3196: *** empty log message *** --- .cvsignore | 1 + README | 14 ++ debian/README.Debian | 6 + debian/changelog | 6 + debian/control | 15 ++ debian/copyright | 19 +++ debian/postinst | 48 +++++++ debian/prerm | 42 ++++++ debian/rules | 69 +++++++++ debian/upload.sh | 4 + pubmed.asd | 47 ++++++ pubmed.lisp | 336 +++++++++++++++++++++++++++++++++++++++++++ 12 files changed, 607 insertions(+) create mode 100644 .cvsignore create mode 100644 README create mode 100644 debian/README.Debian create mode 100644 debian/changelog create mode 100644 debian/control create mode 100644 debian/copyright create mode 100755 debian/postinst create mode 100755 debian/prerm create mode 100755 debian/rules create mode 100755 debian/upload.sh create mode 100644 pubmed.asd create mode 100644 pubmed.lisp diff --git a/.cvsignore b/.cvsignore new file mode 100644 index 0000000..ca8d09f --- /dev/null +++ b/.cvsignore @@ -0,0 +1 @@ +.bin diff --git a/README b/README new file mode 100644 index 0000000..73989f6 --- /dev/null +++ b/README @@ -0,0 +1,14 @@ +This is the Common Lisp PubMed package. + +This package is written and Copyright (C) 2000-2001 by +Kevin M. Rosenberg + +The web site for this package is http://pubmed.b9.com/ + +This package requires the KMRCL utility package that available for +download at ftp://kmrcl.b9.com/. This package also depends on +Allegroserve which is included with AllegroCL and is available for +other platforms at http://portableaserve.sourceforge.net. + + + diff --git a/debian/README.Debian b/debian/README.Debian new file mode 100644 index 0000000..138717d --- /dev/null +++ b/debian/README.Debian @@ -0,0 +1,6 @@ +To use this package in Debian, execute + +(require 'pubmed) + +in your Lisp environment. + diff --git a/debian/changelog b/debian/changelog new file mode 100644 index 0000000..dcf2a3e --- /dev/null +++ b/debian/changelog @@ -0,0 +1,6 @@ +cl-pubmed (1.0-3) unstable; urgency=low + + * Initial release (closes: ) + + -- Kevin M. Rosenberg Tue, 22 Oct 2002 09:57:38 -0600 + diff --git a/debian/control b/debian/control new file mode 100644 index 0000000..fc9e1fd --- /dev/null +++ b/debian/control @@ -0,0 +1,15 @@ +Source: cl-pubmed +Section: devel +Priority: optional +Maintainer: Kevin M. Rosenberg +Build-Depends-Indep: debhelper (>= 4.0.0) +Standards-Version: 3.5.7.0 + +Package: cl-pubmed +Architecture: all +Depends: ${shlibs:Depends}, common-lisp-controller (>= 3.37), cl-kmrcl, cl-aserve +Description: Common Lisp package to query Pubmed medical literature database + This library has functions for querying the PubMed medical literature + database and parsing the XML results into Common Lisp objects. + + diff --git a/debian/copyright b/debian/copyright new file mode 100644 index 0000000..b51386b --- /dev/null +++ b/debian/copyright @@ -0,0 +1,19 @@ +This package was debianized by Kevin M. Rosenberg in +October 2002. + +The upstream source was downloaded from http://pubmed.b9.com/ + +Upstream Author: Kevin M. Rosenberg + +As the upstream author is the same as the Debian package maintainer, +no changes are expected between the upstream and Debian packages. + + +Copyright (c) 2000-2002 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 +License as published by the Free Software Foundation. + +The GNU Lessor General Public License can be found in your Debian file +system in /usr/share/common-licenses/LGPL. diff --git a/debian/postinst b/debian/postinst new file mode 100755 index 0000000..fbebe3f --- /dev/null +++ b/debian/postinst @@ -0,0 +1,48 @@ +#! /bin/sh +# postinst script for cl-pubmed +# +# see: dh_installdeb(1) + +set -e + +# package name according to lisp +LISP_PKG=pubmed + +# summary of how this script can be called: +# * `configure' +# * `abort-upgrade' +# * `abort-remove' `in-favour' +# +# * `abort-deconfigure' `in-favour' +# `removing' +# +# for details, see http://www.debian.org/doc/debian-policy/ or +# the debian-policy package +# +# quoting from the policy: +# Any necessary prompting should almost always be confined to the +# post-installation script, and should be protected with a conditional +# so that unnecessary prompting doesn't happen if a package's +# installation fails and the `postinst' is called with `abort-upgrade', +# `abort-remove' or `abort-deconfigure'. + +case "$1" in + configure) + /usr/sbin/register-common-lisp-source ${LISP_PKG} + ;; + abort-upgrade|abort-remove|abort-deconfigure) + ;; + *) + echo "postinst called with unknown argument \`$1'" >&2 + exit 1 + ;; +esac + +# dh_installdeb will replace this with shell code automatically +# generated by other debhelper scripts. + +#DEBHELPER# + +exit 0 + + diff --git a/debian/prerm b/debian/prerm new file mode 100755 index 0000000..a5194d7 --- /dev/null +++ b/debian/prerm @@ -0,0 +1,42 @@ +#! /bin/sh +# prerm script for cl-pubmed +# +# see: dh_installdeb(1) + +set -e + +# package name according to lisp +LISP_PKG=pubmed + +# summary of how this script can be called: +# * `remove' +# * `upgrade' +# * `failed-upgrade' +# * `remove' `in-favour' +# * `deconfigure' `in-favour' +# `removing' +# +# for details, see http://www.debian.org/doc/debian-policy/ or +# the debian-policy package + + +case "$1" in + remove|upgrade|deconfigure) + /usr/sbin/unregister-common-lisp-source ${LISP_PKG} + ;; + failed-upgrade) + ;; + *) + echo "prerm called with unknown argument \`$1'" >&2 + exit 1 + ;; +esac + +# dh_installdeb will replace this with shell code automatically +# generated by other debhelper scripts. + +#DEBHELPER# + +exit 0 + + diff --git a/debian/rules b/debian/rules new file mode 100755 index 0000000..64ac3bc --- /dev/null +++ b/debian/rules @@ -0,0 +1,69 @@ +#!/usr/bin/make -f + +export DH_COMPAT=4 + +pkg := pubmed +debpkg := cl-pubmed + + +clc-source := usr/share/common-lisp/source +clc-systems := usr/share/common-lisp/systems +clc-pubmed := $(clc-source)/$(pkg) + +doc-dir := usr/share/doc/$(debpkg) + + +configure: configure-stamp +configure-stamp: + dh_testdir + # Add here commands to configure the package. + + touch configure-stamp + + +build: build-stamp + +build-stamp: configure-stamp + dh_testdir + # Add here commands to compile the package. + touch build-stamp + +clean: + dh_testdir + dh_testroot + rm -f build-stamp configure-stamp + # Add here commands to clean up after the build process. + rm -f debian/cl-pubmed.postinst.* debian/cl-pubmed.prerm.* + dh_clean + +install: build + dh_testdir + dh_testroot + dh_clean -k + # Add here commands to install the package into debian/pubmed. + dh_installdirs $(clc-systems) $(clc-pubmed) + dh_install pubmed.asd $(shell echo *.lisp) $(clc-pubmed) + dh_link $(clc-pubmed)/pubmed.asd $(clc-systems)/pubmed.asd + +# Build architecture-independent files here. +binary-indep: build install + + +# Build architecture-dependent files here. +binary-arch: build install + dh_testdir + dh_testroot + dh_installdocs + dh_installchangelogs + dh_strip + dh_compress + dh_fixperms + dh_installdeb + dh_shlibdeps + dh_gencontrol + dh_md5sums + dh_builddeb + +binary: binary-indep binary-arch +.PHONY: build clean binary-indep binary-arch binary install configure + diff --git a/debian/upload.sh b/debian/upload.sh new file mode 100755 index 0000000..3215288 --- /dev/null +++ b/debian/upload.sh @@ -0,0 +1,4 @@ +#!/bin/bash -e + +dup pubmed -Uftp.med-info.com -D/home/ftp/pubmed -C"(cd /opt/apache/htdocs/pubmed; make install)" -su $* + diff --git a/pubmed.asd b/pubmed.asd new file mode 100644 index 0000000..f7657ce --- /dev/null +++ b/pubmed.asd @@ -0,0 +1,47 @@ +;;;; -*- 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: pubmed.asd,v 1.1 2002/10/26 17:06:07 kevin Exp $ +;;;; +;;;; 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 :asdf) + +#+(allegro common-lisp-controller) (c-l-c::clc-require :aserve) +#+(allegro (not common-lisp-controller)) (require :aserve) + +;; only define system on implementations that aserve is available +#+(or allegro lispworks cmucl mcl openmcl) +(defsystem :pubmed + :name "cl-pubmed" + :author "Kevin M. Rosenberg " + :version "1.0" + :maintainer "Kevin M. Rosenberg " + :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." + + :perform (load-op :after (op pubmed) + (pushnew :pubmed cl:*features*)) + + :components ((:file "pubmed")) + + :depends-on (:kmrcl #-allegro :aserve)) + +;; only define system on implementations that aserve is available +#+(or allegro lispworks cmucl mcl openmcl) +(when (ignore-errors (find-class 'load-compiled-op)) + (defmethod perform :after ((op load-compiled-op) (c (eql (find-system :pubmed)))) + (pushnew :pubmed cl:*features*))) + diff --git a/pubmed.lisp b/pubmed.lisp new file mode 100644 index 0000000..56556ca --- /dev/null +++ b/pubmed.lisp @@ -0,0 +1,336 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: pubmed.lisp +;;;; Purpose: Library to access PubMed web application +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Jun 2001 +;;;; +;;;; $Id: pubmed.lisp,v 1.1 2002/10/26 17:06:07 kevin Exp $ +;;;; +;;;; 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) +;;;; ************************************************************************* + +(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) + +(in-package #:cl-user) + +(defpackage #:pubmed + (:use #:common-lisp #:kmrcl) + (:export #:pm-search + #:disp-article + #:disp-articleset + #:fetch-pmids + #:total-count + #:article-count + #:articles + )) + +(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") + + +;;; 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)) + (:documentation "Pubmed Article Set Class") + (:default-initargs :total-count 0 :article-start 0 :article-count 0 + :search-str nil :articles nil)) + +(defclass pmarticle () + ( + (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)) + (:documentation "Pubmed Article Class")) + +(defmethod print-object ((obj pmarticleset) (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) + ))) + +(defmethod print-object ((obj pmarticle) (s stream)) + (print-unreadable-object (obj s :type t :identity t) + (format s "pmid:~d" (pmid obj)))) +;; (disp-article obj :os s :format :text) + +(defun pmarticle-pubdata (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)) + "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))) + +(defmethod disp-article ((art pmarticle) &key (os *standard-output*) (format :text) + (complete nil) (disp-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) + (format nil "~a~%" :it) "") + (journal art) (pmarticle-pubdata art) + (if (abstract art) + (if complete + (abstract art) + "Abstract available") + "No abstract available") + (when complete + (format os "~a~%" (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) + (format os "")) + (format os "
~a
~%" + (list-to-delimited-string (authors art) ", ")) + (format os "
~a ~a
~%" + (journal art) (pmarticle-pubdata art)) + (when (and complete (abstract art)) + (format os "
~a
~%" + (abstract art))) + (when (and complete (mesh-headings art)) + (format os "
Mesh Headings:
") + (dolist (mh (mesh-headings art)) + (format os "
~a
~%" mh))) + (format os "

~%")))) + + +;;; PubMed Search Functions + +(defun pm-search (searchstr &key disp-max disp-start) + "Performs PubMed query and fetch and returns articleset 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))) + (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" + (setq pmids (mklist pmids)) + (let ((results (pubmed-fetch-pmids-xml pmids))) + (if (xml-tag-contents "Error" results) + nil + (let ((as (make-instance 'pmarticleset))) + (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)) + as)))) + +#+ignore +(defun pubmed-search-tree (searchstr &key disp-max disp-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) + (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) + "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) + (values (pubmed-fetch-pmids-xml pmids) search-status))) + +(defun pubmed-query-xml (searchstr &key disp-max disp-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))) + (values (extract-pmid-list search-results) search-results))) + +(defun pubmed-query-status (searchstr &key disp-max disp-start) + "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))) + +(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 #\,)))))) + +;;; XML Extraction Routines + +(defun extract-articleset (results) + "Extract article set from PubMed XML string, return results in pmarticleset 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 pmarticle class" + (let ((article (make-instance 'pmarticle))) + (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)) + (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)) + (aif (xml-tag-contents "MedlineDate" xmlstr ji-start ji-end) + (setf (pub-date article) :it) + (setf (pub-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 (authors article) + (if 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)) + nil))) + + (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 + (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)) + nil))) + 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 "Descriptor" 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" + (if (search "" results) + nil + (awhen (xml-tag-contents "Id" results) + (delimited-string-to-list it #\space)))) + + + -- 2.34.1