From achiumenti at common-lisp.net  Mon Sep  1 15:32:50 2008
From: achiumenti at common-lisp.net (achiumenti at common-lisp.net)
Date: Mon,  1 Sep 2008 11:32:50 -0400 (EDT)
Subject: [claw-cvs] r77 - in trunk/main/claw-demo/src: backend frontend
	frontend/docroot/css frontend/docroot/img
Message-ID: <20080901153250.B0F0D4E018@common-lisp.net>

Author: achiumenti
Date: Mon Sep  1 11:32:49 2008
New Revision: 77

Added:
   trunk/main/claw-demo/src/frontend/docroot/img/asc_arrow.gif   (contents, props changed)
   trunk/main/claw-demo/src/frontend/docroot/img/desc_arrow.gif   (contents, props changed)
   trunk/main/claw-demo/src/frontend/docroot/img/sort_arrow.gif   (contents, props changed)
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
   trunk/main/claw-demo/src/frontend/auth.lisp
   trunk/main/claw-demo/src/frontend/customers.lisp
   trunk/main/claw-demo/src/frontend/docroot/css/style.css
   trunk/main/claw-demo/src/frontend/login.lisp
Log:
demo update

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	Mon Sep  1 11:32:49 2008
@@ -58,6 +58,8 @@
 
 
 (defun slot-column-name (symbol-class slot-name)
+  (when (stringp slot-name)
+    (setf slot-name (intern (string-upcase slot-name) 'claw-demo-backend)))
   (let ((slot (loop for slot in (closer-mop:class-slots (find-class symbol-class))
                  when (and (typep slot 'clsql-sys::view-class-effective-slot-definition)
                            (equal (closer-mop:slot-definition-name slot) slot-name))

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	Mon Sep  1 11:32:49 2008
@@ -44,6 +44,8 @@
            #:db-connect
            #:db-disconnect
            ;; --- Value objects --- ;;
+           #:copy-values-by-accessors
+           #:slot-column-name
            #:base-table
            #:table-id
            #:table-version
@@ -97,6 +99,7 @@
            #:update-db-item
            #:delete-db-item
            #:reload-db-item
+           #:find-by-id
            #:delete-class-records
            #:find-user-by-name
            #:find-customers))
\ 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	Mon Sep  1 11:32:49 2008
@@ -54,7 +54,14 @@
   (with-transaction (:database *claw-demo-db*)
     (let ((table-name (symbol-name (view-table (find-class symbol-class)))))
       (delete-records :from table-name :where where))))
-  
+
+(defun build-order-by (fields)
+  (loop for field in fields
+       collect (if (listp field)
+                   (list (sql-expression :attribute (first field))
+                         (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)
   "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."
   (values
@@ -62,7 +69,7 @@
            :where where
            :group-by group-by
            :having having
-           :order-by order-by
+           :order-by (when order-by (build-order-by order-by))
            :flatp t
            :refresh refresh
            :offset offset
@@ -75,18 +82,21 @@
                  :from (view-table (find-class symbol-class))
                  :where where
                  :group-by group-by
-                 :having having
+                 :having having                 
                  :flatp t
                  :refresh refresh)))
 
+(defun find-by-id (symbol-class id)
+  (first (select symbol-class
+                   :where (sql-operation '= (slot-column-name symbol-class 'id) id)
+                   :flatp t
+                   :refresh t)))
+
 (defmethod reload-db-item ((item base-table))
   "Reloads item data selecting the item by its id. This function isn't destructive"
   (let ((symbol-class (class-name (class-of item)))
         (id (table-id item)))
-    (first (select symbol-class
-                   :where [= [slot-value symbol-class 'id] id]
-                   :flatp t
-                   :refresh t))))
+    (find-by-id symbol-class id)))
 
 (defun find-user-by-name (name)
   (let ((where (sql-operation '= (slot-column-name 'user 'username) name)))
@@ -116,6 +126,7 @@
              :limit limit
              :where (if (> (length where) 1)
                         (apply #'sql-operation (cons 'and where))
-                        (first where)))))
+                        (first where))
+             :order-by sorting)))
 
 #.(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	Mon Sep  1 11:32:49 2008
@@ -29,6 +29,13 @@
 
 (in-package :claw-demo-backend)
 
+(defmacro copy-values-by-accessors (dest src &rest accessors)
+  (let ((dest-src-pairs
+         (loop for accessor in accessors
+            collect `(,accessor ,dest)
+            collect `(,accessor ,src))))
+    `(setf , at dest-src-pairs)))
+
 (def-view-class base-table ()
   ((id :db-kind :key
        :accessor table-id
@@ -222,7 +229,7 @@
           :accessor customer-code4
           :type (varchar 50)
           :db-constraints :unique))
-  (:default-initargs :name2 nil :email nil
+  (:default-initargs :name1 nil :name2 nil :email nil
                      :phone1 nil :phone2 nil :phone3 nil
                      :fax nil
                      :vat nil :code1 nil :code2 nil :code3 nil :code4 nil)

Modified: trunk/main/claw-demo/src/frontend/auth.lisp
==============================================================================
--- trunk/main/claw-demo/src/frontend/auth.lisp	(original)
+++ trunk/main/claw-demo/src/frontend/auth.lisp	Mon Sep  1 11:32:49 2008
@@ -49,11 +49,9 @@
                   (claw-parameter "password")))
     (unwind-protect 
          (progn
-           (log-message :info "ppppppppppppppp")
            (db-connect)
            (let ((user-vo (find-user-by-name user)))
              (when (and user-vo (string= password (user-password user-vo)))
-               (log-message :info "----> ~a " (user-roles user-vo))
                (make-instance 'demo-principal
                               :name (user-username user-vo)
                               :firstname (user-firstname user-vo)

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	Mon Sep  1 11:32:49 2008
@@ -33,17 +33,17 @@
 
 (defclass edit-customer (wcomponent)
   ((customer :initarg :customer
-             :accessor edit-customer-customer)
+                      :accessor edit-customer-save-customer)
    (on-before-submit :initarg :on-before-submit
                      :accessor on-before-submit)
    (on-xhr-finish :initarg :on-xhr-finish
                   :accessor on-xhr-finish))
   (:metaclass metacomponent)
-  (:default-initargs :on-before-submit nil :on-xhr-finish nil :customer (make-instance 'customer)))
+  (:default-initargs :on-before-submit nil :on-xhr-finish nil))
 
 (defmethod wcomponent-template ((obj edit-customer))
   (let ((id (htcomponent-client-id obj))
-        (visit-object (edit-customer-customer obj)))
+        (visit-object (edit-customer-save-customer obj)))
     (djform> :static-id id
              :class "customerForm"
              :update-id id
@@ -51,8 +51,13 @@
              :action-object obj
              :on-before-submit (on-before-submit obj)
              :on-xhr-finish (on-xhr-finish obj)
-             (cinput> :type "hidden" :visit-object visit-object
+             (cinput> :id "customerid"
+                      :type "hidden" :visit-object visit-object
+                      :translator *integer-translator*
                       :accessor 'table-id)
+             (cinput> :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
@@ -117,27 +122,53 @@
              (div> :class "buttons"
                    (djsubmit-button> :value "Save")))))
 
+
+(defun customer-save (customer)
+  (let ((db-customer (find-by-id 'customer (table-id customer))))
+    (copy-values-by-accessors db-customer customer
+                              table-version
+                              customer-name1
+                              customer-name2
+                              customer-email
+                              customer-phone1 customer-phone2 customer-phone3
+                              customer-fax
+                              customer-vat
+                              customer-code1 customer-code2 customer-code3 customer-code4)
+    (update-db-item db-customer)
+    db-customer))
+
 (defmethod edit-customer-save ((obj edit-customer))
-  (let ((id (htcomponent-client-id obj)))
+  (let ((id (htcomponent-client-id obj))
+        (customer (edit-customer-save-customer obj)))
     (handler-case
-        (update-db-item (edit-customer-customer obj))
-      (error (cond)
-        (add-validation-error id cond)))))
+        (setf (edit-customer-save-customer obj) (customer-save 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-users (customers-page))
+(defgeneric customers-page-find-customers (customers-page))
 
 (defgeneric customers-page-offset-reset (customers-page))
 
+(defgeneric customers-page-edit-customer (customers-page))
+
+(defgeneric customers-page-sorting (customers-page))
+
 (defclass customers-page (db-page) 
   ((customers :initform nil
               :accessor customers-page-customers)
+   (current-customer :initform (make-instance 'customer)
+                     :accessor customer-page-current-customer)
+   (customer-edit-dialog-title :initform "Add new cutomer"
+                               :accessor customers-page-customer-edit-dialog-title)
    (customers-total-count :initform 0
                           :accessor customers-page-customers-total-count)
    (list-size :initarg :list-size
               :accessor customers-page-list-size)
    (offset :initform 0
            :accessor customers-page-offset)
-   (name1 :initform ""
+   (name1 :initform "*"
           :accessor customers-page-name1)
    (name2 :initform ""
           :accessor customers-page-name2)
@@ -146,22 +177,55 @@
    (vat :initform ""
           :accessor customers-page-vat)
    (phone :initform ""
-          :accessor customers-page-phone))
+          :accessor customers-page-phone)
+   (sorting-column :initform "name1"
+          :accessor customers-page-sorting-column)
+   (sorting-order :initform "asc"
+          :accessor customers-page-sorting-order))
   (:default-initargs :list-size 20))
 
 (defmethod customers-page-offset-reset ((page customers-page)) 0)
 
+(defmethod customers-page-edit-customer ((page customers-page)) 
+  (let ((customer-id (parse-integer (claw-parameter "customerid")))
+        (current-customer))
+    (setf current-customer (find-by-id 'customer customer-id))
+    (setf (customers-page-customer-edit-dialog-title page) "Edit customer")
+    (when current-customer
+      (setf (customer-page-current-customer page) current-customer))))
+
+(defmethod customers-page-sorting ((page customers-page))
+  (let ((direction (if (string-equal "asc" (customers-page-sorting-order page))
+                       :asc
+                       :desc))
+        (fields (if (string-equal "name1" (customers-page-sorting-column page))
+                    (list (slot-column-name 'customer "name1") 
+                          (slot-column-name 'customer "name2"))
+                    (list (slot-column-name 'customer "email") 
+                          (slot-column-name 'customer "name1") 
+                          (slot-column-name 'customer "name2")))))
+    (loop for field in fields
+       collect (list field direction))))
+
 (defmethod page-content ((page customers-page))
   (let ((spinner-id (generate-id "spinner"))
         (form-id (generate-id "customersForm"))
         (customers (customers-page-customers page))
-        (offset-id (generate-id "offset")))
+        (offset-id (generate-id "offset"))
+        (edit-customer-dialog-container-id (generate-id "customerDialogContainer"))
+        (edit-customer-dialog-id (generate-id "customerDialog"))
+        (edit-customer-form-id (generate-id "customerForm"))
+        (sorting-column-id (generate-id "sorting-column"))
+        (sorting-order-id (generate-id "sorting-order"))
+        (edit-customer-action-link-id (generate-id "editCustomer"))
+        (sort-field (customers-page-sorting-column page))
+        (sort-direction (customers-page-sorting-order page)))
     (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
-                             :action 'customers-page-find-users
+                             :action 'customers-page-find-customers
                              :update-id form-id
                              :on-before-submit (ps:ps* `(.show (dijit.by-id ,spinner-id)))
                              :on-xhr-finish (ps:ps* `(.hide (dijit.by-id ,spinner-id)))
@@ -180,30 +244,84 @@
                                             :translator *integer-translator*
                                             :reader 'customers-page-offset-reset
                                             :writer (attribute-value '(setf customers-page-offset)))
+                                   (cinput> :type "hidden"
+                                            :static-id sorting-column-id
+                                            :accessor 'customers-page-sorting-column)
+                                   (cinput> :type "hidden"
+                                            :static-id sorting-order-id
+                                            :accessor 'customers-page-sorting-order)
                                    (djsubmit-button> :id "search"
                                                      :value "Search"))
                              (table> :class "listTable"
                                      (tr> :class "header"
-                                          (th> :class "name" "Name")
-                                          (th> :class "email" "Email")
+                                          (th> :class "name" (span> :class (if (string-equal "name1" sort-field) 
+                                                                               (if (string-equal "asc" sort-direction)
+                                                                                   "sort sortAsc"
+                                                                                   "sort sortDesc")
+                                                                               "sort")
+                                                                    :on-click (remove #\newline (ps:ps* `(progn (setf (slot-value (dojo.by-id ,sorting-order-id) 'value) 
+                                                                                                                      (if (and (== (slot-value (dojo.by-id ,sorting-column-id) 'value) "name1")
+                                                                                                                               (== (slot-value (dojo.by-id ,sorting-order-id) 'value) "asc"))
+                                                                                                                          "desc"
+                                                                                                                          "asc"))
+                                                                                                                (setf (slot-value (dojo.by-id ,sorting-column-id) 'value) 
+                                                                                                                      "name1")
+                                                                                                                (.submit (dijit.by-id ,form-id))))) 
+                                                                    "Name"))
+                                          (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 "vat" "VAT")
                                           (th> :class "phone" "Phone"))
                                      (loop for customer in customers
                                         for index = 0 then (incf index)
                                         collect (tr> :class (if (evenp index) "item even" "item odd")
-                                                     (td> (customer-name1 customer)
-                                                          " "
-                                                          (customer-name2 customer))
+                                                     (td> (a> :id "edit"
+                                                              :href "#"
+                                                              :on-click (remove #\newline (ps:ps* `(progn (setf (slot-value (dijit.by-id ,edit-customer-action-link-id) 'parameters) 
+                                                                                                                (create "customerid" ,(table-id customer)))
+                                                                                                          (.click (dijit.by-id ,edit-customer-action-link-id)))))
+                                                              (customer-name1 customer)
+                                                              " "
+                                                              (customer-name2 customer)))
                                                      (td> (customer-email customer))
                                                      (td> (customer-vat customer))
                                                      (td> (customer-phone1 customer)))))
+                             (djaction-link> :static-id edit-customer-action-link-id
+                                             :style "display:none"
+                                             :action 'customers-page-edit-customer
+                                             :update-id edit-customer-dialog-container-id
+                                             :on-before-submit (ps:ps* `(.show (dijit.by-id ,spinner-id)))
+                                             :on-xhr-finish (remove #\newline (ps:ps* `(progn (.hide (dijit.by-id ,spinner-id))
+                                                                                              (.show (dijit.by-id ,edit-customer-dialog-id)))))
+                                             "invisible")
                              (pager> :id "pager" 
                                      :update-component-id offset-id
                                      :page-size (customers-page-list-size page)
                                      :total-items (customers-page-customers-total-count page)
-                                     :first-item-offset (customers-page-offset page))))))
+                                     :first-item-offset (customers-page-offset page)))
+                    (div> :static-id edit-customer-dialog-container-id
+                          (djdialog> :static-id edit-customer-dialog-id
+                                        :title (customers-page-customer-edit-dialog-title page)
+                                     (edit-customer> :static-id edit-customer-form-id
+                                                     :customer (customer-page-current-customer page)
+                                                     :on-before-submit (ps:ps* `(.show (dijit.by-id ,spinner-id)))
+                                                     :on-xhr-finish (ps:ps* `(.hide (dijit.by-id ,spinner-id)))
+                                                     :customer (customer-page-current-customer page))
+                                     (exception-monitor> :id "exceptionMonitor" :json-render-on-validation-errors-p edit-customer-form-id))))))
 
-(defmethod customers-page-find-users ((page customers-page))
+(defmethod customers-page-find-customers ((page customers-page))
   (let ((name1 (customers-page-name1 page))
         (name2 (customers-page-name2 page))
         (email (customers-page-email page))
@@ -216,14 +334,16 @@
                         :name2 (null-when-empty name2)
                         :email (null-when-empty email)
                         :vat (null-when-empty vat)
-                        :phone (null-when-empty phone))
+                        :phone (null-when-empty phone)
+                        :sorting (customers-page-sorting page))
       (setf (customers-page-customers page) customers
             (customers-page-customers-total-count page) total-size))))
 
 (defmethod page-before-render ((page customers-page))
   (unless (page-req-parameter page *rewind-parameter*)
     (multiple-value-bind (customers total-size) 
-        (find-customers :offset 0
+        (find-customers :sorting (customers-page-sorting page)
+                        :offset 0
                         :limit (customers-page-list-size page))
       (setf (customers-page-customers page) customers
             (customers-page-customers-total-count page) total-size))))

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	Mon Sep  1 11:32:49 2008
@@ -117,4 +117,33 @@
 }
 .searchParameters div.item span {
     display: block;
+}
+
+.customerForm .label span{
+    display:-moz-inline-stack;
+    display:inline-block;
+    width: 80px;
+    text-align: right;
+    padding-right: 15px;
+}
+
+.customerForm .buttons {
+    margin-top: 10px;
+    padding-top: 5px;
+    text-align: center;
+    border-top: 1px solid #BCD5F0;
+}
+
+.sort {
+    cursor: pointer;
+    padding-right: 15px;
+    background: url(../img/sort_arrow.gif) 100% 50% no-repeat;
+}
+
+.sortAsc {
+    background: url(../img/asc_arrow.gif) 100% 50% no-repeat;
+}
+
+.sortDesc {
+    background: url(../img/desc_arrow.gif) 100% 50% no-repeat;
 }
\ No newline at end of file

Added: trunk/main/claw-demo/src/frontend/docroot/img/asc_arrow.gif
==============================================================================
Binary file. No diff available.

Added: trunk/main/claw-demo/src/frontend/docroot/img/desc_arrow.gif
==============================================================================
Binary file. No diff available.

Added: trunk/main/claw-demo/src/frontend/docroot/img/sort_arrow.gif
==============================================================================
Binary file. No diff available.

Modified: trunk/main/claw-demo/src/frontend/login.lisp
==============================================================================
--- trunk/main/claw-demo/src/frontend/login.lisp	(original)
+++ trunk/main/claw-demo/src/frontend/login.lisp	Mon Sep  1 11:32:49 2008
@@ -39,7 +39,8 @@
 
 (defmethod page-content ((o login-page))
   (let ((login-result-id (generate-id "loginResult"))
-        (spinner-id (generate-id "spinner")))
+        (spinner-id (generate-id "spinner"))
+        (form-id (generate-id "login")))
     (site-template> :title "CLAW Demo login"
                     (djdialog> :id "loginDialog" 
                                :title "Login into system"
@@ -47,7 +48,8 @@
                                (djfloating-content> :static-id spinner-id
                                            (img> :alt "spinner"
                                                  :src "docroot/img/spinner.gif"))
-                               (djform> :id "login" 
+                               (djform> :static-id form-id 
+                                        :method "get"
                                         :class "loginForm"
                                         :action 'login-page-do-login
                                         :update-id login-result-id
@@ -67,7 +69,7 @@
                                                       :accessor 'login-page-password))
                                         (div> :class "buttonContainer"
                                               (djsubmit-button> :value "Login")
-                                              (exception-monitor> :id "exceptionMonitor")))
+                                              (exception-monitor> :id "exceptionMonitor" :json-render-on-validation-errors-p form-id)))
                                (div> :static-id login-result-id
                                      (redirect> :render-condition #'current-principal 
                                                 :id "redirect"
@@ -80,7 +82,6 @@
                                     :login-page-p t)
 
 (defmethod login-page-do-login ((page login-page))
-  (log-message :error "Performing login")
   (unless (login)
       (add-validation-error "login"
                             "Invalid user or password")))
\ No newline at end of file


From achiumenti at common-lisp.net  Mon Sep  1 15:34:52 2008
From: achiumenti at common-lisp.net (achiumenti at common-lisp.net)
Date: Mon,  1 Sep 2008 11:34:52 -0400 (EDT)
Subject: [claw-cvs] r79 - trunk/main/claw-html.dojo/src
Message-ID: <20080901153452.7C8E26630E@common-lisp.net>

Author: achiumenti
Date: Mon Sep  1 11:34:52 2008
New Revision: 79

Modified:
   trunk/main/claw-html.dojo/src/djbutton.lisp
   trunk/main/claw-html.dojo/src/djdialog.lisp
   trunk/main/claw-html.dojo/src/djform.lisp
   trunk/main/claw-html.dojo/src/djlink.lisp
   trunk/main/claw-html.dojo/src/djtooltip.lisp
Log:
bufixs on form related components

Modified: trunk/main/claw-html.dojo/src/djbutton.lisp
==============================================================================
--- trunk/main/claw-html.dojo/src/djbutton.lisp	(original)
+++ trunk/main/claw-html.dojo/src/djbutton.lisp	Mon Sep  1 11:34:52 2008
@@ -33,7 +33,7 @@
   ()
   (:metaclass metacomponent)
   (:documentation "Class for dojo dijit.form.Button component. More info at http://api.dojotoolkit.org/")
-  (:default-initargs :dojo-type "dijit.form.Button"))
+  (:default-initargs :dojo-type "dijit.form.Button" :tag-name "button"))
 
 (defclass djdrop-down-button (djwidget)
   ()
@@ -67,8 +67,10 @@
   (let* ((id (htcomponent-client-id obj))
 	 (value (csubmit-value obj)))
     (djbutton> :static-id id
+               :type "submit"
+               :value value
                (wcomponent-informal-parameters obj)
-               value)))
+               (or (htcomponent-body obj) value))))
 
 (defmethod wcomponent-before-prerender ((obj djsubmit-button) (page page))
   (setf (djsubmit-button-form obj) (page-current-form page)))
@@ -76,13 +78,3 @@
 (defmethod wcomponent-before-render ((obj djsubmit-button) (page page))
   (setf (djsubmit-button-form obj) (page-current-form page)))
 
