r4740: *** empty log message ***

diff --git a/debian/changelog b/debian/changelog
index 4a7015fc6c31f16c6a4251dfb556cdca641014ca..3def700717aa2746c0587ba667d1b0091999c04a 100644 (file)
--- 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 <kmr@debian.org>  Thu,  1 May 2003 23:37:02 -0600
 

diff --git a/sql-classes.lisp b/sql-classes.lisp
index da55a01d9c9cb40674d04379696ab042928ea307..161b9cd792bf854d1754eff6d4c40aa770e67641 100644 (file)
--- 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 (file)
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 fc92c334fad4cdfb0233d7095f21e31c9cefaa73..f2d0cb3485485ae06e903980c60056b2d46cb3f9 100644 (file)
--- 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")))