- claw-cvs@common-lisp.net - mailman3.common-lisp.net

[claw-cvs] r105 - trunk/main/claw-demo/src/frontend/docroot/css
by achiumenti＠common-lisp.net 01 Oct '08

01 Oct '08

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

1 0

[claw-cvs] r104 - trunk/main/claw-demo/src/frontend/components
by achiumenti＠common-lisp.net 01 Oct '08

01 Oct '08

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

1 0

[claw-cvs] r103 - trunk/main/claw-demo/src/frontend
by achiumenti＠common-lisp.net 01 Oct '08

01 Oct '08

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")) +

1 0

[claw-cvs] r102 - trunk/main/claw-demo/src/frontend
by achiumenti＠common-lisp.net 01 Oct '08

01 Oct '08

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))

1 0

[claw-cvs] r101 - trunk/main/claw-demo/src/backend
by achiumenti＠common-lisp.net 01 Oct '08

01 Oct '08

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.

1 0

[claw-cvs] r100 - trunk/main/claw-html.dojo/src
by achiumenti＠common-lisp.net 01 Oct '08

01 Oct '08

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))

1 0

[claw-cvs] r99 - trunk/main/claw-html/src
by achiumenti＠common-lisp.net 01 Oct '08

01 Oct '08

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 <input> and <select>) client-id and the associated value. -When FROM-REQUEST-P is not null, the value is retrived from the http request by its name, from the associated reader or accessor when nil")) +The value may be retrived from the http request by its name, from the associated reader or accessor when nil if no relative request parameter is set")) (defgeneric label (cinput) (:documentation "Returns the label that describes the component. It's also be used when component validation fails. If it's a function it is funcalled")) @@ -233,8 +233,14 @@ :documentation "The object hoding the property mapped to the current input html component. When nil the owner page is used.") (css-class :initarg :class :reader css-class - :documentation "the html component class attribute")) - (:default-initargs :multiple nil :writer nil :reader nil :accessor nil :class nil + :documentation "the html component class attribute") + (name :initarg :name + :reader base-cinput-name + :documentation "When specified the name tag attribute, otherwise the given component id is used") + (empty-to-null-p :initarg :empty-to-null-p + :reader base-cinput-empty-to-null-p + :documentation "When not NIL and empty string is threated as a NIL value")) + (:default-initargs :name nil :multiple nil :writer nil :reader nil :accessor nil :class nil :empty-to-null-p t :label nil :translator *simple-translator* :validator nil :visit-object *claw-current-page*) (:documentation "Class inherited from both CINPUT and CSELECT")) @@ -245,14 +251,15 @@ label))) (defmethod name-attr ((cinput base-cinput)) - (htcomponent-client-id cinput)) + (or (base-cinput-name cinput) + (htcomponent-client-id cinput))) (defclass cinput (base-cinput) ((input-type :initarg :type :reader input-type :documentation "The html <input> 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))

1 0

[claw-cvs] r98 - trunk/main/claw/src
by achiumenti＠common-lisp.net 01 Oct '08

01 Oct '08

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)))))))))

1 0

[claw-cvs] r97 - trunk/main/claw-demo/test/backend
by achiumenti＠common-lisp.net 18 Sep '08

18 Sep '08

