Author: achiumenti Date: Sat May 24 13:18:39 2008 New Revision: 48 Modified: trunk/main/claw-core/claw.asd trunk/main/claw-core/src/components.lisp trunk/main/claw-core/src/lisplet.lisp trunk/main/claw-core/src/misc.lisp trunk/main/claw-core/src/packages.lisp trunk/main/claw-core/src/server.lisp trunk/main/claw-core/src/tags.lisp trunk/main/claw-core/src/validators.lisp Log: a lot of bug fixes Modified: trunk/main/claw-core/claw.asd ============================================================================== --- trunk/main/claw-core/claw.asd (original) +++ trunk/main/claw-core/claw.asd Sat May 24 13:18:39 2008 @@ -31,7 +31,7 @@ :name "claw" :author "Andrea Chiumenti" :description "Common Lisp Active Web.A famework to write web applications" - :depends-on (:closer-mop :hunchentoot :alexandria :cl-ppcre :cl-fad :local-time :split-sequence) + :depends-on (:closer-mop :hunchentoot :alexandria :cl-ppcre :cl-fad :local-time :split-sequence :parenscript) :components ((:module src :components ((:file "packages") (:file "misc" :depends-on ("packages")) Modified: trunk/main/claw-core/src/components.lisp ============================================================================== --- trunk/main/claw-core/src/components.lisp (original) +++ trunk/main/claw-core/src/components.lisp Sat May 24 13:18:39 2008 @@ -55,7 +55,8 @@ (defun component-validation-errors (component &optional (request *request*)) "Resurns possible validation errors occurred during form rewinding bound to a specific component" (let ((client-id (htcomponent-client-id component))) - (assoc client-id (validation-errors request) :test #'equal))) + (getf (validation-errors request) (make-symbol client-id)))) + ;-------------------------------------------------------------------------------- (defclass cform (wcomponent) @@ -87,7 +88,7 @@ (defmethod wcomponent-template((cform cform)) (let ((client-id (htcomponent-client-id cform)) (class (css-class cform)) - (validation-errors (aux-request-value :validation-errors))) + (validation-errors (validation-errors))) (when validation-errors (if (or (null class) (string= class "")) (setf class "error") @@ -105,7 +106,7 @@ (setf (page-current-form pobj) obj)) (defmethod wcomponent-after-rewind ((obj cform) (pobj page)) - (let ((validation-errors (aux-request-value :validation-errors)) + (let ((validation-errors (validation-errors)) (action (action obj))) (unless validation-errors (when (or action (cform-rewinding-p obj pobj)) @@ -177,7 +178,7 @@ :reader input-type :documentation "The html <input> TYPE attribute. For submit type, use the CSUBMIT> function.")) (:metaclass metacomponent) - (:default-initargs :reserved-parameters (list :value :name) :empty t) + (:default-initargs :reserved-parameters (list :value :name) :empty t :type "text") (:documentation "Request cycle aware component the renders as an INPUT tag class")) (let ((class (find-class 'cinput))) Modified: trunk/main/claw-core/src/lisplet.lisp ============================================================================== --- trunk/main/claw-core/src/lisplet.lisp (original) +++ trunk/main/claw-core/src/lisplet.lisp Sat May 24 13:18:39 2008 @@ -196,8 +196,14 @@ (let ((resource-full-path (merge-pathnames (uri-to-pathname (subseq (script-name) (+ (length (clawserver-base-path (current-server))) - (length (lisplet-base-path (lisplet-base-path lisplet)))))) + (length (lisplet-base-path lisplet)) + (length location) 1))) resource-path))) + (log-message :info "--------------------------------------------- ~% +script-name: \"~a\"~% +resource-path: \"~a\"~% +resource-full-path :\"~a\"~% +--------------------------------------------" (script-name) resource-path resource-full-path) (handle-static-file resource-full-path content-type))) #'(lambda () (handle-static-file resource-path content-type)))) pages))))) @@ -208,10 +214,9 @@ (loop for dispatcher in dispatchers for url = (car dispatcher) for action = (cdr dispatcher) - do (cond - ((and (string< url rel-script-name) - (null (starts-with-subseq rel-script-name url))) (return nil)) - ((starts-with-subseq rel-script-name url) (return (funcall action))))))) + do (progn + (log-message :info "rel-script-name: \"~a\" url: \"~a\" --- (starts-with-subseq rel-script-name url) : ~a" rel-script-name url (starts-with-subseq rel-script-name url)) + (when (starts-with-subseq rel-script-name url) (return (funcall action))))))) (defmethod lisplet-dispatch-method ((lisplet lisplet)) (let ((base-path (build-lisplet-location lisplet)) Modified: trunk/main/claw-core/src/misc.lisp ============================================================================== --- trunk/main/claw-core/src/misc.lisp (original) +++ trunk/main/claw-core/src/misc.lisp Sat May 24 13:18:39 2008 @@ -217,6 +217,22 @@ "Resurns possible validation errors occurred during form rewinding" (aux-request-value :validation-errors request)) +(defun (setf validation-errors) (value &optional (request *request*)) + "Sets possible validation errors occurred during form rewinding" + (setf (aux-request-value :validation-errors request) value)) + +(defun validation-compliances (&optional (request *request*)) + "Resurns the list of components that pass validation during form rewinding" + (aux-request-value :validation-compliances request)) + +(defun (setf validation-compliances) (value &optional (request *request*)) + "Sets the list of components that pass validation during form rewinding" + (setf (aux-request-value :validation-compliances request) value)) + +(defun add-validation-compliance (id &optional (request *request*)) + "Adds a component id to the list of components that pass validation during form rewinding" + (setf (validation-compliances request) (nconc (validation-compliances request) (list id)))) + (defclass metacomponent (standard-class) () (:documentation "This is the meta class the must be set for every WCOMPONENT. Modified: trunk/main/claw-core/src/packages.lisp ============================================================================== --- trunk/main/claw-core/src/packages.lisp (original) +++ trunk/main/claw-core/src/packages.lisp Sat May 24 13:18:39 2008 @@ -211,6 +211,7 @@ :lisplet-protect :lisplet-authentication-type :claw-start-session + :build-lisplet-location ;; clawserver :clawserver :clawserver-base-path @@ -234,6 +235,8 @@ #-:hunchentoot-no-ssl :clawserver-ssl-certificate-file #-:hunchentoot-no-ssl :clawserver-ssl-privatekey-file #-:hunchentoot-no-ssl :clawserver-ssl-privatekey-password + :add-exception + :component-exceptions :msie-p :*id-and-static-id-description* :describe-component-behaviour @@ -273,6 +276,8 @@ :*locales* :validate :validation-errors + :validation-compliances + :add-validation-compliance :component-validation-errors :validate-required :validate-size Modified: trunk/main/claw-core/src/server.lisp ============================================================================== --- trunk/main/claw-core/src/server.lisp (original) +++ trunk/main/claw-core/src/server.lisp Sat May 24 13:18:39 2008 @@ -385,21 +385,15 @@ (when (starts-with-subseq script-name base-path) (setf rel-script-name (subseq script-name (length base-path)) rel-script-name-libs (subseq script-name (1+ (length base-path)))) - (or + (or (loop for dispatcher in *claw-libraries-resources* for url = (car dispatcher) for action = (cdr dispatcher) - do (cond - ((and (string< url rel-script-name-libs) - (null (starts-with-subseq rel-script-name-libs url))) (return nil)) - ((starts-with-subseq rel-script-name-libs url) (return (funcall action))))) + do (when (starts-with-subseq rel-script-name-libs url) (funcall action))) (loop for dispatcher in dispatchers for url = (car dispatcher) for action = (cdr dispatcher) - do (cond - ((and (string< url rel-script-name) - (null (starts-with-subseq rel-script-name url))) (return nil)) - ((starts-with-subseq rel-script-name url) (return (funcall action))))))))) + do (when (starts-with-subseq rel-script-name url) (return (funcall action)))))))) (defmethod clawserver-dispatch-method ((clawserver clawserver)) (let ((result (clawserver-dispatch-request clawserver))) Modified: trunk/main/claw-core/src/tags.lisp ============================================================================== --- trunk/main/claw-core/src/tags.lisp (original) +++ trunk/main/claw-core/src/tags.lisp Sat May 24 13:18:39 2008 @@ -15,7 +15,7 @@ ;;; disclaimer in the documentation and/or other materials ;;; provided with the distribution. -;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSEDse +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY @@ -105,9 +105,10 @@ This internal method is called to render these scripts. - PAGE is the page instance that must be given")) -(defgeneric htbody-init-scripts-tag (page) +(defgeneric htbody-init-scripts-tag (page &optional on-load) (:documentation "Encloses the init inscance scripts injected into the page into a <script> tag component -See PAGE-BODY-INIT-SCRIPTS form more info. +See PAGE-BODY-INIT-SCRIPTS form more info. If the ON-LOAD parameter it not nil, then the script will be executed +on the onload document event. - PAGE is the page instance that must be given")) (defgeneric page-current-component (page) @@ -370,6 +371,8 @@ :accessor page-lasttag :documentation "Last rendered tag. Needed for page output rendering") (json-component-count :initarg :json-component-count :accessor page-json-component-count :documentation "Need to render the json object after an xhr call.") + (json-component-id-list :initform () + :accessor page-json-component-id-list :documentation "The current component that will ber rendered into json reply object in an xhr call.") (request-parameters :initarg :request-parameters :documentation "This slot is used to avoid PAGE-REQUEST-PARAMETERS multimple computations, saving the result of this function on the first call and then using the cached value.") (components-stack :initform nil @@ -398,6 +401,9 @@ (defclass htcomponent (i18n-aware) ((page :initarg :page :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.") (body :initarg :body :accessor htcomponent-body :documentation "The tag body") (client-id :initarg :client-id @@ -416,6 +422,7 @@ :accessor htcomponent-instance-initscript :documentation "Page injectable javascript instance derectives")) (:default-initargs :page nil :body nil + :json-render-on-validation-errors-p nil :client-id nil :attributes nil :empty nil @@ -585,14 +592,19 @@ (defun json-validation-errors () "Composes the error part for the json reply" - (let ((validation-errors (aux-request-value :validation-errors))) + (let ((validation-errors (validation-errors))) (if validation-errors - (strings-to-jsarray - (loop for component-exceptions in validation-errors - collect (format "{~a:~a}"(car component-exceptions) - (strings-to-jsarray (loop for message in (cdr component-exceptions) - collect (prin1-to-string message)))))) + (let* ((errors (loop for (component-id messages) on validation-errors by #'cddr + collect (symbol-name component-id) + collect (push 'array messages))) + (js-struct (ps:ps* `(create ,@errors)))) + (subseq js-struct 0 (1- (length js-struct)))) "null"))) + +(defun json-validation-compliances () + "Composes the compliances part to form validation for the json reply" + (let ((js-array (ps:ps* `(array ,@(validation-compliances))))) + (subseq js-array 0 (1- (length js-array))))) (defmethod page-render ((page page)) (let ((body (page-content page)) @@ -624,6 +636,8 @@ (htcomponent-render init-scripts page))) (page-format-raw page "\",errors:") (page-format-raw page (json-validation-errors)) + (page-format-raw page ",valid:") + (page-format-raw page (json-validation-compliances)) (page-format-raw page "}")))))) (defmethod page-body-init-scripts ((page page)) @@ -687,26 +701,39 @@ (let* ((id (htcomponent-client-id htcomponent)) (page (htcomponent-page htcomponent)) (print-status (page-can-print page)) - (render-p (member id (page-json-id-list page) :test #'string=))) - (or print-status render-p))) + (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))) + #|json-render-on-validation-errors-p|# + (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 (htcomponent-client-id htcomponent))) + (id (htcomponent-client-id htcomponent)) + (validation-errors (validation-errors))) (when (and jsonp - (member id jsonp :test #'string-equal)) + (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))))) (defmethod htcomponent-json-print-end-component ((htcomponent htcomponent)) (let* ((page (htcomponent-page htcomponent)) (jsonp (page-json-id-list page)) - (id (htcomponent-client-id htcomponent))) + (id (htcomponent-client-id htcomponent)) + (validation-errors (validation-errors))) (when (and jsonp - (member id jsonp :test #'string-equal)) + (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 "\"")))) (defmethod htcomponent-rewind :before ((htcomponent htcomponent) (page page)) @@ -776,7 +803,7 @@ (page-format page " ~a=\"~a\"" (string-downcase (if (eq k :static-id) "id" - (symbol-name k))) + (parenscript::symbol-to-js k))) (let ((s (if (eq k :id) (prin1-to-string (htcomponent-client-id tag)) (prin1-to-string v)))) ;escapes double quotes @@ -784,26 +811,32 @@ (defmethod tag-render-starttag ((tag tag) (page page)) (let ((tagname (tag-name tag)) + (id (htcomponent-client-id tag)) + (jsonp (page-json-id-list page)) (emptyp (htcomponent-empty tag)) (xml-p (page-xmloutput page))) (setf (page-lasttag page) tagname) - (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) + (unless (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 (htcomponent-client-id tag)) + (jsonp (page-json-id-list page)) (previous-tagname (page-lasttag page)) (emptyp (htcomponent-empty tag))) - (when (null emptyp) + (when (and (null emptyp) (not (and jsonp + (string= id (first (page-json-component-id-list page)))))) (progn (decf (page-tabulator page)) (if (string= tagname previous-tagname) @@ -906,8 +939,8 @@ (dolist (element body) (when element (cond - ((stringp element) (htcomponent-render ($> element) page)) - ((functionp element) (htcomponent-render ($> (funcall element)) page)) + ((stringp element) (htcomponent-render ($raw> element) page)) + ((functionp element) (htcomponent-render ($raw> (funcall element)) page)) (t (htcomponent-render element page))))) (if (null xml-p) (page-format page "~%//-->") @@ -952,20 +985,22 @@ ((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) 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)) +(defmethod htbody-init-scripts-tag ((page page) &optional on-load) (let ((js (script> :type "text/javascript")) - (js-start-directive (if (msie-p) - "window.attachEvent\('onload', function\(e) {" - "document.addEventListener\('DOMContentLoaded', function\(e) {")) - (js-end-directive (if (msie-p) - "});" - "}, false);")) + (js-start-directive (if on-load (if (msie-p) + "window.attachEvent\('onload', function\(e) {" + "document.addEventListener\('DOMContentLoaded', function\(e) {") + "")) + (js-end-directive (if on-load (if (msie-p) + "});" + "}, false);") + "")) (page-body-init-scripts (page-body-init-scripts page))) (setf (htcomponent-page js) page (htcomponent-body js) (when page-body-init-scripts @@ -982,6 +1017,9 @@ :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 Modified: trunk/main/claw-core/src/validators.lisp ============================================================================== --- trunk/main/claw-core/src/validators.lisp (original) +++ trunk/main/claw-core/src/validators.lisp Sat May 24 13:18:39 2008 @@ -39,44 +39,47 @@ (decode-local-time local-time) (declare (ignore nsec)) (loop for result = "" then (concatenate 'string result (if (stringp element) - element - (ccase element - (:second (format nil "~2,'0D" sec)) - (:minute (format nil "~2,'0D" min)) - (:hour (format nil "~2,'0D" hour)) - (:date (format nil "~2,'0D" day)) - (:month (format nil "~2,'0D" month)) - (:year (format nil "~4,'0D" year))))) + element + (ccase element + (:second (format nil "~2,'0D" sec)) + (:minute (format nil "~2,'0D" min)) + (:hour (format nil "~2,'0D" hour)) + (:date (format nil "~2,'0D" day)) + (:month (format nil "~2,'0D" month)) + (:year (format nil "~4,'0D" year))))) for element in format finally (return result)))) (defun add-exception (id reason) -"Adds an exception for the given input component identified by its ID with the message expressed by REASON" - (let* ((validation-errors (aux-request-value :validation-errors)) - (component-exceptions (assoc id validation-errors :test #'equal))) - (if component-exceptions - (setf (cdr component-exceptions) (append (cdr component-exceptions) (list reason))) - (if validation-errors - (setf (aux-request-value :validation-errors) (append validation-errors (list (cons id (list reason))))) - (setf (aux-request-value :validation-errors) (list (cons id (list reason)))))))) - + "Adds an exception for the given input component identified by its ID with the message expressed by REASON" + (let* ((validation-errors (validation-errors)) + (symbol-id (make-symbol id)) + (errors (getf validation-errors symbol-id))) + (setf (getf validation-errors symbol-id) (nconc errors (list reason)) + (validation-errors *request*) validation-errors))) + +(defun component-exceptions (id) + "Returns a list of exception connectd to the given component" + (let ((symbol-id (make-symbol id))) + (getf (validation-errors) symbol-id))) (defun validate (test &key component message) -"When test is nil, an exception message given by MESSAGE is added for the COMPONENT. See: ADD-EXCEPTION..." + "When test is nil, an exception message given by MESSAGE is added for the COMPONENT. See: ADD-EXCEPTION..." (let ((client-id (htcomponent-client-id component))) - (unless test - (add-exception client-id message)))) + (if test + (add-validation-compliance client-id) + (add-exception client-id message)))) (defun validate-required (component value) - "Checks if the required input field VALUE is present. If not, a localizable message \"Field ~a may not be null.\" is sent with key \"VALIDATE-REQUIRED\". + "Checks if the required input field VALUE is present. If not, a localizable message \"Field ~a may not be empty.\" is sent with key \"VALIDATE-REQUIRED\". The argument for the message will be the :label attribute of the COMPONENT." (when (stringp value) (validate (and value (string-not-equal value "")) - :component component - :message (format nil (do-message "VALIDATE-REQUIRED" "Field ~a may not be null.") (label component))))) + :component component + :message (format nil (do-message "VALIDATE-REQUIRED" "Field ~a may not be empty.") (label component))))) (defun validate-size (component value &key min-size max-size) -"Checks if the input field VALUE legth is less then or greater then rispectively of the form keywords :MIN-SIZE and :MAX-SIZE. + "Checks if the input field VALUE legth is less then or greater then rispectively of the form keywords :MIN-SIZE and :MAX-SIZE. If less then :MIN-SIZE, a localizable message \"Size of ~a may not be less then ~a chars.\" is sent with key \"VALIDATE-SIZE-MIN\". The argument for the message will be the :label attribute of the COMPONENT and the :MIN-ZIZE value. If greater then :MAX-SIZE, a localizable message \"Size of ~a may not be more then ~a chars\" is sent with key \"VALIDATE-SIZE-MAX\". @@ -86,64 +89,64 @@ (setf value (format nil "~a" value)) (setf value-len (length value)) (and (= value-len 0) - (when min-size - (validate (>= value-len min-size) - :component component - :message (format nil (do-message "VALIDATE-SIZE-MIN" "Size of ~a may not be less then ~a chars." ) - (label component) - min-size))) - (when max-size - (validate (<= value-len max-size) - :component component - :message (format nil (do-message "VALIDATE-SIZE-MAX" "Size of ~a may not be more then ~a chars." ) - (label component) - max-size))))))) + (when min-size + (validate (>= value-len min-size) + :component component + :message (format nil (do-message "VALIDATE-SIZE-MIN" "Size of ~a may not be less then ~a chars." ) + (label component) + min-size))) + (when max-size + (validate (<= value-len max-size) + :component component + :message (format nil (do-message "VALIDATE-SIZE-MAX" "Size of ~a may not be more then ~a chars." ) + (label component) + max-size))))))) (defun validate-range (component value &key min max) -"Checks if the numeric input field VALUE is less then or greater then rispectively of the form keywords :MIN and :MAX. + "Checks if the numeric input field VALUE is less then or greater then rispectively of the form keywords :MIN and :MAX. If less then :MIN, a localizable message \"Field ~a is not less then or equal to ~d.\" is sent with key \"VALIDATE-RANGE-MIN\". The argument for the message will be the :label attribute of the COMPONENT and the :MIN value. If greater then :MIN, a localizable message \"Field ~a is not greater then or equal to ~d.\" is sent with key \"VALIDATE-RANGE-MAX\". The argument for the message will be the :label attribute of the COMPONENT and the :MAX value." (when value (and (when min - (validate (>= value min) - :component component - :message (format nil (do-message "VALIDATE-RANGE-MIN" "Field ~a is not greater then or equal to ~d") - (label component) - (if (typep min 'ratio) - (coerce min 'float) - min)))) - (when max - (validate (<= value max) - :component component - :message (format nil (do-message "VALIDATE-RANGE-MAX" "Field ~a is not less then or equal to ~d") - (label component) - (if (typep max 'ratio) - (coerce max 'float) - max))))))) + (validate (>= value min) + :component component + :message (format nil (do-message "VALIDATE-RANGE-MIN" "Field ~a is not greater then or equal to ~d") + (label component) + (if (typep min 'ratio) + (coerce min 'float) + min)))) + (when max + (validate (<= value max) + :component component + :message (format nil (do-message "VALIDATE-RANGE-MAX" "Field ~a is not less then or equal to ~d") + (label component) + (if (typep max 'ratio) + (coerce max 'float) + max))))))) (defun validate-number (component value &key min max) -"Checks if the input field VALUE is a valid number and then passes the validation to VALIDATION-RANGE. + "Checks if the input field VALUE is a valid number and then passes the validation to VALIDATION-RANGE. If not a number, a localizable message \"Field ~a is not a valid number.\" is sent with key \"VALIDATE-NUMBER\". The argument for the message will be the :label attribute of the COMPONENT." (when value (let ((test (numberp value))) (and (validate test - :component component - :message (format nil (do-message "VALIDATE-NUMBER" "Field ~a is not a valid number.") (label component))) - (validate-range component value :min min :max max))))) + :component component + :message (format nil (do-message "VALIDATE-NUMBER" "Field ~a is not a valid number.") (label component))) + (validate-range component value :min min :max max))))) (defun validate-integer (component value &key min max) -"Checks if the input field VALUE is a valid number and then passes the validation to VALIDATION-RANGE. + "Checks if the input field VALUE is a valid number and then passes the validation to VALIDATION-RANGE. If not a number, a localizable message \"Field ~a is not a valid integer.\" is sent with key \"VALIDATE-INTEGER\". The argument for the message will be the :label attribute of the COMPONENT." (when value (let ((test (integerp value))) (and (validate test - :component component - :message (format nil (do-message "VALIDATE-INTEGER" "Field ~a is not a valid integer.") (label component))) - (validate-range component value :min min :max max))))) + :component component + :message (format nil (do-message "VALIDATE-INTEGER" "Field ~a is not a valid integer.") (label component))) + (validate-range component value :min min :max max))))) (defun validate-date-range (component value &key min max (use-date-p t) use-time-p) @@ -157,64 +160,69 @@ The argument for the message will be the :label attribute of the COMPONENT and the value passed to :MAX parsed with the :LOCAL-TIME-FORMAT keyword." (unless (component-validation-errors component) (let ((local-time-format '(:date "-" :month "-" :year)) - (new-value (make-instance 'local-time - :nsec (nsec-of value) - :sec (sec-of value) - :day (day-of value) - :timezone (timezone-of value)))) + (new-value (make-instance 'local-time + :nsec (nsec-of value) + :sec (sec-of value) + :day (day-of value) + :timezone (timezone-of value)))) (when (and use-date-p (not use-time-p)) - (setf (local-time:nsec-of new-value) 0 - (local-time:sec-of new-value) 0) - (when min - (setf (local-time:nsec-of min) 0 - (local-time:sec-of min) 0)) - (when max - (setf (local-time:nsec-of max) 0 - (local-time:sec-of max) 0))) + (setf (local-time:nsec-of new-value) 0 + (local-time:sec-of new-value) 0) + (when min + (setf (local-time:nsec-of min) 0 + (local-time:sec-of min) 0)) + (when max + (setf (local-time:nsec-of max) 0 + (local-time:sec-of max) 0))) (when (and (not use-date-p) use-time-p) - (setf (local-time:day-of new-value) 0) - (when min - (setf (local-time:day-of min) 0)) - (when max - (setf (local-time:day-of max) 0))) + (setf (local-time:day-of new-value) 0) + (when min + (setf (local-time:day-of min) 0)) + (when max + (setf (local-time:day-of max) 0))) (and (when min - (validate (local-time> new-value min) - :component component - :message (format nil (do-message "VALIDATE-DATE-RANGE-MIN" "Field ~a is less then ~a.") - (label component) - (local-time-to-string min local-time-format)))) - (when max - (validate (local-time< new-value max) - :component component - :message (format nil (do-message "VALIDATE-DATE-RANGE-MAX" "Field ~a is greater then ~a.") - (label component) - (local-time-to-string max local-time-format)))))))) - + (validate (local-time> new-value min) + :component component + :message (format nil (do-message "VALIDATE-DATE-RANGE-MIN" "Field ~a is less then ~a.") + (label component) + (local-time-to-string min local-time-format)))) + (when max + (validate (local-time< new-value max) + :component component + :message (format nil (do-message "VALIDATE-DATE-RANGE-MAX" "Field ~a is greater then ~a.") + (label component) + (local-time-to-string max local-time-format)))))))) + ;; ------------------------------------------------------------------------------------ (defclass exception-monitor (wcomponent) () (:metaclass metacomponent) - (:default-initargs :empty t) + (:default-initargs :json-render-on-validation-errors-p t) (:documentation "If from submission contains exceptions. It displays exception messages")) (let ((class (find-class 'exception-monitor))) (closer-mop:ensure-finalized class) (setf (documentation (find-symbol (format nil "~a>" (class-name class))) 'function) - (format nil "Description: ~a~%Parameters:~%~a~a~%~%~a" - "If from submission contains exceptions. It displays exception messages with a <ul> list" - *id-and-static-id-description* - (describe-html-attributes-from-class-slot-initargs class) - (describe-component-behaviour class)))) + (format nil "Description: ~a~%Parameters:~%~a~a~%~%~a" + "If from submission contains exceptions. It displays exception messages with a <ul> list" + *id-and-static-id-description* + (describe-html-attributes-from-class-slot-initargs class) + (describe-component-behaviour class)))) (defmethod wcomponent-template ((exception-monitor exception-monitor)) (let ((client-id (htcomponent-client-id exception-monitor)) - (validation-errors (aux-request-value :validation-errors))) - (when validation-errors - (ul> :static-id client-id - (wcomponent-informal-parameters exception-monitor) - (loop for component-exceptions in validation-errors - collect (loop for message in (cdr component-exceptions) - collect (li> message))))))) + (validation-errors (validation-errors)) + (body (htcomponent-body exception-monitor))) + (div> :static-id client-id + (wcomponent-informal-parameters exception-monitor) + (when validation-errors + (if body + body + (ul> + (loop for component-exceptions in (rest validation-errors) by #'cddr + do (loop for message in component-exceptions + collect (li> message))))))))) + ;;-------------------------------------------------------------------------------------------