[claw-cvs] r90 - trunk/main/claw-html/src
achiumenti at common-lisp.net
achiumenti at common-lisp.net
Thu Sep 18 13:30:00 UTC 2008
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))))))))
More information about the Claw-cvs
mailing list