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
