[claw-cvs] r16 - in trunk/main/claw-core: src tests
achiumenti at common-lisp.net
achiumenti at common-lisp.net
Wed Mar 12 20:20:24 UTC 2008
Author: achiumenti
Date: Wed Mar 12 15:20:24 2008
New Revision: 16
Modified:
trunk/main/claw-core/src/misc.lisp
trunk/main/claw-core/src/packages.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/src/misc.lisp
==============================================================================
--- trunk/main/claw-core/src/misc.lisp (original)
+++ trunk/main/claw-core/src/misc.lisp Wed Mar 12 15:20:24 2008
@@ -144,33 +144,31 @@
(t (push element result))))
(nreverse result)))
-(defmacro message (key locale &optional (default ""))
+(defmacro with-message (key locale &optional (default ""))
(let ((current-lisplet (gensym))
(current-page (gensym))
(current-component (gensym))
(result (gensym))
(key-val key)
- (locale-val locale)
+ (locale-val (gensym))
(default-val default))
`#'(lambda ()
(let ((,current-lisplet (current-lisplet))
- (,current-page (current-page))
- (,current-component (current-component))
- (,result))
+ (,current-page (current-page))
+ (,current-component (current-component))
+ (,locale-val ,locale)
+ (,result))
+ (log-message :info "LISPLET: ~a; PAGE: ~a; COMPONENT: ~a"
+ ,current-lisplet
+ ,current-page
+ ,current-component)
(when ,current-lisplet
+ (log-message :info "CALLING (message-dispatch ~a ~a ~a)" ,current-lisplet ,key-val ,locale-val)
(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))))
+ (setf ,result (message-dispatch ,current-component ,key-val ,locale-val)))
(when (null ,result)
(setf ,locale-val "")
(when ,current-lisplet
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 15:20:24 2008
@@ -275,7 +275,12 @@
:page-current-component
:user-in-role-p
:login
- :message
+ ;;i18n
+ :message-dispatcher
+ :message-dispatch
+ :simple-message-dispatcher
+ :simple-message-dispatcher-add-message
+ :with-message
;;validation
:translator
:translator-integer
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 15:20:24 2008
@@ -214,6 +214,9 @@
- WCOMPONENT is the tag instance
- PAGE the page instance"))
+(defgeneric simple-message-dispatcher-add-message (simple-message-dispatcher locale key value)
+ (:documentation "Adds a key value pair to a given locale for message translation"))
+
(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")
@@ -326,6 +329,10 @@
(defclass message-dispatcher ()
())
+(defclass simple-message-dispatcher (message-dispatcher)
+ ((locales :initform (make-hash-table :test #'equal)
+ :accessor simple-message-dispatcher-locales)))
+
(defclass i18n-aware (message-dispatcher)
((message-dispatcher :initarg :message-dispatcher
:accessor message-dispatcher
@@ -577,9 +584,9 @@
(let ((body (page-content page))
(jsonp (page-json-id-list page)))
(if (null body)
- ;(format nil "null body for page ~a~%" (type-of page))
- (setf (current-page) page)
+ (format nil "null body for page ~a~%" (type-of page))
(progn
+ (setf (current-page) page)
(page-init page)
(when (page-req-parameter page *rewind-parameter*)
(htcomponent-rewind body page))
@@ -728,7 +735,7 @@
(when child-tag
(cond
((stringp child-tag) (htcomponent-render ($> child-tag) page))
- ((functionp child-tag) (funcall child-tag))
+ ((functionp child-tag) (htcomponent-render ($> (funcall child-tag)) page))
(t (htcomponent-render child-tag page)))))
(when (null previous-print-status)
(setf (page-can-print page) nil)
@@ -793,11 +800,13 @@
(htcomponent-json-print-start-component tag))
(when (or (page-can-print page) previous-print-status)
(tag-render-starttag tag page))
+ (when (string-equal "messaged" (htcomponent-client-id tag))
+ (log-message :info "RENDEING ~a: body ~a" (htcomponent-client-id tag) body-list))
(dolist (child-tag body-list)
- (when child-tag
- (cond
+ (when child-tag
+ (cond
((stringp child-tag) (htcomponent-render ($> child-tag) page))
- ((functionp child-tag) (funcall child-tag))
+ ((functionp child-tag) (htcomponent-render ($> (funcall child-tag)) page))
(t (htcomponent-render child-tag page)))))
(when (or (page-can-print page) previous-print-status)
(tag-render-endtag tag page))
@@ -815,7 +824,7 @@
(when child-tag
(cond
((stringp child-tag) (htcomponent-render ($> child-tag) page))
- ((functionp child-tag) (funcall child-tag))
+ ((functionp child-tag) (htcomponent-render ($> (funcall child-tag)) page))
(t (htcomponent-render child-tag page)))))
(dolist (injection injections)
(when injection
@@ -876,7 +885,7 @@
(when element
(cond
((stringp element) (htcomponent-render ($> element) page))
- ((functionp element) (funcall element))
+ ((functionp element) (htcomponent-render ($> (funcall element)) page))
(t (htcomponent-render element page)))))
(if (null xml-p)
(page-format page "~%//-->")
@@ -918,7 +927,7 @@
(when child-tag
(cond
((stringp child-tag) (htcomponent-render ($> child-tag) page))
- ((functionp child-tag) (funcall child-tag))
+ ((functionp child-tag) (htcomponent-render ($> (funcall child-tag)) page))
(t (htcomponent-render child-tag page)))))
(when (page-can-print page)
(htcomponent-render (htbody-init-scripts-tag page) page)
@@ -1095,7 +1104,7 @@
(when child-tag
(cond
((stringp child-tag) (htcomponent-render ($> child-tag) page))
- ((functionp child-tag) (funcall child-tag))
+ ((functionp child-tag) (htcomponent-render ($> (funcall child-tag)) page))
(t (htcomponent-render child-tag page)))))
(wcomponent-after-render wcomponent page)
(when (null previous-print-status)
@@ -1137,6 +1146,13 @@
(setf result (message-dispatch dispatcher (subseq key 0 2) locale)))))
result))
-
-
+(defmethod simple-message-dispatcher-add-message ((simple-message-dispatcher simple-message-dispatcher) locale key value)
+ (let ((current-locale (gethash locale (simple-message-dispatcher-locales simple-message-dispatcher) (make-hash-table :test #'equal))))
+ (setf (gethash key current-locale) value)
+ (setf (gethash locale (simple-message-dispatcher-locales simple-message-dispatcher)) current-locale)))
+
+(defmethod message-dispatch ((simple-message-dispatcher simple-message-dispatcher) key locale)
+ (let ((current-locale (gethash locale (simple-message-dispatcher-locales simple-message-dispatcher))))
+ (when current-locale
+ (gethash key current-locale))))
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 15:20:24 2008
@@ -35,11 +35,22 @@
(setf *clawserver-base-path* "/claw")
+(defvar *lisplet-messages*
+ (make-instance 'simple-message-dispatcher))
+
+(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* "it" "NAME" "Nome")
+(simple-message-dispatcher-add-message *lisplet-messages* "it" "SURNAME" "Cognome")
+
(defvar *test-lisplet*)
-(setf *test-lisplet* (make-instance 'lisplet :realm "test1" :base-path "/test"))
+(setf *test-lisplet* (make-instance 'lisplet :realm "test1" :base-path "/test"
+ ));:message-dispatcher *lisplet-messages*))
(defvar *test-lisplet2*)
-(setf *test-lisplet2* (make-instance 'lisplet :realm "test2" :base-path "/test2"))
+(setf *test-lisplet2* (make-instance 'lisplet :realm "test2" :base-path "/test2"
+ ));:message-dispatcher *lisplet-messages*))
;;(defparameter *clawserver* (make-instance 'clawserver :port 4242))
@@ -312,6 +323,7 @@
:colors nil
:gender '("M")
:age 1800
+ :message-dispatcher *lisplet-messages*
:user (make-instance 'user)))
(defmethod form-page-update-user ((form-page form-page))
@@ -341,8 +353,8 @@
:validator #'(lambda (value)
(validator-required (page-current-component o) value))
:accessor 'form-page-name)"*"))
- (tr>
- (td> "Surname")
+ (tr> :id "messaged"
+ (td> (with-message "SURNAME" "it"))
(td>
(cinput> :id "surname"
:type "text"
More information about the Claw-cvs
mailing list