[claw-cvs] r49 - in trunk/main/claw-core: src tests
achiumenti at common-lisp.net
achiumenti at common-lisp.net
Fri May 30 10:03:02 UTC 2008
Author: achiumenti
Date: Fri May 30 06:03:00 2008
New Revision: 49
Modified:
trunk/main/claw-core/src/components.lisp
trunk/main/claw-core/src/lisplet.lisp
trunk/main/claw-core/src/misc.lisp
trunk/main/claw-core/src/packages.lisp
trunk/main/claw-core/src/server.lisp
trunk/main/claw-core/src/tags.lisp
trunk/main/claw-core/src/translators.lisp
trunk/main/claw-core/src/validators.lisp
trunk/main/claw-core/tests/test1.lisp
Log:
a lot of bug fixes, plus adding of checkbox and radio components
Modified: trunk/main/claw-core/src/components.lisp
==============================================================================
--- trunk/main/claw-core/src/components.lisp (original)
+++ trunk/main/claw-core/src/components.lisp Fri May 30 06:03:00 2008
@@ -41,9 +41,33 @@
(defgeneric translator-encode (translator wcomponent)
(:documentation "Encodes the input component value, used when rendering the component (Encodes from type to string)."))
+(defgeneric translator-type-to-string (translator wcomponent)
+ (:documentation "Encodes the input component value, used when rendering the component (Encodes from type to string). It's a wrapper for translator-encode"))
+
(defgeneric translator-decode (translator wcomponent)
(:documentation "Decodes the input component value after a form submit (Decodes from string to type)."))
+(defgeneric translator-string-to-type (translator wcomponent)
+ (:documentation "Decodes the input component value after a form submit (Decodes from string to type). It's a wrapper for translator-decode"))
+
+(defgeneric translator-value-encode (translator value)
+ (:documentation "Encodes the value, used when rendering the component (Encodes from type to string)."))
+
+(defgeneric translator-value-type-to-string (translator value)
+ (:documentation "Encodes the value, used when rendering the component (Encodes from type to string). It's a wrapper for translator-value-encode"))
+
+(defgeneric translator-value-decode (translator value &optional client-id label)
+ (:documentation "Decodes value after a form submit (Decodes from string to type)."))
+
+(defgeneric translator-value-string-to-type (translator value &optional client-id label)
+ (:documentation "Decodes value after a form submit (Decodes from string to type). It's a wrapper for translator-value-decode"))
+
+(defgeneric label (cinput)
+ (:documentation "Returns the label that describes the component. It's also be used when component validation fails. If it's a function it is funcalled"))
+
+(defgeneric name-attr (cinput)
+ (:documentation "Returns the name of the input component"))
+
(defclass translator ()
()
(:documentation "a translator object encodes and decodes values passed to a html input component"))
@@ -55,10 +79,12 @@
(defun component-validation-errors (component &optional (request *request*))
"Resurns possible validation errors occurred during form rewinding bound to a specific component"
(let ((client-id (htcomponent-client-id component)))
- (getf (validation-errors request) (make-symbol client-id))))
+ (getf (validation-errors request) (intern client-id))))
;--------------------------------------------------------------------------------
+
+
(defclass cform (wcomponent)
((action :initarg :action
:accessor action
@@ -94,7 +120,6 @@
(setf class "error")
(setf class (format nil "~a error" class))))
(form> :static-id client-id
- :name client-id
:class class
(wcomponent-informal-parameters cform)
(input> :name *rewind-parameter*
@@ -154,8 +179,7 @@
(accessor :initarg :accessor
:reader cinput-accessor
:documentation "Visit object slot accessor symbol. It can be used in place of the :READER and :WRITER parameters")
- (label :initarg :label
- :reader label
+ (label :initarg :label
:documentation "The label is the description of the component. It's also be used when component validation fails.")
(translator :initarg :translator
:reader translator
@@ -173,6 +197,15 @@
:label nil :translator *simple-translator* :validator nil :visit-object nil)
(:documentation "Class inherited from both CINPUT and CSELECT"))
+(defmethod label ((cinput base-cinput))
+ (let ((label (slot-value cinput 'label)))
+ (if (functionp label)
+ (funcall label)
+ label)))
+
+(defmethod name-attr ((cinput base-cinput))
+ (htcomponent-client-id cinput))
+
(defclass cinput (base-cinput)
((input-type :initarg :type
:reader input-type
@@ -204,7 +237,7 @@
(setf value (translator-encode translator cinput))
(input> :static-id client-id
:type type
- :name client-id
+ :name (name-attr cinput)
:class class
:value value
(wcomponent-informal-parameters cinput))))
@@ -233,7 +266,7 @@
(setf value
(cond
(from-request-p (page-req-parameter (htcomponent-page cinput)
- client-id
+ (name-attr cinput)
result-as-list-p))
((and (null reader) accessor) (funcall (fdefinition accessor) visit-object))
(t (funcall (fdefinition reader) visit-object))))
@@ -260,12 +293,15 @@
(describe-html-attributes-from-class-slot-initargs class)
(describe-component-behaviour class))))
+(defmethod name-attr ((csubmit csubmit))
+ (htcomponent-client-id csubmit))
+
(defmethod wcomponent-template ((obj csubmit))
(let ((client-id (htcomponent-client-id obj))
(value (csubmit-value obj)))
(input> :static-id client-id
:type "submit"
- :name client-id
+ :name (name-attr obj)
:value value
(wcomponent-informal-parameters obj))))
@@ -300,7 +336,7 @@
(input> :static-id submit-id
:style "display:none;"
:type "submit"
- :name id
+ :name (name-attr obj)
:value "-")
(a> :static-id id
:href (format nil "javascript:document.getElementById('~a').click();" submit-id)
@@ -332,12 +368,135 @@
(setf class "error")
(setf class (format nil "~a error" class))))
(select> :static-id client-id
- :name client-id
+ :name (name-attr obj)
:class class
:multiple (cinput-result-as-list-p obj)
(wcomponent-informal-parameters obj)
(htcomponent-body obj))))
+;--------------------------------------------------------------------------------------------
+(defclass ccheckbox (cinput)
+ ((test :initarg :test
+ :accessor ccheckbox-test)
+ (value :initarg :value
+ :accessor ccheckbox-value))
+ (:metaclass metacomponent)
+ (:default-initargs :reserved-parameters (list :name) :empty t :type "checkbox" :test #'equal)
+ (:documentation "Request cycle aware component the renders as an INPUT tag class"))
+(let ((class (find-class 'ccheckbox)))
+ (closer-mop:ensure-finalized class)
+ (setf (documentation (find-symbol (format nil "~a>" (class-name class))) 'function)
+ (format nil "Description: ~a~%Parameters:~%~a~a~a~a~%~%~a"
+ "Function that instantiates a CCHECKBOX component and renders a html <input> tag of type \"checkbox\"."
+ *id-and-static-id-description*
+ (describe-html-attributes-from-class-slot-initargs (find-class 'base-cinput))
+ (describe-html-attributes-from-class-slot-initargs (find-class 'cinput))
+ (describe-html-attributes-from-class-slot-initargs class)
+ (describe-component-behaviour class))))
+(defmethod wcomponent-template ((cinput ccheckbox))
+ (let* ((client-id (htcomponent-client-id cinput))
+ (translator (translator cinput))
+ (type (input-type cinput))
+ (value (translator-value-type-to-string translator (ccheckbox-value cinput)))
+ (current-value (translator-type-to-string translator cinput))
+ (class (css-class cinput)))
+ (when (component-validation-errors cinput)
+ (if (or (null class) (string= class ""))
+ (setf class "error")
+ (setf class (format nil "~a error" class))))
+ (input> :static-id client-id
+ :type type
+ :name (name-attr cinput)
+ :class class
+ :value value
+ :checked (when (and current-value (equal value current-value)) "checked")
+ (wcomponent-informal-parameters cinput))))
+
+(defmethod wcomponent-after-rewind ((cinput ccheckbox) (page page))
+ (let* ((visit-object (or (cinput-visit-object cinput) page))
+ (client-id (htcomponent-client-id cinput))
+ (translator (translator cinput))
+ (accessor (cinput-accessor cinput))
+ (writer (cinput-writer cinput))
+ (validator (validator cinput))
+ (result-as-list-p (cinput-result-as-list-p cinput))
+ (new-value (page-req-parameter page
+ client-id
+ result-as-list-p)))
+ (when new-value
+ (setf new-value (translator-string-to-type translator cinput)))
+ (unless (component-validation-errors cinput)
+ (when validator
+ (funcall validator (or new-value "")))
+ (unless (component-validation-errors cinput)
+ (if (and (null writer) accessor)
+ (funcall (fdefinition `(setf ,accessor)) new-value visit-object)
+ (funcall (fdefinition writer) new-value visit-object))))))
+
+;-------------------------------------------------------------------------------------
+(defclass cradio (ccheckbox)
+ ()
+ (:metaclass metacomponent)
+ (:default-initargs :type "radio")
+ (:documentation "Request cycle aware component the renders as an INPUT tag class"))
+
+(let ((class (find-class 'cradio)))
+ (closer-mop:ensure-finalized class)
+ (setf (documentation (find-symbol (format nil "~a>" (class-name class))) 'function)
+ (format nil "Description: ~a~%Parameters:~%~a~a~a~a~a~%~%~a"
+ "Function that instantiates a CRADIO component and renders a html <input> tag of type \"radio\"."
+ *id-and-static-id-description*
+ (describe-html-attributes-from-class-slot-initargs (find-class 'base-cinput))
+ (describe-html-attributes-from-class-slot-initargs (find-class 'cinput))
+ (describe-html-attributes-from-class-slot-initargs (find-class 'ccheckbox))
+ (describe-html-attributes-from-class-slot-initargs class)
+ (describe-component-behaviour class))))
+
+(defmethod name-attr ((ccheckbox ccheckbox))
+ (htcomponent-real-id ccheckbox))
+
+(defmethod wcomponent-after-rewind ((cinput cradio) (page page))
+ (let* ((visit-object (or (cinput-visit-object cinput) page))
+ (translator (translator cinput))
+ (accessor (cinput-accessor cinput))
+ (writer (cinput-writer cinput))
+ (validator (validator cinput))
+ (ccheckbox-test (ccheckbox-test cinput))
+ (result-as-list-p (cinput-result-as-list-p cinput))
+ (value (translator-value-string-to-type translator (ccheckbox-value cinput)))
+ (new-value (page-req-parameter page
+ (name-attr cinput)
+ result-as-list-p))
+ (checked))
+ (when new-value
+ (setf new-value (translator-string-to-type translator cinput)
+ checked (funcall ccheckbox-test value new-value)))
+ (when (and checked (null (component-validation-errors cinput)))
+ (when validator
+ (funcall validator (or new-value "")))
+ (when (null (component-validation-errors cinput))
+ (if (and (null writer) accessor)
+ (funcall (fdefinition `(setf ,accessor)) new-value visit-object)
+ (funcall (fdefinition writer) new-value visit-object))))))
+
+(defmethod wcomponent-template ((cinput cradio))
+ (let* ((client-id (htcomponent-client-id cinput))
+ (translator (translator cinput))
+ (type (input-type cinput))
+ (value (translator-value-type-to-string translator (ccheckbox-value cinput)))
+ (current-value (translator-type-to-string translator cinput))
+ (class (css-class cinput)))
+ (when (component-validation-errors cinput)
+ (if (or (null class) (string= class ""))
+ (setf class "error")
+ (setf class (format nil "~a error" class))))
+ (input> :static-id client-id
+ :type type
+ :name (name-attr cinput)
+ :class class
+ :value value
+ :checked (when (and current-value (equal value current-value)) "checked")
+ (wcomponent-informal-parameters cinput))))
Modified: trunk/main/claw-core/src/lisplet.lisp
==============================================================================
--- trunk/main/claw-core/src/lisplet.lisp (original)
+++ trunk/main/claw-core/src/lisplet.lisp Fri May 30 06:03:00 2008
@@ -49,7 +49,7 @@
- :WELCOME-PAGE-P When true, the function will be a welcome page, making the lisplet to redirect direct access to its base path to the expressed location
- :LOGIN-PAGE-P Marks the function as a login page"))
-(defgeneric lisplet-register-page-location (lisplet page-class location &key welcome-page-p login-page-p)
+(defgeneric lisplet-register-page-location (lisplet page-class location &key welcome-page-p login-page-p encoding)
(:documentation "Registers a page into a lisplet for dispatching.
parameters:
- LISPLET the lisplet that will dispatch the page
@@ -57,15 +57,17 @@
- LOCATION The url location where the page will be registered (relative to the lisplet base path)
keys:
- :WELCOME-PAGE-P When true, the page will be a welcome page, making the lisplet to redirect direct access to its base path to the expressed location
-- :LOGIN-PAGE-P Marks the page as a login page"))
+- :LOGIN-PAGE-P Marks the page as a login page
+- :ENCODING The charset encoding used to render the resource"))
-(defgeneric lisplet-register-resource-location (lisplet resource-path location &optional content-type)
+(defgeneric lisplet-register-resource-location (lisplet resource-path location &optional content-type encoding)
(:documentation "Registers a resource (file or directory) into a lisplet for dispatching.
parameters:
- LISPLET the lisplet that will dispatch the page
- RESOURCE-PATH pathname of a file or directory that is to be registered for dispatching
- LOCATION The url location where the resource will be registered (relative to the lisplet base path)
-- CONTENT-TYPE Meaningful only when the resource-path points to a file, indicates the resource content type"))
+- CONTENT-TYPE Meaningful only when the resource-path points to a file, indicates the resource content type
+- ENCODING The charset encoding used to render the resource"))
(defgeneric lisplet-dispatch-method (lisplet)
(:documentation "Performs authorizations checking then makes a call to LISPLET-DISPATCH-REQUEST
@@ -106,7 +108,7 @@
(if handler
(funcall handler)
(let ((error-page (make-instance 'error-page
- :title (format nil "Server error: ~a" error-code)
+ :title (format nil "Server error: ~a" error-code)
:error-code error-code)))
(with-output-to-string (*standard-output*) (page-render error-page)))))))
@@ -120,6 +122,9 @@
(login-page :initarg :login-page
:accessor lisplet-login-page
:documentation "url location for the welcome page")
+ (encoding :initarg :encoding
+ :accessor lisplet-encoding
+ :documentation "The default charset external format for resources provided by this lisplet.")
(realm :initarg :realm
:reader lisplet-realm
:documentation "realm for requests that pass through this lisplet and session opened into this lisplet")
@@ -137,6 +142,7 @@
:documentation "When not null every request will be redirected in https mode. When running in mod-lisp mode, *apache-http-port* and *apache-https-port* values are used"))
(:default-initargs :welcome-page nil
:login-page nil
+ :encoding :utf-8
:realm "claw"
:redirect-protected-resources-p nil)
(:documentation "A lisplet is a container for resources provided trhough the clawserver.
@@ -170,7 +176,7 @@
:basic))
(defmethod lisplet-register-function-location ((lisplet lisplet) function location &key welcome-page-p login-page-p)
- (let ((pages (lisplet-pages lisplet)))
+ (let ((pages (lisplet-pages lisplet)))
(setf (lisplet-pages lisplet)
(sort-by-location (pushnew-location (cons location function) pages)))
(when welcome-page-p
@@ -178,16 +184,18 @@
(when login-page-p
(setf (lisplet-login-page lisplet) location))))
-(defmethod lisplet-register-page-location ((lisplet lisplet) page-class location &key welcome-page-p login-page-p)
- (lisplet-register-function-location lisplet
- #'(lambda () (with-output-to-string (*standard-output*)
- (page-render (make-instance page-class :lisplet lisplet :url location))))
- location
- :welcome-page-p welcome-page-p
- :login-page-p login-page-p))
-
-(defmethod lisplet-register-resource-location ((lisplet lisplet) resource-path location &optional content-type)
- (let ((pages (lisplet-pages lisplet)))
+(defmethod lisplet-register-page-location ((lisplet lisplet) page-class location &key welcome-page-p login-page-p encoding)
+ (let ((charset-encoding (or encoding (lisplet-encoding lisplet))))
+ (lisplet-register-function-location lisplet
+ #'(lambda () (with-output-to-string (*standard-output*)
+ (page-render (make-instance page-class :lisplet lisplet :url location :encoding charset-encoding))))
+ location
+ :welcome-page-p welcome-page-p
+ :login-page-p login-page-p)))
+
+(defmethod lisplet-register-resource-location ((lisplet lisplet) resource-path location &optional content-type (encoding :utf-8))
+ (let ((pages (lisplet-pages lisplet))
+ (external-format (flexi-streams:make-external-format (or encoding (lisplet-encoding lisplet)) :eol-style :lf)))
(setf (lisplet-pages lisplet)
(sort-by-location (pushnew-location
(cons location
@@ -199,11 +207,7 @@
(length (lisplet-base-path lisplet))
(length location) 1)))
resource-path)))
- (log-message :info "--------------------------------------------- ~%
-script-name: \"~a\"~%
-resource-path: \"~a\"~%
-resource-full-path :\"~a\"~%
---------------------------------------------" (script-name) resource-path resource-full-path)
+ (setf (reply-external-format) external-format)
(handle-static-file resource-full-path content-type)))
#'(lambda () (handle-static-file resource-path content-type))))
pages)))))
@@ -214,9 +218,7 @@
(loop for dispatcher in dispatchers
for url = (car dispatcher)
for action = (cdr dispatcher)
- do (progn
- (log-message :info "rel-script-name: \"~a\" url: \"~a\" --- (starts-with-subseq rel-script-name url) : ~a" rel-script-name url (starts-with-subseq rel-script-name url))
- (when (starts-with-subseq rel-script-name url) (return (funcall action)))))))
+ do (when (starts-with-subseq rel-script-name url) (return (funcall action))))))
(defmethod lisplet-dispatch-method ((lisplet lisplet))
(let ((base-path (build-lisplet-location lisplet))
@@ -266,8 +268,6 @@
for match = (format nil "~a/~a" base-path (car protected-resource))
for allowed-roles = (cdr protected-resource)
do (when (or (starts-with-subseq match uri) (string= login-page-url uri))
- ;(when (lisplet-redirect-protected-resources-p lisplet)
- ;(redirect-to-https server request))
(cond
((and princp (not (user-in-role-p allowed-roles)) (not (string= login-page-url uri)))
(setf (return-code) +http-forbidden+)
Modified: trunk/main/claw-core/src/misc.lisp
==============================================================================
--- trunk/main/claw-core/src/misc.lisp (original)
+++ trunk/main/claw-core/src/misc.lisp Fri May 30 06:03:00 2008
@@ -289,7 +289,7 @@
(format nil "~{:~a ~}" (eval reserved-parameters))
"NONE"))))
-(defun register-library-resource (location resource-path &optional content-type)
+(defun register-library-resource (location resource-path &optional content-type (encoding :utf-8))
"Adds a RESOURCE \(a file or directory) as a library exposed resource to the given relative LOCATION."
(setf *claw-libraries-resources*
(sort-by-location (pushnew-location
@@ -300,9 +300,13 @@
(uri-to-pathname (subseq (script-name)
(+ (length (clawserver-base-path (current-server)))
(length location))))
- resource-path)))
+ resource-path))
+ (charset-encoding (flexi-streams:make-external-format encoding :eol-style :lf)))
+ (setf (reply-external-format) charset-encoding)
(handle-static-file resource-full-path content-type)))
- #'(lambda () (handle-static-file resource-path content-type))))
+ #'(lambda () (let ((charset-encoding (flexi-streams:make-external-format encoding :eol-style :lf)))
+ (setf (reply-external-format) charset-encoding)
+ (handle-static-file resource-path content-type)))))
*claw-libraries-resources*))))
(defun uri-to-pathname (uri &optional (relative t))
Modified: trunk/main/claw-core/src/packages.lisp
==============================================================================
--- trunk/main/claw-core/src/packages.lisp (original)
+++ trunk/main/claw-core/src/packages.lisp Fri May 30 06:03:00 2008
@@ -53,6 +53,7 @@
:empty-string-p
:build-tagf
:page
+ :page-encoding
:page-url
:page-lisplet
:page-current-form
@@ -68,6 +69,7 @@
:htcomponent-body
:htcomponent-empty
:htcomponent-client-id
+ :htcomponent-real-id
:htcomponent-script-files
:htcomponent-stylesheet-files
:htcomponent-class-initscripts
@@ -188,14 +190,18 @@
:wcomponent-before-prerender
:wcomponent-after-prerender
:wcomponent-before-render
- :wcomponent-after-render
+ :wcomponent-after-render
:cform
:cform>
:action
:action-link
- :action-link>
+ :action-link>
:cinput
:cinput>
+ :ccheckbox
+ :ccheckbox>
+ :cradio
+ :cradio>
:cselect
:cselect>
:csubmit
@@ -203,7 +209,12 @@
:csubmit-value
:submit-link
:submit-link>
+ :input-type
+ :ccheckbox-value
+ :css-class
+ :name-attr
:lisplet
+ :lisplet-encoding
:lisplet-pages
:lisplet-register-page-location
:lisplet-register-function-location
@@ -269,10 +280,18 @@
:translator
:translator-integer
:translator-number
+ :translator-boolean
:translator-date
:translator-encode
:translator-decode
+ :translator-string-to-type
+ :translator-type-to-string
+ :translator-value-decode
+ :translator-value-encode
+ :translator-value-string-to-type
+ :translator-value-type-to-string
:*simple-translator*
+ :*boolean-translator*
:*locales*
:validate
:validation-errors
Modified: trunk/main/claw-core/src/server.lisp
==============================================================================
--- trunk/main/claw-core/src/server.lisp (original)
+++ trunk/main/claw-core/src/server.lisp Fri May 30 06:03:00 2008
@@ -104,6 +104,7 @@
(error-code :initarg :error-code
:reader page-error-code
:documentation "The error code to display"))
+ (:default-initargs :encoding :utf-8)
(:documentation "This is the page class used to render
the http error messages."))
Modified: trunk/main/claw-core/src/tags.lisp
==============================================================================
--- trunk/main/claw-core/src/tags.lisp (original)
+++ trunk/main/claw-core/src/tags.lisp Fri May 30 06:03:00 2008
@@ -226,9 +226,6 @@
(defvar *xhtml-1.0-frameset* "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Frameset//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-frameset.dtd\">"
"Page doctype as XHTML 4.01 FRAMESET")
-(defvar *default-encoding* "UTF-8"
- "Page default encoding (if no changes 'UTF-8')")
-
(defvar *rewind-parameter* "rewindobject"
"The request parameter for the object asking for a rewind action")
@@ -292,19 +289,20 @@
(id-table-map (request-id-table-map))
(id (getf (first fbody) :id))
(static-id (getf (first fbody) :static-id))
+ (real-id (or static-id id))
(instance))
(when static-id
(remf (first fbody) :id)
(setf id nil))
(setf instance (make-instance parent
:empty emptyp
+ :real-id real-id
:name (string-downcase tag-name)
:attributes (first fbody)
:body (second fbody)))
(if (null static-id)
(when (and id-table-map id)
- (setf (htcomponent-client-id instance)
- (generate-id id)))
+ (setf (htcomponent-client-id instance) (generate-id id)))
(setf (htcomponent-client-id instance) static-id))
instance))
@@ -378,9 +376,12 @@
(components-stack :initform nil
:accessor page-components-stack
:documentation "A stack of components enetered into rendering process.")
- (content-type :initarg :content-type
- :accessor page-content-type
- :documentation "Define the content type of the page when rendered")
+ (mime-type :initarg :mime-type
+ :accessor page-mime-type
+ :documentation "Define the mime type of the page when rendered")
+ (encoding :initarg :encoding
+ :accessor page-encoding
+ :documentation "The charset external format. When not provided the lisplet one is used")
(url :initarg :url
:accessor page-url :documentation "The URL provided with this page instance"))
(:default-initargs :writer t
@@ -394,7 +395,7 @@
:xmloutput nil
:doc-type *html-4.01-strict*
:request-parameters nil
- :content-type hunchentoot:*default-content-type*
+ :mime-type "text/html"
:url nil)
(:documentation "A page object holds claw components to be rendered") )
@@ -408,6 +409,8 @@
:accessor htcomponent-body :documentation "The tag body")
(client-id :initarg :client-id
:accessor htcomponent-client-id :documentation "The tag computed id if :ID war provided for the building function")
+ (real-id :initarg :real-id
+ :accessor htcomponent-real-id :documentation "The tag real id got from :ID or :STATIC-ID")
(attributes :initarg :attributes
:accessor htcomponent-attributes :documentation "The tag attributes")
(empty :initarg :empty
@@ -424,6 +427,7 @@
:body nil
:json-render-on-validation-errors-p nil
:client-id nil
+ :real-id nil
:attributes nil
:empty nil
:script-files nil
@@ -578,17 +582,15 @@
(setf (page-tabulator page) 0)))
(defmethod page-render-headings ((page page))
- (let* ((writer (page-writer page))
- (jsonp (page-json-id-list page))
- (encoding (handler-case (format nil "~a" (stream-external-format writer))
- (error () (format nil "~a" *default-encoding*))))
+ (let* ((jsonp (page-json-id-list page))
+ (encoding (page-encoding page))
(xml-p (page-xmloutput page))
- (content-type (page-doc-type page)))
+ (doc-type (page-doc-type page)))
(when (null jsonp)
(when xml-p
- (page-format-raw page "<?xml version=\"1.0\" encoding=\"~a\"?>~%" encoding))
- (when content-type
- (page-format-raw page "~a~%" content-type)))))
+ (page-format-raw page "<?xml version=\"1.0\" encoding=\"~a\"?>~%" encoding))
+ (when doc-type
+ (page-format-raw page "~a~%" doc-type)))))
(defun json-validation-errors ()
"Composes the error part for the json reply"
@@ -609,7 +611,8 @@
(defmethod page-render ((page page))
(let ((body (page-content page))
(jsonp (page-json-id-list page)))
- (setf (hunchentoot:content-type) (page-content-type page))
+ (setf (reply-external-format)
+ (flexi-streams:make-external-format (page-encoding page) :eol-style :lf))
(if (null body)
(format nil "null body for page ~a~%" (type-of page))
(progn
@@ -874,7 +877,11 @@
(let ((body-list (htcomponent-body hthead))
(injections (page-init-injections page)))
(tag-render-starttag hthead page)
- (htcomponent-render (meta> :http-equiv "Content-Type" :content (page-content-type page)) page)
+ (htcomponent-render (meta> :http-equiv "Content-Type"
+ :content (format nil "~a;charset=~a"
+ (page-mime-type page)
+ (page-encoding page)))
+ page)
(dolist (child-tag body-list)
(when child-tag
(cond
@@ -1072,8 +1079,11 @@
(defun make-component (name parameters content)
"This function instantiates a wcomponent by the passed NAME, separetes parameters into formal(the ones that are the
initarg of a slot, and informal parameters, that have their own slot in common. The CONTENT is the body content."
- (let ((instance (make-instance name))
- (static-id (getf parameters :static-id)))
+ (let* ((instance (make-instance name))
+ (id (getf parameters :id))
+ (static-id (getf parameters :static-id))
+ (real-id (or static-id id)))
+ (setf (htcomponent-real-id instance) real-id)
(when static-id
(remf parameters :id))
(loop for (initarg value) on parameters by #'cddr
Modified: trunk/main/claw-core/src/translators.lisp
==============================================================================
--- trunk/main/claw-core/src/translators.lisp (original)
+++ trunk/main/claw-core/src/translators.lisp Fri May 30 06:03:00 2008
@@ -29,28 +29,45 @@
(in-package :claw)
+(defmethod translator-value-encode ((translator translator) value)
+ (format nil "~a" value))
+
+(defmethod translator-value-type-to-string ((translator translator) value)
+ (translator-value-encode translator value))
+
(defmethod translator-encode ((translator translator) (wcomponent cinput))
- (let ((page (htcomponent-page wcomponent))
- (visit-object (cinput-visit-object wcomponent))
- (accessor (cinput-accessor wcomponent))
- (reader (cinput-reader wcomponent)))
- (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)))))))
+ (let* ((page (htcomponent-page wcomponent))
+ (visit-object (or (cinput-visit-object wcomponent) page))
+ (accessor (cinput-accessor wcomponent))
+ (reader (cinput-reader wcomponent))
+ (value (page-req-parameter page (name-attr wcomponent) nil)))
+ (if (component-validation-errors wcomponent)
+ value
+ (progn
+ (setf value (cond
+ ((and (null reader) accessor) (funcall (fdefinition accessor) visit-object))
+ (t (funcall (fdefinition reader) visit-object))))
+ (translator-value-encode translator value)))))
+
+(defmethod translator-type-to-string ((translator translator) (wcomponent cinput))
+ (translator-encode translator wcomponent))
+
+(defmethod translator-value-decode ((translator translator) value &optional client-id label)
+ (declare (ignore client-id label))
+ value)
+
+(defmethod translator-value-string-to-type ((translator translator) value &optional client-id label)
+ (translator-value-decode translator value client-id label))
(defmethod translator-decode ((translator translator) (wcomponent wcomponent))
- (multiple-value-bind (client-id new-value)
+ (multiple-value-bind (client-id value)
(component-id-and-value wcomponent)
- (declare (ignore client-id))
- new-value))
+ (translator-value-decode translator value client-id (label wcomponent))))
-(setf *simple-translator* (make-instance 'translator))
+(defmethod translator-string-to-type ((translator translator) (wcomponent wcomponent))
+ (translator-decode translator wcomponent))
+(setf *simple-translator* (make-instance 'translator))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;; Integer translator ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -58,56 +75,43 @@
(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
+ :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.")
+ :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"))
+ :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 cinput))
- (let* ((page (htcomponent-page wcomponent))
- (visit-object (or (cinput-visit-object wcomponent) page))
- (accessor (cinput-accessor wcomponent))
- (reader (cinput-reader wcomponent))
- (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
- (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-value-encode ((translator translator-integer) value)
+ (let* ((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))))
+ (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))
+(defmethod translator-value-decode ((translator translator-integer) value &optional client-id label)
(let ((thousand-separator (translator-thousand-separator translator)))
- (multiple-value-bind (client-id value)
- (component-id-and-value wcomponent)
- (handler-case
- (if thousand-separator
- (parse-integer (regex-replace-all (format nil "~a" thousand-separator) value ""))
- (parse-integer value))
- (error () (progn
- (add-exception client-id (format nil (do-message "VALIDATE-INTEGER" "Field ~a is not a valid integer.") (label wcomponent)))
- value))))))
+ (handler-case
+ (if thousand-separator
+ (parse-integer (regex-replace-all (format nil "~a" thousand-separator) value ""))
+ (parse-integer value))
+ (error () (progn
+ (when label
+ (add-exception client-id (format nil (do-message "VALIDATE-INTEGER" "Field ~a is not a valid integer.") label)))
+ value)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;Folating point number translator ;;;;;;;;;;;;;;;;
@@ -115,79 +119,67 @@
(defclass translator-number (translator-integer)
((decimals-separator :initarg :decimals-separator
- :reader translator-decimals-separator
- :documentation "The decimal separator of the rendered number. Default to #\.")
+ :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")
+ :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"))
+ :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)
+ ;: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 cinput))
- (let* ((page (htcomponent-page wcomponent))
- (visit-object (or (cinput-visit-object wcomponent) page))
- (accessor (cinput-accessor wcomponent))
- (reader (cinput-reader wcomponent))
- (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
- (multiple-value-bind (int-value dec-value)
- (floor (cond
- ((and (null reader) accessor) (funcall (fdefinition accessor) visit-object))
- (t (funcall (fdefinition reader) visit-object))))
- (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-value-encode ((translator translator-number) value)
+ (let* ((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))))
+ (multiple-value-bind (int-value dec-value)
+ (floor value)
+ (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))
+(defmethod translator-value-decode ((translator translator-number) value &optional client-id label)
(let ((thousand-separator (translator-thousand-separator translator))
- (type (translator-coerce translator))
- (new-value))
- (multiple-value-bind (client-id value)
- (component-id-and-value wcomponent)
- (if thousand-separator
- (setf new-value (regex-replace-all (format nil "~a" thousand-separator) value ""))
- (setf new-value value))
- (handler-case
- (let* ((decomposed-string (all-matches-as-strings "[0-9]+" new-value))
- (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)))
- (error () (progn
- (add-exception client-id (format nil (do-message "VALIDATE-NUMBER" "Field ~a is not a valid number.") (label wcomponent)))
- value))))))
-
+ (type (translator-coerce translator))
+ (new-value))
+ (if thousand-separator
+ (setf new-value (regex-replace-all (format nil "~a" thousand-separator) value ""))
+ (setf new-value value))
+ (handler-case
+ (let* ((decomposed-string (all-matches-as-strings "[0-9]+" new-value))
+ (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)))
+ (error () (progn
+ (when label
+ (add-exception client-id (format nil (do-message "VALIDATE-NUMBER" "Field ~a is not a valid number.") label)))
+ value)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;; Dates translator ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -195,8 +187,8 @@
(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
+ :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.
@@ -206,76 +198,74 @@
-(defmethod translator-encode ((translator translator-date) (wcomponent cinput))
- (let* ((page (htcomponent-page wcomponent))
- (visit-object (or (cinput-visit-object wcomponent) page))
- (accessor (cinput-accessor wcomponent))
- (reader (cinput-reader wcomponent))
- (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
- (setf value (cond
- ((and (null reader) accessor) (funcall (fdefinition accessor) visit-object))
- (t (funcall (fdefinition reader) visit-object))))
- (if (and value (not (stringp value)))
- (local-time-to-string value local-time-format)
- value)))))
+(defmethod translator-value-encode ((translator translator-date) value)
+ (let* ((local-time-format (translator-local-time-format translator)))
+ (if (and value (not (stringp value)))
+ (local-time-to-string value local-time-format)
+ value)))
-(defmethod translator-decode ((translator translator-date) (wcomponent wcomponent))
+(defmethod translator-value-decode ((translator translator-date) value &optional client-id label)
(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 "VALIDATE-DATE" "Field ~a is not a valid date or wrong format: ~a")
- (label wcomponent)
- old-value))
- (if (component-validation-errors wcomponent)
- old-value
- (encode-local-time 0 sec min hour day month year))))))
+ (sec 0)
+ (min 0)
+ (hour 0)
+ (day 0)
+ (month 0)
+ (year 0)
+ (old-value))
+ (when (and value (string-not-equal value ""))
+ (setf old-value value)
+ (loop for element in date-format
+ do (if (stringp element)
+ (setf value (subseq value (length element)))
+ (ccase element
+ (:second (multiple-value-bind (curr-value size)
+ (parse-integer value :junk-allowed t)
+ (setf value (subseq value size))
+ (setf sec curr-value)))
+ (:minute (multiple-value-bind (curr-value size)
+ (parse-integer value :junk-allowed t)
+ (setf value (subseq value size))
+ (setf min curr-value)))
+ (:hour (multiple-value-bind (curr-value size)
+ (parse-integer value :junk-allowed t)
+ (setf value (subseq value size))
+ (setf hour curr-value)))
+ (:date (multiple-value-bind (curr-value size)
+ (parse-integer value :junk-allowed t)
+ (setf value (subseq value size))
+ (setf day curr-value)))
+ (:month (multiple-value-bind (curr-value size)
+ (parse-integer value :junk-allowed t)
+ (setf value (subseq value size))
+ (setf month curr-value)))
+ (:year (multiple-value-bind (curr-value size)
+ (parse-integer value :junk-allowed t)
+ (setf value (subseq value size))
+ (setf year curr-value))))))
+ (if (and (string-equal value "")
+ (>= sec 0)
+ (>= min 0)
+ (>= hour 0)
+ (and (> month 0) (<= month 12))
+ (and (> day 0) (<= day (days-in-month month year))))
+ (encode-local-time 0 sec min hour day month year)
+ (progn
+ (when label
+ (add-exception client-id (format nil (do-message "VALIDATE-DATE" "Field ~a is not a valid date or wrong format: ~a") label old-value)))
+ value)))))
+
+
+(defclass translator-boolean (translator)
+ ()
+ (:documentation "a translator object encodes and decodes boolean values passed to a html input component"))
+
+(defmethod translator-value-encode ((translator translator-boolean) value)
+ (format nil "~a" value))
+
+(defmethod translator-value-decode ((translator translator-boolean) value &optional client-id label)
+ (if (string-equal value "NIL")
+ nil
+ t))
+(defvar *boolean-translator* (make-instance 'translator-boolean))
\ No newline at end of file
Modified: trunk/main/claw-core/src/validators.lisp
==============================================================================
--- trunk/main/claw-core/src/validators.lisp (original)
+++ trunk/main/claw-core/src/validators.lisp Fri May 30 06:03:00 2008
@@ -53,14 +53,14 @@
(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 (validation-errors))
- (symbol-id (make-symbol id))
+ (symbol-id (intern id))
(errors (getf validation-errors symbol-id)))
(setf (getf validation-errors symbol-id) (nconc errors (list reason))
(validation-errors *request*) validation-errors)))
(defun component-exceptions (id)
"Returns a list of exception connectd to the given component"
- (let ((symbol-id (make-symbol id)))
+ (let ((symbol-id (intern id)))
(getf (validation-errors) symbol-id)))
(defun validate (test &key component message)
@@ -70,15 +70,15 @@
(add-validation-compliance client-id)
(add-exception client-id message))))
-(defun validate-required (component value)
+(defun validate-required (component value &key message)
"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."
(when (stringp value)
(validate (and value (string-not-equal value ""))
:component component
- :message (format nil (do-message "VALIDATE-REQUIRED" "Field ~a may not be empty.") (label component)))))
+ :message (or message (format nil (do-message "VALIDATE-REQUIRED" "Field ~a may not be empty.") (label component))))))
-(defun validate-size (component value &key min-size max-size)
+(defun validate-size (component value &key min-size max-size message-low message-hi)
"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.
@@ -92,17 +92,17 @@
(when min-size
(validate (>= value-len min-size)
:component component
- :message (format nil (do-message "VALIDATE-SIZE-MIN" "Size of ~a may not be less then ~a chars." )
- (label component)
- min-size)))
+ :message (or message-low (format nil (do-message "VALIDATE-SIZE-MIN" "Size of ~a may not be less then ~a chars." )
+ (label component)
+ min-size))))
(when max-size
(validate (<= value-len max-size)
:component component
- :message (format nil (do-message "VALIDATE-SIZE-MAX" "Size of ~a may not be more then ~a chars." )
+ :message (or message-hi (format nil (do-message "VALIDATE-SIZE-MAX" "Size of ~a may not be more then ~a chars." )
(label component)
- max-size)))))))
+ max-size))))))))
-(defun validate-range (component value &key min max)
+(defun validate-range (component value &key min max message-low message-hi)
"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.
@@ -112,21 +112,21 @@
(and (when min
(validate (>= value min)
:component component
- :message (format nil (do-message "VALIDATE-RANGE-MIN" "Field ~a is not greater then or equal to ~d")
- (label component)
- (if (typep min 'ratio)
- (coerce min 'float)
- min))))
+ :message (or message-low (format nil (do-message "VALIDATE-RANGE-MIN" "Field ~a is not greater then or equal to ~d")
+ (label component)
+ (if (typep min 'ratio)
+ (coerce min 'float)
+ min)))))
(when max
(validate (<= value max)
:component component
- :message (format nil (do-message "VALIDATE-RANGE-MAX" "Field ~a is not less then or equal to ~d")
- (label component)
- (if (typep max 'ratio)
- (coerce max 'float)
- max)))))))
+ :message (or message-hi (format nil (do-message "VALIDATE-RANGE-MAX" "Field ~a is not less then or equal to ~d")
+ (label component)
+ (if (typep max 'ratio)
+ (coerce max 'float)
+ max))))))))
-(defun validate-number (component value &key min max)
+(defun validate-number (component value &key min max message-nan message-low message-hi)
"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."
@@ -134,10 +134,10 @@
(let ((test (numberp value)))
(and (validate test
:component component
- :message (format nil (do-message "VALIDATE-NUMBER" "Field ~a is not a valid number.") (label component)))
- (validate-range component value :min min :max max)))))
+ :message (or message-nan (format nil (do-message "VALIDATE-NUMBER" "Field ~a is not a valid number.") (label component))))
+ (validate-range component value :min min :max max :message-low message-low :message-hi message-hi)))))
-(defun validate-integer (component value &key min max)
+(defun validate-integer (component value &key min max message-nan message-low message-hi)
"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."
@@ -145,11 +145,11 @@
(let ((test (integerp value)))
(and (validate test
:component component
- :message (format nil (do-message "VALIDATE-INTEGER" "Field ~a is not a valid integer.") (label component)))
- (validate-range component value :min min :max max)))))
+ :message (or message-nan (format nil (do-message "VALIDATE-INTEGER" "Field ~a is not a valid integer.") (label component))))
+ (validate-range component value :min min :max max :message-low message-low :message-hi message-hi)))))
-(defun validate-date-range (component value &key min max (use-date-p t) use-time-p)
+(defun validate-date-range (component value &key min max (use-date-p t) use-time-p message-low message-hi)
"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.
@@ -183,15 +183,15 @@
(and (when min
(validate (local-time> new-value min)
:component component
- :message (format nil (do-message "VALIDATE-DATE-RANGE-MIN" "Field ~a is less then ~a.")
- (label component)
- (local-time-to-string min local-time-format))))
+ :message (or message-low (format nil (do-message "VALIDATE-DATE-RANGE-MIN" "Field ~a is less then ~a.")
+ (label component)
+ (local-time-to-string min local-time-format)))))
(when max
(validate (local-time< new-value max)
:component component
- :message (format nil (do-message "VALIDATE-DATE-RANGE-MAX" "Field ~a is greater then ~a.")
- (label component)
- (local-time-to-string max local-time-format))))))))
+ :message (or message-hi (format nil (do-message "VALIDATE-DATE-RANGE-MAX" "Field ~a is greater then ~a.")
+ (label component)
+ (local-time-to-string max local-time-format)))))))))
@@ -213,16 +213,16 @@
(defmethod wcomponent-template ((exception-monitor exception-monitor))
(let ((client-id (htcomponent-client-id exception-monitor))
(validation-errors (validation-errors))
- (body (htcomponent-body exception-monitor)))
+ (body (htcomponent-body exception-monitor)))
(div> :static-id client-id
(wcomponent-informal-parameters exception-monitor)
(when validation-errors
(if body
body
- (ul>
- (loop for component-exceptions in (rest validation-errors) by #'cddr
- do (loop for message in component-exceptions
- collect (li> message)))))))))
+ (ul> :id "errors"
+ (loop for (client-id component-exceptions) on validation-errors by #'cddr
+ collect (loop for message in component-exceptions
+ collect (li> message)))))))))
;;-------------------------------------------------------------------------------------------
Modified: trunk/main/claw-core/tests/test1.lisp
==============================================================================
--- trunk/main/claw-core/tests/test1.lisp (original)
+++ trunk/main/claw-core/tests/test1.lisp Fri May 30 06:03:00 2008
@@ -46,10 +46,15 @@
(simple-message-dispatcher-add-message *lisplet-messages* "en" "NAME" "Name")
(simple-message-dispatcher-add-message *lisplet-messages* "en" "SURNAME" "Surname")
(simple-message-dispatcher-add-message *lisplet-messages* "en" "WELCOME" "Welcome")
+(simple-message-dispatcher-add-message *lisplet-messages* "en" "AGREE" "Agree")
+(simple-message-dispatcher-add-message *lisplet-messages* "en" "SURE" "Are you sure?")
+(simple-message-dispatcher-add-message *lisplet-messages* "it" "YES" "sì")
(simple-message-dispatcher-add-message *lisplet-messages* "it" "NAME" "Nome")
(simple-message-dispatcher-add-message *lisplet-messages* "it" "SURNAME" "Cognome")
(simple-message-dispatcher-add-message *lisplet-messages* "it" "WELCOME" "Benvenuto")
+(simple-message-dispatcher-add-message *lisplet-messages* "it" "SURE" "Sei sicuro?")
+(simple-message-dispatcher-add-message *lisplet-messages* "it" "SURE-ERROR-MESSAGE" "Devi essere sicuro")
(simple-message-dispatcher-add-message *lisplet-messages* "it" "VALIDATE-REQUIRED" "Il campo ~a non può essere vuoto!")
@@ -120,7 +125,7 @@
(title>
(title o))
(style> :type "text/css"
- "input.error {
+ "input.error, div.error {
background-color: #FF9999;
}
"))
@@ -331,9 +336,13 @@
:accessor user-gender)
(age :initarg :age
:accessor user-age)
+ (agree :initarg :agree
+ :accessor user-agree)
+ (sure :initarg :sure
+ :accessor user-sure)
(capital :initarg :capital
:accessor user-capital))
- (:default-initargs :name "" :surname "" :gender "" :age "" :capital 0.0))
+ (:default-initargs :name "" :surname "" :gender "" :age "" :capital 0.0 :sure "" :agree ""))
(defgeneric form-page-update-user (form-page))
@@ -351,11 +360,14 @@
:accessor form-page-user)
(age :initarg :age
:accessor form-page-age)
+ (agree :initarg :agree
+ :accessor form-page-agree)
+ (sure :initarg :sure
+ :accessor form-page-sure)
(capital :initarg :capital
:accessor form-page-capital)
(birthday :initarg :birthday
- :accessor form-page-birthday))
-
+ :accessor form-page-birthday))
(:default-initargs :name "kiuma"
:surname "surnk"
:colors nil
@@ -364,6 +376,8 @@
:capital 500055/100
:birthday (now)
:message-dispatcher *lisplet-messages*
+ :agree t
+ :sure "yes"
:user (make-instance 'user)))
(defmethod form-page-update-user ((form-page form-page))
@@ -371,113 +385,149 @@
(name (form-page-name form-page))
(surname (form-page-surname form-page))
(gender (form-page-gender form-page))
- (age (form-page-age form-page)))
+ (age (form-page-age form-page))
+ (agree (form-page-agree form-page))
+ (sure (form-page-sure form-page)))
(setf (user-name user) name
(user-surname user) surname
(user-gender user) gender
- (user-age user) age)))
+ (user-age user) age
+ (user-agree user) agree
+ (user-sure user) sure)))
+
- ;(defmethod message-dispatch ((object form-page) key locale)
+(defun validate-agree (component value)
+ (declare (ignore value))
+ (validate nil
+ :component component
+ :message (do-message "SURE-ERROR-MESSAGE" "You must be sure")))
-(defmethod page-content ((o form-page))
- (site-template> :title "a page title"
- (cform> :id "testform" :method "post" :action #'form-page-update-user
- (table>
- (tr>
- (td> "Name")
- (td>
- (cinput> :id "name"
- :type "text"
- :label "Name"
- :validator #'(lambda (value)
- (validate-required (page-current-component o) value))
- :accessor 'form-page-name)"*"))
- (tr> :id "messaged"
- (td> (with-message "SURNAME" "SURNAME"))
- (td>
- (cinput> :id "surname"
- :type "text"
- :label "Surname"
- :validator #'(lambda (value)
- (validate-required (page-current-component o) value)
- (validate-size (page-current-component o) value :min-size 1 :max-size 20))
- :accessor 'form-page-surname)"*"))
- (tr>
- (td> "Gender")
- (td>
- (cselect> :id "gender"
- :accessor 'form-page-gender
- (loop for gender in (list "M" "F")
- collect (option> :value gender
- (when (string= gender (form-page-gender o))
- '(:selected "selected"))
- (if (string= gender "M")
- "Male"
- "Female"))))))
- (tr>
- (td> "Age")
- (td>
- (cinput> :id "age"
- :type "text"
- :label "Age"
- :translator (make-instance 'translator-integer :thousand-separator #\')
- :validator #'(lambda (value)
- (let ((component (page-current-component o)))
- (validate-required component value)
- (validate-integer component value :min 1 :max 2000)))
- :accessor 'form-page-age)"*"))
- (tr>
- (td> "Birthday")
- (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)))
- (validate-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"
- :type "text"
- :label "Capital"
- :translator (make-instance 'translator-number
- :decimal-digits 2
- :thousand-separator #\')
- :validator #'(lambda (value)
- (let ((component (page-current-component o)))
- (validate-required component value)
- (validate-number component value :min 1000.01 :max 500099/100)))
- :accessor 'form-page-capital)"*"))
- (tr>
- (td> "Colors")
- (td>
- (cselect> :id "colors"
- :multiple "true"
- :style "width:80px;height:120px;"
- :accessor 'form-page-colors
- (loop for color in (list "R" "G" "B")
- collect (option> :value color
- (when (find color (form-page-colors o) :test #'string=)
- '(:selected "selected"))
- (cond
- ((string= color "R") "red")
- ((string= color "G") "green")
- (t "blue")))))))
- (tr>
- (td> :colspan "2"
- (csubmit> :id "submit" :value "OK")))))
- (p>
- (exception-monitor>)
- (hr>)
- (h2> "From result:")
- (div> (format nil "Name: ~a" (user-name (form-page-user o))))
- (div> (format nil "Surname: ~a" (user-surname (form-page-user o))))
- (div> (format nil "Gender: ~a" (user-gender (form-page-user o))))
- (div> (format nil "Age: ~a" (user-age (form-page-user o)))))))
+(defmethod page-content ((o form-page))
+ (let ((user (form-page-user o)))
+ (site-template> :title "a page title"
+ (cform> :id "testform" :method "post" :action #'form-page-update-user
+ (table>
+ (tr>
+ (td> "Name")
+ (td>
+ (cinput> :id "name"
+ :type "text"
+ :label "Name"
+ :validator #'(lambda (value)
+ (validate-required (page-current-component o) value))
+ :accessor 'form-page-name)"*"))
+ (tr> :id "messaged"
+ (td> (with-message "SURNAME" "SURNAME"))
+ (td>
+ (cinput> :id "surname"
+ :type "text"
+ :label "Surname"
+ :validator #'(lambda (value)
+ (validate-required (page-current-component o) value)
+ (validate-size (page-current-component o) value :min-size 1 :max-size 20))
+ :accessor 'form-page-surname)"*"))
+ (tr> :id "agree"
+ (td> (with-message "AGREE" "AGREE"))
+ (td>
+ (ccheckbox> :id "agree"
+ :label (with-message "AGREE" "AGREE")
+ :validator #'(lambda (value)
+ (validate-required (page-current-component o) value))
+ :accessor 'form-page-agree
+ :value t)"*"))
+ (tr> :id "sure"
+ (td> (with-message "SURE" "SURE"))
+ (td>
+ (cradio> :id "sure"
+ :label (with-message "SURE" "SURE")
+ :accessor 'form-page-sure
+ :value "yes")
+ (span> :style "margin-right:1.5em;" (with-message "YES" "yes"))
+ (cradio> :id "sure"
+ :label (with-message "SURE" "SURE")
+ :validator #'(lambda (value)
+ (validate-agree (page-current-component o) value))
+ :accessor 'form-page-sure
+ :value "no")
+ (span> :style "margin-right:1.5em;" (with-message "NO" "no"))))
+ (tr>
+ (td> "Gender")
+ (td>
+ (cselect> :id "gender"
+ :accessor 'form-page-gender
+ (loop for gender in (list "M" "F")
+ collect (option> :value gender
+ (when (string= gender (form-page-gender o))
+ '(:selected "selected"))
+ (if (string= gender "M")
+ "Male"
+ "Female"))))))
+ (tr>
+ (td> "Age")
+ (td>
+ (cinput> :id "age"
+ :type "text"
+ :label "Age"
+ :translator (make-instance 'translator-integer :thousand-separator #\')
+ :validator #'(lambda (value)
+ (let ((component (page-current-component o)))
+ (validate-required component value)
+ (validate-integer component value :min 1 :max 2000)))
+ :accessor 'form-page-age)"*"))
+ (tr>
+ (td> "Birthday")
+ (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)))
+ (validate-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"
+ :type "text"
+ :label "Capital"
+ :translator (make-instance 'translator-number
+ :decimal-digits 2
+ :thousand-separator #\')
+ :validator #'(lambda (value)
+ (let ((component (page-current-component o)))
+ (validate-required component value)
+ (validate-number component value :min 1000.01 :max 500099/100)))
+ :accessor 'form-page-capital)"*"))
+ (tr>
+ (td> "Colors")
+ (td>
+ (cselect> :id "colors"
+ :multiple "true"
+ :style "width:80px;height:120px;"
+ :accessor 'form-page-colors
+ (loop for color in (list "R" "G" "B")
+ collect (option> :value color
+ (when (find color (form-page-colors o) :test #'string=)
+ '(:selected "selected"))
+ (cond
+ ((string= color "R") "red")
+ ((string= color "G") "green")
+ (t "blue")))))))
+ (tr>
+ (td> :colspan "2"
+ (csubmit> :id "submit" :value "OK")))))
+ (p>
+ (exception-monitor> :class "error")
+ (hr>)
+ (h2> "From result:")
+ (div> (format nil "Name: ~a" (user-name user)))
+ (div> (format nil "Surname: ~a" (user-surname user)))
+ (div> (format nil "Gender: ~a" (user-gender user)))
+ (div> (format nil "Age: ~a" (user-age user)))
+ (div> (format nil "Agree: ~a" (user-agree user)))
+ (div> (format nil "Sure: ~a" (user-sure user)))))))
(lisplet-register-page-location *test-lisplet* 'form-page "form.html")
More information about the Claw-cvs
mailing list