From achiumenti at common-lisp.net Wed Oct 1 11:56:42 2008 From: achiumenti at common-lisp.net (achiumenti at common-lisp.net) Date: Wed, 1 Oct 2008 07:56:42 -0400 (EDT) Subject: [claw-cvs] r98 - trunk/main/claw/src Message-ID: <20081001115642.23F9A71123@common-lisp.net> Author: achiumenti Date: Wed Oct 1 07:56:41 2008 New Revision: 98 Modified: trunk/main/claw/src/lisplet.lisp Log: several bugfixes and enhancements Modified: trunk/main/claw/src/lisplet.lisp ============================================================================== --- trunk/main/claw/src/lisplet.lisp (original) +++ trunk/main/claw/src/lisplet.lisp Wed Oct 1 07:56:41 2008 @@ -258,5 +258,5 @@ (string-not-equal (claw-script-name) login-page-url)) (redirect-to-https (format nil "~a~a" *root-path* (lisplet-login-page lisplet)))) ((and sslport (not (= (claw-server-port) sslport))) - (redirect-to-https (format nil "~a~a" *root-path* (car protected-resource))) + (redirect-to-https (format nil "~a/~a" *root-path* (car protected-resource))) (throw 'handler-done nil))))))))) From achiumenti at common-lisp.net Wed Oct 1 11:57:13 2008 From: achiumenti at common-lisp.net (achiumenti at common-lisp.net) Date: Wed, 1 Oct 2008 07:57:13 -0400 (EDT) Subject: [claw-cvs] r99 - trunk/main/claw-html/src Message-ID: <20081001115713.1C0E479187@common-lisp.net> Author: achiumenti Date: Wed Oct 1 07:57:12 2008 New Revision: 99 Modified: trunk/main/claw-html/src/components.lisp trunk/main/claw-html/src/packages.lisp trunk/main/claw-html/src/tags.lisp trunk/main/claw-html/src/translators.lisp Log: several bugfixes and enhancements Modified: trunk/main/claw-html/src/components.lisp ============================================================================== --- trunk/main/claw-html/src/components.lisp (original) +++ trunk/main/claw-html/src/components.lisp Wed Oct 1 07:57:12 2008 @@ -38,9 +38,9 @@ - OBJ the wcomponent instance - PAGE-OBJ the wcomponent owner page")) -(defgeneric component-id-and-value (cinput &key from-request-p) +(defgeneric component-id-and-value (cinput) (:documentation "Returns the form component \(such as and TYPE attribute. For submit type, use the CSUBMIT> function.")) (:metaclass metacomponent) - (:default-initargs :reserved-parameters (list :value :name) :empty t :type "text") + (:default-initargs :reserved-parameters (list :value) :empty t :type "text") (:documentation "Request cycle aware component the renders as an INPUT tag class")) (let ((class (find-class 'cinput))) @@ -298,13 +305,17 @@ (funcall validator cinput)) (unless (component-validation-errors cinput) (if (and (null writer) accessor) - (funcall (fdefinition `(setf ,accessor)) value visit-object) - (funcall (fdefinition writer) value visit-object))))))) + (funcall (fdefinition `(setf ,accessor)) (if (and (stringp value) (string= value "") (base-cinput-empty-to-null-p cinput)) + nil + value) visit-object) + (funcall (fdefinition writer) (if (and (stringp value) (string= value "") (base-cinput-empty-to-null-p cinput)) + nil + value) visit-object))))))) (defclass ctextarea (base-cinput) () (:metaclass metacomponent) - (:default-initargs :reserved-parameters (list :name) :empty nil) + (:default-initargs :empty nil) (:documentation "Request cycle aware component the renders as an INPUT tag class")) (let ((class (find-class 'ctextarea))) @@ -333,8 +344,9 @@ (wcomponent-informal-parameters ctextarea) (or value "")))) -(defmethod component-id-and-value ((cinput base-cinput) &key (from-request-p t)) +(defmethod component-id-and-value ((cinput base-cinput)) (let ((client-id (htcomponent-client-id cinput)) + (from-request-p (nth-value 1 (gethash (string-upcase (name-attr cinput)) (page-request-parameters *claw-current-page*)))) (visit-object (cinput-visit-object cinput)) (accessor (cinput-accessor cinput)) (reader (cinput-reader cinput)) @@ -347,14 +359,14 @@ (name-attr cinput) result-as-list-p)) ((and (null reader) accessor) (funcall (fdefinition accessor) visit-object)) - (t (funcall (fdefinition reader) visit-object)))) + (reader (funcall (fdefinition reader) visit-object)))) (values client-id value)))) ;--------------------------------------------------------------------------------------- (defclass cinput-file (cinput) () (:metaclass metacomponent) - (:default-initargs :reserved-parameters (list :value :name :type) :empty t :type "file" :translator *file-translator*) + (:default-initargs :reserved-parameters (list :value :type) :empty t :type "file" :translator *file-translator*) (:documentation "Request cycle aware component the renders as an INPUT tag class of type file")) (let ((class (find-class 'cinput-file))) @@ -374,7 +386,7 @@ :reader csubmit-value :documentation "The html VALUE attribute")) (:metaclass metacomponent) - (:default-initargs :reserved-parameters (list :type :name) :empty t :action nil) + (:default-initargs :reserved-parameters (list :type ) :empty t :action nil) (:documentation "This component render as an INPUT tag class ot type submit, but can override the default CFORM action, using its own associated action")) @@ -443,7 +455,7 @@ ;-------------------------------------------------------------------------- (defclass cselect (base-cinput) () - (:default-initargs :reserved-parameters (list :type :name) :empty nil) + (:default-initargs :reserved-parameters (list :type) :empty nil) (:metaclass metacomponent) (:documentation "This component renders as a normal SELECT tag class, but it is request cycle aware.")) @@ -480,13 +492,14 @@ (value :initarg :value :accessor ccheckbox-value)) (:metaclass metacomponent) - (:default-initargs :reserved-parameters (list :name) :empty t :type "checkbox" :test #'equal) + (:default-initargs :reserved-parameters () :empty t :type "checkbox" :test #'equal :multiple t) (:documentation "Request cycle aware component the renders as an INPUT tag class. IMPORTANT its assigned id mus be unique since its NAME tag attribute will be extracted from the assigned id and not from the generate one as for other cinput components")) (defmethod name-attr ((cinput ccheckbox)) - (htcomponent-real-id cinput)) + (or (base-cinput-name cinput) + (htcomponent-real-id cinput))) (let ((class (find-class 'ccheckbox))) (closer-mop:ensure-finalized class) @@ -504,7 +517,7 @@ (translator (translator cinput)) (type (input-type cinput)) (value (translator-value-type-to-string translator (ccheckbox-value cinput))) - (current-value (translator-string-to-type translator cinput)) + (accessor-value (translator-string-to-type translator cinput)) (class (css-class cinput)) (test (ccheckbox-test cinput))) (when (component-validation-errors cinput) @@ -516,10 +529,11 @@ :name (name-attr cinput) :class class :value value - :checked (when (and current-value - (if (listp current-value) - (member (ccheckbox-value cinput) current-value :test test) - (funcall test (ccheckbox-value cinput) current-value))) "checked") + :checked (when (and (or (cinput-accessor cinput) + (cinput-reader cinput)) accessor-value + (if (listp accessor-value) + (member value accessor-value :test test) + (funcall test value accessor-value))) "checked") (wcomponent-informal-parameters cinput)))) (defmethod wcomponent-after-rewind ((cinput ccheckbox) (page page)) @@ -545,13 +559,14 @@ (unless (component-validation-errors cinput) (if (and (null writer) accessor) (funcall (fdefinition `(setf ,accessor)) new-value visit-object) - (funcall (fdefinition writer) new-value visit-object))))))) + (when writer + (funcall (fdefinition writer) new-value visit-object)))))))) ;------------------------------------------------------------------------------------- (defclass cradio (ccheckbox) () (:metaclass metacomponent) - (:default-initargs :type "radio") + (:default-initargs :type "radio" :multiple t :reserved-parameters '(:multiple)) (:documentation "Request cycle aware component the renders as an INPUT tag class")) (let ((class (find-class 'cradio))) @@ -566,9 +581,55 @@ (describe-html-attributes-from-class-slot-initargs class) (describe-component-behaviour class)))) -(defmethod name-attr ((ccheckbox ccheckbox)) - (htcomponent-real-id ccheckbox)) +(defmethod wcomponent-template ((cinput cradio)) + (let* ((client-id (htcomponent-client-id cinput)) + (translator (translator cinput)) + (type (input-type cinput)) + (value (translator-value-type-to-string translator (ccheckbox-value cinput))) + (accessor-value (first (translator-string-to-type translator cinput))) + (class (css-class cinput)) + (test (ccheckbox-test cinput))) + (when (component-validation-errors cinput) + (if (or (null class) (string= class "")) + (setf class "error") + (setf class (format nil "~a error" class)))) + (input> :static-id client-id + :type type + :name (name-attr cinput) + :class class + :value value + :checked (when (and (or (cinput-accessor cinput) + (cinput-reader cinput)) accessor-value + (funcall test value accessor-value)) "checked") + (wcomponent-informal-parameters cinput)))) + +(defmethod wcomponent-after-rewind ((cinput cradio) (page page)) + (when (cform-rewinding-p (page-current-form page) page) + (let* ((visit-object (cinput-visit-object cinput)) + (name (name-attr cinput)) + (translator (translator cinput)) + (accessor (cinput-accessor cinput)) + (writer (cinput-writer cinput)) + (validator (validator cinput)) + (result-as-list-p (cinput-result-as-list-p cinput)) + (new-value (page-req-parameter page + name + result-as-list-p))) + (when new-value + (setf new-value + (first (remove-if #'(lambda (x) (or (null x) (and (stringp x) (string-equal x "")))) + (loop for item in new-value + collect (translator-value-string-to-type translator item)))))) + (unless (or (null visit-object) (component-validation-errors cinput)) + (when validator + (funcall validator (or new-value ""))) + (unless (component-validation-errors cinput) + (if (and (null writer) accessor) + (funcall (fdefinition `(setf ,accessor)) new-value visit-object) + (when writer + (funcall (fdefinition writer) new-value visit-object)))))))) +#| (defmethod wcomponent-after-rewind ((cinput cradio) (page page)) (when (cform-rewinding-p (page-current-form page) page) (let* ((visit-object (cinput-visit-object cinput)) @@ -612,3 +673,4 @@ :value value :checked (when (and current-value (equal value current-value)) "checked") (wcomponent-informal-parameters cinput)))) +|# \ No newline at end of file Modified: trunk/main/claw-html/src/packages.lisp ============================================================================== --- trunk/main/claw-html/src/packages.lisp (original) +++ trunk/main/claw-html/src/packages.lisp Wed Oct 1 07:57:12 2008 @@ -229,6 +229,7 @@ ;;validation #:translator + #:validation-error-control-string #:translator-integer #:translator-number #:translator-boolean Modified: trunk/main/claw-html/src/tags.lisp ============================================================================== --- trunk/main/claw-html/src/tags.lisp (original) +++ trunk/main/claw-html/src/tags.lisp Wed Oct 1 07:57:12 2008 @@ -1179,13 +1179,13 @@ do (when (eq (car (last (closer-mop:slot-definition-initargs slot-definition))) initarg) (return (closer-mop:slot-definition-name slot-definition)))))) (if (find initarg (wcomponent-reserved-parameters wcomponent)) - (error (format nil "Parameter ~a is reserved" initarg)) + (error (format nil "Parameter ~a for component ~a is reserved" initarg (type-of wcomponent))) (if slot-name (setf (slot-value wcomponent slot-name) new-value) (if (null (wcomponent-allow-informal-parametersp wcomponent)) (error (format nil "Component ~a doesn't accept informal parameters" - slot-initarg)) + (type-of wcomponent))) (setf (getf (wcomponent-informal-parameters wcomponent) initarg) new-value)))))) Modified: trunk/main/claw-html/src/translators.lisp ============================================================================== --- trunk/main/claw-html/src/translators.lisp (original) +++ trunk/main/claw-html/src/translators.lisp Wed Oct 1 07:57:12 2008 @@ -79,7 +79,7 @@ (progn (setf value (cond ((and (null reader) accessor) (funcall (fdefinition accessor) visit-object)) - (t (funcall (fdefinition reader) visit-object)))) + (reader (funcall (fdefinition reader) visit-object)))) (if (listp value) (loop for item in value collect (translator-value-encode translator item)) From achiumenti at common-lisp.net Wed Oct 1 11:58:00 2008 From: achiumenti at common-lisp.net (achiumenti at common-lisp.net) Date: Wed, 1 Oct 2008 07:58:00 -0400 (EDT) Subject: [claw-cvs] r100 - trunk/main/claw-html.dojo/src Message-ID: <20081001115800.01DBC2F00A@common-lisp.net> Author: achiumenti Date: Wed Oct 1 07:57:59 2008 New Revision: 100 Removed: trunk/main/claw-html.dojo/src/djtoolbar.fasl Modified: trunk/main/claw-html.dojo/src/djform.lisp Log: several bugfixes and enhancements Modified: trunk/main/claw-html.dojo/src/djform.lisp ============================================================================== --- trunk/main/claw-html.dojo/src/djform.lisp (original) +++ trunk/main/claw-html.dojo/src/djform.lisp Wed Oct 1 07:57:59 2008 @@ -79,7 +79,7 @@ (input> :static-id client-id :type type :dojoType dojo-type - :name client-id + :name (name-attr obj) :class class :value value (wcomponent-informal-parameters obj)))) @@ -218,7 +218,7 @@ (setf value (translator-encode translator obj)) (select> :static-id client-id :dojoType dojo-type - :name client-id + :name (name-attr obj) :class class :value value :multiple (cinput-result-as-list-p obj) @@ -333,9 +333,11 @@ (:default-initargs :dojo-require (list "dijit.form.Slider"))) (defclass _djslider-slider (cinput _djslider) - () + ((name :initarg :name + :reader base-cinput-name + :documentation "When specified the name tag attribute, otherwise the given component id is used")) (:metaclass metacomponent) - (:default-initargs :reserved-parameters (list :value :name) :translator *number-translator*) + (:default-initargs :reserved-parameters (list :value) :translator *number-translator*) (:documentation "Base class to map dojo dijit.form.HorizontalSlider and dijit.form.VerticalSlider. More info at http://api.dojotoolkit.org/")) (defmethod wcomponent-template ((_djslider-slider _djslider-slider)) From achiumenti at common-lisp.net Wed Oct 1 11:58:55 2008 From: achiumenti at common-lisp.net (achiumenti at common-lisp.net) Date: Wed, 1 Oct 2008 07:58:55 -0400 (EDT) Subject: [claw-cvs] r101 - trunk/main/claw-demo/src/backend Message-ID: <20081001115855.845A971123@common-lisp.net> 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. From achiumenti at common-lisp.net Wed Oct 1 11:59:17 2008 From: achiumenti at common-lisp.net (achiumenti at common-lisp.net) Date: Wed, 1 Oct 2008 07:59:17 -0400 (EDT) Subject: [claw-cvs] r102 - trunk/main/claw-demo/src/frontend Message-ID: <20081001115917.AE15971123@common-lisp.net> Author: achiumenti Date: Wed Oct 1 07:59:17 2008 New Revision: 102 Modified: trunk/main/claw-demo/src/frontend/commons.lisp trunk/main/claw-demo/src/frontend/customers.lisp Log: several bugfixes and enhancements Modified: trunk/main/claw-demo/src/frontend/commons.lisp ============================================================================== --- trunk/main/claw-demo/src/frontend/commons.lisp (original) +++ trunk/main/claw-demo/src/frontend/commons.lisp Wed Oct 1 07:59:17 2008 @@ -29,70 +29,6 @@ (in-package :claw-demo-frontend) - - - -(defclass site-template (wcomponent) - ((title :initarg :title - :reader site-template-title) - (djconfig :initarg :djconfig - :reader site-template-djconfig)) - (:metaclass metacomponent) - (:default-initargs :djconfig nil)) - -(defclass redirect (wcomponent) - ((href :initarg :href - :reader redirect-href)) - (:metaclass metacomponent)) - -(defmethod htcomponent-instance-initscript ((redirect redirect)) - (ps:ps* `(location.replace ,(redirect-href redirect)))) - -(defmethod wcomponent-template ((redirect redirect)) - ($> "")) - -(defun current-site-template () - (claw-aux-request-value 'site-template)) - -(defmethod wcomponent-template ((site-template site-template)) - (let ((principal (current-principal))) - (html> - (head> - (title> (site-template-title site-template)) - (link> :href (format nil "~a/docroot/css/style.css" *root-path*) - :rel "stylesheet" - :type "text/css")) - (djbody> :is-debug "false" - :theme "soria" - :class "demo" - :djconfig (site-template-djconfig site-template) - (wcomponent-informal-parameters site-template) - (div> :class "topheader" - (div> :class "logoDemo") - (div> :class "logoClaw")) - (djtoolbar> :id "menuBar" :class "menuBar" - (djdrop-down-button> (span> "File") - (djmenu> - (djmenu-item> :id "loginMenu" - :render-condition #'(lambda () (null principal)) - :on-click (ps:ps* `(location.replace ,(format nil "~a/login.html" *root-path*))) - "Login") - (djmenu-item> :id "logoutMenu" - :render-condition #'(lambda () principal) - :on-click (ps:ps* `(location.replace ,(format nil "~a/logout.html" *root-path*))) - "Logout"))) - (djdrop-down-button> :render-condition #'(lambda () principal) - (span> "Anagraphics") - (djmenu> - (djmenu-item> :id "customersMenu" - :on-click (ps:ps* `(location.replace ,(format nil "~a/customers.html" *root-path*))) - "Customers") - (djmenu-item> :id "usersMenu" - :render-condition #'(lambda () (user-in-role-p '("admin"))) - "Users")))) - (div> :class "contentBody" - (htcomponent-body site-template)))))) - (defclass db-page (page) ()) @@ -106,156 +42,6 @@ (db-disconnect))) result)) - - -(defgeneric pager-count-pages (pager)) - -(defgeneric pager-current-page (pager)) - -(defgeneric pager-page-list (pager)) - -(defgeneric set-offset-value (pager page)) - -(defclass pager (wcomponent) - ((update-component-id :initarg :update-component-id - :accessor pager-update-component-id) - (class :initarg :class - :reader pager-class) - (page-size :initarg :page-size - :reader pager-page-size) - (visible-pages :initarg :visible-pages - :accessor pager-visible-pages) - (total-items :initarg :total-items - :accessor pager-total-items) - (first-item-offset :initarg :first-item-offset - :accessor pager-first-item-offset)) - (:metaclass metacomponent) - (:default-initargs :page-size 10 :visible-pages 10 :class "pager")) - -(defmethod wcomponent-template ((pager pager)) - (let ((total-items (pager-total-items pager)) - (page-size (pager-page-size pager)) - (page-list (pager-page-list pager)) - (current-page (pager-current-page pager)) - (count-pages (pager-count-pages pager)) - (id (htcomponent-client-id pager))) - (when (> total-items page-size) - (div> - :static-id id - :class (pager-class pager) - (wcomponent-informal-parameters pager) - - (when (> current-page 1) - (list (div> :class "button first" - (span> :on-click (set-offset-value pager 1) "first")) - (div> :class "button previous" - (span> :on-click (set-offset-value pager (1- current-page)) "previous")))) - (loop for page in page-list - collect (if (= page current-page) - (div> :class "current page" - (span> (format nil "~a" page))) - (div> :class "page" (span> :on-click (set-offset-value pager page) (format nil "~a" page))))) - (when (< current-page count-pages) - (list (div> :class "button next" - (span> :on-click (set-offset-value pager (1+ current-page)) "next")) - (div> :class "button last" - (span> :on-click (set-offset-value pager count-pages) "last")))))))) - -(defmethod htcomponent-class-initscripts ((pager pager)) - (let ((update-component-id (pager-update-component-id pager)) - (page-size (pager-page-size pager))) - (list - (ps:ps* `(defun pager-go-to (page) - (setf (slot-value (dojo.by-id ,update-component-id) 'value) (* (1- page) ,page-size)) - (defvar form-id (slot-value (slot-value (dojo.by-id ,update-component-id) 'form) 'id)) - (let ((form-el (or (dijit.by-id form-id) - (dojo.by-id form-id)))) - (.submit form-el))))))) - -(defmethod set-offset-value ((pager pager) page) - (ps:ps* `(pager-go-to ,page))) - -(defmethod pager-count-pages ((pager pager)) - (let ((page-size (pager-page-size pager)) - (total-items (pager-total-items pager))) - (count-pages page-size total-items))) - -(defun count-pages (page-size total-items) - (multiple-value-bind (pages rest) - (truncate total-items page-size) - (when (> rest 0) (incf pages)) - pages)) - -(defmethod pager-current-page ((pager pager)) - (let ((page-size (pager-page-size pager)) - (first-item-offset (pager-first-item-offset pager))) - (multiple-value-bind (page rest) - (truncate (1+ first-item-offset) page-size) - (when (> rest 0) (incf page)) - page))) - -(defmethod pager-page-list ((pager pager)) - (let ((current-page (pager-current-page pager)) - (count-pages (pager-count-pages pager)) - (visible-pages (pager-visible-pages pager)) - (pages-before-current-page) - (pages-after-current-page) - (result)) - (when (> current-page 1) - (setf pages-before-current-page - (reverse - (loop for page from (1- current-page) downto (max 1 (- current-page - (truncate visible-pages 2))) - collect page)))) - (when (< current-page count-pages) - (setf pages-after-current-page - (loop for page from (1+ current-page) to (min count-pages (+ (1- current-page) - (- visible-pages (length pages-before-current-page)))) - collect page))) - (setf result (append pages-before-current-page (list current-page) pages-after-current-page)) - (let ((result-length (length result)) - (first-result-page (first result))) - (if (< result-length visible-pages) - (append (reverse (loop for page from (1- first-result-page) downto (max 1 (- first-result-page (- visible-pages result-length))) - collect page)) result) - result)))) - (defun null-when-empty (string) (unless (string= string "") string)) - -(defclass djconfirmation-submit (wcomponent) - ((value :initarg :value - :accessor djconfirmation-submit-value) - (action :initarg :action - :accessor djconfirmation-submit-action) - (confirmation-message :initarg :confirmation-message - :accessor djconfirmation-submit-confirmation-message) - (yes-label :initarg :yes - :accessor djconfirmation-submit-yes) - (no-label :initarg :no - :accessor djconfirmation-submit-no)) - (:default-initargs :yes "Yes" :no "No") - (:metaclass metacomponent)) - -(defmethod wcomponent-template ((obj djconfirmation-submit)) - (let* ((dialog-id (generate-id "confirmationDiaolg")) - (yes-id (generate-id "yes")) - (value (djconfirmation-submit-value obj))) - (div> :class "dijit dijitReset dijitLeft dijitInline" - (djbutton> :static-id (htcomponent-client-id obj) - :on-click (ps:ps* `(.show (dijit.by-id ,dialog-id))) - (wcomponent-informal-parameters obj) - (or (htcomponent-body obj) value)) - (djdialog> :static-id dialog-id - :title "Confirm" - (div> (djconfirmation-submit-confirmation-message obj) - (div> :class "buttonContainer" - (djsubmit-button> :static-id yes-id - :value (djconfirmation-submit-value obj) - :action (djconfirmation-submit-action obj) - :on-click (ps:ps* `(.hide (dijit.by-id ,dialog-id))) - (djconfirmation-submit-yes obj)) - (djbutton> :id dialog-id - :on-click (ps:ps* `(.hide (dijit.by-id ,dialog-id))) - (djconfirmation-submit-no obj)))))))) \ No newline at end of file Modified: trunk/main/claw-demo/src/frontend/customers.lisp ============================================================================== --- trunk/main/claw-demo/src/frontend/customers.lisp (original) +++ trunk/main/claw-demo/src/frontend/customers.lisp Wed Oct 1 07:59:17 2008 @@ -1,5 +1,5 @@ ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- -;;; $Header: dojo/tests/customers.lisp $ +;;; $Header: customers.lisp $ ;;; Copyright (c) 2008, Andrea Chiumenti. All rights reserved. @@ -29,228 +29,6 @@ (in-package :claw-demo-frontend) -(defgeneric edit-customer-save (edit-customer)) - -(defclass edit-customer (djform) - ((customer :initarg :customer - :accessor edit-customer-customer) -#| - (on-before-submit :initarg :on-before-submit - :accessor on-before-submit) - (on-xhr-finish :initarg :on-xhr-finish - :accessor on-xhr-finish) -|# - (customer-id-parameter :initarg :customer-id-parameter - :accessor edit-customer-customer-id-parameter) - (on-close-click :initarg :on-close-click - :accessor edit-customer-on-close-click)) - (:metaclass metacomponent) - (:default-initargs :on-close-click nil - :class "customerForm" :customer-id-parameter "customerid")) - -(defmethod initialize-instance :after ((obj edit-customer) &key rest) - (declare (ignore rest)) - (setf (action-object obj) obj - (action obj) 'edit-customer-save)) - -(defun find-or-add-address (customer address-type) - (let ((address (loop for item in (customer-addresses customer) - when (= (customer-address-type item) address-type) - return item))) - (unless address - (setf address (make-instance 'customer-address :address-type address-type)) - (push address (customer-addresses customer))) - address)) - -(defun address-nullp (address) - (let ((attributes (list (customer-address-address address) - (customer-address-zip address) - (customer-address-city address) - (customer-address-state address) - (customer-address-country address)))) - (not - (loop for val in (mapcar #'(lambda (x) - (when (and x (string-not-equal x "")) - t)) - attributes) - when val - return t)))) - -(defmethod htcomponent-body ((obj edit-customer)) - (let* ((visit-object (edit-customer-customer obj)) - (main-address (find-or-add-address visit-object 0)) - (billing-address (find-or-add-address visit-object 1))) - (list - (cinput> :id (edit-customer-customer-id-parameter obj) - :type "hidden" :visit-object visit-object - :translator *integer-translator* - :accessor 'table-id) - (cinput> :id "tabbleVersion" - :type "hidden" - :visit-object visit-object - :translator *integer-translator* - :accessor 'table-version) - (div> :class "label name1" - (span> "Name 1") - (djvalidation-text-box> :visit-object visit-object - :required "true" - :label "Name 1" - :accessor 'customer-name1)) - (div> :class "label name2" - (span> "Name 2") - (djvalidation-text-box> :visit-object visit-object - :label "Name 2" - :accessor 'customer-name2)) - (div> :class "label email" - (span> "Email") - (djvalidation-text-box> :visit-object visit-object - :label "Email" - :accessor 'customer-email)) - (div> :class "label pone1" - (span> "Phone 1") - (djvalidation-text-box> :visit-object visit-object - :label "Phone 1" - :accessor 'customer-phone1)) - (div> :class "label pone2" - (span> "Phone 2") - (djvalidation-text-box> :visit-object visit-object - :label "Phone 2" - :accessor 'customer-phone2)) - (div> :class "label pone3" - (span> "Phone 3") - (djvalidation-text-box> :visit-object visit-object - :label "Phone 3" - :accessor 'customer-phone3)) - (div> :class "label fax" - (span> "Fax") - (djvalidation-text-box> :visit-object visit-object - :label "Fax" - :accessor 'customer-fax)) - (div> :class "label vat" - (span> "VAT") - (djvalidation-text-box> :visit-object visit-object - :label "VAT" - :accessor 'customer-vat)) - (div> :class "label code1" - (span> "Code 1") - (djvalidation-text-box> :visit-object visit-object - :label "Code 1" - :accessor 'customer-code1)) - (div> :class "label code2" - (span> "Code 2") - (djvalidation-text-box> :visit-object visit-object - :label "Code 2" - :accessor 'customer-code2)) - (div> :class "label code3" - (span> "Code 3") - (djvalidation-text-box> :visit-object visit-object - :label "Code 3" - :accessor 'customer-code3)) - (div> :class "label code4" - (span> "Code 4") - (djvalidation-text-box> :visit-object visit-object - :label "Code 4" - :accessor 'customer-code4)) - (djtab-container> :id "addressTabs" - :class "addressTabs" - (djcontent-pane> :id "mainAddress" :title "Main address" - (div> (div> :class "address" - (span> :class "label" "Street") - (djvalidation-text-box> :visit-object main-address - :label "Main Address[address]" - :accessor 'customer-address-address)) - (div> :class "zip" - (span> :class "label" "Zip") - (djvalidation-text-box> :visit-object main-address - :class "text" - :label "Main Address[zip]" - :accessor 'customer-address-zip)) - (div> :class "city" - (span> :class "label" "City") - (djvalidation-text-box> :visit-object main-address - :class "text" - :label "Main Address[city]" - :accessor 'customer-address-city)) - (div> :class "state" - (span> :class "label" "State") - (djvalidation-text-box> :visit-object main-address - :class "text" - :label "Main Address[state]" - :accessor 'customer-address-state)) - (div> :class "country" - (span> :class "label" "Country") - (djvalidation-text-box> :visit-object main-address - :class "text" - :label "Main Address[country]" - :accessor 'customer-address-country)))) - (djcontent-pane> :id "billingAddress" :title "Billing address" - (div> (div> :class "address" - (span> :class "label" "Street") - (djvalidation-text-box> :visit-object billing-address - :class "text" - :label "Billing Address[street]" - :accessor 'customer-address-address)) - (div> :class "zip" - (span> :class "label" "Zip") - (djvalidation-text-box> :visit-object billing-address - :class "text" - :label "Billing Address[zip]" - :accessor 'customer-address-zip)) - (div> :class "city" - (span> :class "label" "City") - (djvalidation-text-box> :visit-object billing-address - :class "text" - :label "Billing Address[city]" - :accessor 'customer-address-city)) - (div> :class "state" - (span> :class "label" "State") - (djvalidation-text-box> :visit-object billing-address - :class "text" - :label "Billing Address[state]" - :accessor 'customer-address-state)) - (div> :class "country" - (span> :class "label" "Country") - (djvalidation-text-box> :visit-object billing-address - :class "text" - :label "Billing Address[country]" - :accessor 'customer-address-country))))) - (div> :class "buttons" - (djsubmit-button> :value "Save") - (djbutton> :render-condition #'(lambda () (edit-customer-on-close-click obj)) - :id "Close" - :on-click (edit-customer-on-close-click obj) - "Close"))))) - - -(defmethod wcomponent-before-rewind :before ((obj edit-customer) (page page)) - (when (string-equal (htcomponent-client-id obj) (claw-parameter *rewind-parameter*)) - (let ((customer-id (parse-integer (claw-parameter (edit-customer-customer-id-parameter obj))))) - (setf (edit-customer-customer obj) - (find-by-id 'customer - customer-id)) - (find-or-add-address (edit-customer-customer obj) 0) - (find-or-add-address (edit-customer-customer obj) 1)))) - -(defmethod edit-customer-save ((obj edit-customer)) - (let ((id (htcomponent-client-id obj)) - (customer (edit-customer-customer obj)) - (main-address (find-or-add-address (edit-customer-customer obj) 0)) - (billing-address (find-or-add-address (edit-customer-customer obj) 1)) - (address-list ())) - (handler-case - (progn - (log-message :info "PHONE: ~a" (customer-phone1 customer)) - (unless (address-nullp main-address) - (push main-address address-list)) - (unless (address-nullp billing-address) - (push billing-address address-list)) - (setf (customer-addresses customer) address-list) - (update-db-item customer)) - (clsql-sys:sql-database-error (cond) - (log-message :info "Exception on edit-customer-save: ~a" cond) - (add-validation-error id (clsql-sys:sql-error-database-message cond)) - nil)))) - (defgeneric customers-page-find-customers (customers-page)) (defgeneric customers-page-offset-reset (customers-page)) @@ -376,7 +154,11 @@ (div> :static-id result-container-id (table> :class "listTable" (tr> :class "header" - (th> :class "delete" (djcheck-box> :id "deleteAll" :accessor 'customers-page-delete-all :value "all")) + (th> :class "deleteAll" (djcheck-box> :id "deleteAll" + ;:reader 'customers-page-delete-all + :value "all" + :onchange(remove #\newline (ps:ps (.for-each dojo (.map (.query dojo ".deleteItem") dijit.by-node) + (lambda (checkbox) (.attr checkbox "checked" (.attr this "checked"))) this))))) (th> :class "name" (span> :class (if (string-equal "name1" sort-field) (if (string-equal "asc" sort-direction) "sort sortAsc" @@ -410,7 +192,7 @@ (loop for customer in customers for index = 0 then (incf index) collect (tr> :class (if (evenp index) "item even" "item odd") - (th> :class "delete" (djcheck-box> :id "deleteItem" :accessor 'customers-page-delete-items + (th> :class "delete" (djcheck-box> :id "deleteItem" :class "deleteItem" :accessor 'customers-page-delete-items :value (table-id customer) :translator *integer-translator* :multiple t)) From achiumenti at common-lisp.net Wed Oct 1 11:59:40 2008 From: achiumenti at common-lisp.net (achiumenti at common-lisp.net) Date: Wed, 1 Oct 2008 07:59:40 -0400 (EDT) Subject: [claw-cvs] r103 - trunk/main/claw-demo/src/frontend Message-ID: <20081001115940.09E7971123@common-lisp.net> Author: achiumenti Date: Wed Oct 1 07:59:39 2008 New Revision: 103 Added: trunk/main/claw-demo/src/frontend/users.lisp Log: several bugfixes and enhancements Added: trunk/main/claw-demo/src/frontend/users.lisp ============================================================================== --- (empty file) +++ trunk/main/claw-demo/src/frontend/users.lisp Wed Oct 1 07:59:39 2008 @@ -0,0 +1,369 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- +;;; $Header: src/frontend/users.lisp $ + +;;; Copyright (c) 2008, Andrea Chiumenti. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(in-package :claw-demo-frontend) + +(defgeneric users-page-find-users (users-page)) + +(defgeneric users-page-offset-reset (users-page)) + +(defgeneric users-page-edit-user (uses-page)) + +(defgeneric users-page-sorting (users-page)) + +(defgeneric users-page-delete-users (users-page)) + +(defclass users-page (db-page) + ((users :initform nil + :accessor users-page-users) + (current-user :initform (make-instance 'user) + :accessor users-page-current-user) + (user-edit-dialog-title :initform "Add new cutomer" + :accessor users-page-user-edit-dialog-title) + (users-total-count :initform 0 + :accessor users-page-users-total-count) + (list-size :initarg :list-size + :accessor users-page-list-size) + (offset :initform 0 + :accessor users-page-offset) + (surname :initform "*" + :accessor users-page-surname) + (firstname :initform "" + :accessor users-page-firstname) + (username :initform "" + :accessor users-page-username) + (email :initform "" + :accessor users-page-email) + (active :initform :any + :accessor users-page-active) + (roles :initform '("user" "guest") + :accessor users-page-roles) + (sorting-column :initform "surname" + :accessor users-page-sorting-column) + (sorting-order :initform "asc" + :accessor users-page-sorting-order) + (delete-all :initform nil + :accessor users-page-delete-all) + (delete-items :initform nil + :accessor users-page-delete-items)) + (:default-initargs :list-size 20)) + +(defmethod users-page-offset-reset ((page users-page)) 0) + +(defmethod users-page-edit-user ((page users-page)) + (let ((user-id (parse-integer (claw-parameter "userid"))) + (current-user)) + (setf current-user (find-by-id 'user user-id) + (users-page-user-edit-dialog-title page) "Edit user" + (users-page-users page) (list current-user)) + (when current-user + (setf (users-page-current-user page) current-user)))) + +(defmethod users-page-sorting ((page users-page)) + (let ((direction (if (string-equal "asc" (users-page-sorting-order page)) + :asc + :desc)) + (fields (cond + ((string-equal "surname" (users-page-sorting-column page)) (list (slot-column-name 'user "surname") + (slot-column-name 'user "firstname"))) + ((string-equal "username" (users-page-sorting-column page)) (list (slot-column-name 'user "username"))) + (t (list (slot-column-name 'user "email") + (slot-column-name 'user "surname") + (slot-column-name 'user "firstname")))))) + (loop for field in fields + collect (list field direction)))) + +(defmethod page-content ((page users-page)) + (let ((spinner-id (generate-id "spinner")) + (form-id (generate-id "usersForm")) + (users (users-page-users page)) + (offset-id (generate-id "offset")) + (result-container-id (generate-id "resultContainer")) + (edit-user-dialog-container-id (generate-id "userDialogContainer")) + (edit-user-dialog-id (generate-id "userDialog")) + (edit-user-form-id (generate-id "userForm")) + (sorting-column-id (generate-id "sorting-column")) + (sorting-order-id (generate-id "sorting-order")) + (active-any-id (generate-id "activeAny")) + (active-yes-id (generate-id "activeYes")) + (active-no-id (generate-id "activeNo")) + (edit-user-action-link-id (generate-id "editUser")) + (sort-field (users-page-sorting-column page)) + (sort-direction (users-page-sorting-order page)) + (all-roles (find-vo 'role :order-by (list (slot-column-name 'role "name"))))) + (site-template> :title "CLAW Demo anagraphics" + (djfloating-content> :static-id spinner-id + (img> :alt "spinner" + :src "docroot/img/spinner.gif")) + (djform> :static-id form-id + :class "users" + :action 'users-page-find-users + :update-id result-container-id + :on-before-submit (ps:ps* `(.show (dijit.by-id ,spinner-id))) + :on-xhr-finish (ps:ps* `(.hide (dijit.by-id ,spinner-id))) + (div> (div> :class "searchParameters hlist" + (div> :class "item" (span> :class "surname" "Name") + (djtext-box> :label "name" :id "surname" :accessor 'users-page-surname) + (djtext-box> :label "name" :id "firstname" :accessor 'users-page-firstname)) + (div> :class "item" (span> :class "username" "Username") + (djtext-box> :label "username" :id "username" :accessor 'users-page-username)) + (div> :class "item" (span> :class "email" "Email") + (djtext-box> :label "email" :id "email" :accessor 'users-page-email)) + (div> :class "item active" (span> :class "active" "Active") + (div> :class "boundBox" + (div> (djradio-button> :static-id active-any-id + :name "active" + :class "active" + :translator *threestate-translator* + :accessor 'users-page-active + :value :any) + (label> :for active-any-id "Any")) + (div> (djradio-button> :static-id active-yes-id + :name "active" + :class "active" + :translator *threestate-translator* + :accessor 'users-page-active + :value t) + (label> :for active-yes-id "Yes")) + (div> (djradio-button> :static-id active-no-id + :name "active" + :class "active" + :translator *threestate-translator* + :accessor 'users-page-active + :value nil) + (label> :for active-no-id "No")))) + (div> :class "item roles" (span> :class "roles" "Roles") + (div> :class "boundBox" + (loop for role in all-roles + collect (let ((chk-id (generate-id "selRole"))) + (div> (djcheck-box> :static-id chk-id + :name "selRole" + :class "selRole" + :accessor 'users-page-roles + :value (role-name role) + :multiple t) + (label> :for chk-id (role-name role)))))))) + (cinput> :type "hidden" + :static-id offset-id + :translator *integer-translator* + :reader 'users-page-offset-reset + :writer (attribute-value '(setf users-page-offset))) + (cinput> :type "hidden" + :static-id sorting-column-id + :accessor 'users-page-sorting-column) + (cinput> :type "hidden" + :static-id sorting-order-id + :accessor 'users-page-sorting-order) + (div> :class "hlistButtons" + (djsubmit-button> :id "search" + :value "Search") + (djconfirmation-submit> :id "delete" + :value "Delete" + :action 'users-page-delete-users + :confirmation-message "Are you sure to delete these items?"))) + + (div> :static-id result-container-id + (table> :class "listTable" + (tr> :class "header" + (th> :class "deleteAll" (djcheck-box> :id "deleteAll" + ;:reader 'users-page-delete-all + :value "all" + :onchange(remove #\newline (ps:ps (.for-each dojo (.map (.query dojo ".deleteItem") dijit.by-node) + (lambda (checkbox) (.attr checkbox "checked" (.attr this "checked"))) this))))) + (th> :class "name" (span> :class (if (string-equal "surname" sort-field) + (if (string-equal "asc" sort-direction) + "sort sortAsc" + "sort sortDesc") + "sort") + :on-click (remove #\newline (ps:ps* `(progn (setf (slot-value (dojo.by-id ,sorting-order-id) 'value) + (if (and (== (slot-value (dojo.by-id ,sorting-column-id) 'value) "surname") + (== (slot-value (dojo.by-id ,sorting-order-id) 'value) "asc")) + "desc" + "asc")) + (setf (slot-value (dojo.by-id ,sorting-column-id) 'value) + "surname") + (.submit (dijit.by-id ,form-id))))) + "Name")) + (th> :class "username" (span> :class (if (string-equal "username" sort-field) + (if (string-equal "asc" sort-direction) + "sort sortAsc" + "sort sortDesc") + "sort") + :on-click (remove #\newline (ps:ps* `(progn (setf (slot-value (dojo.by-id ,sorting-order-id) 'value) + (if (and (== (slot-value (dojo.by-id ,sorting-column-id) 'value) "username") + (== (slot-value (dojo.by-id ,sorting-order-id) 'value) "asc")) + "desc" + "asc")) + (setf (slot-value (dojo.by-id ,sorting-column-id) 'value) + "username") + (.submit (dijit.by-id ,form-id))))) + "Username")) + (th> :class "email" (span> :class (if (string-equal "email" sort-field) + (if (string-equal "asc" sort-direction) + "sort sortAsc" + "sort sortDesc") + "sort") + :on-click (remove #\newline (ps:ps* `(progn (setf (slot-value (dojo.by-id ,sorting-order-id) 'value) + (if (and (== (slot-value (dojo.by-id ,sorting-column-id) 'value) "email") + (== (slot-value (dojo.by-id ,sorting-order-id) 'value) "asc")) + "desc" + "asc")) + (setf (slot-value (dojo.by-id ,sorting-column-id) 'value) + "email") + (.submit (dijit.by-id ,form-id))))) + "Email")) + (th> :class "enabled" "Enabled") + (th> :class "roles" "Roles")) + (loop for user in users + for index = 0 then (incf index) + collect (tr> :class (if (evenp index) "item even" "item odd") + (th> :class "delete" (djcheck-box> :id "deleteItem" :class "deleteItem" :accessor 'users-page-delete-items + :value (table-id user) + :translator *integer-translator* + :multiple t)) + (td> (a> :id "edit" + :href "#" + :on-click (remove #\newline (ps:ps* `(progn (setf (slot-value (dijit.by-id ,edit-user-action-link-id) 'parameters) + (create "userid" ,(table-id user))) + (.click (dijit.by-id ,edit-user-action-link-id))))) + (user-surname user) + " " + (user-firstname user))) + (td> (user-username user)) + (td> (user-email user)) + (td> :class (if (user-active user) + "active" + "inactive") + (if (user-active user) + "yes" + "no")) + (td> (format nil "~{~a~^, ~}" (loop for role in (user-roles user) + collect (role-name (first role)))))))) + (unless users + (djcheck-box> :id "deleteItem" + :accessor 'users-page-delete-items + :value 0 + :multiple t + :translator *integer-translator* + :style "display: none;")) + (djaction-link> :static-id edit-user-action-link-id + :style "display:none" + :action 'users-page-edit-user + :update-id (attribute-value (list edit-user-dialog-container-id result-container-id)) + :on-before-submit (ps:ps* `(.show (dijit.by-id ,spinner-id))) + :on-xhr-finish (remove #\newline (ps:ps* `(progn (.hide (dijit.by-id ,spinner-id)) + (.show (dijit.by-id ,edit-user-dialog-id))))) + "invisible") + (pager> :id "pager" + :update-component-id offset-id + :page-size (users-page-list-size page) + :total-items (users-page-users-total-count page) + :first-item-offset (users-page-offset page)))) + (div> :static-id edit-user-dialog-container-id + (djdialog> :static-id edit-user-dialog-id + :class "userDialog" + :title (users-page-user-edit-dialog-title page) + #| + (edit-user> :static-id edit-user-form-id + :on-close-click (ps:ps* `(.hide (dijit.by-id ,edit-user-dialog-id))) + :update-id (attribute-value (list edit-user-form-id result-container-id)) + :user (users-page-current-user page) + :on-before-submit (remove #\newline (ps:ps* `(progn (.show (dijit.by-id ,spinner-id)) + (dojo.add-class + (slot-value (dijit.by-id ,edit-user-dialog-id) 'container-node) + "hideForm")))) + :on-xhr-finish (ps:ps* `(progn (.hide (dijit.by-id ,spinner-id)) + (dojo.remove-class + (slot-value (dijit.by-id ,edit-user-dialog-id) 'container-node) + "hideForm")))) + |# + (exception-monitor> :id "exceptionMonitor" :json-render-on-validation-errors-p edit-user-form-id)))))) + +(defmethod users-page-delete-users ((page users-page)) + (let ((user-id-list (users-page-delete-items page)) + (surname (users-page-surname page)) + (firstname (users-page-firstname page)) + (username (user-username page)) + (email (users-page-email page)) + (active (users-page-active page)) + (roles (users-page-roles page))) + (log-message :info "...deleting") + (delete-by-id 'user user-id-list) + (setf (users-page-delete-items page) ()) + (multiple-value-bind (users total-size) + (find-users :offset (users-page-offset page) + :limit (users-page-list-size page) + :surname (null-when-empty surname) + :firstname (null-when-empty firstname) + :username username + :email (null-when-empty email) + :active active + :role-names (null-when-empty roles) + :sorting (users-page-sorting page)) + (setf (users-page-users page) users + (users-page-users-total-count page) total-size)))) + +(defmethod users-page-find-users ((page users-page)) + (let ((surname (users-page-surname page)) + (firstname (users-page-firstname page)) + (username (users-page-username page)) + (email (users-page-email page)) + (active (users-page-active page)) + (roles (users-page-roles page))) +(log-message :info "???? ~a" roles) + (multiple-value-bind (users total-size) + (find-users :offset (users-page-offset page) + :limit (users-page-list-size page) + :surname (null-when-empty surname) + :firstname (null-when-empty firstname) + :username (null-when-empty username) + :email (null-when-empty email) + :active active + :role-names roles + :sorting (users-page-sorting page)) + (log-message :info "xxxx : ~a" users) + (setf (users-page-users page) users + (users-page-users-total-count page) total-size)))) + +(defmethod page-before-render ((page users-page)) + (unless (page-req-parameter page *rewind-parameter*) + (multiple-value-bind (users total-size) + (find-users :sorting (users-page-sorting page) + :offset 0 + :limit (users-page-list-size page)) + (setf (users-page-users page) users + (users-page-users-total-count page) total-size)))) + + +(lisplet-register-function-location *dojo-demo-lisplet* + (make-page-renderer 'users-page #'claw-post-parameters #'claw-get-parameters) + "users.html") + +(lisplet-protect *dojo-demo-lisplet* "users.html" '("administrator" "user")) + From achiumenti at common-lisp.net Wed Oct 1 12:01:18 2008 From: achiumenti at common-lisp.net (achiumenti at common-lisp.net) Date: Wed, 1 Oct 2008 08:01:18 -0400 (EDT) Subject: [claw-cvs] r105 - trunk/main/claw-demo/src/frontend/docroot/css Message-ID: <20081001120118.356642F047@common-lisp.net> Author: achiumenti Date: Wed Oct 1 08:01:16 2008 New Revision: 105 Modified: trunk/main/claw-demo/src/frontend/docroot/css/style.css Log: several bugfixes and enhancements Modified: trunk/main/claw-demo/src/frontend/docroot/css/style.css ============================================================================== --- trunk/main/claw-demo/src/frontend/docroot/css/style.css (original) +++ trunk/main/claw-demo/src/frontend/docroot/css/style.css Wed Oct 1 08:01:16 2008 @@ -6,6 +6,10 @@ font-family: arial; } +ul.errors { + padding: 0; +} + .contentBody { margin-top: 0; background: white; @@ -43,7 +47,7 @@ } .topheader { - visibility: hidden; + /*visibility: hidden;*/ position: relative; height: 140px; background: url(../img/clawHead.png) 0 0 no-repeat; @@ -111,9 +115,30 @@ font-weight: bold; } + .hlist div.item { float: left; } + +.hlist .boundBox{ + border: 1px solid #8BA0BD; + padding: 2px 4px 2px 2px; +} + +.hlist div.active .boundBox{ + width: 100px; +} + +.hlist div.roles .boundBox{ + margin-left: 2px; + width: 230px; +} + + +.hlist div.item div, .hlistButtons{ + clear: left; +} + .searchParameters div.item span { display: block; } @@ -128,8 +153,7 @@ body.demo .customerDialog { width: 305px; - height: 460px; - overflow: hidden; + min-height: 460px; } body.demo .customerDialog .dijitDialogPaneContent{ @@ -173,6 +197,11 @@ margin-left: 4px; } +.addressTabs .address { + width: 270px; + margin-left: 0; +} + .addressTabs .zip, .addressTabs .country { width: 56px; margin-left: 0; @@ -197,3 +226,7 @@ .hideForm form, .hideForm .dijitTextBox input, hideForm .dijitComboBox input, .hideForm .dijitSpinner input{ visibility: hidden !important; } + +.users .hlist .dijitTextBox { + width: 150px; +} \ No newline at end of file From achiumenti at common-lisp.net Wed Oct 1 12:01:56 2008 From: achiumenti at common-lisp.net (achiumenti at common-lisp.net) Date: Wed, 1 Oct 2008 08:01:56 -0400 (EDT) Subject: [claw-cvs] r106 - trunk/main/claw-demo Message-ID: <20081001120156.E792C7918E@common-lisp.net> Author: achiumenti Date: Wed Oct 1 08:01:55 2008 New Revision: 106 Modified: trunk/main/claw-demo/claw-demo.asd Log: several bugfixes and enhancements Modified: trunk/main/claw-demo/claw-demo.asd ============================================================================== --- trunk/main/claw-demo/claw-demo.asd (original) +++ trunk/main/claw-demo/claw-demo.asd Wed Oct 1 08:01:55 2008 @@ -54,13 +54,32 @@ :components ((:module src :components ((:module frontend :components ((:file "packages") + (:file "edit-customer" + :pathname #.(make-pathname :directory '(:relative "components") :name "edit-customer" :type "lisp") + :depends-on ("packages")) + (:file "site-template" + :pathname #.(make-pathname :directory '(:relative "components") :name "site-template" :type "lisp") + :depends-on ("packages")) + (:file "pager" + :pathname #.(make-pathname :directory '(:relative "components") :name "pager" :type "lisp") + :depends-on ("packages")) + (:file "djconfirmation-submit" + :pathname #.(make-pathname :directory '(:relative "components") :name "djconfirmation-submit" :type "lisp") + :depends-on ("packages")) + (:file "redirect" + :pathname #.(make-pathname :directory '(:relative "components") :name "redirect" :type "lisp") + :depends-on ("packages")) + (:file "translator-threestate" + :pathname #.(make-pathname :directory '(:relative "components") :name "translator-threestate" :type "lisp") + :depends-on ("packages")) (:file "auth" :depends-on ("packages")) - (:file "commons" :depends-on ("packages")) + (:file "commons" :depends-on ("packages" "site-template" "pager" "djconfirmation-submit" "redirect" "edit-customer" "translator-threestate")) (:file "main" :depends-on ("packages" "auth")) (:file "index" :depends-on ("commons" "main")) (:file "logout" :depends-on ("commons" "main")) (:file "login" :depends-on ("commons" "main")) - (:file "customers" :depends-on ("commons" "main")))))))) + (:file "customers" :depends-on ("commons" "main")) + (:file "users" :depends-on ("commons" "main")))))))) (asdf:defsystem :claw-demo From achiumenti at common-lisp.net Wed Oct 1 12:02:35 2008 From: achiumenti at common-lisp.net (achiumenti at common-lisp.net) Date: Wed, 1 Oct 2008 08:02:35 -0400 (EDT) Subject: [claw-cvs] r107 - trunk/main/claw-demo/test/backend Message-ID: <20081001120235.93FC071157@common-lisp.net> Author: achiumenti Date: Wed Oct 1 08:02:30 2008 New Revision: 107 Modified: trunk/main/claw-demo/test/backend/tests.lisp Log: several bugfixes and enhancements Modified: trunk/main/claw-demo/test/backend/tests.lisp ============================================================================== --- trunk/main/claw-demo/test/backend/tests.lisp (original) +++ trunk/main/claw-demo/test/backend/tests.lisp Wed Oct 1 08:02:30 2008 @@ -189,6 +189,43 @@ :roles (list admin-role user-role))) (lift:ensure (find-user-by-name "admin")))) +(lift:addtest (claw-demo-backend-testsuite) + find-users + (let ((admin-role (make-instance 'role :name "administrator")) + (user-role (make-instance 'role :name "user"))) + (update-db-item admin-role) + (update-db-item user-role) + (update-db-item (make-instance 'user :firstname "Andrea" + :surname "Chiumenti" + :username "admin" + :password "admin" + :email "admin at new.com" + :roles (list admin-role user-role))) + (lift:ensure (find-users :role-names '("administrator"))))) + +(locally-enable-sql-reader-syntax) +(lift:addtest (claw-demo-backend-testsuite) + test-join + (let ((admin-role (make-instance 'role :name "administrator")) + (user-role (make-instance 'role :name "user"))) + (update-db-item admin-role) + (update-db-item user-role) + (update-db-item (make-instance 'user :firstname "Andrea" + :surname "Chiumenti" + :username "admin" + :password "admin" + :email "admin at new.com" + :roles (list admin-role user-role))) + (lift:ensure (= (length (select 'user + :from [left-join [left-join [users] [users-roles] [= [slot-value 'user 'id] [slot-value 'user-role 'user-id] ] ] [roles] [= [slot-value 'user-role 'role-id] [slot-value 'role 'id]]] + :where [and [= [slot-value 'user 'firstname] "Andrea" ] [= [slot-value 'role 'name] "administrator" ]] + :flatp t)) 1)) + (lift:ensure (= (length (select 'user + :from [left-join [left-join [users] [users-roles] [= [slot-value 'user 'id] [slot-value 'user-role 'user-id] ] ] [roles] [= [slot-value 'user-role 'role-id] [slot-value 'role 'id]]] + :where [and [= [slot-value 'user 'firstname] "Andreax" ] [= [slot-value 'role 'name] "administrator" ]] + :flatp t)) 0)))) +(locally-disable-sql-reader-syntax) + (lift:addtest (claw-demo-backend-testsuite) like-operation (let ((admin-role (make-instance 'role :name "administrator")) @@ -204,6 +241,22 @@ (lift:ensure (find-vo 'user :where (like-operation 'username "*n\\&1"))) (lift:ensure-null (find-vo 'user :where (like-operation 'username "*n\\&"))))) +(lift:addtest (claw-demo-backend-testsuite) + find-users + (let ((admin-role (make-instance 'role :name "administrator")) + (user-role (make-instance 'role :name "user"))) + (update-db-item admin-role) + (update-db-item user-role) + (update-db-item (make-instance 'user :firstname "Andrea" + :surname "Chiumenti" + :username "admin\\&1" + :password "admin" + :email "admin at new.com" + :roles (list admin-role user-role))) + (lift:ensure (find-users :firstname "*" :role-names '("administrator"))) + (lift:ensure-null (find-users :firstname "*" :role-names '("administratorxx"))) + (lift:ensure-null (find-users :firstname "xxx")))) + (lift:addtest (claw-demo-backend-testsuite) find-customers From achiumenti at common-lisp.net Wed Oct 1 12:00:41 2008 From: achiumenti at common-lisp.net (achiumenti at common-lisp.net) Date: Wed, 1 Oct 2008 08:00:41 -0400 (EDT) Subject: [claw-cvs] r104 - trunk/main/claw-demo/src/frontend/components Message-ID: <20081001120041.B1D281B019@common-lisp.net> Author: achiumenti Date: Wed Oct 1 08:00:39 2008 New Revision: 104 Added: trunk/main/claw-demo/src/frontend/components/ trunk/main/claw-demo/src/frontend/components/djconfirmation-submit.lisp trunk/main/claw-demo/src/frontend/components/edit-customer.lisp trunk/main/claw-demo/src/frontend/components/pager.lisp trunk/main/claw-demo/src/frontend/components/redirect.lisp trunk/main/claw-demo/src/frontend/components/site-template.lisp trunk/main/claw-demo/src/frontend/components/translator-threestate.lisp Log: several bugfixes and enhancements Added: trunk/main/claw-demo/src/frontend/components/djconfirmation-submit.lisp ============================================================================== --- (empty file) +++ trunk/main/claw-demo/src/frontend/components/djconfirmation-submit.lisp Wed Oct 1 08:00:39 2008 @@ -0,0 +1,66 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- +;;; $Header: src/frontend/components/djconfirmation-submit.lisp $ + +;;; Copyright (c) 2008, Andrea Chiumenti. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(in-package :claw-demo-frontend) + +(defclass djconfirmation-submit (wcomponent) + ((value :initarg :value + :accessor djconfirmation-submit-value) + (action :initarg :action + :accessor djconfirmation-submit-action) + (confirmation-message :initarg :confirmation-message + :accessor djconfirmation-submit-confirmation-message) + (yes-label :initarg :yes + :accessor djconfirmation-submit-yes) + (no-label :initarg :no + :accessor djconfirmation-submit-no)) + (:default-initargs :yes "Yes" :no "No") + (:metaclass metacomponent)) + +(defmethod wcomponent-template ((obj djconfirmation-submit)) + (let* ((dialog-id (generate-id "confirmationDiaolg")) + (yes-id (generate-id "yes")) + (value (djconfirmation-submit-value obj))) + (div> :class "dijit dijitReset dijitLeft dijitInline" + (djbutton> :static-id (htcomponent-client-id obj) + :on-click (ps:ps* `(.show (dijit.by-id ,dialog-id))) + (wcomponent-informal-parameters obj) + (or (htcomponent-body obj) value)) + (djdialog> :static-id dialog-id + :title "Confirm" + (div> (djconfirmation-submit-confirmation-message obj) + (div> :class "buttonContainer" + (djsubmit-button> :static-id yes-id + :value (djconfirmation-submit-value obj) + :action (djconfirmation-submit-action obj) + :on-click (ps:ps* `(.hide (dijit.by-id ,dialog-id))) + (djconfirmation-submit-yes obj)) + (djbutton> :id dialog-id + :on-click (ps:ps* `(.hide (dijit.by-id ,dialog-id))) + (djconfirmation-submit-no obj)))))))) \ No newline at end of file Added: trunk/main/claw-demo/src/frontend/components/edit-customer.lisp ============================================================================== --- (empty file) +++ trunk/main/claw-demo/src/frontend/components/edit-customer.lisp Wed Oct 1 08:00:39 2008 @@ -0,0 +1,319 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- +;;; $Header: components/edit-customer.lisp $ + +;;; Copyright (c) 2008, Andrea Chiumenti. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(in-package :claw-demo-frontend) + +(defgeneric edit-customer-save (edit-customer)) + +(defclass edit-customer (djform) + ((customer :initarg :customer + :accessor edit-customer-customer) + (customer-id-parameter :initarg :customer-id-parameter + :accessor edit-customer-customer-id-parameter) + (on-close-click :initarg :on-close-click + :accessor edit-customer-on-close-click)) + (:metaclass metacomponent) + (:default-initargs :on-close-click nil + :class "customerForm" :customer-id-parameter "customerid")) + +(defmethod initialize-instance :after ((obj edit-customer) &key rest) + (declare (ignore rest)) + (setf (action-object obj) obj + (action obj) 'edit-customer-save)) + +(defun find-or-add-address (customer address-type) + (let ((address (loop for item in (customer-addresses customer) + when (= (customer-address-type item) address-type) + return item))) + (unless address + (setf address (make-instance 'customer-address :address-type address-type)) + (push address (customer-addresses customer))) + address)) + +(defun address-nullp (address) + (let ((attributes (list (customer-address-address address) + (customer-address-zip address) + (customer-address-city address) + (customer-address-state address) + (customer-address-country address)))) + (not + (loop for val in (mapcar #'(lambda (x) + (when (and x (string-not-equal x "")) + t)) + attributes) + when val + return t)))) + +(defmethod htcomponent-class-initscripts :around ((obj edit-customer)) + (let ((req-function (ps:ps (defun is-address-field-required (container-id) + (defvar input-list (dojo.query "[widgetId]" (dojo.by-id container-id))) + (defvar result false) + (dojo.for-each (.map input-list (slot-value dijit 'by-node)) + (lambda (input) (when (.get-value input) (setf result t)))) + (return result)))) + (address-field-validation (ps:ps (progn + (defun address-field-validation-init (component-id address-container-class) + (dojo.for-each (dojo.query (+ "." address-container-class) (dojo.by-id component-id)) + (lambda (main-address-node) + (dojo.for-each (.map (dojo.query "[widgetId]" main-address-node) dijit.by-node) + (lambda (widget) + (setf (slot-value widget 'is-valid) (lambda (is-focused) + (address-field-validation widget (slot-value main-address-node 'id)) + (return (.validator widget (slot-value (slot-value widget 'textbox) 'value) + (slot-value widget 'constraints)))))))))) + (defun address-field-validation (sender container-id) + (if (is-address-field-required container-id) + (unless (= (slot-value sender 'required) t) + (defvar input-list (dojo.query "[widgetId]" (dojo.by-id container-id))) + (dojo.for-each (.map input-list dijit.by-node) + (lambda (input-widget) (setf (slot-value input-widget 'required) t)))) + (unless (!= (slot-value sender 'required) t) + (defvar input-list (dojo.query "[widgetId]" (dojo.by-id container-id))) + (dojo.for-each (.map input-list dijit.by-node) + (lambda (input-widget) (setf (slot-value input-widget 'required) false)))))))))) + (append (list req-function address-field-validation) (call-next-method)))) + +(defmethod htcomponent-instance-initscript :around ((obj edit-customer)) + (let* ((component-id (htcomponent-client-id obj)) + (parent-script (call-next-method)) + (script (ps:ps* `(progn + (address-field-validation-init ,component-id "mainAddress") + (address-field-validation-init ,component-id "billingAddress"))))) + (if parent-script + (format nil "~a~%~a" parent-script script) + script))) + +(defmethod htcomponent-body ((obj edit-customer)) + (let* ((visit-object (edit-customer-customer obj)) + (main-address (find-or-add-address visit-object 0)) + (billing-address (find-or-add-address visit-object 1)) + (main-address-id (generate-id "mainAddress")) + (billing-address-id (generate-id "billingAddress")) + (address-1-id (generate-id "address")) + (zip-1-id (generate-id "zip")) + (city-1-id (generate-id "city")) + (state-1-id (generate-id "state")) + (country-1-id (generate-id "country")) + (address-2-id (generate-id "address")) + (zip-2-id (generate-id "zip")) + (city-2-id (generate-id "city")) + (state-2-id (generate-id "state")) + (country-2-id (generate-id "country"))) + (list + (cinput> :id (edit-customer-customer-id-parameter obj) + :type "hidden" :visit-object visit-object + :translator *integer-translator* + :accessor 'table-id) + (cinput> :id "tabbleVersion" + :type "hidden" + :visit-object visit-object + :translator *integer-translator* + :accessor 'table-version) + (div> :class "label name1" + (span> "Name 1") + (djvalidation-text-box> :visit-object visit-object + :required "true" + :label "Name 1" + :accessor 'customer-name1)) + (div> :class "label name2" + (span> "Name 2") + (djvalidation-text-box> :visit-object visit-object + :label "Name 2" + :accessor 'customer-name2)) + (div> :class "label email" + (span> "Email") + (djvalidation-text-box> :visit-object visit-object + :label "Email" + :accessor 'customer-email)) + (div> :class "label pone1" + (span> "Phone 1") + (djvalidation-text-box> :visit-object visit-object + :label "Phone 1" + :accessor 'customer-phone1)) + (div> :class "label pone2" + (span> "Phone 2") + (djvalidation-text-box> :visit-object visit-object + :label "Phone 2" + :accessor 'customer-phone2)) + (div> :class "label pone3" + (span> "Phone 3") + (djvalidation-text-box> :visit-object visit-object + :label "Phone 3" + :accessor 'customer-phone3)) + (div> :class "label fax" + (span> "Fax") + (djvalidation-text-box> :visit-object visit-object + :label "Fax" + :accessor 'customer-fax)) + (div> :class "label vat" + (span> "VAT") + (djvalidation-text-box> :visit-object visit-object + :label "VAT" + :accessor 'customer-vat)) + (div> :class "label code1" + (span> "Code 1") + (djvalidation-text-box> :visit-object visit-object + :label "Code 1" + :accessor 'customer-code1)) + (div> :class "label code2" + (span> "Code 2") + (djvalidation-text-box> :visit-object visit-object + :label "Code 2" + :accessor 'customer-code2)) + (div> :class "label code3" + (span> "Code 3") + (djvalidation-text-box> :visit-object visit-object + :label "Code 3" + :accessor 'customer-code3)) + (div> :class "label code4" + (span> "Code 4") + (djvalidation-text-box> :visit-object visit-object + :label "Code 4" + :accessor 'customer-code4)) + (djtab-container> :id "addressTabs" + :class "addressTabs" + (djcontent-pane> :static-id main-address-id :class "mainAddress" :title "Main address" + (div> (div> :class "address" + (span> :class "label" "Street") + (djvalidation-text-box> :static-id address-1-id + :trim "true" + :visit-object main-address + :class "text" + :label "Main Address[address]" + :accessor 'customer-address-address)) + (div> :class "zip" + (span> :class "label" "Zip") + (djvalidation-text-box> :static-id zip-1-id + :trim "true" + :visit-object main-address + :class "text" + :label "Main Address[zip]" + :accessor 'customer-address-zip)) + (div> :class "city" + (span> :class "label" "City") + (djvalidation-text-box> :static-id city-1-id + :trim "true" + :visit-object main-address + :class "text" + :label "Main Address[city]" + :accessor 'customer-address-city)) + (div> :class "state" + (span> :class "label" "State") + (djvalidation-text-box> :static-id state-1-id + :trim "true" + :visit-object main-address + :class "text" + :label "Main Address[state]" + :accessor 'customer-address-state)) + (div> :class "country" + (span> :class "label" "Country") + (djvalidation-text-box> :static-id country-1-id + :trim "true" + :visit-object main-address + :class "text" + :label "Main Address[country]" + :accessor 'customer-address-country)))) + (djcontent-pane> :static-id billing-address-id :class "billingAddress" :title "Billing address" + (div> (div> :class "address" + (span> :class "label" "Street") + (djvalidation-text-box> :static-id address-2-id + :trim "true" + :visit-object billing-address + :class "text" + :label "Billing Address[street]" + :accessor 'customer-address-address)) + (div> :class "zip" + (span> :class "label" "Zip") + (djvalidation-text-box> :static-id zip-2-id + :trim "true" + :visit-object billing-address + :class "text" + :label "Billing Address[zip]" + :accessor 'customer-address-zip)) + (div> :class "city" + (span> :class "label" "City") + (djvalidation-text-box> :static-id city-2-id + :trim "true" + :visit-object billing-address + :class "text" + :label "Billing Address[city]" + :accessor 'customer-address-city)) + (div> :class "state" + (span> :class "label" "State") + (djvalidation-text-box> :static-id state-2-id + :trim "true" + :visit-object billing-address + :class "text" + :label "Billing Address[state]" + :accessor 'customer-address-state)) + (div> :class "country" + (span> :class "label" "Country") + (djvalidation-text-box> :static-id country-2-id + :trim "true" + :visit-object billing-address + :class "text" + :label "Billing Address[country]" + :accessor 'customer-address-country))))) + (div> :class "buttons" + (djsubmit-button> :value "Save") + (djbutton> :render-condition #'(lambda () (edit-customer-on-close-click obj)) + :id "Close" + :on-click (edit-customer-on-close-click obj) + "Close"))))) + + +(defmethod wcomponent-before-rewind :before ((obj edit-customer) (page page)) + (when (string-equal (htcomponent-client-id obj) (claw-parameter *rewind-parameter*)) + (let ((customer-id (parse-integer (claw-parameter (edit-customer-customer-id-parameter obj))))) + (setf (edit-customer-customer obj) + (find-by-id 'customer + customer-id)) + (find-or-add-address (edit-customer-customer obj) 0) + (find-or-add-address (edit-customer-customer obj) 1)))) + +(defmethod edit-customer-save ((obj edit-customer)) + (let ((id (htcomponent-client-id obj)) + (customer (edit-customer-customer obj)) + (main-address (find-or-add-address (edit-customer-customer obj) 0)) + (billing-address (find-or-add-address (edit-customer-customer obj) 1)) + (address-list ())) + (handler-case + (progn + (log-message :info "PHONE: ~a" (customer-phone1 customer)) + (unless (address-nullp main-address) + (push main-address address-list)) + (unless (address-nullp billing-address) + (push billing-address address-list)) + (setf (customer-addresses customer) address-list) + (update-db-item customer)) + (clsql-sys:sql-database-error (cond) + (log-message :info "Exception on edit-customer-save: ~a" cond) + (add-validation-error id (clsql-sys:sql-error-database-message cond)) + nil)))) + Added: trunk/main/claw-demo/src/frontend/components/pager.lisp ============================================================================== --- (empty file) +++ trunk/main/claw-demo/src/frontend/components/pager.lisp Wed Oct 1 08:00:39 2008 @@ -0,0 +1,142 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- +;;; $Header: src/frontend/components/pager.lisp $ + +;;; Copyright (c) 2008, Andrea Chiumenti. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(in-package :claw-demo-frontend) + +(defgeneric pager-count-pages (pager)) + +(defgeneric pager-current-page (pager)) + +(defgeneric pager-page-list (pager)) + +(defgeneric set-offset-value (pager page)) + +(defclass pager (wcomponent) + ((update-component-id :initarg :update-component-id + :accessor pager-update-component-id) + (class :initarg :class + :reader pager-class) + (page-size :initarg :page-size + :reader pager-page-size) + (visible-pages :initarg :visible-pages + :accessor pager-visible-pages) + (total-items :initarg :total-items + :accessor pager-total-items) + (first-item-offset :initarg :first-item-offset + :accessor pager-first-item-offset)) + (:metaclass metacomponent) + (:default-initargs :page-size 10 :visible-pages 10 :class "pager")) + +(defmethod wcomponent-template ((pager pager)) + (let ((total-items (pager-total-items pager)) + (page-size (pager-page-size pager)) + (page-list (pager-page-list pager)) + (current-page (pager-current-page pager)) + (count-pages (pager-count-pages pager)) + (id (htcomponent-client-id pager))) + (when (> total-items page-size) + (div> + :static-id id + :class (pager-class pager) + (wcomponent-informal-parameters pager) + + (when (> current-page 1) + (list (div> :class "button first" + (span> :on-click (set-offset-value pager 1) "first")) + (div> :class "button previous" + (span> :on-click (set-offset-value pager (1- current-page)) "previous")))) + (loop for page in page-list + collect (if (= page current-page) + (div> :class "current page" + (span> (format nil "~a" page))) + (div> :class "page" (span> :on-click (set-offset-value pager page) (format nil "~a" page))))) + (when (< current-page count-pages) + (list (div> :class "button next" + (span> :on-click (set-offset-value pager (1+ current-page)) "next")) + (div> :class "button last" + (span> :on-click (set-offset-value pager count-pages) "last")))))))) + +(defmethod htcomponent-class-initscripts ((pager pager)) + (let ((update-component-id (pager-update-component-id pager)) + (page-size (pager-page-size pager))) + (list + (ps:ps* `(defun pager-go-to (page) + (setf (slot-value (dojo.by-id ,update-component-id) 'value) (* (1- page) ,page-size)) + (defvar form-id (slot-value (slot-value (dojo.by-id ,update-component-id) 'form) 'id)) + (let ((form-el (or (dijit.by-id form-id) + (dojo.by-id form-id)))) + (.submit form-el))))))) + +(defmethod set-offset-value ((pager pager) page) + (ps:ps* `(pager-go-to ,page))) + +(defmethod pager-count-pages ((pager pager)) + (let ((page-size (pager-page-size pager)) + (total-items (pager-total-items pager))) + (count-pages page-size total-items))) + +(defun count-pages (page-size total-items) + (multiple-value-bind (pages rest) + (truncate total-items page-size) + (when (> rest 0) (incf pages)) + pages)) + +(defmethod pager-current-page ((pager pager)) + (let ((page-size (pager-page-size pager)) + (first-item-offset (pager-first-item-offset pager))) + (multiple-value-bind (page rest) + (truncate (1+ first-item-offset) page-size) + (when (> rest 0) (incf page)) + page))) + +(defmethod pager-page-list ((pager pager)) + (let ((current-page (pager-current-page pager)) + (count-pages (pager-count-pages pager)) + (visible-pages (pager-visible-pages pager)) + (pages-before-current-page) + (pages-after-current-page) + (result)) + (when (> current-page 1) + (setf pages-before-current-page + (reverse + (loop for page from (1- current-page) downto (max 1 (- current-page + (truncate visible-pages 2))) + collect page)))) + (when (< current-page count-pages) + (setf pages-after-current-page + (loop for page from (1+ current-page) to (min count-pages (+ (1- current-page) + (- visible-pages (length pages-before-current-page)))) + collect page))) + (setf result (append pages-before-current-page (list current-page) pages-after-current-page)) + (let ((result-length (length result)) + (first-result-page (first result))) + (if (< result-length visible-pages) + (append (reverse (loop for page from (1- first-result-page) downto (max 1 (- first-result-page (- visible-pages result-length))) + collect page)) result) + result)))) \ No newline at end of file Added: trunk/main/claw-demo/src/frontend/components/redirect.lisp ============================================================================== --- (empty file) +++ trunk/main/claw-demo/src/frontend/components/redirect.lisp Wed Oct 1 08:00:39 2008 @@ -0,0 +1,41 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- +;;; $Header: src/frontend/components/redirect.lisp $ + +;;; Copyright (c) 2008, Andrea Chiumenti. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(in-package :claw-demo-frontend) + +(defclass redirect (wcomponent) + ((href :initarg :href + :reader redirect-href)) + (:metaclass metacomponent)) + +(defmethod htcomponent-instance-initscript ((redirect redirect)) + (ps:ps* `(location.replace ,(redirect-href redirect)))) + +(defmethod wcomponent-template ((redirect redirect)) + ($> "")) Added: trunk/main/claw-demo/src/frontend/components/site-template.lisp ============================================================================== --- (empty file) +++ trunk/main/claw-demo/src/frontend/components/site-template.lisp Wed Oct 1 08:00:39 2008 @@ -0,0 +1,78 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- +;;; $Header: src/frontend/components/site-template.lisp $ + +;;; Copyright (c) 2008, Andrea Chiumenti. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(in-package :claw-demo-frontend) + +(defclass site-template (wcomponent) + ((title :initarg :title + :reader site-template-title) + (djconfig :initarg :djconfig + :reader site-template-djconfig)) + (:metaclass metacomponent) + (:default-initargs :djconfig nil)) + +(defmethod wcomponent-template ((site-template site-template)) + (let ((principal (current-principal))) + (html> + (head> + (title> (site-template-title site-template)) + (link> :href (format nil "~a/docroot/css/style.css" *root-path*) + :rel "stylesheet" + :type "text/css")) + (djbody> :is-debug "false" + :theme "soria" + :class "demo" + :djconfig (site-template-djconfig site-template) + (wcomponent-informal-parameters site-template) + (div> :class "topheader" + (div> :class "logoDemo") + (div> :class "logoClaw")) + (djtoolbar> :id "menuBar" :class "menuBar" + (djdrop-down-button> (span> "File") + (djmenu> + (djmenu-item> :id "loginMenu" + :render-condition #'(lambda () (null principal)) + :on-click (ps:ps* `(location.replace ,(format nil "~a/login.html" *root-path*))) + "Login") + (djmenu-item> :id "logoutMenu" + :render-condition #'(lambda () principal) + :on-click (ps:ps* `(location.replace ,(format nil "~a/logout.html" *root-path*))) + "Logout"))) + (djdrop-down-button> :render-condition #'(lambda () principal) + (span> "Anagraphics") + (djmenu> + (djmenu-item> :id "customersMenu" + :on-click (ps:ps* `(location.replace ,(format nil "~a/customers.html" *root-path*))) + "Customers") + (djmenu-item> :id "usersMenu" + :render-condition #'(lambda () (user-in-role-p '("administrator"))) + :on-click (ps:ps* `(location.replace ,(format nil "~a/users.html" *root-path*))) + "Users")))) + (div> :class "contentBody" + (htcomponent-body site-template)))))) \ No newline at end of file Added: trunk/main/claw-demo/src/frontend/components/translator-threestate.lisp ============================================================================== --- (empty file) +++ trunk/main/claw-demo/src/frontend/components/translator-threestate.lisp Wed Oct 1 08:00:39 2008 @@ -0,0 +1,66 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- +;;; $Header: src/frontend/components/translator-threestate.lisp $ + +;;; Copyright (c) 2008, Andrea Chiumenti. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(in-package :claw-demo-frontend) + +(defclass translator-threestate (translator) + ((yes :initarg :yes + :reader translator-threestate-yes) + (no :initarg :no + :reader translator-threestate-no) + (any :initarg :any + :reader translator-threestate-any) + (yes-to-string :initarg :yes-to-string + :reader translator-threestate-yes-to-string) + (no-to-string :initarg :no-to-string + :reader translator-threestate-no-to-string) + (any-to-string :initarg :any-to-string + :reader translator-threestate-any-to-string) + (test :initarg :test + :reader translator-threestate-test)) + (:default-initargs :yes-to-string "yes" :no-to-string "no" :any-to-string "any" :yes t :no nil :any :any :test #'equal)) + +(defmethod translator-value-encode ((translator translator-threestate) value) + (let ((test (translator-threestate-test translator))) + (cond + ((funcall test value (translator-threestate-yes translator)) (translator-threestate-yes-to-string translator)) + ((funcall test value (translator-threestate-no translator)) (translator-threestate-no-to-string translator)) + ((funcall test value (translator-threestate-any translator)) (translator-threestate-any-to-string translator)) + (t (error "Unrecognized value for threestate translator: ~a (Test: ~a on ~a ~a)" value test value (translator-threestate-any translator)))))) + +(defmethod translator-value-decode ((translator translator-threestate) value &optional client-id label) + (cond + ((string-equal value (translator-threestate-yes-to-string translator)) (translator-threestate-yes translator)) + ((string-equal value (translator-threestate-no-to-string translator)) (translator-threestate-no translator)) + ((string-equal value (translator-threestate-any-to-string translator)) (translator-threestate-any translator)) + (t (when label + (add-validation-error client-id (format nil (or (validation-error-control-string translator) + "Field ~a: invalid value '~a'.") label value)))))) + +(defvar *threestate-translator* (make-instance 'translator-threestate)) \ No newline at end of file From achiumenti at common-lisp.net Tue Oct 21 12:42:43 2008 From: achiumenti at common-lisp.net (Andrea Chiumenti) Date: Tue, 21 Oct 2008 12:42:43 +0000 Subject: [claw-cvs] r119 - trunk/main/claw/src Message-ID: Author: achiumenti Date: Tue Oct 21 12:42:43 2008 New Revision: 119 Log: several bugfixes and enhancements Modified: trunk/main/claw/src/session-manager.lisp Modified: trunk/main/claw/src/session-manager.lisp ============================================================================== --- trunk/main/claw/src/session-manager.lisp (original) +++ trunk/main/claw/src/session-manager.lisp Tue Oct 21 12:42:43 2008 @@ -340,15 +340,16 @@ (let ((connector (clawserver-connector *clawserver*)) (cookie-name (default-session-manager-session-cookie-name session-manager)) (current-session (or session (default-session-manager-current-session session-manager)))) - (bt:with-lock-held ((default-session-manager-service-lock session-manager)) - (remhash (session-id current-session) (default-session-manager-sessions session-manager)) - (let ((cookie (make-instance 'claw-cookie - :name cookie-name - :expires (get-universal-time) - :path (format nil "~a/" *root-path*) - :domain nil - :value ""))) - (setf (connector-cookie-out connector cookie-name) cookie))))) + (when current-session + (bt:with-lock-held ((default-session-manager-service-lock session-manager)) + (remhash (session-id current-session) (default-session-manager-sessions session-manager)) + (let ((cookie (make-instance 'claw-cookie + :name cookie-name + :expires (get-universal-time) + :path (format nil "~a/" *root-path*) + :domain nil + :value ""))) + (setf (connector-cookie-out connector cookie-name) cookie)))))) (defmethod session-manager-session-value ((session-manager default-session-manager) symbol) (let ((session (default-session-manager-current-session session-manager))) From achiumenti at common-lisp.net Tue Oct 21 12:43:24 2008 From: achiumenti at common-lisp.net (Andrea Chiumenti) Date: Tue, 21 Oct 2008 12:43:24 +0000 Subject: [claw-cvs] r120 - trunk/main/claw-html/src Message-ID: Author: achiumenti Date: Tue Oct 21 12:43:23 2008 New Revision: 120 Log: several bugfixes and enhancements Modified: trunk/main/claw-html/src/packages.lisp trunk/main/claw-html/src/tags.lisp trunk/main/claw-html/src/validators.lisp Modified: trunk/main/claw-html/src/packages.lisp ============================================================================== --- trunk/main/claw-html/src/packages.lisp (original) +++ trunk/main/claw-html/src/packages.lisp Tue Oct 21 12:43:23 2008 @@ -180,6 +180,7 @@ #:generate-id #:metacomponent #:wcomponent + #:wcomponent-created #:wcomponent-informal-parameters #:wcomponent-allow-informal-parametersp #:wcomponent-template Modified: trunk/main/claw-html/src/tags.lisp ============================================================================== --- trunk/main/claw-html/src/tags.lisp (original) +++ trunk/main/claw-html/src/tags.lisp Tue Oct 21 12:43:23 2008 @@ -183,6 +183,9 @@ (defgeneric (setf slot-initialization) (value wcomponent slot-initarg) (:documentation "Sets a slot by its :INITARG. It's used just after instance creation")) +(defgeneric wcomponent-created (wcomponent) + (:documentation "Method called just before the make-component function exits. Do additional instance initialization here.")) + (defgeneric wcomponent-before-rewind (wcomponent page) (:documentation "Method called by the framework before the rewinding phase. It is intended to be eventually overridden in descendant classes. - WCOMPONENT is the tag instance @@ -1152,6 +1155,9 @@ :allow-informal-parameters t) (:documentation "Base class for creationg customized web components. Use this or one of its subclasses to make your own.")) +(defmethod wcomponent-created ((wcomponent wcomponent)) + nil) + (defun slot-initarg-p (initarg class-precedence-list) "Returns nil if a slot with that initarg isn't found into the list of classes passed" (loop for class in class-precedence-list @@ -1205,6 +1211,7 @@ (loop for (initarg value) on parameters by #'cddr do (setf (slot-initialization instance initarg) value)) (setf (htcomponent-body instance) content) + (wcomponent-created instance) instance)) (defun build-component (component-name &rest rest) Modified: trunk/main/claw-html/src/validators.lisp ============================================================================== --- trunk/main/claw-html/src/validators.lisp (original) +++ trunk/main/claw-html/src/validators.lisp Tue Oct 21 12:43:23 2008 @@ -197,9 +197,11 @@ ;; ------------------------------------------------------------------------------------ -(defclass exception-monitor (wcomponent) () +(defclass exception-monitor (wcomponent) + ((class :initarg :class + :reader class-name)) (:metaclass metacomponent) - (:default-initargs :json-render-on-validation-errors-p t) + (:default-initargs :json-render-on-validation-errors-p t :class "") (:documentation "If from submission contains exceptions. It displays exception messages")) (let ((class (find-class 'exception-monitor))) @@ -215,6 +217,7 @@ (let ((client-id (htcomponent-client-id exception-monitor)) (body (htcomponent-body exception-monitor))) (div> :static-id client-id + :class (format nil "exceptionMonitor ~@[ ~a~]" (class-name exception-monitor)) (wcomponent-informal-parameters exception-monitor) (when *validation-errors* (if body From achiumenti at common-lisp.net Tue Oct 21 12:58:29 2008 From: achiumenti at common-lisp.net (Andrea Chiumenti) Date: Tue, 21 Oct 2008 12:58:29 +0000 Subject: [claw-cvs] r122 - trunk/main/claw-html.dojo Message-ID: Author: achiumenti Date: Tue Oct 21 12:58:29 2008 New Revision: 122 Log: several bugfixes and enhancements Modified: trunk/main/claw-html.dojo/claw-html.dojo.asd Modified: trunk/main/claw-html.dojo/claw-html.dojo.asd ============================================================================== --- trunk/main/claw-html.dojo/claw-html.dojo.asd (original) +++ trunk/main/claw-html.dojo/claw-html.dojo.asd Tue Oct 21 12:58:29 2008 @@ -39,6 +39,7 @@ (:file "djwidget" :depends-on ("misc")) (:file "djcontent-pane" :depends-on ("misc")) (:file "djbody" :depends-on ("djcontent-pane")) + (:file "djdnd" :depends-on ("djwidget")) (:file "dijit" :depends-on ("djwidget")) (:file "djclaw" :depends-on ("djwidget")) (:file "djform" :depends-on ("djwidget")) @@ -51,4 +52,5 @@ (:file "djtree" :depends-on ("djwidget")) (:file "djlayout" :depends-on ("djwidget")) (:file "djtooltip" :depends-on ("djwidget")) - (:file "djtoolbar" :depends-on ("djwidget")))))) + (:file "djtoolbar" :depends-on ("djwidget")) + (:file "djxpassword" :depends-on ("djwidget")))))) From achiumenti at common-lisp.net Tue Oct 21 13:03:31 2008 From: achiumenti at common-lisp.net (Andrea Chiumenti) Date: Tue, 21 Oct 2008 13:03:31 +0000 Subject: [claw-cvs] r123 - trunk/main/claw-html.dojo/src Message-ID: Author: achiumenti Date: Tue Oct 21 13:03:31 2008 New Revision: 123 Log: several bugfixes and enhancements Added: trunk/main/claw-html.dojo/src/djdnd.lisp trunk/main/claw-html.dojo/src/djxpassword.lisp Modified: trunk/main/claw-html.dojo/src/djwidget.lisp trunk/main/claw-html.dojo/src/misc.lisp trunk/main/claw-html.dojo/src/packages.lisp Added: trunk/main/claw-html.dojo/src/djdnd.lisp ============================================================================== --- (empty file) +++ trunk/main/claw-html.dojo/src/djdnd.lisp Tue Oct 21 13:03:31 2008 @@ -0,0 +1,88 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- +;;; $Header: dojo/src/djdnd.lisp $ + +;;; Copyright (c) 2008, Andrea Chiumenti. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(in-package :dojo) + +(defclass djdnd-avatar (djwidget) + () + (:metaclass metacomponent) + (:default-initargs :dojo-type "claw.dnd.Avatar") + (:documentation "Teansform an element into a dnd avatar")) + +(defclass djdnd-container (djwidget) + () + (:metaclass metacomponent) + (:default-initargs :dojo-type "claw.dnd.Container") + (:documentation "Teansform an element into a dnd container")) + +(defclass djdnd-moveable (djwidget) + () + (:metaclass metacomponent) + (:default-initargs :dojo-type "claw.dnd.Moveable") + (:documentation "Teansform an element into a dnd moveable")) + +(defclass djdnd-mover (djwidget) + () + (:metaclass metacomponent) + (:default-initargs :dojo-type "claw.dnd.Mover") + (:documentation "Teansform an element into a dnd mover")) + +(defclass djdnd-source (djwidget) + () + (:metaclass metacomponent) + (:default-initargs :dojo-type "claw.dnd.Source") + (:documentation "Teansform an element into a dnd source container")) + +(defclass djdnd-timed-moveable (djwidget) + () + (:metaclass metacomponent) + (:default-initargs :dojo-type "claw.dnd.TimedMoveable") + (:documentation "Teansform an element into a dnd timed moveable")) + +(defclass djdnd-item (wcomponent) + ((tag-name :initarg :tag-name + :reader djwidget-tag-name + :documentation "The HTML tag element that will be rendered") + (css-class :initarg :class + :reader css-class + :documentation "The html CLASS attribute")) + (:default-initargs :tag-name "div" :class nil) + (:metaclass metacomponent)) + +(defmethod wcomponent-template ((obj djdnd-item)) + (let ((tag-name (djwidget-tag-name obj))) + (when tag-name + (let ((parameters (list :static-id (htcomponent-client-id obj) :class (format nil "dojoDndItem~@[ ~a~]" (css-class obj))))) + (build-tagf tag-name + 'tag + (not (null (find tag-name *empty-tags*))) + (list + parameters + (wcomponent-informal-parameters obj) + (htcomponent-body obj))))))) Modified: trunk/main/claw-html.dojo/src/djwidget.lisp ============================================================================== --- trunk/main/claw-html.dojo/src/djwidget.lisp (original) +++ trunk/main/claw-html.dojo/src/djwidget.lisp Tue Oct 21 13:03:31 2008 @@ -80,30 +80,3 @@ (wcomponent-informal-parameters obj) (htcomponent-body obj))))))) -(defclass djdnd-source (djwidget) - () - (:metaclass metacomponent) - (:default-initargs :dojo-type "dojo.dnd.Source") - (:documentation "Teansform an element into a dnd source container")) - -(defclass djdnd-item (wcomponent) - ((tag-name :initarg :tag-name - :reader djwidget-tag-name - :documentation "The HTML tag element that will be rendered") - (css-class :initarg :class - :reader css-class - :documentation "The html CLASS attribute")) - (:default-initargs :tag-name "div" :class nil) - (:metaclass metacomponent)) - -(defmethod wcomponent-template ((obj djdnd-item)) - (let ((tag-name (djwidget-tag-name obj))) - (when tag-name - (let ((parameters (list :static-id (htcomponent-client-id obj) :class (format nil "dojoDndItem~@[ ~a~]" (css-class obj))))) - (build-tagf tag-name - 'tag - (not (null (find tag-name *empty-tags*))) - (list - parameters - (wcomponent-informal-parameters obj) - (htcomponent-body obj))))))) \ No newline at end of file Added: trunk/main/claw-html.dojo/src/djxpassword.lisp ============================================================================== --- (empty file) +++ trunk/main/claw-html.dojo/src/djxpassword.lisp Tue Oct 21 13:03:31 2008 @@ -0,0 +1,87 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- +;;; $Header: dojo/src/djxpassword.lisp $ + +;;; Copyright (c) 2008, Andrea Chiumenti. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(in-package :dojo) + +(defclass djxpassword-validator (cinput djwidget) + ((required :initarg :required + :reader djxpassword-validator-required)) + (:documentation "CLAW implementation of dojox.form.PasswordValidator") + (:default-initargs :dojo-type "dojox.form.PasswordValidator" :required t) + (:metaclass metacomponent)) + +(defmethod wcomponent-after-rewind :after ((obj djxpassword-validator) (p page)) + (claw:log-message :info "PPPPPPPPPP> ~a ::: ~a" + (translated-value obj) + (multiple-value-list (claw-html::component-id-and-value obj))) + ) + +(defmethod wcomponent-template ((obj djxpassword-validator)) + (let ((required (djxpassword-validator-required obj))) + (div> :static-id (htcomponent-client-id obj) + :name (name-attr obj) + :dojo-type (djwidget-dojo-type obj) + :required (unless required + "false") + (wcomponent-informal-parameters obj) + (htcomponent-body obj)))) + +(defclass djxpassword-validator-input-mixin (wcomponent) + ((pw-type :initarg :pw-type + :reader djxpassword-validator-input-mixin-pw-type)) + (:documentation "CLAW implementation of dojox.form.PasswordValidator mixin password input box") + (:default-initargs :reserved-parameters (list :type :name :value :pw-type)) + (:metaclass metacomponent)) + +(defmethod wcomponent-template ((obj djxpassword-validator-input-mixin)) + (input> :static-id (htcomponent-client-id obj) + :type "password" + :pw-type (djxpassword-validator-input-mixin-pw-type obj) + (wcomponent-informal-parameters obj))) + + +(defclass djxpassword-old (djxpassword-validator-input-mixin) + () + (:documentation "CLAW implementation of dojox.form.PasswordValidator old password input box") + (:default-initargs :pw-type "old") + (:metaclass metacomponent)) + +(defclass djxpassword-new (djxpassword-validator-input-mixin) + () + (:documentation "CLAW implementation of dojox.form.PasswordValidator new password input box") + (:default-initargs :pw-type "new") + (:metaclass metacomponent)) + +(defclass djxpassword-verify (djxpassword-validator-input-mixin) + () + (:documentation "CLAW implementation of dojox.form.PasswordValidator verify password input box") + (:default-initargs :pw-type "verify") + (:metaclass metacomponent)) + + Modified: trunk/main/claw-html.dojo/src/misc.lisp ============================================================================== --- trunk/main/claw-html.dojo/src/misc.lisp (original) +++ trunk/main/claw-html.dojo/src/misc.lisp Tue Oct 21 13:03:31 2008 @@ -36,6 +36,7 @@ (substitute #\- #\_ (string-downcase (user-locale)))) (register-library-resource "dojotoolkit/" (make-pathname :directory (append (pathname-directory *dojo-misc-file*) '("dojotoolkit")))) +(register-library-resource "dojotoolkit/claw.js" (make-pathname :directory (append (pathname-directory *dojo-misc-file*) '("js")) :name "claw" :type "js")) (register-library-resource "dojotoolkit/claw/HardLink.js" (make-pathname :directory (append (pathname-directory *dojo-misc-file*) '("js")) :name "HardLink" :type "js")) (register-library-resource "dojotoolkit/claw/FloatingContent.js" (make-pathname :directory (append (pathname-directory *dojo-misc-file*) '("js")) :name "FloatingContent" :type "js")) (register-library-resource "dojotoolkit/claw/Rounded.js" (make-pathname :directory (append (pathname-directory *dojo-misc-file*) '("js")) :name "Rounded" :type "js")) @@ -44,3 +45,12 @@ (register-library-resource "dojotoolkit/claw/ActionLink.js" (make-pathname :directory (append (pathname-directory *dojo-misc-file*) '("js")) :name "ActionLink" :type "js")) (register-library-resource "dojotoolkit/claw/Dialog.js" (make-pathname :directory (append (pathname-directory *dojo-misc-file*) '("js")) :name "Dialog" :type "js")) (register-library-resource "dojotoolkit/claw/Button.js" (make-pathname :directory (append (pathname-directory *dojo-misc-file*) '("js")) :name "Button" :type "js")) + +(register-library-resource "dojotoolkit/claw/dnd/common.js" (make-pathname :directory (append (pathname-directory *dojo-misc-file*) '("js" "dnd")) :name "common" :type "js")) +(register-library-resource "dojotoolkit/claw/dnd/Avatar.js" (make-pathname :directory (append (pathname-directory *dojo-misc-file*) '("js" "dnd")) :name "Avatar" :type "js")) +(register-library-resource "dojotoolkit/claw/dnd/Container.js" (make-pathname :directory (append (pathname-directory *dojo-misc-file*) '("js" "dnd")) :name "Container" :type "js")) +(register-library-resource "dojotoolkit/claw/dnd/Moveable.js" (make-pathname :directory (append (pathname-directory *dojo-misc-file*) '("js" "dnd")) :name "Moveable" :type "js")) +(register-library-resource "dojotoolkit/claw/dnd/Mover.js" (make-pathname :directory (append (pathname-directory *dojo-misc-file*) '("js" "dnd")) :name "Mover" :type "js")) +(register-library-resource "dojotoolkit/claw/dnd/Selector.js" (make-pathname :directory (append (pathname-directory *dojo-misc-file*) '("js" "dnd")) :name "Selector" :type "js")) +(register-library-resource "dojotoolkit/claw/dnd/Source.js" (make-pathname :directory (append (pathname-directory *dojo-misc-file*) '("js" "dnd")) :name "Source" :type "js")) +(register-library-resource "dojotoolkit/claw/dnd/TimedMoveable.js" (make-pathname :directory (append (pathname-directory *dojo-misc-file*) '("js" "dnd")) :name "TimedMoveable" :type "js")) Modified: trunk/main/claw-html.dojo/src/packages.lisp ============================================================================== --- trunk/main/claw-html.dojo/src/packages.lisp (original) +++ trunk/main/claw-html.dojo/src/packages.lisp Tue Oct 21 13:03:31 2008 @@ -38,8 +38,18 @@ :djwidget-dojo-require :djwidget :djwidget> + #:djdnd-avatar + #:djdnd-avatar> + #:djdnd-container + #:djdnd-container> + #:djdnd-moveable + #:djdnd-moveable> + #:djdnd-mover + #:djdnd-mover> #:djdnd-source #:djdnd-source> + #:djdnd-timed-moveable + #:djdnd-timed-moveable> #:djdnd-item #:djdnd-item> :djwidget-formal-parameters @@ -186,4 +196,12 @@ :djhard-link :djhard-link> :djrounded - :djrounded>)) + :djrounded> + #:djxpassword-validator + #:djxpassword-validator> + #:djxpassword-old + #:djxpassword-old> + #:djxpassword-new + #:djxpassword-new> + #:djxpassword-verify + #:djxpassword-verify>)) From achiumenti at common-lisp.net Tue Oct 21 13:04:29 2008 From: achiumenti at common-lisp.net (Andrea Chiumenti) Date: Tue, 21 Oct 2008 13:04:29 +0000 Subject: [claw-cvs] r124 - trunk/main/claw-html.dojo/src/js Message-ID: Author: achiumenti Date: Tue Oct 21 13:04:29 2008 New Revision: 124 Log: several bugfixes and enhancements Modified: trunk/main/claw-html.dojo/src/js/ActionLink.js trunk/main/claw-html.dojo/src/js/Dialog.js trunk/main/claw-html.dojo/src/js/Form.js trunk/main/claw-html.dojo/src/js/HardLink.js trunk/main/claw-html.dojo/src/js/claw.js Modified: trunk/main/claw-html.dojo/src/js/ActionLink.js ============================================================================== --- trunk/main/claw-html.dojo/src/js/ActionLink.js (original) +++ trunk/main/claw-html.dojo/src/js/ActionLink.js Tue Oct 21 13:04:29 2008 @@ -53,8 +53,16 @@ var element = dojo.byId(item); if (element != null) { if (reply.components[item] != null) { - var list = dojo.query('[widgetId]', element); + var list = dojo.query('[dndId]', element); + dojo.forEach(list, function(dndEl){ + var dndObj = claw.dnd.byId(dojo.attr(dndEl, "dndId")); + if (dndObj) { + dndObj.destroy(); + } + }); + list = dojo.query('[widgetId]', element); dojo.forEach(list.map(dijit.byNode), function(widget){if (widget) widget.destroy(); }); + } element.innerHTML = reply.components[item]; dojo.parser.parse(element, true); Modified: trunk/main/claw-html.dojo/src/js/Dialog.js ============================================================================== --- trunk/main/claw-html.dojo/src/js/Dialog.js (original) +++ trunk/main/claw-html.dojo/src/js/Dialog.js Tue Oct 21 13:04:29 2008 @@ -59,4 +59,25 @@ } } ); + + claw.showMessage = function(/*String?*/dialogTitle, /*String*/message,/*String?*/closeLabel) { + var closeButton = new dijit.form.Button({label:closeLabel || 'Ok'}); + var buttonsContainer = document.createElement('div'); + dojo.attr(buttonsContainer, 'class', 'clawButtons'); + buttonsContainer.appendChild(closeButton.domNode); + var dialog = new dijit.Dialog({title: dialogTitle || 'Message', content: message}); + dialog.containerNode.appendChild(buttonsContainer); + dojo.connect(dialog, + 'onClose', + function(evt) { + dialog.destroy(); + }); + dojo.connect(closeButton, + 'onClick', + function(evt) { + dialog.destroy(); + }); + dialog.show(); + + }; } \ No newline at end of file Modified: trunk/main/claw-html.dojo/src/js/Form.js ============================================================================== --- trunk/main/claw-html.dojo/src/js/Form.js (original) +++ trunk/main/claw-html.dojo/src/js/Form.js Tue Oct 21 13:04:29 2008 @@ -52,7 +52,14 @@ var element = dojo.byId(item); if (element != null) { if (reply.components[item] != null) { - var list = dojo.query('[widgetId]', element); + var list = dojo.query('[dndId]', element); + dojo.forEach(list, function(dndEl){ + var dndObj = claw.dnd.byId(dojo.attr(dndEl, "dndId")); + if (dndObj) { + dndObj.destroy(); + } + }); + list = dojo.query('[widgetId]', element); dojo.forEach(list.map(dijit.byNode), function(widget){if (widget) widget.destroy(); }); } element.innerHTML = reply.components[item]; Modified: trunk/main/claw-html.dojo/src/js/HardLink.js ============================================================================== --- trunk/main/claw-html.dojo/src/js/HardLink.js (original) +++ trunk/main/claw-html.dojo/src/js/HardLink.js Tue Oct 21 13:04:29 2008 @@ -51,7 +51,14 @@ var widget = dijit.byId(this.refId); if (widget) { var domNode = widget.domNode; - var list = dojo.query('[widgetId]', domNode); + var list = dojo.query('[dndId]', domNode); + dojo.forEach(list, function(dndEl){ + var dndObj = claw.dnd.byId(dojo.attr(dndEl, "dndId")); + if (dndObj) { + dndObj.destroy(); + } + }); + list = dojo.query('[widgetId]', domNode); dojo.forEach(list.map(dijit.byNode), function(widget){if (widget) widget.destroy(); }); widget.destroy(); } Modified: trunk/main/claw-html.dojo/src/js/claw.js ============================================================================== --- trunk/main/claw-html.dojo/src/js/claw.js (original) +++ trunk/main/claw-html.dojo/src/js/claw.js Tue Oct 21 13:04:29 2008 @@ -1,4 +1,4 @@ -/** +y/** ;;; $Header: dojo/src/js/claw.js $ ;;; Copyright (c) 2008, Andrea Chiumenti. All rights reserved. @@ -28,32 +28,6 @@ ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. */ -//dojo.require('dijit.Tooltip'); +dojo.provide("claw"); -var claw = { - _updateParts: function (reply) { - for (var item in reply.components) { - var element = dojo.byId(item); - if ((element != null) && (reply.components[item] != null)) { - var list = dojo.query('[widgetId]', element); - dojo.forEach(list.map(dijit.byNode), function(widget){if (widget) widget.destroy(); }); - element.innerHTML = reply.components[item]; - dojo.parser.parse(element, true); - } - } - }, - _evalReplClassScripts: function (reply) { - dijit.byId('scripts-content-pane').setContent(reply.classInjections); - }, - _evalReplInstanceScripts: function (reply) { - dijit.byId('scripts-content-pane').setContent(reply.instanceInjections); - }, - updateAndEval: function (reply) { - console.debug("Plain object as string is: ", reply); - console.debug("Object as string is: ", dojo.toJson(reply, true)); - this._evalReplClassScripts(reply); - this._updateParts(reply); - this._evalReplInstanceScripts(reply); - - } -}; \ No newline at end of file +var claw = {}; \ No newline at end of file From achiumenti at common-lisp.net Tue Oct 21 13:05:45 2008 From: achiumenti at common-lisp.net (Andrea Chiumenti) Date: Tue, 21 Oct 2008 13:05:45 +0000 Subject: [claw-cvs] r125 - trunk/main/claw-html.dojo/src/js Message-ID: Author: achiumenti Date: Tue Oct 21 13:05:45 2008 New Revision: 125 Log: several bugfixes and enhancements Added: trunk/main/claw-html.dojo/src/js/Button.js Added: trunk/main/claw-html.dojo/src/js/Button.js ============================================================================== --- (empty file) +++ trunk/main/claw-html.dojo/src/js/Button.js Tue Oct 21 13:05:45 2008 @@ -0,0 +1,70 @@ +/** +;;; $Header: dojo/src/js/Button.js $ + +;;; Copyright (c) 2008, Andrea Chiumenti. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +*/ + +if(!dojo._hasResource["claw.Button"]){ +dojo.provide("claw.Button"); + +dojo.require("dijit.form.Button"); + +dojo.declare( + "claw.Button", + [dijit.form.Button], + { + formId: '', + _onButtonClick: function(/*Event*/ e){ + // summary: callback when the user mouse clicks the button portion + if(e.type!='click'){ + dojo.stopEvent(e); + } + if(this._onClick(e) === false){ // returning nothing is same as true + dojo.stopEvent(e); + return false; + } + + var form = dojo.byId(this.id).form; + if (!form && (this.formId != '')) { + form = dojo.byId(this.formId) + } + if(this.type=="submit" && form){ // see if a form widget needs to be signalled + var name = this.name; + if (!name) { + name = "submit"; + } + var djform = dijit.byId(form.id); + if (djform) { + var jsonContent = {}; + jsonContent[name] = this.value; + djform.jsonContent = dojo.mixin(djform.jsonContent, jsonContent); + djform.onSubmit(e); + } + } + } + }); +} \ No newline at end of file From achiumenti at common-lisp.net Tue Oct 21 13:06:42 2008 From: achiumenti at common-lisp.net (Andrea Chiumenti) Date: Tue, 21 Oct 2008 13:06:42 +0000 Subject: [claw-cvs] r126 - trunk/main/claw-html.dojo/src/js/dnd Message-ID: Author: achiumenti Date: Tue Oct 21 13:06:41 2008 New Revision: 126 Log: several bugfixes and enhancements Added: trunk/main/claw-html.dojo/src/js/dnd/ trunk/main/claw-html.dojo/src/js/dnd/Avatar.js trunk/main/claw-html.dojo/src/js/dnd/Container.js trunk/main/claw-html.dojo/src/js/dnd/Moveable.js trunk/main/claw-html.dojo/src/js/dnd/Mover.js trunk/main/claw-html.dojo/src/js/dnd/Source.js trunk/main/claw-html.dojo/src/js/dnd/TimedMoveable.js trunk/main/claw-html.dojo/src/js/dnd/common.js Added: trunk/main/claw-html.dojo/src/js/dnd/Avatar.js ============================================================================== --- (empty file) +++ trunk/main/claw-html.dojo/src/js/dnd/Avatar.js Tue Oct 21 13:06:41 2008 @@ -0,0 +1,37 @@ +/** +;;; $Header: dojo/src/js/dnd/Avatar.js $ + +;;; Copyright (c) 2008, Andrea Chiumenti. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +*/ +dojo.provide("claw.dnd.Avatar"); + +dojo.require("claw.dnd.common"); +dojo.require("dojo.dnd.Avatar"); + +dojo.declare("claw.dnd.Avatar",[dojo.dnd.Avatar,claw.dnd._DndMixin], { + +}); \ No newline at end of file Added: trunk/main/claw-html.dojo/src/js/dnd/Container.js ============================================================================== --- (empty file) +++ trunk/main/claw-html.dojo/src/js/dnd/Container.js Tue Oct 21 13:06:41 2008 @@ -0,0 +1,37 @@ +/** +;;; $Header: dojo/src/js/dnd/Container.js $ + +;;; Copyright (c) 2008, Andrea Chiumenti. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +*/ +dojo.provide("claw.dnd.Container"); + +dojo.require("claw.dnd.common"); +dojo.require("dojo.dnd.Container"); + +dojo.declare("claw.dnd.Container",[dojo.dnd.Container,claw.dnd._DndMixin], { + +}); \ No newline at end of file Added: trunk/main/claw-html.dojo/src/js/dnd/Moveable.js ============================================================================== --- (empty file) +++ trunk/main/claw-html.dojo/src/js/dnd/Moveable.js Tue Oct 21 13:06:41 2008 @@ -0,0 +1,37 @@ +/** +;;; $Header: dojo/src/js/dnd/Moveable.js $ + +;;; Copyright (c) 2008, Andrea Chiumenti. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +*/ +dojo.provide("claw.dnd.Selector"); + +dojo.require("claw.dnd.common"); +dojo.require("dojo.dnd.Selector"); + +dojo.declare("claw.dnd.Selector",[dojo.dnd.Selector,claw.dnd._DndMixin], { + +}); \ No newline at end of file Added: trunk/main/claw-html.dojo/src/js/dnd/Mover.js ============================================================================== --- (empty file) +++ trunk/main/claw-html.dojo/src/js/dnd/Mover.js Tue Oct 21 13:06:41 2008 @@ -0,0 +1,37 @@ +/** +;;; $Header: dojo/src/js/dnd/Mover.js $ + +;;; Copyright (c) 2008, Andrea Chiumenti. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +*/ +dojo.provide("claw.dnd.Mover"); + +dojo.require("claw.dnd.common"); +dojo.require("dojo.dnd.Mover"); + +dojo.declare("claw.dnd.Mover",[dojo.dnd.Mover,claw.dnd._DndMixin], { + +}); \ No newline at end of file Added: trunk/main/claw-html.dojo/src/js/dnd/Source.js ============================================================================== --- (empty file) +++ trunk/main/claw-html.dojo/src/js/dnd/Source.js Tue Oct 21 13:06:41 2008 @@ -0,0 +1,40 @@ +/** +;;; $Header: dojo/src/js/dnd/Source.js $ + +;;; Copyright (c) 2008, Andrea Chiumenti. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +*/ +dojo.provide("claw.dnd.Source"); + +dojo.require("claw.dnd.common"); +dojo.require("dojo.dnd.Source"); + +dojo.declare("claw.dnd.Source",[dojo.dnd.Source,claw.dnd._DndMixin], { + markupFactory: function(params, node){ + params._skipStartup = true; + return new claw.dnd.Source(node, params); + } +}); \ No newline at end of file Added: trunk/main/claw-html.dojo/src/js/dnd/TimedMoveable.js ============================================================================== --- (empty file) +++ trunk/main/claw-html.dojo/src/js/dnd/TimedMoveable.js Tue Oct 21 13:06:41 2008 @@ -0,0 +1,37 @@ +/** +;;; $Header: dojo/src/js/dnd/TimedMoveable.js $ + +;;; Copyright (c) 2008, Andrea Chiumenti. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +*/ +dojo.provide("claw.dnd.TimedMoveable"); + +dojo.require("claw.dnd.common"); +dojo.require("dojo.dnd.TimedMoveable"); + +dojo.declare("claw.dnd.TimedMoveable",[dojo.dnd.TimedMoveable,claw.dnd._DndMixin], { + +}); \ No newline at end of file Added: trunk/main/claw-html.dojo/src/js/dnd/common.js ============================================================================== --- (empty file) +++ trunk/main/claw-html.dojo/src/js/dnd/common.js Tue Oct 21 13:06:41 2008 @@ -0,0 +1,69 @@ +/** +;;; $Header: dojo/src/js/dnd/common.js $ + +;;; Copyright (c) 2008, Andrea Chiumenti. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +*/ +dojo.provide("claw.dnd.common"); + + +claw.dnd = {}; + +claw.dnd._map = {}; + + +claw.dnd._cache = {'clawDnd': 0}; + +claw.dnd.byId = function(id){ + // summary: returns the dojo.dnd instance bound to a HTML object element + return claw.dnd._map[id]; // assume it's a node +}; + + +dojo.declare("claw.dnd._DndMixin", null, { + id: "", + _putInCache: function (node) { + this.id = dojo.attr(node, "dndId"); + if(!this.id) { + this.id = dojo.attr(node, "id"); + if (!this.id) { + var index = claw.dnd._cache._clawDnd; + claw.dnd._cache._clawDnd = index++; + this.id = "clawDnd" + index; + } + dojo.attr(node, "dndId", this.id); + } + claw.dnd._map[this.id] = this; + }, + constructor: function (node, params) { + this._putInCache(this.node); + }, + destroy: function() { + // summary: warning. Like dojo.dnd.Container destroy method, but cleans up claw.dnd._map. Remember to eventually remove its node. + delete claw.dnd._map[this.id]; + dojo.dnd.Source.prototype.destroy.call(this); + } +}); From achiumenti at common-lisp.net Tue Oct 21 12:41:38 2008 From: achiumenti at common-lisp.net (Andrea Chiumenti) Date: Tue, 21 Oct 2008 12:41:38 +0000 Subject: [claw-cvs] r118 - trunk/logo Message-ID: Author: achiumenti Date: Tue Oct 21 12:41:37 2008 New Revision: 118 Log: several bugfixes and enhancements Modified: trunk/logo/claw.svg Modified: trunk/logo/claw.svg ============================================================================== --- trunk/logo/claw.svg (original) +++ trunk/logo/claw.svg Tue Oct 21 12:41:37 2008 @@ -2,23 +2,171 @@ + version="1.0" + inkscape:export-filename="/home/kiuma/common-lisp.net/claw/trunk/main/claw-demo/src/frontend/docroot/img/claw.png" + inkscape:export-xdpi="29" + inkscape:export-ydpi="29"> + id="defs4"> + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + inkscape:current-layer="layer1" + showgrid="false" + inkscape:window-width="1674" + inkscape:window-height="986" + inkscape:window-x="0" + inkscape:window-y="0" /> @@ -50,40 +199,8477 @@ inkscape:label="Livello 1" inkscape:groupmode="layer" id="layer1" - transform="translate(-1.5750449e-6,-599.66831)"> + transform="translate(-25.810558,-17.512569)"> + + + + + transform="matrix(0.6465745,0,0,0.596393,44.002223,56.396457)" + id="g8129" + inkscape:export-filename="/home/kiuma/common-lisp.net/claw/trunk/main/claw-demo/src/frontend/docroot/img/claw.png" + inkscape:export-xdpi="29" + inkscape:export-ydpi="29"> + sodipodi:nodetypes="csssssssssssssssssssssssssssssssssssssssssssssssssssssssssssssssssssssssssssssssssssssssssssssssssssssssssssssssssssssssssssssssssssssssssssc" + id="path14689" + d="M 86.542876,241.58288 C 85.074807,238.91705 84.825367,236.72111 88.061172,233.4853 C 89.810329,231.73615 93.37071,230.007 95.652652,229.43651 C 98.287976,228.77768 101.29902,226.82673 103.24413,224.88163 C 105.70554,222.42022 107.29746,220.83056 110.32951,219.31454 C 112.9191,218.01975 112.35391,214.88464 112.35391,212.22916 C 112.35391,209.47264 114.88064,206.66709 116.4027,204.63768 C 118.47244,201.87802 119.63906,200.41242 122.98198,199.57669 C 125.82129,198.86686 128.16878,197.33141 130.57346,195.5279 C 133.3104,193.4752 135.558,191.40992 138.16494,189.45472 C 140.85043,187.4406 143.06168,186.7533 145.75642,185.40593 C 148.77368,183.8973 150.82829,181.85236 153.3479,179.33274 C 155.4298,177.25084 156.64931,174.24823 157.90279,171.74126 C 159.21888,169.10909 160.71432,166.39924 162.96378,164.14978 C 164.85183,162.26173 165.9128,158.93299 166.50647,156.5583 C 167.18138,153.85866 168.37607,151.61037 169.03696,148.96682 C 169.68848,146.36073 170.92278,143.95405 171.56746,141.37534 C 172.25961,138.60672 172.28781,136.66527 171.56746,133.78386 C 170.94456,131.29227 170.55526,128.87159 170.55526,126.19238 C 170.55526,123.66189 170.55526,121.13139 170.55526,118.6009 C 170.55526,115.94074 170.9668,113.41205 171.56746,111.00942 C 172.20551,108.4572 172.57965,105.53281 172.57965,102.91184 C 172.57965,100.33061 173.24233,97.971071 172.57965,95.320362 C 171.77389,92.097321 171.49841,90.121293 170.04916,87.222783 C 169.06322,85.250903 169.54306,81.979763 169.54306,79.631302 C 169.54306,77.100809 169.54306,74.570315 169.54306,72.039822 C 169.54306,68.991789 168.68876,67.104312 168.02476,64.448342 C 167.22384,61.244663 167.54163,59.586676 165.49427,56.856861 C 163.98671,54.84678 159.97786,54.870474 157.90279,53.31417 C 155.59706,51.584872 157.40888,47.698344 157.90279,45.72269 C 158.3556,43.911442 163.33146,44.710493 164.98817,44.710493 C 167.22046,44.710493 170.39626,46.695138 172.57965,47.240986 C 175.10524,47.872384 177.38252,48.253184 180.17113,48.253184 C 182.54557,48.253184 184.97052,49.265381 187.76261,49.265381 C 190.38859,49.265381 192.77047,49.911287 195.35409,49.265381 C 197.96556,48.612514 200.35315,48.395191 202.94557,47.747085 C 206.24506,46.922213 209.35402,45.006251 212.56145,44.204394 C 215.28179,43.524308 217.46343,41.840178 220.15293,41.167802 C 222.62045,40.550921 225.12316,40.661703 227.74441,40.661703 C 230.2749,40.661703 232.8054,40.661703 235.33589,40.661703 C 238.80659,40.661703 240.1268,39.025396 242.92737,37.625111 C 245.12494,36.526327 247.85446,36.612914 250.51885,36.612914 C 253.37314,36.612914 256.23985,39.741853 258.61643,41.167802 C 261.18012,42.706019 263.99276,45.465776 264.68961,48.253184 C 265.31479,50.753887 269.77916,53.32845 271.775,54.326368 C 274.22363,55.550686 277.4196,57.946575 279.36648,59.893453 C 281.11308,61.640062 284.75282,61.366565 286.95796,61.917848 C 289.93925,62.663171 292.44776,61.469711 294.54944,59.893453 C 297.30355,57.827866 298.60597,57.869059 302.14092,57.869059 C 304.87023,57.869059 306.94497,57.869059 309.7324,57.869059 C 312.00331,57.869059 314.7537,58.375157 317.32388,58.375157 C 320.39111,58.375157 322.20365,59.215527 324.91536,59.893453 C 327.11098,60.44236 330.60926,62.171485 331.49464,63.942243 C 332.99441,66.941775 330.26872,69.723047 328.45805,71.533723 C 326.11415,73.877618 323.3716,75.101874 320.86657,77.606907 C 318.48648,79.986998 315.88103,81.725633 313.27509,83.680092 C 310.36289,85.864241 309.09352,86.741706 308.2141,90.259375 C 307.54396,92.939934 306.6958,94.798067 306.6958,97.850855 C 306.6958,100.15624 306.1212,103.55495 305.17751,105.44234 C 304.29227,107.21282 304.67141,110.94687 304.67141,113.03382 C 304.67141,115.35233 303.65921,117.92866 303.65921,120.6253 C 303.65921,123.35305 304.67141,125.30483 304.67141,128.21678 C 304.67141,130.49483 305.13427,133.61091 305.68361,135.80826 C 306.33085,138.39721 306.57492,140.8918 307.2019,143.39974 C 307.95906,146.42838 310.11644,148.35653 310.74459,151.49732 C 311.35376,154.54315 311.97226,156.48314 313.27509,159.0888 C 314.92345,162.38553 315.67036,165.38122 318.84217,166.17417 C 321.67696,166.88287 327.54589,174.37769 326.93975,176.80225 C 326.06978,180.28215 330.74218,181.11077 333.01294,183.38153 C 335.67855,186.04715 337.09672,188.0064 338.58002,190.97301 C 340.09027,193.99351 343.10635,195.76667 345.6654,197.0462 C 348.01051,198.21875 350.85166,198.37408 353.25688,199.57669 C 356.04442,200.97046 358.71906,202.30778 361.35446,203.62548 C 364.14301,205.01976 366.4364,206.29821 368.94594,208.18037 C 371.87502,210.37718 372.40688,211.95145 374.51303,214.75965 C 376.70118,217.67719 378.08395,217.29015 381.59841,217.29015 C 384.49554,217.29015 386.94779,218.64516 389.18989,220.32674 C 391.39174,221.97813 394.44958,222.62668 396.78137,224.37553 C 399.41345,226.34958 401.8098,228.02033 404.37285,229.94261 C 407.16313,232.03532 408.07005,235.04092 409.93994,237.53409 C 411.96718,240.23709 413.61223,242.72468 416.01312,245.12557 C 417.20045,246.3129 416.51922,250.95031 416.51922,252.71705 C 416.51922,255.40874 411.17944,255.24755 409.43384,255.24755 C 407.11195,255.24755 404.35476,254.74145 401.84236,254.74145 C 399.45038,254.74145 396.89544,254.23535 394.25088,254.23535 C 391.41016,254.23535 391.38424,254.06539 387.67159,257.77804 C 385.73906,259.71057 382.45912,261.14343 380.08011,262.33293 C 377.22934,263.75831 375.48603,266.42091 373.50083,268.40611 C 371.07177,270.83518 368.78177,272.09938 367.93375,275.49149 C 367.27553,278.12436 365.90935,280.0039 365.90935,283.08297 C 365.90935,285.73388 364.00275,288.17889 363.37886,290.67445 C 362.63989,293.63031 361.35446,294.9143 361.35446,298.26594 C 361.35446,301.85154 362.85144,303.3056 365.40325,305.85742 C 366.69205,307.14622 368.50257,312.01423 369.95814,313.95499 C 372.15821,316.88842 372.30132,318.0794 372.99473,321.54647 C 373.9604,326.37482 367.74906,323.38619 366.41545,322.05257 C 364.54125,320.17837 361.13362,319.15861 358.82397,318.00378 C 355.8597,316.52165 354.14232,313.7334 351.73859,311.9306 C 350.79011,311.21924 345.39803,311.4245 344.14711,311.4245 C 342.25066,311.4245 338.00687,305.93365 336.55563,304.84522 C 334.55524,303.34493 331.15597,303.41064 328.96415,302.31472 C 326.16123,300.91327 323.7061,300.59937 321.37267,298.26594 C 319.01082,295.90409 316.41812,295.02951 313.78119,293.71105 C 311.63972,292.64031 307.9301,294.28815 306.18971,294.72324 C 302.70946,295.59331 302.14092,292.7633 302.14092,289.66226 C 302.14092,287.01881 299.39111,283.87586 297.58603,282.07078 C 295.79011,280.27486 293.62441,276.67803 292.52504,274.4793 C 291.11363,271.65648 287.66779,269.57111 285.43966,267.90001 C 283.38223,266.35694 280.21064,264.94794 277.84818,264.35732 C 275.94552,263.88166 272.16122,265.39949 270.2567,265.87562 C 268.04977,266.42735 264.95352,265.87562 262.66522,265.87562 C 259.57352,265.87562 257.26536,268.74499 255.07374,270.93661 C 253.11122,272.89913 251.83945,276.89909 250.51885,279.54028 C 249.05331,282.47136 247.8946,285.06368 245.96396,287.63786 C 243.87555,290.42241 242.34858,292.33814 240.90298,295.22934 C 239.24445,298.54639 238.25692,299.43355 234.82979,300.29033 C 233.10541,300.72143 228.59368,296.75197 227.23831,295.73544 C 224.25065,293.4947 223.77884,291.96632 221.67123,289.15616 C 219.81828,286.68556 218.90297,283.94685 217.11634,281.56468 C 215.55848,279.48754 216.05899,276.17819 216.61024,273.9732 C 217.75555,269.39194 215.96352,270.21261 213.06755,270.93661 C 210.36353,271.61261 208.4788,272.4549 205.47607,272.4549 C 202.85683,272.4549 200.34081,273.86524 197.88459,274.4793 C 195.20964,275.14803 192.79384,275.87851 190.29311,276.50369 C 187.72342,277.14611 185.31775,277.87405 182.70163,278.52809 C 180.04499,279.19225 177.06188,282.14344 175.11015,284.09517 C 172.64576,286.55956 171.43768,287.46138 168.02476,288.14396 C 165.22126,288.70466 163.52284,289.66226 160.43328,289.66226 C 157.90545,289.66226 154.90019,291.66966 152.8418,292.69885 C 150.20016,294.01967 147.50524,295.56255 145.25032,297.25374 C 143.46778,298.59064 139.75869,298.73431 137.65884,299.78423 C 135.51586,300.85572 132.4622,300.82356 130.06736,301.30253 C 127.24715,301.86657 125.54466,302.82082 122.47588,302.82082 C 120.47189,302.82082 116.36665,298.73598 114.8844,297.25374 C 112.6307,295.00004 109.7235,293.10503 107.29292,290.67445 C 105.73063,289.11216 105.17813,284.14926 104.76243,282.07078 C 104.14792,278.99823 102.62462,276.27687 101.21974,273.4671 C 99.606409,270.24044 98.63856,267.29255 97.170948,264.35732 C 95.756246,261.52792 93.444662,259.43524 92.109961,256.76584 C 90.940214,254.42635 90.768081,251.55159 89.579468,249.17436 C 87.356471,244.72837 85.600276,242.76113 86.542876,241.58288 z" + style="fill:#268942;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:1px;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1" /> + sodipodi:nodetypes="cssssssssssssssssssssssssssssssssssssssc" + id="path12495" + d="M 401.22455,252.91066 C 401.22455,255.55123 406.44277,254.58619 408.30993,256.45336 C 410.13655,258.27997 413.73601,258.91334 415.90142,259.99605 C 418.51847,261.30457 420.90836,262.75257 423.4929,264.04484 C 426.38735,265.49206 428.35543,268.24745 431.08438,269.61192 C 433.71894,270.92921 447.08358,285.22037 449.39431,287.5311 C 451.77253,289.90931 459.46599,300.53856 460.74273,303.09204 C 461.97124,305.54905 470.95342,322.15549 471.67118,325.02653 C 472.29529,327.52298 474.60552,337.73287 475.75983,340.0415 C 476.8824,342.28664 477.73572,351.98966 477.95648,354.09053 C 478.19247,356.33642 477.69414,366.18577 477.44825,368.72753 C 477.19627,371.33231 476.34059,373.34107 475.7221,375.81504 C 475.0437,378.52863 473.45865,380.13835 472.22354,382.60857 C 470.87485,385.30595 472.04517,378.17494 472.30753,377.12549 C 472.95445,374.53781 472.52212,372.70057 472.05342,370.58394 C 471.59466,368.51222 470.8836,366.47706 469.60904,365.42831 C 467.66539,363.82899 466.96195,364.06788 465.60225,362.45653 C 463.90773,360.4484 460.54375,355.72178 457.84491,353.69765 C 455.37351,351.8441 454.75392,349.42919 452.3533,347.62872 C 450.64667,346.34875 449.90182,344.03138 447.78563,343.50233 C 445.00985,342.80838 442.96851,341.15933 440.19415,340.46574 C 437.75305,339.85546 435.11493,338.56331 432.60267,337.93524 C 430.63388,337.44305 426.95572,333.84652 425.01119,332.87426 C 422.44218,331.58975 419.86773,331.06168 417.41971,329.83767 C 414.77664,328.51613 414.93362,327.83109 409.57625,327.13492 C 407.05242,326.80696 404.75527,326.39538 402.32074,325.78675 C 399.65826,325.12113 396.85911,325.28229 394.13917,324.6023 C 391.50905,323.94477 388.28427,322.93796 385.87573,321.73369 C 383.43328,320.51247 381.30804,319.37331 378.95621,318.1974 C 376.41207,316.92532 373.83256,316.39472 371.36473,315.1608 C 368.53682,313.74685 366.13985,312.07438 364.27935,309.59372 C 362.50618,307.22949 361.01578,304.58487 359.72446,302.00224 C 358.92693,300.40718 359.72446,296.24108 359.72446,294.41076 C 359.72446,291.90401 360.73666,289.31642 360.73666,286.81928 C 360.73666,284.352 363.25588,281.27473 364.27935,279.2278 C 365.69708,276.39234 366.39051,274.21982 368.32814,271.63632 C 370.43483,268.82739 373.04425,266.92021 375.41352,264.55093 C 378.13195,261.83251 378.90632,260.89419 382.4989,259.99605 C 385.31382,259.29232 387.53168,255.70831 390.09038,254.42896 C 392.88561,253.03135 400.09135,253.81723 401.22455,252.91066 z" + style="fill:#ecf00b;fill-opacity:1;fill-rule:evenodd;stroke:none;stroke-width:1px;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1" /> + sodipodi:nodetypes="cssssssssssssssssssssssssssssc" + id="path12497" + d="M 240.79127,271.63632 C 241.74308,270.76735 246.15134,263.46396 249.90104,262.52654 C 252.29964,261.92689 258.2584,258.03324 260.52912,257.46556 C 263.32542,256.76648 270.42317,257.46555 273.68768,257.46555 C 276.83821,257.46555 283.35854,259.88327 285.83405,260.50214 C 288.75051,261.23126 291.26925,264.41905 293.42553,266.57533 C 295.29798,268.44778 298.87401,274.19845 299.49872,276.6973 C 300.23504,279.64259 301.49142,281.12546 302.5353,288.33757 C 302.93519,291.10041 303.96535,299.30589 303.96535,301.83638 C 303.96535,304.76929 303.91261,305.90973 304.55331,312.2082 C 304.81373,314.76827 303.43426,317.23832 304.05361,319.71569 C 304.60534,321.92262 304.05361,325.01887 304.05361,327.30717 C 304.05361,329.69915 304.5597,332.25409 304.5597,334.89865 C 304.5597,337.42915 303.52675,341.01332 303.0478,343.49807 C 302.54383,346.11256 299.54712,370.73486 298.48652,372.85605 C 297.35711,375.11487 294.64357,385.43922 293.42766,387.87102 C 292.17845,390.36944 288.58701,400.90095 286.84625,403.22197 C 285.07656,405.58156 285.52213,408.38732 283.63954,410.89745 C 281.43737,413.83367 281.83956,416.64716 278.74867,415.87444 C 275.96641,415.17888 276.72779,410.31087 274.69988,408.28296 C 272.91654,406.49962 271.7288,402.84689 270.65109,400.69148 C 269.32197,398.03323 267.89917,395.69373 266.6023,393.1 C 265.18402,390.26344 263.80831,388.5033 263.05961,385.50852 C 262.36095,382.71389 257.31151,373.00012 255.97423,370.32556 C 254.94518,368.26745 251.08927,358.3772 250.40714,355.6487 C 249.79481,353.19934 242.81567,334.72913 242.81567,332.36816 C 242.81567,329.89586 240.29421,319.59692 239.27297,316.6791 C 235.73028,306.55713 236.74248,298.77301 236.74248,295.92905 C 236.74248,293.37911 235.80766,289.38461 236.23638,286.81928 C 237.24858,280.76257 235.2073,278.29999 240.79127,271.63632 z" + style="fill:#ecf00b;fill-opacity:1;fill-rule:evenodd;stroke:none;stroke-width:1px;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1" /> + sodipodi:nodetypes="csssssssssssssssssssssssssssssssssssssssssc" + id="path12509" + d="M 34.809096,368.30117 C 33.405986,365.49494 32.142106,363.22688 30.254216,360.70969 C 28.587966,358.48802 28.484048,355.92697 27.811548,353.23699 C 27.191858,350.7582 26.304676,347.94815 25.699326,345.52672 C 25.060126,342.96993 24.687126,340.859 24.687126,337.93524 C 24.687126,334.9552 23.168826,333.38308 23.168826,330.34376 C 23.168826,327.6594 23.568896,325.2008 24.181026,322.75228 C 24.856586,320.05004 25.532846,317.51816 26.711516,315.1608 C 27.843446,312.89695 27.574246,309.89266 28.735916,307.56932 C 30.095476,304.8502 29.860986,303.04631 31.627796,300.69056 C 33.461386,298.24577 34.573112,294.89465 36.239564,292.14879 C 37.705581,289.73319 40.001771,286.14768 41.212711,283.7258 C 42.681251,280.78873 45.166567,278.81663 47.611307,276.37189 C 50.113727,273.86947 52.004696,273.17812 53.534756,270.11802 C 54.088256,269.01102 60.280868,265.78361 61.720168,264.34431 C 64.212698,261.85177 65.302488,260.41065 67.648638,258.06451 C 69.583018,256.13012 73.870913,254.25394 76.071623,252.05323 C 78.381603,249.74324 80.470466,250.32393 83.394576,248.86188 C 85.735066,247.69163 87.92851,244.60125 90.51091,243.95565 C 93.27905,243.26362 96.420618,242.23166 99.171468,241.54395 C 101.94185,240.85135 104.07859,240.62584 106.88174,240.65053 C 109.09961,240.67007 111.62892,242.13827 113.87929,242.70086 C 116.59632,243.38012 119.07742,244.50527 121.26415,246.30043 C 123.55278,248.17924 126.48973,251.54589 127.42516,253.41676 C 128.60579,255.77801 128.83693,258.55773 129.44956,261.00824 C 130.04029,263.37118 131.36168,266.12626 131.98005,268.59972 C 132.83969,272.03827 132.69583,273.45551 132.24356,276.30999 C 131.77457,279.26993 131.24298,280.99047 129.23791,283.66389 C 128.12052,285.15375 127.34204,289.51602 126.41297,291.37416 C 124.7595,294.6811 122.01237,295.09276 119.32758,296.43515 C 117.20966,297.49411 118.21149,298.55833 116.1312,299.70931 C 113.19364,301.3346 109.74441,302.70485 107.11428,303.96472 C 104.55851,305.18897 100.41642,307.18191 97.978573,308.40083 C 95.009763,309.88524 83.885375,315.6836 82.082895,317.03546 C 80.473775,318.2423 77.877142,319.89246 75.916852,320.8726 C 73.238742,322.21166 70.951542,323.87684 68.325372,325.18992 C 65.384002,326.66061 62.330819,328.17883 59.990219,330.51943 C 57.370189,333.13946 54.354406,333.64441 53.534756,336.92305 C 52.843706,339.68721 51.709936,342.09097 50.498156,344.51453 C 49.167386,347.17608 48.214546,349.58786 46.955466,352.10601 C 45.669406,354.67813 43.588422,355.36938 42.374652,357.79691 C 41.098382,360.34946 40.730173,366.0562 40.081735,368.71441 C 39.742252,370.10608 37.907091,375.3096 37.938549,374.85452" + style="fill:#ecf00b;fill-opacity:1;fill-rule:evenodd;stroke:none;stroke-width:1px;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1" /> + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + id="path12507" + d="M 126.52467,354.94899 C 126.69337,354.78029 126.18727,355.28639 126.52467,354.94899 z" + style="fill:none;fill-rule:evenodd;stroke:#000000;stroke-width:1px;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1" /> From achiumenti at common-lisp.net Tue Oct 21 12:45:47 2008 From: achiumenti at common-lisp.net (Andrea Chiumenti) Date: Tue, 21 Oct 2008 12:45:47 +0000 Subject: [claw-cvs] r121 - in trunk/main/claw-demo: . src src/backend src/frontend src/frontend/components src/frontend/docroot/css Message-ID: Author: achiumenti Date: Tue Oct 21 12:45:47 2008 New Revision: 121 Log: several bugfixes and enhancements Added: trunk/main/claw-demo/src/frontend/components/translator-stringlist.lisp trunk/main/claw-demo/src/main.lisp trunk/main/claw-demo/src/packages.lisp Modified: trunk/main/claw-demo/claw-demo.asd 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 trunk/main/claw-demo/src/frontend/components/djconfirmation-submit.lisp trunk/main/claw-demo/src/frontend/components/edit-customer.lisp trunk/main/claw-demo/src/frontend/components/edit-user.lisp trunk/main/claw-demo/src/frontend/components/site-template.lisp trunk/main/claw-demo/src/frontend/customers.lisp trunk/main/claw-demo/src/frontend/docroot/css/style.css trunk/main/claw-demo/src/frontend/login.lisp trunk/main/claw-demo/src/frontend/main.lisp trunk/main/claw-demo/src/frontend/packages.lisp trunk/main/claw-demo/src/frontend/users.lisp Modified: trunk/main/claw-demo/claw-demo.asd ============================================================================== --- trunk/main/claw-demo/claw-demo.asd (original) +++ trunk/main/claw-demo/claw-demo.asd Tue Oct 21 12:45:47 2008 @@ -50,7 +50,7 @@ :name "claw-demo-frontend" :author "Andrea Chiumenti" :description "Demo application for claw, frontend part." - :depends-on (:local-time :claw :hunchentoot-connector :claw-html :claw-html.dojo :claw-demo-backend) + :depends-on (:local-time :claw :hunchentoot-connector :claw-html :claw-html.dojo :claw-demo-backend :split-sequence) :components ((:module src :components ((:module frontend :components ((:file "packages") @@ -75,8 +75,12 @@ (:file "translator-threestate" :pathname #.(make-pathname :directory '(:relative "components") :name "translator-threestate" :type "lisp") :depends-on ("packages")) + (:file "translator-stringlist" + :pathname #.(make-pathname :directory '(:relative "components") :name "translator-stringlist" :type "lisp") + :depends-on ("packages")) (:file "auth" :depends-on ("packages")) - (:file "commons" :depends-on ("packages" "site-template" "pager" "djconfirmation-submit" "redirect" "edit-customer" "edit-user" "translator-threestate")) + (:file "commons" :depends-on ("packages" "site-template" "pager" "djconfirmation-submit" "redirect" "edit-customer" + "edit-user" "translator-threestate" "translator-stringlist")) (:file "main" :depends-on ("packages" "auth")) (:file "index" :depends-on ("commons" "main")) (:file "logout" :depends-on ("commons" "main")) @@ -93,4 +97,7 @@ :perform (test-op :after (op c) (describe (funcall (find-symbol "RUN-TESTS" "LIFT") :suite (find-symbol "CLAW-DEMO-BACKEND-TESTSUITE" "CLAW-DEMO-BACKEND")))) - :depends-on (:clsql :clsql-postgresql :local-time :claw :closer-mop :claw-demo-backend :claw-demo-frontend)) + :depends-on (:clsql :clsql-postgresql :local-time :claw :closer-mop :claw-demo-backend :claw-demo-frontend) + :components ((:module src + :components ((:file "packages") + (:file "main" :depends-on ("packages")))))) 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 Tue Oct 21 12:45:47 2008 @@ -85,18 +85,15 @@ (defmethod delete-instance-records :before ((instance base-table)) (check-instance-version instance :database *claw-demo-db*)) - - (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 (= 0 (table-id instance)))) - (incf (table-version instance)) - (unless (typep instance 'base-table-121) - (let ((sequence-name (format nil - "~a_id_seq" - (string-downcase (symbol-name (view-table (class-of instance))))))) - (setf (table-id instance) (sequence-next sequence-name :database database)))))) + (if (= (table-id instance) 0) + (let ((sequence-name (format nil + "~a_id_seq" + (string-downcase (symbol-name (view-table (class-of instance))))))) + (setf (table-id instance) (sequence-next sequence-name :database database))) + (incf (table-version instance)))) (defmethod update-record-from-slot :before ((instance base-table) slot &key (database *claw-demo-db*)) (declare (ignore slot database)) @@ -119,25 +116,15 @@ (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 (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 - :user-id id - :role-id (table-id role)) :database database)))))) + (let ((id (table-id instance)) + (role-list (user-roles instance))) + (delete-records :from (symbol-name (view-table (find-class 'user-role))) + :where (sql-operation '= (slot-column-name 'user-role 'user-id) id) + :database database) + (dolist (role role-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*)) @@ -391,4 +378,4 @@ :field-names field-names :database database))))))))) -(export '(sql-join sql-left-join sql-right-join sql-outer-join sql-inner-join sql-upper)) \ No newline at end of file +(export '(sql-join sql-left-join sql-right-join sql-outer-join sql-inner-join sql-upper)) 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 Tue Oct 21 12:45:47 2008 @@ -107,5 +107,7 @@ #:find-vo #:count-vo #:find-user-by-name + #:find-roles-by-names + #:find-roles-by-ids #: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 Tue Oct 21 12:45:47 2008 @@ -108,12 +108,13 @@ (find-by-id symbol-class id))) (defun find-user-by-name (name) - (let ((where (sql-operation '= (slot-column-name 'user 'username) name))) - (first (select 'user - :where where - :flatp t - :refresh t - :database *claw-demo-db*)))) + (let* ((where (sql-operation '= (slot-column-name 'user 'username) name)) + (user (first (select 'user + :where where + :flatp t + :refresh t + :database *claw-demo-db*)))) + user)) (defun find-customers (&key (offset 0) (limit *select-limit*) name1 name2 email vat phone sorting) (let ((where (remove-if #'null (list @@ -161,11 +162,11 @@ (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))) + :from (sql-left-join (sql-left-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) @@ -175,8 +176,19 @@ (first where)) :order-by sorting))) -#| -(defun oo () - (list [slot-value 'role 'id])) -|# + +(defun find-roles-by-names (&key (offset 0) (limit *select-limit*) names) + (if (null names) + (values nil 0) + (find-vo 'role :offset offset + :limit limit + :where (sql-operation 'in (slot-value 'role 'name) names)))) + +(defun find-roles-by-ids (&key (offset 0) (limit *select-limit*) ids) + (if (null ids) + (values nil 0) + (find-vo 'role :offset offset + :limit limit + :where (sql-operation 'in 'id ids)))) + (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 Tue Oct 21 12:45:47 2008 @@ -72,12 +72,8 @@ (and (equal (type-of o1) (type-of o2)) (= (table-id o1) (table-id o2)))) -(def-view-class base-table-121 (base-table) - ((id :db-kind :key - :accessor table-id - :initarg :id - :type integer - :db-constraints :not-null))) +(def-view-class base-table-121 () + ()) (def-view-class user-role () ((user-id :db-kind :key @@ -142,7 +138,7 @@ :foreign-key user-id :target-slot role :set t))) - (:default-initargs :firstname nil :surname nil :username nil :email nil :password nil :active t) + (:default-initargs :firstname nil :surname nil :username nil :email nil :password nil :active t ) (:base-table users)) (defmethod user-roles ((user user)) (loop for role-users-roles in (slot-value user 'roles) Modified: trunk/main/claw-demo/src/frontend/components/djconfirmation-submit.lisp ============================================================================== --- trunk/main/claw-demo/src/frontend/components/djconfirmation-submit.lisp (original) +++ trunk/main/claw-demo/src/frontend/components/djconfirmation-submit.lisp Tue Oct 21 12:45:47 2008 @@ -46,11 +46,19 @@ (defmethod wcomponent-template ((obj djconfirmation-submit)) (let* ((dialog-id (generate-id "confirmationDiaolg")) (yes-id (generate-id "yes")) - (value (djconfirmation-submit-value obj))) + (value (djconfirmation-submit-value obj)) + (informal-parameters (wcomponent-informal-parameters obj)) + (on-click (or (getf (wcomponent-informal-parameters obj) :on-click) + (getf (wcomponent-informal-parameters obj) :onclick)))) + (remf informal-parameters :on-click) + (remf informal-parameters :onclick) (div> :class "dijit dijitReset dijitLeft dijitInline" (djbutton> :static-id (htcomponent-client-id obj) - :on-click (ps:ps* `(.show (dijit.by-id ,dialog-id))) - (wcomponent-informal-parameters obj) + informal-parameters + (script> :type "dojo/connect" :event "onClick" :args "evt" + (format nil "if ((function (evt) {~a}).call(this, evt) !== false) {" on-click) + (ps:ps* `(.show (dijit.by-id ,dialog-id))) + "}") (or (htcomponent-body obj) value)) (djdialog> :static-id dialog-id :title "Confirm" Modified: trunk/main/claw-demo/src/frontend/components/edit-customer.lisp ============================================================================== --- trunk/main/claw-demo/src/frontend/components/edit-customer.lisp (original) +++ trunk/main/claw-demo/src/frontend/components/edit-customer.lisp Tue Oct 21 12:45:47 2008 @@ -140,61 +140,73 @@ (djvalidation-text-box> :visit-object visit-object :required "true" :label "Name 1" + :size 150 :accessor 'customer-name1)) (div> :class "label name2" (span> "Name 2") (djvalidation-text-box> :visit-object visit-object :label "Name 2" + :size 80 :accessor 'customer-name2)) (div> :class "label email" (span> "Email") (djvalidation-text-box> :visit-object visit-object :label "Email" + :size 200 :accessor 'customer-email)) (div> :class "label pone1" (span> "Phone 1") (djvalidation-text-box> :visit-object visit-object :label "Phone 1" + :size 25 :accessor 'customer-phone1)) (div> :class "label pone2" (span> "Phone 2") (djvalidation-text-box> :visit-object visit-object :label "Phone 2" + :size 25 :accessor 'customer-phone2)) (div> :class "label pone3" (span> "Phone 3") (djvalidation-text-box> :visit-object visit-object :label "Phone 3" + :size 25 :accessor 'customer-phone3)) (div> :class "label fax" (span> "Fax") (djvalidation-text-box> :visit-object visit-object :label "Fax" + :size 25 :accessor 'customer-fax)) (div> :class "label vat" (span> "VAT") (djvalidation-text-box> :visit-object visit-object :label "VAT" + :size 50 :accessor 'customer-vat)) (div> :class "label code1" (span> "Code 1") (djvalidation-text-box> :visit-object visit-object :label "Code 1" + :size 50 :accessor 'customer-code1)) (div> :class "label code2" (span> "Code 2") (djvalidation-text-box> :visit-object visit-object :label "Code 2" + :size 50 :accessor 'customer-code2)) (div> :class "label code3" (span> "Code 3") (djvalidation-text-box> :visit-object visit-object :label "Code 3" + :size 50 :accessor 'customer-code3)) (div> :class "label code4" (span> "Code 4") (djvalidation-text-box> :visit-object visit-object :label "Code 4" + :size 50 :accessor 'customer-code4)) (djtab-container> :id "addressTabs" :class "addressTabs" @@ -206,6 +218,7 @@ :visit-object main-address :class "text" :label "Main Address[address]" + :size 200 :accessor 'customer-address-address)) (div> :class "zip" (span> :class "label" "Zip") @@ -214,6 +227,7 @@ :visit-object main-address :class "text" :label "Main Address[zip]" + :size 5 :accessor 'customer-address-zip)) (div> :class "city" (span> :class "label" "City") @@ -222,6 +236,7 @@ :visit-object main-address :class "text" :label "Main Address[city]" + :size 120 :accessor 'customer-address-city)) (div> :class "state" (span> :class "label" "State") @@ -230,6 +245,7 @@ :visit-object main-address :class "text" :label "Main Address[state]" + :size 120 :accessor 'customer-address-state)) (div> :class "country" (span> :class "label" "Country") @@ -238,6 +254,7 @@ :visit-object main-address :class "text" :label "Main Address[country]" + :size 80 :accessor 'customer-address-country)))) (djcontent-pane> :static-id billing-address-id :class "billingAddress" :title "Billing address" (div> (div> :class "address" @@ -247,6 +264,7 @@ :visit-object billing-address :class "text" :label "Billing Address[street]" + :size 200 :accessor 'customer-address-address)) (div> :class "zip" (span> :class "label" "Zip") @@ -255,6 +273,7 @@ :visit-object billing-address :class "text" :label "Billing Address[zip]" + :size 5 :accessor 'customer-address-zip)) (div> :class "city" (span> :class "label" "City") @@ -263,6 +282,7 @@ :visit-object billing-address :class "text" :label "Billing Address[city]" + :size 120 :accessor 'customer-address-city)) (div> :class "state" (span> :class "label" "State") @@ -271,6 +291,7 @@ :visit-object billing-address :class "text" :label "Billing Address[state]" + :size 120 :accessor 'customer-address-state)) (div> :class "country" (span> :class "label" "Country") @@ -279,6 +300,7 @@ :visit-object billing-address :class "text" :label "Billing Address[country]" + :size 80 :accessor 'customer-address-country))))) (div> :class "buttons" (djsubmit-button> :value "Save") @@ -291,9 +313,11 @@ (defmethod wcomponent-before-rewind :before ((obj edit-customer) (page page)) (when (string-equal (htcomponent-client-id obj) (claw-parameter *rewind-parameter*)) (let ((customer-id (parse-integer (claw-parameter (edit-customer-customer-id-parameter obj))))) - (setf (edit-customer-customer obj) - (find-by-id 'customer - customer-id)) + (if (> customer-id 0) + (setf (edit-customer-customer obj) + (find-by-id 'customer + customer-id)) + (setf (edit-customer-customer obj) (make-instance 'customer))) (find-or-add-address (edit-customer-customer obj) 0) (find-or-add-address (edit-customer-customer obj) 1)))) Modified: trunk/main/claw-demo/src/frontend/components/edit-user.lisp ============================================================================== --- trunk/main/claw-demo/src/frontend/components/edit-user.lisp (original) +++ trunk/main/claw-demo/src/frontend/components/edit-user.lisp Tue Oct 21 12:45:47 2008 @@ -34,97 +34,49 @@ (defclass edit-user (djform) ((user :initarg :user :accessor edit-user-user) + (password :initarg :password + :accessor edit-user-password) (user-id-parameter :initarg :user-id-parameter :accessor edit-user-user-id-parameter) + (assigned-roles :initform () + :accessor edit-user-assigned-roles) (on-close-click :initarg :on-close-click :accessor edit-user-on-close-click)) (:metaclass metacomponent) (:default-initargs :on-close-click nil - :class "userForm" :user-id-parameter "userid")) + :class "userForm" :user-id-parameter "userid" :user nil :password nil)) (defmethod initialize-instance :after ((obj edit-user) &key rest) (declare (ignore rest)) (setf (action-object obj) obj (action obj) 'edit-user-save)) -#| -(defun find-or-add-address (user address-type) - (let ((address (loop for item in (user-addresses user) - when (= (user-address-type item) address-type) - return item))) - (unless address - (setf address (make-instance 'user-address :address-type address-type)) - (push address (user-addresses user))) - address)) - -(defun address-nullp (address) - (let ((attributes (list (user-address-address address) - (user-address-zip address) - (user-address-city address) - (user-address-state address) - (user-address-country address)))) - (not - (loop for val in (mapcar #'(lambda (x) - (when (and x (string-not-equal x "")) - t)) - attributes) - when val - return t)))) - -(defmethod htcomponent-class-initscripts :around ((obj edit-user)) - (let ((req-function (ps:ps (defun is-address-field-required (container-id) - (defvar input-list (dojo.query "[widgetId]" (dojo.by-id container-id))) - (defvar result false) - (dojo.for-each (.map input-list (slot-value dijit 'by-node)) - (lambda (input) (when (.get-value input) (setf result t)))) - (return result)))) - (address-field-validation (ps:ps (progn - (defun address-field-validation-init (component-id address-container-class) - (dojo.for-each (dojo.query (+ "." address-container-class) (dojo.by-id component-id)) - (lambda (main-address-node) - (dojo.for-each (.map (dojo.query "[widgetId]" main-address-node) dijit.by-node) - (lambda (widget) - (setf (slot-value widget 'is-valid) (lambda (is-focused) - (address-field-validation widget (slot-value main-address-node 'id)) - (return (.validator widget (slot-value (slot-value widget 'textbox) 'value) - (slot-value widget 'constraints)))))))))) - (defun address-field-validation (sender container-id) - (if (is-address-field-required container-id) - (unless (= (slot-value sender 'required) t) - (defvar input-list (dojo.query "[widgetId]" (dojo.by-id container-id))) - (dojo.for-each (.map input-list dijit.by-node) - (lambda (input-widget) (setf (slot-value input-widget 'required) t)))) - (unless (!= (slot-value sender 'required) t) - (defvar input-list (dojo.query "[widgetId]" (dojo.by-id container-id))) - (dojo.for-each (.map input-list dijit.by-node) - (lambda (input-widget) (setf (slot-value input-widget 'required) false)))))))))) - (append (list req-function address-field-validation) (call-next-method)))) - -(defmethod htcomponent-instance-initscript :around ((obj edit-user)) - (let* ((component-id (htcomponent-client-id obj)) - (parent-script (call-next-method)) - (script (ps:ps* `(progn - (address-field-validation-init ,component-id "mainAddress") - (address-field-validation-init ,component-id "billingAddress"))))) - (if parent-script - (format nil "~a~%~a" parent-script script) - script))) -|# - +(defmethod wcomponent-created :after ((obj edit-user)) + (setf (edit-user-assigned-roles obj) (and (edit-user-user obj) + (loop for role in (user-roles (edit-user-user obj)) + collect (table-id role))))) (defun unused-roles (user) (remove-if #'(lambda (role) (find role (user-roles user) :test #'records-equal)) (find-vo 'role :order-by (list (slot-column-name 'role "name"))))) - (defun edit-user-roles-can-drop (css-class-name) - (ps:ps* `(progn - (defvar m (.manager (slot-value dojo 'dnd))) - (when (slot-value m 'source) - (.can-drop m (.has-class dojo (slot-value (slot-value m 'source) 'node) ,css-class-name)))))) + `(progn + (defvar m (.manager (slot-value dojo 'dnd))) + (when (slot-value m 'source) + (.can-drop m (.has-class dojo (slot-value (slot-value m 'source) 'node) ,css-class-name))))) + +(defun edit-user-check-nodes (checked-p) + `(progn + (defvar m (.manager (slot-value dojo 'dnd))) + (.for-each dojo nodes (lambda (node-el) + (.for-each dojo (.query dojo "input" node-el) + (lambda (input-el) (setf (slot-value input-el 'checked) ,checked-p))))))) (defmethod htcomponent-body ((obj edit-user)) - (let* ((visit-object (edit-user-user obj))) + (let* ((visit-object (edit-user-user obj)) + (assigned-roles-container-id (generate-id "assignedRolesContainer")) + (available-roles-container-id (generate-id "availableRolesContainer"))) (list (cinput> :id (edit-user-user-id-parameter obj) :type "hidden" :visit-object visit-object @@ -135,21 +87,31 @@ :visit-object visit-object :translator *integer-translator* :accessor 'table-version) + (div> :class "label username" + (span> "Username") + (djvalidation-text-box> :visit-object visit-object + :required "true" + :label "Username" + :size 80 + :accessor 'user-username)) (div> :class "label surname" (span> "Surname") (djvalidation-text-box> :visit-object visit-object :required "true" :label "Surname" + :size 80 :accessor 'user-surname)) (div> :class "label firstname" (span> "First name") (djvalidation-text-box> :visit-object visit-object :label "First name" + :size 80 :accessor 'user-firstname)) (div> :class "label email" (span> "Email") (djvalidation-text-box> :visit-object visit-object :label "Email" + :size 200 :accessor 'user-email)) (div> :class "label active" (span> "Active") @@ -157,24 +119,50 @@ :label "Active" :translator *boolean-translator* :value t + :multiple nil :accessor 'user-active)) - (div> :class "label password" - (span> "Password") - (djvalidation-text-box> :visit-object visit-object - :label "Password" - :type "password" - :accessor 'user-password)) - (div> :class "userRoles" - (djdnd-source> :class "userRolesContainer availableRoles" + (djxpassword-validator> :id "password" + :class "label password" + :visit-object obj + :label "Password" + :type "password" + :size 100 + :accessor 'edit-user-password + (div> :class "label" + (span> "Password") + (djxpassword-new>)) + (div> :class "label" + (span> "Confirm password") + (djxpassword-verify>))) + (div> :class "userRolesRow" + (djdnd-source> :static-id available-roles-container-id :class "userRolesContainer availableRoles" + :tag-name "fieldset" (script> :type "dojo/connect" :event "onMouseMove" :args "e" - (edit-user-roles-can-drop "userRoles")) + (ps:ps* `,(edit-user-roles-can-drop "userRoles"))) + (script> :type "dojo/connect" :event "onDndDrop" :args "source, nodes, copy, target" + (ps:ps* `(when (= target.id ,available-roles-container-id) ,(edit-user-check-nodes 'false)))) + (legend> "Available roles") (loop for role in (unused-roles visit-object) - collect (djdnd-item> (role-name role)))) - (djdnd-source> :class "userRolesContainer userRoles" + collect (djdnd-item> (role-name role) + (ccheckbox> :id "userRole" + :visit-object obj + :translator *integer-translator* + :value (table-id role) + :accessor 'edit-user-assigned-roles)))) + (djdnd-source> :static-id assigned-roles-container-id :class "userRolesContainer userRoles" + :tag-name "fieldset" (script> :type "dojo/connect" :event "onMouseMove" :args "e" - (edit-user-roles-can-drop "availableRoles")) - (loop for role in (user-roles visit-object) - collect (djdnd-item> (role-name role))))) + (ps:ps* `,(edit-user-roles-can-drop "availableRoles"))) + (script> :type "dojo/connect" :event "onDndDrop" :args "source, nodes, copy, target" + (ps:ps* `(when (= target.id ,assigned-roles-container-id) ,(edit-user-check-nodes t)))) + (legend> "Assigned roles") + (loop for role in (user-roles visit-object) + collect (djdnd-item> (role-name role) + (ccheckbox> :id "userRole" + :visit-object obj + :translator *integer-translator* + :value (table-id role) + :accessor 'edit-user-assigned-roles))))) (div> :class "buttons" (djsubmit-button> :value "Save") (djbutton> :render-condition #'(lambda () (edit-user-on-close-click obj)) @@ -187,15 +175,22 @@ (when (string-equal (htcomponent-client-id obj) (claw-parameter *rewind-parameter*)) (let ((user-id (parse-integer (claw-parameter (edit-user-user-id-parameter obj))))) (setf (edit-user-user obj) - (find-by-id 'user - user-id))))) + (if (> user-id 0) + (find-by-id 'user + user-id) + (make-instance 'user)))))) (defmethod edit-user-save ((obj edit-user)) (let ((id (htcomponent-client-id obj)) - (user (edit-user-user obj))) + (user (edit-user-user obj)) + (roles (find-roles-by-ids :ids (edit-user-assigned-roles obj)))) (handler-case (progn - (update-db-item user)) + (log-message :info "password ~a" (edit-user-password obj)) + (setf (user-roles user) roles + (user-password user) (edit-user-password obj)) + (update-db-item user) + (setf (edit-user-password obj) nil)) (clsql-sys:sql-database-error (cond) (log-message :info "Exception on edit-user-save: ~a" cond) (add-validation-error id (clsql-sys:sql-error-database-message cond)) Modified: trunk/main/claw-demo/src/frontend/components/site-template.lisp ============================================================================== --- trunk/main/claw-demo/src/frontend/components/site-template.lisp (original) +++ trunk/main/claw-demo/src/frontend/components/site-template.lisp Tue Oct 21 12:45:47 2008 @@ -39,7 +39,6 @@ (defmethod wcomponent-template ((site-template site-template)) (let ((principal (current-principal))) -;(log-message :info "###### ~a ~a" principal (principal-roles principal)) (html> (head> (title> (site-template-title site-template)) @@ -57,6 +56,9 @@ (djtoolbar> :id "menuBar" :class "menuBar" (djdrop-down-button> (span> "File") (djmenu> + (djmenu-item> :id "homeMenu" + :on-click (ps:ps* `(location.replace ,(format nil "~a/home.html" *root-path*))) + "Home") (djmenu-item> :id "loginMenu" :render-condition #'(lambda () (null principal)) :on-click (ps:ps* `(location.replace ,(format nil "~a/login.html" *root-path*))) @@ -65,7 +67,7 @@ :render-condition #'(lambda () principal) :on-click (ps:ps* `(location.replace ,(format nil "~a/logout.html" *root-path*))) "Logout"))) - (djdrop-down-button> :render-condition #'(lambda () principal) + (djdrop-down-button> :render-condition #'(lambda () (user-in-role-p '("user"))) (span> "Anagraphics") (djmenu> (djmenu-item> :id "customersMenu" Added: trunk/main/claw-demo/src/frontend/components/translator-stringlist.lisp ============================================================================== --- (empty file) +++ trunk/main/claw-demo/src/frontend/components/translator-stringlist.lisp Tue Oct 21 12:45:47 2008 @@ -0,0 +1,44 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- +;;; $Header: src/frontend/components/translator-stringlist.lisp $ + +;;; Copyright (c) 2008, Andrea Chiumenti. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(in-package :claw-demo-frontend) + +(defclass translator-stringlist (translator) + ()) + +(defmethod translator-value-encode ((translator translator-stringlist) value) + (if (string= (string-trim " " value) "") + () + (split-sequence #\, value))) + +(defmethod translator-value-decode ((translator translator-stringlist) value &optional client-id label) + (declare (ignore client-id label)) + (format nil "~{~a~^,~}" value)) + +(defvar *stringlist-translator* (make-instance 'translator-stringlist)) \ No newline at end of file Modified: trunk/main/claw-demo/src/frontend/customers.lisp ============================================================================== --- trunk/main/claw-demo/src/frontend/customers.lisp (original) +++ trunk/main/claw-demo/src/frontend/customers.lisp Tue Oct 21 12:45:47 2008 @@ -35,11 +35,13 @@ (defgeneric customers-page-edit-customer (customers-page)) +(defgeneric customers-page-add-customer (customers-page)) + (defgeneric customers-page-sorting (customers-page)) (defgeneric customers-page-delete-customers (customers-page)) -(defclass customers-page (db-page) +(defclass customers-page (db-page) ((customers :initform nil :accessor customers-page-customers) (current-customer :initform (make-instance 'customer) @@ -59,17 +61,17 @@ (email :initform "" :accessor customers-page-email) (vat :initform "" - :accessor customers-page-vat) + :accessor customers-page-vat) (phone :initform "" :accessor customers-page-phone) (sorting-column :initform "name1" - :accessor customers-page-sorting-column) + :accessor customers-page-sorting-column) (sorting-order :initform "asc" - :accessor customers-page-sorting-order) + :accessor customers-page-sorting-order) (delete-all :initform nil :accessor customers-page-delete-all) (delete-items :initform nil - :accessor customers-page-delete-items)) + :accessor customers-page-delete-items)) (:default-initargs :list-size 20)) (defmethod wcomponent-after-rewind :after ((obj edit-customer) (page customers-page)) @@ -78,28 +80,108 @@ (defmethod customers-page-offset-reset ((page customers-page)) 0) -(defmethod customers-page-edit-customer ((page customers-page)) +(defmethod customers-page-edit-customer ((page customers-page)) (let ((customer-id (parse-integer (claw-parameter "customerid"))) (current-customer)) - (setf current-customer (find-by-id 'customer customer-id) - (customers-page-customer-edit-dialog-title page) "Edit customer" - (customers-page-customers page) (list current-customer)) - (when current-customer - (setf (customers-page-current-customer page) current-customer)))) + (log-message :info "customers-page-edit-customer") + (if (> customer-id 0) + (progn + (setf current-customer (find-by-id 'customer customer-id) + (customers-page-customer-edit-dialog-title page) "Edit customer" + (customers-page-customers page) (list current-customer)) + (when current-customer + (setf (customers-page-current-customer page) current-customer))) + (customers-page-add-customer page)))) + +(defmethod customers-page-add-customer ((page customers-page)) + (let ((current-customer (make-instance 'customer))) + (log-message :info "customers-page-add-customer") + (setf (customers-page-customer-edit-dialog-title page) "Add new customer" + (customers-page-current-customer page) current-customer))) (defmethod customers-page-sorting ((page customers-page)) (let ((direction (if (string-equal "asc" (customers-page-sorting-order page)) :asc :desc)) (fields (if (string-equal "name1" (customers-page-sorting-column page)) - (list (slot-column-name 'customer "name1") + (list (slot-column-name 'customer "name1") (slot-column-name 'customer "name2")) - (list (slot-column-name 'customer "email") - (slot-column-name 'customer "name1") + (list (slot-column-name 'customer "email") + (slot-column-name 'customer "name1") (slot-column-name 'customer "name2"))))) (loop for field in fields collect (list field direction)))) +(defun js-customers-check-deletion () + (ps:ps* '(when (= (slot-value (.query dojo ".dijitCheckBoxChecked > [name='deleteItem']") 'length) 0) + (.show-message claw "Message" "No items to delete") + (return false)))) + +(defun js-customers-add-new-click (edit-customer-action-link-id offset-id) + (remove #\newline + (ps:ps* + `(progn (setf (slot-value (.by-id dojo ,offset-id) 'value) + 0 + (slot-value (dijit.by-id ,edit-customer-action-link-id) 'parameters) + (create "customerid" 0)) + (.click (dijit.by-id ,edit-customer-action-link-id)))))) + +(defun js-customers-form-submit (spinner-id edit-customer-dialog-id) + (remove #\newline + (ps:ps* `(progn (.hide (dijit.by-id ,spinner-id)) + (when (slot-value (dijit.by-id ,edit-customer-dialog-id) 'xhrShow) + (setf (slot-value (dijit.by-id ,edit-customer-dialog-id) 'xhrShow) false) + (.show (dijit.by-id ,edit-customer-dialog-id))))))) + +(defun js-customers-show-spinner (spinner-id) + (remove #\newline (ps:ps* `(.show (dijit.by-id ,spinner-id))))) + +(defun js-customers-delete-all-on-change () + (remove #\newline + (ps:ps (.for-each dojo + (.map (.query dojo ".deleteItem") dijit.by-node) + (lambda (checkbox) (.attr checkbox "checked" (.attr this "checked"))) + this)))) + +(defun js-customers-sort (sorting-column-id sorting-order-id form-id offset-id column) + (remove #\newline + (ps:ps* `(progn + (setf (slot-value (dojo.by-id ,sorting-order-id) 'value) + (if (and (== (slot-value (dojo.by-id ,sorting-column-id) 'value) ,column) + (== (slot-value (dojo.by-id ,sorting-order-id) 'value) "asc")) + "desc" + "asc") + (slot-value (dojo.by-id ,sorting-column-id) 'value) + ,column + (slot-value (dojo.by-id ,offset-id) 'value) + 0) + (.submit (dijit.by-id ,form-id)))))) + +(defun js-customers-edit (edit-customer-action-link-id customer) + (remove #\newline + (ps:ps* `(progn (setf (slot-value (dijit.by-id ,edit-customer-action-link-id) 'parameters) + (create "customerid" ,(table-id customer))) + (.click (dijit.by-id ,edit-customer-action-link-id)))))) + +(defun js-customers-action-edit (spinner-id edit-customer-dialog-id) + (remove #\newline + (ps:ps* `(progn (.hide (dijit.by-id ,spinner-id)) + (.show (dijit.by-id ,edit-customer-dialog-id)))))) + +(defun js-customers-edit-customers-before-submit (spinner-id edit-customer-dialog-id) + (remove #\newline + (ps:ps* `(progn (.show (dijit.by-id ,spinner-id)) + (dojo.add-class + (slot-value (dijit.by-id ,edit-customer-dialog-id) 'container-node) + "hideForm"))))) + +(defun js-customers-edit-customers-xhr-finish (spinner-id edit-customer-dialog-id) + (remove #\newline + (ps:ps* `(progn (.hide (dijit.by-id ,spinner-id)) + (dojo.remove-class + (slot-value (dijit.by-id ,edit-customer-dialog-id) 'container-node) + "hideForm"))))) + (defmethod page-content ((page customers-page)) (let ((spinner-id (generate-id "spinner")) (form-id (generate-id "customersForm")) @@ -121,18 +203,33 @@ (djform> :static-id form-id :action 'customers-page-find-customers :update-id result-container-id - :on-before-submit (ps:ps* `(.show (dijit.by-id ,spinner-id))) - :on-xhr-finish (ps:ps* `(.hide (dijit.by-id ,spinner-id))) + :on-before-submit (js-customers-show-spinner spinner-id) + :on-xhr-finish (js-customers-form-submit spinner-id edit-customer-dialog-id) (div> (div> :class "searchParameters hlist" - (div> :class "item" (span> :class "name1" "Name") - (djtext-box> :label "name" :id "name1" :accessor 'customers-page-name1) - (djtext-box> :label "name" :id "name2" :accessor 'customers-page-name2)) - (div> :class "item" (span> :class "email" "Email") - (djtext-box> :label "email" :id "email" :accessor 'customers-page-email)) - (div> :class "item" (span> :class "vat" "VAT") - (djtext-box> :label "vat" :id "vat" :accessor 'customers-page-vat)) - (div> :class "item" (span> :class "phone" "phone") - (djtext-box> :label "phone" :id "phone" :accessor 'customers-page-phone))) + (div> :class "item" (span> :class "name1" "Name") + (djtext-box> :size 150 + :label "name" + :id "name1" + :accessor 'customers-page-name1) + (djtext-box> :size 80 + :label "name" + :id "name2" + :accessor 'customers-page-name2)) + (div> :class "item" (span> :class "email" "Email") + (djtext-box> :size 100 + :label "email" + :id "email" + :accessor 'customers-page-email)) + (div> :class "item" (span> :class "vat" "VAT") + (djtext-box> :size 50 + :label "vat" + :id "vat" + :accessor 'customers-page-vat)) + (div> :class "item" (span> :class "phone" "phone") + (djtext-box> :size 25 + :label "phone" + :id "phone" + :accessor 'customers-page-phone))) (cinput> :type "hidden" :static-id offset-id :translator *integer-translator* @@ -145,62 +242,62 @@ :static-id sorting-order-id :accessor 'customers-page-sorting-order) (djsubmit-button> :id "search" + :on-click (ps:ps* `(setf + (slot-value (.by-id dojo ,offset-id) 'value) + 0)) :value "Search") + (djbutton> :id "addNew" + :on-click (js-customers-add-new-click edit-customer-action-link-id offset-id) + "Add new") (djconfirmation-submit> :id "delete" :value "Delete" + :on-click (js-customers-check-deletion) :action 'customers-page-delete-customers :confirmation-message "Are you sure to delete these items?")) (div> :static-id result-container-id (table> :class "listTable" (tr> :class "header" - (th> :class "deleteAll" (djcheck-box> :id "deleteAll" - ;:reader 'customers-page-delete-all - :value "all" - :onchange(remove #\newline (ps:ps (.for-each dojo (.map (.query dojo ".deleteItem") dijit.by-node) - (lambda (checkbox) (.attr checkbox "checked" (.attr this "checked"))) this))))) - (th> :class "name" (span> :class (if (string-equal "name1" sort-field) + (th> :class "deleteAll" (djcheck-box> :id "deleteAll" + :value "all" + :onchange (js-customers-delete-all-on-change))) + (th> :class "name" (span> :class (if (string-equal "name1" sort-field) (if (string-equal "asc" sort-direction) "sort sortAsc" "sort sortDesc") "sort") - :on-click (remove #\newline (ps:ps* `(progn (setf (slot-value (dojo.by-id ,sorting-order-id) 'value) - (if (and (== (slot-value (dojo.by-id ,sorting-column-id) 'value) "name1") - (== (slot-value (dojo.by-id ,sorting-order-id) 'value) "asc")) - "desc" - "asc")) - (setf (slot-value (dojo.by-id ,sorting-column-id) 'value) - "name1") - (.submit (dijit.by-id ,form-id))))) + :on-click (js-customers-sort sorting-column-id + sorting-order-id + form-id + offset-id + "name1") "Name")) - (th> :class "email" (span> :class (if (string-equal "email" sort-field) + (th> :class "email" (span> :class (if (string-equal "email" sort-field) (if (string-equal "asc" sort-direction) "sort sortAsc" "sort sortDesc") - "sort") - :on-click (remove #\newline (ps:ps* `(progn (setf (slot-value (dojo.by-id ,sorting-order-id) 'value) - (if (and (== (slot-value (dojo.by-id ,sorting-column-id) 'value) "email") - (== (slot-value (dojo.by-id ,sorting-order-id) 'value) "asc")) - "desc" - "asc")) - (setf (slot-value (dojo.by-id ,sorting-column-id) 'value) - "email") - (.submit (dijit.by-id ,form-id))))) + "sort") + :on-click (js-customers-sort sorting-column-id + sorting-order-id + form-id + offset-id + "email") "Email")) (th> :class "vat" "VAT") (th> :class "phone" "Phone")) (loop for customer in customers for index = 0 then (incf index) collect (tr> :class (if (evenp index) "item even" "item odd") - (th> :class "delete" (djcheck-box> :id "deleteItem" :class "deleteItem" :accessor 'customers-page-delete-items - :value (table-id customer) - :translator *integer-translator* - :multiple t)) + (th> :class "delete" + (djcheck-box> :id "deleteItem" + :class "deleteItem" + :accessor 'customers-page-delete-items + :value (table-id customer) + :translator *integer-translator* + :multiple t)) (td> (a> :id "edit" :href "#" - :on-click (remove #\newline (ps:ps* `(progn (setf (slot-value (dijit.by-id ,edit-customer-action-link-id) 'parameters) - (create "customerid" ,(table-id customer))) - (.click (dijit.by-id ,edit-customer-action-link-id))))) + :on-click (js-customers-edit edit-customer-action-link-id customer) (customer-name1 customer) " " (customer-name2 customer))) @@ -208,21 +305,20 @@ (td> (customer-vat customer)) (td> (customer-phone1 customer))))) (unless customers - (djcheck-box> :id "deleteItem" - :accessor 'customers-page-delete-items + (djcheck-box> :id "deleteItem" + :accessor 'customers-page-delete-items :value 0 - :multiple t + :multiple t :translator *integer-translator* :style "display: none;")) (djaction-link> :static-id edit-customer-action-link-id :style "display:none" :action 'customers-page-edit-customer :update-id (attribute-value (list edit-customer-dialog-container-id result-container-id)) - :on-before-submit (ps:ps* `(.show (dijit.by-id ,spinner-id))) - :on-xhr-finish (remove #\newline (ps:ps* `(progn (.hide (dijit.by-id ,spinner-id)) - (.show (dijit.by-id ,edit-customer-dialog-id))))) + :on-before-submit (js-customers-show-spinner spinner-id) + :on-xhr-finish (js-customers-action-edit spinner-id edit-customer-dialog-id) "invisible") - (pager> :id "pager" + (pager> :id "pager" :update-component-id offset-id :page-size (customers-page-list-size page) :total-items (customers-page-customers-total-count page) @@ -235,15 +331,10 @@ :on-close-click (ps:ps* `(.hide (dijit.by-id ,edit-customer-dialog-id))) :update-id (attribute-value (list edit-customer-form-id result-container-id)) :customer (customers-page-current-customer page) - :on-before-submit (remove #\newline (ps:ps* `(progn (.show (dijit.by-id ,spinner-id)) - (dojo.add-class - (slot-value (dijit.by-id ,edit-customer-dialog-id) 'container-node) - "hideForm")))) - :on-xhr-finish (ps:ps* `(progn (.hide (dijit.by-id ,spinner-id)) - (dojo.remove-class - (slot-value (dijit.by-id ,edit-customer-dialog-id) 'container-node) - "hideForm")))) - (exception-monitor> :id "exceptionMonitor" :json-render-on-validation-errors-p edit-customer-form-id)))))) + :on-before-submit (js-customers-edit-customers-before-submit spinner-id edit-customer-dialog-id) + :on-xhr-finish (js-customers-edit-customers-xhr-finish spinner-id edit-customer-dialog-id)) + (exception-monitor> :id "exceptionMonitor" + :json-render-on-validation-errors-p edit-customer-form-id)))))) (defmethod customers-page-delete-customers ((page customers-page)) (let ((customer-id-list (customers-page-delete-items page)) @@ -255,7 +346,7 @@ (log-message :info "...deleting") (delete-by-id 'customer customer-id-list) (setf (customers-page-delete-items page) ()) - (multiple-value-bind (customers total-size) + (multiple-value-bind (customers total-size) (find-customers :offset (customers-page-offset page) :limit (customers-page-list-size page) :name1 (null-when-empty name1) @@ -273,7 +364,7 @@ (email (customers-page-email page)) (vat (customers-page-vat page)) (phone (customers-page-phone page))) - (multiple-value-bind (customers total-size) + (multiple-value-bind (customers total-size) (find-customers :offset (customers-page-offset page) :limit (customers-page-list-size page) :name1 (null-when-empty name1) @@ -287,7 +378,7 @@ (defmethod page-before-render ((page customers-page)) (unless (page-req-parameter page *rewind-parameter*) - (multiple-value-bind (customers total-size) + (multiple-value-bind (customers total-size) (find-customers :sorting (customers-page-sorting page) :offset 0 :limit (customers-page-list-size page)) @@ -295,8 +386,8 @@ (customers-page-customers-total-count page) total-size)))) -(lisplet-register-function-location *dojo-demo-lisplet* - (make-page-renderer 'customers-page #'claw-post-parameters #'claw-get-parameters) +(lisplet-register-function-location *dojo-demo-lisplet* + (make-page-renderer 'customers-page #'claw-post-parameters #'claw-get-parameters) "customers.html") (lisplet-protect *dojo-demo-lisplet* "customers.html" '("administrator" "user")) Modified: trunk/main/claw-demo/src/frontend/docroot/css/style.css ============================================================================== --- trunk/main/claw-demo/src/frontend/docroot/css/style.css (original) +++ trunk/main/claw-demo/src/frontend/docroot/css/style.css Tue Oct 21 12:45:47 2008 @@ -6,6 +6,13 @@ font-family: arial; } +.clawButtons { + margin-top: 1em; + border-top: 1px solid #BDD6F0; + padding-top: .5em; + text-align: center; +} + ul.errors { padding: 0; } @@ -44,7 +51,7 @@ text-align: center; } -#exceptionMonitor ul { +.exceptionMonitor ul { list-style-type: none; color: red; } @@ -149,17 +156,18 @@ .customerForm .label span, .userForm .label span{ display:-moz-inline-stack; display:inline-block; - width: 80px; + width: 127px; text-align: right; padding-right: 15px; } -body.demo .customerDialog { - width: 305px; - min-height: 460px; +body.demo .customerDialog form{ + width: 360px; + height:415px; + overflow: hidden; } -body.demo .customerDialog .dijitDialogPaneContent{ +body.demo .dijitDialog .dijitDialogPaneContent{ background: #F0F4FC; } .customerForm .buttons, .userForm .buttons { @@ -189,6 +197,7 @@ width: 100%; height: 150px; margin-top: 5px; +/* margin-left: 20px;*/ } .demo .addressTabs .dijitTabLabels-top { @@ -224,6 +233,10 @@ display: block; } +div.label { + margin-top: 2px; +} + .addressTabs .text { width: 100%; } @@ -236,24 +249,33 @@ width: 150px; } -.userRoles { +.userRolesRow { position: relative; margin-top: 5px; /* width: 340px;*/ } -.userRoles div.userRolesContainer { +.userRolesRow .userRolesContainer { position: relative; float: left; width: 160px; height: 180px; border: 1px solid #8BA0BD; margin-top: 0; + padding:3px; +} + +legend { + font-weight: bolder; } -.userRoles div div { +.userRolesRow div div { clear: left; } .availableRoles { margin-right: 5px; +} + +.userRolesRow input { + display: none; } \ No newline at end of file Modified: trunk/main/claw-demo/src/frontend/login.lisp ============================================================================== --- trunk/main/claw-demo/src/frontend/login.lisp (original) +++ trunk/main/claw-demo/src/frontend/login.lisp Tue Oct 21 12:45:47 2008 @@ -61,6 +61,7 @@ (djvalidation-text-box> :id "username" :label "Username" :required "true" + :size 80 :accessor 'login-page-username)) (div> :class "row" (span> :class "dialogLabel" "Password") @@ -68,15 +69,18 @@ :label "Password" :type "password" :required "true" + :size 100 :accessor 'login-page-password)) (div> :class "buttonContainer" (djsubmit-button> :value "Login") - (exception-monitor> :id "exceptionMonitor" :json-render-on-validation-errors-p form-id))) + (exception-monitor> :id "exceptionMonitor" + :json-render-on-validation-errors-p form-id))) (div> :static-id login-result-id (redirect> :render-condition #'current-principal :id "redirect" :href (format nil "~a/index.html" *root-path*)))) - (script> (ps:ps* `(dojo.add-on-load (lambda () (.show (dijit.by-id "loginDialog"))))))))) + (script> :render-condition #'(lambda () (null (current-principal))) + (ps:ps* `(dojo.add-on-load (lambda () (.show (dijit.by-id "loginDialog"))))))))) (lisplet-register-function-location *dojo-demo-lisplet* (make-page-renderer 'login-page #'claw-post-parameters #'claw-get-parameters) Modified: trunk/main/claw-demo/src/frontend/main.lisp ============================================================================== --- trunk/main/claw-demo/src/frontend/main.lisp (original) +++ trunk/main/claw-demo/src/frontend/main.lisp Tue Oct 21 12:45:47 2008 @@ -1,5 +1,5 @@ ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- -;;; $Header: dojo/tests/main.lisp $ +;;; $Header: src/frontend/main.lisp $ ;;; Copyright (c) 2008, Andrea Chiumenti. All rights reserved. Modified: trunk/main/claw-demo/src/frontend/packages.lisp ============================================================================== --- trunk/main/claw-demo/src/frontend/packages.lisp (original) +++ trunk/main/claw-demo/src/frontend/packages.lisp Tue Oct 21 12:45:47 2008 @@ -1,5 +1,5 @@ ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- -;;; $Header: src/package.lisp $ +;;; $Header: src/frontend/package.lisp $ ;;; Copyright (c) 2008, Andrea Chiumenti. All rights reserved. @@ -31,6 +31,5 @@ (defpackage :claw-demo-frontend - (:use :cl :local-time :claw :hunchentoot-connector :claw-html :claw-html.dojo :claw-demo-backend) - (:documentation "A demo application for CLAW") - #|(:export #:demo-setup)|#) \ No newline at end of file + (:use :cl :local-time :claw :hunchentoot-connector :claw-html :claw-html.dojo :claw-demo-backend :split-sequence) + (:documentation "Frontend layer for demo application for CLAW")) \ No newline at end of file Modified: trunk/main/claw-demo/src/frontend/users.lisp ============================================================================== --- trunk/main/claw-demo/src/frontend/users.lisp (original) +++ trunk/main/claw-demo/src/frontend/users.lisp Tue Oct 21 12:45:47 2008 @@ -35,11 +35,13 @@ (defgeneric users-page-edit-user (uses-page)) +(defgeneric users-page-add-user (uses-page)) + (defgeneric users-page-sorting (users-page)) (defgeneric users-page-delete-users (users-page)) -(defclass users-page (db-page) +(defclass users-page (db-page) ((users :initform nil :accessor users-page-users) (current-user :initform (make-instance 'user) @@ -74,31 +76,140 @@ :accessor users-page-delete-items)) (:default-initargs :list-size 20)) +(defmethod wcomponent-after-rewind :after ((obj edit-user) (page users-page)) + (setf (users-page-current-user page) (edit-user-user obj) + (users-page-users page) (list (edit-user-user obj)))) + (defmethod users-page-offset-reset ((page users-page)) 0) -(defmethod users-page-edit-user ((page users-page)) +(defmethod users-page-edit-user ((page users-page)) (let ((user-id (parse-integer (claw-parameter "userid"))) (current-user)) - (setf current-user (find-by-id 'user user-id) - (users-page-user-edit-dialog-title page) "Edit user" - (users-page-users page) (list current-user)) - (when current-user - (setf (users-page-current-user page) current-user)))) + (if (> user-id 0) + (progn + (setf current-user (find-by-id 'user user-id) + (users-page-user-edit-dialog-title page) "Edit user" + (users-page-users page) (list current-user)) + (when current-user + (when (string-equal (user-username current-user) "admin") + (add-validation-error "user" "User admin is readonly")) + (setf (users-page-current-user page) current-user))) + (users-page-add-user page)))) + +(defmethod users-page-add-user ((page users-page)) + (let ((current-user (make-instance 'user))) + (setf (users-page-user-edit-dialog-title page) "Add new user" + (users-page-current-user page) current-user))) + (defmethod users-page-sorting ((page users-page)) (let ((direction (if (string-equal "asc" (users-page-sorting-order page)) :asc :desc)) - (fields (cond - ((string-equal "surname" (users-page-sorting-column page)) (list (slot-column-name 'user "surname") + (fields (cond + ((string-equal "surname" (users-page-sorting-column page)) (list (slot-column-name 'user "surname") (slot-column-name 'user "firstname"))) ((string-equal "username" (users-page-sorting-column page)) (list (slot-column-name 'user "username"))) - (t (list (slot-column-name 'user "email") - (slot-column-name 'user "surname") + (t (list (slot-column-name 'user "email") + (slot-column-name 'user "surname") (slot-column-name 'user "firstname")))))) (loop for field in fields collect (list field direction)))) +(defun js-users-clean-excpetions () + (ps:ps* '(defun clean-exceptions () + (.for-each dojo + (.query dojo ".exceptionMonitor") + (lambda (em) + (.for-each dojo + (slot-value em 'child-nodes) + (lambda (node) + (.remove-child em node)))))))) + +(defun js-users-add-new-click (edit-user-action-link-id offset-id) + (remove #\newline + (ps:ps* + `(progn (setf (slot-value (.by-id dojo ,offset-id) 'value) + 0 + (slot-value (dijit.by-id ,edit-user-action-link-id) 'parameters) + (create "userid" 0)) + (.click (dijit.by-id ,edit-user-action-link-id)))))) + + +(defun js-no-exceptions-p () + (ps:ps* '(defun no-exceptions () + (defvar validp t) + (.for-each dojo + (.query dojo ".globalExceptionMonitor") + (lambda (el) (when (.has-child-nodes el) + (setf validp false)))) + (return validp)))) + + +(defun js-users-form-submit (spinner-id edit-user-dialog-id) + (remove #\newline + (ps:ps* `(progn (.hide (dijit.by-id ,spinner-id)) + (when (slot-value (dijit.by-id ,edit-user-dialog-id) 'xhrShow) + (setf (slot-value (dijit.by-id ,edit-user-dialog-id) 'xhrShow) false) + (when (no-exceptions) + (.show (dijit.by-id ,edit-user-dialog-id)))))))) + +(defun js-users-show-spinner (spinner-id) + (remove #\newline (ps:ps* `(progn (clean-exceptions) + (.show (dijit.by-id ,spinner-id)))))) + +(defun js-users-delete-all-on-change () + (remove #\newline + (ps:ps (.for-each dojo + (.map (.query dojo ".deleteItem") dijit.by-node) + (lambda (checkbox) (.attr checkbox "checked" (.attr this "checked"))) + this)))) + +(defun js-users-sort (sorting-column-id sorting-order-id form-id offset-id column) + (remove #\newline + (ps:ps* `(progn + (setf (slot-value (dojo.by-id ,sorting-order-id) 'value) + (if (and (== (slot-value (dojo.by-id ,sorting-column-id) 'value) ,column) + (== (slot-value (dojo.by-id ,sorting-order-id) 'value) "asc")) + "desc" + "asc") + (slot-value (dojo.by-id ,sorting-column-id) 'value) + ,column + (slot-value (dojo.by-id ,offset-id) 'value) + 0) + (.submit (dijit.by-id ,form-id)))))) + +(defun js-users-edit (edit-user-action-link-id user) + (remove #\newline + (ps:ps* `(progn (setf (slot-value (dijit.by-id ,edit-user-action-link-id) 'parameters) + (create "userid" ,(table-id user))) + (.click (dijit.by-id ,edit-user-action-link-id)))))) + +(defun js-users-action-edit (spinner-id edit-user-dialog-id) + (remove #\newline + (ps:ps* `(progn (.hide (dijit.by-id ,spinner-id)) + (when (no-exceptions) + (.show (dijit.by-id ,edit-user-dialog-id))))))) + +(defun js-users-edit-users-before-submit (spinner-id edit-user-dialog-id) + (remove #\newline + (ps:ps* `(progn (.show (dijit.by-id ,spinner-id)) + (dojo.add-class + (slot-value (dijit.by-id ,edit-user-dialog-id) 'container-node) + "hideForm"))))) +(defun js-users-check-deletion () + (ps:ps* '(when (= (slot-value (.query dojo ".dijitCheckBoxChecked > [name='deleteItem']") 'length) 0) + (.show-message claw "Message" "No items to delete") + (return false)))) + +(defun js-users-edit-users-xhr-finish (spinner-id edit-user-dialog-id) + (remove #\newline + (ps:ps* `(progn (.hide (dijit.by-id ,spinner-id)) + (dojo.remove-class + (slot-value (dijit.by-id ,edit-user-dialog-id) 'container-node) + "hideForm"))))) + + (defmethod page-content ((page users-page)) (let ((spinner-id (generate-id "spinner")) (form-id (generate-id "usersForm")) @@ -121,39 +232,40 @@ (djfloating-content> :static-id spinner-id (img> :alt "spinner" :src "docroot/img/spinner.gif")) + (exception-monitor> :class "globalExceptionMonitor") (djform> :static-id form-id :class "users" :action 'users-page-find-users :update-id result-container-id - :on-before-submit (ps:ps* `(.show (dijit.by-id ,spinner-id))) - :on-xhr-finish (ps:ps* `(.hide (dijit.by-id ,spinner-id))) + :on-before-submit (js-users-show-spinner spinner-id) + :on-xhr-finish (js-users-form-submit spinner-id edit-user-dialog-id) (div> (div> :class "searchParameters hlist" (div> :class "item" (span> :class "surname" "Name") - (djtext-box> :label "name" :id "surname" :accessor 'users-page-surname) - (djtext-box> :label "name" :id "firstname" :accessor 'users-page-firstname)) + (djtext-box> :size 80 :label "name" :id "surname" :accessor 'users-page-surname) + (djtext-box> :size 80 :label "name" :id "firstname" :accessor 'users-page-firstname)) (div> :class "item" (span> :class "username" "Username") - (djtext-box> :label "username" :id "username" :accessor 'users-page-username)) + (djtext-box> :size 80 :label "username" :id "username" :accessor 'users-page-username)) (div> :class "item" (span> :class "email" "Email") - (djtext-box> :label "email" :id "email" :accessor 'users-page-email)) + (djtext-box> :size 200 :label "email" :id "email" :accessor 'users-page-email)) (div> :class "item active" (span> :class "active" "Active") (div> :class "boundBox" (div> (djradio-button> :static-id active-any-id :name "active" - :class "active" + :class "active" :translator *threestate-translator* :accessor 'users-page-active :value :any) (label> :for active-any-id "Any")) (div> (djradio-button> :static-id active-yes-id :name "active" - :class "active" + :class "active" :translator *threestate-translator* :accessor 'users-page-active :value t) (label> :for active-yes-id "Yes")) (div> (djradio-button> :static-id active-no-id :name "active" - :class "active" + :class "active" :translator *threestate-translator* :accessor 'users-page-active :value nil) @@ -161,12 +273,12 @@ (div> :class "item roles" (span> :class "roles" "Roles") (div> :class "boundBox" (loop for role in all-roles - collect (let ((chk-id (generate-id "selRole"))) + collect (let ((chk-id (generate-id "selRole"))) (div> (djcheck-box> :static-id chk-id :name "selRole" - :class "selRole" - :accessor 'users-page-roles - :value (role-name role) + :class "selRole" + :accessor 'users-page-roles + :value (role-name role) :multiple t) (label> :for chk-id (role-name role)))))))) (cinput> :type "hidden" @@ -182,105 +294,106 @@ :accessor 'users-page-sorting-order) (div> :class "hlistButtons" (djsubmit-button> :id "search" + :on-click (ps:ps* + `(setf + (slot-value (.by-id dojo ,offset-id) 'value) + 0)) :value "Search") + (djbutton> :id "addNew" + :on-click (js-users-add-new-click + edit-user-action-link-id + offset-id) + "Add new") (djconfirmation-submit> :id "delete" :value "Delete" + :on-click (js-users-check-deletion) :action 'users-page-delete-users :confirmation-message "Are you sure to delete these items?"))) (div> :static-id result-container-id (table> :class "listTable" (tr> :class "header" - (th> :class "deleteAll" (djcheck-box> :id "deleteAll" - ;:reader 'users-page-delete-all - :value "all" - :onchange(remove #\newline (ps:ps (.for-each dojo (.map (.query dojo ".deleteItem") dijit.by-node) - (lambda (checkbox) (.attr checkbox "checked" (.attr this "checked"))) this))))) - (th> :class "name" (span> :class (if (string-equal "surname" sort-field) + (th> :class "deleteAll" (djcheck-box> :id "deleteAll" + :value "all" + :onchange (js-users-delete-all-on-change))) + (th> :class "name" (span> :class (if (string-equal "surname" sort-field) (if (string-equal "asc" sort-direction) "sort sortAsc" "sort sortDesc") "sort") - :on-click (remove #\newline (ps:ps* `(progn (setf (slot-value (dojo.by-id ,sorting-order-id) 'value) - (if (and (== (slot-value (dojo.by-id ,sorting-column-id) 'value) "surname") - (== (slot-value (dojo.by-id ,sorting-order-id) 'value) "asc")) - "desc" - "asc")) - (setf (slot-value (dojo.by-id ,sorting-column-id) 'value) - "surname") - (.submit (dijit.by-id ,form-id))))) + :on-click (js-users-sort sorting-column-id + sorting-order-id + form-id + offset-id + "surname") "Name")) - (th> :class "username" (span> :class (if (string-equal "username" sort-field) + (th> :class "username" (span> :class (if (string-equal "username" sort-field) (if (string-equal "asc" sort-direction) "sort sortAsc" "sort sortDesc") - "sort") - :on-click (remove #\newline (ps:ps* `(progn (setf (slot-value (dojo.by-id ,sorting-order-id) 'value) - (if (and (== (slot-value (dojo.by-id ,sorting-column-id) 'value) "username") - (== (slot-value (dojo.by-id ,sorting-order-id) 'value) "asc")) - "desc" - "asc")) - (setf (slot-value (dojo.by-id ,sorting-column-id) 'value) - "username") - (.submit (dijit.by-id ,form-id))))) + "sort") + :on-click (js-users-sort sorting-column-id + sorting-order-id + form-id + offset-id + "username") "Username")) - (th> :class "email" (span> :class (if (string-equal "email" sort-field) + (th> :class "email" (span> :class (if (string-equal "email" sort-field) (if (string-equal "asc" sort-direction) "sort sortAsc" "sort sortDesc") - "sort") - :on-click (remove #\newline (ps:ps* `(progn (setf (slot-value (dojo.by-id ,sorting-order-id) 'value) - (if (and (== (slot-value (dojo.by-id ,sorting-column-id) 'value) "email") - (== (slot-value (dojo.by-id ,sorting-order-id) 'value) "asc")) - "desc" - "asc")) - (setf (slot-value (dojo.by-id ,sorting-column-id) 'value) - "email") - (.submit (dijit.by-id ,form-id))))) + "sort") + :on-click (js-users-sort sorting-column-id + sorting-order-id + form-id + offset-id + "email") "Email")) (th> :class "enabled" "Enabled") (th> :class "roles" "Roles")) (loop for user in users for index = 0 then (incf index) collect (tr> :class (if (evenp index) "item even" "item odd") - (th> :class "delete" (djcheck-box> :id "deleteItem" :class "deleteItem" :accessor 'users-page-delete-items - :value (table-id user) - :translator *integer-translator* - :multiple t)) - (td> (a> :id "edit" - :href "#" - :on-click (remove #\newline (ps:ps* `(progn (setf (slot-value (dijit.by-id ,edit-user-action-link-id) 'parameters) - (create "userid" ,(table-id user))) - (.click (dijit.by-id ,edit-user-action-link-id))))) - (user-surname user) - " " - (user-firstname user))) + (th> :class "delete" (when (> (table-id user) 1) + (djcheck-box> :id "deleteItem" :class "deleteItem" :accessor 'users-page-delete-items + :value (table-id user) + :translator *integer-translator* + :multiple t))) + (td> (if (> (table-id user) 1) + (a> :id "edit" + :href "#" + :on-click (js-users-edit edit-user-action-link-id user) + (user-surname user) + " " + (user-firstname user)) + (format nil "~a ~a" + (user-surname user) + (user-firstname user)))) (td> (user-username user)) (td> (user-email user)) (td> :class (if (user-active user) "active" - "inactive") + "inactive") (if (user-active user) "yes" "no")) (td> (format nil "~{~a~^, ~}" (loop for role in (user-roles user) collect (role-name role))))))) (unless users - (djcheck-box> :id "deleteItem" - :accessor 'users-page-delete-items + (djcheck-box> :id "deleteItem" + :accessor 'users-page-delete-items :value 0 - :multiple t + :multiple t :translator *integer-translator* :style "display: none;")) (djaction-link> :static-id edit-user-action-link-id :style "display:none" :action 'users-page-edit-user :update-id (attribute-value (list edit-user-dialog-container-id result-container-id)) - :on-before-submit (ps:ps* `(.show (dijit.by-id ,spinner-id))) - :on-xhr-finish (remove #\newline (ps:ps* `(progn (.hide (dijit.by-id ,spinner-id)) - (.show (dijit.by-id ,edit-user-dialog-id))))) + :on-before-submit (js-users-show-spinner spinner-id) + :on-xhr-finish (js-users-action-edit spinner-id edit-user-dialog-id) "invisible") - (pager> :id "pager" + (pager> :id "pager" :update-component-id offset-id :page-size (users-page-list-size page) :total-items (users-page-users-total-count page) @@ -293,28 +406,26 @@ :on-close-click (ps:ps* `(.hide (dijit.by-id ,edit-user-dialog-id))) :update-id (attribute-value (list edit-user-form-id result-container-id)) :user (users-page-current-user page) - :on-before-submit (remove #\newline (ps:ps* `(progn (.show (dijit.by-id ,spinner-id)) - (dojo.add-class - (slot-value (dijit.by-id ,edit-user-dialog-id) 'container-node) - "hideForm")))) - :on-xhr-finish (ps:ps* `(progn (.hide (dijit.by-id ,spinner-id)) - (dojo.remove-class - (slot-value (dijit.by-id ,edit-user-dialog-id) 'container-node) - "hideForm")))) - (exception-monitor> :id "exceptionMonitor" :json-render-on-validation-errors-p edit-user-form-id)))))) + :on-before-submit (js-users-edit-users-before-submit spinner-id edit-user-dialog-id) + :on-xhr-finish (js-users-edit-users-xhr-finish spinner-id edit-user-dialog-id)) + (exception-monitor> :id "exceptionMonitor" :json-render-on-validation-errors-p edit-user-form-id))) + (script> :type "text/javascript" + (js-users-clean-excpetions) + (js-no-exceptions-p))))) (defmethod users-page-delete-users ((page users-page)) - (let ((user-id-list (users-page-delete-items page)) + (let ((user-id-list (remove-if #'(lambda (item) (= item 1)) (users-page-delete-items page))) (surname (users-page-surname page)) (firstname (users-page-firstname page)) - (username (user-username page)) + (username (users-page-username page)) (email (users-page-email page)) (active (users-page-active page)) (roles (users-page-roles page))) - (log-message :info "...deleting") - (delete-by-id 'user user-id-list) + (log-message :info "...deleting users ~a" user-id-list) + (when user-id-list + (delete-by-id 'user user-id-list)) (setf (users-page-delete-items page) ()) - (multiple-value-bind (users total-size) + (multiple-value-bind (users total-size) (find-users :offset (users-page-offset page) :limit (users-page-list-size page) :surname (null-when-empty surname) @@ -322,7 +433,7 @@ :username username :email (null-when-empty email) :active active - :role-names (null-when-empty roles) + :role-names roles :sorting (users-page-sorting page)) (setf (users-page-users page) users (users-page-users-total-count page) total-size)))) @@ -335,7 +446,7 @@ (active (users-page-active page)) (roles (users-page-roles page))) (log-message :info "???? ~a" roles) - (multiple-value-bind (users total-size) + (multiple-value-bind (users total-size) (find-users :offset (users-page-offset page) :limit (users-page-list-size page) :surname (null-when-empty surname) @@ -351,7 +462,7 @@ (defmethod page-before-render ((page users-page)) (unless (page-req-parameter page *rewind-parameter*) - (multiple-value-bind (users total-size) + (multiple-value-bind (users total-size) (find-users :sorting (users-page-sorting page) :offset 0 :limit (users-page-list-size page)) @@ -359,8 +470,8 @@ (users-page-users-total-count page) total-size)))) -(lisplet-register-function-location *dojo-demo-lisplet* - (make-page-renderer 'users-page #'claw-post-parameters #'claw-get-parameters) +(lisplet-register-function-location *dojo-demo-lisplet* + (make-page-renderer 'users-page #'claw-post-parameters #'claw-get-parameters) "users.html") (lisplet-protect *dojo-demo-lisplet* "users.html" '("administrator" "user")) Added: trunk/main/claw-demo/src/main.lisp ============================================================================== --- (empty file) +++ trunk/main/claw-demo/src/main.lisp Tue Oct 21 12:45:47 2008 @@ -0,0 +1,42 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- +;;; $Header: src/main.lisp $ + +;;; Copyright (c) 2008, Andrea Chiumenti. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(in-package :claw-demo) + +(defun demo-setup () + "Initializes the demo database" + (demo-setup)) + +(defun demo-start () + "Starts the demo on port 4242 \(for http) and 4343 \(for https)" + (claw-demo-frontend::djstart)) + +(defun demo-stop () + "Stops the demo listening on 4242 and 4343 ports" + (claw-demo-frontend::djstop)) \ No newline at end of file Added: trunk/main/claw-demo/src/packages.lisp ============================================================================== --- (empty file) +++ trunk/main/claw-demo/src/packages.lisp Tue Oct 21 12:45:47 2008 @@ -0,0 +1,38 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- +;;; $Header: src/package.lisp $ + +;;; Copyright (c) 2008, Andrea Chiumenti. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(in-package :cl-user) + + +(defpackage :claw-demo + (:use :cl :claw-demo-backend :claw-demo-frontend) + (:documentation "A demo application for CLAW") + (:export #:demo-setup + #:demo-start + #:demo-stop)) \ No newline at end of file From achiumenti at common-lisp.net Tue Oct 21 14:10:44 2008 From: achiumenti at common-lisp.net (Andrea Chiumenti) Date: Tue, 21 Oct 2008 14:10:44 +0000 Subject: [claw-cvs] r127 - trunk/main/claw-demo/src/frontend Message-ID: Author: achiumenti Date: Tue Oct 21 14:10:44 2008 New Revision: 127 Log: several bugfixes and enhancements Modified: trunk/main/claw-demo/src/frontend/main.lisp Modified: trunk/main/claw-demo/src/frontend/main.lisp ============================================================================== --- trunk/main/claw-demo/src/frontend/main.lisp (original) +++ trunk/main/claw-demo/src/frontend/main.lisp Tue Oct 21 14:10:44 2008 @@ -42,7 +42,9 @@ (defvar *ht-connector* (make-instance 'hunchentoot-connector :address "localhost" :port 4242 - :sslport 4343)) + :sslport 4343 + :ssl-certificate-file #P "/etc/apache2/ssl/server.crt" + :ssl-privatekey-file #P "/etc/apache2/ssl/server.key")) (defvar *sm* (make-instance 'default-session-manager)) From achiumenti at common-lisp.net Tue Oct 21 15:41:04 2008 From: achiumenti at common-lisp.net (Andrea Chiumenti) Date: Tue, 21 Oct 2008 15:41:04 +0000 Subject: [claw-cvs] r128 - trunk/main/claw-demo/src Message-ID: Author: achiumenti Date: Tue Oct 21 15:41:03 2008 New Revision: 128 Log: renaming db creation function Modified: trunk/main/claw-demo/src/main.lisp Modified: trunk/main/claw-demo/src/main.lisp ============================================================================== --- trunk/main/claw-demo/src/main.lisp (original) +++ trunk/main/claw-demo/src/main.lisp Tue Oct 21 15:41:03 2008 @@ -29,7 +29,7 @@ (in-package :claw-demo) -(defun demo-setup () +(defun demo-create-db () "Initializes the demo database" (demo-setup)) From achiumenti at common-lisp.net Tue Oct 21 15:50:47 2008 From: achiumenti at common-lisp.net (Andrea Chiumenti) Date: Tue, 21 Oct 2008 15:50:47 +0000 Subject: [claw-cvs] r129 - trunk/main/claw-demo/src Message-ID: Author: achiumenti Date: Tue Oct 21 15:50:47 2008 New Revision: 129 Log: package update Modified: trunk/main/claw-demo/src/packages.lisp Modified: trunk/main/claw-demo/src/packages.lisp ============================================================================== --- trunk/main/claw-demo/src/packages.lisp (original) +++ trunk/main/claw-demo/src/packages.lisp Tue Oct 21 15:50:47 2008 @@ -33,6 +33,6 @@ (defpackage :claw-demo (:use :cl :claw-demo-backend :claw-demo-frontend) (:documentation "A demo application for CLAW") - (:export #:demo-setup + (:export #:demo-create-db #:demo-start #:demo-stop)) \ No newline at end of file From achiumenti at common-lisp.net Thu Oct 30 08:37:37 2008 From: achiumenti at common-lisp.net (Andrea Chiumenti) Date: Thu, 30 Oct 2008 08:37:37 +0000 Subject: [claw-cvs] r130 - trunk/main/claw/src Message-ID: Author: achiumenti Date: Thu Oct 30 08:37:36 2008 New Revision: 130 Log: several bugfixes and enhancements Modified: trunk/main/claw/src/session-manager.lisp Modified: trunk/main/claw/src/session-manager.lisp ============================================================================== --- trunk/main/claw/src/session-manager.lisp (original) +++ trunk/main/claw/src/session-manager.lisp Thu Oct 30 08:37:36 2008 @@ -102,7 +102,7 @@ :reader session-user-agent :documentation "The incoming 'User-Agent' header that was sent when this session was created.") - (remote-addr :initform (connector-real-remote-addr (clawserver-connector *clawserver*)) + (remote-addr :initform (connector-remote-addr (clawserver-connector *clawserver*));(connector-real-remote-addr (clawserver-connector *clawserver*)) :reader session-remote-addr :documentation "The remote IP address of the client when this sessions was started as returned by REAL-REMOTE-ADDR.") From achiumenti at common-lisp.net Thu Oct 30 09:51:04 2008 From: achiumenti at common-lisp.net (Andrea Chiumenti) Date: Thu, 30 Oct 2008 09:51:04 +0000 Subject: [claw-cvs] r131 - trunk/main/claw-html.dojo/src Message-ID: Author: achiumenti Date: Thu Oct 30 09:51:04 2008 New Revision: 131 Log: several bugfixes and enhancements Modified: trunk/main/claw-html.dojo/src/djxpassword.lisp Modified: trunk/main/claw-html.dojo/src/djxpassword.lisp ============================================================================== --- trunk/main/claw-html.dojo/src/djxpassword.lisp (original) +++ trunk/main/claw-html.dojo/src/djxpassword.lisp Thu Oct 30 09:51:04 2008 @@ -36,12 +36,6 @@ (:default-initargs :dojo-type "dojox.form.PasswordValidator" :required t) (:metaclass metacomponent)) -(defmethod wcomponent-after-rewind :after ((obj djxpassword-validator) (p page)) - (claw:log-message :info "PPPPPPPPPP> ~a ::: ~a" - (translated-value obj) - (multiple-value-list (claw-html::component-id-and-value obj))) - ) - (defmethod wcomponent-template ((obj djxpassword-validator)) (let ((required (djxpassword-validator-required obj))) (div> :static-id (htcomponent-client-id obj)