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"