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