From: Kevin M. Rosenberg Date: Fri, 2 May 2003 18:47:53 +0000 (+0000) Subject: r4740: *** empty log message *** X-Git-Tag: v2006ac.2~256 X-Git-Url: http://git.kpe.io/?p=umlisp.git;a=commitdiff_plain;h=b1dc4b45c38c5723a90875c210f5cbea1c184b26 r4740: *** empty log message *** --- diff --git a/debian/changelog b/debian/changelog index 4a7015f..3def700 100644 --- a/debian/changelog +++ b/debian/changelog @@ -1,6 +1,7 @@ cl-umlisp (2.6.7-1) unstable; urgency=low * New upstream + * Add test-op -- Kevin M. Rosenberg Thu, 1 May 2003 23:37:02 -0600 diff --git a/sql-classes.lisp b/sql-classes.lisp index da55a01..161b9cd 100644 --- a/sql-classes.lisp +++ b/sql-classes.lisp @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Apr 2000 ;;;; -;;;; $Id: sql-classes.lisp,v 1.15 2003/05/02 07:09:07 kevin Exp $ +;;;; $Id: sql-classes.lisp,v 1.16 2003/05/02 18:47:53 kevin Exp $ ;;;; ;;;; This file, part of UMLisp, is ;;;; Copyright (c) 2000-2002 by Kevin M. Rosenberg, M.D. @@ -17,7 +17,7 @@ ;;;; ************************************************************************* (in-package :umlisp) -(declaim (optimize (speed 3) (safety 1) (compilation-speed 0) (debug 3))) +(declaim (optimize (compilation-speed 0) (debug 3))) (defvar *current-srl* nil) @@ -46,15 +46,50 @@ (setq found-ustr ustr)))))) found-ustr)) +(defun umlisp-query (table fields srl where-name where-value + &key (lrlname "KCUILRL") final) + "Query the UMLisp database. Return a list of umlisp objects whose name +is OBJNAME from TABLE where WHERE-NAME field = WHERE-VALUE with FIELDS" + (when where-value + (mutex-sql-query + (query-string table fields srl where-name where-value lrlname final)))) + + +(defun query-string (table fields &optional srl where-name where-value + (lrlname "KCUILRL") final) + (let ((qs (format nil "select ~{~:@(~A~)~^,~} from ~:@(~A~)" fields table))) + (when where-name + (setq qs (concatenate 'string qs + (format nil + (if (stringp where-value) + " where ~A='~A'" + " where ~A=~A") + where-name where-value)))) + (when srl + (setq qs (concatenate 'string qs (format nil " and ~:@(~A~) <= ~D" + lrlname srl)))) + (when final + (setq qs (concatenate 'string qs " " final))) + qs)) (defun find-ucon-cui (cui &key (srl *current-srl*)) + "Find ucon for a cui" + (loop + (for tuple in (umlisp-query 'mrcon '(kpfstr kcuilrl) srl + 'cui (parse-cui cui) :final "limit 1") + collect + (make-instance 'ucon :cui (parse-cui cui) + :pfstr (car tuple) + :lrl (ensure-integer (cadr tuple)))))) + +(defun find-ucon-cui-old (cui &key (srl *current-srl*)) "Find ucon for a cui" (when (stringp cui) (setq cui (parse-cui cui))) (when cui - (let ((ls (format nil "select KPFSTR,KCUILRL from MRCON where CUI=~d" cui))) - (when srl - (string-append ls (format nil " and KCUILRL <= ~d" srl))) - (string-append ls " limit 1") + (let ((ls + (maybe-add-srl + (format nil "select KPFSTR,KCUILRL from MRCON where CUI=~d" cui) + srl :final "limit 1"))) (awhen (car (mutex-sql-query ls)) (make-instance 'ucon :cui cui :pfstr (car it) :lrl (ensure-integer (cadr it))))))) @@ -63,10 +98,9 @@ "Find ucon for a cui" (when (stringp cui) (setq cui (parse-cui cui))) (when cui - (let ((ls (format nil "select KCUILRL from MRCON where CUI=~d" cui))) - (when srl - (string-append ls (format nil " and KCUILRL <= ~d" srl))) - (string-append ls " limit 1") + (let ((ls (maybe-add-srl + (format nil "select KCUILRL from MRCON where CUI=~d" cui) + srl :final "limit 1"))) (awhen (car (mutex-sql-query ls)) (make-instance 'ucon :cui cui :lrl (ensure-integer (car it)) @@ -74,13 +108,11 @@ (defun find-pfstr-cui (cui &key (srl *current-srl*)) "Find preferred string for a cui" - (when (stringp cui) - (setq cui (parse-cui cui))) + (when (stringp cui) (setq cui (parse-cui cui))) (when cui - (let ((ls (format nil "select KPFSTR from MRCON where CUI=~d" cui))) - (when srl - (string-append ls (format nil " and KCUILRL <= ~d" srl))) - (string-append ls " limit 1") + (let ((ls (maybe-add-srl + (format nil "select KPFSTR from MRCON where CUI=~d" cui) + srl :final "limit 1"))) (awhen (car (mutex-sql-query ls)) (car it))))) @@ -89,9 +121,10 @@ (when (stringp lui) (setq lui (parse-lui lui))) (when lui (let ((ucons '()) - (ls (format nil "select distinct CUI,KPFSTR,KCUILRL from MRCON where LUI=~d" lui))) - (if srl - (string-append ls (format nil " and KCUILRL <= ~d" srl))) + (ls + (maybe-add-srl + (format nil "select distinct CUI,KPFSTR,KCUILRL from MRCON where LUI=~d" lui) + srl))) (dolist (tuple (mutex-sql-query ls)) (destructuring-bind (cui pfstr lrl) tuple (push (make-instance 'ucon :cui (ensure-integer cui) @@ -105,9 +138,9 @@ (when (stringp sui) (setq sui (parse-sui sui))) (when sui (let ((ucons '()) - (ls (format nil "select distinct CUI,KPFSTR,KCUILRL from MRCON where SUI=~d" sui))) - (when srl - (string-append ls (format nil " and KCUILRL <= ~d" srl))) + (ls (maybe-add-srl + (format nil "select distinct CUI,KPFSTR,KCUILRL from MRCON where SUI=~d" sui) + srl))) (let ((tuples (mutex-sql-query ls))) (dolist (tuple tuples) (destructuring-bind (cui pfstr lrl) tuple @@ -122,10 +155,11 @@ (when (stringp cui) (setq cui (parse-cui cui))) (when (stringp sui) (setq sui (parse-sui sui))) (when (and cui sui) - (let ((ls (format nil "select distinct CUI,KPFSTR,KCUILRL from MRCON where KCUISUI=~d" - (make-cuisui cui sui)))) - (when srl - (string-append ls (format nil " and KCUILRL <= ~d" srl))) + (let ((ls + (maybe-add-srl + (format nil "select distinct CUI,KPFSTR,KCUILRL from MRCON where KCUISUI=~d" + (make-cuisui cui sui)) + srl))) (awhen (car (mutex-sql-query ls)) (destructuring-bind (cui pfstr lrl) it (make-instance 'ucon :cui (ensure-integer cui) @@ -136,9 +170,9 @@ "Find ucon that are exact match for str" (when str (let ((ucons '()) - (ls (format nil "select distinct CUI,KPFSTR,KCUILRL from MRCON where STR='~a'" str))) - (when srl - (string-append ls " and KCUILRL <= ~d" srl)) + (ls (maybe-add-srl + (format nil "select distinct CUI,KPFSTR,KCUILRL from MRCON where STR='~a'" str) + srl))) (dolist (tuple (mutex-sql-query ls)) (destructuring-bind (cui pfstr lrl) tuple (push (make-instance 'ucon :cui (ensure-integer cui) @@ -149,9 +183,8 @@ (defun find-ucon-all (&key (srl *current-srl*)) "Return list of all ucon's" - (let ((ls "select distinct CUI,KPFSTR,KCUILRL from MRCON")) - (when srl - (string-append ls (format nil " where KCUILRL <= ~d" srl))) + (let ((ls (maybe-add-srl "select distinct CUI,KPFSTR,KCUILRL from MRCON" + srl))) (string-append ls " order by CUI asc") (with-sql-connection (db) (clsql:map-query @@ -165,10 +198,8 @@ (defun map-ucon-all (fn &key (srl *current-srl*)) "Return list of all ucon's" - (let ((ls "select distinct CUI,KPFSTR,KCUILRL from MRCON")) - (when srl - (string-append ls (format nil " where KCUILRL <= ~d" srl))) - (string-append ls " order by CUI asc") + (let ((ls (maybe-add-srl "select distinct CUI,KPFSTR,KCUILRL from MRCON" + srl :final "order by CUI asc"))) (with-sql-connection (db) (clsql:map-query nil @@ -184,9 +215,9 @@ (defun find-udef-cui (cui &key (srl *current-srl*)) "Return a list of udefs for cui" (let ((udefs '()) - (ls (format nil "select SAB,DEF from MRDEF where CUI=~d" cui))) - (when srl - (string-append ls (format nil " and KSRL <= ~d" srl))) + (ls (maybe-add-srl + (format nil "select SAB,DEF from MRDEF where CUI=~d" cui) + srl :var "KSRL"))) (dolist (tuple (mutex-sql-query ls)) (destructuring-bind (sab def) tuple (push (make-instance 'udef :sab sab :def def) udefs))) @@ -195,9 +226,9 @@ (defun find-usty-cui (cui &key (srl *current-srl*)) "Return a list of usty for cui" (let ((ustys '()) - (ls (format nil "select TUI,STY from MRSTY where CUI=~d" cui))) - (when srl - (string-append ls (format nil " and KLRL <= ~d" srl))) + (ls (maybe-add-srl + (format nil "select TUI,STY from MRSTY where CUI=~d" cui) + srl :var "KLRL"))) (dolist (tuple (mutex-sql-query ls)) (destructuring-bind (tui sty) tuple (push (make-instance 'usty :tui (ensure-integer tui) :sty sty) ustys))) @@ -206,9 +237,9 @@ (defun find-usty-word (word &key (srl *current-srl*)) "Return a list of usty that match word" (let ((ustys '()) - (ls (format nil "select distinct TUI,STY from MRSTY where STY like '%~a%'" word))) - (when srl - (string-append ls (format nil " and KLRL <= ~d" srl))) + (ls (maybe-add-srl + (format nil "select distinct TUI,STY from MRSTY where STY like '%~a%'" word) + srl :var "KLRL"))) (dolist (tuple (mutex-sql-query ls)) (destructuring-bind (tui sty) tuple (push (make-instance 'usty :tui (ensure-integer tui) :sty sty) ustys))) @@ -217,9 +248,9 @@ (defun find-urel-cui (cui &key (srl *current-srl*)) "Return a list of urel for cui" (let ((urels '()) - (ls (format nil "select REL,CUI2,RELA,SAB,SL,MG,KPFSTR2 from MRREL where CUI1=~d" cui))) - (when srl - (string-append ls (format nil " and KSRL <= ~d" srl))) + (ls (maybe-add-srl + (format nil "select REL,CUI2,RELA,SAB,SL,MG,KPFSTR2 from MRREL where CUI1=~d" cui) + srl :var "KSRL"))) (dolist (tuple (mutex-sql-query ls)) (destructuring-bind (rel cui2 rela sab sl mg pfstr2) tuple (push (make-instance 'urel @@ -237,9 +268,9 @@ (defun find-urel-cui2 (cui2 &key (srl *current-srl*)) "Return a list of urel for cui2" (let ((urels '()) - (ls (format nil "select REL,CUI1,RELA,SAB,SL,MG,KPFSTR2 from MRREL where CUI2=~d" cui2))) - (when srl - (string-append ls (format nil " and SRL <= ~d" srl))) + (ls (maybe-add-srl + (format nil "select REL,CUI1,RELA,SAB,SL,MG,KPFSTR2 from MRREL where CUI2=~d" cui2) + srl :var "SRL"))) (dolist (tuple (mutex-sql-query ls)) (destructuring-bind (rel cui1 rela sab sl mg pfstr2) tuple (push (make-instance 'urel @@ -262,10 +293,9 @@ (defun find-ucoc-cui (cui &key (srl *current-srl*)) "Return a list of ucoc for cui" (let ((ucocs '()) - (ls (format nil "select CUI2,SOC,COT,COF,COA,KPFSTR2 from MRCOC where CUI1=~d" cui))) - (when srl - (string-append ls (format nil " and KLRL <= ~d" srl))) - (string-append ls " order by COF asc") + (ls (maybe-add-srl + (format nil "select CUI2,SOC,COT,COF,COA,KPFSTR2 from MRCOC where CUI1=~d" cui) + srl :var "KLRL" :final "order by COF asc"))) (dolist (tuple (mutex-sql-query ls)) (destructuring-bind (cui2 soc cot cof coa pfstr2) tuple (setq cui2 (ensure-integer cui2)) diff --git a/tests.lisp b/tests.lisp new file mode 100644 index 0000000..fdc1748 --- /dev/null +++ b/tests.lisp @@ -0,0 +1,47 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: umlisp -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: tests.lisp +;;;; Purpose: Regression suite for UMLisp +;;;; Author: Kevin M. Rosenberg +;;;; Date Started: May 2003 +;;;; +;;;; $Id: tests.lisp,v 1.1 2003/05/02 18:47:53 kevin Exp $ +;;;; +;;;; This file, part of UMLisp, is +;;;; Copyright (c) 2000-2002 by Kevin M. Rosenberg, M.D. +;;;; +;;;; UMLisp users are granted the rights to distribute and use this software +;;;; as governed by the terms of the GNU General Public License. +;;;; ************************************************************************* + +(defpackage #:umlisp-tests + (:use #:umlisp #:cl #:rtest)) +(in-package #:umlisp-tests) + +(setf rtest::*catch-errors* nil) + +(rem-all-tests) + +(deftest qs.1 (umlisp::query-string 'mrcon '(cui lui)) + "select CUI,LUI from MRCON") + +(deftest qs.2 (umlisp::query-string 'mrcon '(cui lui) 0) + "select CUI,LUI from MRCON and KCUILRL <= 0") + +(deftest qs.3 (umlisp::query-string 'mrcon '(cui lui) nil 'cui 5) + "select CUI,LUI from MRCON where CUI=5") + +(deftest qs.4 (umlisp::query-string 'mrcon '(cui lui) nil 'kpfstr "Abc") + "select CUI,LUI from MRCON where KPFSTR='Abc'") + +(deftest qs.5 (umlisp::query-string 'mrcon '(cui lui) 2 'cui 5 "limit 1") + "select CUI,LUI from MRCON where CUI=5 and KCUILRL <= 2 limit 1") + +(deftest qs.6 (umlisp::query-string 'mrdef '(sab def) 2 'cui 39 'srl "limit 1") + "select SAB,DEF from MRDEF where CUI=39 and KSRL <= 2 limit 1") + + + + diff --git a/umlisp.asd b/umlisp.asd index fc92c33..f2d0cb3 100644 --- a/umlisp.asd +++ b/umlisp.asd @@ -4,10 +4,10 @@ ;;;; ;;;; Name: umlisp.asd ;;;; Purpose: ASDF system definition file for UMLisp -;;;; Programmer: Kevin M. Rosenberg +;;;; Author: Kevin M. Rosenberg ;;;; Date Started: Apr 2000 ;;;; -;;;; $Id: umlisp.asd,v 1.14 2003/03/27 21:56:07 kevin Exp $ +;;;; $Id: umlisp.asd,v 1.15 2003/05/02 18:47:53 kevin Exp $ ;;;; ;;;; This file, part of UMLisp, is ;;;; Copyright (c) 2000-2002 by Kevin M. Rosenberg, M.D. @@ -16,28 +16,35 @@ ;;;; as governed by the terms of the GNU General Public License. ;;;; ************************************************************************* -(in-package :asdf) +(defpackage #:umlisp-system (:use #:asdf #:cl)) +(in-package #:umlisp-system) #+(or allegro lispworks cmu sbcl openmcl scl) -(defsystem :umlisp - :perform (load-op :after (op umlisp) - (pushnew :umlisp cl:*features*)) - +(defsystem umlisp :components - ((:file "package") - (:file "data-structures" :depends-on ("package")) - (:file "sql" :depends-on ("data-structures")) - (:file "utils" :depends-on ("data-structures")) - (:file "parse-macros" :depends-on ("sql")) - (:file "parse-2002" :depends-on ("parse-macros")) - (:file "parse-common" :depends-on ("parse-2002")) - (:file "sql-create" :depends-on ("parse-common")) - (:file "classes" :depends-on ("utils")) - (:file "class-support" :depends-on ("classes")) - (:file "sql-classes" :depends-on ("class-support" "sql")) - (:file "composite" :depends-on ("sql-classes"))) - :depends-on (:clsql - :clsql-mysql - :kmrcl - :hyperobject)) + ((:file "package") + (:file "data-structures" :depends-on ("package")) + (:file "sql" :depends-on ("data-structures")) + (:file "utils" :depends-on ("data-structures")) + (:file "parse-macros" :depends-on ("sql")) + (:file "parse-2002" :depends-on ("parse-macros")) + (:file "parse-common" :depends-on ("parse-2002")) + (:file "sql-create" :depends-on ("parse-common")) + (:file "classes" :depends-on ("utils")) + (:file "class-support" :depends-on ("classes")) + (:file "sql-classes" :depends-on ("class-support" "sql")) + (:file "composite" :depends-on ("sql-classes"))) + :depends-on (:clsql :clsql-mysql :kmrcl :hyperobject)) +#+(or allegro lispworks cmu sbcl openmcl scl) +(defmethod perform ((o test-op) (c (eql (find-system :umlisp)))) + (oos 'load-op 'umlisp-tests) + (oos 'test-op 'umlisp-tests)) + +(defsystem umlisp-tests + :depends-on (rt) + :components ((:file "tests"))) + +(defmethod perform ((o test-op) (c (eql (find-system :umlisp-tests)))) + (or (funcall (intern (symbol-name '#:do-tests) (find-package '#:rtest))) + (error "test-op failed")))