commit 8e206af9049496c9c07b904693c551b7b63f7f5b
parent 8e6fcdc06534b8ee2799737360f9e89473ef1ea5
Author: Tomas Hlavaty <tom@logand.com>
Date: Mon, 8 Aug 2011 00:36:45 +0200
orm select aka x-query roughly works
Diffstat:
| M | macros.lisp | | | 6 | ++++-- |
| M | orm.lisp | | | 95 | +++++++++++++++++++++++++++++++++++++++++++++++++++---------------------------- |
| M | test.lisp | | | 14 | ++++++++------ |
3 files changed, 73 insertions(+), 42 deletions(-)
diff --git a/macros.lisp b/macros.lisp
@@ -98,9 +98,11 @@
`(prefix ,what :between ,lexp :and ,rexp))
(defsyntax select (cols &body body)
- `(prefix :select ,(cl:if (cl:atom cols) cols `(clist ,@cols)) ,@body))
+ `(prefix :select ,(cl:if (cl:or (cl:atom cols) (cl:atom (cl:car cols)))
+ cols
+ `(clist ,@cols)) ,@body))
-(defsyntax from (&body body) `(prefix :from ,@body))
+(defsyntax from (&body body) `(prefix :from (clist ,@body)))
(defsyntax where (exp) `(prefix :where ,exp))
(defsyntax order-by (&body clist) `(prefix :order :by (clist ,@clist)))
(defsyntax group-by (&body clist) `(prefix :group :by (clist ,@clist)))
diff --git a/orm.lisp b/orm.lisp
@@ -35,6 +35,11 @@
(c2 :type (or null integer) :initarg :c2 :initform nil :accessor c2)
(c3 :type integer :initarg :c3 :initform 321 :accessor c3)))
+(defpclass t2 ()
+ ((d1 :type integer :initarg :d1 :accessor d1)
+ (d2 :type (or null integer) :initarg :d2 :initform nil :accessor d2)
+ (d3 :type integer :initarg :d3 :initform 271 :accessor d3)))
+
(defconstant +class-id-bit-size+ 16)
(defmacro oid-exp (class-id)
@@ -51,7 +56,7 @@
(defun setup-pclass (class-name)
(2sql:query ()
- `(q:create-table t1
+ `(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))))
@@ -91,50 +96,72 @@
(2sql-backend:with-postgresql-connection ("pokus" "tomas" "test123" "localhost")
(2sql:query () '(q:drop-sequence oid-seq t))
(2sql:query () '(q:create-sequence oid-seq))
- (with-tables (t1)
+ (with-tables (t1 t2)
(make-pinstance 't1 :c1 1 :c2 2 :c3 3)
(make-pinstance 't1 :c1 1 :c2 2)
(2sql:query () '(q:select :* (q:from t1)))
- #+nil(x-query (q:select ((x-instance t1)) (q:from t1)))))
-
-
-(defparameter *x-alias-to-table* nil)
+ #+nil
+ (x-query ()
+ '(q:select ((x-instance t1 x) (q:sum x.c1))
+ (q:from (q:as t1 x))))
+ ;;(x-query () '(q:select ((x-instance t1)) (q:from t1)))
+ (x-query ()
+ '(q:select ((x-instance t1 a) (x-instance t2 b) a.c2)
+ (q:from (q:left-join (q:as t1 a) (q:as t2 b) (q:= a.c1 b.d1)))))
+ ;;(x-query () '(q:select ((x-instance t1)) (q:from t1))) ;; doesnt work 2nd time
+ ))
-(defmacro x-query (form &rest qvars)
- ;; remember stuff, run instance reconstructor at the end
- `(funcall (compile nil `(lambda ()
- (let (((*x-alias-to-table* (make-hash-table))))
- (%query ,,form ,,@qvars)))))
- #+nil
- `(let* ((*x-alias-to-table* (make-hash-table))
- #+nil(x (macroexpand `(%query ,,form ,,@qvars))))
- ;;x
- ))
+;;(defparameter *x-alias-to-table* nil)
+(defparameter *x-instance-collectors* nil) ;; list fn
#+nil
-(defmacro x-select (cols &body body)
- ;; slice in x-instance slots
- `(q:select (clist ,@cols) ,@body))
-
-(defmacro x-instance (x)
- ;; push slot collector and instance reconstructor
- `(clist
- ,@(loop
- for class-name = (gethash x *x-alias-to-table* x)
- for (name type nullable initarg default) in (list-pslots class-name)
- collect name)))
-
+(defmacro x-columns (cols)
+ (cols))
+
+(defmacro x-query (args form)
+ `(let* (#+nil(*x-alias-to-table* (make-hash-table))
+ (*x-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))) *x-alias-to-table*)
+ (setq *x-instance-collectors* (nreverse *x-instance-collectors*))
+ (print *x-instance-collectors*)
+ (loop
+ for row in rows
+ for tail = row
+ collect (nconc (loop
+ for fn in *x-instance-collectors*
+ collect (multiple-value-bind (instance tail2)
+ (funcall fn tail)
+ (setq tail tail2)
+ instance))
+ tail))))
+
+#+nil ;; happens after x-instance:-{
(defmacro x-as (tab alias)
;; remember alias -> tab
(assert (not (gethash alias *x-alias-to-table*)))
(setf (gethash alias *x-alias-to-table*) tab)
- (list tab alias))
-
-(x-query
- (x-select ((x-instance x) (x-instance y) (q:sum y.total))
- (q:from (x-as t1 x) (x-as t2 y))
- (q:where 1)))
+ `(q:as ,tab ,alias))
+
+(defmacro x-instance (tab &optional alias)
+ (let ((pslots (list-pslots tab)))
+ (push (lambda (row)
+ (values (let ((oid (pop row))
+ (args (loop
+ for (name type nullable initarg default) in pslots
+ appending (list initarg (pop row)))))
+ (unless (eq :null oid)
+ ;; TODO uniq oid instance cache
+ (apply #'make-instance tab :oid oid args)))
+ row))
+ *x-instance-collectors*)
+ `(q:clist
+ ,@ (flet ((sym (name)
+ (if alias
+ (intern (format nil "~a.~a" alias name)) ;; TODO avoid intern
+ name)))
+ (cons (sym 'oid) (mapcar (lambda (x) (sym (car x))) pslots))))))
select => populate instances
update => clear affected instances from cache
diff --git a/test.lisp b/test.lisp
@@ -312,13 +312,15 @@ bytea (vector (unsigned-byte 8))
-(with-postgresql-connection ("pokus" "tomas" "test123" "localhost")
- (query (q:create-table t1 nil ((q:column c1 (q:integer-type))
- (q:column c2 (q:integer-type) 314)))))
-
-(with-postgresql-connection ("pokus" "tomas" "test123" "localhost")
- (query (q:drop-table t1)))
+(2sql-backend:with-postgresql-connection ("pokus" "tomas" "test123" "localhost")
+ (query ()
+ '(q:create-table t1 (q:columns
+ (q:column c1 (q:integer-type))
+ (q:column c2 (q:integer-type) 314)))))
+(2sql-backend:with-postgresql-connection ("pokus" "tomas" "test123" "localhost")
+ (query ()
+ '(q:drop-table t1)))
