cl-2sql

Lisp to SQL compiler for Common Lisp
git clone https://logand.com/git/cl-2sql.git/
Log | Files | Refs | README | LICENSE

orm.lisp (23832B)


      1 ;;; cl-2sql Copyright (c) 2011 Tomas Hlavaty
      2 
      3 (defpackage 2sql-orm
      4   (:use :cl)
      5   (:export :textp
      6            :text
      7            :defptype
      8            :defpclass
      9            :setup-pclass
     10            :with-instance-cache
     11            :make-pinstance
     12            :with-pinstance-collector-cache
     13            :query
     14            :instance
     15            ))
     16 
     17 (in-package :2sql-orm)
     18 
     19 ;;; orm types
     20 
     21 ;; string => string | clob
     22 ;; string 3 => char 3
     23 ;; text 5 &optional 2 => varchar 5 (no "" allowed, due to oracle)
     24 ;; string-or-text => string | varchar
     25 ;; char 1 => boolean
     26 
     27 (defun textp (a max &optional (min 1))
     28   (and (stringp a) (<= min (length a) max)))
     29 
     30 ;; (textp "h" 3)
     31 ;; (textp "h" 3 2)
     32 ;; (textp "hi" 3)
     33 ;; (textp "hi" 3 2)
     34 ;; (textp "hello" 3)
     35 ;; (textp "hello" 3 2)
     36 
     37 (deftype text (max &optional (min 1))
     38   (assert (plusp min))
     39   (assert (< min max))
     40   (let ((p (gensym)))
     41     (setf (symbol-function p) #'(lambda (a) (textp a max min)))
     42     `(and string (satisfies ,p))))
     43 
     44 ;; (typep "h" '(text 3))
     45 ;; (typep "h" '(text 3 2))
     46 ;; (typep "hi" '(text 3))
     47 ;; (typep "hi" '(text 3 2))
     48 ;; (typep "hello" '(text 3))
     49 ;; (typep "hello" '(text 3 2))
     50 
     51 (defstruct (pdate (:constructor make-pdate (y m d))) y m d)
     52 (defstruct (ptime (:constructor make-ptime (hh mm ss ms))) hh mm ss ms)
     53 (defstruct (ptimestamp-tz
     54              (:constructor make-ptimestamp-tz (date time timezone)))
     55   date time timezone)
     56 ;;(defstruct pinterval y m d hh mm ss ms)
     57 
     58 (defmethod cl-postgres:to-sql-string ((a pdate))
     59   (with-slots (y m d) a
     60     (values (format nil "~4,'0d-~2,'0d-~2,'0d" y m d) "date")))
     61 
     62 (defmethod cl-postgres:to-sql-string ((a ptimestamp-tz)) ;; TODO timezone
     63   (with-slots (date time timezone) a
     64     (with-slots (y m d) date
     65       (with-slots (hh mm ss ms) time
     66         (values
     67           (format nil "~4,'0d-~2,'0d-~2,'0d ~2,'0d:~2,'0d:~2,'0d~@[.~3,'0d~]"
     68                   y m d hh mm ss (if (zerop ms) nil ms))
     69           "timestamp")))))
     70 
     71 #+nil
     72 (defmethod cl-postgres:to-sql-string ((a pinterval))
     73   (with-slots (y m d hh mm ss ms) a
     74     (if (= year month day hour min sec ms 0)
     75         (values "0 milliseconds" "interval")
     76         (flet ((not-zero (x) (if (zerop x) nil x)))
     77           (values
     78             (format nil "~@[~d years ~]~@[~d months ~]~@[~d days ~]~@[~d hours ~]~@[~d minutes ~]~@[~d seconds ~]~@[~d milliseconds~]"
     79                     (not-zero year) (not-zero month) (not-zero day)
     80                     (not-zero hour) (not-zero min) (not-zero sec) (not-zero ms))
     81             "interval")))))
     82 
     83 (deftype octet () '(unsigned-byte 8))
     84 (deftype octet-vector (&optional size) `(simple-array octet (,size)))
     85 
     86 (defgeneric ptype-macroexpand (type))
     87 
     88 (defun persistent-type-p (type)
     89   (get type 'persistent-type))
     90 
     91 (deftype persistent-type () '(satisfies persistent-type-p))
     92 
     93 (defun lisp-type-to-ptype (type) ;; TODO more types
     94   (if (atom type)
     95       (case type
     96         (boolean '(q:boolean-type))
     97         (integer '(q:integer-type))
     98         (string '(q:varchar-type))
     99         (pdate '(q:date-type))
    100         (ptime '(q:time-type))
    101         (ptimestamp-tz '(q:timestamp-with-timezone-type))
    102         (octet-vector '(q:blob-type))
    103         (t
    104          (cond
    105            ((subtypep type 'persistent-object) (lisp-type-to-ptype 'oid))
    106            ((subtypep type 'persistent-type) (lisp-type-to-ptype 'oid))
    107            ;;((persistent-type-p type) (lisp-type-to-ptype 'oid))
    108            (t (let ((x (ptype-macroexpand type)))
    109                 (assert (not (eq x type)))
    110                 (lisp-type-to-ptype x))))))
    111       (ecase (car type)
    112         (or
    113           (assert (eq 'null (cadr type)))
    114           (assert (not (cddddr type)))
    115           (lisp-type-to-ptype (caddr type)))
    116         (integer `(q:integer-type ,(cadr type)))
    117         (string `(q:char-type ,(cadr type)))
    118         (text `(q:varchar-type ,(cadr type))))))
    119 
    120 ;; (lisp-type-to-ptype 'integer)
    121 ;; (lisp-type-to-ptype 'string)
    122 ;; (lisp-type-to-ptype '(integer 16))
    123 ;; (lisp-type-to-ptype '(string 3))
    124 ;; (lisp-type-to-ptype '(text 3))
    125 ;; (lisp-type-to-ptype '(text 3 2))
    126 
    127 (defun lisp-type-nullable-p (type)
    128   (unless (eql 'boolean type)
    129     (typep nil type)))
    130 
    131 (defmacro defptype (name args specifier &optional db-type db-check)
    132   `(progn
    133      (deftype ,name ,args ,specifier)
    134      (defmethod 2sql-orm::ptype-macroexpand ((type (eql ',name)))
    135        ,(if db-type `(values ,db-type ,db-check) specifier))))
    136 
    137 (defun natural0p (a)
    138   (and (integerp a) (<= 0 a)))
    139 
    140 (defmethod ptype-macroexpand ((type (eql 'list)))
    141   'string)
    142 
    143 (defptype natural0 () '(and integer (satisfies natural0p)) 'integer 'q:le0)
    144 (defptype natural () '(and integer (satisfies plusp)) 'integer 'q:plusp)
    145 (defptype universal-time () 'integer 'ptimestamp-tz)
    146 (defptype oid () 'natural)
    147 
    148 ;;; persistent-object
    149 
    150 (defparameter *instance-cache* nil)
    151 
    152 (defmacro with-instance-cache (args &body body)
    153   (declare (ignore args))
    154   `(let ((*instance-cache* (make-hash-table)))
    155      ,@body))
    156 
    157 ;; http://users.encs.concordia.ca/~haarslev/publications/jvlc92/node6.html
    158 ;; http://objectmix.com/lisp/725624-help-creating-clos-meta-classes.html
    159 ;; http://www.lispworks.com/documentation/lw50/LWRM/html/lwref-71.htm
    160 ;; http://paste.lisp.org/display/123125
    161 ;; http://www.cliki.net/MOP%20design%20patterns
    162 ;; http://bc.tech.coop/blog/040412.html
    163 
    164 (defclass persistent-class (standard-class)
    165   ())
    166 
    167 (defmethod c2mop:validate-superclass ((class persistent-class)
    168                                       (superclass standard-class))
    169   t)
    170 
    171 (defclass %persistent-object (#+nil standard-object)
    172   ()
    173   (:metaclass persistent-class))
    174 
    175 ;;(c2mop:ensure-finalized (find-class 'persistent-object))
    176 ;;(c2mop:class-slots (find-class 'persistent-object))
    177 
    178 ;; http://www.cliki.net/MOP%20design%20patterns
    179 #+nil ;; TODO add persistent-object superclass automatically
    180 (defmacro init-instance ()
    181   `(call-next-method)
    182   #+nil
    183   `(if (or #+nil(eq 'persistent-class (class-name class))
    184            (loop
    185               for x in direct-superclasses
    186               thereis (subtypep x (find-class 'persistent-object))))
    187        ;; already one of the (indirect) superclasses
    188        (call-next-method)
    189        ;; not one of the superclasses, so we have to add it
    190        (apply #'call-next-method class
    191               :direct-superclasses (append direct-superclasses
    192                                            (list (find-class 'persistent-object)))
    193               initargs)))
    194 
    195 ;; http://www.cliki.net/MOP%20design%20patterns
    196 #+nil ;; TODO add persistent-object superclass automatically
    197 (defmethod initialize-instance :around ((class persistent-class) &rest initargs
    198                                         &key direct-superclasses)
    199   (declare (dynamic-extent initargs))
    200   (init-instance))
    201 
    202 ;; http://www.cliki.net/MOP%20design%20patterns
    203 #+nil ;; TODO add persistent-object superclass automatically
    204 (defmethod reinitialize-instance :around
    205     ((class persistent-class) &rest initargs
    206      &key (direct-superclasses '() direct-superclasses-p))
    207   (declare (dynamic-extent initargs))
    208   (if direct-superclasses-p
    209       ;; if direct superclasses are explicitly passed this is exactly
    210       ;; like above
    211       (init-instance)
    212       ;; if direct superclasses are not explicitly passed we _must_
    213       ;; not change anything
    214       (call-next-method)))
    215 
    216 (defparameter *initializing-instance* nil)
    217 
    218 (defun check-cached-instance (a)
    219   (unless *initializing-instance*
    220     (assert (eq a (gethash (oid a) *instance-cache*)))))
    221 
    222 (defmethod c2mop::shared-initialize :around ((object %persistent-object)
    223                                              slot-names &rest initargs
    224                                              &key &allow-other-keys)
    225   (declare (ignore initargs))
    226   (let ((*initializing-instance* t))
    227     (call-next-method)))
    228 
    229 (defmethod c2mop:slot-value-using-class :before ((class persistent-class)
    230                                                  (a %persistent-object)
    231                                                  slotd)
    232   (unless (eq 'oid (c2mop:slot-definition-name slotd))
    233     (check-cached-instance a)))
    234 
    235 (defmethod (setf c2mop:slot-value-using-class) :before (value
    236                                                         (class persistent-class)
    237                                                         (a %persistent-object)
    238                                                         slotd)
    239   (unless (eq 'oid (c2mop:slot-definition-name slotd))
    240     (check-cached-instance a)))
    241 
    242 (defstruct (proxy (:constructor make-proxy (oid))) oid)
    243 
    244 (defmethod c2mop:slot-value-using-class :around ((class persistent-class)
    245                                                  (a %persistent-object)
    246                                                  slotd)
    247   (let ((s (call-next-method)))
    248     (if (proxy-p s)
    249         (load-instance (ltype slotd) (proxy-oid s))
    250         s)))
    251 
    252 (defmethod (setf c2mop:slot-value-using-class) :around (value
    253                                                         (class persistent-class)
    254                                                         (a %persistent-object)
    255                                                         slotd)
    256   ;; TODO ? enforce assert-type?
    257   (let ((x (call-next-method)))
    258     (unless *initializing-instance*
    259       (let ((oid (oid a)))
    260         (2sql:query (oid value)
    261           `(q:update ,(class-name class)
    262                      ((,(pslot-name slotd) (q:qvar value)))
    263                      (q:where (q:= oid (q:qvar oid)))))))
    264     x))
    265 
    266 ;;; persistent slots
    267 
    268 (defclass persistent-slot-definition ()
    269   ((ltype :reader ltype) ;; remember unexpanded
    270    (ptype :reader ptype) ;; remember computed
    271    (nullable :reader nullable)
    272    (transient :type boolean :initarg :transient :initform nil :accessor transient)))
    273 
    274 (defclass persistent-direct-slot-definition
    275     (persistent-slot-definition c2mop:standard-direct-slot-definition)
    276   ())
    277 
    278 (defclass persistent-effective-slot-definition
    279     (persistent-slot-definition c2mop:standard-effective-slot-definition)
    280   ())
    281 
    282 (defmethod c2mop:direct-slot-definition-class :around
    283     ((class persistent-class) &rest initargs)
    284   ;;(print (list :@@@-direct-slot-definition-class initargs))
    285   (find-class 'persistent-direct-slot-definition))
    286 
    287 (defmethod c2mop:effective-slot-definition-class
    288     ((class persistent-class) &rest initargs)
    289   ;;(format t "getting eff class. initargs=~s~%" initargs)
    290   (find-class 'persistent-effective-slot-definition))
    291 
    292 #+nil
    293 (defmethod c2mop:compute-effective-slot-definition
    294     ((class persistent-class) slot-name direct-slots)
    295   (call-next-method)
    296   #+nil
    297   (format t "computing slot definition: class=~s name=~s slots=~s~%"
    298           class slot-name direct-slots)
    299   #+nil
    300   (let ((result (call-next-method)))
    301     ;;(break "~s" result)
    302     #+nil
    303     (format t "    result: ~s~%" result)
    304     result))
    305 
    306 (defmethod initialize-instance :before
    307     ((class persistent-direct-slot-definition) &rest initargs
    308      &key direct-superclasses)
    309   (declare (ignore direct-superclasses))
    310   (with-slots (ltype ptype nullable) class ;; TODO transient
    311     (setq ltype (getf initargs :type)
    312           ptype (lisp-type-to-ptype ltype)
    313           nullable (unless (eql 'boolean ltype)
    314                      (typep nil ltype)))))
    315 
    316 (defmethod c2mop:compute-effective-slot-definition :around
    317     ((class persistent-class) name direct-slot-definitions)
    318   (let ((x (call-next-method)))
    319     (assert (not (cdr direct-slot-definitions))) ;; TODO
    320     (let ((slotd (car direct-slot-definitions)))
    321       (assert (typep slotd 'persistent-slot-definition))
    322       (with-slots (ltype ptype nullable) x ;; TODO transient
    323         (setq ltype (ltype slotd)
    324               ptype (ptype slotd)
    325               nullable (nullable slotd))))
    326     x))
    327 
    328 #+nil
    329 (defmethod initialize-instance :around
    330     ((class persistent-direct-slot-definition) &rest initargs
    331      &key direct-superclasses)
    332   ;;(declare (ignore direct-superclasses))
    333   #+nil
    334   (with-slots (ltype ptype nullable) class
    335     (setq ltype (getf initargs :type)
    336           ptype (lisp-type-to-ptype ltype)
    337           nullable (unless (eql 'boolean ltype)
    338                      (typep nil ltype))))
    339   (call-next-method)
    340   #+nil
    341   (let ((ltype (getf initargs :type)))
    342     (apply #'call-next-method
    343            class
    344            `(:ltype ,ltype
    345                     :ptype ,(lisp-type-to-ptype ltype)
    346                     :nullable ,(unless (eql 'boolean ltype)
    347                                        (typep nil ltype))
    348                     ,@initargs)
    349            direct-superclasses)))
    350 
    351 #+nil
    352 (defclass foo ()
    353   ((hi :initarg :hi)))
    354 
    355 ;;(c2mop:class-slots (find-class 'foo))
    356 
    357 #+nil
    358 (defclass person (#+nil persistent-object foo)
    359   ((name :type string :initarg :name #+nil :transient #+nil t)
    360    (age :type natural0 :initarg :age))
    361   (:metaclass persistent-class))
    362 
    363 ;;(slot-value (make-instance 'person :age 12) 'age)
    364 
    365 ;;(c2mop:class-slots (find-class 'person))
    366 
    367 #+nil
    368 (defclass person2 (persistent-object foo)
    369   ((name :type string :initarg :name #+nil :transient #+nil t)
    370    (age :type natural0 :initarg :age))
    371   (:metaclass persistent-class))
    372 
    373 ;;(c2mop:ensure-finalized (find-class 'person2))
    374 ;;(c2mop:class-slots (find-class 'person2))
    375 
    376 #+nil
    377 (let ((x (make-instance 'person :hi "cus" :name "John" :age 12)))
    378   (dolist (s (c2mop:class-slots (class-of x)))
    379     (format t "slot ~s = ~s~%"
    380             (c2mop:slot-definition-name s)
    381             (slot-value x (c2mop:slot-definition-name s)))))
    382 
    383 #+nil
    384 (defun persistent-slot-p (slot)
    385   (when (typep slot 'persistent-slot)
    386     (transient slot)))
    387 
    388 #+nil
    389 (defun list-pslots2 (class)
    390   (c2mop:class-slots class)
    391   #+nil
    392   (remove-if 'transient (c2mop:class-slots class)))
    393 
    394 ;;(list-pslots (find-class 'person))
    395 ;;(list-pslots (class-of (make-instance 'person :hi "cus" :name "John" :age 12)))
    396 
    397 
    398 
    399 
    400 ;; TODO revert to defmethod or hook initialize-instance, ccl expands types too early:-{
    401 (defun list-pslots (class)
    402   (c2mop:class-slots (if (symbolp class) (find-class class) class)))
    403 
    404 (defun pslot-name (a)
    405   (c2mop:slot-definition-name a))
    406 
    407 (defun pslot-ltype (a)
    408   (ltype a))
    409 
    410 (defun pslot-initargs (a)
    411   (c2mop:slot-definition-initargs a))
    412 
    413 (defun pslot-initform (a)
    414   (c2mop:slot-definition-initform a))
    415 
    416 (defun pslot-ptype (a)
    417   (ptype a))
    418 
    419 (defun pslot-nullable (a)
    420   (nullable a))
    421 
    422 ;; (pslot-ptype (cadr (list-pslots (find-class 'person))))
    423 
    424 #+nil
    425 (defpclass bar ()
    426   ((slot1 :initarg :slot1 :accessor slot1)
    427    (slot2 :initarg :slot2 :accessor slot2)))
    428 
    429 ;;(with-instance-cache () (slot2 (make-pinstance 'bar :oid 123 :slot2 2)))
    430 ;;(setf (slot2 (make-instance 'bar :slot2 2)) 3)
    431 ;;(slot-value (make-instance 'bar :slot2 2) 'slot2)
    432 ;;(setf (slot-value (make-instance 'bar :slot2 2) 'slot2) 3)
    433 
    434 #+nil
    435 (defpclass person ()
    436   ((name :type string :initarg :name)
    437    (age :type natural0 :initarg :age))
    438   #+nil
    439   (:metaclass persistent-class))
    440 
    441 #+nil
    442 (defpclass person ()
    443   ((name :type string :initarg :name)
    444    (birth-date :type pdate :initarg :birth-date))
    445   #+nil
    446   (:metaclass persistent-class))
    447 
    448 
    449 
    450 ;;; http://www.b9.com/blog/archives/000084.html
    451 ;;
    452 ;; Also, special thanks to Christophe Rhodes, frequent contributor to
    453 ;; SBCL's MOP, for his excellent suggestion in response to a question
    454 ;; for improving CLSQL's MOP internals: CLSQL object definitions use
    455 ;; custom slot types. For example, a CLSQL slot may have :type
    456 ;; (varchar 10) specified which gets translated to a lisp type of (or
    457 ;; null string). Rather than parsing and then re-storing the type
    458 ;; atrribute of a slot in compute-effective-slot-definiton, Christophe
    459 ;; suggested performing the type parsing in initialize-instance
    460 ;; :around of the CLSQL direct-slot-definition object. Then, the real
    461 ;; type attribute is stored in the both the direct and effective slot
    462 ;; definition from the beginning.This is more AMOP complaint since
    463 ;; AMOP doesn't specify that one may change the type attribute of a
    464 ;; slot. This is clearly seen since CLSQL no longer needs to modify
    465 ;; OpenMCL's ccl:type-predicate slot attribute after the type was
    466 ;; changed in compute-effective-slot-definition.
    467 
    468 
    469 (defclass persistent-object (%persistent-object)
    470   ((oid :type oid :initarg :oid :accessor oid))
    471   (:metaclass persistent-class))
    472 
    473 (defmethod cl-postgres:to-sql-string ((a persistent-object))
    474   (cl-postgres:to-sql-string (oid a)))
    475 
    476 ;;; db stuff
    477 
    478 (defconstant +class-id-bit-size+ 16)
    479 
    480 (defmacro oid-exp (class-id)
    481   (let ((bit-size +class-id-bit-size+))
    482     `(q:backend-ecase
    483       (:oracle (q:+ (q:* (q:nextval oid-seq) (q:power 2 ,bit-size)) ,class-id))
    484       (:postgresql (q:\| (q:<< (q:nextval "oid_seq_") ,bit-size) ,class-id)) ;; TODO oid_seq_ via symbol printing
    485       (:sqlite (q:\| (q:<< (q:nextval oid-seq) ,bit-size) ,class-id)))))
    486 
    487 #+nil
    488 (defun octets-to-integer (octets) ;; TODO
    489   (do ()
    490       ()
    491     ))
    492 
    493 #+nil
    494 (defun string-to-octets () ;; TODO
    495   (babel:string-to-octets (symbol-name class-name) :encoding :utf-8))
    496 
    497 #+nil
    498 (defun class-name-to-class-id (class-name)
    499   (mod (ironclad:octets-to-integer
    500         (ironclad:digest-sequence :crc32 (string-to-octets (symbol-name class-name))))
    501        (expt 2 +class-id-bit-size+)))
    502 
    503 (defmacro defpclass (name superclasses slots)
    504   `(defclass ,name ,(append superclasses '(persistent-object))
    505      ,slots
    506      (:metaclass persistent-class)))
    507 
    508 (defun setup-pclass (class-name)
    509   (2sql:query ()
    510     `(q:create-table
    511       ,class-name
    512       (q:columns
    513         (q:column oid (q:integer-type) nil
    514                   (oid-exp (q:qchunk (class-name-to-class-id ',class-name))))
    515         ,@(loop
    516              for x in (list-pslots class-name)
    517              unless (eq 'oid (pslot-name x))
    518              collect `(q:column ,(pslot-name x)
    519                                 ,(pslot-ptype x)
    520                                 ,(pslot-nullable x)
    521                                 ,(pslot-initform x)))))))
    522 
    523 (defun insert-into (tab args vals returning-cols)
    524   (2sql:apply-query args
    525                     vals
    526                     `(q:insert-into ,tab ,args
    527                        (q:values ,@(mapcar (lambda (x) `(q:qvar ,x)) args))
    528                        (q:returning ,returning-cols))))
    529 
    530 (defun assert-type (value type)
    531   (unless (typep value type)
    532     (cond ;; TODO more cases
    533       ((typep value 'string)
    534        (setq value (coerce value 'simple-string)))
    535       ((typep value 'simple-date:timestamp)
    536        (setq value (multiple-value-bind (y m d hh mm ss ms)
    537                        (simple-date:decode-timestamp value)
    538                      (make-ptimestamp-tz (make-pdate y m d)
    539                                          (make-ptime hh mm ss ms)
    540                                          nil))))
    541       ((subtypep type 'persistent-object)
    542        (setq value (or (gethash value *instance-cache*)
    543                        (make-proxy value))))))
    544   (assert (or (typep value type)
    545               (when (subtypep type 'persistent-object)
    546                 (proxy-p value))))
    547   value)
    548 
    549 (defun cache-pinstance (a)
    550   (assert (not (gethash (oid a) *instance-cache*)))
    551   (setf (gethash (oid a) *instance-cache*) a))
    552 
    553 (defun make-pinstance (class-name &rest args)
    554   (multiple-value-bind (known unknown)
    555       (loop
    556          for x in (list-pslots class-name)
    557          for name = (pslot-name x)
    558          for initarg = (car (pslot-initargs x))
    559          for ltype = (pslot-ltype x)
    560          for c = (member initarg args)
    561          if c collect (list (cadr c) name initarg ltype) into known
    562          else collect (list name initarg ltype) into unknown
    563          finally (return (values known unknown)))
    564     (cache-pinstance
    565      (apply #'make-instance class-name
    566             (nconc
    567              (loop
    568                 for (v name initarg ltype) in known
    569                 appending (list initarg (assert-type v ltype)))
    570              (loop
    571                 for (name initarg ltype) in unknown
    572                 for v in (car
    573                           (insert-into class-name (mapcar #'cadr known)
    574                             (mapcar #'car known)
    575                             (mapcar #'car unknown)))
    576                 appending (list initarg (assert-type v ltype))))))))
    577 
    578 (defun delete-pinstance (a)
    579   (let ((oid (oid a)))
    580     (remhash oid *instance-cache*)
    581     (2sql:query (oid)
    582       `(q:delete-from ,(type-of a)
    583          (q:where (q:= oid (q:qvar oid)))))))
    584 
    585 (defparameter *instance-collector-cache* nil) ;; equal form->fn
    586 
    587 (defmacro with-pinstance-collector-cache (args &body body)
    588   (declare (ignore args))
    589   `(let ((*instance-collector-cache* (make-hash-table :test #'equal)))
    590      ,@body))
    591 
    592 (defparameter *instance-collectors* nil) ;; list fn
    593 
    594 (defmacro query (args form)
    595   `(let* (#+nil(*alias-to-table* (make-hash-table))
    596                (*instance-collectors* nil) ;; TODO that's not right is it? need to remember form->collector! for subsequent queries
    597                (rows (2sql:query ,args ,form)))
    598      ;;(maphash (lambda (k v) (print (list :@@@ k v))) *alias-to-table*)
    599      (multiple-value-bind (value present)
    600          (gethash ,form *instance-collector-cache*)
    601        (cond
    602          (present
    603           (assert (not *instance-collectors*))
    604           (setq *instance-collectors* value))
    605          (t
    606           (setq *instance-collectors* (nreverse *instance-collectors*))
    607           (setf (gethash ,form *instance-collector-cache*) *instance-collectors*))))
    608      (loop
    609         for row in rows
    610         for tail = row
    611         collect (nconc (loop
    612                           for fn in *instance-collectors*
    613                           collect (multiple-value-bind (instance tail2)
    614                                       (funcall fn tail)
    615                                     (setq tail tail2)
    616                                     instance))
    617                        tail))))
    618 
    619 (defmacro instance (tab &optional alias) ;; use inside 2sql queries
    620   (let ((pslots (list-pslots tab)))
    621     (push (lambda (row)
    622             (values (let ((oid (car row))
    623                           (args (loop
    624                                    for x in pslots
    625                                    appending (list (car (pslot-initargs x))
    626                                                    (assert-type (pop row) (pslot-ltype x)))))) ;; TODO resolve pclassp foreign ref (lazy foreign reference?)
    627                       ;;(print (list :@@@ (mapcar (lambda (x) (cons x (type-of x))) args)))
    628                       (or (gethash oid *instance-cache*)
    629                           (cache-pinstance (apply #'make-instance tab args)))
    630                       #+nil
    631                       (unless (eq :null oid)
    632                         ;; TODO uniq oid->instance cache
    633                         (apply #'make-instance tab :oid oid args))) ;; TODO fix values from rdbms backend to lisp, e.g. :null :true :false pclasp
    634                     row))
    635           *instance-collectors*)
    636     `(q:clist
    637        ,@ (flet ((sym (name)
    638                    (if alias
    639                        (intern (format nil "~a.~a" alias name)) ;; TODO avoid intern
    640                        name)))
    641             (mapcar (lambda (x) (sym (pslot-name x))) pslots)))))
    642 
    643 (defun load-instance (class-name oid)
    644   (let ((x (2sql-orm:query (oid)
    645              `(q:select ((instance ,class-name))
    646                 (q:from ,class-name)
    647                 (q:where (q:= oid (q:qvar oid)))))))
    648     (assert (not (cdr x)))
    649     (assert (car x))
    650     (assert (not (cadr x)))
    651     (assert (typep (caar x) class-name))
    652     (caar x)))
    653 
    654 (defmacro with-pclasses (names &body body)
    655   (labels ((rec (x)
    656              (if x
    657                  `(progn
    658                     (c2mop:ensure-finalized (find-class ',(car x)))
    659                     (2sql-orm:setup-pclass ',(car x))
    660                     (unwind-protect ,(rec (cdr x))
    661                       (2sql:query () '(q:drop-table ,(car x) t t))))
    662                  `(progn ,@body))))
    663     (rec names)))
    664 
    665 (defmacro with-psequences (names &body body)
    666   (labels ((rec (x)
    667              (if x
    668                  `(progn
    669                     (2sql:query () '(q:create-sequence ,(car x)))
    670                     (unwind-protect ,(rec (cdr x))
    671                       (2sql:query () '(q:drop-sequence ,(car x) t))))
    672                  `(progn ,@body))))
    673     (rec names)))