-
-;;; Accessors (read on demand)
-
-;; defines a slot-unbound method for class and slot-name, fills
-;; the slot by calling reader function with the slot values of
-;; the instance's reader-keys
-(defmacro def-lazy-reader (class slot-name reader &rest reader-keys)
- (let* ((the-slot-name (gensym))
- (the-class (gensym))
- (the-instance (gensym))
- (keys '()))
- (dolist (key reader-keys)
- (push (list 'slot-value the-instance (list 'quote key)) keys))
- (setq keys (nreverse keys))
- `(defmethod slot-unbound (,the-class (,the-instance ,class)
- (,the-slot-name (eql ',slot-name)))
- (declare (ignore ,the-class))
- (setf (slot-value ,the-instance ,the-slot-name)
- (,reader ,@keys)))))
-
-(def-lazy-reader ucon s#term find-uterm-cui cui)
-(def-lazy-reader ucon s#def find-udef-cui cui)
-(def-lazy-reader ucon s#sty find-usty-cui cui)
-(def-lazy-reader ucon s#rel find-urel-cui cui)
-(def-lazy-reader ucon s#coc find-ucoc-cui cui)
-(def-lazy-reader ucon s#lo find-ulo-cui cui)
-(def-lazy-reader ucon s#atx find-uatx-cui cui)
-(def-lazy-reader ucon s#sat find-usat-ui cui)
-
-;; For uterms
-(def-lazy-reader uterm s#str find-ustr-cuilui cui lui)
-(def-lazy-reader uterm s#sat find-usat-ui cui lui)
-
-;; For ustrs
-(def-lazy-reader ustr s#sat find-usat-ui cui lui sui)
-(def-lazy-reader ustr s#cxt find-ucxt-cuisui cui sui)
-(def-lazy-reader ustr s#so find-uso-cuisui cui sui)
-
-;;; Object lookups
-
-;;; Lookup functions for uterms,ustr in ucons
-
-(defun find-uterm-in-ucon (ucon lui)
- (find lui (s#term ucon) :key #'lui :test 'equal))
-
-(defun find-ustr-in-uterm (uterm sui)
- (find sui (s#str uterm) :key #'sui :test 'equal))
-
-(defun find-ustr-in-ucon (ucon sui)
- (let ((found-ustr nil))
- (dolist (uterm (s#term ucon))
- (unless found-ustr
- (dolist (ustr (s#str uterm))
- (unless found-ustr
- (when (string-equal sui (sui ustr))
- (setq found-ustr ustr))))))
- found-ustr))
-
+(defmacro query-string (table fields &optional srl where-name where-value
+ &key (lrl "KCUILRL") single distinct order like)
+ (let* ((%%fields (format nil "select ~A~{~:@(~A~)~^,~} from ~:@(~A~)"
+ (if distinct "distinct " "") fields table))
+ (%%order (if order (format nil " order by ~{~:@(~A~) ~(~A~)~^,~}"
+ order)
+ ""))
+ (%%lrl (format nil " and ~:@(~A~)<=" lrl))
+ (%%where (when where-name
+ (format nil " where ~:@(~A~)~A" where-name
+ (if like " like " "")))))
+ `(concatenate
+ 'string
+ ,%%fields
+ ,@(when %%where (list %%where))
+ ,@(when %%where
+ `((typecase ,where-value
+ (number
+ (concatenate 'string "=" (write-to-string ,where-value)))
+ (null
+ " is null")
+ (t
+ (format nil ,(if like "'%~A%'" "='~A'") ,where-value)))))
+ (if ,srl (concatenate 'string ,%%lrl (write-to-string ,srl)) "")
+ ,@(when %%order (list %%order))
+ ,@(when single (list " limit 1")))))
+
+(defun query-string-eval (table fields &optional srl where-name where-value
+ &key (lrl "KCUILRL") single distinct order like)
+ (concatenate
+ 'string
+ (format nil "select ~A~{~:@(~A~)~^,~} from ~:@(~A~)"
+ (if distinct "distinct " "") fields table)
+ (if where-name (format nil " where ~:@(~A~)" where-name) "")
+ (if where-name
+ (format nil
+ (typecase where-value
+ (number "=~D")
+ (null " is null")
+ (t
+ (if like " like '%~A%""='~A'")))
+ where-value)
+ "")
+ (if srl (format nil " and ~:@(~A~)<=~D" lrl srl) "")
+ (if order (format nil " order by ~{~:@(~A~) ~(~A~)~^,~}" order) "")
+ (if single " limit 1" "")))
+
+
+(defmacro umlisp-query (table fields srl where-name where-value
+ &key (lrl "KCUILRL") single distinct order like)
+ "Query the UMLisp database. Return a list of umlisp objects whose name
+is OBJNAME from TABLE where WHERE-NAME field = WHERE-VALUE with FIELDS"
+ `(mutex-sql-query
+ (query-string ,table ,fields ,srl ,where-name ,where-value
+ :lrl ,lrl :single ,single :distinct ,distinct :order ,order :like ,like)))
+
+(defmacro umlisp-query-eval (table fields srl where-name where-value
+ &key (lrl "KCUILRL") single distinct order like)
+ "Query the UMLisp database. Return a list of umlisp objects whose name
+is OBJNAME from TABLE where WHERE-NAME field = WHERE-VALUE with FIELDS"
+ `(mutex-sql-query
+ (query-string-eval ,table ,fields ,srl ,where-name ,where-value
+ :lrl ,lrl :single ,single :distinct ,distinct :order ,order :like ,like)))
+
+;; only WHERE-VALUE and SRL are evaluated
+(defmacro with-umlisp-query ((table fields srl where-name where-value
+ &key (lrl "KCUILRL") distinct single
+ order like)
+ &body body)
+ (let ((value (gensym))
+ (r (gensym)))
+ (if single
+ `(let* ((,value ,where-value)
+ (tuple (car (umlisp-query ,table ,fields ,srl ,where-name ,value
+ :lrl ,lrl :single ,single
+ :distinct ,distinct :order ,order
+ :like ,like))))
+ ,@(unless where-name `((declare (ignore ,value))))
+ (when tuple
+ (destructuring-bind ,fields tuple
+ ,@body)))
+ `(let ((,value ,where-value))
+ ,@(unless where-name `((declare (ignore ,value))))
+ (let ((,r '()))
+ (dolist (tuple (umlisp-query ,table ,fields ,srl ,where-name ,value
+ :lrl ,lrl :single ,single :distinct ,distinct
+ :order ,order :like ,like))
+ (push (destructuring-bind ,fields tuple ,@body) ,r))
+ (nreverse ,r))
+ #+ignore
+ (loop for tuple in
+ (umlisp-query ,table ,fields ,srl ,where-name ,value
+ :lrl ,lrl :single ,single :distinct ,distinct
+ :order ,order :like ,like)
+ collect (destructuring-bind ,fields tuple ,@body))))))
+
+(defmacro with-umlisp-query-eval ((table fields srl where-name where-value
+ &key (lrl "KCUILRL") distinct single
+ order like)
+ &body body)
+ (let ((value (gensym))
+ (r (gensym))
+ (eval-fields (cadr fields)))
+ (if single
+ `(let* ((,value ,where-value)
+ (tuple (car (umlisp-query-eval ,table ,fields ,srl ,where-name ,value
+ :lrl ,lrl :single ,single
+ :distinct ,distinct :order ,order
+ :like ,like))))
+ (when tuple
+ (destructuring-bind ,eval-fields tuple
+ ,@body)))
+ `(let ((,value ,where-value)
+ (,r '()))
+ (dolist (tuple (umlisp-query-eval ,table ,fields ,srl ,where-name ,value
+ :lrl ,lrl :single ,single :distinct ,distinct
+ :order ,order :like ,like))
+ (push (destructuring-bind ,eval-fields tuple ,@body) ,r))
+ (nreverse ,r)
+ #+ignore
+ (loop for tuple in
+ (umlisp-query-eval ,table ,fields ,srl ,where-name ,value
+ :lrl ,lrl :single ,single :distinct ,distinct
+ :order ,order :like ,like)
+ collect (destructuring-bind ,eval-fields tuple ,@body))))))
+
+;;;
+;;; Read from SQL database