[claw-cvs] r48 - in trunk/main/claw-core: . src
achiumenti at common-lisp.net
achiumenti at common-lisp.net
Sat May 24 17:18:44 UTC 2008
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 , at 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)))))))))
+
;;-------------------------------------------------------------------------------------------
More information about the Claw-cvs
mailing list