[claw-cvs] r18 - in trunk/main/claw-core: src tests
achiumenti at common-lisp.net
achiumenti at common-lisp.net
Mon Mar 17 19:57:50 UTC 2008
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 , at 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"
More information about the Claw-cvs
mailing list