Author: achiumenti Date: Thu Sep 18 09:29:59 2008 New Revision: 90

Modified: trunk/main/claw-html/src/components.lisp trunk/main/claw-html/src/packages.lisp trunk/main/claw-html/src/tags.lisp trunk/main/claw-html/src/translators.lisp trunk/main/claw-html/src/validators.lisp Log: several bugfixes

Modified: trunk/main/claw-html/src/components.lisp ============================================================================== --- trunk/main/claw-html/src/components.lisp (original) +++ trunk/main/claw-html/src/components.lisp Thu Sep 18 09:29:59 2008 @@ -77,7 +77,10 @@ (:documentation "Internal use component"))

(defclass _cform-mixin (_cform) - () + ((validator :initarg :validator + :reader validator + :documentation "A function that accept the passed component value during submission and performs the validation logic calling the validator functions.")) + (:default-initargs :validator nil) (:documentation "Internal use component"))

@@ -86,13 +89,17 @@ (when (not (and render-condition (null (funcall render-condition)))) (setf (cform-execute-p obj) t))))

-(defmethod wcomponent-after-rewind ((obj _cform) (pobj page)) +(defmethod wcomponent-after-rewind ((obj _cform-mixin) (pobj page)) (let ((validation-errors *validation-errors*) - (action (action obj))) + (action (action obj)) + (validator (validator obj))) (when (and (null validation-errors) action - (cform-rewinding-p obj pobj)) - (funcall action (action-object obj))))) + (cform-rewinding-p obj pobj)) + (when validator + (funcall validator obj)) + (unless *validation-errors* + (funcall action (action-object obj))))))

