[claw-cvs] r14 - in trunk/main/claw-core: . src tests
achiumenti at common-lisp.net
achiumenti at common-lisp.net
Wed Mar 12 10:26:41 UTC 2008
Author: achiumenti
Date: Wed Mar 12 05:26:40 2008
New Revision: 14
Added:
trunk/main/claw-core/src/validators.lisp
Modified:
trunk/main/claw-core/claw.asd
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/tests/test1.lisp
Log:
beginning of translators and i18n support
Modified: trunk/main/claw-core/claw.asd
==============================================================================
--- trunk/main/claw-core/claw.asd (original)
+++ trunk/main/claw-core/claw.asd Wed Mar 12 05:26:40 2008
@@ -37,6 +37,7 @@
(:file "misc" :depends-on ("packages"))
(:file "hunchentoot-overrides" :depends-on ("packages"))
(:file "tags" :depends-on ("misc"))
- (:file "components" :depends-on ("tags"))
- (:file "lisplet" :depends-on ("components"))
+ (:file "validators" :depends-on ("tags"))
+ (:file "components" :depends-on ("tags" "validators"))
+ (:file "lisplet" :depends-on ("components"))
(:file "server" :depends-on ("lisplet"))))))
Modified: trunk/main/claw-core/src/components.lisp
==============================================================================
--- trunk/main/claw-core/src/components.lisp (original)
+++ trunk/main/claw-core/src/components.lisp Wed Mar 12 05:26:40 2008
@@ -52,10 +52,6 @@
(defmethod wcomponent-template((cform cform))
(let ((client-id (htcomponent-client-id cform))
(class (wcomponent-parameter-value cform :class)))
- (when (null client-id)
- (setf client-id ""))
- (when (null class)
- (setf class ""))
(form> :static-id client-id
:name client-id
:class class
@@ -111,6 +107,7 @@
:validator-handler nil
:class nil
:label nil
+ :translator *simple-translator*
:validator nil
:type :required))
@@ -118,26 +115,16 @@
'(:value :name))
(defmethod wcomponent-template ((cinput cinput))
- (let* ((client-id (htcomponent-client-id cinput))
+ (let ((client-id (htcomponent-client-id cinput))
(type (wcomponent-parameter-value cinput :type))
- (visit-object (wcomponent-parameter-value cinput :visit-object))
- (accessor (wcomponent-parameter-value cinput :accessor))
- (reader (wcomponent-parameter-value cinput :reader))
- (class (wcomponent-parameter-value cinput :class))
- (value "")
- (validation-errors (aux-request-value :validation-errors))
- (component-exceptions (assoc client-id validation-errors :test #'equal)))
- (when (null visit-object)
- (setf visit-object (htcomponent-page cinput)))
- (when (null class)
- (setf class ""))
- (when component-exceptions
- (if (string= class "")
+ (class (wcomponent-parameter-value cinput :class))
+ (translator (wcomponent-parameter-value cinput :translator))
+ (value ""))
+ (when (component-validation-errors cinput)
+ (if (or (null class) (string= class ""))
(setf class "error")
(setf class (format nil "~a error" class))))
- (if (and (null reader) accessor)
- (setf value (funcall (fdefinition accessor) visit-object))
- (setf value (funcall (fdefinition reader) visit-object)))
+ (setf value (translator-encode translator cinput))
(input> :static-id client-id
:type type
:name client-id
@@ -145,22 +132,28 @@
:value value
(wcomponent-informal-parameters cinput))))
-(defmethod wcomponent-after-rewind ((obj cinput) (pobj page))
- (let ((visit-object (wcomponent-parameter-value obj :visit-object))
- (accessor (wcomponent-parameter-value obj :accessor))
- (writer (wcomponent-parameter-value obj :writer))
- (validator (wcomponent-parameter-value obj :validator))
- (new-value (page-req-parameter pobj
- (htcomponent-client-id obj)
- (cinput-result-as-list obj))))
- (unless (null new-value)
- (when (null visit-object)
- (setf visit-object (htcomponent-page obj)))
- (if (and (null writer) accessor)
- (funcall (fdefinition `(setf ,accessor)) new-value visit-object)
- (funcall (fdefinition writer) new-value visit-object))
- (when validator
- (funcall validator)))))
+(defmethod wcomponent-after-rewind ((cinput cinput) (page page))
+ (let ((visit-object (wcomponent-parameter-value cinput :visit-object))
+ (accessor (wcomponent-parameter-value cinput :accessor))
+ (writer (wcomponent-parameter-value cinput :writer))
+ (validator (wcomponent-parameter-value cinput :validator))
+ (translator (wcomponent-parameter-value cinput :translator))
+ (value))
+ (multiple-value-bind (client-id request-value)
+ (component-id-and-value cinput)
+ (setf value
+ (handler-case
+ (translator-decode translator cinput)
+ (error () request-value)))
+ (unless (null value)
+ (when validator
+ (funcall validator value))
+ (unless (component-validation-errors cinput)
+ (when (null visit-object)
+ (setf visit-object page))
+ (if (and (null writer) accessor)
+ (funcall (fdefinition `(setf ,accessor)) value visit-object)
+ (funcall (fdefinition writer) value visit-object)))))))
;---------------------------------------------------------------------------------------
(defcomponent csubmit () ()
@@ -236,54 +229,5 @@
(htcomponent-body obj))))
-(defun component-id-and-value (component)
- (let ((client-id (htcomponent-client-id component))
- (visit-object (wcomponent-parameter-value component :visit-object))
- (accessor (wcomponent-parameter-value component :accessor))
- (reader (wcomponent-parameter-value component :reader))
- (value ""))
- (when (null visit-object)
- (setf visit-object (htcomponent-page component)))
- (if (and (null reader) accessor)
- (setf value (funcall (fdefinition accessor) visit-object))
- (setf value (funcall (fdefinition reader) visit-object)))
- (values client-id value)))
-
-(defun add-exception (id reason)
- (let* ((validation-errors (aux-request-value :validation-errors))
- (component-exceptions (assoc id validation-errors :test #'equal)))
- (if component-exceptions
- (push reason (cdr component-exceptions))
- (push (cons id (list reason))
- (aux-request-value :validation-errors)))))
-
-(defun validator-required (component)
- (multiple-value-bind (client-id value)
- (component-id-and-value component)
- (when (or (null value) (string= value ""))
- (add-exception client-id
- (format nil "Field ~a may not be null." (wcomponent-parameter-value component :label))))))
-;; ------------------------------------------------------------------------------------
-(defcomponent exce (cinput) ()
- (:default-initargs :result-as-list t)
- (:documentation "This component renders as a normal SELECT tag class,
-but it is request cycle aware."))
-(defmethod wcomponent-parameters :around ((obj cselect))
- (declare (ignore obj))
- (let ((params (call-next-method)))
- (remf params :reader)
- (remf params :type)
- params))
-
-(defmethod wcomponent-reserved-parameters ((obj cselect))
- (declare (ignore obj))
- '(:type :name))
-
-(defmethod wcomponent-template ((obj cselect))
- (let ((client-id (htcomponent-client-id obj)))
- (select> :static-id client-id
- :name client-id
- (wcomponent-informal-parameters obj)
- (htcomponent-body obj))))
\ No newline at end of file
Modified: trunk/main/claw-core/src/lisplet.lisp
==============================================================================
--- trunk/main/claw-core/src/lisplet.lisp (original)
+++ trunk/main/claw-core/src/lisplet.lisp Wed Mar 12 05:26:40 2008
@@ -95,11 +95,7 @@
:error-code error-code)))
(with-output-to-string (*standard-output*) (page-render error-page)))))))
-(defun lisplet-start-session ()
- "Starts a session boud to the current lisplet base path"
- (start-session (format nil "~@[~a~]~a/" *clawserver-base-path* (lisplet-base-path (current-lisplet)))))
-
-(defclass lisplet ()
+(defclass lisplet (i18n-aware)
((base-path :initarg :base-path
:reader lisplet-base-path
:documentation "common base path all resources registered into this lisplet")
@@ -123,7 +119,7 @@
:documentation "A collection of cons where the car is the protected url location and the cdr is a string list of roles allowhed to access the relative location")
(redirect-protected-resources-p :initarg :redirect-protected-resources-p
:accessor lisplet-redirect-protected-resources-p
- :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"))
+ :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
:realm "claw"
@@ -196,8 +192,10 @@
(uri (request-uri))
(welcome-page (lisplet-welcome-page lisplet)))
(progn
- (setf (aux-request-value 'lisplet) lisplet)
- (setf (aux-request-value 'realm) (lisplet-realm lisplet))
+ ;;(setf (aux-request-value 'lisplet) lisplet)
+ (setf (current-lisplet) lisplet)
+ ;;(setf (aux-request-value 'realm) (lisplet-realm lisplet))
+ (setf (current-realm) (lisplet-realm lisplet))
(lisplet-check-authorization lisplet)
(when (= (return-code) +http-ok+)
(if (and welcome-page (string= uri base-path))
@@ -263,6 +261,6 @@
(format nil "Basic realm=\"~A\"" (hunchentoot::quote-string (current-realm)))))
(setf (return-code) +http-authorization-required+)
(throw 'handler-done nil))
- (unless (user-in-role-p)
+ (unless (user-in-role-p allowed-roles)
(setf (return-code) +http-forbidden+)
(throw 'handler-done nil))))))))
Modified: trunk/main/claw-core/src/misc.lisp
==============================================================================
--- trunk/main/claw-core/src/misc.lisp (original)
+++ trunk/main/claw-core/src/misc.lisp Wed Mar 12 05:26:40 2008
@@ -29,6 +29,8 @@
(in-package :claw)
+(defvar *clawserver-base-path* nil)
+
(defvar *apache-http-port* 80
"Default apache http port when claw is running in mod_lisp mode")
(defvar *apache-https-port* 443
@@ -71,25 +73,56 @@
(let ((result (remove-by-location (car location-cons) cons-list)))
(setf result (push location-cons cons-list))))
+(defun lisplet-start-session ()
+ "Starts a session boud to the current lisplet base path"
+ (start-session (format nil "~@[~a~]~a/" *clawserver-base-path* (lisplet-base-path (current-lisplet)))))
+
+
+(defun current-page (&optional (request *request*))
+ "Returns the page that is rendering"
+ (aux-request-value 'page request))
+
+(defun (setf current-page) (page &optional (request *request*))
+ "Setf the page that is to be rendered"
+ (setf (aux-request-value 'page request) page))
+
(defun current-realm (&optional (request *request*))
"Returns the realm under which the request has been sent"
(aux-request-value 'realm request))
+(defun (setf current-realm) (realm &optional (request *request*))
+ "Setf the realm under which the request has been sent"
+ (setf (aux-request-value 'realm request) realm))
+
(defun current-lisplet (&optional (request *request*))
"Returns the lisplet instance from which the request comes from"
(aux-request-value 'lisplet request))
+(defun (setf current-lisplet) (lisplet &optional (request *request*))
+ "Sets the lisplet instance from which the request comes from"
+ (setf (aux-request-value 'lisplet request) lisplet))
+
(defun current-server (&optional (request *request*))
"Returns the clawserver instance from which the request comes from"
(aux-request-value 'clawserver request))
+(defun (setf current-server) (server &optional (request *request*))
+ "Sets the clawserver instance from which the request comes from"
+ (setf (aux-request-value 'clawserver request) server))
+
(defun current-principal (&optional (session *session*))
"Returns the principal(user) that logged into the application"
(when session
(session-value 'principal session)))
+(defun (setf current-principal) (principal &optional (session *session*))
+ "Setf the principal(user) that logged into the application"
+ (unless session
+ (setf session (lisplet-start-session)))
+ (setf (session-value 'principal session) principal))
+
(defun user-in-role-p (roles &optional (session *session*))
- "Detects if current principal belongs to any of the expressed roles"
+ "Detects if current principal belongs to any of the expressed roles"
(let ((principal (current-principal session)))
(when principal
(loop for el in (principal-roles principal) thereis (member el roles)))))
@@ -101,3 +134,53 @@
(defun login (&optional (request *request*))
"Perfoms a login action using the configuration object given for the request realm"
(configuration-login (current-config request)))
+
+(defun flatten (tree &optional result-list)
+ "Traverses the tree in order, collecting even non-null leaves into a list."
+ (let ((result result-list))
+ (loop for element in tree
+ do (cond
+ ((consp element) (setf result (append (nreverse (flatten element result-list)) result)))
+ (t (push element result))))
+ (nreverse result)))
+
+(defmacro message (key locale &optional (default ""))
+ (let ((current-lisplet (gensym))
+ (current-page (gensym))
+ (current-component (gensym))
+ (result (gensym))
+ (key-val key)
+ (locale-val locale)
+ (default-val default))
+ `#'(lambda ()
+ (let ((,current-lisplet (current-lisplet))
+ (,current-page (current-page))
+ (,current-component (current-component))
+ (,result))
+ (when ,current-lisplet
+ (setf ,result (message-dispatch ,current-lisplet ,key-val ,locale-val)))
+ (when (and (null ,result) ,current-page)
+ (setf ,result (message-dispatch ,current-page ,key-val ,locale-val)))
+ (when (and (null ,result) ,current-component)
+ (setf ,result (message-dispatch ,current-component ,key-val ,locale-val)))
+ (when (and (null ,result) (> (length ,locale-val) 2))
+ (setf ,locale-val (subseq ,locale-val 0 2))
+ (when ,current-lisplet
+ (setf ,result (message-dispatch ,current-lisplet ,key-val ,locale-val)))
+ (when (and (null ,result) ,current-page)
+ (setf ,result (message-dispatch ,current-page ,key-val ,locale-val)))
+ (when (and (null ,result) ,current-component)
+ (setf ,result (message-dispatch ,current-component ,key-val ,locale-val))))
+ (when (null ,result)
+ (setf ,locale-val "")
+ (when ,current-lisplet
+ (setf ,result (message-dispatch ,current-lisplet ,key-val ,locale-val)))
+ (when (and (null ,result) ,current-page)
+ (setf ,result (message-dispatch ,current-page ,key-val ,locale-val)))
+ (when (and (null ,result) ,current-component)
+ (setf ,result (message-dispatch ,current-component ,key-val ,locale-val))))
+ (if ,result
+ ,result
+ ,default-val)))))
+
+
\ No newline at end of file
Modified: trunk/main/claw-core/src/packages.lisp
==============================================================================
--- trunk/main/claw-core/src/packages.lisp (original)
+++ trunk/main/claw-core/src/packages.lisp Wed Mar 12 05:26:40 2008
@@ -34,6 +34,7 @@
(defpackage :claw
(:use :cl :hunchentoot :alexandria :cl-ppcre :cl-fad)
+ (:shadow :flatten)
(:export :*html-4.01-strict*
:*html-4.01-transitional*
:*html-4.01-frameset*
@@ -48,6 +49,7 @@
;:request-realm
:request-id-table-map
;:dyna-id
+ :flatten
:tag-emptyp
:tag-symbol-class
:strings-to-jsarray
@@ -55,6 +57,7 @@
:build-tagf
:parse-htcomponent-function
:page ;page classes hadle the whole rendering cycle
+ :message-dispatch
:page-writer
:page-can-print
:page-url
@@ -219,8 +222,7 @@
:csubmit
:csubmit>
:submit-link
- :submit-link>
- :validator-required
+ :submit-link>
:lisplet
:lisplet-realm
:lisplet-pages
@@ -268,5 +270,26 @@
:current-lisplet
:current-server
:current-realm
+ :current-page
+ :current-component
+ :page-current-component
:user-in-role-p
- :login))
+ :login
+ :message
+ ;;validation
+ :translator
+ :translator-integer
+ :translator-encode
+ :translator-decode
+ :*simple-translator*
+ ;;:with-validators disabled
+ :validate
+ :validation-errors
+ :component-validation-errors
+ :validator-required
+ :validator-size
+ :validator-range
+ :validator-number
+ :validator-integer
+ :exception-monitor
+ :exception-monitor>))
Modified: trunk/main/claw-core/src/server.lisp
==============================================================================
--- trunk/main/claw-core/src/server.lisp (original)
+++ trunk/main/claw-core/src/server.lisp Wed Mar 12 05:26:40 2008
@@ -398,7 +398,8 @@
(defmethod clawserver-dispatch-method ((clawserver clawserver))
(let ((result nil))
(progn
- (setf (aux-request-value 'clawserver) clawserver)
+ ;(setf (aux-request-value 'clawserver) clawserver)
+ (setf (current-server) clawserver)
(setf result (clawserver-dispatch-request clawserver))
(if (null result)
#'(lambda () (when (= (return-code) +http-ok+)
@@ -462,8 +463,8 @@
;;;----------------------------------------------------------------------------
(defun login (&optional (request *request*))
"Perform user authentication for the reaml where the request has been created"
- (let* ((server (aux-request-value 'clawserver))
- (realm (aux-request-value 'realm))
+ (let* ((server (current-server request));(aux-request-value 'clawserver))
+ (realm (current-realm request));(aux-request-value 'realm))
(login-config (gethash realm (clawserver-login-config server))))
(configuration-login login-config request)))
Modified: trunk/main/claw-core/src/tags.lisp
==============================================================================
--- trunk/main/claw-core/src/tags.lisp (original)
+++ trunk/main/claw-core/src/tags.lisp Wed Mar 12 05:26:40 2008
@@ -29,7 +29,8 @@
(in-package :claw)
-
+(defgeneric message-dispatch (object key locale)
+ (:documentation "Returns the KEY translation by the given LOCALE"))
(defgeneric page-req-parameter (page name &optional as-list)
(:documentation "This method returns a request parameter given by NAME searching first
@@ -213,8 +214,6 @@
- WCOMPONENT is the tag instance
- PAGE the page instance"))
-(defvar *clawserver-base-path* nil)
-
(defvar *html-4.01-strict* "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01//EN\" \"http://www.w3.org/TR/html4/strict.dtd\">"
"Page doctype as HTML 4.01 STRICT")
@@ -262,22 +261,21 @@
(when (boundp '*request*)
(setf (aux-request-value :id-table-map) (make-hash-table :test 'equal))))
-
(defun parse-htcomponent-function (function-body)
"This function parses attributes passed to a htcomponent creation function"
(let ((attributes)
(body))
- (loop for last-elem = nil then elem
- for elem in function-body
- do (if (or (and (stringp last-elem) (stringp elem))
- (and (null last-elem) (stringp elem))
- (subtypep (type-of elem) 'htcomponent)
- (and (evenp (length attributes)) (stringp elem))
- body)
- (push elem body)
- (push elem attributes)))
+ (loop for last-elem = nil then elem
+ for elem in function-body
+ do (if (and (null body)
+ (or (keywordp elem)
+ (keywordp last-elem)))
+ (push elem attributes)
+ (when elem
+ (push elem body))))
(list (reverse attributes) (reverse body))))
+
(defun generate-id (id)
"This function is very useful when having references to components id inside component body.
When used with :STATIC-ID the generated id will be mantained as is, and rendered just like the :ID tag attribute."
@@ -325,8 +323,17 @@
;;;----------------------------------------------------------------
+(defclass message-dispatcher ()
+ ())
+
+(defclass i18n-aware (message-dispatcher)
+ ((message-dispatcher :initarg :message-dispatcher
+ :accessor message-dispatcher
+ :documentation "Reference to a MESSAGE-DISPATCHER instance"))
+ (:default-initargs :message-dispatcher nil)
+ (:documentation "All classes that need to dispatch messages are subclasses of I18N-AWARE"))
-(defclass page()
+(defclass page(i18n-aware)
((writer :initarg :writer
:accessor page-writer :documentation "The output stream for this page instance")
(lisplet :initarg :lisplet
@@ -570,7 +577,8 @@
(let ((body (page-content page))
(jsonp (page-json-id-list page)))
(if (null body)
- (format nil "null body for page ~a~%" (type-of page))
+ ;(format nil "null body for page ~a~%" (type-of page))
+ (setf (current-page) page)
(progn
(page-init page)
(when (page-req-parameter page *rewind-parameter*)
@@ -587,9 +595,12 @@
(page-format-raw page "},classInjections:\"")
(setf (page-can-print page) t)
(dolist (injection (page-init-injections page))
- (htcomponent-render injection page))
+ (when injection
+ (htcomponent-render injection page)))
(page-format-raw page "\",instanceInjections:\"")
- (htcomponent-render (htbody-init-scripts-tag page) page)
+ (let ((init-scripts (htbody-init-scripts-tag page)))
+ (when init-scripts
+ (htcomponent-render init-scripts page)))
(page-format-raw page "\"}"))))))
(defmethod page-body-init-scripts ((page page))
@@ -639,6 +650,11 @@
(defmethod page-current-component ((page page))
(car (page-components-stack page)))
+
+(defmethod current-component ()
+ (let ((page (current-page)))
+ (when page
+ (car (page-components-stack page)))))
;;;========= HTCOMPONENT ============================
(defmethod htcomponent-can-print ((htcomponent htcomponent))
(let* ((id (htcomponent-client-id htcomponent))
@@ -708,10 +724,12 @@
(when (null previous-print-status)
(setf (page-can-print page) (htcomponent-can-print htcomponent))
(htcomponent-json-print-start-component htcomponent))
- (dolist (tag body-list)
- (if (stringp tag)
- (htcomponent-render ($> tag) page)
- (htcomponent-render tag page)))
+ (dolist (child-tag body-list)
+ (when child-tag
+ (cond
+ ((stringp child-tag) (htcomponent-render ($> child-tag) page))
+ ((functionp child-tag) (funcall child-tag))
+ (t (htcomponent-render child-tag page)))))
(when (null previous-print-status)
(setf (page-can-print page) nil)
(htcomponent-json-print-end-component htcomponent))))
@@ -722,7 +740,9 @@
(loop for (k v) on (htcomponent-attributes tag) by #'cddr
do (progn
(assert (keywordp k))
- (when (and v (string-not-equal v ""))
+ (when (functionp v)
+ (setf v (funcall v)))
+ (when (and v (string-not-equal v ""))
(page-format page " ~a=\"~a\""
(string-downcase (if (eq k :static-id)
"id"
@@ -773,10 +793,12 @@
(htcomponent-json-print-start-component tag))
(when (or (page-can-print page) previous-print-status)
(tag-render-starttag tag page))
- (dolist (tag body-list)
- (if (stringp tag)
- (htcomponent-render ($> tag) page)
- (htcomponent-render tag page)))
+ (dolist (child-tag body-list)
+ (when child-tag
+ (cond
+ ((stringp child-tag) (htcomponent-render ($> child-tag) page))
+ ((functionp child-tag) (funcall child-tag))
+ (t (htcomponent-render child-tag page)))))
(when (or (page-can-print page) previous-print-status)
(tag-render-endtag tag page))
(unless previous-print-status
@@ -789,12 +811,15 @@
(let ((body-list (htcomponent-body hthead))
(injections (page-init-injections page)))
(tag-render-starttag hthead page)
- (dolist (tag body-list)
- (if (stringp tag)
- (htcomponent-render ($> tag) page)
- (htcomponent-render tag page)))
+ (dolist (child-tag body-list)
+ (when child-tag
+ (cond
+ ((stringp child-tag) (htcomponent-render ($> child-tag) page))
+ ((functionp child-tag) (funcall child-tag))
+ (t (htcomponent-render child-tag page)))))
(dolist (injection injections)
- (htcomponent-render injection page))
+ (when injection
+ (htcomponent-render injection page)))
(tag-render-endtag hthead page))))
;;;========= HTSTRING ===================================
@@ -806,7 +831,9 @@
(let ((body (htcomponent-body htstring))
(jsonp (not (null (page-json-id-list page))))
(print-p (page-can-print page)))
- (when (or print-p body)
+ (when (and print-p body)
+ (when (functionp body)
+ (setf body (funcall body)))
(when jsonp
(setf body (regex-replace-all "\""
(regex-replace-all "\\\\\""
@@ -846,9 +873,11 @@
(unless (listp body)
(setf body (list body)))
(dolist (element body)
- (if (stringp element)
- (htcomponent-render ($raw> element) page)
- (htcomponent-render element page)))
+ (when element
+ (cond
+ ((stringp element) (htcomponent-render ($> element) page))
+ ((functionp element) (funcall element))
+ (t (htcomponent-render element page)))))
(if (null xml-p)
(page-format page "~%//-->")
(page-format page "~%//]]>")))
@@ -885,10 +914,12 @@
(htcomponent-json-print-start-component htbody))
(when (page-can-print page)
(tag-render-starttag htbody page))
- (dolist (tag body-list)
- (if (stringp tag)
- (htcomponent-render ($> tag) page)
- (htcomponent-render tag page)))
+ (dolist (child-tag body-list)
+ (when child-tag
+ (cond
+ ((stringp child-tag) (htcomponent-render ($> child-tag) page))
+ ((functionp child-tag) (funcall child-tag))
+ (t (htcomponent-render child-tag page)))))
(when (page-can-print page)
(htcomponent-render (htbody-init-scripts-tag page) page)
(tag-render-endtag htbody page))
@@ -903,7 +934,7 @@
js))
;;;========= WCOMPONENT ===================================
-(defclass wcomponent (htcomponent)
+(defclass wcomponent (htcomponent i18n-aware)
((parameters :initarg :parameters
:accessor wcomponent-parameters
:type cons
@@ -1060,10 +1091,12 @@
(wcomponent-before-render wcomponent page)
(unless (listp template)
(setf template (list template)))
- (dolist (tag template)
- (if (stringp tag)
- (htcomponent-render ($> tag) page)
- (htcomponent-render tag page)))
+ (dolist (child-tag template)
+ (when child-tag
+ (cond
+ ((stringp child-tag) (htcomponent-render ($> child-tag) page))
+ ((functionp child-tag) (funcall child-tag))
+ (t (htcomponent-render child-tag page)))))
(wcomponent-after-render wcomponent page)
(when (null previous-print-status)
(setf (page-can-print page) nil)
@@ -1071,3 +1104,37 @@
(defmethod wcomponent-before-render ((wcomponent wcomponent) (page page)))
(defmethod wcomponent-after-render ((wcomponent wcomponent) (page page)))
+
+(defun component-id-and-value (component &key (from-request-p t) value-as-list-p)
+ (let ((client-id (htcomponent-client-id component))
+ (page (htcomponent-page component))
+ (visit-object (wcomponent-parameter-value component :visit-object))
+ (accessor (wcomponent-parameter-value component :accessor))
+ (reader (wcomponent-parameter-value component :reader))
+ (result-as-list (cinput-result-as-list component))
+ (value ""))
+ (when (null visit-object)
+ (setf visit-object (htcomponent-page component)))
+ (cond
+ (from-request-p (setf value (page-req-parameter page client-id value-as-list-p)))
+ ((and (null reader) accessor) (setf value (funcall (fdefinition accessor) visit-object)))
+ (t (setf value (funcall (fdefinition reader) visit-object))))
+ (values client-id
+ (if result-as-list
+ (list value)
+ value))))
+
+
+(defmethod message-dispatch ((message-dispatcher message-dispatcher) key locale) nil)
+
+(defmethod message-dispatch ((i18n-aware i18n-aware) key locale)
+ (let ((dispatcher (message-dispatcher i18n-aware))
+ (result))
+ (when dispatcher
+ (progn
+ (setf result (message-dispatch dispatcher key locale))
+ (when (null result))))
+
+
+
+
Added: trunk/main/claw-core/src/validators.lisp
==============================================================================
--- (empty file)
+++ trunk/main/claw-core/src/validators.lisp Wed Mar 12 05:26:40 2008
@@ -0,0 +1,273 @@
+;;; -*- 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"))
+
+(defgeneric translator-decode (translator wcomponent)
+ (:documentation "Decodes the input component value"))
+
+(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)
+ new-value))
+
+(defvar *simple-translator* (make-instance 'translator))
+
+(defclass translator-integer (translator)
+ ((thousand-separator :initarg :thousand-separator
+ :reader translator-thousand-separator)
+ (always-show-signum :initarg :always-show-signum
+ :reader translator-always-show-signum))
+ (:default-initargs :thousand-separator nil
+ :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))
+ (thousand-separator (translator-thousand-separator translator))
+ (signum-directive (if (translator-always-show-signum translator)
+ "@"
+ ""))
+ (control-string (if thousand-separator
+ (format nil "~~3,' ,v:~aD" 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)
+ (if thousand-separator
+ (parse-integer (regex-replace-all (format nil "~a" thousand-separator) new-value ""))
+ (parse-integer new-value)))))
+
+;;=========================================
+#|
+(defclass translator-number (translator)
+ ((thousand-separator :initarg :thousand-separator
+ :reader translator-thousand-separator)
+ (decimals-separator :initarg :decimals-separator
+ :reader translator-decimals-separator)
+ (decimal-digits :initarg :decimal-digits
+ :reader translator-decimal-digits)
+ (always-show-signum :initarg :always-show-signum
+ :reader translator-always-show-signum))
+ (:default-initargs :thousand-separator nil :decimals-separator #\.
+ :integer-digits nil
+ :decimal-digits nil
+ :always-show-signum nil)
+ (: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))
+ (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 "~~3,' ,v:~aD" 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))))
+ (format nil "~a~a" (if thousand-separator
+ (string-trim " " (format nil control-string thousand-separator int-value))
+ (format nil control-string int-value))
+ (cond
+ ((and (= 0.0 (coerce dec-value 'double-float)) decimal-digits)
+ (format "~a~a" decimals-separator (make-string decimal-digits #\0)))
+ (decimal-digits
+ (format "~a~a" decimals-separator (make-string decimal-digits #\0))
+
+(defmethod translator-decode ((translator translator-number) (wcomponent wcomponent))
+ (let* ((thousand-separator (translator-thousand-separator translator)))
+ (multiple-value-bind (client-id new-value)
+ (component-id-and-value wcomponent)
+ (if thousand-separator
+ (parse-integer (regex-replace-all (format nil "~a" thousand-separator) new-value ""))
+ (parse-integer new-value)))))
+
+|#
+;;----------------------------------------------------------------------------------------
+(defun add-exception (id reason)
+ (let* ((validation-errors (aux-request-value :validation-errors))
+ (component-exceptions (assoc id validation-errors :test #'equal)))
+ (if component-exceptions
+ (setf (cdr component-exceptions) (append (cdr component-exceptions) (list reason)))
+ (if validation-errors
+ (setf (aux-request-value :validation-errors) (append validation-errors (list (cons id (list reason)))))
+ (setf (aux-request-value :validation-errors) (list (cons id (list reason))))))))
+
+
+(defun validate (test &key component message)
+ (let ((client-id (htcomponent-client-id component)))
+ (unless test
+ (add-exception client-id message))))
+
+(defun validation-errors (&optional (request *request*))
+ "Resurns possible validation errors occurred during form rewinding"
+ (aux-request-value :validation-errors request))
+
+(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)))
+ (assoc client-id (validation-errors request) :test #'equal)))
+
+(defun validator-required (component value)
+ (when (stringp value)
+ (validate (and value (string-not-equal value ""))
+ :component component
+ :message (format nil "Field ~a may not be null." (wcomponent-parameter-value component :label)))))
+
+(defun validator-size (component value &key min-size max-size)
+ (let ((value-len 0))
+ (when value
+ (setf value (format nil "~a" value))
+ (setf value-len (length value))
+ (or (= value-len 0)
+ (when min-size
+ (validate (>= value-len min-size)
+ :component component
+ :message (format nil "Size of ~a may not be less then ~a"
+ (wcomponent-parameter-value component :label)
+ min-size)))
+ (when max-size
+ (validate (<= value-len max-size)
+ :component component
+ :message (format nil "Size of ~a may not be more then ~a"
+ (wcomponent-parameter-value component :label)
+ max-size)))))))
+
+(defun validator-range (component value &key min max)
+ (when value
+ (or (when min
+ (validate (>= value min)
+ :component component
+ :message (format nil "Field ~a is not greater then or equal to ~d" (wcomponent-parameter-value component :label) min)))
+ (when max
+ (validate (<= value max)
+ :component component
+ :message (format nil "Field ~a is not less then or equal to ~d" (wcomponent-parameter-value component :label) max))))))
+
+(defun validator-number (component value &key min max)
+ (when value
+ (let ((test (numberp value)))
+ (or (validate test
+ :component component
+ :message (format nil "Field ~a is not a valid number" (wcomponent-parameter-value component :label)))
+ (validator-range component value :min min :max max)))))
+
+(defun validator-integer (component value &key min max)
+ (when value
+ (let ((test (integerp value)))
+ (or (validate test
+ :component component
+ :message (format nil "Field ~a is not a valid integer" (wcomponent-parameter-value component :label)))
+ (validator-range component value :min min :max max)))))
+
+
+;; ------------------------------------------------------------------------------------
+(defcomponent exception-monitor () ()
+ (:documentation "If from submission contains exceptions. It displays exception messages"))
+
+(defmethod wcomponent-parameters ((exception-monitor exception-monitor))
+ (declare (ignore exception-monitor))
+ (list :class nil))
+
+(defmethod wcomponent-template ((exception-monitor exception-monitor))
+ (let ((client-id (htcomponent-client-id exception-monitor))
+ (validation-errors (aux-request-value :validation-errors)))
+ (when validation-errors
+ (ul> :static-id client-id
+ (loop for component-exceptions in validation-errors
+ collect (loop for message in (cdr component-exceptions)
+ collect (li> message)))))))
+
+;;-------------------------------------------------------------------------------------------
+
+#|
+(defmacro with-validators (&rest rest)
+ (let* ((component (gensym))
+ (value (gensym))
+ (validators (loop for validator in rest
+ collect (list 'funcall validator component value))))
+ `#'(lambda (,value)
+ (let ((,component (current-component)))
+ (or , at validators)))))
+|#
+
Modified: trunk/main/claw-core/tests/test1.lisp
==============================================================================
--- trunk/main/claw-core/tests/test1.lisp (original)
+++ trunk/main/claw-core/tests/test1.lisp Wed Mar 12 05:26:40 2008
@@ -41,8 +41,6 @@
(defvar *test-lisplet2*)
(setf *test-lisplet2* (make-instance 'lisplet :realm "test2" :base-path "/test2"))
-
-
;;(defparameter *clawserver* (make-instance 'clawserver :port 4242))
(defparameter *clawserver* (make-instance 'clawserver :port 4242 :sslport 4445
@@ -60,9 +58,10 @@
(when (and (string-equal user "kiuma")
(string-equal password "password"))
(progn
- (unless session
- (setf session (lisplet-start-session)))
- (setf (session-value 'principal session) (make-instance 'principal :name user :roles '("user")))))))
+ ;;(unless session
+ ;; (setf session (lisplet-start-session)))
+ ;;(setf (session-value 'principal session) (make-instance 'principal :name user :roles '("user")))))))
+ (setf (current-principal session) (make-instance 'principal :name user :roles '("user")))))))
@@ -117,9 +116,11 @@
(defclass auth-page (page) ())
(defmethod page-content ((page auth-page))
(site-template> :title "Unauth test page"
- (p> "not here")))
+ (p> "protected content")))
(lisplet-register-page-location *test-lisplet* 'auth-page "unauth.html")
-(lisplet-protect *test-lisplet* "unauth.html" '("admin" "user"))
+(lisplet-register-page-location *test-lisplet* 'auth-page "auth.html")
+(lisplet-protect *test-lisplet* "auth.html" '("admin" "user"))
+(lisplet-protect *test-lisplet* "unauth.html" '("nobody"))
(defclass index-page (page) ())
@@ -129,6 +130,8 @@
(ul>
(li> (a> :href "login.html"
"Do login"))
+ (li> (a> :href "info.html"
+ "Headers info"))
(li> (a> :href "images/matrix.jpg"
"show static file"))
(li> (a> :href "images/matrix2.jpg"
@@ -139,11 +142,28 @@
"realm on lisplet 'test2'"))
(li> (a> :href "id-tests.html" "id generation test"))
(li> (a> :href "form.html" "form components test"))
+ (li> (a> :href "auth.html" "authorized page"))
(li> (a> :href "unauth.html" "unauthorized page"))))))
+(lisplet-register-page-location *test-lisplet* 'index-page "index.html" :welcome-page-p t)
+
+(defclass info-page (page) ())
+
+(defmethod page-content ((o info-page))
+ (let ((header-props (headers-in)))
+ (site-template> :title "Header info page"
+ (p> :id "p"
+ (table>
+ (tr> (td> :colspan "2" "Header info"))
+ (loop for key-val in header-props
+ collect (tr>
+ (td> (format nil "~a" (car key-val))
+ (td> (format nil "~a" (cdr key-val)))))))))))
+
+(lisplet-register-page-location *test-lisplet* 'info-page "info.html")
+
(defun test-image-file ()
(make-pathname :directory (append (pathname-directory *this-file*) '("img")) :name "matrix" :type "jpg"))
-(lisplet-register-page-location *test-lisplet* 'index-page "index.html" :welcome-page-p t)
(lisplet-register-resource-location *test-lisplet* (test-image-file) "images/matrix.jpg" "image/jpeg")
@@ -266,8 +286,10 @@
(surname :initarg :surname
:accessor user-surname)
(gender :initarg :gender
- :accessor user-gender))
- (:default-initargs :name "" :surname "" :gender ""))
+ :accessor user-gender)
+ (age :initarg :age
+ :accessor user-age))
+ (:default-initargs :name "" :surname "" :gender "" :age ""))
(defgeneric form-page-update-user (form-page))
@@ -282,21 +304,29 @@
:writer setf-gender
:accessor form-page-gender)
(user :initarg :user
- :accessor form-page-user))
+ :accessor form-page-user)
+ (age :initarg :age
+ :accessor form-page-age))
(:default-initargs :name "kiuma"
:surname "surnk"
:colors nil
:gender '("M")
+ :age 1800
:user (make-instance 'user)))
(defmethod form-page-update-user ((form-page form-page))
(let ((user (form-page-user form-page))
(name (form-page-name form-page))
(surname (form-page-surname form-page))
- (gender (first (form-page-gender form-page))))
+ (gender (first (form-page-gender form-page)))
+ (age (form-page-age form-page)))
(setf (user-name user) name
(user-surname user) surname
- (user-gender user) gender)))
+ (user-gender user) gender
+ (user-age user) age)))
+
+;(defmethod message-dispatch ((object form-page) key locale)
+
(defmethod page-content ((o form-page))
(site-template> :title "a page title"
@@ -308,17 +338,18 @@
(cinput> :id "name"
:type "text"
:label "Name"
- :validator #'(lambda ()
- (validator-required (page-current-component o)))
+ :validator #'(lambda (value)
+ (validator-required (page-current-component o) value))
:accessor 'form-page-name)"*"))
(tr>
(td> "Surname")
(td>
(cinput> :id "surname"
:type "text"
- :label "Name"
- :validator #'(lambda ()
- (validator-required (page-current-component o)))
+ :label "Surname"
+ :validator #'(lambda (value)
+ (validator-required (page-current-component o) value)
+ (validator-size (page-current-component o) value :min-size 1 :max-size 20))
:accessor 'form-page-surname)"*"))
(tr>
(td> "Gender")
@@ -333,6 +364,18 @@
"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)))
+ (validator-required component value)
+ (validator-integer component value :min 1 :max 2000)))
+ :accessor 'form-page-age)"*"))
+ (tr>
(td> "Colors")
(td>
(cselect> :id "colors"
@@ -350,12 +393,14 @@
(tr>
(td> :colspan "2"
(csubmit> :id "submit" :value "OK")))))
- (p>
+ (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 "Gender: ~a" (user-gender (form-page-user o))))
+ (div> (format nil "Age: ~a" (user-age (form-page-user o)))))))
(lisplet-register-page-location *test-lisplet* 'form-page "form.html")
More information about the Claw-cvs
mailing list