Author: achiumenti Date: Thu Sep 18 09:32:48 2008 New Revision: 97 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 Thu Sep 18 09:32:48 2008 @@ -29,198 +29,199 @@ (in-package :claw-demo-backend) -(lift:deftestsuite claw-demo-backend-testsuite () - () - (:setup (let ((*default-database* - (db-connect '("127.0.0.1" "claw-demo-test" "claw-demo" "demo")))) - (drop-claw-demo-tables) - (create-claw-demo-tables))) - (:teardown (db-disconnect))) - -(lift:addtest (claw-demo-backend-testsuite) - simple-insert - (let ((role (make-instance 'role :name "admin" :description "Administration role"))) - (update-db-item role) - (lift:ensure (table-id role)) - (setf role (first (find-vo 'role - :where (sql-operation 'like - (sql-expression-upper :attribute (slot-column-name 'role 'name)) - (string-upcase "admiN"))))) - (lift:ensure role) - (lift:ensure (= (table-version role) 0)) - (setf (role-description role) "Administration") - (update-db-item role) - (setf role (first (find-vo 'role - :where (sql-operation 'like - (sql-expression-upper :attribute (slot-column-name 'role 'name)) - (string-upcase "admiN"))))) - (lift:ensure (> (table-version role) 0)))) - -(lift:addtest (claw-demo-backend-testsuite) - simple-empty-table - (let* ((name "simple-empty-table") - (role (make-instance 'role :name name))) - (update-db-item role) - (lift:ensure (find-vo 'role) :report "Role table is empty") - (delete-class-records 'role) - (let ((rs (find-vo 'role :refresh t))) - (lift:ensure-null rs :report "Role table is NOT empty ~a" :arguments ((length rs)))))) - -(lift:addtest (claw-demo-backend-testsuite) - user-roles-relation - (let ((role1 (make-instance 'role :name "role1")) - (role2 (make-instance 'role :name "role2")) - (user (make-instance 'user :firstname "Jhon" - :surname "Doe" - :username "jd" - :password "pwd" - :email "jd(a)new.com"))) - (delete-class-records 'user-role) - (delete-class-records 'user) - (delete-class-records 'role) - (update-db-item role1) - (update-db-item role2) - (lift:ensure (= (length (find-vo 'role)) 2) :report "Role table size is not 2") - (setf (user-roles user) (list role1 role2)) ;here we add two roles to the user - (update-db-item user) - (multiple-value-bind (records count) - (find-vo 'user) - (lift:ensure (= count 1)) - (lift:ensure (= (length (user-roles (first records))) 2))) - (setf (user-username user) "changed") ;here we ensure that the user doesn't loose roles after a change - (update-db-item user) - (multiple-value-bind (records count) - (find-vo 'user) - (lift:ensure (= count 1)) - (lift:ensure (= (length (user-roles (first records))) 2))))) - -(lift:addtest (claw-demo-backend-testsuite) - user-roles-fk - (let ((role1 (make-instance 'role :name "roleA")) - (role2 (make-instance 'role :name "roleB")) - (user (make-instance 'user :firstname "Jhon" - :surname "Doe" - :username "jd" - :password "pwd" - :email "jd(a)new.com"))) - (delete-class-records 'user) - (delete-class-records 'role) - (update-db-item role1) - (update-db-item role2) - (setf (user-roles user) (list role1 role2)) - (update-db-item user) - (delete-class-records 'role - :where (sql-operation '= - (sql-expression :attribute (slot-column-name 'role 'name)) - "roleA")) - (setf user (reload-db-item user)) - (lift:ensure (= (length (user-roles user)) 1) - :report "Expected 1 role for test user, found ~d" - :arguments ((length (user-roles user)))) - (lift:ensure (= (length (role-users role2)) 1) - :report "Expected 1 user for test role \"roleB\", found ~d" - :arguments ((length (role-users role2)))) - (delete-class-records 'user) - (lift:ensure (null (find-vo 'user)) - :report "Users table is not empty") - (setf role2 (reload-db-item role2)) - (let ((role-users (role-users role2))) - (lift:ensure (null role-users) - :report "Role \"roleB\" still contains references to ~d user\(s)" - :arguments ((length role-users)))))) - -(lift:addtest (claw-demo-backend-testsuite) - cusromer-creation - (let ((customer (make-instance 'customer - :name1 "Andrea" - :name2 "Chiumenti" - :email "a.chiumenti(a)new.com" - :phone1 "+393900001" - :phone2 "+393900002" - :phone3 "+393900003" - :fax "+393900010" - :vat "9999999999" - :code1 "code1" - :code1 "code2" - :code1 "code3" - :code1 "code4" - :addresses (list (make-instance 'customer-address - :address "St. Foo, 1" - :city "Milano" - :zip "20100" - :state "MI" - :country "ITALY") - (make-instance 'customer-address - :address-type 1 - :address "St. Bar, 1" - :zip "20100" - :city "Milano" - :state "MI" - :country "ITALY"))))) - (delete-class-records 'customer) - (update-db-item customer) - (let ((addresses (find-vo 'customer-address - :where (sql-operation '= - (sql-expression :attribute (slot-column-name 'customer-address 'customer-id)) - (table-id customer))))) - (lift:ensure (= (length addresses) - 2) - :report "Expected 2 customer address records, found ~d" - :arguments ((length addresses))) - ;;testing referential integrity - (delete-db-item customer) - (let ((addresses (find-vo 'customer-address))) - (lift:ensure-null addresses - :report "Table cutomer-addresses expected to be empty. Found ~d records." - :arguments ((length addresses))))))) - -(lift:addtest (claw-demo-backend-testsuite) - find-user-by-name - (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(a)new.com" - :roles (list admin-role user-role))) - (lift:ensure (find-user-by-name "admin")))) - -(lift:addtest (claw-demo-backend-testsuite) - like-operation - (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(a)new.com" - :roles (list admin-role user-role))) - (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-customers - (let ((customer (make-instance 'customer - :name1 "Andrea" - :name2 "Chiumenti" - :email "a.chiumenti(a)new.com" - :phone1 "+393900001" - :phone2 "+393900002" - :phone3 "+393900003" - :fax "+393900010" - :vat "9999999999" - :code1 "code1" - :code1 "code2" - :code1 "code3" - :code1 "code4"))) - (delete-class-records 'customer) - (update-db-item customer) - (lift:ensure (find-customers :name1 "andrea")) - (lift:ensure (find-customers :name1 "andrea" :name2 "ch*")) - (lift:ensure (find-customers)))) + (lift:deftestsuite claw-demo-backend-testsuite () + () + (:setup (progn (setf *claw-demo-db* + (db-connect '("127.0.0.1" "claw-demo-test" "claw-demo" "demo"))) + (drop-claw-demo-tables) + (create-claw-demo-tables))) + (:teardown (db-disconnect))) + + (lift:addtest (claw-demo-backend-testsuite) + simple-insert + (let ((role (make-instance 'role :name "admin" :description "Administration role"))) + (update-db-item role) + (lift:ensure (table-id role)) + (setf role (first (find-vo 'role + :where (sql-operation 'like + (sql-expression-upper :attribute (slot-column-name 'role 'name)) + (string-upcase "admiN"))))) + (lift:ensure role) + (lift:ensure (= (table-version role) 0)) + (setf (role-description role) "Administration") + (update-db-item role) + (setf role (first (find-vo 'role + :where (sql-operation 'like + (sql-expression-upper :attribute (slot-column-name 'role 'name)) + (string-upcase "admiN"))))) + (lift:ensure (> (table-version role) 0)))) + + (lift:addtest (claw-demo-backend-testsuite) + simple-empty-table + (let* ((name "simple-empty-table") + (role (make-instance 'role :name name))) + (update-db-item role) + (lift:ensure (find-vo 'role) :report "Role table is empty") + (delete-class-records 'role) + (let ((rs (find-vo 'role :refresh t))) + (lift:ensure-null rs :report "Role table is NOT empty ~a" :arguments ((length rs)))))) + + (lift:addtest (claw-demo-backend-testsuite) + user-roles-relation + (let ((role1 (make-instance 'role :name "role1")) + (role2 (make-instance 'role :name "role2")) + (user (make-instance 'user :firstname "Jhon" + :surname "Doe" + :username "jd" + :password "pwd" + :email "jd(a)new.com"))) + (delete-class-records 'user-role) + (delete-class-records 'user) + (delete-class-records 'role) + (update-db-item role1) + (update-db-item role2) + (lift:ensure (= (length (find-vo 'role)) 2) :report "Role table size is not 2") + (setf (user-roles user) (list role1 role2)) ;here we add two roles to the user + (update-db-item user) + (multiple-value-bind (records count) + (find-vo 'user) + (lift:ensure (= count 1)) + (lift:ensure (= (length (user-roles (first records))) 2))) + (setf (user-username user) "changed") ;here we ensure that the user doesn't loose roles after a change + (update-db-item user) + (multiple-value-bind (records count) + (find-vo 'user) + (lift:ensure (= count 1)) + (lift:ensure (= (length (user-roles (first records))) 2))))) + + + (lift:addtest (claw-demo-backend-testsuite) + user-roles-fk + (let ((role1 (make-instance 'role :name "roleA")) + (role2 (make-instance 'role :name "roleB")) + (user (make-instance 'user :firstname "Jhon" + :surname "Doe" + :username "jd" + :password "pwd" + :email "jd(a)new.com"))) + (delete-class-records 'user) + (delete-class-records 'role) + (update-db-item role1) + (update-db-item role2) + (setf (user-roles user) (list role1 role2)) + (update-db-item user) + (delete-class-records 'role + :where (sql-operation '= + (sql-expression :attribute (slot-column-name 'role 'name)) + "roleA")) + (setf user (reload-db-item user)) + (lift:ensure (= (length (user-roles user)) 1) + :report "Expected 1 role for test user, found ~d" + :arguments ((length (user-roles user)))) + (lift:ensure (= (length (role-users role2)) 1) + :report "Expected 1 user for test role \"roleB\", found ~d" + :arguments ((length (role-users role2)))) + (delete-class-records 'user) + (lift:ensure (null (find-vo 'user)) + :report "Users table is not empty") + (setf role2 (reload-db-item role2)) + (let ((role-users (role-users role2))) + (lift:ensure (null role-users) + :report "Role \"roleB\" still contains references to ~d user\(s)" + :arguments ((length role-users)))))) + + (lift:addtest (claw-demo-backend-testsuite) + cusromer-creation + (let ((customer (make-instance 'customer + :name1 "Andrea" + :name2 "Chiumenti" + :email "a.chiumenti(a)new.com" + :phone1 "+393900001" + :phone2 "+393900002" + :phone3 "+393900003" + :fax "+393900010" + :vat "9999999999" + :code1 "code1" + :code1 "code2" + :code1 "code3" + :code1 "code4" + :addresses (list (make-instance 'customer-address + :address "St. Foo, 1" + :city "Milano" + :zip "20100" + :state "MI" + :country "ITALY") + (make-instance 'customer-address + :address-type 1 + :address "St. Bar, 1" + :zip "20100" + :city "Milano" + :state "MI" + :country "ITALY"))))) + (delete-class-records 'customer) + (update-db-item customer) + (let ((addresses (find-vo 'customer-address + :where (sql-operation '= + (sql-expression :attribute (slot-column-name 'customer-address 'customer-id)) + (table-id customer))))) + (lift:ensure (= (length addresses) + 2) + :report "Expected 2 customer address records, found ~d" + :arguments ((length addresses))) + ;;testing referential integrity + (delete-db-item customer) + (let ((addresses (find-vo 'customer-address))) + (lift:ensure-null addresses + :report "Table cutomer-addresses expected to be empty. Found ~d records." + :arguments ((length addresses))))))) + + (lift:addtest (claw-demo-backend-testsuite) + find-user-by-name + (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(a)new.com" + :roles (list admin-role user-role))) + (lift:ensure (find-user-by-name "admin")))) + + (lift:addtest (claw-demo-backend-testsuite) + like-operation + (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(a)new.com" + :roles (list admin-role user-role))) + (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-customers + (let ((customer (make-instance 'customer + :name1 "Andrea" + :name2 "Chiumenti" + :email "a.chiumenti(a)new.com" + :phone1 "+393900001" + :phone2 "+393900002" + :phone3 "+393900003" + :fax "+393900010" + :vat "9999999999" + :code1 "code1" + :code1 "code2" + :code1 "code3" + :code1 "code4"))) + (delete-class-records 'customer) + (update-db-item customer) + (lift:ensure (find-customers :name1 "andrea")) + (lift:ensure (find-customers :name1 "andrea" :name2 "ch*")) + (lift:ensure (find-customers))))

1 0

[claw-cvs] r96 - trunk/main/claw-demo/src/frontend/docroot/img
by achiumenti＠common-lisp.net 18 Sep '08

18 Sep '08

Author: achiumenti Date: Thu Sep 18 09:32:34 2008 New Revision: 96 Modified: trunk/main/claw-demo/src/frontend/docroot/img/clawHead.png Log: several bugfixes and enhancements Modified: trunk/main/claw-demo/src/frontend/docroot/img/clawHead.png ============================================================================== Binary files. No diff available.

1 0