-(defmethod htcomponent-instance-initscript ((obj djsubmit-button))
-  (let ((id (htcomponent-client-id obj))
-        (form-id (htcomponent-client-id (djsubmit-button-form obj))))
-    (ps*
-     `(dojo.connect (dijit.by-id ,id)
-                    "onClick"
-                    (lambda (e) (let ((the-form (dijit.by-id ,form-id)))
-                                  (unless the-form
-                                    (setf the-form (dojo.by-id ,form-id)))
-                                  (.submit the-form)))))))

Modified: trunk/main/claw-html.dojo/src/djdialog.lisp
==============================================================================
--- trunk/main/claw-html.dojo/src/djdialog.lisp	(original)
+++ trunk/main/claw-html.dojo/src/djdialog.lisp	Mon Sep  1 11:34:52 2008
@@ -38,7 +38,9 @@
 (defclass djdialog (wcomponent)
   ()
   (:metaclass metacomponent)
-  (:documentation "Class for dojo dijit.Dialog component. More info at http://api.dojotoolkit.org/. It adds a HardLink so that the Dialog, that is moved inside body, may be referenced where it war originally placed, and so can be deleted from there"))
+  (:documentation "Class for dojo dijit.Dialog component. 
+You cannot directly call a json update on this component, but update its container instead!!!
+More info at http://api.dojotoolkit.org/. It adds a HardLink so that the Dialog, that is moved inside body, may be referenced where it war originally placed, and so can be deleted from there"))
 
 (defmethod wcomponent-template ((obj djdialog))
   (let ((id (htcomponent-client-id obj)))
@@ -57,7 +59,9 @@
 (defclass djdialog-underlay (wcomponent)
   ()
   (:metaclass metacomponent)
-  (:documentation "Class for dojo dijit.DialogUnderlay component. More info at http://api.dojotoolkit.org/. It adds a HardLink so that the Dialog, that is moved inside body, may be referenced where it war originally placed, and so can be deleted from there"))
+  (:documentation "Class for dojo dijit.DialogUnderlay component. 
+You cannot directly call a json update on this component, but update its container instead!!!
+More info at http://api.dojotoolkit.org/. It adds a HardLink so that the Dialog, that is moved inside body, may be referenced where it war originally placed, and so can be deleted from there"))
 
 (defmethod wcomponent-template ((obj djdialog-underlay))
   (let ((id (htcomponent-client-id obj)))

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	Mon Sep  1 11:34:52 2008
@@ -40,23 +40,17 @@
   (:documentation "Class to generate a <form> element that is capable of XHR requests. More info at http://api.dojotoolkit.org/")
   (:default-initargs :dojo-type "claw.Form" :update-id () :ajax-form-p t))
 
-(defmethod wcomponent-template((obj djform))
-  (let ((id (htcomponent-client-id obj))
-        (method (form-method obj))
-        (dojo-type (djwidget-dojo-type obj))
+
+(defmethod wcomponent-template :before ((obj djform))
+  (let ((dojo-type (djwidget-dojo-type obj))
         (update-id (update-id obj)))
-    (form> :static-id id
-           :xhr (djform-ajax-form-p obj)
-           :method method
-           :dojotype dojo-type
-           :update-id (when update-id
-                        (let ((js-array (ps* `(array ,update-id))))
-                          (subseq js-array 0 (1- (length js-array)))))
-           (wcomponent-informal-parameters obj)
-           (input> :name *rewind-parameter*
-                   :type "hidden"
-                   :value id)
-           (htcomponent-body obj))))
+    (setf (wcomponent-informal-parameters obj) 
+          (append (wcomponent-informal-parameters obj)
+                  (list :xhr (djform-ajax-form-p obj)
+                        :dojotype dojo-type
+                        :update-id (when update-id
+                                     (let ((js-array (ps* `(array ,update-id))))
+                                       (subseq js-array 0 (1- (length js-array))))))))))
 
 
 (defmethod htcomponent-instance-initscript ((obj djform))

Modified: trunk/main/claw-html.dojo/src/djlink.lisp
==============================================================================
--- trunk/main/claw-html.dojo/src/djlink.lisp	(original)
+++ trunk/main/claw-html.dojo/src/djlink.lisp	Mon Sep  1 11:34:52 2008
@@ -40,7 +40,8 @@
 (defmethod wcomponent-template((o djaction-link))
   (let ((client-id (htcomponent-client-id o))
         (update-id (update-id o))
-        (dojo-type (djwidget-dojo-type o)))
+        (dojo-type (djwidget-dojo-type o))
+        (params (action-link-parameters o)))
     (a> :static-id client-id
 	:href "#"
         :hxr t
@@ -48,6 +49,8 @@
         :update-id (when update-id
                      (let ((js-array (ps* `(array ,update-id))))
                        (subseq js-array 0 (1- (length js-array)))))
+        :parameters (let ((json-content (ps* `(create , at params))))
+                      (subseq json-content 0 (1- (length json-content))))
 	(wcomponent-informal-parameters o)
 	(htcomponent-body o))))
 

Modified: trunk/main/claw-html.dojo/src/djtooltip.lisp
==============================================================================
--- trunk/main/claw-html.dojo/src/djtooltip.lisp	(original)
+++ trunk/main/claw-html.dojo/src/djtooltip.lisp	Mon Sep  1 11:34:52 2008
@@ -38,7 +38,9 @@
 (defclass djtooltip (wcomponent)
   ()
   (:metaclass metacomponent)
-  (:documentation "Class for dojo dijit.Tooltip component. More info at http://api.dojotoolkit.org/. It adds a HardLink so that the Dialog, that is moved inside body, may be referenced where it war originally placed, and so can be deleted from there"))
+  (:documentation "Class for dojo dijit.Tooltip component. 
+You cannot directly call a json update on this component, but update its container instead!!!
+More info at http://api.dojotoolkit.org/. It adds a HardLink so that the Dialog, that is moved inside body, may be referenced where it war originally placed, and so can be deleted from there"))
 
 (defmethod wcomponent-template ((obj djtooltip))
   (let ((id (htcomponent-client-id obj)))    


From achiumenti at common-lisp.net  Mon Sep  1 15:35:46 2008
From: achiumenti at common-lisp.net (achiumenti at common-lisp.net)
Date: Mon,  1 Sep 2008 11:35:46 -0400 (EDT)
Subject: [claw-cvs] r80 - trunk/main/claw-html.dojo/src/js
Message-ID: <20080901153546.B8F7C69006@common-lisp.net>

Author: achiumenti
Date: Mon Sep  1 11:35:46 2008
New Revision: 80

Modified:
   trunk/main/claw-html.dojo/src/js/ActionLink.js
   trunk/main/claw-html.dojo/src/js/Form.js
   trunk/main/claw-html.dojo/src/js/Rounded.js
Log:
bufixs on js dojo extended components

Modified: trunk/main/claw-html.dojo/src/js/ActionLink.js
==============================================================================
--- trunk/main/claw-html.dojo/src/js/ActionLink.js	(original)
+++ trunk/main/claw-html.dojo/src/js/ActionLink.js	Mon Sep  1 11:35:46 2008
@@ -42,16 +42,24 @@
                 enctype: "",
                 xhr: true,
                 templateString: "<a dojoAttachPoint='containerNode' dojoAttachEvent='onclick:_onClick' href='#'></a>",
+                parameters: {},
                 jsonContent: {},
+                postCreate: function(){
+		    this.widgetId = this.id;
+		    this.inherited(arguments);
+		},
 	        _updateParts: function (reply) {
                     for (var item in reply.components) {
                         var element = dojo.byId(item);
                         if ((element != null) && (reply.components[item] != null)) {
                             var list = dojo.query('[widgetId]', element);
                             dojo.forEach(list.map(dijit.byNode), function(widget){if (widget) widget.destroy(); });
-                            element.innerHTML = reply.components[item];
-                            dojo.parser.parse(element, true);
                         }
+                        var oldVisibility = element.style.visibility;
+                        element.style.visibility = 'hidden';
+                        element.innerHTML = reply.components[item];
+                        dojo.parser.parse(element, true);
+                        element.style.visibility = oldVisibility;
                     }
                 },
 
@@ -90,7 +98,7 @@
                         }
                         this.onBeforeClick(e);
                         var thisLink = this;
-                        var jsonContent = dojo.mixin(this.jsonContent, { json : thisLink.updateId, rewindobject : thisLink.id });
+                        var jsonContent = dojo.mixin(this.jsonContent, this.parameters, { json : thisLink.updateId, rewindobject : thisLink.id, rewindformobject : thisLink.id});
                         this.jsonContent = {};
                         var linkId = this.id;
                         dojo.xhrPost({
@@ -122,7 +130,10 @@
 		    //		Callback when user submits the form. This method is
 		    //		intended to be over-ridden. After the call to dojo.xhrPost
 		    //		thouches lload or error this event is fired
-	        }
+	        },
+                click: function () {
+                    this._onClick();
+                }
 	    }
         );
 

Modified: trunk/main/claw-html.dojo/src/js/Form.js
==============================================================================
--- trunk/main/claw-html.dojo/src/js/Form.js	(original)
+++ trunk/main/claw-html.dojo/src/js/Form.js	Mon Sep  1 11:35:46 2008
@@ -1,4 +1,4 @@
-y/**
+/**
 ;;; $Header: dojo/src/js/Form.js $
 
 ;;; Copyright (c) 2008, Andrea Chiumenti.  All rights reserved.
@@ -52,10 +52,13 @@
                            var element = dojo.byId(item);
                            if ((element != null) && (reply.components[item] != null)) {
                                var list = dojo.query('[widgetId]', element);
-                               dojo.forEach(list.map(dijit.byNode), function(widget){if (widget) widget.destroy(); });
-                               element.innerHTML = reply.components[item];
-                               dojo.parser.parse(element, true);
+                               dojo.forEach(list.map(dijit.byNode), function(widget){if (widget) widget.destroy(); });                               
                            }
+                           var oldVisibility = element.style.visibility;
+                           element.style.visibility = 'hidden';
+                           element.innerHTML = reply.components[item];
+                           dojo.parser.parse(element, true);
+                           element.style.visibility = oldVisibility;
                        }
                  },
 
@@ -100,6 +103,7 @@
                             this.jsonContent = {};
                             var formId = this.id;
                             if (this.enctype != 'multipart/form-data') {
+                                try {
                                 dojo.xhrPost({
                                         url: '#',
                                         load : function (data) {
@@ -109,11 +113,12 @@
                                                 thisForm.onXhrFinish(e);
                                             }
                                         },
-                                        error : function (data) {console.error(data);thisForm.onXhrFinish(e);},
+                                    error : function (data) {console.error("!!!!!!",data);thisForm.onXhrFinish(e);},
                                         timeout : thisForm.xhrTimeout,
-                                        handleAs : 'json',
+                                    handleAs : 'json',
                                         form : formId,
                                         content : jsonContent });
+                                } catch (e) {alert(e);}
                             } else {
                                 jsonContent = dojo.mixin(jsonContent, { jsonPrefix: '<textarea>', jsonSuffix: '</textarea>' });
                                 dojo.io.iframe.send({

Modified: trunk/main/claw-html.dojo/src/js/Rounded.js
==============================================================================
--- trunk/main/claw-html.dojo/src/js/Rounded.js	(original)
+++ trunk/main/claw-html.dojo/src/js/Rounded.js	Mon Sep  1 11:35:46 2008
@@ -45,13 +45,15 @@
         bgImgAlt: "",   // background image for ie6
  
         postCreate: function() {
-                dojo.style(this.contentNode, "height", dojo.style(this.outerNode, "height")-10+'px'); // TODO: Calculate correct height                
-                var alt = (this.bgImgAlt.length && dojo.isIE < 7 && dojo.isIE > 0);
-                dojo.forEach(["roundedContent","roundedTop","roundedBottom","roundedBottomDiv"],
-                        function(elName){
-                                dojo.style(this[elName],"backgroundImage", "url(" + (alt ? this.bgImgAlt : this.bgImg)  + ")");
-                        },
-                this);
+            this.widgetId = this.id;
+            dojo.style(this.contentNode, "height", dojo.style(this.outerNode, "height")-10+'px'); // TODO: Calculate correct height                
+            var alt = (this.bgImgAlt.length && dojo.isIE < 7 && dojo.isIE > 0);
+            dojo.forEach(["roundedContent","roundedTop","roundedBottom","roundedBottomDiv"],
+                         function(elName){
+                             dojo.style(this[elName],"backgroundImage", "url(" + (alt ? this.bgImgAlt : this.bgImg)  + ")");
+                         },
+                         this);
+            this.inherited(arguments);
         }
     });
        


From achiumenti at common-lisp.net  Mon Sep  1 15:33:48 2008
From: achiumenti at common-lisp.net (achiumenti at common-lisp.net)
Date: Mon,  1 Sep 2008 11:33:48 -0400 (EDT)
Subject: [claw-cvs] r78 - trunk/main/claw-html/src
Message-ID: <20080901153348.6FD9883000@common-lisp.net>

Author: achiumenti
Date: Mon Sep  1 11:33:48 2008
New Revision: 78

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:
bufix on rewind 

Modified: trunk/main/claw-html/src/components.lisp
==============================================================================
--- trunk/main/claw-html/src/components.lisp	(original)
+++ trunk/main/claw-html/src/components.lisp	Mon Sep  1 11:33:48 2008
@@ -69,26 +69,37 @@
 		:documentation "The html CLASS attribute")
      (method :initarg :method
              :reader form-method
-             :documentation "Form post method (may be \"get\" or \"post\")"))
-  (:default-initargs :action nil :class nil :method "post" :action-object nil)
+             :documentation "Form post method (may be \"get\" or \"post\")")
+     (execut-p :initform T
+             :accessor cform-execute-p
+             :documentation "When nil the form will never rewind an the CFORM-REWINDING-P will always be nil"))
+  (:default-initargs :action nil :class nil :method "post" :action-object *claw-current-page*)
+  (:documentation "Internal use component"))
+
+(defclass _cform-mixin (_cform)
+  ()
   (:documentation "Internal use component"))
 
+
+(defmethod htcomponent-rewind :before ((obj _cform) (pobj page))
+  (let ((render-condition (htcomponent-render-condition obj)))
+    (when (not (and render-condition (null (funcall render-condition))))
+      (setf (cform-execute-p obj) t))))
+
 (defmethod wcomponent-after-rewind ((obj _cform) (pobj page))
   (let ((validation-errors *validation-errors*)
 	(action (action obj)))
     (when (and (null validation-errors)
                action
-               (cform-rewinding-p obj pobj))
-      (funcall action (or (action-object obj) pobj)))))
+               (cform-rewinding-p obj pobj))      
+      (funcall action (action-object obj)))))
 
 (defmethod cform-rewinding-p ((cform _cform) (page page))
   (string= (htcomponent-client-id cform)
 	   (page-req-parameter page *rewind-parameter*)))
 
-(defclass cform (_cform)
-  ((execut-p :initform T
-             :accessor cform-execute-p
-             :documentation "When nil the form will never rewind an the CFORM-REWINDING-P will always be nil"))
+(defclass cform (_cform-mixin)
+  ()
   (:metaclass metacomponent)
   (:documentation "This component render as a FORM tag class, but it is aware of
 the request cycle and is able to fire an action on rewind"))
@@ -116,40 +127,48 @@
 	   :class class
            :method method
 	   (wcomponent-informal-parameters cform)
+           (input> :name *rewind-form-parameter*
+		   :type "hidden"
+		   :value client-id)
 	   (input> :name *rewind-parameter*
 		   :type "hidden"
 		   :value client-id)
 	   (htcomponent-body cform))))
 
-(defmethod cform-rewinding-p ((cform cform) (page page))
+(defmethod cform-rewinding-p ((cform _cform-mixin) (page page))
   (and (cform-execute-p cform)
        (string= (htcomponent-client-id cform)
                 (page-req-parameter page *rewind-parameter*))))
 
-(defmethod wcomponent-before-rewind ((obj cform) (pobj page))
-  (let ((render-condition (htcomponent-render-condition obj)))
-    (setf (cform-execute-p obj) (not (and render-condition (null (funcall render-condition))))
-          (page-current-form pobj) obj)))
+(defmethod htcomponent-rewind :before ((obj _cform-mixin) (pobj page))
+  (let ((render-condition (htcomponent-render-condition obj))
+        (id (htcomponent-client-id obj)))
+    (when (and (not (and render-condition (null (funcall render-condition))))
+               (string= id (page-req-parameter pobj *rewind-form-parameter*)))
+      (setf (page-current-form pobj) obj))))
 
-(defmethod wcomponent-after-rewind :after ((obj cform) (pobj page))
+(defmethod wcomponent-after-rewind :after ((obj _cform-mixin) (pobj page))
   (setf (page-current-form pobj) nil))
 
-(defmethod wcomponent-before-prerender ((obj cform) (pobj page))
+(defmethod wcomponent-before-prerender ((obj _cform-mixin) (pobj page))
   (setf (page-current-form pobj) obj))
 
-(defmethod wcomponent-after-prerender ((obj cform) (pobj page))
+(defmethod wcomponent-after-prerender ((obj _cform-mixin) (pobj page))
   (setf (page-current-form pobj) nil))
 
-(defmethod wcomponent-before-render ((obj cform) (pobj page))
+(defmethod wcomponent-before-render ((obj _cform-mixin) (pobj page))
   (setf (page-current-form pobj) obj))
 
-(defmethod wcomponent-after-render ((obj cform) (pobj page))
+(defmethod wcomponent-after-render ((obj _cform-mixin) (pobj page))
   (setf (page-current-form pobj) nil))
 ;--------------------------------------------------------------------------------
 
-(defclass action-link (_cform) ()
+(defclass action-link (_cform-mixin) 
+  ((parameters :initarg :parameters
+               :reader action-link-parameters
+               :documentation "An alist of strings for optional request get parameters."))
   (:metaclass metacomponent)
-  (:default-initargs :reserved-parameters (list :href))
+  (:default-initargs :reserved-parameters (list :href) :parameters nil)
   (:documentation "This component behaves like a CFORM, firing it's associated action once clicked.
 It renders as a normal link."))
 
@@ -164,11 +183,15 @@
 		(describe-component-behaviour class))))
 
 (defmethod wcomponent-template((o action-link))
-  (let ((client-id (htcomponent-client-id o)))
+  (let* ((client-id (htcomponent-client-id o))
+         (href (format nil "?~a=~a&~a=~a" *rewind-form-parameter* client-id *rewind-parameter* client-id))
+         (params (action-link-parameters o)))
     (when (null client-id)
       (setf client-id ""))
     (a> :static-id client-id
-	:href (format nil "?~a=~a" *rewind-parameter* client-id)
+	:href (if params
+                  (format nil "~a~{&~a=~a~}" href params)
+                  href)
 	(wcomponent-informal-parameters o)
 	(htcomponent-body o))))
 
@@ -202,7 +225,7 @@
 	      :reader css-class
 	      :documentation "the html component class attribute"))
   (:default-initargs :multiple nil :writer nil :reader nil :accessor nil :class nil
-		     :label nil :translator *simple-translator* :validator nil :visit-object nil)
+		     :label nil :translator *simple-translator* :validator nil :visit-object *claw-current-page*)
   (:documentation "Class inherited from both CINPUT and CSELECT"))
 
 (defmethod label ((cinput base-cinput))
@@ -252,12 +275,12 @@
 
 (defmethod wcomponent-after-rewind ((cinput base-cinput) (page page))
   (when (cform-rewinding-p (page-current-form page) page)
-    (let ((visit-object (or (cinput-visit-object cinput) page))
+    (let ((visit-object (cinput-visit-object cinput))
           (accessor (cinput-accessor cinput))
           (writer (cinput-writer cinput))
           (validator (validator cinput))
           (value (translator-decode (translator cinput) cinput)))
-      (unless (or (null value) (component-validation-errors cinput))
+      (unless (or (null value) (null visit-object) (component-validation-errors cinput))
 	(when validator
 	  (funcall validator value))
 	(unless (component-validation-errors cinput)
@@ -299,19 +322,20 @@
 
 (defmethod component-id-and-value ((cinput base-cinput) &key (from-request-p t))
   (let ((client-id (htcomponent-client-id cinput))
-	(visit-object (or (cinput-visit-object cinput) (htcomponent-page cinput)))
+	(visit-object (cinput-visit-object cinput))
 	(accessor (cinput-accessor cinput))
 	(reader (cinput-reader cinput))
 	(result-as-list-p (cinput-result-as-list-p cinput))
 	(value ""))
-    (setf value
-	  (cond
-	    (from-request-p (page-req-parameter (htcomponent-page cinput)
-						(name-attr cinput)
-						result-as-list-p))
-	    ((and (null reader) accessor) (funcall (fdefinition accessor) visit-object))
-	    (t (funcall (fdefinition reader) visit-object))))
-    (values client-id value)))
+    (when visit-object
+      (setf value
+            (cond
+              (from-request-p (page-req-parameter (htcomponent-page cinput)
+                                                  (name-attr cinput)
+                                                  result-as-list-p))
+              ((and (null reader) accessor) (funcall (fdefinition accessor) visit-object))
+              (t (funcall (fdefinition reader) visit-object))))
+      (values client-id value))))
 
 ;---------------------------------------------------------------------------------------
 (defclass cinput-file (cinput)
@@ -478,7 +502,7 @@
 
 (defmethod wcomponent-after-rewind ((cinput ccheckbox) (page page))
   (when (cform-rewinding-p (page-current-form page) page)
-    (let* ((visit-object (or (cinput-visit-object cinput) page))
+    (let* ((visit-object (cinput-visit-object cinput))
            (client-id (htcomponent-client-id cinput))
            (translator (translator cinput))
            (accessor (cinput-accessor cinput))
@@ -490,7 +514,7 @@
                                           result-as-list-p)))
       (when new-value
         (setf new-value (translator-string-to-type translator cinput)))
-      (unless (component-validation-errors cinput)
+      (unless (or (null visit-object) (component-validation-errors cinput))
         (when validator
           (funcall validator (or new-value "")))
         (unless (component-validation-errors cinput)
@@ -522,7 +546,7 @@
 
 (defmethod wcomponent-after-rewind ((cinput cradio) (page page))
   (when (cform-rewinding-p (page-current-form page) page)
-    (let* ((visit-object (or (cinput-visit-object cinput) page))
+    (let* ((visit-object (cinput-visit-object cinput))
            (translator (translator cinput))
            (accessor (cinput-accessor cinput))
            (writer (cinput-writer cinput))
@@ -537,7 +561,7 @@
       (when new-value
         (setf new-value (translator-string-to-type translator cinput)
               checked (funcall ccheckbox-test value new-value)))
-      (when (and checked (null (component-validation-errors cinput)))
+      (when (and checked visit-object (null (component-validation-errors cinput)))
         (when validator
           (funcall validator (or new-value "")))
         (when (null (component-validation-errors cinput))

Modified: trunk/main/claw-html/src/packages.lisp
==============================================================================
--- trunk/main/claw-html/src/packages.lisp	(original)
+++ trunk/main/claw-html/src/packages.lisp	Mon Sep  1 11:33:48 2008
@@ -42,7 +42,7 @@
            #:*xhtml-1.0-frameset*
            #:*rewind-parameter*
            #:*validation-errors*
-
+           #:*claw-current-page*
            #:error-page
            #:render-error-page
 
@@ -195,6 +195,7 @@
            #:action
            #:action-link
            #:action-link>
+           #:action-link-parameters
            #:cinput
            #:cinput>
            #:ctextarea

Modified: trunk/main/claw-html/src/tags.lisp
==============================================================================
--- trunk/main/claw-html/src/tags.lisp	(original)
+++ trunk/main/claw-html/src/tags.lisp	Mon Sep  1 11:33:48 2008
@@ -238,6 +238,9 @@
 (defvar *rewind-parameter* "rewindobject"
   "The request parameter name for the object asking for a rewind action")
 
+(defvar *rewind-form-parameter* "rewindformobject"
+  "The request parameter name for the form curently rewinding")
+
 (defvar *empty-tags*
   (list "area" "base" "basefont" "br" "col" "frame"
         "hr" "img" "input" "isindex" "meta"
@@ -449,7 +452,8 @@
          :reader htcomponent-page :documentation "The owner page")
    (json-render-on-validation-errors-p :initarg :json-render-on-validation-errors-p
                                        :reader htcomponent-json-render-on-validation-errors-p
-                                       :documentation "If from submission contains exceptions and the value is not nil, the component is rendered into the xhr json reply.")
+                                       :documentation "If from submission contains exceptions and the value is not nil, the component is rendered into the xhr json reply.
+If the value is T then component will be rendered on any error, if it's a tag id string it will be rendere only when the rewind parameter will match")
    (body :initarg :body
          :accessor htcomponent-body :documentation "The tag body")
    (client-id :initarg :client-id
@@ -756,227 +760,241 @@
     (car (page-components-stack *claw-current-page*))))
 ;;;========= HTCOMPONENT ============================
 (defmethod htcomponent-can-print ((htcomponent htcomponent))
-(let* ((id (when (slot-boundp htcomponent 'client-id) 
-             (htcomponent-client-id htcomponent)))
-       (page (htcomponent-page htcomponent))
-       (print-status (page-can-print page))
-       (validation-errors *validation-errors*)
-       (json-render-on-validation-errors-p (htcomponent-json-render-on-validation-errors-p htcomponent))
-       (render-p (or (and (member id (page-json-id-list page) :test #'string=)
-                          (null validation-errors))
-                     print-status)))
-  (or json-render-on-validation-errors-p print-status render-p)))
+  (let* ((id (when (slot-boundp htcomponent 'client-id) 
+               (htcomponent-client-id htcomponent)))
+         (page (htcomponent-page htcomponent))
+         (print-status (page-can-print page))
+         (validation-errors *validation-errors*)
+         (json-render-on-validation-errors-value (htcomponent-json-render-on-validation-errors-p htcomponent))
+         (json-render-on-validation-errors-p (if (typep json-render-on-validation-errors-value 'boolean)
+                                                 json-render-on-validation-errors-value
+                                                 (string= json-render-on-validation-errors-value
+                                                          (page-req-parameter *claw-current-page* *rewind-parameter*))))
+         (render-p (or (and (member id (page-json-id-list page) :test #'string=)
+                            (null validation-errors))
+                       print-status)))
+    (or json-render-on-validation-errors-p print-status render-p)))
 
 (defmethod htcomponent-json-print-start-component ((htcomponent htcomponent))
-(let* ((page (htcomponent-page htcomponent))
-       (jsonp (page-json-id-list page))
-       (id (when (slot-boundp htcomponent 'client-id) 
-             (htcomponent-client-id htcomponent)))
-       (validation-errors *validation-errors*))
-  (when (and jsonp
-             (or (and (null validation-errors)
-                      (member id jsonp :test #'string-equal))
-                 (htcomponent-json-render-on-validation-errors-p htcomponent)))
-    (when (> (page-json-component-count page) 0)
-      (page-format page ","))
-    (page-format-raw page "~a:\"" id)
-    (push id (page-json-component-id-list page))
-    (incf (page-json-component-count page)))))
+  (let* ((page (htcomponent-page htcomponent))
+         (jsonp (page-json-id-list page))
+         (id (when (slot-boundp htcomponent 'client-id) 
+               (htcomponent-client-id htcomponent)))
+         (validation-errors *validation-errors*)
+         (json-render-on-validation-errors-value (htcomponent-json-render-on-validation-errors-p htcomponent))
+         (json-render-on-validation-errors-p (if (typep json-render-on-validation-errors-value 'boolean)
+                                                 json-render-on-validation-errors-value
+                                                 (string= json-render-on-validation-errors-value
+                                                          (page-req-parameter *claw-current-page* *rewind-parameter*)))))
+    (when (and jsonp
+               (or (and (null validation-errors)
+                        (member id jsonp :test #'string-equal))
+                   json-render-on-validation-errors-p))
+      (when (> (page-json-component-count page) 0)
+        (page-format page ","))
+      (page-format-raw page "~a:\"" id)
+      (push id (page-json-component-id-list page))
+      (incf (page-json-component-count page)))))
 
 (defmethod htcomponent-json-print-end-component ((htcomponent htcomponent))
-(let* ((page (htcomponent-page htcomponent))
-       (jsonp (page-json-id-list page))
-       (id (when (slot-boundp htcomponent 'client-id) (htcomponent-client-id htcomponent)))
-       (validation-errors *validation-errors*))
-  (when (and jsonp
-             (or (and (null validation-errors)
-                      (member id jsonp :test #'string-equal))
-                 (htcomponent-json-render-on-validation-errors-p htcomponent)))
-    (pop (page-json-component-id-list page))
-    (page-format-raw page "\""))))
+  (let* ((page (htcomponent-page htcomponent))
+         (jsonp (page-json-id-list page))
+         (id (when (slot-boundp htcomponent 'client-id) (htcomponent-client-id htcomponent)))
+         (validation-errors *validation-errors*)
+         (json-render-on-validation-errors-value (htcomponent-json-render-on-validation-errors-p htcomponent))
+         (json-render-on-validation-errors-p (if (typep json-render-on-validation-errors-value 'boolean)
+                                                 json-render-on-validation-errors-value
+                                                 (string= json-render-on-validation-errors-value
+                                                          (page-req-parameter *claw-current-page* *rewind-parameter*)))))
+    (when (and jsonp
+               (or (and (null validation-errors)
+                        (member id jsonp :test #'string-equal))
+                   json-render-on-validation-errors-p))
+      (pop (page-json-component-id-list page))
+      (page-format-raw page "\""))))
 
 (defmethod htcomponent-rewind :before ((htcomponent htcomponent) (page page))
-(setf (htcomponent-page htcomponent) page)
-(push htcomponent (page-components-stack page)))
+  (setf (htcomponent-page htcomponent) page)
+  (push htcomponent (page-components-stack page)))
 
 (defmethod htcomponent-prerender :before ((htcomponent htcomponent) (page page))
-(let ((render-condition (htcomponent-render-condition htcomponent)))
-  (unless (and render-condition (null (funcall render-condition)))
-    (setf (htcomponent-page htcomponent) page)
-    (push htcomponent (page-components-stack page)))))
+  (let ((render-condition (htcomponent-render-condition htcomponent)))
+    (unless (and render-condition (null (funcall render-condition)))
+      (setf (htcomponent-page htcomponent) page)
+      (push htcomponent (page-components-stack page)))))
 
 (defmethod htcomponent-render :before ((htcomponent htcomponent) (page page))
-(let ((render-condition (htcomponent-render-condition htcomponent)))
-  (unless (and render-condition (null (funcall render-condition)))
-    (setf (htcomponent-page htcomponent) page)
-    (push htcomponent (page-components-stack page)))))
+  (let ((render-condition (htcomponent-render-condition htcomponent)))
+    (unless (and render-condition (null (funcall render-condition)))
+      (setf (htcomponent-page htcomponent) page)
+      (push htcomponent (page-components-stack page)))))
 
 (defmethod htcomponent-rewind :after ((htcomponent htcomponent) (page page))
-(pop (page-components-stack page)))
+  (pop (page-components-stack page)))
 
 (defmethod htcomponent-prerender :after ((htcomponent htcomponent) (page page))
-(let ((render-condition (htcomponent-render-condition htcomponent)))
-  (unless (and render-condition (null (funcall render-condition)))
-    (pop (page-components-stack page)))))
+  (let ((render-condition (htcomponent-render-condition htcomponent)))
+    (unless (and render-condition (null (funcall render-condition)))
+      (pop (page-components-stack page)))))
 
 (defmethod htcomponent-render :after ((htcomponent htcomponent) (page page))
-(let ((render-condition (htcomponent-render-condition htcomponent)))
-  (unless (and render-condition (null (funcall render-condition)))
-    (pop (page-components-stack page)))))
+  (let ((render-condition (htcomponent-render-condition htcomponent)))
+    (unless (and render-condition (null (funcall render-condition)))
+      (pop (page-components-stack page)))))
 
 (defmethod htcomponent-rewind ((htcomponent htcomponent) (page page))
-(dolist (tag (htcomponent-body htcomponent))
-  (when (subtypep (type-of tag) 'htcomponent)
-    (htcomponent-rewind tag page))))
+  (dolist (tag (htcomponent-body htcomponent))
+    (when (subtypep (type-of tag) 'htcomponent)
+      (htcomponent-rewind tag page))))
 
 (defmethod htcomponent-prerender ((htcomponent htcomponent) (page page))
-(let ((previous-print-status (page-can-print page))
-      (render-condition (htcomponent-render-condition htcomponent)))
-  (unless (and render-condition (null (funcall render-condition)))
-    (when (null previous-print-status)
-      (setf (page-can-print page) (htcomponent-can-print htcomponent)))
-    (dolist (tag (htcomponent-body htcomponent))
-      (when (subtypep (type-of tag) 'htcomponent)
-        (htcomponent-prerender tag page)))
-    (when (null previous-print-status)
-      (setf (page-can-print page) nil)))))
+  (let ((previous-print-status (page-can-print page))
+        (render-condition (htcomponent-render-condition htcomponent)))
+    (unless (and render-condition (null (funcall render-condition)))
+      (when (null previous-print-status)
+        (setf (page-can-print page) (htcomponent-can-print htcomponent)))
+      (dolist (tag (htcomponent-body htcomponent))
+        (when (subtypep (type-of tag) 'htcomponent)
+          (htcomponent-prerender tag page)))
+      (when (null previous-print-status)
+        (setf (page-can-print page) nil)))))
 
 (defmethod htcomponent-render ((htcomponent htcomponent) (page page))
-(let ((body-list (htcomponent-body htcomponent))
-      (previous-print-status (page-can-print page))
-      (render-condition (htcomponent-render-condition htcomponent)))
-  (unless (and render-condition (null (funcall render-condition)))
-    (when (null previous-print-status)
-      (setf (page-can-print page) (htcomponent-can-print htcomponent))
-      (htcomponent-json-print-start-component htcomponent))
-    (dolist (child-tag body-list)
-      (when child-tag
-        (cond
-          ((stringp child-tag) (htcomponent-render ($> child-tag) page))
-          ((functionp child-tag) (htcomponent-render ($> (funcall child-tag)) page))
-          (t (htcomponent-render child-tag page)))))
-    (when (null previous-print-status)
-      (setf (page-can-print page) nil)
-      (htcomponent-json-print-end-component htcomponent)))))
+  (let ((body-list (htcomponent-body htcomponent))
+        (previous-print-status (page-can-print page))
+        (render-condition (htcomponent-render-condition htcomponent)))
+    (unless (and render-condition (null (funcall render-condition)))
+      (when (null previous-print-status)
+        (setf (page-can-print page) (htcomponent-can-print htcomponent))
+        (htcomponent-json-print-start-component htcomponent))
+      (dolist (child-tag body-list)
+        (when child-tag
+          (cond
+            ((stringp child-tag) (htcomponent-render ($> child-tag) page))
+            ((functionp child-tag) (htcomponent-render ($> (funcall child-tag)) page))
+            (t (htcomponent-render child-tag page)))))
+      (when (null previous-print-status)
+        (setf (page-can-print page) nil)
+        (htcomponent-json-print-end-component htcomponent)))))
 
 ;;;========= TAG =====================================
 (defmethod tag-attributes ((tag tag))
-(htcomponent-attributes tag))
+  (htcomponent-attributes tag))
 
 (defmethod tag-render-attributes ((tag tag) (page page))
-(when (htcomponent-attributes tag)
-  (loop for (k v) on (htcomponent-attributes tag) by #'cddr
-     do (progn
-          (assert (keywordp k))
-          (when (and (functionp v) (not (eq k :render-condition)))
-            (setf v (funcall v)))
-          (when (numberp v)
-            (setf v (princ-to-string v)))
-          (when (and (not (eq k :render-condition)) v (string-not-equal v ""))
-            (page-format page " ~a=\"~a\""
-                         (if (eq k :static-id)
-                             "id"
-                             (parenscript::symbol-to-js k))
-                         (let ((s (if (eq k :id)
-                                      (prin1-to-string (htcomponent-client-id tag))
-                                      (if (eq t v)
-                                          "\"true\""
-                                          (prin1-to-string v))))) ;escapes double quotes
-                           (subseq s 1 (1- (length s))))))))))
+  (when (htcomponent-attributes tag)
+    (loop for (k v) on (htcomponent-attributes tag) by #'cddr
+       do (progn
+            (assert (keywordp k))
+            (when (and (functionp v) (not (eq k :render-condition)))
+              (setf v (funcall v)))
+            (when (numberp v)
+              (setf v (princ-to-string v)))
+            (when (and (not (eq k :render-condition)) v (string-not-equal v ""))
+              (page-format page " ~a=\"~a\""
+                           (if (eq k :static-id)
+                               "id"
+                               (parenscript::symbol-to-js k))
+                           (let ((s (if (eq k :id)
+                                        (prin1-to-string (htcomponent-client-id tag))
+                                        (if (eq t v)
+                                            "\"true\""
+                                            (prin1-to-string v))))) ;escapes double quotes
+                             (subseq s 1 (1- (length s))))))))))
 
 (defmethod tag-render-starttag ((tag tag) (page page))
-(let ((tagname (tag-name tag))
-      (id (when (slot-boundp tag 'client-id) (htcomponent-client-id tag)))
-      (jsonp (page-json-id-list page))
-      (emptyp (htcomponent-empty tag))
-      (xml-p (page-xmloutput page))
-      (injection-writing-p (page-injection-writing-p page)))
-  (setf (page-lasttag page) tagname)
-  (when (or injection-writing-p
-            (null jsonp)
-            (null (and jsonp 
-                       (string= id (first (page-json-component-id-list page))))))
-    (page-newline page)
-    (page-print-tabulation page)
-    (page-format page "<~a" tagname)
-    (tag-render-attributes tag page)
-    (if (null emptyp)
-        (progn
-          (page-format page ">")
-          (incf (page-tabulator page)))
-        (if (null xml-p)
+  (let ((tagname (tag-name tag))
+        (id (when (slot-boundp tag 'client-id) (htcomponent-client-id tag)))
+        (jsonp (page-json-id-list page))
+        (emptyp (htcomponent-empty tag))
+        (xml-p (page-xmloutput page))
+        (injection-writing-p (page-injection-writing-p page)))
+    (setf (page-lasttag page) tagname)
+    (when (or injection-writing-p
+              (null jsonp)
+              (null (and jsonp 
+                         (string= id (first (page-json-component-id-list page))))))
+      (page-newline page)
+      (page-print-tabulation page)
+      (page-format page "<~a" tagname)
+      (tag-render-attributes tag page)
+      (if (null emptyp)
+          (progn
             (page-format page ">")
-            (page-format page "/>"))))))
+            (incf (page-tabulator page)))
+          (if (null xml-p)
+              (page-format page ">")
+              (page-format page "/>"))))))
 
 (defmethod tag-render-endtag ((tag tag) (page page))
-(let ((tagname (tag-name tag))
-      (id (when (slot-boundp tag 'client-id) (htcomponent-client-id tag)))
-      (jsonp (page-json-id-list page))
-      (previous-tagname (page-lasttag page))
-      (emptyp (htcomponent-empty tag))
-      (injection-writing-p (page-injection-writing-p page)))
-  (when (and (null emptyp)
-             (or injection-writing-p
-                 (null jsonp)
-                 (null (and jsonp 
-                            (string= id (first (page-json-component-id-list page)))))))
-    (progn
-      (decf (page-tabulator page))
-      (if (string= tagname previous-tagname)
-          (progn
-            (page-format page "</~a>" tagname))
-          (progn
-            (page-newline page)
-            (page-print-tabulation page)
-            (page-format page "</~a>" tagname)))))
-  (setf (page-lasttag page) nil)))
+  (let ((tagname (tag-name tag))
+        (id (when (slot-boundp tag 'client-id) (htcomponent-client-id tag)))
+        (jsonp (page-json-id-list page))
+        (previous-tagname (page-lasttag page))
+        (emptyp (htcomponent-empty tag))
+        (injection-writing-p (page-injection-writing-p page)))
+    (when (and (null emptyp)
+               (or injection-writing-p
+                   (null jsonp)
+                   (null (and jsonp 
+                              (string= id (first (page-json-component-id-list page)))))))
+      (progn
+        (decf (page-tabulator page))
+        (if (string= tagname previous-tagname)
+            (progn
+              (page-format page "</~a>" tagname))
+            (progn
+              (page-newline page)
+              (page-print-tabulation page)
+              (page-format page "</~a>" tagname)))))
+    (setf (page-lasttag page) nil)))
 
 (defmethod htcomponent-render ((tag tag) (page page))
-(let ((body-list (htcomponent-body tag))
-      (previous-print-status (page-can-print page))
-      (render-condition (htcomponent-render-condition tag)))
-  (unless (and render-condition (null (funcall render-condition)))
-    (when (null previous-print-status)
-      (setf (page-can-print page) (htcomponent-can-print tag))
-      (htcomponent-json-print-start-component tag))
-    (when (or (page-can-print page) previous-print-status)
-      (tag-render-starttag tag page))
-    (dolist (child-tag body-list)
-      (when child-tag
-        (cond
-          ((stringp child-tag) (htcomponent-render ($> child-tag) page))
-          ((functionp child-tag) (htcomponent-render ($> (funcall child-tag)) page))
-          (t (htcomponent-render child-tag page)))))
-    (when (or (page-can-print page) previous-print-status)
-      (tag-render-endtag tag page))
-    (unless previous-print-status
-      (setf (page-can-print page) nil)
-      (htcomponent-json-print-end-component tag)))))
+  (let ((body-list (htcomponent-body tag))
+        (previous-print-status (page-can-print page))
+        (render-condition (htcomponent-render-condition tag)))
+    (unless (and render-condition (null (funcall render-condition)))
+      (when (null previous-print-status)
+        (setf (page-can-print page) (htcomponent-can-print tag))
+        (htcomponent-json-print-start-component tag))
+      (when (or (page-can-print page) previous-print-status)
+        (tag-render-starttag tag page))
+      (dolist (child-tag body-list)
+        (when child-tag
+          (cond
+            ((stringp child-tag) (htcomponent-render ($> child-tag) page))
+            ((functionp child-tag) (htcomponent-render ($> (funcall child-tag)) page))
+            (t (htcomponent-render child-tag page)))))
+      (when (or (page-can-print page) previous-print-status)
+        (tag-render-endtag tag page))
+      (unless previous-print-status
+        (setf (page-can-print page) nil)
+        (htcomponent-json-print-end-component tag)))))
 
 ;;;========= HTHEAD ======================================
 (defmethod htcomponent-render ((hthead hthead) (page page))
-(let ((render-condition (htcomponent-render-condition hthead)))
-  (unless (and render-condition (null (funcall render-condition)))
-    (when (null (page-json-id-list page))
-      (let ((body-list (htcomponent-body hthead))
-            (injections (page-init-injections page))
-            (encoding (page-external-format-encoding page)))
-        (tag-render-starttag hthead page)
-        (htcomponent-render (meta> :http-equiv "Content-Type"
-                                   :content (format nil "~a;charset=~a"
-                                                    (page-mime-type page)
-                                                    encoding))
-                            page)
-        (dolist (child-tag body-list)
-          (when child-tag
-            (cond
-              ((stringp child-tag) (htcomponent-render ($> child-tag) page))
-              ((functionp child-tag) (htcomponent-render ($> (funcall child-tag)) page))
-              (t (htcomponent-render child-tag page)))))
-        (dolist (injection injections)
-          (when injection
-            (htcomponent-render injection page)))
-        (tag-render-endtag hthead page))))))
+  (let ((render-condition (htcomponent-render-condition hthead)))
+    (unless (and render-condition (null (funcall render-condition)))
+      (when (null (page-json-id-list page))
+        (let ((body-list (htcomponent-body hthead))
+              (injections (page-init-injections page))
+              (encoding (page-external-format-encoding page)))
+          (tag-render-starttag hthead page)
+          (htcomponent-render (meta> :http-equiv "Content-Type"
+                                     :content (format nil "~a;charset=~a"
+                                                      (page-mime-type page)
+                                                      encoding))
+                              page)
+          (dolist (child-tag body-list)
+            (when child-tag
+              (cond
+                ((stringp child-tag) (htcomponent-render ($> child-tag) page))
+                ((functionp child-tag) (htcomponent-render ($> (funcall child-tag)) page))
+                (t (htcomponent-render child-tag page)))))
+          (dolist (injection injections)
+            (when injection
+              (htcomponent-render injection page)))
+          (tag-render-endtag hthead page))))))
 
 ;;;========= HTSTRING ===================================
 
@@ -984,283 +1002,289 @@
 (defmethod htcomponent-prerender((htstring htstring) (page page)))
 
 (defmethod htcomponent-render ((htstring htstring) (page page))
-(let ((body (htcomponent-body htstring))
-      (jsonp (not (null (page-json-id-list page))))
-      (print-p (page-can-print page))
-      (render-condition (htcomponent-render-condition htstring)))
-  (unless (and render-condition (null (funcall render-condition)))
-    (when (and print-p body)
-      (when (functionp body)
-        (setf body (funcall body)))
-      (when jsonp
-        (setf body (regex-replace-all "\""
-                                      (regex-replace-all "\\\\\""
-                                                         (regex-replace-all "\\n"
-                                                                            body
-                                                                            "\\n")
-                                                         "\\\\\\\"")
-                                      "\\\"")))
-      (if (htstring-raw htstring)
-          (page-format-raw page body)
-          (loop for ch across body
-             do (case ch
-                  ((#\<) (page-format-raw page "&#60;"))
-                  ((#\>) (page-format-raw page "&#62;"))
-                  ((#\&) (page-format-raw page "&#38;"))
-                  (t (page-format-raw page "~a" ch)))))))))
+  (let ((body (htcomponent-body htstring))
+        (jsonp (not (null (page-json-id-list page))))
+        (print-p (page-can-print page))
+        (render-condition (htcomponent-render-condition htstring)))
+    (unless (and render-condition (null (funcall render-condition)))
+      (when (and print-p body)
+        (when (functionp body)
+          (setf body (funcall body)))
+        (when jsonp
+          (setf body (regex-replace-all "\""
+                                        (regex-replace-all "\\\\\""
+                                                           (regex-replace-all "\\n"
+                                                                              body
+                                                                              "\\n")
+                                                           "\\\\\\\"")
+                                        "\\\"")))
+        (if (htstring-raw htstring)
+            (page-format-raw page body)
+            (loop for ch across body
+               do (case ch
+                    ((#\<) (page-format-raw page "&#60;"))
+                    ((#\>) (page-format-raw page "&#62;"))
+                    ((#\&) (page-format-raw page "&#38;"))
+                    (t (page-format-raw page "~a" ch)))))))))
 
 ;;;========= HTSCRIPT ===================================
 (defmethod htcomponent-prerender((htscript htscript) (page page)))
 
 (defmethod htcomponent-render ((htscript htscript) (page page))
-(let ((xml-p (page-xmloutput page))
-      (body (htcomponent-body htscript))
-      (previous-print-status (page-can-print page))
-      (render-condition (htcomponent-render-condition htscript)))
-  (unless (and render-condition (null (funcall render-condition)))
-    (when (null previous-print-status)
-      (setf (page-can-print page) (htcomponent-can-print htscript))
-      (htcomponent-json-print-start-component htscript))
-    (unless (getf (htcomponent-attributes htscript) :type)
-      (append '(:type "text/javascript") (htcomponent-attributes htscript)))
-    (when (page-can-print page)
-      (tag-render-starttag htscript page)
-      (when (and (null (getf (htcomponent-attributes htscript) :src))
-                 (not (null (htcomponent-body htscript))))
-        (if (null xml-p)
-            (page-format page "~%//<!--~%")
-            (page-format page "~%//<[CDATA[~%"))
-        (unless (listp body)
-          (setf body (list body)))
-        (dolist (element body)
-          (when element
-            (cond
-              ((stringp element) (htcomponent-render ($raw> element) page))
-              ((functionp element) (htcomponent-render ($raw> (funcall element)) page))
-              (t (htcomponent-render element page)))))
-        (if (null xml-p)
-            (page-format page "~%//-->")
-            (page-format page "~%//]]>")))
-      (setf (page-lasttag page) nil)
-      (tag-render-endtag htscript page))
-    (when (null previous-print-status)
-      (setf (page-can-print page) nil)
-      (htcomponent-json-print-end-component htscript)))))
+  (let ((xml-p (page-xmloutput page))
+        (body (htcomponent-body htscript))
+        (previous-print-status (page-can-print page))
+        (render-condition (htcomponent-render-condition htscript)))
+    (unless (and render-condition (null (funcall render-condition)))
+      (when (null previous-print-status)
+        (setf (page-can-print page) (htcomponent-can-print htscript))
+        (htcomponent-json-print-start-component htscript))
+      (unless (getf (htcomponent-attributes htscript) :type)
+        (append '(:type "text/javascript") (htcomponent-attributes htscript)))
+      (when (page-can-print page)
+        (tag-render-starttag htscript page)
+        (when (and (null (getf (htcomponent-attributes htscript) :src))
+                   (not (null (htcomponent-body htscript))))
+          (if (null xml-p)
+              (page-format page "~%//<!--~%")
+              (page-format page "~%//<[CDATA[~%"))
+          (unless (listp body)
+            (setf body (list body)))
+          (dolist (element body)
+            (when element
+              (cond
+                ((stringp element) (htcomponent-render ($raw> element) page))
+                ((functionp element) (htcomponent-render ($raw> (funcall element)) page))
+                (t (htcomponent-render element page)))))
+          (if (null xml-p)
+              (page-format page "~%//-->")
+              (page-format page "~%//]]>")))
+        (setf (page-lasttag page) nil)
+        (tag-render-endtag htscript page))
+      (when (null previous-print-status)
+        (setf (page-can-print page) nil)
+        (htcomponent-json-print-end-component htscript)))))
 
 ;;;========= HTLINK ====================================
 
 (defmethod htcomponent-render ((htlink htlink) (page page))
-(let ((previous-print-status (page-can-print page))
-      (render-condition (htcomponent-render-condition htlink)))
-  (unless (and render-condition (null (funcall render-condition)))
-    (when (null previous-print-status)
-      (setf (page-can-print page) (htcomponent-can-print htlink))
-      (htcomponent-json-print-start-component htlink))
-    (when (page-can-print page)
-      (unless (getf (htcomponent-attributes htlink) :type)
-        (append '(:type "text/css") (htcomponent-attributes htlink)))
-      (unless (getf (htcomponent-attributes htlink) :rel)
-        (append '(:rel "styleshhet") (htcomponent-attributes htlink)))
-      (tag-render-starttag htlink page)
-      (tag-render-endtag htlink page))
-    (when (null previous-print-status)
-      (setf (page-can-print page) nil)
-      (htcomponent-json-print-end-component htlink)))))
+  (let ((previous-print-status (page-can-print page))
+        (render-condition (htcomponent-render-condition htlink)))
+    (unless (and render-condition (null (funcall render-condition)))
+      (when (null previous-print-status)
+        (setf (page-can-print page) (htcomponent-can-print htlink))
+        (htcomponent-json-print-start-component htlink))
+      (when (page-can-print page)
+        (unless (getf (htcomponent-attributes htlink) :type)
+          (append '(:type "text/css") (htcomponent-attributes htlink)))
+        (unless (getf (htcomponent-attributes htlink) :rel)
+          (append '(:rel "styleshhet") (htcomponent-attributes htlink)))
+        (tag-render-starttag htlink page)
+        (tag-render-endtag htlink page))
+      (when (null previous-print-status)
+        (setf (page-can-print page) nil)
+        (htcomponent-json-print-end-component htlink)))))
 
 ;;;========= HTBODY ===================================
 (defmethod htcomponent-render ((htbody htbody) (page page))
-(let ((body-list (htcomponent-body htbody))
-      (previous-print-status (page-can-print page))
-      (render-condition (htcomponent-render-condition htbody)))
-  (unless (and render-condition (null (funcall render-condition)))
-    (when (or (page-can-print page) previous-print-status)
-      (setf (page-can-print page) (htcomponent-can-print htbody))
-      (htcomponent-json-print-start-component htbody))
-    (when (page-can-print page)
-      (tag-render-starttag htbody page))
-    (dolist (child-tag body-list)
-      (when child-tag
-        (cond
-          ((stringp child-tag) (htcomponent-render ($> child-tag) page))
-          ((functionp child-tag) (htcomponent-render ($> (funcall child-tag)) page))
-          (t (htcomponent-render child-tag page)))))
-    (when (page-can-print page)
-      (htcomponent-render (htbody-init-scripts-tag page t) page)
-      (tag-render-endtag htbody page))
-    (when (or (page-can-print page) previous-print-status)
-      (setf (page-can-print page) nil)
-      (htcomponent-json-print-end-component htbody)))))
+  (let ((body-list (htcomponent-body htbody))
+        (previous-print-status (page-can-print page))
+        (render-condition (htcomponent-render-condition htbody)))
+    (unless (and render-condition (null (funcall render-condition)))
+      (when (or (page-can-print page) previous-print-status)
+        (setf (page-can-print page) (htcomponent-can-print htbody))
+        (htcomponent-json-print-start-component htbody))
+      (when (page-can-print page)
+        (tag-render-starttag htbody page))
+      (dolist (child-tag body-list)
+        (when child-tag
+          (cond
+            ((stringp child-tag) (htcomponent-render ($> child-tag) page))
+            ((functionp child-tag) (htcomponent-render ($> (funcall child-tag)) page))
+            (t (htcomponent-render child-tag page)))))
+      (when (page-can-print page)
+        (htcomponent-render (htbody-init-scripts-tag page t) page)
+        (tag-render-endtag htbody page))
+      (when (or (page-can-print page) previous-print-status)
+        (setf (page-can-print page) nil)
+        (htcomponent-json-print-end-component htbody)))))
 
 (defmethod htbody-init-scripts-tag ((page page) &optional on-load)
-(let ((js (script> :type "text/javascript"))
-      (js-control-string-directive (if on-load 
-                                       "
+  (let ((js (script> :type "text/javascript"))
+        (js-control-string-directive (if on-load 
+                                         "
 var bodyInitFunction = function\(e){~{~a~}};~%
 if (/MSIE (\\d+\\.\\d+);/.test(navigator.userAgent)) {~%
   window.attachEvent\('onload', bodyInitFunction);~%
 } else {~%
   document.addEventListener\('DOMContentLoaded', bodyInitFunction, false);~%
 }"
-                                       "~{~a~}~%"))
-      (page-body-init-scripts (page-body-init-scripts page)))
-  (setf (htcomponent-page js) page
-        (htcomponent-body js) (when page-body-init-scripts
-                                (format nil js-control-string-directive (if (listp page-body-init-scripts)
-                                                                            page-body-init-scripts
-                                                                            (list page-body-init-scripts)))))
-  js))
+                                         "~{~a~}~%"))
+        (page-body-init-scripts (page-body-init-scripts page)))
+    (setf (htcomponent-page js) page
+          (htcomponent-body js) (when page-body-init-scripts
+                                  (format nil js-control-string-directive (if (listp page-body-init-scripts)
+                                                                              page-body-init-scripts
+                                                                              (list page-body-init-scripts)))))
+    js))
 
 ;;;========= WCOMPONENT ===================================
 (defclass wcomponent (htcomponent)
-((reserved-parameters :initarg :reserved-parameters
-                      :accessor wcomponent-reserved-parameters
-                      :type cons
-                      :documentation "Parameters that may not be used in the constructor function")
- (json-error-monitor-p :initarg :json-error-monitor-p
-                       :accessor htcomponent-json-error-monitor-p
-                       :documentation "When not nil, if the client has sent a XHR call, let the page to fill the errorComponents property of the json reply.")
- (informal-parameters :initform ()
-                      :accessor wcomponent-informal-parameters
-                      :type cons
-                      :documentation "Informal parameters are parameters optional for the component")
- (allow-informal-parameters :initarg :allow-informal-parameters
-                            :reader wcomponent-allow-informal-parametersp
-                            :allocation :class
-                            :documentation "Determines if the component accepts informal parameters"))
-(:default-initargs :reserved-parameters nil
-  :allow-informal-parameters t)
-(:documentation "Base class for creationg customized web components. Use this or one of its subclasses to make your own."))
+  ((reserved-parameters :initarg :reserved-parameters
+                        :accessor wcomponent-reserved-parameters
+                        :type cons
+                        :documentation "Parameters that may not be used in the constructor function")
+   (json-error-monitor-p :initarg :json-error-monitor-p
+                         :accessor htcomponent-json-error-monitor-p
+                         :documentation "When not nil, if the client has sent a XHR call, let the page to fill the errorComponents property of the json reply.")
+   (informal-parameters :initform ()
+                        :accessor wcomponent-informal-parameters
+                        :type cons
+                        :documentation "Informal parameters are parameters optional for the component")
+   (allow-informal-parameters :initarg :allow-informal-parameters
+                              :reader wcomponent-allow-informal-parametersp
+                              :allocation :class
+                              :documentation "Determines if the component accepts informal parameters"))
+  (:default-initargs :reserved-parameters nil
+    :allow-informal-parameters t)
+  (:documentation "Base class for creationg customized web components. Use this or one of its subclasses to make your own."))
 
 (defun slot-initarg-p (initarg class-precedence-list)
-"Returns nil if a slot with that initarg isn't found into the list of classes passed"
-(loop for class in class-precedence-list
-   do (let* ((direct-slots (closer-mop:class-direct-slots class))
-             (result (loop for slot in direct-slots
-                        do (when (eq (first (closer-mop:slot-definition-initargs slot)) initarg)
-                             (return initarg)))))
-        (when result
-          (return result)))))
+  "Returns nil if a slot with that initarg isn't found into the list of classes passed"
+  (loop for class in class-precedence-list
+     do (let* ((direct-slots (closer-mop:class-direct-slots class))
+               (result (loop for slot in direct-slots
+                          do (when (eq (first (closer-mop:slot-definition-initargs slot)) initarg)
+                               (return initarg)))))
+          (when result
+            (return result)))))
 
 (defmethod initialize-instance :after ((instance wcomponent) &rest rest)
-(let* ((class-precedence-list (closer-mop:compute-class-precedence-list (class-of instance)))
-       (informal-parameters (loop for (k v) on rest by #'cddr
-                               for result = ()
-                               do (unless (slot-initarg-p k class-precedence-list)
-                                    (push v result)
-                                    (push k result))
-                               finally (return result))))
-  (setf (slot-value instance 'informal-parameters) informal-parameters)))
+  (let* ((class-precedence-list (closer-mop:compute-class-precedence-list (class-of instance)))
+         (informal-parameters (loop for (k v) on rest by #'cddr
+                                 for result = ()
+                                 do (unless (slot-initarg-p k class-precedence-list)
+                                      (push v result)
+                                      (push k result))
+                                 finally (return result))))
+    (setf (slot-value instance 'informal-parameters) informal-parameters)))
 
 (defmethod (setf slot-initialization) (value (wcomponent wcomponent) slot-initarg)
-(let* ((initarg (if (or (eq slot-initarg :static-id) (eq slot-initarg :id)) :client-id slot-initarg))
-       (new-value (if (eq slot-initarg :id) (generate-id value) value))
-       (slot-name (loop for slot-definition in (closer-mop:class-slots (class-of wcomponent))
-                     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))
-      (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))
-              (setf (getf (wcomponent-informal-parameters wcomponent) initarg) new-value))))))
+  (let* ((initarg (if (or (eq slot-initarg :static-id) (eq slot-initarg :id)) :client-id slot-initarg))
+         (new-value (if (eq slot-initarg :id) (generate-id value) value))
+         (slot-name (loop for slot-definition in (closer-mop:class-slots (class-of wcomponent))
+                       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))
+        (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))
+                (setf (getf (wcomponent-informal-parameters wcomponent) initarg) new-value))))))
 
 
 (defun make-component (name parameters content)
-"This function instantiates a wcomponent by the passed NAME, separetes parameters into formal(the ones that are the
+  "This function instantiates a wcomponent by the passed NAME, separetes parameters into formal(the ones that are the
 initarg of a slot, and informal parameters, that have their own slot in common. The CONTENT is the body content."
-(unless (or (getf parameters :id) 
-            (getf parameters :static-id))
-  (setf (getf parameters :id) "claw"))
-(let* ((instance (make-instance name))
-       (id (getf parameters :id))
-       (static-id (getf parameters :static-id))
-       (real-id (or static-id id)))
-  (setf (htcomponent-real-id instance) real-id)
-  (when static-id
-    (remf parameters :id))
-  (loop for (initarg value) on parameters by #'cddr
-     do (setf (slot-initialization instance initarg) value))
-  (setf (htcomponent-body instance) content)
-  instance))
+  (unless (or (getf parameters :id) 
+              (getf parameters :static-id))
+    (setf (getf parameters :id) "claw"))
+  (let* ((instance (make-instance name))
+         (id (getf parameters :id))
+         (static-id (getf parameters :static-id))
+         (real-id (or static-id id)))
+    (setf (htcomponent-real-id instance) real-id)
+    (when static-id
+      (remf parameters :id))
+    (loop for (initarg value) on parameters by #'cddr
+       do (setf (slot-initialization instance initarg) value))
+    (setf (htcomponent-body instance) content)
+    instance))
 
 (defun build-component (component-name &rest rest)
-"This function is the one that WCOMPONENT init functions call to intantiate their relative components.
+  "This function is the one that WCOMPONENT init functions call to intantiate their relative components.
 The REST parameter is flattened and divided into a pair, where the first element is the alist of the component parameters,
 while the second is the component body."
-(let ((fbody (parse-htcomponent-function (flatten rest))))
-  (make-component component-name (first fbody) (second fbody))))
+  (let ((fbody (parse-htcomponent-function (flatten rest))))
+    (make-component component-name (first fbody) (second fbody))))
 
 (defmethod htcomponent-rewind ((wcomponent wcomponent) (page page))
-(let ((template (wcomponent-template wcomponent)))
-  (wcomponent-before-rewind wcomponent page)
-  (if (listp template)
-      (dolist (tag template)
-        (htcomponent-rewind tag page))
-      (htcomponent-rewind template page))
-  (wcomponent-after-rewind wcomponent page)))
+  (let* ((template (wcomponent-template wcomponent))
+         (current-form (page-current-form page))
+         (call-rewind-methods-p (and (null *validation-errors*)
+                                     current-form
+                                     (string= (htcomponent-client-id current-form) (page-req-parameter page *rewind-parameter*)))))
+    (when call-rewind-methods-p
+      (wcomponent-before-rewind wcomponent page))
+    (if (listp template)
+        (dolist (tag template)
+          (htcomponent-rewind tag page))
+        (htcomponent-rewind template page))
+    (when call-rewind-methods-p
+      (wcomponent-after-rewind wcomponent page))))
 
 (defmethod wcomponent-before-rewind ((wcomponent wcomponent) (page page)))
 (defmethod wcomponent-after-rewind ((wcomponent wcomponent) (page page)))
 
 (defmethod htcomponent-prerender ((wcomponent wcomponent) (page page))
-(let ((render-condition (htcomponent-render-condition wcomponent)))
-  (unless (and render-condition (null (funcall render-condition)))
-    (wcomponent-before-prerender wcomponent page)
-    (let ((previous-print-status (page-can-print page))
-          (template (wcomponent-template wcomponent)))
-      (when (null previous-print-status)
-        (setf (page-can-print page) (htcomponent-can-print wcomponent)))
-      (when (page-can-print page)
-        (let ((script-files (htcomponent-script-files wcomponent)))
-          (dolist (script (if (listp script-files)
-                              script-files
-                              (list script-files)))
-            (pushnew script (page-script-files page) :test #'equal)))
-        (let ((css-files (htcomponent-stylesheet-files wcomponent)))
-          (dolist (css (if (listp css-files)
-                           css-files
-                           (list css-files)))
-            (pushnew css (page-stylesheet-files page) :test #'equal)))
-        (dolist (js (htcomponent-class-initscripts wcomponent))
-          (pushnew js (page-class-initscripts page) :test #'equal))
-        (when (htcomponent-instance-initscript wcomponent)
-          (pushnew (htcomponent-instance-initscript wcomponent) (page-instance-initscripts page) :test #'equal)))
-      (if (listp template)
-          (dolist (tag template)
-            (when (subtypep (type-of tag) 'htcomponent)
-              (htcomponent-prerender tag page)))
-          (htcomponent-prerender template page))
-      (when (null previous-print-status)
-        (setf (page-can-print page) nil)))
-    (wcomponent-after-prerender wcomponent page))))
+  (let ((render-condition (htcomponent-render-condition wcomponent)))
+    (unless (and render-condition (null (funcall render-condition)))
+      (wcomponent-before-prerender wcomponent page)
+      (let ((previous-print-status (page-can-print page))
+            (template (wcomponent-template wcomponent)))
+        (when (null previous-print-status)
+          (setf (page-can-print page) (htcomponent-can-print wcomponent)))
+        (when (page-can-print page)
+          (let ((script-files (htcomponent-script-files wcomponent)))
+            (dolist (script (if (listp script-files)
+                                script-files
+                                (list script-files)))
+              (pushnew script (page-script-files page) :test #'equal)))
+          (let ((css-files (htcomponent-stylesheet-files wcomponent)))
+            (dolist (css (if (listp css-files)
+                             css-files
+                             (list css-files)))
+              (pushnew css (page-stylesheet-files page) :test #'equal)))
+          (dolist (js (htcomponent-class-initscripts wcomponent))
+            (pushnew js (page-class-initscripts page) :test #'equal))
+          (when (htcomponent-instance-initscript wcomponent)
+            (pushnew (htcomponent-instance-initscript wcomponent) (page-instance-initscripts page) :test #'equal)))
+        (if (listp template)
+            (dolist (tag template)
+              (when (subtypep (type-of tag) 'htcomponent)
+                (htcomponent-prerender tag page)))
+            (htcomponent-prerender template page))
+        (when (null previous-print-status)
+          (setf (page-can-print page) nil)))
+      (wcomponent-after-prerender wcomponent page))))
 
 (defmethod wcomponent-before-prerender ((wcomponent wcomponent) (page page)))
 (defmethod wcomponent-after-prerender ((wcomponent wcomponent) (page page)))
 
 (defmethod htcomponent-render ((wcomponent wcomponent) (page page))
-(let ((template (wcomponent-template wcomponent))
-      (previous-print-status (page-can-print page))
-      (render-condition (htcomponent-render-condition wcomponent)))
-  (unless (and render-condition (null (funcall render-condition)))
-    (when (null previous-print-status)
-      (setf (page-can-print page) (htcomponent-can-print wcomponent))
-      (htcomponent-json-print-start-component wcomponent))
-    (wcomponent-before-render wcomponent page)
-    (unless (listp template)
-      (setf template (list template)))
-    (dolist (child-tag template)
-      (when child-tag
-        (cond
-          ((stringp child-tag) (htcomponent-render ($> child-tag) page))
-          ((functionp child-tag) (htcomponent-render ($> (funcall child-tag)) page))
-          (t (htcomponent-render child-tag page)))))
-    (wcomponent-after-render wcomponent page)
-    (when (null previous-print-status)
-      (setf (page-can-print page) nil)
-      (htcomponent-json-print-end-component wcomponent)))))
+  (let ((template (wcomponent-template wcomponent))
+        (previous-print-status (page-can-print page))
+        (render-condition (htcomponent-render-condition wcomponent)))
+    (unless (and render-condition (null (funcall render-condition)))
+      (when (null previous-print-status)
+        (setf (page-can-print page) (htcomponent-can-print wcomponent))
+        (htcomponent-json-print-start-component wcomponent))
+      (wcomponent-before-render wcomponent page)
+      (unless (listp template)
+        (setf template (list template)))
+      (dolist (child-tag template)
+        (when child-tag
+          (cond
+            ((stringp child-tag) (htcomponent-render ($> child-tag) page))
+            ((functionp child-tag) (htcomponent-render ($> (funcall child-tag)) page))
+            (t (htcomponent-render child-tag page)))))
+      (wcomponent-after-render wcomponent page)
+      (when (null previous-print-status)
+        (setf (page-can-print page) nil)
+        (htcomponent-json-print-end-component wcomponent)))))
 
 (defmethod wcomponent-before-render ((wcomponent wcomponent) (page page)))
 (defmethod wcomponent-after-render ((wcomponent wcomponent) (page page)))

Modified: trunk/main/claw-html/src/translators.lisp
==============================================================================
--- trunk/main/claw-html/src/translators.lisp	(original)
+++ trunk/main/claw-html/src/translators.lisp	Mon Sep  1 11:33:48 2008
@@ -61,18 +61,20 @@
   (:default-initargs :validation-error-control-string nil))
 
 (defmethod translator-value-encode ((translator translator) value)
-  (format nil "~a" value))
+  (if value
+      (format nil "~a" value)
+      ""))
 
 (defmethod translator-value-type-to-string ((translator translator) value)
   (translator-value-encode translator value))
 
 (defmethod translator-encode ((translator translator) (wcomponent base-cinput))
   (let* ((page (htcomponent-page wcomponent))
-         (visit-object (or (cinput-visit-object wcomponent) page))
+         (visit-object (cinput-visit-object wcomponent))
          (accessor (cinput-accessor wcomponent))
          (reader (cinput-reader wcomponent))
          (value (page-req-parameter page (name-attr wcomponent) nil)))
-    (if (component-validation-errors wcomponent)
+    (if (or (component-validation-errors wcomponent) (null visit-object))
         value
         (progn
           (setf value (cond
@@ -85,7 +87,9 @@
 
 (defmethod translator-value-decode ((translator translator) value &optional client-id label)
   (declare (ignore client-id label))
-  value)
+  (if (string= value "")
+      nil
+      value))
 
 (defmethod translator-value-string-to-type ((translator translator) value &optional client-id label)
   (translator-value-decode translator value client-id label))


From achiumenti at common-lisp.net  Wed Sep  3 17:54:24 2008
From: achiumenti at common-lisp.net (achiumenti at common-lisp.net)
Date: Wed,  3 Sep 2008 13:54:24 -0400 (EDT)
Subject: [claw-cvs] r81 - trunk/main/claw-html/src
Message-ID: <20080903175424.2D1543E056@common-lisp.net>

Author: achiumenti
Date: Wed Sep  3 13:54:22 2008
New Revision: 81

Modified:
   trunk/main/claw-html/src/packages.lisp
   trunk/main/claw-html/src/tags.lisp
Log:
bufix on rewind 

Modified: trunk/main/claw-html/src/packages.lisp
==============================================================================
--- trunk/main/claw-html/src/packages.lisp	(original)
+++ trunk/main/claw-html/src/packages.lisp	Wed Sep  3 13:54:22 2008
@@ -190,9 +190,10 @@
            #:wcomponent-before-render
            #:wcomponent-after-render
            #:cform
+           #:action-object
+           #:action
            #:form-method
            #:cform>
-           #:action
            #:action-link
            #:action-link>
            #:action-link-parameters

Modified: trunk/main/claw-html/src/tags.lisp
==============================================================================
--- trunk/main/claw-html/src/tags.lisp	(original)
+++ trunk/main/claw-html/src/tags.lisp	Wed Sep  3 13:54:22 2008
@@ -303,7 +303,10 @@
        do (if (and (null body)
                    (or (keywordp elem)
                        (keywordp last-elem)))
-              (push (or (when (list-for-tag-attribute-p elem) (list-for-tag-attribute-value elem)) elem) attributes)
+              (push (or (when (list-for-tag-attribute-p elem) 
+                          (list-for-tag-attribute-value elem)) 
+                        elem) 
+                    attributes)
               (when elem
                 (push elem body))))
     (list (reverse attributes) (reverse body))))
@@ -1212,17 +1215,17 @@
     (make-component component-name (first fbody) (second fbody))))
 
 (defmethod htcomponent-rewind ((wcomponent wcomponent) (page page))
-  (let* ((template (wcomponent-template wcomponent))
-         (current-form (page-current-form page))
+  (let* ((current-form (page-current-form page))
          (call-rewind-methods-p (and (null *validation-errors*)
                                      current-form
                                      (string= (htcomponent-client-id current-form) (page-req-parameter page *rewind-parameter*)))))
     (when call-rewind-methods-p
       (wcomponent-before-rewind wcomponent page))
-    (if (listp template)
-        (dolist (tag template)
-          (htcomponent-rewind tag page))
-        (htcomponent-rewind template page))
+    (let ((template (wcomponent-template wcomponent)))
+      (if (listp template)
+          (dolist (tag template)
+            (htcomponent-rewind tag page))
+          (htcomponent-rewind template page)))
     (when call-rewind-methods-p
       (wcomponent-after-rewind wcomponent page))))
 


From achiumenti at common-lisp.net  Wed Sep  3 17:55:06 2008
From: achiumenti at common-lisp.net (achiumenti at common-lisp.net)
Date: Wed,  3 Sep 2008 13:55:06 -0400 (EDT)
Subject: [claw-cvs] r82 - trunk/main/claw-html.dojo/src
Message-ID: <20080903175506.6FEEE601A9@common-lisp.net>

Author: achiumenti
Date: Wed Sep  3 13:55:06 2008
New Revision: 82

Modified:
   trunk/main/claw-html.dojo/src/djform.lisp
   trunk/main/claw-html.dojo/src/djlink.lisp
Log:
bufix on rewind 

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 Sep  3 13:55:06 2008
@@ -40,7 +40,6 @@
   (:documentation "Class to generate a <form> element that is capable of XHR requests. More info at http://api.dojotoolkit.org/")
   (:default-initargs :dojo-type "claw.Form" :update-id () :ajax-form-p t))
 
-
 (defmethod wcomponent-template :before ((obj djform))
   (let ((dojo-type (djwidget-dojo-type obj))
         (update-id (update-id obj)))
@@ -49,7 +48,9 @@
                   (list :xhr (djform-ajax-form-p obj)
                         :dojotype dojo-type
                         :update-id (when update-id
-                                     (let ((js-array (ps* `(array ,update-id))))
+                                     (let ((js-array (if (listp update-id) 
+                                                         (ps* `(array , at update-id))
+                                                         (ps* `(array ,update-id)))))
                                        (subseq js-array 0 (1- (length js-array))))))))))
 
 

