[bknr-cvs] ksprotte changed trunk/projects/bos/web/web-utils.lisp

[BKNR Commits]

Revision: 3705
Author: ksprotte
URL: http://bknr.net/trac/changeset/3705

fixed content-language-chooser to keep other GET parameters
U   trunk/projects/bos/web/web-utils.lisp

Modified: trunk/projects/bos/web/web-utils.lisp
===================================================================
--- trunk/projects/bos/web/web-utils.lisp	2008-07-31 08:02:37 UTC (rev 3704)
+++ trunk/projects/bos/web/web-utils.lisp	2008-07-31 08:21:43 UTC (rev 3705)
@@ -37,15 +37,23 @@
 (defun language-name (language-short-name)
   (cadr (assoc language-short-name (website-languages) :test #'equal)))
 
-(defun content-language-chooser ()
-  "Note that in the current implementation other GET parameters than
-   language will be lost (not appended to script-name)."
+(defun content-language-chooser ()  
   (html
    ((:p :class "languages")
     "Content languages: "
     (loop for (language-symbol language-name) in (website-languages)
-       do (labels ((show-language-link ()
-                     (html (cmslink (format nil "~A?language=~A" (hunchentoot:script-name*) language-symbol)
+       do (labels ((show-language-link ()                     
+                     (html (cmslink (with-output-to-string (out)
+                                      (write-string (hunchentoot:script-name*) out)
+                                      ;; write language param and remaining get params
+                                      (write-string "?language=" out)
+                                      (write-string language-symbol out)
+                                      (dolist (get-param (remove "language" (hunchentoot:get-parameters*) :key #'first :test #'equal))
+                                        (destructuring-bind (key . value) get-param
+                                          (write-string "&" out)
+                                          (write-string key out)
+                                          (write-string "=" out)
+                                          (write-string value out))))
                              (:princ-safe language-name)))))
             (if (equal (request-language) language-symbol)
                 (html "[" (show-language-link) "]")