(defmethod cform-rewinding-p ((cform _cform) (page page)) (string= (htcomponent-client-id cform) @@ -197,6 +204,9 @@

;--------------------------------------------------------------------------------------- +(defgeneric translated-value (base-cinput) + (:documentation "Returns the component value using its translator")) + (defclass base-cinput (wcomponent) ((result-as-list-p :initarg :multiple :accessor cinput-result-as-list-p @@ -273,16 +283,19 @@ :value value (wcomponent-informal-parameters cinput))))

+(defmethod translated-value ((cinput base-cinput)) + (translator-decode (translator cinput) cinput)) + (defmethod wcomponent-after-rewind ((cinput base-cinput) (page page)) (when (cform-rewinding-p (page-current-form page) page) (let ((visit-object (cinput-visit-object cinput)) (accessor (cinput-accessor cinput)) (writer (cinput-writer cinput)) (validator (validator cinput)) - (value (translator-decode (translator cinput) cinput))) + (value (translated-value cinput))) (unless (or (null value) (null visit-object) (component-validation-errors cinput)) (when validator - (funcall validator value)) + (funcall validator cinput)) (unless (component-validation-errors cinput) (if (and (null writer) accessor) (funcall (fdefinition `(setf ,accessor)) value visit-object) @@ -393,8 +406,8 @@ (current-form (page-current-form pobj)) (submitted-p (page-req-parameter pobj (htcomponent-client-id obj)))) (unless (or (null current-form) (null submitted-p) (null action)) - (setf (action current-form) action - (action-object current-form) (or (action-object obj) (action-object current-form))))))) + (setf (action (page-current-form pobj)) action + (action-object (page-current-form pobj)) (or (action-object obj) (action-object current-form)))))))

;----------------------------------------------------------------------------- (defclass submit-link (csubmit) @@ -468,7 +481,12 @@ :accessor ccheckbox-value)) (:metaclass metacomponent) (:default-initargs :reserved-parameters (list :name) :empty t :type "checkbox" :test #'equal) - (:documentation "Request cycle aware component the renders as an INPUT tag class")) + (:documentation "Request cycle aware component the renders as an INPUT tag class. IMPORTANT its assigned id mus be unique +since its NAME tag attribute will be extracted from the assigned id and not from the generate one as for other cinput components")) + + +(defmethod name-attr ((cinput ccheckbox)) + (htcomponent-real-id cinput))

(let ((class (find-class 'ccheckbox))) (closer-mop:ensure-finalized class) @@ -486,8 +504,9 @@ (translator (translator cinput)) (type (input-type cinput)) (value (translator-value-type-to-string translator (ccheckbox-value cinput))) - (current-value (translator-type-to-string translator cinput)) - (class (css-class cinput))) + (current-value (translator-string-to-type translator cinput)) + (class (css-class cinput)) + (test (ccheckbox-test cinput))) (when (component-validation-errors cinput) (if (or (null class) (string= class "")) (setf class "error") @@ -497,23 +516,29 @@ :name (name-attr cinput) :class class :value value - :checked (when (and current-value (equal value current-value)) "checked") + :checked (when (and current-value + (if (listp current-value) + (member (ccheckbox-value cinput) current-value :test test) + (funcall test (ccheckbox-value cinput) current-value))) "checked") (wcomponent-informal-parameters cinput))))

(defmethod wcomponent-after-rewind ((cinput ccheckbox) (page page)) (when (cform-rewinding-p (page-current-form page) page) (let* ((visit-object (cinput-visit-object cinput)) - (client-id (htcomponent-client-id cinput)) + (name (name-attr cinput)) (translator (translator cinput)) (accessor (cinput-accessor cinput)) (writer (cinput-writer cinput)) (validator (validator cinput)) (result-as-list-p (cinput-result-as-list-p cinput)) (new-value (page-req-parameter page - client-id + name result-as-list-p))) (when new-value - (setf new-value (translator-string-to-type translator cinput))) + (setf new-value (if result-as-list-p + (loop for item in new-value + collect (translator-value-string-to-type translator item)) + (translator-string-to-type translator cinput)))) (unless (or (null visit-object) (component-validation-errors cinput)) (when validator (funcall validator (or new-value "")))

Modified: trunk/main/claw-html/src/packages.lisp ============================================================================== --- trunk/main/claw-html/src/packages.lisp (original) +++ trunk/main/claw-html/src/packages.lisp Thu Sep 18 09:29:59 2008 @@ -197,6 +197,7 @@ #:action-link #:action-link> #:action-link-parameters + #:translated-value #:cinput #:cinput> #:ctextarea

Modified: trunk/main/claw-html/src/tags.lisp ============================================================================== --- trunk/main/claw-html/src/tags.lisp (original) +++ trunk/main/claw-html/src/tags.lisp Thu Sep 18 09:29:59 2008 @@ -602,7 +602,8 @@ (when parameters (setf retval (gethash (string-upcase name) parameters)) (if (or (null retval) as-list) - retval + (progn + retval) (first retval)))))

(defmethod page-format ((page page) str &rest rest) @@ -715,10 +716,9 @@ (format nil "~a" js-body))))

(defmethod page-print-tabulation ((page page)) - (let ((jsonp (page-json-id-list page)) - (tabulator (page-tabulator page)) + (let ((tabulator (page-tabulator page)) (indent-p (page-indent page))) - (when (and (<= 0 tabulator) indent-p (null jsonp)) + (when (and (<= 0 tabulator) indent-p) (page-format-raw page "~a" (make-string tabulator :initial-element #\tab)))))

Modified: trunk/main/claw-html/src/translators.lisp ============================================================================== --- trunk/main/claw-html/src/translators.lisp (original) +++ trunk/main/claw-html/src/translators.lisp Thu Sep 18 09:29:59 2008 @@ -80,16 +80,17 @@ (setf value (cond ((and (null reader) accessor) (funcall (fdefinition accessor) visit-object)) (t (funcall (fdefinition reader) visit-object)))) - (translator-value-encode translator value))))) + (if (listp value) + (loop for item in value + collect (translator-value-encode translator item)) + (translator-value-encode translator value))))))

(defmethod translator-type-to-string ((translator translator) (wcomponent cinput)) (translator-encode translator wcomponent))

(defmethod translator-value-decode ((translator translator) value &optional client-id label) (declare (ignore client-id label)) - (if (string= value "") - nil - value)) + value)

(defmethod translator-value-string-to-type ((translator translator) value &optional client-id label) (translator-value-decode translator value client-id label)) @@ -97,7 +98,10 @@ (defmethod translator-decode ((translator translator) (wcomponent wcomponent)) (multiple-value-bind (client-id value) (component-id-and-value wcomponent) - (translator-value-decode translator value client-id (label wcomponent)))) + (if (listp value) + (loop for item in value + collect (translator-value-decode translator item client-id (label wcomponent))) + (translator-value-decode translator value client-id (label wcomponent)))))

(defmethod translator-string-to-type ((translator translator) (wcomponent wcomponent)) (translator-decode translator wcomponent))

Modified: trunk/main/claw-html/src/validators.lisp ============================================================================== --- trunk/main/claw-html/src/validators.lisp (original) +++ trunk/main/claw-html/src/validators.lisp Thu Sep 18 09:29:59 2008 @@ -62,21 +62,23 @@ (getf *validation-errors* symbol-id)))

(defun validate (test &key component message) - "When test is nil, an exception message given by MESSAGE is added for the COMPONENT. See: ADD-VALIDATION-ERROR..." - (let ((client-id (htcomponent-client-id component))) + "When test is nil, an exception message given by MESSAGE is added for the COMPONENT (that may be a WCOMPONENT instance or an ID string). See: ADD-VALIDATION-ERROR..." + (let ((client-id (if (stringp component) + component + (htcomponent-client-id component)))) (if test (add-validation-compliance client-id) (add-validation-error client-id message))))

-(defun validate-required (component value &key message) +(defun validate-required (component value &key message component-label) "Checks if the required input field VALUE is present. If not, a localizable message "Field ~a may not be empty." is sent with key "VALIDATE-REQUIRED". The argument for the message will be the :label attribute of the COMPONENT." (when (stringp value) (validate (and value (string-not-equal value "")) :component component - :message (or message (format nil "Field ~a may not be empty." (label component)))))) + :message (or message (format nil "Field ~a may not be empty." (or component-label (label component)))))))

-(defun validate-size (component value &key min-size max-size message-low message-hi) +(defun validate-size (component value &key min-size max-size message-low message-hi component-label) "Checks if the input field VALUE legth is less then or greater then rispectively of the form keywords :MIN-SIZE and :MAX-SIZE. If less then :MIN-SIZE, a localizable message "Size of ~a may not be less then ~a chars." is sent with key "VALIDATE-SIZE-MIN". The argument for the message will be the :label attribute of the COMPONENT and the :MIN-ZIZE value. @@ -91,16 +93,16 @@ (validate (>= value-len min-size) :component component :message (or message-low (format nil "Size of ~a may not be less then ~a chars." - (label component) + (or component-label (label component)) min-size)))) (when max-size (validate (<= value-len max-size) :component component :message (or message-hi (format nil "Size of ~a may not be more then ~a chars." - (label component) + (or component-label (label component)) max-size))))))))

-(defun validate-range (component value &key min max message-low message-hi) +(defun validate-range (component value &key min max message-low message-hi component-label) "Checks if the numeric input field VALUE is less then or greater then rispectively of the form keywords :MIN and :MAX. If less then :MIN, a localizable message "Field ~a is not less then or equal to ~d." is sent with key "VALIDATE-RANGE-MIN". The argument for the message will be the :label attribute of the COMPONENT and the :MIN value. @@ -111,7 +113,7 @@ (validate (>= value min) :component component :message (or message-low (format nil "Field ~a is not greater then or equal to ~d" - (label component) + (or component-label (label component)) (if (typep min 'ratio) (coerce min 'float) min))))) @@ -119,12 +121,12 @@ (validate (<= value max) :component component :message (or message-hi (format nil "Field ~a is not less then or equal to ~d" - (label component) + (or component-label (label component)) (if (typep max 'ratio) (coerce max 'float) max))))))))

-(defun validate-number (component value &key min max message-nan message-low message-hi) +(defun validate-number (component value &key min max message-nan message-low message-hi component-label) "Checks if the input field VALUE is a valid number and then passes the validation to VALIDATION-RANGE. If not a number, a localizable message "Field ~a is not a valid number." is sent with key "VALIDATE-NUMBER". The argument for the message will be the :label attribute of the COMPONENT." @@ -132,10 +134,11 @@ (let ((test (numberp value))) (and (validate test :component component - :message (or message-nan (format nil "Field ~a is not a valid number." (label component)))) - (validate-range component value :min min :max max :message-low message-low :message-hi message-hi))))) + :message (or message-nan (format nil "Field ~a is not a valid number." (or component-label + (label component))))) + (validate-range component value :min min :max max :message-low message-low :message-hi message-hi :component-label component-label)))))

-(defun validate-integer (component value &key min max message-nan message-low message-hi) +(defun validate-integer (component value &key min max message-nan message-low message-hi component-label) "Checks if the input field VALUE is a valid number and then passes the validation to VALIDATION-RANGE. If not a number, a localizable message "Field ~a is not a valid integer." is sent with key "VALIDATE-INTEGER". The argument for the message will be the :label attribute of the COMPONENT." @@ -143,11 +146,11 @@ (let ((test (integerp value))) (and (validate test :component component - :message (or message-nan (format nil "Field ~a is not a valid integer." (label component)))) - (validate-range component value :min min :max max :message-low message-low :message-hi message-hi))))) + :message (or message-nan (format nil "Field ~a is not a valid integer." (or component-label (label component))))) + (validate-range component value :min min :max max :message-low message-low :message-hi message-hi :component-label component-label)))))

-(defun validate-date-range (component value &key min max (use-date-p t) use-time-p message-low message-hi) +(defun validate-date-range (component value &key min max (use-date-p t) use-time-p message-low message-hi component-label) "Checks if the input field VALUE is a date between min and max. If :USE-DATE-P is not nil and :USE-TIME-P is nil, validation is made without considering the time part of local-time. If :USE-DATE-P nil and :USE-TIME-P is not nil, validation is made without considering the date part of local-time. @@ -156,40 +159,40 @@ The argument for the message will be the :label attribute of the COMPONENT and the value passed to :MIN parsed with the :LOCAL-TIME-FORMAT keyword. If value is greater then the date passed to :MAX, a localizable message "Field ~a is greater then ~a." is sent with key "VALIDATE-DATE-RANGE-MAX". The argument for the message will be the :label attribute of the COMPONENT and the value passed to :MAX parsed with the :LOCAL-TIME-FORMAT keyword." - (unless (component-validation-errors component) - (let ((local-time-format '(:date "-" :month "-" :year)) - (new-value (make-instance 'local-time - :nsec (nsec-of value) - :sec (sec-of value) - :day (day-of value) - :timezone (timezone-of value)))) - (when (and use-date-p (not use-time-p)) - (setf (local-time:nsec-of new-value) 0 - (local-time:sec-of new-value) 0) - (when min - (setf (local-time:nsec-of min) 0 - (local-time:sec-of min) 0)) - (when max - (setf (local-time:nsec-of max) 0 - (local-time:sec-of max) 0))) - (when (and (not use-date-p) use-time-p) - (setf (local-time:day-of new-value) 0) - (when min - (setf (local-time:day-of min) 0)) - (when max - (setf (local-time:day-of max) 0))) - (and (when min - (validate (local-time> new-value min) - :component component - :message (or message-low (format nil "Field ~a is less then ~a." - (label component) - (local-time-to-string min local-time-format))))) - (when max - (validate (local-time< new-value max) - :component component - :message (or message-hi (format nil "Field ~a is greater then ~a." - (label component) - (local-time-to-string max local-time-format))))))))) +; (unless (component-validation-errors component)) + (let ((local-time-format '(:date "-" :month "-" :year)) + (new-value (make-instance 'local-time + :nsec (nsec-of value) + :sec (sec-of value) + :day (day-of value) + :timezone (timezone-of value)))) + (when (and use-date-p (not use-time-p)) + (setf (local-time:nsec-of new-value) 0 + (local-time:sec-of new-value) 0) + (when min + (setf (local-time:nsec-of min) 0 + (local-time:sec-of min) 0)) + (when max + (setf (local-time:nsec-of max) 0 + (local-time:sec-of max) 0))) + (when (and (not use-date-p) use-time-p) + (setf (local-time:day-of new-value) 0) + (when min + (setf (local-time:day-of min) 0)) + (when max + (setf (local-time:day-of max) 0))) + (and (when min + (validate (local-time> new-value min) + :component component + :message (or message-low (format nil "Field ~a is less then ~a." + (or component-label (label component)) + (local-time-to-string min local-time-format))))) + (when max + (validate (local-time< new-value max) + :component component + :message (or message-hi (format nil "Field ~a is greater then ~a." + (or component-label (label component)) + (local-time-to-string max local-time-format))))))))