Modified: trunk/main/claw-html.dojo/src/djlink.lisp
==============================================================================
--- trunk/main/claw-html.dojo/src/djlink.lisp	(original)
+++ trunk/main/claw-html.dojo/src/djlink.lisp	Wed Sep  3 13:55:06 2008
@@ -47,7 +47,9 @@
         :hxr t
         :dojotype dojo-type
         :update-id (when update-id
-                     (let ((js-array (ps* `(array ,update-id))))
+                     (let ((js-array (if (listp update-id) 
+                                         (ps* `(array , at update-id))
+                                         (ps* `(array ,update-id)))))
                        (subseq js-array 0 (1- (length js-array)))))
         :parameters (let ((json-content (ps* `(create , at params))))
                       (subseq json-content 0 (1- (length json-content))))


From achiumenti at common-lisp.net  Wed Sep  3 17:55:24 2008
From: achiumenti at common-lisp.net (achiumenti at common-lisp.net)
Date: Wed,  3 Sep 2008 13:55:24 -0400 (EDT)
Subject: [claw-cvs] r83 - trunk/main/claw-html.dojo/src/js
Message-ID: <20080903175524.93023601A9@common-lisp.net>

Author: achiumenti
Date: Wed Sep  3 13:55:24 2008
New Revision: 83

Modified:
   trunk/main/claw-html.dojo/src/js/Form.js
Log:
bufix on rewind 

Modified: trunk/main/claw-html.dojo/src/js/Form.js
==============================================================================
--- trunk/main/claw-html.dojo/src/js/Form.js	(original)
+++ trunk/main/claw-html.dojo/src/js/Form.js	Wed Sep  3 13:55:24 2008
@@ -104,7 +104,7 @@
                             var formId = this.id;
                             if (this.enctype != 'multipart/form-data') {
                                 try {
-                                dojo.xhrPost({
+                                    dojo.xhrPost({
                                         url: '#',
                                         load : function (data) {
                                             try {
@@ -113,9 +113,9 @@
                                                 thisForm.onXhrFinish(e);
                                             }
                                         },
-                                    error : function (data) {console.error("!!!!!!",data);thisForm.onXhrFinish(e);},
+                                        error : function (data) {console.error("!!!!!!",data);thisForm.onXhrFinish(e);},
                                         timeout : thisForm.xhrTimeout,
-                                    handleAs : 'json',
+                                        handleAs : 'json',
                                         form : formId,
                                         content : jsonContent });
                                 } catch (e) {alert(e);}


From achiumenti at common-lisp.net  Wed Sep  3 17:58:37 2008
From: achiumenti at common-lisp.net (achiumenti at common-lisp.net)
Date: Wed,  3 Sep 2008 13:58:37 -0400 (EDT)
Subject: [claw-cvs] r84 - trunk/main/claw-demo/src/frontend
Message-ID: <20080903175837.0ADC61D172@common-lisp.net>

Author: achiumenti
Date: Wed Sep  3 13:58:36 2008
New Revision: 84

Modified:
   trunk/main/claw-demo/src/frontend/customers.lisp
Log:
CLAW demo update

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 Sep  3 13:58:36 2008
@@ -31,117 +31,115 @@
 
 (defgeneric edit-customer-save (edit-customer))
 
-(defclass edit-customer (wcomponent)
+(defclass edit-customer (djform)
   ((customer :initarg :customer
-                      :accessor edit-customer-save-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))
+                  :accessor on-xhr-finish)
+   (customer-id-parameter :initarg :customer-id-parameter
+                          :accessor edit-customer-customer-id-parameter))
   (:metaclass metacomponent)
-  (:default-initargs :on-before-submit nil :on-xhr-finish nil))
+  (:default-initargs :on-before-submit nil :on-xhr-finish nil 
+                     :class "customerForm" :customer-id-parameter "customerid"))
 
-(defmethod wcomponent-template ((obj edit-customer))
-  (let ((id (htcomponent-client-id obj))
-        (visit-object (edit-customer-save-customer obj)))
-    (djform> :static-id id
-             :class "customerForm"
-             :update-id id
-             :action 'edit-customer-save
-             :action-object obj
-             :on-before-submit (on-before-submit obj)
-             :on-xhr-finish (on-xhr-finish obj)
-             (cinput> :id "customerid"
-                      :type "hidden" :visit-object visit-object
-                      :translator *integer-translator*
-                      :accessor 'table-id)
-             (cinput> :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))
-             (div> :class "buttons"
-                   (djsubmit-button> :value "Save")))))
-
-
-(defun customer-save (customer)
-  (let ((db-customer (find-by-id 'customer (table-id customer))))
-    (copy-values-by-accessors db-customer customer
-                              table-version
-                              customer-name1
-                              customer-name2
-                              customer-email
-                              customer-phone1 customer-phone2 customer-phone3
-                              customer-fax
-                              customer-vat
-                              customer-code1 customer-code2 customer-code3 customer-code4)
-    (update-db-item db-customer)
-    db-customer))
+(defmethod initialize-instance :after ((obj edit-customer) &key rest)
+  (declare (ignore rest))
+  (setf (action-object obj) obj
+        (action obj) 'edit-customer-save))
+
+(defmethod htcomponent-body ((obj edit-customer))
+  (let ((visit-object (edit-customer-customer obj)))
+    (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))
+     (div> :class "buttons"
+           (djsubmit-button> :value "Save")))))
+
+
+(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)))))
 
 (defmethod edit-customer-save ((obj edit-customer))
   (let ((id (htcomponent-client-id obj))
-        (customer (edit-customer-save-customer obj)))
+        (customer (edit-customer-customer obj)))
     (handler-case
-        (setf (edit-customer-save-customer obj) (customer-save customer))
+        (progn
+          (log-message :info "PHONE: ~a" (customer-phone1 customer))
+          (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))
@@ -159,7 +157,7 @@
   ((customers :initform nil
               :accessor customers-page-customers)
    (current-customer :initform (make-instance 'customer)
-                     :accessor customer-page-current-customer)
+                     :accessor customers-page-current-customer)
    (customer-edit-dialog-title :initform "Add new cutomer"
                                :accessor customers-page-customer-edit-dialog-title)
    (customers-total-count :initform 0
@@ -184,15 +182,20 @@
           :accessor customers-page-sorting-order))
   (:default-initargs :list-size 20))
 
+(defmethod wcomponent-after-rewind :after ((obj edit-customer) (page customers-page))
+  (setf (customers-page-current-customer page) (edit-customer-customer obj)
+        (customers-page-customers page) (list (edit-customer-customer obj))))
+
 (defmethod customers-page-offset-reset ((page customers-page)) 0)
 
 (defmethod customers-page-edit-customer ((page customers-page)) 
   (let ((customer-id (parse-integer (claw-parameter "customerid")))
         (current-customer))
-    (setf current-customer (find-by-id 'customer customer-id))
-    (setf (customers-page-customer-edit-dialog-title page) "Edit customer")
+    (setf current-customer (find-by-id 'customer customer-id)
+          (customers-page-customer-edit-dialog-title page) "Edit customer"
+          (customers-page-customers page) (list current-customer))
     (when current-customer
-      (setf (customer-page-current-customer page) current-customer))))
+      (setf (customers-page-current-customer page) current-customer))))
 
 (defmethod customers-page-sorting ((page customers-page))
   (let ((direction (if (string-equal "asc" (customers-page-sorting-order page))
@@ -212,6 +215,7 @@
         (form-id (generate-id "customersForm"))
         (customers (customers-page-customers page))
         (offset-id (generate-id "offset"))
+        (result-container-id (generate-id "resultContainer"))
         (edit-customer-dialog-container-id (generate-id "customerDialogContainer"))
         (edit-customer-dialog-id (generate-id "customerDialog"))
         (edit-customer-form-id (generate-id "customerForm"))
@@ -226,7 +230,7 @@
                                                :src "docroot/img/spinner.gif"))
                     (djform> :static-id form-id
                              :action 'customers-page-find-customers
-                             :update-id form-id
+                             :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"
@@ -252,73 +256,74 @@
                                             :accessor 'customers-page-sorting-order)
                                    (djsubmit-button> :id "search"
                                                      :value "Search"))
-                             (table> :class "listTable"
-                                     (tr> :class "header"
-                                          (th> :class "name" (span> :class (if (string-equal "name1" sort-field) 
-                                                                               (if (string-equal "asc" sort-direction)
-                                                                                   "sort sortAsc"
-                                                                                   "sort sortDesc")
-                                                                               "sort")
-                                                                    :on-click (remove #\newline (ps:ps* `(progn (setf (slot-value (dojo.by-id ,sorting-order-id) 'value) 
-                                                                                                                      (if (and (== (slot-value (dojo.by-id ,sorting-column-id) 'value) "name1")
-                                                                                                                               (== (slot-value (dojo.by-id ,sorting-order-id) 'value) "asc"))
-                                                                                                                          "desc"
-                                                                                                                          "asc"))
-                                                                                                                (setf (slot-value (dojo.by-id ,sorting-column-id) 'value) 
-                                                                                                                      "name1")
-                                                                                                                (.submit (dijit.by-id ,form-id))))) 
-                                                                    "Name"))
-                                          (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 "vat" "VAT")
-                                          (th> :class "phone" "Phone"))
-                                     (loop for customer in customers
-                                        for index = 0 then (incf index)
-                                        collect (tr> :class (if (evenp index) "item even" "item odd")
-                                                     (td> (a> :id "edit"
-                                                              :href "#"
-                                                              :on-click (remove #\newline (ps:ps* `(progn (setf (slot-value (dijit.by-id ,edit-customer-action-link-id) 'parameters) 
-                                                                                                                (create "customerid" ,(table-id customer)))
-                                                                                                          (.click (dijit.by-id ,edit-customer-action-link-id)))))
-                                                              (customer-name1 customer)
-                                                              " "
-                                                              (customer-name2 customer)))
-                                                     (td> (customer-email customer))
-                                                     (td> (customer-vat customer))
-                                                     (td> (customer-phone1 customer)))))
-                             (djaction-link> :static-id edit-customer-action-link-id
-                                             :style "display:none"
-                                             :action 'customers-page-edit-customer
-                                             :update-id edit-customer-dialog-container-id
-                                             :on-before-submit (ps:ps* `(.show (dijit.by-id ,spinner-id)))
-                                             :on-xhr-finish (remove #\newline (ps:ps* `(progn (.hide (dijit.by-id ,spinner-id))
-                                                                                              (.show (dijit.by-id ,edit-customer-dialog-id)))))
-                                             "invisible")
-                             (pager> :id "pager" 
-                                     :update-component-id offset-id
-                                     :page-size (customers-page-list-size page)
-                                     :total-items (customers-page-customers-total-count page)
-                                     :first-item-offset (customers-page-offset page)))
+                             (div> :static-id result-container-id
+                                   (table> :class "listTable"
+                                           (tr> :class "header"
+                                                (th> :class "name" (span> :class (if (string-equal "name1" sort-field) 
+                                                                                     (if (string-equal "asc" sort-direction)
+                                                                                         "sort sortAsc"
+                                                                                         "sort sortDesc")
+                                                                                     "sort")
+                                                                          :on-click (remove #\newline (ps:ps* `(progn (setf (slot-value (dojo.by-id ,sorting-order-id) 'value) 
+                                                                                                                            (if (and (== (slot-value (dojo.by-id ,sorting-column-id) 'value) "name1")
+                                                                                                                                     (== (slot-value (dojo.by-id ,sorting-order-id) 'value) "asc"))
+                                                                                                                                "desc"
+                                                                                                                                "asc"))
+                                                                                                                      (setf (slot-value (dojo.by-id ,sorting-column-id) 'value) 
+                                                                                                                            "name1")
+                                                                                                                      (.submit (dijit.by-id ,form-id))))) 
+                                                                          "Name"))
+                                                (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 "vat" "VAT")
+                                                (th> :class "phone" "Phone"))
+                                           (loop for customer in customers
+                                              for index = 0 then (incf index)
+                                              collect (tr> :class (if (evenp index) "item even" "item odd")
+                                                           (td> (a> :id "edit"
+                                                                    :href "#"
+                                                                    :on-click (remove #\newline (ps:ps* `(progn (setf (slot-value (dijit.by-id ,edit-customer-action-link-id) 'parameters) 
+                                                                                                                      (create "customerid" ,(table-id customer)))
+                                                                                                                (.click (dijit.by-id ,edit-customer-action-link-id)))))
+                                                                    (customer-name1 customer)
+                                                                    " "
+                                                                    (customer-name2 customer)))
+                                                           (td> (customer-email customer))
+                                                           (td> (customer-vat customer))
+                                                           (td> (customer-phone1 customer)))))
+                                   (djaction-link> :static-id edit-customer-action-link-id
+                                                   :style "display:none"
+                                                   :action 'customers-page-edit-customer
+                                                   :update-id (attribute-value (list edit-customer-dialog-container-id result-container-id))
+                                                   :on-before-submit (ps:ps* `(.show (dijit.by-id ,spinner-id)))
+                                                   :on-xhr-finish (remove #\newline (ps:ps* `(progn (.hide (dijit.by-id ,spinner-id))
+                                                                                                    (.show (dijit.by-id ,edit-customer-dialog-id)))))
+                                                   "invisible")
+                                   (pager> :id "pager" 
+                                           :update-component-id offset-id
+                                           :page-size (customers-page-list-size page)
+                                           :total-items (customers-page-customers-total-count page)
+                                           :first-item-offset (customers-page-offset page))))
                     (div> :static-id edit-customer-dialog-container-id
                           (djdialog> :static-id edit-customer-dialog-id
                                         :title (customers-page-customer-edit-dialog-title page)
                                      (edit-customer> :static-id edit-customer-form-id
-                                                     :customer (customer-page-current-customer page)
+                                                     :update-id (attribute-value (list edit-customer-form-id result-container-id))
+                                                     :customer (customers-page-current-customer page)
                                                      :on-before-submit (ps:ps* `(.show (dijit.by-id ,spinner-id)))
-                                                     :on-xhr-finish (ps:ps* `(.hide (dijit.by-id ,spinner-id)))
-                                                     :customer (customer-page-current-customer page))
+                                                     :on-xhr-finish (ps:ps* `(.hide (dijit.by-id ,spinner-id))))
                                      (exception-monitor> :id "exceptionMonitor" :json-render-on-validation-errors-p edit-customer-form-id))))))
 
 (defmethod customers-page-find-customers ((page customers-page))


From achiumenti at common-lisp.net  Mon Sep  8 09:33:19 2008
From: achiumenti at common-lisp.net (achiumenti at common-lisp.net)
Date: Mon,  8 Sep 2008 05:33:19 -0400 (EDT)
Subject: [claw-cvs] r85 - trunk/main/claw/src
Message-ID: <20080908093319.8CF7B7A090@common-lisp.net>

Author: achiumenti
Date: Mon Sep  8 05:33:16 2008
New Revision: 85

Modified:
   trunk/main/claw/src/connector.lisp
   trunk/main/claw/src/lisplet.lisp
   trunk/main/claw/src/misc.lisp
   trunk/main/claw/src/packages.lisp
   trunk/main/claw/src/server.lisp
   trunk/main/claw/src/session-manager.lisp
Log:
CLAW redirection bugfix

Modified: trunk/main/claw/src/connector.lisp
==============================================================================
--- trunk/main/claw/src/connector.lisp	(original)
+++ trunk/main/claw/src/connector.lisp	Mon Sep  8 05:33:16 2008
@@ -207,10 +207,7 @@
   (:documentation "Sets the outgoing Content-Length http header"))
 
 (defclass connector (claw-service)
-  ((behind-apache-p :initarg :behind-apache-p
-                    :accessor connector-behind-apache-p
-                    :documentation "Returns true if the connector is running behind apache.")
-   (port :initarg :port
+  ((port :initarg :port
          :accessor connector-port
          :documentation "The port under which normal http requests are handled")
    (sslport :initarg :sslport
@@ -218,10 +215,10 @@
             :documentation "The port under which https requests are handled")
    (address :initarg :address
             :accessor connector-address
-            :documentation "The address under which https reqhests are handled"))
+            :documentation "The address whe the connector is bound to"))
   (:default-initargs :port 80 :sslport 443 
-                     :address nil
-                     :behind-apache-p nil :name 'connector)
+                     :address *claw-default-server-address*
+                     :name 'connector)
   (:documentation "CONNECTOR is an interface, so you cannot directly use it.
 A Connector subclass is a class that helps to decouple CLAW from the web server on which CLAWSERVER resides.
 To properly work a CLAWSERVER instance must be provided with a CONNECTOR implementation.

Modified: trunk/main/claw/src/lisplet.lisp
==============================================================================
--- trunk/main/claw/src/lisplet.lisp	(original)
+++ trunk/main/claw/src/lisplet.lisp	Mon Sep  8 05:33:16 2008
@@ -127,10 +127,11 @@
         (location (lisplet-base-path lisplet)))
     (unless (string= "/" (subseq location 0 1))
       (setf location (concatenate 'string "/" location)))
-    (setf (clawserver-lisplets clawserver) (sort-by-location (pushnew-location
-                                                                 (cons location
-                                                                       lisplet)
-                                                                 lisplets)))))
+    (setf (lisplet-server-address lisplet) (clawserver-address clawserver)
+          (clawserver-lisplets clawserver) (sort-by-location (pushnew-location
+                                                              (cons location
+                                                                    lisplet)
+                                                              lisplets)))))
 
 (defmethod clawserver-unregister-lisplet ((clawserver clawserver) (lisplet lisplet))
   (let ((lisplets (clawserver-lisplets clawserver))
@@ -195,6 +196,7 @@
   (let* ((*claw-current-realm* (lisplet-realm lisplet))
          (*claw-current-lisplet* lisplet)
          (*claw-session* (default-session-manager-session-verify *session-manager*))
+         (*root-path* (format nil "~a~a" *server-path* (lisplet-base-path lisplet)))
          (base-path (build-lisplet-location lisplet))
          (uri (claw-script-name))
          (welcome-page (lisplet-welcome-page lisplet)))
@@ -215,13 +217,11 @@
   "Redirects a request sent through http using https"
   (let* ((connector (clawserver-connector *clawserver*))
          (path (or uri (claw-request-uri)))
-         (port (connector-port connector))
-         (sslport (connector-sslport connector)))
-    (if (connector-behind-apache-p connector)
-        (claw-redirect path :port *apache-https-port* :protocol :https)
-        (claw-redirect path :port (or sslport port) :protocol (if sslport
-                                                                  :https
-                                                                  :http)))))
+         (sslport (if (claw-proxified-p)
+                      (clawserver-proxy-https-port *clawserver*)
+                      (connector-sslport connector))))
+    (claw-redirect path :host (claw-host-name) :port sslport
+                   :protocol :https)))
 
 (defmethod lisplet-check-authorization ((lisplet lisplet))
   (let* ((connector (clawserver-connector *clawserver*))
@@ -230,7 +230,7 @@
          (protected-resources (lisplet-protected-resources lisplet))
          (princp (current-principal))
          (login-config (current-config))
-         (login-page-url (format nil "~a/~a" base-path (lisplet-login-page lisplet)))
+         (login-page-url (format nil "~a~a" base-path (lisplet-login-page lisplet)))
          (sslport (connector-sslport connector))
          (auth-basicp (eq (lisplet-authentication-type lisplet) :basic)))
     (when (or (string= uri base-path) (string= uri (concatenate 'string base-path "/")))
@@ -240,22 +240,23 @@
       (when (and auth-basicp (null princp))
         (configuration-login login-config))
       (setf princp (current-principal))
-      (loop for protected-resource in protected-resources
+      (loop for protected-resource in (append (list (cons (lisplet-login-page lisplet) nil)) protected-resources)
          for match = (format nil "~a/~a" base-path (car protected-resource))
          for allowed-roles = (cdr protected-resource)
          do
+         (progn
            (when (or (starts-with-subseq match uri) (string= login-page-url uri))
              (cond
-               ((and princp (not (user-in-role-p allowed-roles)) (not (string= login-page-url uri)))
+               ((and princp allowed-roles (not (user-in-role-p allowed-roles)) (not (string= login-page-url uri)))
                 (setf (claw-return-code) +http-forbidden+)
                 (throw 'handler-done nil))
                ((and (null princp) auth-basicp)
                 (setf (claw-return-code) +http-authorization-required+
                       (claw-header-out "WWW-Authenticate") (format nil "Basic realm=\"~A\"" *claw-current-realm*))
                 (throw 'handler-done nil))
-               ((and (null princp) (null auth-basicp) (not (string= login-page-url uri)))
-                (redirect-to-https login-page-url)
-                (throw 'handler-done nil))
+               ((and (null princp)
+                     (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)
-                (throw 'handler-done nil))))))))
+                (redirect-to-https (format nil "~a~a" *root-path* (car protected-resource)))
+                (throw 'handler-done nil)))))))))

Modified: trunk/main/claw/src/misc.lisp
==============================================================================
--- trunk/main/claw/src/misc.lisp	(original)
+++ trunk/main/claw/src/misc.lisp	Mon Sep  8 05:33:16 2008
@@ -75,6 +75,14 @@
     "The three-character names of the twelve months - needed for cookie
 date format.")
 
+  (defvar *root-path*
+    nil
+    "The eventually froxified lisplet path ")
+  
+  (defvar *server-path*
+    nil
+    "The eventually froxified claw server path ")
+
   (defmacro def-http-return-code (name value reason-phrase)
     "Shortcut to define constants for return codes.  NAME is a
 Lisp symbol, VALUE is the numerical value of the return code, and
@@ -223,7 +231,7 @@
 (defun claw-server-port ()
   "Wrapper function around CLAWSERVER-SERVER-PORT.
 Returns the IP port \(as a number) where the request came in."
-  (clawserver-server-addr *clawserver*))
+  (clawserver-server-port *clawserver*))
 
 (defun claw-user-agent ()
   "Wrapper function around CLAWSERVER-USER-AGENT.
@@ -339,7 +347,7 @@
   "Wrapper function around CLAWSERVER-REDIRECT.
 Sends back appropriate headers to redirect the client to target \(a string)."
   (clawserver-redirect *clawserver* target
-                       :host (or host (lisplet-server-address *claw-current-lisplet*))
+                       :host (or host (claw-host-name))
                        :port port
                        :protocol protocol
                        :add-session-id add-session-id :code code))
@@ -392,7 +400,7 @@
 (defun claw-start-session (&key max-time domain)
   "Starts a session bound to the current lisplet base path"
   (session-manager-start-session (clawserver-session-manager *clawserver*)
-                                 :path (format nil "~a/" (build-lisplet-location *claw-current-lisplet*))
+                                 :path (format nil "~a/" *root-path*)
                                  :max-time max-time
                                  :domain domain))
 
@@ -540,3 +548,22 @@
             minute
             second)))
 
+(defun claw-host-name ()
+  "Extracts the host name from the HOST header-in parameter or the X-FORWARDED-HOST, if present"
+  (first (split-sequence #\: (or (claw-header-in 'x-forwarded-host) (claw-header-in 'host)))))
+
+(defun claw-host-port ()
+  "Extracts the host port from the HOST header-in parameter or the X-FORWARDED-HOST, if present"
+  (second (split-sequence #\: (or (claw-header-in 'x-forwarded-host) (claw-header-in 'host)))))
+
+(defun claw-host-protocol ()
+  "Return :HTTP or :HTTPS depending on the header HOST parameter"
+  (let ((port (parse-integer (second (split-sequence #\: (claw-header-in 'host)))))
+        (connector (clawserver-connector *clawserver*)))
+    (if (= port (connector-port connector))
+        :http
+        :https)))
+
+(defun claw-proxified-p ()
+  "Retrun a non NIL value when the request is handled by a proxy"
+  (claw-header-in 'x-forwarded-host))
\ No newline at end of file

Modified: trunk/main/claw/src/packages.lisp
==============================================================================
--- trunk/main/claw/src/packages.lisp	(original)
+++ trunk/main/claw/src/packages.lisp	Mon Sep  8 05:33:16 2008
@@ -56,6 +56,10 @@
            #:claw-header-in
            #:claw-headers-in
            #:claw-authorization
+           #:claw-host-name
+           #:claw-host-port
+           #:claw-host-protocol
+           #:claw-proxified-p
            #:claw-remote-addr
            #:claw-remote-port
            #:claw-real-remote-addr
@@ -91,7 +95,6 @@
            #:claw-cookie-http-only
 
            #:connector
-           #:connector-behind-apache-p
            #:connector-host
            #:connector-request-method
            #:connector-script-name
@@ -149,8 +152,11 @@
            #:lisplet-register-resource-location
            #:lisplet-protect
            #:lisplet-authentication-type
+           #:lisplet-reverse-proxy-path
 
-           #:build-lisplet-location
+           ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;#:build-lisplet-location
+           #:*root-path*
+           #:*server-path*
            ;; claw-service
            #:claw-service
            #:claw-service-name

Modified: trunk/main/claw/src/server.lisp
==============================================================================
--- trunk/main/claw/src/server.lisp	(original)
+++ trunk/main/claw/src/server.lisp	Mon Sep  8 05:33:16 2008
@@ -224,11 +224,9 @@
 (defgeneric (setf clawserver-sslport) (sslport clawserver)
   (:documentation "Sets the claw server https port. When server is started an error will be signaled."))
 
-(defgeneric (setf clawserver-address) (address clawserver)
+(defgeneric clawserver-address (clawserver)
   (:documentation "Binds the claw server to a specific address.  When server is started an error will be signaled."))
 
-(defgeneric clawserver-behind-apache-p (clawserver)
-  (:documentation "Returns true if the server (or better, the connector) is running behind apache."))
 ;;-----------------------------------------------------------------------------------------------
 (defgeneric (setf clawserver-read-timeout) (read-timeout clawserver)
   (:documentation "Sets the read timeout in seconds. When server is started an error will be signaled."))
@@ -250,6 +248,15 @@
   ((base-path :initarg :base-path
 	      :accessor clawserver-base-path
 	      :documentation "This slot is used to keep all server resources under a common URL")
+   (proxy-http-port :initarg :proxy-http-port
+                    :accessor clawserver-proxy-http-port
+                    :documentation "The port eventually used to proxify http requests")
+   (proxy-https-port :initarg :proxy-https-port
+                     :accessor clawserver-proxy-https-port
+                     :documentation "The port eventually used to proxify https requests")
+   (reverse-proxy-path :initarg :reverse-proxy-path
+                       :accessor clawserver-reverse-proxy-path
+                       :documentation "When request is sent via proxy, use this value to build absolute paths")
    (connector :initarg :connector
               :accessor clawserver-connector
               :documentation "Reads or sets the server connector that dispatches requests and processes replies from the remote host.")
@@ -271,6 +278,9 @@
 	     :accessor clawserver-lisplets
 	     :documentation "A collection of cons where the car is an url location where a lisplet is registered and the cdr is the lisplet"))
   (:default-initargs :base-path ""
+    :proxy-http-port *apache-http-port*
+    :proxy-https-port *apache-https-port*
+    :reverse-proxy-path nil
     :services (make-hash-table))
   (:documentation "CLAWSERVER is built around huncentoot and has the
 instructions for lisplet dispatching, so use this class to start and stop
@@ -294,6 +304,9 @@
          (base-path (clawserver-base-path clawserver))
          (lisplets (clawserver-lisplets clawserver))
          (script-name (connector-script-name connector))
+         (*server-path* (or (when (claw-proxified-p) 
+                              (clawserver-reverse-proxy-path clawserver))
+                            (clawserver-base-path clawserver)))
          (rel-script-name)
          (rel-script-name-libs)
          (http-result nil))
@@ -510,14 +523,14 @@
 (defmethod clawserver-redirect (clawserver target &key host port protocol add-session-id code)
   (connector-redirect (clawserver-connector clawserver) target :host host :port port :protocol protocol :add-session-id add-session-id :code code))
 
-(defmethod clawserver-behind-apache-p ((clawserver clawserver))
-  (connector-behind-apache-p (clawserver-connector clawserver)))
-
 (defmethod clawserver-script-name ((clawserver clawserver))
   (connector-script-name (clawserver-connector clawserver)))
 
+(defmethod clawserver-address ((clawserver clawserver))
+  (connector-address (clawserver-connector clawserver)))
+
 (defmethod error-renderer ((clawserver clawserver) &key (error-code 404))
-  (let ((request-uri (connector-request-uri (clawserver-connector clawserver)))
+  (let ((request-uri (format nil "~a/~a" *server-path* (subseq (claw-script-name) (1+ (length (clawserver-base-path clawserver))))))
         (connector (clawserver-connector clawserver))
         (style "body {
   font-family: arial, elvetica;

Modified: trunk/main/claw/src/session-manager.lisp
==============================================================================
--- trunk/main/claw/src/session-manager.lisp	(original)
+++ trunk/main/claw/src/session-manager.lisp	Mon Sep  8 05:33:16 2008
@@ -283,7 +283,7 @@
             (let ((cookie (make-instance 'claw-cookie
                                          :name cookie-name
                                          :expires (get-universal-time)
-                                         :path (format nil "~a/" (build-lisplet-location *claw-current-lisplet*))
+                                         :path (format nil "~a/" *root-path*)
                                          :domain nil
                                          :value "")))
               (setf (connector-cookie-out connector cookie-name) cookie)))
@@ -337,9 +337,18 @@
                   *claw-session* session))))))
 
 (defmethod session-manager-remove-session ((session-manager default-session-manager) &optional session)
-  (let ((current-session (or session (default-session-manager-current-session session-manager))))
+  (let ((connector (clawserver-connector *clawserver*))
+        (cookie-name (default-session-manager-session-cookie-name session-manager))
+        (current-session (or session (default-session-manager-current-session session-manager))))
     (bt:with-lock-held ((default-session-manager-service-lock session-manager))
-      (remhash (session-id current-session) (default-session-manager-sessions session-manager)))))
+      (remhash (session-id current-session) (default-session-manager-sessions session-manager))
+      (let ((cookie (make-instance 'claw-cookie
+                                   :name cookie-name
+                                   :expires (get-universal-time)
+                                   :path (format nil "~a/" *root-path*)
+                                   :domain nil
+                                   :value "")))
+        (setf (connector-cookie-out connector cookie-name) cookie)))))
 
 (defmethod session-manager-session-value ((session-manager default-session-manager) symbol)
   (let ((session (default-session-manager-current-session session-manager)))


From achiumenti at common-lisp.net  Mon Sep  8 09:34:13 2008
From: achiumenti at common-lisp.net (achiumenti at common-lisp.net)
Date: Mon,  8 Sep 2008 05:34:13 -0400 (EDT)
Subject: [claw-cvs] r86 - trunk/main/connectors/hunchentoot/src
Message-ID: <20080908093413.70F997A090@common-lisp.net>

Author: achiumenti
Date: Mon Sep  8 05:34:13 2008
New Revision: 86

Modified:
   trunk/main/connectors/hunchentoot/src/hunchentoot.lisp
   trunk/main/connectors/hunchentoot/src/packages.lisp
Log:
CLAW redirection bugfix

Modified: trunk/main/connectors/hunchentoot/src/hunchentoot.lisp
==============================================================================
--- trunk/main/connectors/hunchentoot/src/hunchentoot.lisp	(original)
+++ trunk/main/connectors/hunchentoot/src/hunchentoot.lisp	Mon Sep  8 05:34:13 2008
@@ -33,9 +33,6 @@
       hunchentoot:*default-content-type* "text/html; charset=utf-8"
       hunchentoot:*handle-http-errors-p* nil)
 
-(defgeneric claw-to-hunchentoot-cookie (claw-cookie)
-  (:documentation "Returns hunchentoot cookie from a claw cookie"))
-
 (defgeneric hunchentoot-to-claw-cookie (hunchentoot-cookie)
   (:documentation "Returns a claw cookie from a hunchentoot cookie"))
 
@@ -113,15 +110,8 @@
 	   :documentation "The hunchentoot server dispatching http requests.")
    (sslserver :initform nil
               :accessor hunchentoot-connector-sslserver
-              :documentation "The hunchentoot server dispatching https requests.")
-   (http-p :initarg :http-p
-           :reader hunchentoot-connector-http-p
-           :documentation "When true the http server is enabled.")
-   (https-p :initarg :https-p
-            :reader hunchentoot-connector-https-p
-            :documentation "When true the https server is enabled if ssl-certificate-file is provided."))
-  (:default-initargs :http-p t :https-p nil
-                     :mod-lisp-p nil
+              :documentation "The hunchentoot server dispatching https requests."))
+  (:default-initargs :mod-lisp-p nil
                      :use-apache-log-p nil
                      :input-chunking-p nil 
                      :read-timeout hunchentoot:*default-read-timeout*
@@ -152,7 +142,7 @@
          (ssl-privatekey-file (hunchentoot-connector-ssl-privatekey-file connector))
          (ssl-privatekey-password (hunchentoot-connector-ssl-privatekey-password connector)))
     (progn
-      (when (hunchentoot-connector-http-p connector)
+      (when port
         (setf (hunchentoot-connector-server connector)
               (hunchentoot:start-server :port port
                                         :address address
@@ -164,21 +154,21 @@
                                         :write-timeout write-timeout
                                         #+(and :unix (not :win32)) :setuid uid
                                         #+(and :unix (not :win32)) :setgid gid)))
-      #-:hunchentoot-no-ssl (when (and (hunchentoot-connector-https-p connector) ssl-certificate-file)
-                              (setf (hunchentoot-connector-sslserver connector)
-                                    (hunchentoot:start-server :port sslport
-                                                              :address address
-                                                              :dispatch-table dispatch-table
-                                                              :mod-lisp-p mod-lisp-p
-                                                              :use-apache-log-p use-apache-log-p
-                                                              :input-chunking-p input-chunking-p
-                                                              :read-timeout read-timeout
-                                                              :write-timeout write-timeout
-                                                              #+(and :unix (not :win32)) :setuid uid
-                                                              #+(and :unix (not :win32)) :setgid gid
-                                                              :ssl-certificate-file ssl-certificate-file
-                                                              :ssl-privatekey-file ssl-privatekey-file
-                                                              :ssl-privatekey-password ssl-privatekey-password))))))
+      (when sslport
+        (setf (hunchentoot-connector-sslserver connector)
+              (hunchentoot:start-server :port sslport
+                                        :address address
+                                        :dispatch-table dispatch-table
+                                        :mod-lisp-p mod-lisp-p
+                                        :use-apache-log-p use-apache-log-p
+                                        :input-chunking-p input-chunking-p
+                                        :read-timeout read-timeout
+                                        :write-timeout write-timeout
+                                        #+(and :unix (not :win32)) :setuid uid
+                                        #+(and :unix (not :win32)) :setgid gid
+                                        #-:hunchentoot-no-ssl :ssl-certificate-file ssl-certificate-file
+                                        #-:hunchentoot-no-ssl :ssl-privatekey-file ssl-privatekey-file
+                                        #-:hunchentoot-no-ssl :ssl-privatekey-password ssl-privatekey-password))))))
 
 (defmethod claw-service-stop :before ((connector hunchentoot-connector))
   (let ((server (hunchentoot-connector-server connector))
@@ -323,9 +313,9 @@
 
 (defmethod connector-redirect ((connector hunchentoot-connector) target &key host port protocol add-session-id code)
   (hunchentoot:redirect target
-                        :host (or host (connector-server-addr connector))
-                        :port (or port (connector-server-port connector))
-                        :protocol (or protocol (connector-server-protocol connector))
+                        :host host
+                        :port port
+                        :protocol protocol
                         :add-session-id add-session-id
                         :code code))
 
@@ -385,15 +375,6 @@
 (defmethod (setf connector-content-length) (value (connector hunchentoot-connector))
   (setf (hunchentoot:content-length) value))
 
-(defmethod claw-to-hunchentoot-cookie ((cookie claw-cookie))
-  (make-instance 'hunchentoot::cookie 
-                 :name (claw-cookie-name cookie)
-                 :value (claw-cookie-value cookie)
-                 :expires (claw-cookie-expires cookie)
-                 :path (claw-cookie-path cookie)
-                 :domoain (claw-cookie-domain cookie)
-                 :secure (claw-cookie-secure cookie)
-                 :http-only (claw-cookie-http-only cookie)))
 
 (defmethod hunchentoot-to-claw-cookie ((cookie hunchentoot::cookie))
   (make-instance 'claw-cookie 

Modified: trunk/main/connectors/hunchentoot/src/packages.lisp
==============================================================================
--- trunk/main/connectors/hunchentoot/src/packages.lisp	(original)
+++ trunk/main/connectors/hunchentoot/src/packages.lisp	Mon Sep  8 05:34:13 2008
@@ -1,4 +1,4 @@
-(in-package :cl-user)
+y(in-package :cl-user)
 
 (defpackage :hunchentoot-connector
   (:use :cl :claw)


From achiumenti at common-lisp.net  Mon Sep  8 09:35:08 2008
From: achiumenti at common-lisp.net (achiumenti at common-lisp.net)
Date: Mon,  8 Sep 2008 05:35:08 -0400 (EDT)
Subject: [claw-cvs] r87 - trunk/main/claw-html.dojo/src
Message-ID: <20080908093508.9CB64A107@common-lisp.net>

Author: achiumenti
Date: Mon Sep  8 05:35:07 2008
New Revision: 87

Modified:
   trunk/main/claw-html.dojo/src/djbody.lisp
   trunk/main/claw-html.dojo/src/djdialog.lisp
   trunk/main/claw-html.dojo/src/djform.lisp
   trunk/main/claw-html.dojo/src/misc.lisp
Log:
CLAW dojo bugfixex

Modified: trunk/main/claw-html.dojo/src/djbody.lisp
==============================================================================
--- trunk/main/claw-html.dojo/src/djbody.lisp	(original)
+++ trunk/main/claw-html.dojo/src/djbody.lisp	Mon Sep  8 05:35:07 2008
@@ -55,7 +55,7 @@
              :documentation "Additional dojo configurations"))
   (:metaclass metacomponent)
   (:default-initargs :class "" :theme "tundra"
-                     :themes-url (format nil "~a/dojotoolkit/dijit/themes/" (clawserver-base-path *clawserver*))
+                     :themes-url (format nil "~a/dojotoolkit/dijit/themes/" *server-path*)
                      :parse-on-load "true"
                      :load-dojo-js t
                      :is-debug nil
@@ -77,7 +77,7 @@
         (djconfig (djbody-djconfig o)))
     (when (load-dojo-js o)
       (script> :type "text/javascript"
-               :src  (format nil "~a/dojotoolkit/dojo/dojo.js" (clawserver-base-path *clawserver*))
+               :src  (format nil "~a/dojotoolkit/dojo/dojo.js" *server-path*)
                :djconfig (if (null djconfig)
                              (format nil
                                      "parseOnLoad:~a,usePlainJson:true,isDebug:~a"
@@ -90,8 +90,8 @@
 (defmethod htcomponent-stylesheet-files ((o djbody))
   (let ((theme (djbody-theme o)))
     (list
-     (format nil "~a/dojotoolkit/dojo/resources/dojo.css" (clawserver-base-path *clawserver*))
-     (format nil "~a/dojotoolkit/dijit/themes/dijit.css" (clawserver-base-path *clawserver*))
+     (format nil "~a/dojotoolkit/dojo/resources/dojo.css" *server-path*)
+     (format nil "~a/dojotoolkit/dijit/themes/dijit.css" *server-path*)
      (format nil "~a~a/~a.css" (djbody-themes-url o) theme theme))))
 
 

Modified: trunk/main/claw-html.dojo/src/djdialog.lisp
==============================================================================
--- trunk/main/claw-html.dojo/src/djdialog.lisp	(original)
+++ trunk/main/claw-html.dojo/src/djdialog.lisp	Mon Sep  8 05:35:07 2008
@@ -33,7 +33,7 @@
   ()
   (:metaclass metacomponent)
   (:documentation "Class for dojo dijit.Dialog component. More info at http://api.dojotoolkit.org/")
-  (:default-initargs :dojo-type "dijit.Dialog"))
+  (:default-initargs :dojo-type "claw.Dialog"))
 
 (defclass djdialog (wcomponent)
   ()

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	Mon Sep  8 05:35:07 2008
@@ -417,7 +417,7 @@
                      :translator *file-translator*))
 
 (defmethod htcomponent-stylesheet-files((djtext-box-file djtext-box-file))
-  (list (format nil "~a/dojotoolkit/dojox/widget/FileInput/FileInput.css" (clawserver-base-path *clawserver*))))
+  (list (format nil "~a/dojotoolkit/dojox/widget/FileInput/FileInput.css" *server-path*)))
 
 (defclass djeditor (djtextarea)
   ((form :initform nil

Modified: trunk/main/claw-html.dojo/src/misc.lisp
==============================================================================
--- trunk/main/claw-html.dojo/src/misc.lisp	(original)
+++ trunk/main/claw-html.dojo/src/misc.lisp	Mon Sep  8 05:35:07 2008
@@ -42,3 +42,4 @@
 (register-library-resource "dojotoolkit/claw/Form.js"  (make-pathname :directory (append (pathname-directory *dojo-misc-file*) '("js")) :name "Form" :type "js"))
 (register-library-resource "dojotoolkit/claw/Editor.js"  (make-pathname :directory (append (pathname-directory *dojo-misc-file*) '("js")) :name "Editor" :type "js"))
 (register-library-resource "dojotoolkit/claw/ActionLink.js"  (make-pathname :directory (append (pathname-directory *dojo-misc-file*) '("js")) :name "ActionLink" :type "js"))
+(register-library-resource "dojotoolkit/claw/Dialog.js"  (make-pathname :directory (append (pathname-directory *dojo-misc-file*) '("js")) :name "Dialog" :type "js"))


From achiumenti at common-lisp.net  Mon Sep  8 09:36:05 2008
From: achiumenti at common-lisp.net (achiumenti at common-lisp.net)
Date: Mon,  8 Sep 2008 05:36:05 -0400 (EDT)
Subject: [claw-cvs] r88 - trunk/main/claw-html.dojo/src/js
Message-ID: <20080908093605.14297A107@common-lisp.net>

Author: achiumenti
Date: Mon Sep  8 05:36:04 2008
New Revision: 88

Modified:
   trunk/main/claw-html.dojo/src/js/Dialog.js
Log:
CLAW dojo dialo enhancement

Modified: trunk/main/claw-html.dojo/src/js/Dialog.js
==============================================================================
--- trunk/main/claw-html.dojo/src/js/Dialog.js	(original)
+++ trunk/main/claw-html.dojo/src/js/Dialog.js	Mon Sep  8 05:36:04 2008
@@ -1,5 +1,5 @@
 /**
-;;; $Header: dojo/src/js/HardLink.js $
+;;; $Header: dojo/src/js/Dialog.js $
 
 ;;; Copyright (c) 2008, Andrea Chiumenti.  All rights reserved.
 
@@ -28,13 +28,31 @@
 ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 */
 
-//if(!dojo._hasResource["claw.Dialog"]){ //_hasResource checks added by build. Do not use _hasResource directly in your code.
+if(!dojo._hasResource["claw.Dialog"]){ //_hasResource checks added by build. Do not use _hasResource directly in your code.
     dojo.provide("claw.Dialog");
 
     dojo.require("dijit.Dialog");
 
     dojo.declare(
         "claw.Dialog",
-        dijit.Dialog
+        [dijit.Dialog],
+        {
+            closable: true,
+            templateString:  "<div class=\"dijitDialog\" tabindex=\"-1\" waiRole=\"dialog\" waiState=\"labelledby-${id}_title\">\n\t<div dojoAttachPoint=\"titleBar\" class=\"dijitDialogTitleBar\">\n\t<span dojoAttachPoint=\"titleNode\" class=\"dijitDialogTitle\" id=\"${id}_title\">${title}</span>\n\t<span dojoAttachPoint=\"closeButtonNode\" class=\"dijitDialogCloseIcon\" dojoAttachEvent=\"onclick: onCancel\">\n\t\t<span dojoAttachPoint=\"closeText\" class=\"closeText\">x</span>\n\t</span>\n\t</div>\n\t\t<div dojoAttachPoint=\"containerNode\" class=\"dijitDialogPaneContent\"></div>\n</div>\n",
+            templateStringUnclosable:  "<div class=\"dijitDialog\" tabindex=\"-1\" waiRole=\"dialog\" waiState=\"labelledby-${id}_title\">\n\t<div dojoAttachPoint=\"titleBar\" class=\"dijitDialogTitleBar\">\n\t<span dojoAttachPoint=\"titleNode\" class=\"dijitDialogTitle\" id=\"${id}_title\">${title}</span>\n\t</div>\n\t\t<div dojoAttachPoint=\"containerNode\" class=\"dijitDialogPaneContent\"></div>\n</div>\n",
+            _onKey: function(/*Event*/ evt){
+                if((evt.charOrCode == dojo.keys.ESCAPE) && !(this.closable)) {
+                    return;
+                } else {
+                    this.inherited(arguments);
+                }
+            },
+            postMixInProperties: function(){
+                if (!this.closable) {
+                    this.templateString = this.templateStringUnclosable;
+                }
+                this.inherited(arguments);
+            }
+        }
     );
-//}
\ No newline at end of file
+}
\ No newline at end of file


From achiumenti at common-lisp.net  Mon Sep  8 09:37:00 2008
From: achiumenti at common-lisp.net (achiumenti at common-lisp.net)
Date: Mon,  8 Sep 2008 05:37:00 -0400 (EDT)
Subject: [claw-cvs] r89 - in trunk/main/claw-demo/src/frontend: . docroot/css
Message-ID: <20080908093700.6534BA107@common-lisp.net>

Author: achiumenti
Date: Mon Sep  8 05:36:59 2008
New Revision: 89

Modified:
   trunk/main/claw-demo/src/frontend/commons.lisp
   trunk/main/claw-demo/src/frontend/docroot/css/style.css
   trunk/main/claw-demo/src/frontend/index.lisp
   trunk/main/claw-demo/src/frontend/login.lisp
   trunk/main/claw-demo/src/frontend/logout.lisp
   trunk/main/claw-demo/src/frontend/main.lisp
Log:
CLAW demo enhancement

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	Mon Sep  8 05:36:59 2008
@@ -59,7 +59,7 @@
     (html>
      (head>
       (title> (site-template-title site-template))
-      (link> :href (format nil "~a/docroot/css/style.css" (build-lisplet-location *claw-current-lisplet*))
+      (link> :href (format nil "~a/docroot/css/style.css" *root-path*)
              :rel "stylesheet"
              :type "text/css"))
      (djbody> :is-debug "false"
@@ -75,17 +75,17 @@
                                                (djmenu>
                                                 (djmenu-item> :id "loginMenu"
                                                               :render-condition #'(lambda () (null principal))
-                                                              :on-click (ps:ps* `(location.replace ,(format nil "~a/login.html" (build-lisplet-location *claw-current-lisplet*))))
+                                                              :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" (build-lisplet-location *claw-current-lisplet*))))
+                                                              :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" (build-lisplet-location *claw-current-lisplet*))))
+                                                              :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")))

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	Mon Sep  8 05:36:59 2008
@@ -23,10 +23,6 @@
     margin-top:0;
 }
 
-.unclosable .dijitDialogCloseIcon {
-    display: none;
-}
-
 .dialogLabel {
     width: 80px;
     text-align: right;

Modified: trunk/main/claw-demo/src/frontend/index.lisp
==============================================================================
--- trunk/main/claw-demo/src/frontend/index.lisp	(original)
+++ trunk/main/claw-demo/src/frontend/index.lisp	Mon Sep  8 05:36:59 2008
@@ -38,6 +38,10 @@
 
 (defmethod page-content ((o index-page))
   (site-template> :title "Home test page"
+                  (div> (format nil "~a" (claw-headers-in)))
+                  (div> (format nil "~a" (claw-script-name)))
+                  (div> (format nil "~a" "popopo" ))
+                  
                   (ul>
                    (li> (a> :href "index.html" "Home"))
                    (li> (a> :href "info.html" "HTTP Header info"))

Modified: trunk/main/claw-demo/src/frontend/login.lisp
==============================================================================
--- trunk/main/claw-demo/src/frontend/login.lisp	(original)
+++ trunk/main/claw-demo/src/frontend/login.lisp	Mon Sep  8 05:36:59 2008
@@ -45,6 +45,7 @@
                     (djdialog> :id "loginDialog" 
                                :title "Login into system"
                                :class "unclosable"
+                               :closable "false"
                                (djfloating-content> :static-id spinner-id
                                            (img> :alt "spinner"
                                                  :src "docroot/img/spinner.gif"))
@@ -73,7 +74,7 @@
                                (div> :static-id login-result-id
                                      (redirect> :render-condition #'current-principal 
                                                 :id "redirect"
-                                                :href (format nil "~a/index.html" (build-lisplet-location *claw-current-lisplet*)))))
+                                                :href (format nil "~a/index.html" *root-path*))))
                     (script> (ps:ps* `(dojo.add-on-load (lambda () (.show (dijit.by-id "loginDialog")))))))))
  
 (lisplet-register-function-location *dojo-demo-lisplet* 

Modified: trunk/main/claw-demo/src/frontend/logout.lisp
==============================================================================
--- trunk/main/claw-demo/src/frontend/logout.lisp	(original)
+++ trunk/main/claw-demo/src/frontend/logout.lisp	Mon Sep  8 05:36:59 2008
@@ -39,7 +39,7 @@
 
 (defmethod do-logout ((demo-page logout-page))
   (claw-remove-session)
-  (claw-redirect (format nil "~a/index.html" (build-lisplet-location *claw-current-lisplet*)) :protocol :http))
+  (claw-redirect (format nil "~a/index.html" *root-path*) :protocol :http))
 
 (lisplet-register-function-location *dojo-demo-lisplet* 
                                     (make-page-renderer 'logout-page #'claw-post-parameters #'claw-get-parameters) 

Modified: trunk/main/claw-demo/src/frontend/main.lisp
==============================================================================
--- trunk/main/claw-demo/src/frontend/main.lisp	(original)
+++ trunk/main/claw-demo/src/frontend/main.lisp	Mon Sep  8 05:36:59 2008
@@ -40,10 +40,9 @@
                                          :base-path "/demo"))
 
 (defvar *ht-connector* (make-instance 'hunchentoot-connector
+                                      :address "localhost"
                                       :port 4242
-                                      :sslport nil
-                                      :behind-apache-p t
-                                      :mod-lisp-p nil))
+                                      :sslport 4343))
 
 (defvar *sm* (make-instance 'default-session-manager))
 
@@ -53,7 +52,8 @@
                                          :connector *ht-connector*
                                          :log-manager *ht-log-manager*
                                          :session-manager *sm*
-                                         :base-path "/claw"))
+                                         :base-path "/claw"
+                                         :reverse-proxy-path "/claw1"))
 
 (clawserver-register-lisplet *dojo-clawserver* *dojo-demo-lisplet*)
 


From achiumenti at common-lisp.net  Thu Sep 18 13:30:00 2008
From: achiumenti at common-lisp.net (achiumenti at common-lisp.net)
Date: Thu, 18 Sep 2008 09:30:00 -0400 (EDT)
Subject: [claw-cvs] r90 - trunk/main/claw-html/src
Message-ID: <20080918133000.94C726A052@common-lisp.net>

Author: achiumenti
Date: Thu Sep 18 09:29:59 2008
New Revision: 90

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
   trunk/main/claw-html/src/validators.lisp
Log:
several bugfixes

Modified: trunk/main/claw-html/src/components.lisp
==============================================================================
--- trunk/main/claw-html/src/components.lisp	(original)
+++ trunk/main/claw-html/src/components.lisp	Thu Sep 18 09:29:59 2008
@@ -77,7 +77,10 @@
   (:documentation "Internal use component"))
 
 (defclass _cform-mixin (_cform)
-  ()
+  ((validator :initarg :validator
+	      :reader validator
+	      :documentation "A function that accept the passed component value during submission and performs the validation logic calling the validator functions."))
+  (:default-initargs :validator nil)
   (:documentation "Internal use component"))
 
 
@@ -86,13 +89,17 @@
     (when (not (and render-condition (null (funcall render-condition))))
       (setf (cform-execute-p obj) t))))
 
-(defmethod wcomponent-after-rewind ((obj _cform) (pobj page))
+(defmethod wcomponent-after-rewind ((obj _cform-mixin) (pobj page))
   (let ((validation-errors *validation-errors*)
-	(action (action obj)))
+	(action (action obj))
+        (validator (validator obj)))
     (when (and (null validation-errors)
                action
-               (cform-rewinding-p obj pobj))      
-      (funcall action (action-object obj)))))
+               (cform-rewinding-p obj pobj))
+      (when validator
+	  (funcall validator obj))
+      (unless *validation-errors*
+        (funcall action (action-object obj))))))
 
 (defmethod cform-rewinding-p ((cform _cform) (page page))
   (string= (htcomponent-client-id cform)
@@ -197,6 +204,9 @@
 
 
 ;---------------------------------------------------------------------------------------
+(defgeneric translated-value (base-cinput)
+  (:documentation "Returns the component value using its translator"))
+
 (defclass base-cinput (wcomponent)
   ((result-as-list-p :initarg :multiple
 		   :accessor cinput-result-as-list-p
@@ -273,16 +283,19 @@
 	    :value value
 	    (wcomponent-informal-parameters cinput))))
 
+(defmethod translated-value ((cinput base-cinput))
+  (translator-decode (translator cinput) cinput))
+
 (defmethod wcomponent-after-rewind ((cinput base-cinput) (page page))
   (when (cform-rewinding-p (page-current-form page) page)
     (let ((visit-object (cinput-visit-object cinput))
           (accessor (cinput-accessor cinput))
           (writer (cinput-writer cinput))
           (validator (validator cinput))
-          (value (translator-decode (translator cinput) cinput)))
+          (value (translated-value cinput)))
       (unless (or (null value) (null visit-object) (component-validation-errors cinput))
 	(when validator
-	  (funcall validator value))
+	  (funcall validator cinput))
 	(unless (component-validation-errors cinput)
 	  (if (and (null writer) accessor)
 	      (funcall (fdefinition `(setf ,accessor)) value visit-object)
@@ -393,8 +406,8 @@
           (current-form (page-current-form pobj))
           (submitted-p (page-req-parameter pobj (htcomponent-client-id obj))))
       (unless (or (null current-form) (null submitted-p) (null action))
-        (setf (action current-form) action
-              (action-object current-form) (or (action-object obj) (action-object current-form)))))))
+        (setf (action (page-current-form pobj)) action
+              (action-object (page-current-form pobj)) (or (action-object obj) (action-object current-form)))))))
 
 ;-----------------------------------------------------------------------------
 (defclass submit-link (csubmit)
@@ -468,7 +481,12 @@
             :accessor ccheckbox-value))
     (:metaclass metacomponent)
     (:default-initargs :reserved-parameters (list :name) :empty t :type "checkbox" :test #'equal)
-    (:documentation "Request cycle aware component the renders as an INPUT tag class"))
+    (: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))
 
 (let ((class (find-class 'ccheckbox)))
   (closer-mop:ensure-finalized class)
@@ -486,8 +504,9 @@
          (translator (translator cinput))
          (type (input-type cinput))
          (value (translator-value-type-to-string translator (ccheckbox-value cinput)))
-         (current-value (translator-type-to-string translator cinput))
-         (class (css-class cinput)))
+         (current-value (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")
@@ -497,23 +516,29 @@
 	    :name (name-attr cinput)
 	    :class class
 	    :value value
-            :checked (when (and current-value (equal value current-value)) "checked")
+            :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")
 	    (wcomponent-informal-parameters cinput))))
 
 (defmethod wcomponent-after-rewind ((cinput ccheckbox) (page page))
   (when (cform-rewinding-p (page-current-form page) page)
     (let* ((visit-object (cinput-visit-object cinput))
-           (client-id (htcomponent-client-id 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
-                                          client-id
+                                          name
                                           result-as-list-p)))
       (when new-value
-        (setf new-value (translator-string-to-type translator cinput)))
+        (setf new-value (if result-as-list-p 
+                            (loop for item in new-value
+                                 collect (translator-value-string-to-type translator item))
+                            (translator-string-to-type translator cinput))))
       (unless (or (null visit-object) (component-validation-errors cinput))
         (when validator
           (funcall validator (or new-value "")))

Modified: trunk/main/claw-html/src/packages.lisp
==============================================================================
--- trunk/main/claw-html/src/packages.lisp	(original)
+++ trunk/main/claw-html/src/packages.lisp	Thu Sep 18 09:29:59 2008
@@ -197,6 +197,7 @@
            #:action-link
            #:action-link>
            #:action-link-parameters
+           #:translated-value
            #:cinput
            #:cinput>
            #:ctextarea

Modified: trunk/main/claw-html/src/tags.lisp
==============================================================================
--- trunk/main/claw-html/src/tags.lisp	(original)
+++ trunk/main/claw-html/src/tags.lisp	Thu Sep 18 09:29:59 2008
@@ -602,7 +602,8 @@
     (when parameters
       (setf retval (gethash (string-upcase name) parameters))
       (if (or (null retval) as-list)
-          retval
+          (progn
+            retval)
           (first retval)))))
 
 (defmethod page-format ((page page) str &rest rest)
@@ -715,10 +716,9 @@
         (format nil "~a" js-body))))
 
 (defmethod page-print-tabulation ((page page))
-  (let ((jsonp (page-json-id-list page))
-        (tabulator (page-tabulator page))
+  (let ((tabulator (page-tabulator page))
         (indent-p (page-indent page)))
-    (when (and (<= 0 tabulator) indent-p (null jsonp))
+    (when (and (<= 0 tabulator) indent-p)
       (page-format-raw page "~a"
                        (make-string tabulator :initial-element #\tab)))))
 

Modified: trunk/main/claw-html/src/translators.lisp
==============================================================================
--- trunk/main/claw-html/src/translators.lisp	(original)
+++ trunk/main/claw-html/src/translators.lisp	Thu Sep 18 09:29:59 2008
@@ -80,16 +80,17 @@
           (setf value (cond
                         ((and (null reader) accessor) (funcall (fdefinition accessor) visit-object))
                         (t (funcall (fdefinition reader) visit-object))))
-          (translator-value-encode translator value)))))
+          (if (listp value)
+              (loop for item in value
+                   collect (translator-value-encode translator item))
+              (translator-value-encode translator value))))))
 
 (defmethod translator-type-to-string ((translator translator) (wcomponent cinput))
   (translator-encode translator wcomponent))
 
 (defmethod translator-value-decode ((translator translator) value &optional client-id label)
   (declare (ignore client-id label))
-  (if (string= value "")
-      nil
-      value))
+  value)
 
 (defmethod translator-value-string-to-type ((translator translator) value &optional client-id label)
   (translator-value-decode translator value client-id label))
