[claw-cvs] r93 - trunk/main/claw-demo/src/backend
achiumenti at common-lisp.net
achiumenti at common-lisp.net
Thu Sep 18 13:31:55 UTC 2008
Author: achiumenti
Date: Thu Sep 18 09:31:55 2008
New Revision: 93
Modified:
trunk/main/claw-demo/src/backend/dao.lisp
trunk/main/claw-demo/src/backend/packages.lisp
trunk/main/claw-demo/src/backend/service.lisp
trunk/main/claw-demo/src/backend/setup.lisp
trunk/main/claw-demo/src/backend/vo.lisp
Log:
several bugfixes and enhancements
Modified: trunk/main/claw-demo/src/backend/dao.lisp
==============================================================================
--- trunk/main/claw-demo/src/backend/dao.lisp (original)
+++ trunk/main/claw-demo/src/backend/dao.lisp Thu Sep 18 09:31:55 2008
@@ -29,6 +29,16 @@
(in-package :claw-demo-backend)
+(defun slot-column-name (symbol-class slot-name)
+ (when (stringp slot-name)
+ (setf slot-name (intern (string-upcase slot-name) 'claw-demo-backend)))
+ (let ((slot (loop for slot in (closer-mop:class-slots (find-class symbol-class))
+ when (and (typep slot 'clsql-sys::view-class-effective-slot-definition)
+ (equal (closer-mop:slot-definition-name slot) slot-name))
+ return slot)))
+ (when slot
+ (slot-value slot 'clsql-sys::column))))
+
(defgeneric check-instance-version (base-table &key database)
(:documentation "Versioning support for base-table instances"))
@@ -56,29 +66,17 @@
(setf (table-update-user base-table) user-name
(table-update-date base-table) now-timestamp)))
-
-(defun slot-column-name (symbol-class slot-name)
- (when (stringp slot-name)
- (setf slot-name (intern (string-upcase slot-name) 'claw-demo-backend)))
- (let ((slot (loop for slot in (closer-mop:class-slots (find-class symbol-class))
- when (and (typep slot 'clsql-sys::view-class-effective-slot-definition)
- (equal (closer-mop:slot-definition-name slot) slot-name))
- return slot)))
- (when slot
- (slot-value slot 'clsql-sys::column))))
-
(defun sql-expression-upper (&key string table alias attribute type)
(sql-operation 'upper (sql-expression :string string :table table :alias alias :attribute attribute :type type)))
-#.(locally-enable-sql-reader-syntax)
-(defmethod check-instance-version ((instance base-table) &key (database *default-database*))
+(defmethod check-instance-version ((instance base-table) &key (database *claw-demo-db*))
(let* ((instance-version (table-version instance))
(table (view-table (class-of instance)))
(instance-id (table-id instance))
- (version (first (select [version]
+ (version (first (select (slot-column-name 'base-table 'version)
:from table
- :where [= [id] instance-id]
+ :where (sql-operation '= (slot-column-name 'base-table 'id) instance-id)
:flatp t
:refresh t
:database database))))
@@ -90,11 +88,11 @@
table))))
(defmethod delete-instance-records :before ((instance base-table))
- (check-instance-version instance :database (clsql-sys::view-database instance)))
+ (check-instance-version instance :database *claw-demo-db*))
-(defmethod update-records-from-instance :before ((instance base-table) &key (database *default-database*))
+(defmethod update-records-from-instance :before ((instance base-table) &key (database *claw-demo-db*))
(check-instance-version instance :database database)
(sign-table-update instance)
(if (and (slot-boundp instance 'id) (not (null (table-id instance))))
@@ -105,48 +103,87 @@
(string-downcase (symbol-name (view-table (class-of instance)))))))
(setf (table-id instance) (sequence-next sequence-name :database database))))))
-(defmethod update-record-from-slot :before ((instance base-table) slot &key (database *default-database*))
+(defmethod update-record-from-slot :before ((instance base-table) slot &key (database *claw-demo-db*))
(declare (ignore slot database))
(check-instance-version instance))
-(defmethod update-records-from-instance :before ((instance user) &key (database *default-database*))
- (let ((id (table-id instance)))
+(defmethod update-records-from-instance :before ((instance user) &key (database *claw-demo-db*))
+ (let ((id (table-id instance))
+ (role-list (user-roles instance))
+ (role-id-column-name (slot-column-name 'user-role 'role-id))
+ (table-name (symbol-name (view-table (find-class 'user-role)))))
(when id
- (delete-records :from [users-roles] :where [= [user-id] id]))))
-
-(defmethod update-records-from-instance :after ((instance user) &key (database *default-database*))
- (let ((id (table-id instance)))
- (dolist (role (user-roles instance))
- (update-records-from-instance (make-instance 'user-role :user-id id :role-id (table-id role))))))
-
-
-(defmethod update-records-from-instance :before ((instance customer) &key (database *default-database*))
- (let ((id (table-id instance)))
+ (delete-records :from table-name
+ :where (sql-operation 'and
+ (sql-operation '= (slot-column-name 'user-role 'user-id) id)
+ (sql-operation 'not (sql-operation 'in role-id-column-name
+ (loop for user-role in role-list
+ collect (table-id user-role)))))
+ :database database))))
+
+(defmethod update-records-from-instance :after ((instance user) &key (database *claw-demo-db*))
+ (with-transaction (:database database)
+ (let* ((id (table-id instance))
+ (table-name (view-table (find-class 'user-role)))
+ (user-id-column-name (slot-column-name 'user-role 'user-id))
+ (role-id-column-name (slot-column-name 'user-role 'role-id))
+ (role-list (user-roles instance))
+ (roles-already-present-id-list (select role-id-column-name
+ :from table-name
+ :where (sql-operation 'in user-id-column-name
+ (loop for user-role in role-list
+ collect (table-id user-role)))
+ :flatp t
+ :refresh t
+ :database database)))
+ (dolist (role (user-roles instance))
+ (unless (member (table-id role) roles-already-present-id-list)
+ (update-records-from-instance (make-instance 'user-role
+ :user-id id
+ :role-id (table-id role)) :database database))))))
+
+
+(defmethod update-records-from-instance :before ((instance customer) &key (database *claw-demo-db*))
+ (let ((id (table-id instance))
+ (address-list (customer-addresses instance))
+ (address-id-column-name (slot-column-name 'customer-address 'id))
+ (table-name (symbol-name (view-table (find-class 'customer-address)))))
(when id
- (delete-records :from [customer-addresses] :where [= [customer-id] id]))))
+ (delete-records :from table-name
+ :where (sql-operation 'and
+ (sql-operation '= (slot-column-name 'customer-address 'customer-id) id)
+ (sql-operation 'not (sql-operation 'in address-id-column-name
+ (loop for customer-address in address-list
+ collect (table-id customer-address)))))
+ :database database)
+ (setf (customer-addresses instance) address-list))))
-(defmethod update-records-from-instance :after ((instance customer) &key (database *default-database*))
+(defmethod update-records-from-instance :after ((instance customer) &key (database *claw-demo-db*))
(let ((id (table-id instance)))
(dolist (address (customer-addresses instance))
(setf (customer-address-customer-id address) id)
- (update-records-from-instance address))))
+ (update-records-from-instance address :database database))))
(defmethod delete-instance-records :before ((instance user))
(let ((id (table-id instance)))
(when id
- (delete-records :from [users-roles] :where [= [user-id] id]))))
+ (delete-records :from (symbol-name (view-table (find-class 'user-role)))
+ :where (sql-operation '= (slot-column-name 'user-role 'role-id) id)
+ :database *claw-demo-db*))))
(defmethod delete-instance-records :before ((instance customer))
(let ((id (table-id instance)))
(when id
- (delete-records :from [customer-addresses] :where [= [customer-id] id]))))
+ (delete-records :from (symbol-name (view-table (find-class 'customer-address)))
+ :where (sql-operation '= (slot-column-name 'customer-address 'customer-id) id)))))
(defmethod delete-instance-records :before ((instance role))
(let ((id (table-id instance)))
(when id
- (delete-records :from [users-roles] :where [= [role-id] id]))))
+ (delete-records :from (symbol-name (view-table (find-class 'user-role)))
+ :where (sql-operation '= (slot-column-name 'user-role 'role-id) id)))))
(defun like-operation (name value &key (insensitive t) (wild-char #\*))
(setf value (format nil "~{~A~^\\\\~}" (split-sequence #\\ value)))
@@ -165,4 +202,3 @@
v)))
result))
-#.(locally-disable-sql-reader-syntax)
\ No newline at end of file
Modified: trunk/main/claw-demo/src/backend/packages.lisp
==============================================================================
--- trunk/main/claw-demo/src/backend/packages.lisp (original)
+++ trunk/main/claw-demo/src/backend/packages.lisp Thu Sep 18 09:31:55 2008
@@ -40,7 +40,8 @@
:universal-time
:parse-timestring)
(:documentation "A demo application for CLAW")
- (:export #:demo-setup
+ (:export #:*claw-demo-db*
+ #:demo-setup
#:db-connect
#:db-disconnect
;; --- Value objects --- ;;
@@ -89,7 +90,7 @@
#:customer-address
#:customer-address-name1
#:customer-address-name2
- #:customer-address-address-type
+ #:customer-address-type
#:customer-address-address
#:customer-address-city
#:customer-address-zip
@@ -100,6 +101,7 @@
#:delete-db-item
#:reload-db-item
#:find-by-id
+ #:delete-by-id
#:delete-class-records
#:find-user-by-name
#:find-customers))
\ No newline at end of file
Modified: trunk/main/claw-demo/src/backend/service.lisp
==============================================================================
--- trunk/main/claw-demo/src/backend/service.lisp (original)
+++ trunk/main/claw-demo/src/backend/service.lisp Thu Sep 18 09:31:55 2008
@@ -40,8 +40,6 @@
(defgeneric reload-db-item (base-table)
(:documentation "Reloads an item."))
-#.(locally-enable-sql-reader-syntax)
-
(defmethod update-db-item ((item base-table))
(with-transaction (:database *claw-demo-db*)
(update-records-from-instance item)))
@@ -53,7 +51,7 @@
(defun delete-class-records (symbol-class &key where)
(with-transaction (:database *claw-demo-db*)
(let ((table-name (symbol-name (view-table (find-class symbol-class)))))
- (delete-records :from table-name :where where))))
+ (delete-records :from table-name :where where :database *claw-demo-db*))))
(defun build-order-by (fields)
(loop for field in fields
@@ -73,24 +71,32 @@
:flatp t
:refresh refresh
:offset offset
- :limit limit)
+ :limit limit
+ :database *claw-demo-db*)
(count-vo symbol-class :refresh refresh :where where :group-by group-by :having having)))
(defun count-vo (symbol-class &key (refresh t) where group-by having)
"Returns the number of records matching the given criteria"
- (first (select [count [*]]
+ (first (select (sql-operation 'count '*)
:from (view-table (find-class symbol-class))
:where where
:group-by group-by
- :having having
+ :having having
:flatp t
- :refresh refresh)))
+ :refresh refresh
+ :database *claw-demo-db*)))
(defun find-by-id (symbol-class id)
(first (select symbol-class
:where (sql-operation '= (slot-column-name symbol-class 'id) id)
:flatp t
- :refresh t)))
+ :refresh t
+ :database *claw-demo-db*)))
+
+(defun delete-by-id (symbol-class id-list)
+ (first (delete-records :from (view-table (find-class symbol-class))
+ :where (sql-operation 'in (slot-column-name symbol-class 'id) id-list)
+ :database *claw-demo-db*)))
(defmethod reload-db-item ((item base-table))
"Reloads item data selecting the item by its id. This function isn't destructive"
@@ -103,7 +109,8 @@
(first (select 'user
:where where
:flatp t
- :refresh t))))
+ :refresh t
+ :database *claw-demo-db*))))
(defun find-customers (&key (offset 0) (limit *select-limit*) name1 name2 email vat phone sorting)
(let ((where (remove-if #'null (list
@@ -128,5 +135,3 @@
(apply #'sql-operation (cons 'and where))
(first where))
:order-by sorting)))
-
-#.(locally-disable-sql-reader-syntax)
\ No newline at end of file
Modified: trunk/main/claw-demo/src/backend/setup.lisp
==============================================================================
--- trunk/main/claw-demo/src/backend/setup.lisp (original)
+++ trunk/main/claw-demo/src/backend/setup.lisp Thu Sep 18 09:31:55 2008
@@ -33,14 +33,14 @@
"The demo datebase")
(defun db-connect (&optional (connection-string '("127.0.0.1" "claw-demo" "claw-demo" "demo")))
- (setf *claw-demo-db* (connect connection-string :database-type :postgresql :pool t)))
+ (connect connection-string :database-type :postgresql :pool t))
-(defun db-disconnect ()
- (disconnect :database *claw-demo-db*))
+(defun db-disconnect (&optional (database *claw-demo-db*) )
+ (disconnect :database database))
(defun create-claw-demo-tables ()
- (let ((*default-database* *claw-demo-db*))
+ (let ((clsql:*default-database* *claw-demo-db*))
(create-view-from-class 'user-role)
(create-view-from-class 'user)
(create-view-from-class 'role)
@@ -66,7 +66,7 @@
(symbol-name (view-table (find-class 'customer))))))))
(defun drop-claw-demo-tables ()
- (let ((*default-database* *claw-demo-db*)
+ (let ((clsql:*default-database* *claw-demo-db*)
(user-role-table (symbol-name (view-table (find-class 'user-role))))
(customer-address-table (symbol-name (view-table (find-class 'customer-address)))))
(dolist (table (list-tables))
@@ -75,7 +75,7 @@
(execute-command (format nil "DROP SEQUENCE ~a" sequence)))))
(defun demo-setup ()
- (db-connect)
+ (let ((*claw-demo-db* (db-connect)))
(drop-claw-demo-tables)
(create-claw-demo-tables)
(with-transaction ()
@@ -103,4 +103,4 @@
:code1 (format nil "code2-~a" i)
:code1 (format nil "code3-~a" i)
:code1 (format nil "code4-~a" i))))))
- (db-disconnect))
\ No newline at end of file
+ (db-disconnect)))
\ No newline at end of file
Modified: trunk/main/claw-demo/src/backend/vo.lisp
==============================================================================
--- trunk/main/claw-demo/src/backend/vo.lisp (original)
+++ trunk/main/claw-demo/src/backend/vo.lisp Thu Sep 18 09:31:55 2008
@@ -270,5 +270,9 @@
:foreign-key id
:retrieval :immediate
:set nil)))
- (:default-initargs :address-type 0)
+ (:default-initargs :address-type 0 :address nil
+ :city nil
+ :zip nil
+ :state nil
+ :country nil)
(:base-table customer-addresses))
More information about the Claw-cvs
mailing list