- claw-cvs@common-lisp.net - mailman3.common-lisp.net

[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

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

26 Aug '08

Author: achiumenti Date: Tue Aug 26 07:08:35 2008 New Revision: 76 Modified: trunk/main/connectors/hunchentoot/src/hunchentoot.lisp Log: updated hunchentoot connector Modified: trunk/main/connectors/hunchentoot/src/hunchentoot.lisp ============================================================================== --- trunk/main/connectors/hunchentoot/src/hunchentoot.lisp (original) +++ trunk/main/connectors/hunchentoot/src/hunchentoot.lisp Tue Aug 26 07:08:35 2008 @@ -29,8 +29,9 @@ (in-package :hunchentoot-connector) -(setf hunchentoot:*hunchentoot-default-external-format* (flex:make-external-format :utf-8 :eol-style :lf)) -(setf hunchentoot:*default-content-type* "text/html; charset=utf-8") +(setf hunchentoot:*hunchentoot-default-external-format* (flex:make-external-format :utf-8 :eol-style :lf) + 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")) @@ -313,14 +314,12 @@ (defmethod (setf connector-reply-external-format-encoding) (value (connector hunchentoot-connector)) (let ((encoding (flexi-streams:external-format-name (hunchentoot:reply-external-format)))) - ;(log-message :info "ENCODING: ~a| VALUE: ~a" encoding value) (unless (and (null value) (equal encoding value)) (setf (hunchentoot:reply-external-format) (flex:make-external-format value :eol-style :lf))))) (defmethod connector-writer ((connector hunchentoot-connector)) (hunchentoot:send-headers)) - ;*standard-output*) (defmethod connector-redirect ((connector hunchentoot-connector) target &key host port protocol add-session-id code) (hunchentoot:redirect target

1 0