@@ -97,7 +98,10 @@
 (defmethod translator-decode ((translator translator) (wcomponent wcomponent))
   (multiple-value-bind (client-id value)
       (component-id-and-value wcomponent)
-    (translator-value-decode translator value client-id (label wcomponent))))
+    (if (listp value)
+        (loop for item in value
+                   collect (translator-value-decode translator item client-id (label wcomponent)))
+        (translator-value-decode translator value client-id (label wcomponent)))))
 
 (defmethod translator-string-to-type ((translator translator) (wcomponent wcomponent))
   (translator-decode translator wcomponent))

Modified: trunk/main/claw-html/src/validators.lisp
==============================================================================
--- trunk/main/claw-html/src/validators.lisp	(original)
+++ trunk/main/claw-html/src/validators.lisp	Thu Sep 18 09:29:59 2008
@@ -62,21 +62,23 @@
     (getf *validation-errors* symbol-id)))
 
 (defun validate (test &key component message)
-  "When test is nil, an exception message given by MESSAGE is added for the COMPONENT. See: ADD-VALIDATION-ERROR..."
-  (let ((client-id (htcomponent-client-id component)))
+  "When test is nil, an exception message given by MESSAGE is added for the COMPONENT (that may be a WCOMPONENT instance or an ID string). See: ADD-VALIDATION-ERROR..."
+  (let ((client-id (if (stringp component)
+                       component 
+                       (htcomponent-client-id component))))
     (if test
         (add-validation-compliance client-id)
         (add-validation-error client-id message))))
 
-(defun validate-required (component value &key message)
+(defun validate-required (component value &key message component-label)
   "Checks if the required input field VALUE is present.  If not, a localizable message \"Field ~a may not be empty.\" is sent with key \"VALIDATE-REQUIRED\".
 The argument for the message will be the :label attribute of the COMPONENT."
   (when (stringp value)
     (validate (and value (string-not-equal value ""))
               :component component
-              :message (or message (format nil "Field ~a may not be empty." (label component))))))
+              :message (or message (format nil "Field ~a may not be empty." (or component-label (label component)))))))
 
