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

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

08 Sep '08

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

1 0

[claw-cvs] r86 - trunk/main/connectors/hunchentoot/src
by achiumenti＠common-lisp.net 08 Sep '08

08 Sep '08

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)

1 0

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

08 Sep '08

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

1 0

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

03 Sep '08

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

1 0

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

03 Sep '08

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

1 0

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

03 Sep '08

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 ,@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 ,@update-id)) + (ps* `(array ,update-id))))) (subseq js-array 0 (1- (length js-array))))) :parameters (let ((json-content (ps* `(create ,@params)))) (subseq json-content 0 (1- (length json-content))))

1 0

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

03 Sep '08

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

1 0

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

01 Sep '08

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

1 0

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

01 Sep '08

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

1 0

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

01 Sep '08

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 "<")) - ((#\>) (page-format-raw page ">")) - ((#\&) (page-format-raw page "&")) - (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 "<")) + ((#\>) (page-format-raw page ">")) + ((#\&) (page-format-raw page "&")) + (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 "~%//]]>"))) - (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 "~%//]]>"))) + (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))

1 0

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

01 Sep '08

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 ,@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

1 0

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

claw-cvs September 2008