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.