-(defun validate-size (component value &key min-size max-size message-low message-hi)
+(defun validate-size (component value &key min-size max-size message-low message-hi component-label)
   "Checks if the input field VALUE legth is less then or greater then rispectively of the form keywords :MIN-SIZE and :MAX-SIZE.
 If less then :MIN-SIZE, a localizable message \"Size of ~a may not be less then ~a chars.\" is sent with key \"VALIDATE-SIZE-MIN\".
 The argument for the message will be the :label attribute of the COMPONENT and the :MIN-ZIZE value.
@@ -91,16 +93,16 @@
              (validate (>= value-len min-size)
                        :component component
                        :message (or message-low (format nil "Size of ~a may not be less then ~a chars."
-                                                        (label component)
+                                                        (or component-label (label component))
                                                         min-size))))
            (when max-size
              (validate (<= value-len max-size)
                        :component component
                        :message (or message-hi (format nil "Size of ~a may not be more then ~a chars."
-                                                       (label component)
+                                                       (or component-label (label component))
                                                        max-size))))))))
 
-(defun validate-range (component value &key min max message-low message-hi)
+(defun validate-range (component value &key min max message-low message-hi component-label)
   "Checks if the numeric input field VALUE is less then or greater then rispectively of the form keywords :MIN and :MAX.
 If less then :MIN, a localizable message \"Field ~a is not less then or equal to ~d.\" is sent with key \"VALIDATE-RANGE-MIN\".
 The argument for the message will be the :label attribute of the COMPONENT and the :MIN value.
@@ -111,7 +113,7 @@
            (validate (>= value min)
                      :component component
                      :message (or message-low (format nil "Field ~a is not greater then or equal to ~d"
-                                                      (label component)
+                                                      (or component-label (label component))
                                                       (if (typep min 'ratio)
                                                           (coerce min 'float)
                                                           min)))))
@@ -119,12 +121,12 @@
            (validate (<= value max)
                      :component component
                      :message (or message-hi (format nil "Field ~a is not less then or equal to ~d"
-                                                     (label component)
+                                                     (or component-label (label component))
                                                      (if (typep max 'ratio)
                                                          (coerce max 'float)
                                                          max))))))))
 
-(defun validate-number (component value &key min max message-nan message-low message-hi)
+(defun validate-number (component value &key min max message-nan message-low message-hi component-label)
   "Checks if the input field VALUE is a valid number and then passes the validation to VALIDATION-RANGE.
 If not a number, a localizable message \"Field ~a is not a valid number.\" is sent with key \"VALIDATE-NUMBER\".
 The argument for the message will be the :label attribute of the COMPONENT."
@@ -132,10 +134,11 @@
     (let ((test (numberp value)))
       (and (validate test
                      :component component
-                     :message (or message-nan (format nil "Field ~a is not a valid number." (label component))))
-           (validate-range component value :min min :max max :message-low  message-low :message-hi message-hi)))))
+                     :message (or message-nan (format nil "Field ~a is not a valid number." (or component-label
+                                                                                                (label component)))))
+           (validate-range component value :min min :max max :message-low  message-low :message-hi message-hi :component-label component-label)))))
 
