commit 0bbd621ebf756f76a05e81579f86ca63644e0aa7
parent 2853aa882c9be6718135107b6ea166b90e877c9e
Author: Tomas Hlavaty <tom@logand.com>
Date: Sat, 13 Aug 2011 21:46:13 +0200
toxi tags example added
Diffstat:
| M | orm.lisp | | | 12 | +++++++++++- |
| M | test.lisp | | | 64 | ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
2 files changed, 75 insertions(+), 1 deletion(-)
diff --git a/orm.lisp b/orm.lisp
@@ -253,7 +253,7 @@
appending (list (pslot-initarg x) (pop row))))) ;; TODO resolve pclassp foreign ref (lazy foreign reference?)
(unless (eq :null oid)
;; TODO uniq oid->instance cache
- (apply #'make-instance tab :oid oid args)))
+ (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
@@ -262,3 +262,13 @@
(intern (format nil "~a.~a" alias name)) ;; TODO avoid intern
name)))
(cons (sym 'oid) (mapcar (lambda (x) (sym (pslot-name x))) pslots))))))
+
+(defmacro with-pclasses (names &body body)
+ (labels ((rec (rest)
+ (if rest
+ `(progn
+ (2sql-orm:setup-pclass ',(car rest))
+ (unwind-protect ,(rec (cdr rest))
+ (2sql:query () '(q:drop-table ,(car rest) t t))))
+ `(progn ,@body))))
+ (rec names)))
diff --git a/test.lisp b/test.lisp
@@ -431,3 +431,67 @@ bytea (vector (unsigned-byte 8))
select => populate instances
update => clear affected instances from cache
delete => clear affected instances from cache
+
+;;; http://www.pui.ch/phred/archives/2005/04/tags-database-schemas.html
+;;; toxi solution
+
+(2sql-orm:defptype tag-name () '(2sql-orm:text 32))
+(2sql-orm:defptype bookmark-name () '(2sql-orm:text 128))
+
+(2sql-orm:defpclass tag ()
+ ((name :type tag-name :initarg :name)))
+
+(2sql-orm:defpclass bookmark ()
+ ((name :type bookmark-name :initarg :name)))
+
+(2sql-orm:defpclass tagmap ()
+ ((bookmark :type bookmark :initarg :bookmark)
+ (tag :type tag :initarg :tag)))
+
+(defun make-tag (name)
+ (2sql-orm:make-pinstance 'tag :name name))
+
+(defun make-bookmark (name)
+ (2sql-orm:make-pinstance 'bookmark :name name))
+
+(defun make-tagmap (bookmark tag)
+ (2sql-orm:make-pinstance 'tagmap :bookmark bookmark :tag tag))
+
+(defun build-sql-query (q)
+ (if (atom q)
+ `(q:select ((2sql-orm:instance bookmark b)) ;; TODO b.*
+ (q:from (q:as bookmark b) (q:as tag t) (q:as tagmap m))
+ (q:where (q:and (q:= b.oid m.bookmark)
+ (q:= t.oid m.tag)
+ (q:= t.name ,q))))
+ (ecase (car q)
+ (and `(q:intersect nil nil nil ,@(mapcar 'build-sql-query (cdr q))))
+ (or `(q:union nil nil nil ,@(mapcar 'build-sql-query (cdr q))))
+ (not `(q:except nil nil nil ,@(mapcar 'build-sql-query (cdr q)))))))
+
+(2sql-backend:with-postgresql-connection ("pokus" "tomas" "test123" "localhost")
+ (2sql-orm:with-pinstance-collector-cache ()
+ (2sql-orm::with-pclasses (tag bookmark tagmap)
+ (let* ((t1 (make-tag "bookmark"))
+ (t2 (make-tag "webservice"))
+ (t3 (make-tag "semweb"))
+ (t4 (make-tag "lisp"))
+ (t5 (make-tag "sql"))
+ (b1 (make-bookmark "b1"))
+ (b2 (make-bookmark "b2")))
+ (make-tagmap b1 t1)
+ (make-tagmap b1 t2)
+ (make-tagmap b1 t3)
+ (make-tagmap b1 t4)
+ (make-tagmap b2 t1)
+ (make-tagmap b2 t2)
+ (flet ((look-up (q)
+ (2sql-orm:query () ;; TODO cache compiled queries
+ `(q:select ((2sql-orm:instance bookmark))
+ (q:from (q:as (q:par ,(build-sql-query q)) x))))))
+ ;; Query for “bookmark+webservice+semweb”
+ (look-up '(and "bookmark" "webservice" "semweb"))
+ ;; Query for “bookmark|webservice|semweb”
+ (look-up '(or "bookmark" "webservice" "semweb"))
+ ;; Query for “bookmark+webservice-semweb”
+ (look-up '(not (and "bookmark" "webservice") "semweb")))))))
