September 2008 - claw-cvs@common-lisp.net

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

18 Sep '08

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

1 0

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

18 Sep '08

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

1 0

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

18 Sep '08

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; +}

1 0

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

18 Sep '08

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

1 0

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

18 Sep '08

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

1 0

[claw-cvs] r92 - trunk/main/claw-html.dojo/src/js
by achiumenti＠common-lisp.net 18 Sep '08

18 Sep '08

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 } - } -); + } + ); -} + }

1 0

[claw-cvs] r91 - trunk/main/claw-html.dojo/src
by achiumenti＠common-lisp.net 18 Sep '08

18 Sep '08

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

1 0

[claw-cvs] r90 - trunk/main/claw-html/src
by achiumenti＠common-lisp.net 18 Sep '08

18 Sep '08

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

1 0

[claw-cvs] r89 - in trunk/main/claw-demo/src/frontend: . docroot/css
by achiumenti＠common-lisp.net 08 Sep '08

08 Sep '08

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

1 0

[claw-cvs] r88 - trunk/main/claw-html.dojo/src/js
by achiumenti＠common-lisp.net 08 Sep '08

08 Sep '08

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

1 0