Author: achiumenti Date: Mon Mar 17 14:57:50 2008 New Revision: 18
Modified: trunk/main/claw-core/src/packages.lisp trunk/main/claw-core/src/validators.lisp trunk/main/claw-core/tests/test1.lisp Log: added translator-number
Modified: trunk/main/claw-core/src/packages.lisp ============================================================================== --- trunk/main/claw-core/src/packages.lisp (original) +++ trunk/main/claw-core/src/packages.lisp Mon Mar 17 14:57:50 2008 @@ -285,6 +285,7 @@ ;;validation :translator :translator-integer + :translator-number :translator-encode :translator-decode :*simple-translator*
Modified: trunk/main/claw-core/src/validators.lisp ============================================================================== --- trunk/main/claw-core/src/validators.lisp (original) +++ trunk/main/claw-core/src/validators.lisp Mon Mar 17 14:57:50 2008 @@ -56,6 +56,7 @@ (defmethod translator-decode ((translator translator) (wcomponent wcomponent)) (multiple-value-bind (client-id new-value) (component-id-and-value wcomponent) + (declare (ignore client-id)) new-value))
(defvar *simple-translator* (make-instance 'translator)) @@ -99,12 +100,13 @@ (let* ((thousand-separator (translator-thousand-separator translator))) (multiple-value-bind (client-id new-value) (component-id-and-value wcomponent) + (declare (ignore client-id)) (if thousand-separator (parse-integer (regex-replace-all (format nil "~a" thousand-separator) new-value "")) (parse-integer new-value)))))
;;========================================= -#| + (defclass translator-number (translator) ((thousand-separator :initarg :thousand-separator :reader translator-thousand-separator) @@ -113,13 +115,17 @@ (decimal-digits :initarg :decimal-digits :reader translator-decimal-digits) (always-show-signum :initarg :always-show-signum - :reader translator-always-show-signum)) + :reader translator-always-show-signum) + (coerce :initarg :coerce + :accessor translator-coerce)) (:default-initargs :thousand-separator nil :decimals-separator #. - :integer-digits nil + ;:integer-digits nil :decimal-digits nil - :always-show-signum nil) + :always-show-signum nil + :coerce 'ratio) (:documentation "a translator object encodes and decodes integer values passed to a html input component"))
+ (defmethod translator-encode ((translator translator-number) (wcomponent wcomponent)) (let* ((page (htcomponent-page wcomponent)) (visit-object (wcomponent-parameter-value wcomponent :visit-object)) @@ -145,24 +151,40 @@ (floor (cond ((and (null reader) accessor) (funcall (fdefinition accessor) visit-object)) (t (funcall (fdefinition reader) visit-object)))) + (progn + (setf dec-value (coerce dec-value 'float)) (format nil "~a~a" (if thousand-separator - (string-trim " " (format nil control-string thousand-separator int-value)) - (format nil control-string int-value)) + (string-trim " " (format nil integer-control-string thousand-separator int-value)) + (format nil integer-control-string int-value)) (cond ((and (= 0.0 (coerce dec-value 'double-float)) decimal-digits) - (format "~a~a" decimals-separator (make-string decimal-digits #\0))) + (format nil "~a~a" decimals-separator (make-string decimal-digits :initial-element #\0))) (decimal-digits - (format "~a~a" decimals-separator (make-string decimal-digits #\0)) + (let ((frac-part (subseq (format nil "~f" dec-value) 2))) + (if (> (length frac-part) decimal-digits) + (setf frac-part (subseq frac-part 0 decimal-digits)) + (setf frac-part (concatenate 'string frac-part (make-string (- decimal-digits (length frac-part)) :initial-element #\0)))) + (format nil "~a~a" decimals-separator frac-part))) + (t (format nil "~a~a" decimals-separator (subseq (format nil "~f" dec-value) 2))))))))))) +
(defmethod translator-decode ((translator translator-number) (wcomponent wcomponent)) - (let* ((thousand-separator (translator-thousand-separator translator))) - (multiple-value-bind (client-id new-value) + (let* ((thousand-separator (translator-thousand-separator translator)) + (type (translator-coerce translator)) + (int-value) + (dec-value)) + (multiple-value-bind (client-id new-value) (component-id-and-value wcomponent) - (if thousand-separator - (parse-integer (regex-replace-all (format nil "~a" thousand-separator) new-value "")) - (parse-integer new-value))))) + (declare (ignore client-id)) + (when thousand-separator + (setf new-value (regex-replace-all (format nil "~a" thousand-separator) new-value ""))) + (let ((decomposed-string (all-matches-as-strings "[0-9]+" new-value))) + (setf int-value (parse-integer (concatenate 'string (first decomposed-string) (second decomposed-string)))) + (setf dec-value (expt 10 (length (second decomposed-string)))) + (coerce (/ int-value dec-value) type))))) + +
-|# ;;---------------------------------------------------------------------------------------- (defun add-exception (id reason) (let* ((validation-errors (aux-request-value :validation-errors)) @@ -218,11 +240,19 @@ (or (when min (validate (>= value min) :component component - :message (format nil "Field ~a is not greater then or equal to ~d" (wcomponent-parameter-value component :label) min))) + :message (format nil "Field ~a is not greater then or equal to ~d" + (wcomponent-parameter-value component :label) + (if (typep min 'ratio) + (coerce min 'float) + min)))) (when max (validate (<= value max) :component component - :message (format nil "Field ~a is not less then or equal to ~d" (wcomponent-parameter-value component :label) max)))))) + :message (format nil "Field ~a is not less then or equal to ~d" + (wcomponent-parameter-value component :label) + (if (typep max 'ratio) + (coerce max 'float) + max)))))))
(defun validator-number (component value &key min max) (when value @@ -259,15 +289,3 @@ collect (li> message)))))))
;;------------------------------------------------------------------------------------------- - -#| -(defmacro with-validators (&rest rest) - (let* ((component (gensym)) - (value (gensym)) - (validators (loop for validator in rest - collect (list 'funcall validator component value)))) - `#'(lambda (,value) - (let ((,component (current-component))) - (or ,@validators))))) -|# -
Modified: trunk/main/claw-core/tests/test1.lisp ============================================================================== --- trunk/main/claw-core/tests/test1.lisp (original) +++ trunk/main/claw-core/tests/test1.lisp Mon Mar 17 14:57:50 2008 @@ -299,8 +299,10 @@ (gender :initarg :gender :accessor user-gender) (age :initarg :age - :accessor user-age)) - (:default-initargs :name "" :surname "" :gender "" :age "")) + :accessor user-age) + (capital :initarg :capital + :accessor user-capital)) + (:default-initargs :name "" :surname "" :gender "" :age "" :capital 0.0))
(defgeneric form-page-update-user (form-page))
@@ -317,12 +319,15 @@ (user :initarg :user :accessor form-page-user) (age :initarg :age - :accessor form-page-age)) + :accessor form-page-age) + (capital :initarg :capital + :accessor form-page-capital)) (:default-initargs :name "kiuma" :surname "surnk" :colors nil :gender '("M") :age 1800 + :capital 500055/100 :message-dispatcher *lisplet-messages* :user (make-instance 'user)))
@@ -388,6 +393,20 @@ (validator-integer component value :min 1 :max 2000))) :accessor 'form-page-age)"*")) (tr> + (td> "Capital") + (td> + (cinput> :id "capital" + :type "text" + :label "Capital" + :translator (make-instance 'translator-number + :decimal-digits 4 + :thousand-separator #') + :validator #'(lambda (value) + (let ((component (page-current-component o))) + (validator-required component value) + (validator-number component value :min 1000.01 :max 500099/100))) + :accessor 'form-page-capital)"*")) + (tr> (td> "Colors") (td> (cselect> :id "colors"