[claw-cvs] r17 - in trunk/main/claw-core: src tests

[achiumenti at common-lisp.net]

Author: achiumenti
Date: Fri Mar 14 02:57:28 2008
New Revision: 17

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	Fri Mar 14 02:57:28 2008
@@ -144,7 +144,7 @@
 	    (t (push element result))))
     (nreverse result)))
 
-(defmacro with-message (key locale &optional (default ""))
+(defmacro with-message (key &optional (default "") locale)
   (let ((current-lisplet (gensym))
 	(current-page (gensym))
 	(current-component (gensym))
@@ -157,28 +157,43 @@
 	       (,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 (null ,result)
-	   (setf ,locale-val "")
+	       (,result))	   
+	   (unless ,locale-val
+	     (setf ,locale-val (user-locale)))
 	   (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)))))
+	     (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
+  
+(defun user-locale (&optional (request *request*) (session *session*))
+  (let ((locale (when session
+		  (session-value 'locale session))))
+    (unless locale
+      (setf locale (first (loop for str in (all-matches-as-strings 
+					    "[A-Z|a-z|_]+" 
+					    (regex-replace-all "-" (regex-replace-all ";.*" (header-in "ACCEPT-LANGUAGE" request) "") "_"))
+			     collect (if (> (length str) 2)
+					 (string-upcase str :start 2)
+					 str)))))
+    locale))
+
+(defun (setf user-locale) (locale &optional (session *session*))
+  (unless session
+    (setf session (lisplet-start-session)))
+  (setf (session-value 'locale session) locale))
+      
+    

Modified: trunk/main/claw-core/src/packages.lisp
==============================================================================
--- trunk/main/claw-core/src/packages.lisp	(original)
+++ trunk/main/claw-core/src/packages.lisp	Fri Mar 14 02:57:28 2008
@@ -272,6 +272,7 @@
 	   :current-realm
 	   :current-page
 	   :current-component
+	   :user-locale
 	   :page-current-component
 	   :user-in-role-p
 	   :login

Modified: trunk/main/claw-core/src/tags.lisp
==============================================================================
--- trunk/main/claw-core/src/tags.lisp	(original)
+++ trunk/main/claw-core/src/tags.lisp	Fri Mar 14 02:57:28 2008
@@ -389,7 +389,7 @@
     :url nil)
   (:documentation "A page object holds claw components to be rendered") )
   
-(defclass htcomponent ()
+(defclass htcomponent (i18n-aware)
   ((page :initarg :page
 	 :reader htcomponent-page :documentation "The owner page") 
    (body :initarg :body
@@ -431,6 +431,8 @@
   (:default-initargs :raw nil)
   (:documentation "Component needed to render strings"))
 
+
+
 (defmethod initialize-instance :after ((inst tag) &rest keys)
   (let ((emptyp (getf keys :empty))
 	(body (getf keys :body)))
@@ -943,7 +945,7 @@
     js))
 
 ;;;========= WCOMPONENT ===================================
-(defclass wcomponent (htcomponent i18n-aware)
+(defclass wcomponent (htcomponent)
   ((parameters :initarg :parameters
 	       :accessor wcomponent-parameters
 	       :type cons
@@ -1142,8 +1144,8 @@
     (when dispatcher
       (progn 
 	(setf result (message-dispatch dispatcher key locale))
-	(when (and (null result) (> (length key) 2))
-	  (setf result (message-dispatch dispatcher (subseq key 0 2) locale)))))
+	(when (and (null result) (> (length locale) 2))
+	  (setf result (message-dispatch dispatcher key (subseq locale 0 2))))))
     result))
 
 (defmethod simple-message-dispatcher-add-message ((simple-message-dispatcher simple-message-dispatcher) locale key value)

Modified: trunk/main/claw-core/tests/test1.lisp
==============================================================================
--- trunk/main/claw-core/tests/test1.lisp	(original)
+++ trunk/main/claw-core/tests/test1.lisp	Fri Mar 14 02:57:28 2008
@@ -354,7 +354,7 @@
 						     (validator-required (page-current-component o) value))
 				      :accessor 'form-page-name)"*"))
 			   (tr> :id "messaged"
-			    (td> (with-message "SURNAME" "it"))
+			    (td> (with-message "SURNAME" "SURNAME"))
 			    (td>
 			     (cinput> :id "surname"
 				      :type "text"