-(defun validate-integer (component value &key min max message-nan message-low message-hi)
+(defun validate-integer (component value &key min max message-nan message-low message-hi component-label)
   "Checks if the input field VALUE is a valid number and then passes the validation to VALIDATION-RANGE.
 If not a number, a localizable message \"Field ~a is not a valid integer.\" is sent with key \"VALIDATE-INTEGER\".
 The argument for the message will be the :label attribute of the COMPONENT."
@@ -143,11 +146,11 @@
     (let ((test (integerp value)))
       (and (validate test
                      :component component
-                     :message (or message-nan (format nil "Field ~a is not a valid integer." (label component))))
-           (validate-range component value :min min :max max :message-low  message-low :message-hi message-hi)))))
+                     :message (or message-nan (format nil "Field ~a is not a valid integer." (or component-label (label component)))))
+           (validate-range component value :min min :max max :message-low  message-low :message-hi message-hi :component-label component-label)))))
 
 
-(defun validate-date-range (component value &key min max (use-date-p t) use-time-p message-low message-hi)
+(defun validate-date-range (component value &key min max (use-date-p t) use-time-p message-low message-hi component-label)
   "Checks if the input field VALUE is a date between min and max.
 If :USE-DATE-P is not nil and :USE-TIME-P is nil, validation is made without considering the time part of local-time.
 If :USE-DATE-P nil and :USE-TIME-P is not nil, validation is made without considering the date part of local-time.
@@ -156,40 +159,40 @@
 The argument for the message will be the :label attribute of the COMPONENT and the value passed to :MIN parsed with the :LOCAL-TIME-FORMAT keyword.
 If value is greater then the date passed to :MAX, a localizable message \"Field ~a is greater then ~a.\" is sent with key \"VALIDATE-DATE-RANGE-MAX\".
 The argument for the message will be the :label attribute of the COMPONENT and the value passed to :MAX parsed with the :LOCAL-TIME-FORMAT keyword."
-  (unless (component-validation-errors component)
-    (let ((local-time-format '(:date "-" :month "-" :year))
-          (new-value (make-instance 'local-time
-                                    :nsec (nsec-of value)
-                                    :sec (sec-of value)
-                                    :day (day-of value)
-                                    :timezone (timezone-of value))))
-      (when (and use-date-p (not use-time-p))
-        (setf (local-time:nsec-of new-value) 0
-              (local-time:sec-of new-value) 0)
-        (when min
-          (setf (local-time:nsec-of min) 0
-                (local-time:sec-of min) 0))
-        (when max
-          (setf (local-time:nsec-of max) 0
-                (local-time:sec-of max) 0)))
-      (when (and (not use-date-p) use-time-p)
-        (setf (local-time:day-of new-value) 0)
-        (when min
-          (setf (local-time:day-of min) 0))
-        (when max
-          (setf (local-time:day-of max) 0)))
-      (and (when min
-             (validate (local-time> new-value min)
-                       :component component
-                       :message (or message-low (format nil "Field ~a is less then ~a."
-                                                        (label component)
-                                                        (local-time-to-string min local-time-format)))))
-           (when max
-             (validate (local-time< new-value max)
-                       :component component
-                       :message (or message-hi (format nil "Field ~a is greater then ~a."
-                                                       (label component)
-                                                       (local-time-to-string max local-time-format)))))))))
+;  (unless (component-validation-errors component))
+  (let ((local-time-format '(:date "-" :month "-" :year))
+        (new-value (make-instance 'local-time
+                                  :nsec (nsec-of value)
+                                  :sec (sec-of value)
+                                  :day (day-of value)
+                                  :timezone (timezone-of value))))
+    (when (and use-date-p (not use-time-p))
+      (setf (local-time:nsec-of new-value) 0
+            (local-time:sec-of new-value) 0)
+      (when min
+        (setf (local-time:nsec-of min) 0
+              (local-time:sec-of min) 0))
+      (when max
+        (setf (local-time:nsec-of max) 0
+              (local-time:sec-of max) 0)))
+    (when (and (not use-date-p) use-time-p)
+      (setf (local-time:day-of new-value) 0)
+      (when min
+        (setf (local-time:day-of min) 0))
+      (when max
+        (setf (local-time:day-of max) 0)))
+    (and (when min
+           (validate (local-time> new-value min)
+                     :component component
+                     :message (or message-low (format nil "Field ~a is less then ~a."
+                                                      (or component-label (label component))
+                                                      (local-time-to-string min local-time-format)))))
+         (when max
+           (validate (local-time< new-value max)
+                     :component component
+                     :message (or message-hi (format nil "Field ~a is greater then ~a."
+                                                     (or component-label (label component))
+                                                     (local-time-to-string max local-time-format))))))))
 
 
 


From achiumenti at common-lisp.net  Thu Sep 18 13:30:34 2008
From: achiumenti at common-lisp.net (achiumenti at common-lisp.net)
Date: Thu, 18 Sep 2008 09:30:34 -0400 (EDT)
Subject: [claw-cvs] r91 - trunk/main/claw-html.dojo/src
Message-ID: <20080918133034.309BB1D115@common-lisp.net>

Author: achiumenti
Date: Thu Sep 18 09:30:33 2008
New Revision: 91

Modified:
   trunk/main/claw-html.dojo/src/djbutton.lisp
   trunk/main/claw-html.dojo/src/djform.lisp
   trunk/main/claw-html.dojo/src/misc.lisp
Log:
several bugfixes

Modified: trunk/main/claw-html.dojo/src/djbutton.lisp
==============================================================================
--- trunk/main/claw-html.dojo/src/djbutton.lisp	(original)
+++ trunk/main/claw-html.dojo/src/djbutton.lisp	Thu Sep 18 09:30:33 2008
@@ -33,7 +33,7 @@
   ()
   (:metaclass metacomponent)
   (:documentation "Class for dojo dijit.form.Button component. More info at http://api.dojotoolkit.org/")
-  (:default-initargs :dojo-type "dijit.form.Button" :tag-name "button"))
+  (:default-initargs :dojo-type "claw.Button" :tag-name "button"))
 
 (defclass djdrop-down-button (djwidget)
   ()
@@ -65,12 +65,16 @@
 
 (defmethod wcomponent-template ((obj djsubmit-button))
   (let* ((id (htcomponent-client-id obj))
-	 (value (csubmit-value obj)))
+	 (value (csubmit-value obj))
+         (form (page-current-form *claw-current-page*)))
     (djbutton> :static-id id
+               :form-id (when form (htcomponent-client-id form))
+               :name (name-attr obj)
                :type "submit"
                :value value
+               :label value
                (wcomponent-informal-parameters obj)
-               (or (htcomponent-body obj) value))))
+               #|(or (htcomponent-body obj) value)|#)))
 
 (defmethod wcomponent-before-prerender ((obj djsubmit-button) (page page))
   (setf (djsubmit-button-form obj) (page-current-form page)))

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	Thu Sep 18 09:30:33 2008
@@ -40,6 +40,7 @@
   (:documentation "Class to generate a <form> element that is capable of XHR requests. More info at http://api.dojotoolkit.org/")
   (:default-initargs :dojo-type "claw.Form" :update-id () :ajax-form-p t))
 
