;;; -*- 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-html) (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)))) (defun add-validation-error (id reason) "Adds an exception for the given input component identified by its ID with the message expressed by REASON " (let* ((symbol-id (intern id)) (errors (getf *validation-errors* symbol-id))) (setf (getf *validation-errors* symbol-id) (nconc errors (list reason))))) (defun component-exceptions (id) "Returns a list of exception connectd to the given component" (let ((symbol-id (intern id))) (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 (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 (value &key (component (page-current-component *claw-current-page*)) 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. " (unless value (setf value "")) (when (stringp value) (validate (and value (string-not-equal value "")) :component component :message (or message (format nil "Field ~a may not be empty." (or component-label (label component))))))) (defun validate-size (value &key (component (page-current-component *claw-current-page*)) 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. If greater then :MAX-SIZE, a localizable message \"Size of ~a may not be more then ~a chars\" is sent with key \"VALIDATE-SIZE-MAX\". The argument for the message will be the :label attribute of the COMPONENT and the :MAX-ZIZE value. " (let ((value-len 0)) (when value (setf value (format nil "~a" value)) (setf value-len (length value)) (and (= value-len 0) (when min-size (validate (>= value-len min-size) :component component :message (or message-low (format nil "Size of ~a may not be less then ~a chars." (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." (or component-label (label component)) max-size)))))))) (defun validate-range (value &key (component (page-current-component *claw-current-page*)) 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. If greater then :MIN, a localizable message \"Field ~a is not greater then or equal to ~d.\" is sent with key \"VALIDATE-RANGE-MAX\". The argument for the message will be the :label attribute of the COMPONENT and the :MAX value. " (when value (and (when min (validate (>= value min) :component component :message (or message-low (format nil "Field ~a is not greater then or equal to ~d" (or component-label (label component)) (if (typep min 'ratio) (coerce min 'float) min))))) (when max (validate (<= value max) :component component :message (or message-hi (format nil "Field ~a is not less then or equal to ~d" (or component-label (label component)) (if (typep max 'ratio) (coerce max 'float) max)))))))) (defun validate-number (value &key (component (page-current-component *claw-current-page*)) 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. " (when value (let ((test (numberp value))) (and (validate test :component component :message (or message-nan (format nil "Field ~a is not a valid number." (or component-label (label component))))) (validate-range value :component component :min min :max max :message-low message-low :message-hi message-hi :component-label component-label))))) (defun validate-integer (value &key (component (page-current-component *claw-current-page*)) 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. " (when value (let ((test (integerp value))) (and (validate test :component component :message (or message-nan (format nil "Field ~a is not a valid integer." (or component-label (label component))))) (validate-range value :component component :min min :max max :message-low message-low :message-hi message-hi :component-label component-label))))) (defun validate-date-range (value &key (component (page-current-component *claw-current-page*)) 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. 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 \"VALIDATE-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 \"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. " (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)))))))) ;; ------------------------------------------------------------------------------------ (defclass exception-monitor (wcomponent) ((class :initarg :class :reader class-name)) (:metaclass metacomponent) (:default-initargs :json-render-on-validation-errors-p t :class "") (:documentation "If from submission contains exceptions. It displays exception messages")) (let ((class (find-class 'exception-monitor))) (closer-mop:ensure-finalized class) (setf (documentation (find-symbol (format nil "~a>" (class-name class))) 'function) (format nil "Description: ~a~%Parameters:~%~a~a~%~%~a" "If from submission contains exceptions. It displays exception messages with a