make-dao, query-dao and new select-dao
Tue Oct 16 14:30:57 PDT 2007 Ryszard Szopa <ryszard.szopa@gmail.com>
* make-dao, query-dao and new select-dao
Make-dao: initiates a DAO object basing on alist of (slot-name . slot-value) pairs.
Query-dao: allows making dao's from arbitrary (s-)sql.
Select-sql has been rewritten to use QUERY-DAO, which makes it more efficient.
Tests included.
diff -rN -u old-submarine/dao.lisp new-submarine/dao.lisp
--- old-submarine/dao.lisp 2014-08-01 02:54:24.000000000 -0700
+++ new-submarine/dao.lisp 2014-08-01 02:54:24.000000000 -0700
@@ -121,13 +121,49 @@
(make-instance (slot-definition-type slot) :id value-from-db)
value-from-db)))))))))))
+(defun make-dao (type initargs)
+ "Create a DAO of the given `TYPE' and initialize it according
+ to the values of the alist `INITARGS'. `Initargs' may contain
+ additional values, not used in the initialization proccess."
+ (let ((instance (make-instance type)))
+ (iter (for slot in (slots-of instance))
+ (setf (slot-value instance (slot-definition-name slot))
+ (let ((the-value (cdr (assoc (intern (symbol-name (slot-definition-name slot)) 'keyword) initargs))))
+ (if (foreign-type-p slot)
+ (make-instance (sb-pcl:slot-definition-type slot) :id the-value)
+ the-value))))
+ instance))
+
+(defun query-dao-fun (type query)
+ "Execute the given `QUERY' (which can be either a string or a
+S-SQL expression, which will be evaluated) and return the result
+as daos of the given `TYPE'. The names of the fields returned by
+the query must match the slots of the dao. This is a functional
+interface for `QUERY-DAO'."
+ (mapcar (lambda (x)
+ (make-dao type x))
+ (with-class-connection ((find-class type))
+ (postmodern:query (postmodern:sql-compile query) :alists))))
+
+(defmacro query-dao (type query)
+ "Execute the given `QUERY' (which can be either a string or a
+S-SQL expression, which won't be evaluated) and return the result
+as daos of the given `TYPE'. The names of the fields returned by
+the query must match the slots of the dao."
+ `(query-dao-fun ,type ',query))
+
(defun select-dao-fun (type test)
"Functional interface for SELECT-DAO."
- (with-class-connection ((find-class type))
- (mapcar (lambda (x) (make-instance type :id (car x)))
- (postmodern:query (:select 'id :from type :where (:raw (if (stringp test)
- test
- (sql-compile test))))))))
+ (query-dao-fun type `(:select * :from ,type
+ :where (:raw ,(if (stringp test)
+ test
+ (sql-compile test))))))
+
+(defmacro select-dao (type &optional (test t))
+ "Select daos of TYPE for the rows in its table for which the given TEST
+holds."
+ `(select-dao-fun ,type ',test))
+
(defgeneric dao= (left right &key test)
(:documentation "T if all the slot-values of `LEFT' and `RIGHT'
are the same. If the compared values are not DAO's, they are
@@ -145,11 +181,6 @@
(always (dao= (slot-value left slot-name)
(slot-value right slot-name) :test test)))))
-(defmacro select-dao (type &optional (test t))
- "Select daos of TYPE for the rows in its table for which the given TEST
-holds."
- `(select-dao-fun ,type ',test))
-
(defgeneric delete-dao (dao)
(:documentation "Delete the given dao from the database.")
(:method ((dao dao))
diff -rN -u old-submarine/package.lisp new-submarine/package.lisp
--- old-submarine/package.lisp 2014-08-01 02:54:24.000000000 -0700
+++ new-submarine/package.lisp 2014-08-01 02:54:24.000000000 -0700
@@ -12,8 +12,8 @@
#:with-connection #:with-object-connection #:with-class-connection
#:def-many-to-many #:relate #:relatedp #:unrelate
#:make-and-save
- #:dao #:defdao #:save-dao #:dao-exists-p #:insert-dao #:update-dao #:dao=
- #:select-dao #:select-dao-fun #:get-dao #:delete-dao #:get-id
+ #:dao #:defdao #:save-dao #:dao-exists-p #:insert-dao #:update-dao #:dao= #:make-dao
+ #:select-dao #:select-dao-fun #:query-dao #:query-dao-fun #:get-dao #:delete-dao #:get-id
#:get-all))
;;; Copyright (C) 2007
diff -rN -u old-submarine/submarine-tests.lisp new-submarine/submarine-tests.lisp
--- old-submarine/submarine-tests.lisp 2014-08-01 02:54:24.000000000 -0700
+++ new-submarine/submarine-tests.lisp 2014-08-01 02:54:24.000000000 -0700
@@ -345,6 +345,38 @@
(is-false (dao= jeden other-jeden))
(is-false (dao= jeden bad-jeden))))
+
+(db-test (make-dao :depends-on (and dao= dao-definition))
+ (defdao-example ocho ()
+ ((ene :initarg :ene :accessor ene-of :type integer)
+ (due :initarg :due :accessor due-of :type integer)))
+
+ (let* ((ocho (make-and-save 'ocho :ene 1 :due 2))
+ (select (with-object-connection (ocho)
+ (postmodern::query (:limit (:select '* :from 'ocho) 1) :alist)))
+ (canned-ocho (submarine::make-dao 'ocho select)))
+ (is (dao= ocho canned-ocho))))
+
+(db-test (make-dao-foreign :depends-on (and dao= dao-definition))
+ (defdao-example diez ()
+ ())
+ (defdao-example nueve ()
+ ((diez :initarg :diez :accessor diez-of :type diez :foreign t)))
+
+
+ (let* ((diez (make-and-save 'diez))
+ (nueve (make-and-save 'nueve :diez diez))
+ (select (with-object-connection (nueve)
+ (postmodern::query (:limit (:select '* :from 'nueve) 1) :alist)))
+ (canned-nueve (submarine::make-dao 'nueve select)))
+ (is (dao= nueve canned-nueve))))
+
+(db-test (query-dao :depends-on (and make-dao make-dao-foreign))
+ (defdao-example once ()
+ ((foo :initarg :foo :type integer)))
+ (let ((once (make-and-save 'once :foo 44))
+ (canned-once (car (query-dao 'once (:limit (:select * :from once) 1)))))
+ (is (dao= once canned-once))))
;;; Copyright (C) 2007
;;; Ryszard Szopa <ryszard.szopa@gmail.com> &
;;; Streamtech http://streamtech.nl/