[claw-cvs] r25 - in trunk/main/claw-core: . src tests
achiumenti at common-lisp.net
achiumenti at common-lisp.net
Tue Apr 1 16:11:58 UTC 2008
Author: achiumenti
Date: Tue Apr 1 11:11:57 2008
New Revision: 25
Added:
trunk/main/claw-core/src/translators.lisp
Modified:
trunk/main/claw-core/claw.asd
trunk/main/claw-core/src/packages.lisp
trunk/main/claw-core/src/validators.lisp
trunk/main/claw-core/tests/packages.lisp
trunk/main/claw-core/tests/test1.lisp
Log:
added local-time integration with validator and translator
Modified: trunk/main/claw-core/claw.asd
==============================================================================
--- trunk/main/claw-core/claw.asd (original)
+++ trunk/main/claw-core/claw.asd Tue Apr 1 11:11:57 2008
@@ -39,7 +39,8 @@
(:file "locales" :depends-on ("i18n"))
(:file "hunchentoot-overrides" :depends-on ("packages"))
(:file "tags" :depends-on ("misc"))
- (:file "validators" :depends-on ("tags"))
+ (:file "validators" :depends-on ("tags"))
+ (:file "translators" :depends-on ("validators"))
(:file "components" :depends-on ("tags" "validators"))
(:file "lisplet" :depends-on ("components"))
(:file "server" :depends-on ("lisplet"))))))
Modified: trunk/main/claw-core/src/packages.lisp
==============================================================================
--- trunk/main/claw-core/src/packages.lisp (original)
+++ trunk/main/claw-core/src/packages.lisp Tue Apr 1 11:11:57 2008
@@ -288,6 +288,7 @@
:translator
:translator-integer
:translator-number
+ :translator-date
:translator-encode
:translator-decode
:*simple-translator*
@@ -299,6 +300,7 @@
:validator-size
:validator-range
:validator-number
- :validator-integer
+ :validator-integer
+ :validator-date-range
:exception-monitor
:exception-monitor>))
Added: trunk/main/claw-core/src/translators.lisp
==============================================================================
--- (empty file)
+++ trunk/main/claw-core/src/translators.lisp Tue Apr 1 11:11:57 2008
@@ -0,0 +1,300 @@
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*-
+;;; $Header: src/components.lisp $
+
+;;; Copyright (c) 2008, Andrea Chiumenti. All rights reserved.
+
+;;; Redistribution and use in source and binary forms, with or without
+;;; modification, are permitted provided that the following conditions
+;;; are met:
+
+;;; * Redistributions of source code must retain the above copyright
+;;; notice, this list of conditions and the following disclaimer.
+
+;;; * Redistributions in binary form must reproduce the above
+;;; copyright notice, this list of conditions and the following
+;;; disclaimer in the documentation and/or other materials
+;;; provided with the distribution.
+
+;;; 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
+;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
+;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
+;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+(in-package :claw)
+
+(defgeneric translator-encode (translator wcomponent)
+ (:documentation "Encodes the input component value, used when rendering the component (Encodes from type to string)."))
+
+(defgeneric translator-decode (translator wcomponent)
+ (:documentation "Decodes the input component value after a form submit (Decodes from string to type)."))
+
+(defclass translator ()
+ ()
+ (:documentation "a translator object encodes and decodes values passed to a html input component"))
+
+(defmethod translator-encode ((translator translator) (wcomponent wcomponent))
+ (let ((page (htcomponent-page wcomponent))
+ (visit-object (wcomponent-parameter-value wcomponent :visit-object))
+ (accessor (wcomponent-parameter-value wcomponent :accessor))
+ (reader (wcomponent-parameter-value wcomponent :reader)))
+ (format nil "~a" (if (component-validation-errors wcomponent)
+ (page-req-parameter page (htcomponent-client-id wcomponent) nil)
+ (progn
+ (when (null visit-object)
+ (setf visit-object (htcomponent-page wcomponent)))
+ (if (and (null reader) accessor)
+ (funcall (fdefinition accessor) visit-object)
+ (funcall (fdefinition reader) visit-object)))))))
+
+(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)
+ "*SIMPLE-TRANSLATOR* is the default translator for any CINPUT component.
+Its encoder and decoder methods pass values unchanged")
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;;;;;;;;;;;;;; Integer translator ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defclass translator-integer (translator)
+ ((thousand-separator :initarg :thousand-separator
+ :reader translator-thousand-separator
+ :documentation "If specified (as character), it is the thousands separator. Despite of
+its name, grouping is done following the TRANSLATOR-GROUPING-SIZE, so it's not a real 'tousands' separator")
+ (always-show-signum :initarg :always-show-signum
+ :reader translator-always-show-signum
+ :documentation "When true the signum is used also for displaying positive numbers.")
+ (grouping-size :initarg :grouping-size
+ :reader translator-grouping-size
+ :documentation "Used only if TRANSLATOR-THOUSAND-SEPARATOR is defined. Default to 3"))
+ (:default-initargs :thousand-separator nil
+ :grouping-size 3
+ :always-show-signum nil)
+ (:documentation "A translator object encodes and decodes integer values passed to a html input component"))
+
+(defmethod translator-encode ((translator translator-integer) (wcomponent wcomponent))
+ (let* ((page (htcomponent-page wcomponent))
+ (visit-object (wcomponent-parameter-value wcomponent :visit-object))
+ (accessor (wcomponent-parameter-value wcomponent :accessor))
+ (reader (wcomponent-parameter-value wcomponent :reader))
+ (grouping-size (translator-grouping-size translator))
+ (thousand-separator (translator-thousand-separator translator))
+ (signum-directive (if (translator-always-show-signum translator)
+ "@"
+ ""))
+ (control-string (if thousand-separator
+ (format nil "~~~d,',v:~aD" grouping-size signum-directive)
+ (format nil "~~~ad" signum-directive)))
+
+ (value (page-req-parameter page (htcomponent-client-id wcomponent) nil)))
+ (if (component-validation-errors wcomponent)
+ value
+ (progn
+ (when (null visit-object)
+ (setf visit-object (htcomponent-page wcomponent)))
+ (setf value (cond
+ ((and (null reader) accessor) (funcall (fdefinition accessor) visit-object))
+ (t (funcall (fdefinition reader) visit-object))))
+ (if thousand-separator
+ (string-trim " " (format nil control-string thousand-separator value))
+ (format nil control-string value))))))
+
+(defmethod translator-decode ((translator translator-integer) (wcomponent wcomponent))
+ (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)))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;;;;;;;;;;;;;;Folating point number translator ;;;;;;;;;;;;;;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defclass translator-number (translator-integer)
+ ((decimals-separator :initarg :decimals-separator
+ :reader translator-decimals-separator
+ :documentation "The decimal separator of the rendered number. Default to #\.")
+ (decimal-digits :initarg :decimal-digits
+ :reader translator-decimal-digits
+ :documentation "force the rendering of the value to a fixed number of decimal digits")
+ (coerce :initarg :coerce
+ :accessor translator-coerce
+ :documentation "Coerces the decoded input value to the given value type"))
+ (:default-initargs :decimals-separator #\.
+ ;:integer-digits nil
+ :decimal-digits 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))
+ (accessor (wcomponent-parameter-value wcomponent :accessor))
+ (reader (wcomponent-parameter-value wcomponent :reader))
+ (thousand-separator (translator-thousand-separator translator))
+ (grouping-size (translator-grouping-size translator))
+ (decimal-digits (translator-decimal-digits translator))
+ (decimals-separator (translator-decimals-separator translator))
+ (signum-directive (if (translator-always-show-signum translator)
+ "@"
+ ""))
+ (integer-control-string (if thousand-separator
+ (format nil "~~~d,',v:~aD" grouping-size signum-directive)
+ (format nil "~~~ad" signum-directive)))
+
+ (value (page-req-parameter page (htcomponent-client-id wcomponent) nil)))
+ (if (component-validation-errors wcomponent)
+ value
+ (progn
+ (when (null visit-object)
+ (setf visit-object (htcomponent-page wcomponent)))
+ (multiple-value-bind (int-value dec-value)
+ (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 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 nil "~a~a" decimals-separator (make-string decimal-digits :initial-element #\0)))
+ (decimal-digits
+ (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))
+ (type (translator-coerce translator))
+ (int-value)
+ (dec-value))
+ (multiple-value-bind (client-id new-value)
+ (component-id-and-value wcomponent)
+ (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))
+ (result))
+ (setf int-value (parse-integer (concatenate 'string (first decomposed-string) (second decomposed-string)))
+ dec-value (expt 10 (length (second decomposed-string)))
+ result (/ int-value dec-value))
+ (if (integerp result)
+ result
+ (coerce result type))))))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;;;;;;;;;;;;;; Dates translator ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defclass translator-date (translator)
+ ((local-time-format :initarg :local-time-format
+ :reader translator-local-time-format
+ :documentation "Sets the format of a date using a list where element are joined together and :DATE :MONTH and :YEAR are
+expanded into day of the month for :DATE, month number for :MONTH and the year for :YEAR. The Default is the list '(:month \"/\" :date \"/\" :year)"))
+ (:default-initargs :local-time-format '(:month "/" :date "/" :year))
+ (:documentation "A translator object encodes and decodes local-date object value passed to a html input component.
+When decoding the input compoenent value string to a local-time instance
+if the date is expressed in a wrong format or is not valid, a localizable message \"Field ~a is not a valid date or wrong format: ~a\" is sent with key \"VALIDATOR-DATE\".
+The argument for the message will be the :label attribute of the COMPONENT and the input component string value."))
+
+
+
+(defmethod translator-encode ((translator translator-date) (wcomponent wcomponent))
+ (let* ((page (htcomponent-page wcomponent))
+ (visit-object (wcomponent-parameter-value wcomponent :visit-object))
+ (accessor (wcomponent-parameter-value wcomponent :accessor))
+ (reader (wcomponent-parameter-value wcomponent :reader))
+ (local-time-format (translator-local-time-format translator))
+ (value (page-req-parameter page (htcomponent-client-id wcomponent) nil)))
+ (if (component-validation-errors wcomponent)
+ value
+ (progn
+ (when (null visit-object)
+ (setf visit-object (htcomponent-page wcomponent)))
+ (setf value (cond
+ ((and (null reader) accessor) (funcall (fdefinition accessor) visit-object))
+ (t (funcall (fdefinition reader) visit-object))))
+ (if (and value (not (stringp value)))
+ (progn
+ (local-time-to-string value
+ local-time-format))
+ value)))))
+
+(defmethod translator-decode ((translator translator-date) (wcomponent wcomponent))
+ (let ((date-format (translator-local-time-format translator))
+ (sec 0)
+ (min 0)
+ (hour 0)
+ (day 0)
+ (month 0)
+ (year 0)
+ (old-value))
+ (multiple-value-bind (client-id new-value)
+ (component-id-and-value wcomponent)
+ (declare (ignore client-id))
+ (when (and new-value (string-not-equal new-value ""))
+ (setf old-value new-value)
+ (loop for element in date-format
+ do (if (stringp element)
+ (setf new-value (subseq new-value (length element)))
+ (ccase element
+ (:second (multiple-value-bind (value size)
+ (parse-integer new-value :junk-allowed t)
+ (setf new-value (subseq new-value size))
+ (setf sec value)))
+ (:minute (multiple-value-bind (value size)
+ (parse-integer new-value :junk-allowed t)
+ (setf new-value (subseq new-value size))
+ (setf min value)))
+ (:hour (multiple-value-bind (value size)
+ (parse-integer new-value :junk-allowed t)
+ (setf new-value (subseq new-value size))
+ (setf hour value)))
+ (:date (multiple-value-bind (value size)
+ (parse-integer new-value :junk-allowed t)
+ (setf new-value (subseq new-value size))
+ (setf day value)))
+ (:month (multiple-value-bind (value size)
+ (parse-integer new-value :junk-allowed t)
+ (setf new-value (subseq new-value size))
+ (setf month value)))
+ (:year (multiple-value-bind (value size)
+ (parse-integer new-value :junk-allowed t)
+ (setf new-value (subseq new-value size))
+ (setf year value))))))
+ (validate (and (string-equal new-value "")
+ (>= sec 0)
+ (>= min 0)
+ (>= hour 0)
+ (and (> month 0) (<= month 12))
+ (and (> day 0) (<= day (days-in-month month year))))
+ :component wcomponent
+ :message (format nil (do-message "VALIDATOR-DATE" "Field ~a is not a valid date or wrong format: ~a")
+ (wcomponent-parameter-value wcomponent :label)
+ old-value))
+ (if (component-validation-errors wcomponent)
+ old-value
+ (encode-local-time 0 sec min hour day month year))))))
+
Modified: trunk/main/claw-core/src/validators.lisp
==============================================================================
--- trunk/main/claw-core/src/validators.lisp (original)
+++ trunk/main/claw-core/src/validators.lisp Tue Apr 1 11:11:57 2008
@@ -29,259 +29,27 @@
(in-package :claw)
-(defgeneric translator-encode (translator wcomponent)
- (:documentation "Encodes the input component value, used when rendering the component (Encodes from type to string)."))
+(defgeneric local-time-to-string (local-time format)
+ (:documentation "Writes a local-time instance the FORMAT list where element are joined together and :SECOND :MINUTE :HOUR :DATE :MONTH and :YEAR are
+expanded into seconds for :SECOND, minutes for :MINUTE, hour of the day for :HOUR, day of the month for :DATE, month number for :MONTH and the year for :YEAR.
+A format list may be for example '(:month \"/\" :date \"/\" :year)"))
+
+(defmethod local-time-to-string ((local-time local-time) format)
+ (multiple-value-bind (nsec sec min hour day month year)
+ (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)))))
+ for element in format
+ finally (return result))))
-(defgeneric translator-decode (translator wcomponent)
- (:documentation "Decodes the input component value after a form submit (Decodes from string to type)."))
-
-(defclass translator ()
- ()
- (:documentation "a translator object encodes and decodes values passed to a html input component"))
-
-(defmethod translator-encode ((translator translator) (wcomponent wcomponent))
- (let ((page (htcomponent-page wcomponent))
- (visit-object (wcomponent-parameter-value wcomponent :visit-object))
- (accessor (wcomponent-parameter-value wcomponent :accessor))
- (reader (wcomponent-parameter-value wcomponent :reader)))
- (format nil "~a" (if (component-validation-errors wcomponent)
- (page-req-parameter page (htcomponent-client-id wcomponent) nil)
- (progn
- (when (null visit-object)
- (setf visit-object (htcomponent-page wcomponent)))
- (if (and (null reader) accessor)
- (funcall (fdefinition accessor) visit-object)
- (funcall (fdefinition reader) visit-object)))))))
-
-(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)
- "*SIMPLE-TRANSLATOR* is the default translator for any CINPUT component.
-Its encoder and decoder methods pass values unchanged")
-
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;;;;;;;;;;;;;;; Integer translator ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(defclass translator-integer (translator)
- ((thousand-separator :initarg :thousand-separator
- :reader translator-thousand-separator
- :documentation "If specified (as character), it is the thousands separator. Despite of
-its name, grouping is done following the TRANSLATOR-GROUPING-SIZE, so it's not a real 'tousands' separator")
- (always-show-signum :initarg :always-show-signum
- :reader translator-always-show-signum
- :documentation "When true the signum is used also for displaying positive numbers.")
- (grouping-size :initarg :grouping-size
- :reader translator-grouping-size
- :documentation "Used only if TRANSLATOR-THOUSAND-SEPARATOR is defined. Default to 3"))
- (:default-initargs :thousand-separator nil
- :grouping-size 3
- :always-show-signum nil)
- (:documentation "A translator object encodes and decodes integer values passed to a html input component"))
-
-(defmethod translator-encode ((translator translator-integer) (wcomponent wcomponent))
- (let* ((page (htcomponent-page wcomponent))
- (visit-object (wcomponent-parameter-value wcomponent :visit-object))
- (accessor (wcomponent-parameter-value wcomponent :accessor))
- (reader (wcomponent-parameter-value wcomponent :reader))
- (grouping-size (translator-grouping-size translator))
- (thousand-separator (translator-thousand-separator translator))
- (signum-directive (if (translator-always-show-signum translator)
- "@"
- ""))
- (control-string (if thousand-separator
- (format nil "~~~d,' ,v:~aD" grouping-size signum-directive)
- (format nil "~~~ad" signum-directive)))
-
- (value (page-req-parameter page (htcomponent-client-id wcomponent) nil)))
- (if (component-validation-errors wcomponent)
- value
- (progn
- (when (null visit-object)
- (setf visit-object (htcomponent-page wcomponent)))
- (setf value (cond
- ((and (null reader) accessor) (funcall (fdefinition accessor) visit-object))
- (t (funcall (fdefinition reader) visit-object))))
- (if thousand-separator
- (string-trim " " (format nil control-string thousand-separator value))
- (format nil control-string value))))))
-
-(defmethod translator-decode ((translator translator-integer) (wcomponent wcomponent))
- (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)))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;;;;;;;;;;;;;;;Folating point number translator ;;;;;;;;;;;;;;;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(defclass translator-number (translator-integer)
- ((decimals-separator :initarg :decimals-separator
- :reader translator-decimals-separator
- :documentation "The decimal separator of the rendered number. Default to #\.")
- (decimal-digits :initarg :decimal-digits
- :reader translator-decimal-digits
- :documentation "force the rendering of the value to a fixed number of decimal digits")
- (coerce :initarg :coerce
- :accessor translator-coerce
- :documentation "Coerces the decoded input value to the given value type"))
- (:default-initargs :decimals-separator #\.
- ;:integer-digits nil
- :decimal-digits 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))
- (accessor (wcomponent-parameter-value wcomponent :accessor))
- (reader (wcomponent-parameter-value wcomponent :reader))
- (thousand-separator (translator-thousand-separator translator))
- (grouping-size (translator-grouping-size translator))
- (decimal-digits (translator-decimal-digits translator))
- (decimals-separator (translator-decimals-separator translator))
- (signum-directive (if (translator-always-show-signum translator)
- "@"
- ""))
- (integer-control-string (if thousand-separator
- (format nil "~~~d,' ,v:~aD" grouping-size signum-directive)
- (format nil "~~~ad" signum-directive)))
-
- (value (page-req-parameter page (htcomponent-client-id wcomponent) nil)))
- (if (component-validation-errors wcomponent)
- value
- (progn
- (when (null visit-object)
- (setf visit-object (htcomponent-page wcomponent)))
- (multiple-value-bind (int-value dec-value)
- (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 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 nil "~a~a" decimals-separator (make-string decimal-digits :initial-element #\0)))
- (decimal-digits
- (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))
- (type (translator-coerce translator))
- (int-value)
- (dec-value))
- (multiple-value-bind (client-id new-value)
- (component-id-and-value wcomponent)
- (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))
- (result))
- (setf int-value (parse-integer (concatenate 'string (first decomposed-string) (second decomposed-string)))
- dec-value (expt 10 (length (second decomposed-string)))
- result (/ int-value dec-value))
- (if (integerp result)
- result
- (coerce result type))))))
-
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;;;;;;;;;;;;;;; Dates translator ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-
-(defclass translator-date (translator)
- ((date-format :initarg :date-format
- :reader translator-date-fromat
- :documentation "Sets the format of a date using a list where element are joined together and :DATE :MONTH and :YEAR are
-expanded into day of the month for :DATE, month number for :MONTH and the year for :YEAR. The Default is the list '(:month \"/\" :date \"/\" :year)"))
- (:default-initargs :date-format '(:month "/" :date "/" :year))
- (:documentation "A translator object encodes and decodes local-date object value 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))
- (accessor (wcomponent-parameter-value wcomponent :accessor))
- (reader (wcomponent-parameter-value wcomponent :reader))
- (thousand-separator (translator-thousand-separator translator))
- (grouping-size (translator-grouping-size translator))
- (decimal-digits (translator-decimal-digits translator))
- (decimals-separator (translator-decimals-separator translator))
- (signum-directive (if (translator-always-show-signum translator)
- "@"
- ""))
- (integer-control-string (if thousand-separator
- (format nil "~~~d,' ,v:~aD" grouping-size signum-directive)
- (format nil "~~~ad" signum-directive)))
-
- (value (page-req-parameter page (htcomponent-client-id wcomponent) nil)))
- (if (component-validation-errors wcomponent)
- value
- (progn
- (when (null visit-object)
- (setf visit-object (htcomponent-page wcomponent)))
- (multiple-value-bind (int-value dec-value)
- (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 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 nil "~a~a" decimals-separator (make-string decimal-digits :initial-element #\0)))
- (decimal-digits
- (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))
- (type (translator-coerce translator))
- (int-value)
- (dec-value))
- (multiple-value-bind (client-id new-value)
- (component-id-and-value wcomponent)
- (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))
- (result))
- (setf int-value (parse-integer (concatenate 'string (first decomposed-string) (second decomposed-string)))
- dec-value (expt 10 (length (second decomposed-string)))
- result (/ int-value dec-value))
- (if (integerp result)
- result
- (coerce result type))))))
-|#
-;;----------------------------------------------------------------------------------------
(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))
@@ -326,7 +94,7 @@
(when value
(setf value (format nil "~a" value))
(setf value-len (length value))
- (or (= value-len 0)
+ (and (= value-len 0)
(when min-size
(validate (>= value-len min-size)
:component component
@@ -347,7 +115,7 @@
If greater then :MIN, a localizable message \"Field ~a is not greater then or equal to ~d.\" is sent with key \"VALIDATOR-RANGE-MAX\".
The argument for the message will be the :label attribute of the COMPONENT and the :MAX value."
(when value
- (or (when min
+ (and (when min
(validate (>= value min)
:component component
:message (format nil (do-message "VALIDATOR-RANGE-MIN" "Field ~a is not greater then or equal to ~d")
@@ -370,7 +138,7 @@
The argument for the message will be the :label attribute of the COMPONENT."
(when value
(let ((test (numberp value)))
- (or (validate test
+ (and (validate test
:component component
:message (format nil (do-message "VALIDATOR-NUMBER" "Field ~a is not a valid number.") (wcomponent-parameter-value component :label)))
(validator-range component value :min min :max max)))))
@@ -381,12 +149,58 @@
The argument for the message will be the :label attribute of the COMPONENT."
(when value
(let ((test (integerp value)))
- (or (validate test
+ (and (validate test
:component component
:message (format nil (do-message "VALIDATOR-INTEGER" "Field ~a is not a valid integer.") (wcomponent-parameter-value component :label)))
(validator-range component value :min min :max max)))))
+(defun validator-date-range (component value &key min max (use-date-p t) use-time-p)
+ "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.
+If :USE-DATE-P and :USE-TIME-P are both not nil or nil, validation is made considering the date and time part of local-time.
+If value is less then the date passed to :MIN, a localizable message \"Field ~a is less then ~a.\" is sent with key \"VALIDATOR-DATE-RANGE-MIN\".
+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 \"VALIDATOR-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));(translator-local-time-format (wcomponent-parameter-value component :translator)))
+ (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 (format nil (do-message "VALIDATOR-DATE-RANGE-MIN" "Field ~a is less then ~a.")
+ (wcomponent-parameter-value component :label)
+ (local-time-to-string min local-time-format))))
+ (when max
+ (validate (local-time< new-value max)
+ :component component
+ :message (format nil (do-message "VALIDATOR-DATE-RANGE-MAX" "Field ~a is greater then ~a.")
+ (wcomponent-parameter-value component :label)
+ (local-time-to-string max local-time-format))))))))
+
+
+
;; ------------------------------------------------------------------------------------
(defcomponent exception-monitor () ()
(:documentation "If from submission contains exceptions. It displays exception messages"))
Modified: trunk/main/claw-core/tests/packages.lisp
==============================================================================
--- trunk/main/claw-core/tests/packages.lisp (original)
+++ trunk/main/claw-core/tests/packages.lisp Tue Apr 1 11:11:57 2008
@@ -30,6 +30,6 @@
(in-package :cl-user)
(defpackage :claw-tests
- (:use :cl :claw :hunchentoot)
+ (:use :cl :claw :hunchentoot :local-time)
(:export :claw-tst-start
:claw-tst-stop))
\ No newline at end of file
Modified: trunk/main/claw-core/tests/test1.lisp
==============================================================================
--- trunk/main/claw-core/tests/test1.lisp (original)
+++ trunk/main/claw-core/tests/test1.lisp Tue Apr 1 11:11:57 2008
@@ -328,13 +328,17 @@
(age :initarg :age
:accessor form-page-age)
(capital :initarg :capital
- :accessor form-page-capital))
+ :accessor form-page-capital)
+ (birthday :initarg :birthday
+ :accessor form-page-birthday))
+
(:default-initargs :name "kiuma"
:surname "surnk"
:colors nil
:gender '("M")
:age 1800
:capital 500055/100
+ :birthday (now)
:message-dispatcher *lisplet-messages*
:user (make-instance 'user)))
@@ -400,6 +404,17 @@
(validator-integer component value :min 1 :max 2000)))
:accessor 'form-page-age)"*"))
(tr>
+ (td> "Bithday")
+ (td>
+ (cinput> :id "bday"
+ :type "text"
+ :label "Birthday"
+ :translator (make-instance 'translator-date :local-time-format '(:date "-" :month "-" :year))
+ :validator #'(lambda (value)
+ (let ((component (page-current-component o)))
+ (validator-date-range component value :min (local-time:encode-local-time 0 0 0 0 31 12 1900))))
+ :accessor 'form-page-birthday)"(dd-mm-yyyy)"))
+ (tr>
(td> "Capital")
(td>
(cinput> :id "capital"
More information about the Claw-cvs
mailing list