+
 (defmethod wcomponent-template :before ((obj djform))
   (let ((dojo-type (djwidget-dojo-type obj))
         (update-id (update-id obj)))
@@ -166,26 +167,10 @@
   (:documentation "This class inherits from a CCHECKBOX, but is used to render a dojo dijit.form.CheckBox")
   (:default-initargs :dojo-type "dijit.form.CheckBox"))
 
-(defmethod wcomponent-template ((cinput djcheck-box))
-  (let* ((client-id (htcomponent-client-id cinput))
-         (dojo-type (djwidget-dojo-type cinput))
-         (translator (translator cinput))
-         (type (input-type cinput))
-         (value (translator-value-type-to-string translator (ccheckbox-value cinput)))
-         (current-value (translator-type-to-string translator cinput))
-         (class (css-class 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
-            :dojoType dojo-type
-            :name (name-attr cinput)
-            :class class
-            :value value
-            :checked (when (and current-value (equal value current-value)) "checked")
-            (wcomponent-informal-parameters cinput))))
+(defmethod wcomponent-template :before ((cinput djcheck-box))
+  (setf (wcomponent-informal-parameters cinput) 
+          (append (wcomponent-informal-parameters cinput)
+                  (list :dojo-type (djwidget-dojo-type cinput)))))
 
 (defclass djradio-button (cradio djwidget)
   ()

Modified: trunk/main/claw-html.dojo/src/misc.lisp
==============================================================================
--- trunk/main/claw-html.dojo/src/misc.lisp	(original)
+++ trunk/main/claw-html.dojo/src/misc.lisp	Thu Sep 18 09:30:33 2008
@@ -43,3 +43,4 @@
 (register-library-resource "dojotoolkit/claw/Editor.js"  (make-pathname :directory (append (pathname-directory *dojo-misc-file*) '("js")) :name "Editor" :type "js"))
 (register-library-resource "dojotoolkit/claw/ActionLink.js"  (make-pathname :directory (append (pathname-directory *dojo-misc-file*) '("js")) :name "ActionLink" :type "js"))
 (register-library-resource "dojotoolkit/claw/Dialog.js"  (make-pathname :directory (append (pathname-directory *dojo-misc-file*) '("js")) :name "Dialog" :type "js"))
+(register-library-resource "dojotoolkit/claw/Button.js"  (make-pathname :directory (append (pathname-directory *dojo-misc-file*) '("js")) :name "Button" :type "js"))


From achiumenti at common-lisp.net  Thu Sep 18 13:30:51 2008
From: achiumenti at common-lisp.net (achiumenti at common-lisp.net)
Date: Thu, 18 Sep 2008 09:30:51 -0400 (EDT)
Subject: [claw-cvs] r92 - trunk/main/claw-html.dojo/src/js
Message-ID: <20080918133051.43C901D115@common-lisp.net>

Author: achiumenti
Date: Thu Sep 18 09:30:51 2008
New Revision: 92

Modified:
   trunk/main/claw-html.dojo/src/js/ActionLink.js
   trunk/main/claw-html.dojo/src/js/Dialog.js
   trunk/main/claw-html.dojo/src/js/Form.js
Log:
several bugfixes

Modified: trunk/main/claw-html.dojo/src/js/ActionLink.js
==============================================================================
--- trunk/main/claw-html.dojo/src/js/ActionLink.js	(original)
+++ trunk/main/claw-html.dojo/src/js/ActionLink.js	Thu Sep 18 09:30:51 2008
@@ -51,15 +51,14 @@
 	        _updateParts: function (reply) {
                     for (var item in reply.components) {
                         var element = dojo.byId(item);
-                        if ((element != null) && (reply.components[item] != null)) {
-                            var list = dojo.query('[widgetId]', element);
-                            dojo.forEach(list.map(dijit.byNode), function(widget){if (widget) widget.destroy(); });
+                        if (element != null) {
+                            if (reply.components[item] != null) {
+                                var list = dojo.query('[widgetId]', element);
+                                dojo.forEach(list.map(dijit.byNode), function(widget){if (widget) widget.destroy(); });
+                            }
+                            element.innerHTML = reply.components[item];
+                            dojo.parser.parse(element, true);
                         }
-                        var oldVisibility = element.style.visibility;
-                        element.style.visibility = 'hidden';
-                        element.innerHTML = reply.components[item];
-                        dojo.parser.parse(element, true);
-                        element.style.visibility = oldVisibility;
                     }
                 },
 

Modified: trunk/main/claw-html.dojo/src/js/Dialog.js
==============================================================================
--- trunk/main/claw-html.dojo/src/js/Dialog.js	(original)
+++ trunk/main/claw-html.dojo/src/js/Dialog.js	Thu Sep 18 09:30:51 2008
@@ -52,6 +52,10 @@
                     this.templateString = this.templateStringUnclosable;
                 }
                 this.inherited(arguments);
+            },
+            hide: function () {
+                this.domNode.style.visibility = 'hidden';
+                this.inherited(arguments);
             }
         }
     );

Modified: trunk/main/claw-html.dojo/src/js/Form.js
==============================================================================
--- trunk/main/claw-html.dojo/src/js/Form.js	(original)
+++ trunk/main/claw-html.dojo/src/js/Form.js	Thu Sep 18 09:30:51 2008
@@ -28,135 +28,135 @@
 ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 */
 
-if(!dojo._hasResource["claw.Form"]){
-dojo.provide("claw.Form");
+    if(!dojo._hasResource["claw.Form"]){
+        dojo.provide("claw.Form");
 
-dojo.require("dojo.io.iframe");
-dojo.require("dijit.form.Form");
+        dojo.require("dojo.io.iframe");
+        dojo.require("dijit.form.Form");
 
-dojo.declare(
-	"claw.Form",
-	[dijit.form.Form],
-	{
+        dojo.declare(
+	    "claw.Form",
+	    [dijit.form.Form],
+	    {
 		// summary:
 		// Adds conveniences to regular HTML form
 
 		// HTML <FORM> attributes
-            xhrTimeout: "",//2000,
+                xhrTimeout: "",//2000,
                 updateId: null,
                 enctype: "",
                 xhr: null,
                 jsonContent: {},
 		_updateParts: function (reply) {
-                       for (var item in reply.components) {
-                           var element = dojo.byId(item);
-                           if ((element != null) && (reply.components[item] != null)) {
-                               var list = dojo.query('[widgetId]', element);
-                               dojo.forEach(list.map(dijit.byNode), function(widget){if (widget) widget.destroy(); });                               
-                           }
-                           var oldVisibility = element.style.visibility;
-                           element.style.visibility = 'hidden';
-                           element.innerHTML = reply.components[item];
-                           dojo.parser.parse(element, true);
-                           element.style.visibility = oldVisibility;
-                       }
-                 },
+                    for (var item in reply.components) {
+                        var element = dojo.byId(item);
+                        if (element != null) {
+                            if (reply.components[item] != null) {
+                                var list = dojo.query('[widgetId]', element);
+                                dojo.forEach(list.map(dijit.byNode), function(widget){if (widget) widget.destroy(); });
+                            }
+                            element.innerHTML = reply.components[item];
+                            dojo.parser.parse(element, true);
+                        }
+                    }
+                },
 
                 _evalReplClassScripts: function (reply) {
-                       dijit.byId('scripts-content-pane').setContent(reply.classInjections);
+                    dijit.byId('scripts-content-pane').setContent(reply.classInjections);
                 },
 
                 _evalReplInstanceScripts: function (reply) {
-                       dijit.byId('scripts-content-pane').setContent(reply.instanceInjections);
+                    dijit.byId('scripts-content-pane').setContent(reply.instanceInjections);
                 },
 
                 _updateAndEval: function (reply) {
-                       console.debug("Plain object as string is: ", reply);
-                       console.debug("Object as string is: ", dojo.toJson(reply, true));
-                       this._evalReplClassScripts(reply);
-                       this._updateParts(reply);
-                       this._evalReplInstanceScripts(reply);
+                    console.debug("Plain object as string is: ", reply);
+                    console.debug("Object as string is: ", dojo.toJson(reply, true));
+                    this._evalReplClassScripts(reply);
+                    this._updateParts(reply);
+                    this._evalReplInstanceScripts(reply);
                 },
                 submit: function(){
-                       if(!(this.onSubmit() === false) && !this.xhr){
-                           this.containerNode.submit();
-			}
+                    if(!(this.onSubmit() === false) && !this.xhr){
+                        this.containerNode.submit();
+		    }
                 },
 		onSubmit: function(e){
-			//	summary:
-			//		Callback when user submits the form. This method is
-			//		intended to be over-ridden, but by default it checks and
-			//		returns the validity of form elements. When the `submit`
-			//		method is called programmatically, the return value from
-			//		`onSubmit` is used to compute whether or not submission
-			//		should proceed
-
-			var valid = this.validate(); // Boolean
-
-                        if (valid && this.xhr) {
-                            if (e) {
-                                e.preventDefault();
-                            }
-                            this.onBeforeSubmit(e);
-                            var thisForm = this;
-                            var jsonContent = dojo.mixin(this.jsonContent, { json : thisForm.updateId });
-                            this.jsonContent = {};
-                            var formId = this.id;
-                            if (this.enctype != 'multipart/form-data') {
-                                try {
-                                    dojo.xhrPost({
-                                        url: '#',
-                                        load : function (data) {
-                                            try {
-                                                thisForm._updateAndEval(data);
-                                            } finally {
-                                                thisForm.onXhrFinish(e);
-                                            }
-                                        },
-                                        error : function (data) {console.error("!!!!!!",data);thisForm.onXhrFinish(e);},
-                                        timeout : thisForm.xhrTimeout,
-                                        handleAs : 'json',
-                                        form : formId,
-                                        content : jsonContent });
-                                } catch (e) {alert(e);}
-                            } else {
-                                jsonContent = dojo.mixin(jsonContent, { jsonPrefix: '<textarea>', jsonSuffix: '</textarea>' });
-                                dojo.io.iframe.send({
-                                        load : function (data) {
-                                            try {
-                                                thisForm._updateAndEval(data);
-                                            } finally {
-                                                thisForm.onXhrFinish(e);
-                                            }
-                                        },
-                                        error : function (data) {
-                                            console.error(data);
+		    //	summary:
+		    //		Callback when user submits the form. This method is
+		    //		intended to be over-ridden, but by default it checks and
+		    //		returns the validity of form elements. When the `submit`
+		    //		method is called programmatically, the return value from
+		    //		`onSubmit` is used to compute whether or not submission
+		    //		should proceed
+
+		    var valid = this.validate(); // Boolean
+
+                    if (valid && this.xhr) {
+                        if (e) {
+                            e.preventDefault();
+                        }
+                        this.onBeforeSubmit(e);
+                        var thisForm = this;
+                        var jsonContent = dojo.mixin(this.jsonContent, { json : thisForm.updateId });
+                        this.jsonContent = {};
+                        var formId = this.id;
+                        if (this.enctype != 'multipart/form-data') {
+                            try {
+                                dojo.xhrPost({
+                                    url: '#',
+                                    load : function (data) {
+                                        try {
+                                            thisForm._updateAndEval(data);
+                                        } finally {
                                             thisForm.onXhrFinish(e);
-                                        },
-                                        timeout : thisForm.xhrTimeout,
-                                        handleAs : 'json',
-                                        form: formId,
-                                        content : jsonContent });
-                            }
+                                        }
+                                    },
+                                    error : function (data) {console.error("!!!!!!",data);thisForm.onXhrFinish(e);},
+                                    timeout : thisForm.xhrTimeout,
+                                    handleAs : 'json',
+                                    form : formId,
+                                    content : jsonContent });
+                            } catch (e) {alert(e);}
+                        } else {
+                            jsonContent = dojo.mixin(jsonContent, { jsonPrefix: '<textarea>', jsonSuffix: '</textarea>' });
+                            dojo.io.iframe.send({
+                                load : function (data) {
+                                    try {
+                                        thisForm._updateAndEval(data);
+                                    } finally {
+                                        thisForm.onXhrFinish(e);
+                                    }
+                                },
+                                error : function (data) {
+                                    console.error(data);
+                                    thisForm.onXhrFinish(e);
+                                },
+                                timeout : thisForm.xhrTimeout,
+                                handleAs : 'json',
+                                form: formId,
+                                content : jsonContent });
                         }
-                        return valid;
+                    } 
+                    this.jsonContent = {};
+                    return valid;
 		},
 
                 onBeforeSubmit: function(/*Event?*/e){
-			//	summary:
-			//		Callback when user submits the form. This method is
-			//		intended to be over-ridden. When the `submit` calls dojo.xhrPost
-			//		this method is called before.
+		    //	summary:
+		    //		Callback when user submits the form. This method is
+		    //		intended to be over-ridden. When the `submit` calls dojo.xhrPost
+		    //		this method is called before.
 		},
 
                 onXhrFinish: function(/*Event?*/e){
-			//	summary:
-			//		Callback when user submits the form. This method is
-			//		intended to be over-ridden. After the call to dojo.xhrPost
-			//		thouches lload or error this event is fired
+		    //	summary:
+		    //		Callback when user submits the form. This method is
+		    //		intended to be over-ridden. After the call to dojo.xhrPost
+		    //		thouches lload or error this event is fired
 		}
-	}
-);
+	    }
+        );
 
-}
+    }
 


From achiumenti at common-lisp.net  Thu Sep 18 13:31:55 2008
From: achiumenti at common-lisp.net (achiumenti at common-lisp.net)
Date: Thu, 18 Sep 2008 09:31:55 -0400 (EDT)
Subject: [claw-cvs] r93 - trunk/main/claw-demo/src/backend
Message-ID: <20080918133155.5AFCE232B9@common-lisp.net>

Author: achiumenti
Date: Thu Sep 18 09:31:55 2008
New Revision: 93

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/setup.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	Thu Sep 18 09:31:55 2008
@@ -29,6 +29,16 @@
 
 (in-package :claw-demo-backend)
 
+(defun slot-column-name (symbol-class slot-name)
+  (when (stringp slot-name)
+    (setf slot-name (intern (string-upcase slot-name) 'claw-demo-backend)))
+  (let ((slot (loop for slot in (closer-mop:class-slots (find-class symbol-class))
+                 when (and (typep slot 'clsql-sys::view-class-effective-slot-definition)
+                           (equal (closer-mop:slot-definition-name slot) slot-name))
+                 return slot)))
+    (when slot
+      (slot-value slot 'clsql-sys::column))))
+
 (defgeneric check-instance-version (base-table &key database)
   (:documentation "Versioning support for base-table instances"))
 
@@ -56,29 +66,17 @@
     (setf (table-update-user base-table) user-name
           (table-update-date base-table) now-timestamp)))
 
-
-(defun slot-column-name (symbol-class slot-name)
-  (when (stringp slot-name)
-    (setf slot-name (intern (string-upcase slot-name) 'claw-demo-backend)))
-  (let ((slot (loop for slot in (closer-mop:class-slots (find-class symbol-class))
-                 when (and (typep slot 'clsql-sys::view-class-effective-slot-definition)
-                           (equal (closer-mop:slot-definition-name slot) slot-name))
-                 return slot)))
-    (when slot
-      (slot-value slot 'clsql-sys::column))))
-
 (defun sql-expression-upper (&key string table alias attribute type)
   (sql-operation 'upper (sql-expression :string string :table table :alias alias :attribute attribute :type type)))
 
-#.(locally-enable-sql-reader-syntax)
 
-(defmethod check-instance-version ((instance base-table) &key (database *default-database*))
+(defmethod check-instance-version ((instance base-table) &key (database *claw-demo-db*))
   (let* ((instance-version (table-version instance))
          (table (view-table (class-of instance)))
          (instance-id (table-id instance))
-         (version (first (select [version]
+         (version (first (select (slot-column-name 'base-table 'version)
                                  :from table
-                                 :where [= [id] instance-id]
+                                 :where (sql-operation '= (slot-column-name 'base-table 'id) instance-id)
                                  :flatp t
                                  :refresh t
                                  :database database))))
@@ -90,11 +88,11 @@
              table))))
 
 (defmethod delete-instance-records :before ((instance base-table))
-  (check-instance-version instance :database (clsql-sys::view-database instance)))
+  (check-instance-version instance :database *claw-demo-db*))
 
 
 
-(defmethod update-records-from-instance :before ((instance base-table) &key (database *default-database*))
+(defmethod update-records-from-instance :before ((instance base-table) &key (database *claw-demo-db*))
   (check-instance-version instance :database database)
   (sign-table-update instance)
   (if (and (slot-boundp instance 'id) (not (null (table-id instance))))
@@ -105,48 +103,87 @@
                                      (string-downcase (symbol-name (view-table (class-of instance)))))))
           (setf (table-id instance) (sequence-next sequence-name :database database))))))
 
-(defmethod update-record-from-slot :before ((instance base-table) slot &key (database *default-database*))
+(defmethod update-record-from-slot :before ((instance base-table) slot &key (database *claw-demo-db*))
   (declare (ignore slot database))
   (check-instance-version instance))
 
 
-(defmethod update-records-from-instance :before ((instance user) &key (database *default-database*))
-  (let ((id (table-id instance)))
+(defmethod update-records-from-instance :before ((instance user) &key (database *claw-demo-db*))
+  (let ((id (table-id instance))
+        (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
-      (delete-records :from [users-roles] :where [= [user-id] id]))))
-
-(defmethod update-records-from-instance :after ((instance user) &key (database *default-database*))
-  (let ((id (table-id instance)))
-    (dolist (role (user-roles instance))
-      (update-records-from-instance (make-instance 'user-role :user-id id :role-id (table-id role))))))
-
-
-(defmethod update-records-from-instance :before ((instance customer) &key (database *default-database*))
-  (let ((id (table-id instance)))
+      (delete-records :from table-name
+                      :where (sql-operation 'and
+                                            (sql-operation '= (slot-column-name 'user-role 'user-id) id)
+                                            (sql-operation 'not (sql-operation 'in role-id-column-name
+                                                                               (loop for user-role in role-list
+                                                                                  collect (table-id user-role)))))
+                      :database database))))
+
+(defmethod update-records-from-instance :after ((instance user) &key (database *claw-demo-db*))
+  (with-transaction (:database database)
+    (let* ((id (table-id instance))
+           (table-name (view-table (find-class 'user-role)))
+           (user-id-column-name (slot-column-name 'user-role 'user-id))
+           (role-id-column-name (slot-column-name 'user-role 'role-id))
+           (role-list (user-roles instance))
+           (roles-already-present-id-list (select role-id-column-name
+                                                  :from table-name
+                                                  :where (sql-operation 'in user-id-column-name
+                                                                        (loop for user-role in role-list
+                                                                           collect (table-id user-role)))
+                                                  :flatp t
+                                                  :refresh t
+                                                  :database database)))
+      (dolist (role (user-roles instance))
+        (unless (member (table-id role) roles-already-present-id-list)
+          (update-records-from-instance (make-instance 'user-role 
+                                                       :user-id id 
+                                                       :role-id (table-id role)) :database database))))))
+
+
+(defmethod update-records-from-instance :before ((instance customer) &key (database *claw-demo-db*))
+  (let ((id (table-id instance))
+        (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
-      (delete-records :from [customer-addresses] :where [= [customer-id] id]))))
+      (delete-records :from table-name
+                      :where (sql-operation 'and
+                                            (sql-operation '= (slot-column-name 'customer-address 'customer-id) id)
+                                            (sql-operation 'not (sql-operation 'in address-id-column-name
+                                                                               (loop for customer-address in address-list
+                                                                                    collect (table-id customer-address)))))
+                      :database database)
+      (setf (customer-addresses instance) address-list))))
 
-(defmethod update-records-from-instance :after ((instance customer) &key (database *default-database*))
+(defmethod update-records-from-instance :after ((instance customer) &key (database *claw-demo-db*))
   (let ((id (table-id instance)))
     (dolist (address (customer-addresses instance))
       (setf (customer-address-customer-id address) id)
-      (update-records-from-instance address))))
+      (update-records-from-instance address :database database))))
 
 (defmethod delete-instance-records :before ((instance user))
   (let ((id (table-id instance)))
     (when id
-      (delete-records :from [users-roles] :where [= [user-id] id]))))
+      (delete-records :from (symbol-name (view-table (find-class 'user-role)))
+                      :where (sql-operation '= (slot-column-name 'user-role 'role-id) id)
+                      :database *claw-demo-db*))))
 
 
 (defmethod delete-instance-records :before ((instance customer))
   (let ((id (table-id instance)))
     (when id
-      (delete-records :from [customer-addresses] :where [= [customer-id] id]))))
+      (delete-records :from (symbol-name (view-table (find-class 'customer-address)))
+                      :where (sql-operation '= (slot-column-name 'customer-address 'customer-id) id)))))
 
 (defmethod delete-instance-records :before ((instance role))
   (let ((id (table-id instance)))
     (when id
-      (delete-records :from [users-roles] :where [= [role-id] id]))))
+      (delete-records :from (symbol-name (view-table (find-class 'user-role)))
+                      :where (sql-operation '= (slot-column-name 'user-role 'role-id) id)))))
 
 (defun like-operation (name value &key (insensitive t) (wild-char #\*))
   (setf value (format nil "~{~A~^\\\\~}" (split-sequence #\\ value)))
@@ -165,4 +202,3 @@
                                     v)))
     result))
 
-#.(locally-disable-sql-reader-syntax)
\ 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	Thu Sep 18 09:31:55 2008
@@ -40,7 +40,8 @@
                           :universal-time
                           :parse-timestring)
   (:documentation "A demo application for CLAW")
-  (:export #:demo-setup
+  (:export #:*claw-demo-db*
+           #:demo-setup
            #:db-connect
            #:db-disconnect
            ;; --- Value objects --- ;;
@@ -89,7 +90,7 @@
            #:customer-address
            #:customer-address-name1
            #:customer-address-name2
-           #:customer-address-address-type
+           #:customer-address-type
            #:customer-address-address
            #:customer-address-city
            #:customer-address-zip
@@ -100,6 +101,7 @@
            #:delete-db-item
            #:reload-db-item
            #:find-by-id
+           #:delete-by-id
            #:delete-class-records
            #:find-user-by-name
            #:find-customers))
\ 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	Thu Sep 18 09:31:55 2008
@@ -40,8 +40,6 @@
 (defgeneric reload-db-item (base-table)
   (:documentation "Reloads an item."))
 
-#.(locally-enable-sql-reader-syntax)
-
 (defmethod update-db-item ((item base-table))
   (with-transaction (:database *claw-demo-db*)
       (update-records-from-instance item)))
@@ -53,7 +51,7 @@
 (defun delete-class-records (symbol-class &key where)
   (with-transaction (:database *claw-demo-db*)
     (let ((table-name (symbol-name (view-table (find-class symbol-class)))))
-      (delete-records :from table-name :where where))))
+      (delete-records :from table-name :where where :database *claw-demo-db*))))
 
 (defun build-order-by (fields)
   (loop for field in fields
@@ -73,24 +71,32 @@
            :flatp t
            :refresh refresh
            :offset offset
-           :limit limit)
+           :limit limit
+           :database *claw-demo-db*)
    (count-vo symbol-class :refresh refresh :where where :group-by group-by :having having)))
 
 (defun count-vo (symbol-class &key (refresh t) where group-by having)
   "Returns the number of records matching the given criteria"
-  (first (select [count [*]]
+  (first (select (sql-operation 'count '*)
                  :from (view-table (find-class symbol-class))
                  :where where
                  :group-by group-by
-                 :having having                 
+                 :having having
                  :flatp t
-                 :refresh refresh)))
+                 :refresh refresh
+                 :database *claw-demo-db*)))
 
 (defun find-by-id (symbol-class id)
   (first (select symbol-class
                    :where (sql-operation '= (slot-column-name symbol-class 'id) id)
                    :flatp t
-                   :refresh t)))
+                   :refresh t
+                   :database *claw-demo-db*)))
+
+(defun delete-by-id (symbol-class id-list)
+  (first (delete-records :from (view-table (find-class symbol-class))
+                         :where (sql-operation 'in (slot-column-name symbol-class 'id) id-list)
+                         :database *claw-demo-db*)))
 
 (defmethod reload-db-item ((item base-table))
   "Reloads item data selecting the item by its id. This function isn't destructive"
@@ -103,7 +109,8 @@
     (first (select 'user
                    :where where
                    :flatp t
-                   :refresh t))))
+                   :refresh t
+                   :database *claw-demo-db*))))
 
 (defun find-customers (&key (offset 0) (limit *select-limit*) name1 name2 email vat phone sorting)
   (let ((where (remove-if #'null (list
@@ -128,5 +135,3 @@
                         (apply #'sql-operation (cons 'and where))
                         (first where))
              :order-by sorting)))
-
-#.(locally-disable-sql-reader-syntax)
\ No newline at end of file

Modified: trunk/main/claw-demo/src/backend/setup.lisp
==============================================================================
--- trunk/main/claw-demo/src/backend/setup.lisp	(original)
+++ trunk/main/claw-demo/src/backend/setup.lisp	Thu Sep 18 09:31:55 2008
@@ -33,14 +33,14 @@
   "The demo datebase")
 
 (defun db-connect (&optional (connection-string '("127.0.0.1" "claw-demo" "claw-demo" "demo")))
-  (setf *claw-demo-db* (connect connection-string :database-type :postgresql :pool t)))
+  (connect connection-string :database-type :postgresql :pool t))
 
-(defun db-disconnect ()
-  (disconnect :database *claw-demo-db*))
+(defun db-disconnect (&optional (database *claw-demo-db*) )
+  (disconnect :database database))
 
 
 (defun create-claw-demo-tables ()
-  (let ((*default-database* *claw-demo-db*))
+  (let ((clsql:*default-database* *claw-demo-db*))
     (create-view-from-class 'user-role)
     (create-view-from-class 'user)
     (create-view-from-class 'role)
@@ -66,7 +66,7 @@
                                (symbol-name (view-table (find-class 'customer))))))))
 
 (defun drop-claw-demo-tables ()
-  (let ((*default-database* *claw-demo-db*)
+  (let ((clsql:*default-database* *claw-demo-db*)
         (user-role-table (symbol-name (view-table (find-class 'user-role))))
         (customer-address-table (symbol-name (view-table (find-class 'customer-address)))))
     (dolist (table (list-tables))
@@ -75,7 +75,7 @@
       (execute-command (format nil "DROP SEQUENCE ~a" sequence)))))
 
 (defun demo-setup ()
-  (db-connect)
+  (let ((*claw-demo-db* (db-connect)))
   (drop-claw-demo-tables)
   (create-claw-demo-tables)
   (with-transaction ()
@@ -103,4 +103,4 @@
                                            :code1 (format nil "code2-~a" i)
                                            :code1 (format nil "code3-~a" i)
                                            :code1 (format nil "code4-~a" i))))))
-  (db-disconnect))
\ No newline at end of file
+  (db-disconnect)))
\ 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	Thu Sep 18 09:31:55 2008
@@ -270,5 +270,9 @@
                                    :foreign-key id
                                    :retrieval :immediate
                                    :set nil)))
-  (:default-initargs :address-type 0)
+  (:default-initargs :address-type 0 :address nil
+                     :city nil
+                     :zip nil
+                     :state nil
+                     :country nil)
   (:base-table customer-addresses))


From achiumenti at common-lisp.net  Thu Sep 18 13:32:13 2008
From: achiumenti at common-lisp.net (achiumenti at common-lisp.net)
Date: Thu, 18 Sep 2008 09:32:13 -0400 (EDT)
Subject: [claw-cvs] r94 - trunk/main/claw-demo/src/frontend
Message-ID: <20080918133213.65AAA2B1E2@common-lisp.net>

Author: achiumenti
Date: Thu Sep 18 09:32:12 2008
New Revision: 94

Modified:
   trunk/main/claw-demo/src/frontend/auth.lisp
   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/auth.lisp
==============================================================================
--- trunk/main/claw-demo/src/frontend/auth.lisp	(original)
+++ trunk/main/claw-demo/src/frontend/auth.lisp	Thu Sep 18 09:32:12 2008
@@ -40,22 +40,21 @@
   ()
   (:documentation "Authorization configuration for application
 atuhentication and authorization management."))
-
+0
 (defmethod configuration-login ((configuration configuration))
-  (multiple-value-bind (user password)
-      (if (eq (lisplet-authentication-type *claw-current-lisplet*) :basic)
-          (claw-authorization)
-          (values (claw-parameter "username")
-                  (claw-parameter "password")))
-    (unwind-protect 
-         (progn
-           (db-connect)
-           (let ((user-vo (find-user-by-name user)))
-             (when (and user-vo (string= password (user-password user-vo)))
-               (make-instance 'demo-principal
-                              :name (user-username user-vo)
-                              :firstname (user-firstname user-vo)
-                              :surname (user-surname user-vo)
-                              :roles (loop for role-vo in (user-roles user-vo)
-                                        collect (role-name (first role-vo)))))))
-      (db-disconnect))))
\ No newline at end of file
+  (let ((claw-demo-backend:*claw-demo-db* (db-connect)))
+    (multiple-value-bind (user password)
+        (if (eq (lisplet-authentication-type *claw-current-lisplet*) :basic)
+            (claw-authorization)
+            (values (claw-parameter "username")
+                    (claw-parameter "password")))
+      (unwind-protect
+        (let ((user-vo (find-user-by-name user)))
+          (when (and user-vo (string= password (user-password user-vo)))
+            (make-instance 'demo-principal
+                           :name (user-username user-vo)
+                           :firstname (user-firstname user-vo)
+                           :surname (user-surname user-vo)
+                           :roles (loop for role-vo in (user-roles user-vo)
+                                     collect (role-name (first role-vo))))))
+        (db-disconnect)))))
\ No newline at end of file

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	Thu Sep 18 09:32:12 2008
@@ -97,11 +97,13 @@
   ())
 
 (defmethod page-render :around ((db-page db-page))
-  (let ((result))
-    (unwind-protect (progn
-                      (db-connect)
-                      (setf result (call-next-method)))
-      (db-disconnect))
+  (let ((result)
+        (claw-demo-backend:*claw-demo-db* (db-connect))
+        (clsql-sys:*default-caching* nil))
+    (unwind-protect 
+         (setf result (call-next-method))
+      (when *claw-demo-db*
+        (db-disconnect)))
     result))
 
 
@@ -220,4 +222,40 @@
 
 (defun null-when-empty (string)
   (unless (string= string "")
-    string))
\ No newline at end of file
+    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	Thu Sep 18 09:32:12 2008
@@ -34,14 +34,18 @@
 (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))
+                          :accessor edit-customer-customer-id-parameter)
+   (on-close-click :initarg :on-close-click
+                   :accessor edit-customer-on-close-click))
   (:metaclass metacomponent)
-  (:default-initargs :on-before-submit nil :on-xhr-finish nil 
+  (:default-initargs :on-close-click nil
                      :class "customerForm" :customer-id-parameter "customerid"))
 
 (defmethod initialize-instance :after ((obj edit-customer) &key rest)
@@ -49,8 +53,33 @@
   (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)))
+  (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
@@ -122,8 +151,75 @@
            (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")))))
+           (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))
@@ -131,14 +227,24 @@
     (let ((customer-id (parse-integer (claw-parameter (edit-customer-customer-id-parameter obj)))))
       (setf (edit-customer-customer obj) 
             (find-by-id 'customer 
-                        customer-id)))))
+                        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)))
+        (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)
@@ -153,6 +259,8 @@
 
 (defgeneric customers-page-sorting (customers-page))
 
+(defgeneric customers-page-delete-customers (customers-page))
+
 (defclass customers-page (db-page) 
   ((customers :initform nil
               :accessor customers-page-customers)
@@ -179,7 +287,11 @@
    (sorting-column :initform "name1"
           :accessor customers-page-sorting-column)
    (sorting-order :initform "asc"
-          :accessor customers-page-sorting-order))
+          :accessor customers-page-sorting-order)
+   (delete-all :initform nil
+               :accessor customers-page-delete-all)
+   (delete-items :initform nil
+               :accessor customers-page-delete-items))
   (:default-initargs :list-size 20))
 
 (defmethod wcomponent-after-rewind :after ((obj edit-customer) (page customers-page))
@@ -255,10 +367,16 @@
                                             :static-id sorting-order-id
                                             :accessor 'customers-page-sorting-order)
                                    (djsubmit-button> :id "search"
-                                                     :value "Search"))
+                                                     :value "Search")
+                                   (djconfirmation-submit> :id "delete"
+                                                           :value "Delete"
+                                                           :action 'customers-page-delete-customers
+                                                           :confirmation-message "Are you sure to delete these items?"))
+
                              (div> :static-id result-container-id
                                    (table> :class "listTable"
                                            (tr> :class "header"
+                                                (th> :class "delete" (djcheck-box> :id "deleteAll" :accessor 'customers-page-delete-all :value "all"))
                                                 (th> :class "name" (span> :class (if (string-equal "name1" sort-field) 
                                                                                      (if (string-equal "asc" sort-direction)
                                                                                          "sort sortAsc"
@@ -292,6 +410,10 @@
                                            (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 
+                                                                                              :value (table-id customer) 
+                                                                                              :translator *integer-translator*
+                                                                                              :multiple t))
                                                            (td> (a> :id "edit"
                                                                     :href "#"
                                                                     :on-click (remove #\newline (ps:ps* `(progn (setf (slot-value (dijit.by-id ,edit-customer-action-link-id) 'parameters) 
@@ -303,6 +425,13 @@
                                                            (td> (customer-email customer))
                                                            (td> (customer-vat customer))
                                                            (td> (customer-phone1 customer)))))
+                                   (unless customers
+                                     (djcheck-box> :id "deleteItem" 
+                                                   :accessor 'customers-page-delete-items 
+                                                   :value 0
+                                                   :multiple t 
+                                                   :translator *integer-translator*
+                                                   :style "display: none;"))
                                    (djaction-link> :static-id edit-customer-action-link-id
                                                    :style "display:none"
                                                    :action 'customers-page-edit-customer
@@ -318,14 +447,44 @@
                                            :first-item-offset (customers-page-offset page))))
                     (div> :static-id edit-customer-dialog-container-id
                           (djdialog> :static-id edit-customer-dialog-id
-                                        :title (customers-page-customer-edit-dialog-title page)
+                                     :class "customerDialog"
+                                     :title (customers-page-customer-edit-dialog-title page)
                                      (edit-customer> :static-id edit-customer-form-id
+                                                     :on-close-click (ps:ps* `(.hide (dijit.by-id ,edit-customer-dialog-id)))
                                                      :update-id (attribute-value (list edit-customer-form-id result-container-id))
                                                      :customer (customers-page-current-customer page)
-                                                     :on-before-submit (ps:ps* `(.show (dijit.by-id ,spinner-id)))
-                                                     :on-xhr-finish (ps:ps* `(.hide (dijit.by-id ,spinner-id))))
+                                                     :on-before-submit (remove #\newline (ps:ps* `(progn (.show (dijit.by-id ,spinner-id))
+                                                                                                         (dojo.add-class
+                                                                                                               (slot-value (dijit.by-id ,edit-customer-dialog-id) 'container-node) 
+                                                                                                               "hideForm"))))
+                                                     :on-xhr-finish (ps:ps* `(progn (.hide (dijit.by-id ,spinner-id))
+                                                                                    (dojo.remove-class
+                                                                                     (slot-value (dijit.by-id ,edit-customer-dialog-id) 'container-node) 
+                                                                                     "hideForm"))))
                                      (exception-monitor> :id "exceptionMonitor" :json-render-on-validation-errors-p edit-customer-form-id))))))
 
+(defmethod customers-page-delete-customers ((page customers-page))
+  (let ((customer-id-list (customers-page-delete-items page))
+        (name1 (customers-page-name1 page))
+        (name2 (customers-page-name2 page))
+        (email (customers-page-email page))
+        (vat (customers-page-vat page))
+        (phone (customers-page-phone page)))
+    (log-message :info "...deleting")
+    (delete-by-id 'customer customer-id-list)
+    (setf (customers-page-delete-items page) ())
+    (multiple-value-bind (customers total-size) 
+        (find-customers :offset (customers-page-offset page)
+                        :limit (customers-page-list-size page)
+                        :name1 (null-when-empty name1)
+                        :name2 (null-when-empty name2)
+                        :email (null-when-empty email)
+                        :vat (null-when-empty vat)
+                        :phone (null-when-empty phone)
+                        :sorting (customers-page-sorting page))
+      (setf (customers-page-customers page) customers
+            (customers-page-customers-total-count page) total-size))))
+
 (defmethod customers-page-find-customers ((page customers-page))
   (let ((name1 (customers-page-name1 page))
         (name2 (customers-page-name2 page))


From achiumenti at common-lisp.net  Thu Sep 18 13:32:29 2008
From: achiumenti at common-lisp.net (achiumenti at common-lisp.net)
Date: Thu, 18 Sep 2008 09:32:29 -0400 (EDT)
Subject: [claw-cvs] r95 - trunk/main/claw-demo/src/frontend/docroot/css
Message-ID: <20080918133229.212332B1E1@common-lisp.net>

Author: achiumenti
Date: Thu Sep 18 09:32:27 2008
New Revision: 95

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	Thu Sep 18 09:32:27 2008
@@ -43,6 +43,7 @@
 }
 
 .topheader {
+    visibility: hidden;
     position: relative;
     height: 140px;
     background: url(../img/clawHead.png) 0 0 no-repeat;
@@ -72,6 +73,7 @@
 .soria .listTable {
     width: 100%;
     border-collapse: collapse;
+    margin-bottom: 1em;
 }
 
 .soria .listTable .header {
@@ -79,7 +81,7 @@
     border-bottom:1px solid #CCCCCC;
 }
 
-.soria .listTable .header th {
+.listTable th {
     padding:3px 0 1px 3px;
 }
 
@@ -92,6 +94,7 @@
     display:-moz-inline-stack;
     display:inline-block;
     cursor: pointer;
+    border: 1px solid gray;
 }
 
 .pager div.page {
@@ -123,6 +126,15 @@
     padding-right: 15px;
 }
 
+body.demo .customerDialog {
+    width: 305px;
+    height: 460px;
+    overflow: hidden;
+}
+
+body.demo .customerDialog .dijitDialogPaneContent{
+    background: #F0F4FC;
+}
 .customerForm .buttons {
     margin-top: 10px;
     padding-top: 5px;
@@ -142,4 +154,46 @@
 
 .sortDesc {
     background: url(../img/desc_arrow.gif) 100% 50% no-repeat;
-}
\ No newline at end of file
+}
+
+.addressTabs {
+    width: 100%;
+    height: 150px;
+    margin-top: 5px;
+}
+
+.demo .addressTabs .dijitTabLabels-top {
+    border-left:none;
+    border-right:none;
+    border-top:none;
+}
+
+.addressTabs .zip, .addressTabs .city, .addressTabs .state {
+    float:left;
+    margin-left: 4px;
+}
+
+.addressTabs .zip, .addressTabs .country {
+    width: 56px;
+    margin-left: 0;
+}
+
+.addressTabs .city {
+    width: 140px;
+}
+
+.addressTabs .state {
+    width: 65px;
+}
+
+.addressTabs .label {
+    display: block;
+}
+
+.addressTabs .text {
+    width: 100%;
+}
+
+.hideForm form, .hideForm .dijitTextBox input, hideForm .dijitComboBox input, .hideForm .dijitSpinner input{
+    visibility: hidden !important;
+}


From achiumenti at common-lisp.net  Thu Sep 18 13:32:35 2008
From: achiumenti at common-lisp.net (achiumenti at common-lisp.net)
Date: Thu, 18 Sep 2008 09:32:35 -0400 (EDT)
Subject: [claw-cvs] r96 - trunk/main/claw-demo/src/frontend/docroot/img
Message-ID: <20080918133235.450B32B1E1@common-lisp.net>

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.


From achiumenti at common-lisp.net  Thu Sep 18 13:32:49 2008
From: achiumenti at common-lisp.net (achiumenti at common-lisp.net)
Date: Thu, 18 Sep 2008 09:32:49 -0400 (EDT)
Subject: [claw-cvs] r97 - trunk/main/claw-demo/test/backend
Message-ID: <20080918133249.055F92B1E1@common-lisp.net>

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