cl-2sql

orm.lisp (23832B)

---

 ;;; cl-2sql Copyright (c) 2011 Tomas Hlavaty
 
 (defpackage 2sql-orm
   (:use :cl)
   (:export :textp
            :text
            :defptype
            :defpclass
            :setup-pclass
            :with-instance-cache
            :make-pinstance
            :with-pinstance-collector-cache
            :query
            :instance
            ))
 
 (in-package :2sql-orm)
 
 ;;; orm types
 
 ;; string => string | clob
 ;; string 3 => char 3
 ;; text 5 &optional 2 => varchar 5 (no "" allowed, due to oracle)
 ;; string-or-text => string | varchar
 ;; char 1 => boolean
 
 (defun textp (a max &optional (min 1))
   (and (stringp a) (<= min (length a) max)))
 
 ;; (textp "h" 3)
 ;; (textp "h" 3 2)
 ;; (textp "hi" 3)
 ;; (textp "hi" 3 2)
 ;; (textp "hello" 3)
 ;; (textp "hello" 3 2)
 
 (deftype text (max &optional (min 1))
   (assert (plusp min))
   (assert (< min max))
   (let ((p (gensym)))
     (setf (symbol-function p) #'(lambda (a) (textp a max min)))
     `(and string (satisfies ,p))))
 
 ;; (typep "h" '(text 3))
 ;; (typep "h" '(text 3 2))
 ;; (typep "hi" '(text 3))
 ;; (typep "hi" '(text 3 2))
 ;; (typep "hello" '(text 3))
 ;; (typep "hello" '(text 3 2))
 
 (defstruct (pdate (:constructor make-pdate (y m d))) y m d)
 (defstruct (ptime (:constructor make-ptime (hh mm ss ms))) hh mm ss ms)
 (defstruct (ptimestamp-tz
              (:constructor make-ptimestamp-tz (date time timezone)))
   date time timezone)
 ;;(defstruct pinterval y m d hh mm ss ms)
 
 (defmethod cl-postgres:to-sql-string ((a pdate))
   (with-slots (y m d) a
     (values (format nil "~4,'0d-~2,'0d-~2,'0d" y m d) "date")))
 
 (defmethod cl-postgres:to-sql-string ((a ptimestamp-tz)) ;; TODO timezone
   (with-slots (date time timezone) a
     (with-slots (y m d) date
       (with-slots (hh mm ss ms) time
         (values
           (format nil "~4,'0d-~2,'0d-~2,'0d ~2,'0d:~2,'0d:~2,'0d~@[.~3,'0d~]"
                   y m d hh mm ss (if (zerop ms) nil ms))
           "timestamp")))))
 
 #+nil
 (defmethod cl-postgres:to-sql-string ((a pinterval))
   (with-slots (y m d hh mm ss ms) a
     (if (= year month day hour min sec ms 0)
         (values "0 milliseconds" "interval")
         (flet ((not-zero (x) (if (zerop x) nil x)))
           (values
             (format nil "~@[~d years ~]~@[~d months ~]~@[~d days ~]~@[~d hours ~]~@[~d minutes ~]~@[~d seconds ~]~@[~d milliseconds~]"
                     (not-zero year) (not-zero month) (not-zero day)
                     (not-zero hour) (not-zero min) (not-zero sec) (not-zero ms))
             "interval")))))
 
 (deftype octet () '(unsigned-byte 8))
 (deftype octet-vector (&optional size) `(simple-array octet (,size)))
 
 (defgeneric ptype-macroexpand (type))
 
 (defun persistent-type-p (type)
   (get type 'persistent-type))
 
 (deftype persistent-type () '(satisfies persistent-type-p))
 
 (defun lisp-type-to-ptype (type) ;; TODO more types
   (if (atom type)
       (case type
         (boolean '(q:boolean-type))
         (integer '(q:integer-type))
         (string '(q:varchar-type))
         (pdate '(q:date-type))
         (ptime '(q:time-type))
         (ptimestamp-tz '(q:timestamp-with-timezone-type))
         (octet-vector '(q:blob-type))
         (t
          (cond
            ((subtypep type 'persistent-object) (lisp-type-to-ptype 'oid))
            ((subtypep type 'persistent-type) (lisp-type-to-ptype 'oid))
            ;;((persistent-type-p type) (lisp-type-to-ptype 'oid))
            (t (let ((x (ptype-macroexpand type)))
                 (assert (not (eq x type)))
                 (lisp-type-to-ptype x))))))
       (ecase (car type)
         (or
           (assert (eq 'null (cadr type)))
           (assert (not (cddddr type)))
           (lisp-type-to-ptype (caddr type)))
         (integer `(q:integer-type ,(cadr type)))
         (string `(q:char-type ,(cadr type)))
         (text `(q:varchar-type ,(cadr type))))))
 
 ;; (lisp-type-to-ptype 'integer)
 ;; (lisp-type-to-ptype 'string)
 ;; (lisp-type-to-ptype '(integer 16))
 ;; (lisp-type-to-ptype '(string 3))
 ;; (lisp-type-to-ptype '(text 3))
 ;; (lisp-type-to-ptype '(text 3 2))
 
 (defun lisp-type-nullable-p (type)
   (unless (eql 'boolean type)
     (typep nil type)))
 
 (defmacro defptype (name args specifier &optional db-type db-check)
   `(progn
      (deftype ,name ,args ,specifier)
      (defmethod 2sql-orm::ptype-macroexpand ((type (eql ',name)))
        ,(if db-type `(values ,db-type ,db-check) specifier))))
 
 (defun natural0p (a)
   (and (integerp a) (<= 0 a)))
 
 (defmethod ptype-macroexpand ((type (eql 'list)))
   'string)
 
 (defptype natural0 () '(and integer (satisfies natural0p)) 'integer 'q:le0)
 (defptype natural () '(and integer (satisfies plusp)) 'integer 'q:plusp)
 (defptype universal-time () 'integer 'ptimestamp-tz)
 (defptype oid () 'natural)
 
 ;;; persistent-object
 
 (defparameter *instance-cache* nil)
 
 (defmacro with-instance-cache (args &body body)
   (declare (ignore args))
   `(let ((*instance-cache* (make-hash-table)))
      ,@body))
 
 ;; http://users.encs.concordia.ca/~haarslev/publications/jvlc92/node6.html
 ;; http://objectmix.com/lisp/725624-help-creating-clos-meta-classes.html
 ;; http://www.lispworks.com/documentation/lw50/LWRM/html/lwref-71.htm
 ;; http://paste.lisp.org/display/123125
 ;; http://www.cliki.net/MOP%20design%20patterns
 ;; http://bc.tech.coop/blog/040412.html
 
 (defclass persistent-class (standard-class)
   ())
 
 (defmethod c2mop:validate-superclass ((class persistent-class)
                                       (superclass standard-class))
   t)
 
 (defclass %persistent-object (#+nil standard-object)
   ()
   (:metaclass persistent-class))
 
 ;;(c2mop:ensure-finalized (find-class 'persistent-object))
 ;;(c2mop:class-slots (find-class 'persistent-object))
 
 ;; http://www.cliki.net/MOP%20design%20patterns
 #+nil ;; TODO add persistent-object superclass automatically
 (defmacro init-instance ()
   `(call-next-method)
   #+nil
   `(if (or #+nil(eq 'persistent-class (class-name class))
            (loop
               for x in direct-superclasses
               thereis (subtypep x (find-class 'persistent-object))))
        ;; already one of the (indirect) superclasses
        (call-next-method)
        ;; not one of the superclasses, so we have to add it
        (apply #'call-next-method class
               :direct-superclasses (append direct-superclasses
                                            (list (find-class 'persistent-object)))
               initargs)))
 
 ;; http://www.cliki.net/MOP%20design%20patterns
 #+nil ;; TODO add persistent-object superclass automatically
 (defmethod initialize-instance :around ((class persistent-class) &rest initargs
                                         &key direct-superclasses)
   (declare (dynamic-extent initargs))
   (init-instance))
 
 ;; http://www.cliki.net/MOP%20design%20patterns
 #+nil ;; TODO add persistent-object superclass automatically
 (defmethod reinitialize-instance :around
     ((class persistent-class) &rest initargs
      &key (direct-superclasses '() direct-superclasses-p))
   (declare (dynamic-extent initargs))
   (if direct-superclasses-p
       ;; if direct superclasses are explicitly passed this is exactly
       ;; like above
       (init-instance)
       ;; if direct superclasses are not explicitly passed we _must_
       ;; not change anything
       (call-next-method)))
 
 (defparameter *initializing-instance* nil)
 
 (defun check-cached-instance (a)
   (unless *initializing-instance*
     (assert (eq a (gethash (oid a) *instance-cache*)))))
 
 (defmethod c2mop::shared-initialize :around ((object %persistent-object)
                                              slot-names &rest initargs
                                              &key &allow-other-keys)
   (declare (ignore initargs))
   (let ((*initializing-instance* t))
     (call-next-method)))
 
 (defmethod c2mop:slot-value-using-class :before ((class persistent-class)
                                                  (a %persistent-object)
                                                  slotd)
   (unless (eq 'oid (c2mop:slot-definition-name slotd))
     (check-cached-instance a)))
 
 (defmethod (setf c2mop:slot-value-using-class) :before (value
                                                         (class persistent-class)
                                                         (a %persistent-object)
                                                         slotd)
   (unless (eq 'oid (c2mop:slot-definition-name slotd))
     (check-cached-instance a)))
 
 (defstruct (proxy (:constructor make-proxy (oid))) oid)
 
 (defmethod c2mop:slot-value-using-class :around ((class persistent-class)
                                                  (a %persistent-object)
                                                  slotd)
   (let ((s (call-next-method)))
     (if (proxy-p s)
         (load-instance (ltype slotd) (proxy-oid s))
         s)))
 
 (defmethod (setf c2mop:slot-value-using-class) :around (value
                                                         (class persistent-class)
                                                         (a %persistent-object)
                                                         slotd)
   ;; TODO ? enforce assert-type?
   (let ((x (call-next-method)))
     (unless *initializing-instance*
       (let ((oid (oid a)))
         (2sql:query (oid value)
           `(q:update ,(class-name class)
                      ((,(pslot-name slotd) (q:qvar value)))
                      (q:where (q:= oid (q:qvar oid)))))))
     x))
 
 ;;; persistent slots
 
 (defclass persistent-slot-definition ()
   ((ltype :reader ltype) ;; remember unexpanded
    (ptype :reader ptype) ;; remember computed
    (nullable :reader nullable)
    (transient :type boolean :initarg :transient :initform nil :accessor transient)))
 
 (defclass persistent-direct-slot-definition
     (persistent-slot-definition c2mop:standard-direct-slot-definition)
   ())
 
 (defclass persistent-effective-slot-definition
     (persistent-slot-definition c2mop:standard-effective-slot-definition)
   ())
 
 (defmethod c2mop:direct-slot-definition-class :around
     ((class persistent-class) &rest initargs)
   ;;(print (list :@@@-direct-slot-definition-class initargs))
   (find-class 'persistent-direct-slot-definition))
 
 (defmethod c2mop:effective-slot-definition-class
     ((class persistent-class) &rest initargs)
   ;;(format t "getting eff class. initargs=~s~%" initargs)
   (find-class 'persistent-effective-slot-definition))
 
 #+nil
 (defmethod c2mop:compute-effective-slot-definition
     ((class persistent-class) slot-name direct-slots)
   (call-next-method)
   #+nil
   (format t "computing slot definition: class=~s name=~s slots=~s~%"
           class slot-name direct-slots)
   #+nil
   (let ((result (call-next-method)))
     ;;(break "~s" result)
     #+nil
     (format t "    result: ~s~%" result)
     result))
 
 (defmethod initialize-instance :before
     ((class persistent-direct-slot-definition) &rest initargs
      &key direct-superclasses)
   (declare (ignore direct-superclasses))
   (with-slots (ltype ptype nullable) class ;; TODO transient
     (setq ltype (getf initargs :type)
           ptype (lisp-type-to-ptype ltype)
           nullable (unless (eql 'boolean ltype)
                      (typep nil ltype)))))
 
 (defmethod c2mop:compute-effective-slot-definition :around
     ((class persistent-class) name direct-slot-definitions)
   (let ((x (call-next-method)))
     (assert (not (cdr direct-slot-definitions))) ;; TODO
     (let ((slotd (car direct-slot-definitions)))
       (assert (typep slotd 'persistent-slot-definition))
       (with-slots (ltype ptype nullable) x ;; TODO transient
         (setq ltype (ltype slotd)
               ptype (ptype slotd)
               nullable (nullable slotd))))
     x))
 
 #+nil
 (defmethod initialize-instance :around
     ((class persistent-direct-slot-definition) &rest initargs
      &key direct-superclasses)
   ;;(declare (ignore direct-superclasses))
   #+nil
   (with-slots (ltype ptype nullable) class
     (setq ltype (getf initargs :type)
           ptype (lisp-type-to-ptype ltype)
           nullable (unless (eql 'boolean ltype)
                      (typep nil ltype))))
   (call-next-method)
   #+nil
   (let ((ltype (getf initargs :type)))
     (apply #'call-next-method
            class
            `(:ltype ,ltype
                     :ptype ,(lisp-type-to-ptype ltype)
                     :nullable ,(unless (eql 'boolean ltype)
                                        (typep nil ltype))
                     ,@initargs)
            direct-superclasses)))
 
 #+nil
 (defclass foo ()
   ((hi :initarg :hi)))
 
 ;;(c2mop:class-slots (find-class 'foo))
 
 #+nil
 (defclass person (#+nil persistent-object foo)
   ((name :type string :initarg :name #+nil :transient #+nil t)
    (age :type natural0 :initarg :age))
   (:metaclass persistent-class))
 
 ;;(slot-value (make-instance 'person :age 12) 'age)
 
 ;;(c2mop:class-slots (find-class 'person))
 
 #+nil
 (defclass person2 (persistent-object foo)
   ((name :type string :initarg :name #+nil :transient #+nil t)
    (age :type natural0 :initarg :age))
   (:metaclass persistent-class))
 
 ;;(c2mop:ensure-finalized (find-class 'person2))
 ;;(c2mop:class-slots (find-class 'person2))
 
 #+nil
 (let ((x (make-instance 'person :hi "cus" :name "John" :age 12)))
   (dolist (s (c2mop:class-slots (class-of x)))
     (format t "slot ~s = ~s~%"
             (c2mop:slot-definition-name s)
             (slot-value x (c2mop:slot-definition-name s)))))
 
 #+nil
 (defun persistent-slot-p (slot)
   (when (typep slot 'persistent-slot)
     (transient slot)))
 
 #+nil
 (defun list-pslots2 (class)
   (c2mop:class-slots class)
   #+nil
   (remove-if 'transient (c2mop:class-slots class)))
 
 ;;(list-pslots (find-class 'person))
 ;;(list-pslots (class-of (make-instance 'person :hi "cus" :name "John" :age 12)))
 
 
 
 
 ;; TODO revert to defmethod or hook initialize-instance, ccl expands types too early:-{
 (defun list-pslots (class)
   (c2mop:class-slots (if (symbolp class) (find-class class) class)))
 
 (defun pslot-name (a)
   (c2mop:slot-definition-name a))
 
 (defun pslot-ltype (a)
   (ltype a))
 
 (defun pslot-initargs (a)
   (c2mop:slot-definition-initargs a))
 
 (defun pslot-initform (a)
   (c2mop:slot-definition-initform a))
 
 (defun pslot-ptype (a)
   (ptype a))
 
 (defun pslot-nullable (a)
   (nullable a))
 
 ;; (pslot-ptype (cadr (list-pslots (find-class 'person))))
 
 #+nil
 (defpclass bar ()
   ((slot1 :initarg :slot1 :accessor slot1)
    (slot2 :initarg :slot2 :accessor slot2)))
 
 ;;(with-instance-cache () (slot2 (make-pinstance 'bar :oid 123 :slot2 2)))
 ;;(setf (slot2 (make-instance 'bar :slot2 2)) 3)
 ;;(slot-value (make-instance 'bar :slot2 2) 'slot2)
 ;;(setf (slot-value (make-instance 'bar :slot2 2) 'slot2) 3)
 
 #+nil
 (defpclass person ()
   ((name :type string :initarg :name)
    (age :type natural0 :initarg :age))
   #+nil
   (:metaclass persistent-class))
 
 #+nil
 (defpclass person ()
   ((name :type string :initarg :name)
    (birth-date :type pdate :initarg :birth-date))
   #+nil
   (:metaclass persistent-class))
 
 
 
 ;;; http://www.b9.com/blog/archives/000084.html
 ;;
 ;; Also, special thanks to Christophe Rhodes, frequent contributor to
 ;; SBCL's MOP, for his excellent suggestion in response to a question
 ;; for improving CLSQL's MOP internals: CLSQL object definitions use
 ;; custom slot types. For example, a CLSQL slot may have :type
 ;; (varchar 10) specified which gets translated to a lisp type of (or
 ;; null string). Rather than parsing and then re-storing the type
 ;; atrribute of a slot in compute-effective-slot-definiton, Christophe
 ;; suggested performing the type parsing in initialize-instance
 ;; :around of the CLSQL direct-slot-definition object. Then, the real
 ;; type attribute is stored in the both the direct and effective slot
 ;; definition from the beginning.This is more AMOP complaint since
 ;; AMOP doesn't specify that one may change the type attribute of a
 ;; slot. This is clearly seen since CLSQL no longer needs to modify
 ;; OpenMCL's ccl:type-predicate slot attribute after the type was
 ;; changed in compute-effective-slot-definition.
 
 
 (defclass persistent-object (%persistent-object)
   ((oid :type oid :initarg :oid :accessor oid))
   (:metaclass persistent-class))
 
 (defmethod cl-postgres:to-sql-string ((a persistent-object))
   (cl-postgres:to-sql-string (oid a)))
 
 ;;; db stuff
 
 (defconstant +class-id-bit-size+ 16)
 
 (defmacro oid-exp (class-id)
   (let ((bit-size +class-id-bit-size+))
     `(q:backend-ecase
       (:oracle (q:+ (q:* (q:nextval oid-seq) (q:power 2 ,bit-size)) ,class-id))
       (:postgresql (q:\| (q:<< (q:nextval "oid_seq_") ,bit-size) ,class-id)) ;; TODO oid_seq_ via symbol printing
       (:sqlite (q:\| (q:<< (q:nextval oid-seq) ,bit-size) ,class-id)))))
 
 #+nil
 (defun octets-to-integer (octets) ;; TODO
   (do ()
       ()
     ))
 
 #+nil
 (defun string-to-octets () ;; TODO
   (babel:string-to-octets (symbol-name class-name) :encoding :utf-8))
 
 #+nil
 (defun class-name-to-class-id (class-name)
   (mod (ironclad:octets-to-integer
         (ironclad:digest-sequence :crc32 (string-to-octets (symbol-name class-name))))
        (expt 2 +class-id-bit-size+)))
 
 (defmacro defpclass (name superclasses slots)
   `(defclass ,name ,(append superclasses '(persistent-object))
      ,slots
      (:metaclass persistent-class)))
 
 (defun setup-pclass (class-name)
   (2sql:query ()
     `(q:create-table
       ,class-name
       (q:columns
         (q:column oid (q:integer-type) nil
                   (oid-exp (q:qchunk (class-name-to-class-id ',class-name))))
         ,@(loop
              for x in (list-pslots class-name)
              unless (eq 'oid (pslot-name x))
              collect `(q:column ,(pslot-name x)
                                 ,(pslot-ptype x)
                                 ,(pslot-nullable x)
                                 ,(pslot-initform x)))))))
 
 (defun insert-into (tab args vals returning-cols)
   (2sql:apply-query args
                     vals
                     `(q:insert-into ,tab ,args
                        (q:values ,@(mapcar (lambda (x) `(q:qvar ,x)) args))
                        (q:returning ,returning-cols))))
 
 (defun assert-type (value type)
   (unless (typep value type)
     (cond ;; TODO more cases
       ((typep value 'string)
        (setq value (coerce value 'simple-string)))
       ((typep value 'simple-date:timestamp)
        (setq value (multiple-value-bind (y m d hh mm ss ms)
                        (simple-date:decode-timestamp value)
                      (make-ptimestamp-tz (make-pdate y m d)
                                          (make-ptime hh mm ss ms)
                                          nil))))
       ((subtypep type 'persistent-object)
        (setq value (or (gethash value *instance-cache*)
                        (make-proxy value))))))
   (assert (or (typep value type)
               (when (subtypep type 'persistent-object)
                 (proxy-p value))))
   value)
 
 (defun cache-pinstance (a)
   (assert (not (gethash (oid a) *instance-cache*)))
   (setf (gethash (oid a) *instance-cache*) a))
 
 (defun make-pinstance (class-name &rest args)
   (multiple-value-bind (known unknown)
       (loop
          for x in (list-pslots class-name)
          for name = (pslot-name x)
          for initarg = (car (pslot-initargs x))
          for ltype = (pslot-ltype x)
          for c = (member initarg args)
          if c collect (list (cadr c) name initarg ltype) into known
          else collect (list name initarg ltype) into unknown
          finally (return (values known unknown)))
     (cache-pinstance
      (apply #'make-instance class-name
             (nconc
              (loop
                 for (v name initarg ltype) in known
                 appending (list initarg (assert-type v ltype)))
              (loop
                 for (name initarg ltype) in unknown
                 for v in (car
                           (insert-into class-name (mapcar #'cadr known)
                             (mapcar #'car known)
                             (mapcar #'car unknown)))
                 appending (list initarg (assert-type v ltype))))))))
 
 (defun delete-pinstance (a)
   (let ((oid (oid a)))
     (remhash oid *instance-cache*)
     (2sql:query (oid)
       `(q:delete-from ,(type-of a)
          (q:where (q:= oid (q:qvar oid)))))))
 
 (defparameter *instance-collector-cache* nil) ;; equal form->fn
 
 (defmacro with-pinstance-collector-cache (args &body body)
   (declare (ignore args))
   `(let ((*instance-collector-cache* (make-hash-table :test #'equal)))
      ,@body))
 
 (defparameter *instance-collectors* nil) ;; list fn
 
 (defmacro query (args form)
   `(let* (#+nil(*alias-to-table* (make-hash-table))
                (*instance-collectors* nil) ;; TODO that's not right is it? need to remember form->collector! for subsequent queries
                (rows (2sql:query ,args ,form)))
      ;;(maphash (lambda (k v) (print (list :@@@ k v))) *alias-to-table*)
      (multiple-value-bind (value present)
          (gethash ,form *instance-collector-cache*)
        (cond
          (present
           (assert (not *instance-collectors*))
           (setq *instance-collectors* value))
          (t
           (setq *instance-collectors* (nreverse *instance-collectors*))
           (setf (gethash ,form *instance-collector-cache*) *instance-collectors*))))
      (loop
         for row in rows
         for tail = row
         collect (nconc (loop
                           for fn in *instance-collectors*
                           collect (multiple-value-bind (instance tail2)
                                       (funcall fn tail)
                                     (setq tail tail2)
                                     instance))
                        tail))))
 
 (defmacro instance (tab &optional alias) ;; use inside 2sql queries
   (let ((pslots (list-pslots tab)))
     (push (lambda (row)
             (values (let ((oid (car row))
                           (args (loop
                                    for x in pslots
                                    appending (list (car (pslot-initargs x))
                                                    (assert-type (pop row) (pslot-ltype x)))))) ;; TODO resolve pclassp foreign ref (lazy foreign reference?)
                       ;;(print (list :@@@ (mapcar (lambda (x) (cons x (type-of x))) args)))
                       (or (gethash oid *instance-cache*)
                           (cache-pinstance (apply #'make-instance tab args)))
                       #+nil
                       (unless (eq :null oid)
                         ;; TODO uniq oid->instance cache
                         (apply #'make-instance tab :oid oid args))) ;; TODO fix values from rdbms backend to lisp, e.g. :null :true :false pclasp
                     row))
           *instance-collectors*)
     `(q:clist
        ,@ (flet ((sym (name)
                    (if alias
                        (intern (format nil "~a.~a" alias name)) ;; TODO avoid intern
                        name)))
             (mapcar (lambda (x) (sym (pslot-name x))) pslots)))))
 
 (defun load-instance (class-name oid)
   (let ((x (2sql-orm:query (oid)
              `(q:select ((instance ,class-name))
                 (q:from ,class-name)
                 (q:where (q:= oid (q:qvar oid)))))))
     (assert (not (cdr x)))
     (assert (car x))
     (assert (not (cadr x)))
     (assert (typep (caar x) class-name))
     (caar x)))
 
 (defmacro with-pclasses (names &body body)
   (labels ((rec (x)
              (if x
                  `(progn
                     (c2mop:ensure-finalized (find-class ',(car x)))
                     (2sql-orm:setup-pclass ',(car x))
                     (unwind-protect ,(rec (cdr x))
                       (2sql:query () '(q:drop-table ,(car x) t t))))
                  `(progn ,@body))))
     (rec names)))
 
 (defmacro with-psequences (names &body body)
   (labels ((rec (x)
              (if x
                  `(progn
                     (2sql:query () '(q:create-sequence ,(car x)))
                     (unwind-protect ,(rec (cdr x))
                       (2sql:query () '(q:drop-sequence ,(car x) t))))
                  `(progn ,@body))))
     (rec names)))