[claw-cvs] r101 - trunk/main/claw-demo/src/backend
achiumenti at common-lisp.net
achiumenti at common-lisp.net
Wed Oct 1 11:58:55 UTC 2008
Author: achiumenti
Date: Wed Oct 1 07:58:54 2008
New Revision: 101
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/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 Wed Oct 1 07:58:54 2008
@@ -113,7 +113,7 @@
(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
+ (when (and id role-list)
(delete-records :from table-name
:where (sql-operation 'and
(sql-operation '= (slot-column-name 'user-role 'user-id) id)
@@ -129,14 +129,15 @@
(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)))
+ (roles-already-present-id-list (when role-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
@@ -149,7 +150,7 @@
(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
+ (when (and id address-list)
(delete-records :from table-name
:where (sql-operation 'and
(sql-operation '= (slot-column-name 'customer-address 'customer-id) id)
@@ -202,3 +203,197 @@
v)))
result))
+
+;;---- CLSQL EXTENSIONS ------------------------
+
+(in-package #:clsql-sys)
+
+(defclass sql-join-exp (sql-ident)
+ ((components :initarg :components)
+ (modifier :initarg :modifier)
+ (on :initarg :on)))
+
+(defmethod make-load-form ((sql sql-join-exp) &optional environment)
+ (declare (ignore environment))
+ (with-slots (components modifier on)
+ sql
+ `(make-instance 'sql-join-exp :components ',components :modifier ',modifier :on ',on)))
+
+(defmethod output-sql ((expr sql-join-exp) database)
+ (with-slots (modifier components on)
+ expr
+ (output-sql (first components) database)
+ (write-string " " *sql-stream*)
+ (output-sql modifier database)
+ (write-string " " *sql-stream*)
+ (output-sql (second components) database)
+ (write-string " ON " *sql-stream*)
+ (output-sql on database)))
+
+
+(defsql sql-join (:symbol "join") (&rest rest)
+ (if (= (length rest) 3)
+ (make-instance 'sql-join-exp
+ :modifier 'JOIN :components (butlast rest) :on (third rest))
+ (error 'sql-user-error "JOIN must have three arguments")))
+
+(defsql sql-left-join (:symbol "left-join") (&rest rest)
+ (if (= (length rest) 3)
+ (make-instance 'sql-join-exp
+ :modifier '|LEFT JOIN| :components (butlast rest) :on (third rest))
+ (error 'sql-user-error "LEFT-JOIN must have three arguments")))
+
+(defsql sql-right-join (:symbol "right-join") (&rest rest)
+ (if (= (length rest) 3)
+ (make-instance 'sql-join-exp
+ :modifier '|RIGHT JOIN| :components (butlast rest) :on (third rest))
+ (error 'sql-user-error "RIGHT-JOIN must have three arguments")))
+
+(defsql sql-inner-join (:symbol "inner-join") (&rest rest)
+ (if (= (length rest) 3)
+ (make-instance 'sql-join-exp
+ :modifier '|INNER JOIN| :components (butlast rest) :on (third rest))
+ (error 'sql-user-error "INNER-JOIN must have three arguments")))
+
+(defsql sql-outer-join (:symbol "outer-join") (&rest rest)
+ (if (= (length rest) 3)
+ (make-instance 'sql-join-exp
+ :modifier '|OUTER JOIN| :components (butlast rest) :on (third rest))
+ (error 'sql-user-error "OUTER-JOIN must have three arguments")))
+
+
+(defun select (&rest select-all-args)
+ "Executes a query on DATABASE, which has a default value of
+*DEFAULT-DATABASE*, specified by the SQL expressions supplied
+using the remaining arguments in SELECT-ALL-ARGS. The SELECT
+argument can be used to generate queries in both functional and
+object oriented contexts.
+
+In the functional case, the required arguments specify the
+columns selected by the query and may be symbolic SQL expressions
+or strings representing attribute identifiers. Type modified
+identifiers indicate that the values selected from the specified
+column are converted to the specified lisp type. The keyword
+arguments ALL, DISTINCT, FROM, GROUP-by, HAVING, ORDER-BY,
+SET-OPERATION and WHERE are used to specify, using the symbolic
+SQL syntax, the corresponding components of the SQL query
+generated by the call to SELECT. RESULT-TYPES is a list of
+symbols which specifies the lisp type for each field returned by
+the query. If RESULT-TYPES is nil all results are returned as
+strings whereas the default value of :auto means that the lisp
+types are automatically computed for each field. FIELD-NAMES is t
+by default which means that the second value returned is a list
+of strings representing the columns selected by the query. If
+FIELD-NAMES is nil, the list of column names is not returned as a
+second value.
+
+In the object oriented case, the required arguments to SELECT are
+symbols denoting View Classes which specify the database tables
+to query. In this case, SELECT returns a list of View Class
+instances whose slots are set from the attribute values of the
+records in the specified table. Slot-value is a legal operator
+which can be employed as part of the symbolic SQL syntax used in
+the WHERE keyword argument to SELECT. REFRESH is nil by default
+which means that the View Class instances returned are retrieved
+from a cache if an equivalent call to SELECT has previously been
+issued. If REFRESH is true, the View Class instances returned are
+updated as necessary from the database and the generic function
+INSTANCE-REFRESHED is called to perform any necessary operations
+on the updated instances.
+
+In both object oriented and functional contexts, FLATP has a
+default value of nil which means that the results are returned as
+a list of lists. If FLATP is t and only one result is returned
+for each record selected in the query, the results are returneds
+as elements of a list."
+
+ (flet ((select-objects (target-args)
+ (and target-args
+ (every #'(lambda (arg)
+ (and (symbolp arg)
+ (find-class arg nil)))
+ target-args))))
+ (multiple-value-bind (target-args qualifier-args)
+ (query-get-selections select-all-args)
+ (unless (or *default-database* (getf qualifier-args :database))
+ (signal-no-database-error nil))
+
+ (cond
+ ((select-objects target-args)
+ (let ((caching (getf qualifier-args :caching *default-caching*))
+ (result-types (getf qualifier-args :result-types :auto))
+ (refresh (getf qualifier-args :refresh nil))
+ (database (or (getf qualifier-args :database) *default-database*))
+ (order-by (getf qualifier-args :order-by)))
+ (remf qualifier-args :caching)
+ (remf qualifier-args :refresh)
+ (remf qualifier-args :result-types)
+
+ ;; Add explicity table name to order-by if not specified and only
+ ;; one selected table. This is required so FIND-ALL won't duplicate
+ ;; the field
+ (when (and order-by (= 1 (length target-args)))
+ (let ((table-name (view-table (find-class (car target-args))))
+ (order-by-list (copy-seq (listify order-by))))
+
+ (loop for i from 0 below (length order-by-list)
+ do (etypecase (nth i order-by-list)
+ (sql-ident-attribute
+ (unless (slot-value (nth i order-by-list) 'qualifier)
+ (setf (slot-value (nth i order-by-list) 'qualifier) table-name)))
+ (cons
+ (unless (slot-value (car (nth i order-by-list)) 'qualifier)
+ (setf (slot-value (car (nth i order-by-list)) 'qualifier) table-name)))))
+ (setf (getf qualifier-args :order-by) order-by-list)))
+
+ (cond
+ ((null caching)
+ (apply #'find-all target-args
+ (append qualifier-args
+ (list :result-types result-types :refresh refresh))))
+ (t
+ (let ((cached (records-cache-results target-args qualifier-args database)))
+ (cond
+ ((and cached (not refresh))
+ cached)
+ ((and cached refresh)
+ (let ((results (apply #'find-all (append (list target-args) qualifier-args `(:instances ,cached :result-types :auto :refresh ,refresh)))))
+ (setf (records-cache-results target-args qualifier-args database) results)
+ results))
+ (t
+ (let ((results (apply #'find-all target-args (append qualifier-args
+ `(:result-types :auto :refresh ,refresh)))))
+ (setf (records-cache-results target-args qualifier-args database) results)
+ results))))))))
+ (t
+ (let* ((expr (apply #'make-query select-all-args))
+ (specified-types
+ (mapcar #'(lambda (attrib)
+ (if (typep attrib 'sql-ident-attribute)
+ (let ((type (slot-value attrib 'type)))
+ (if type
+ type
+ t))
+ t))
+ (slot-value expr 'selections))))
+ (destructuring-bind (&key (flatp nil)
+ (result-types :auto)
+ (field-names t)
+ (database *default-database*)
+ &allow-other-keys)
+ qualifier-args
+ (progn
+ (when (listp (slot-value expr 'from))
+ (let ((join (first (member-if #'(lambda (i) (typep i 'sql-join-exp)) (slot-value expr 'from)))))
+ (when join
+ (setf (slot-value expr 'from) join))))
+ (query expr :flatp flatp
+ :result-types
+ ;; specifying a type for an attribute overrides result-types
+ (if (some #'(lambda (x) (not (eq t x))) specified-types)
+ specified-types
+ result-types)
+ :field-names field-names
+ :database database)))))))))
+
+(export '(sql-join sql-left-join sql-right-join sql-outer-join sql-inner-join))
\ 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 Wed Oct 1 07:58:54 2008
@@ -31,7 +31,7 @@
(defpackage :claw-demo-backend
- (:use :cl :clsql :clsql-postgresql :local-time :claw :closer-mop :split-sequence)
+ (:use :cl :clsql :clsql-sys :clsql-postgresql :local-time :claw :closer-mop :split-sequence)
(:shadowing-import-from :local-time
:timezone
:decode-duration
@@ -103,5 +103,8 @@
#:find-by-id
#:delete-by-id
#:delete-class-records
+ #:find-vo
+ #:count-vo
#:find-user-by-name
- #:find-customers))
\ No newline at end of file
+ #:find-customers
+ #:find-users))
\ 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 Wed Oct 1 07:58:54 2008
@@ -60,10 +60,25 @@
(second field))
(sql-expression :attribute field))))
-(defun find-vo (symbol-class &key (offset 0) (limit *select-limit*) (refresh t) where group-by having order-by)
+(defun find-vo (symbol-class &key (offset 0) (limit *select-limit*) (refresh t) from where group-by having order-by (distinct t))
"Returns a pair of values where the first is the select result, and the second is the total record amount without considering offset and limit keys."
+#|
+ (claw:log-message :info "--> ~a" (print-query (make-instance 'clsql-sys:query symbol-class
+ :from from
+ :where where
+ :group-by group-by
+ :having having
+ :order-by (when order-by (build-order-by order-by))
+ :flatp t
+ :refresh refresh
+ :offset offset
+ :limit limit
+ :distinct distinct
+ :database *claw-demo-db*)))
+|#
(values
(select symbol-class
+ :from from
:where where
:group-by group-by
:having having
@@ -72,18 +87,20 @@
:refresh refresh
:offset offset
:limit limit
+ :distinct distinct
:database *claw-demo-db*)
- (count-vo symbol-class :refresh refresh :where where :group-by group-by :having having)))
+ (count-vo symbol-class :refresh refresh :from from :where where :group-by group-by :having having)))
-(defun count-vo (symbol-class &key (refresh t) where group-by having)
+(defun count-vo (symbol-class &key (refresh t) from where group-by having (distinct t))
"Returns the number of records matching the given criteria"
(first (select (sql-operation 'count '*)
- :from (view-table (find-class symbol-class))
+ :from (or from (view-table (find-class symbol-class)))
:where where
:group-by group-by
:having having
:flatp t
:refresh refresh
+ :distinct distinct
:database *claw-demo-db*)))
(defun find-by-id (symbol-class id)
@@ -135,3 +152,45 @@
(apply #'sql-operation (cons 'and where))
(first where))
:order-by sorting)))
+
+(clsql-sys:locally-enable-sql-reader-syntax)
+(defun find-users (&key (offset 0) (limit *select-limit*) surname firstname email username (active :any) role-names sorting)
+ (let ((where (remove-if #'null (list
+ (when surname
+ (like-operation (sql-slot-value 'user 'surname)
+ surname))
+ (when firstname
+ (like-operation (sql-slot-value 'user 'firstname)
+ firstname))
+ (when username
+ (like-operation (sql-slot-value 'user 'username)
+ firstname))
+ (when email
+ (like-operation (sql-slot-value 'user 'email)
+ email))
+ (unless (eql active :any)
+ (sql-operation '= (sql-slot-value 'user 'active)
+ active))
+ (when role-names
+ (sql-operation 'in (sql-slot-value 'role 'name) role-names))))))
+ (find-vo 'user :offset offset
+ :limit limit
+ :from (sql-join (sql-join (view-table (find-class 'user))
+ (view-table (find-class 'user-role))
+ (sql-operation '=
+ (sql-slot-value 'user 'id)
+ (sql-slot-value 'user-role 'user-id)))
+ (view-table (find-class 'role))
+ (sql-operation '=
+ (sql-slot-value 'user-role 'role-id)
+ (sql-slot-value 'role 'id)))
+ :where (if (> (length where) 1)
+ (apply #'sql-operation (cons 'and where))
+ (first where))
+ :order-by sorting)))
+
+#|
+(defun oo ()
+ (list [slot-value 'role 'id]))
+|#
+(clsql-sys:locally-disable-sql-reader-syntax)
\ 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 Wed Oct 1 07:58:54 2008
@@ -1,5 +1,5 @@
;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*-
-;;; $Header: src/vo.lisp $
+;;; $Header: src/backend/vo.lisp $
;;; Copyright (c) 2008, Andrea Chiumenti. All rights reserved.
More information about the Claw-cvs
mailing list