Update of /project/cl-l10n/cvsroot/cl-l10n In directory clnet:/tmp/cvs-serv6511

Modified Files: cl-l10n.asd i18n.lisp load-locale.lisp locale.lisp package.lisp parse-time.lisp parsers.lisp printers.lisp Log Message: Merge attila.lendvai@gmail.com's changes, mostly i18n stuff

--- /project/cl-l10n/cvsroot/cl-l10n/cl-l10n.asd 2006/04/27 18:30:30 1.15 +++ /project/cl-l10n/cvsroot/cl-l10n/cl-l10n.asd 2006/06/08 09:38:19 1.16 @@ -28,7 +28,6 @@

(defmethod perform :after ((o load-op) (c (eql (find-system :cl-l10n)))) (provide 'cl-l10n)) -

(defmethod perform ((op test-op) (sys (eql (find-system :cl-l10n)))) (oos 'load-op :cl-l10n-tests) --- /project/cl-l10n/cvsroot/cl-l10n/i18n.lisp 2006/04/27 18:30:30 1.4 +++ /project/cl-l10n/cvsroot/cl-l10n/i18n.lisp 2006/06/08 09:38:19 1.5 @@ -2,68 +2,120 @@ ;; See the file LICENCE for licence information. (in-package :cl-l10n)

+#| +(defresources en + (indefinit-article-for (str) + ;; calculate "a"/"an" here + ) + (foo.bar "some constant")) + +then writing (indefinit-article-for "asdf") will call the locale-specific +implementation of that function + +|# + +(defvar *resources* (make-hash-table :test 'equal)) + +(defun clear-resources () + (setf *resources* (make-hash-table :test 'equal))) + +(defun resource-key (locale name) + (list (if (stringp locale) locale (locale-name locale)) + (if (stringp name) (string-downcase name) (string-downcase (symbol-name name))))) + +(define-condition resource-missing (warning) + ((name :accessor name-of :initarg :name))) + +(defun add-resource (locale name args body) + ;; store in resouce map + (setf (gethash (resource-key locale name) *resources*) + (if (and (= (length body) 1) + (stringp (first body))) + (first body) + (eval `(lambda ,args ,@body)))) + ;; make a function + (setf (symbol-function name) (eval `(lambda (&rest args) (lookup-resource ',name args)))) + name) + +(defun %lookup-resource (locale name args) + (declare (type locale locale) + (type (or symbol string) name)) + (let* ((key (resource-key locale name))) + (multiple-value-bind (resource found) + (gethash key *resources*) + (unless found + ;; try again with the default locale for the language + (setf key (resource-key (canonical-locale-name-from (first (split "_" (locale-name locale)))) name)) + (setf resource (gethash key *resources*))) + ;; dispatch on resource type + (cond ((functionp resource) + (apply resource args)) + ;; literal + ((not (null resource)) + resource))))) + +(defun lookup-resource (name args &key (warn-if-missing t) (fallback-to-name t)) + (loop for locale in (if (consp *locale*) *locale* (list *locale*)) do + (let ((result (funcall '%lookup-resource locale name args))) + (when result + (return-from lookup-resource (values result t))))) + (resource-not-found name warn-if-missing fallback-to-name)) + +(defun lookup-resource-without-fallback (locale name args &key (warn-if-missing t) (fallback-to-name t)) + (aif (%lookup-resource locale name args) + it + (resource-not-found name warn-if-missing fallback-to-name))) + +(defun resource-not-found (name warn-if-missing fallback-to-name) + (if warn-if-missing + (signal 'resource-missing :name name)) + (values (if fallback-to-name + (string-downcase (string name))) + nil)) + +(defmacro defresources (locale &body resources) + (let ((locale-name (canonical-locale-name-from locale))) + (cons 'progn + (loop for resource in resources + if (= 2 (length resource)) + collect `(add-resource ,locale-name + ',(first resource) nil ',(cdr resource)) + else + collect `(add-resource ,locale-name + ',(first resource) ',(second resource) ',(cddr resource)))))) + +(defmacro enable-sharpquote-reader () + "Enable quote reader for the rest of the file (being loaded or compiled). +#"my i18n text" parts will be replaced by a lookup-resource call for the string. +Be careful when using in different situations, because it modifies *readtable*." + ;; The standard sais that *readtable* is restored after loading/compiling a file, + ;; so we make a copy and alter that. The effect is that it will be enabled + ;; for the rest of the file being processed. + `(eval-when (:compile-toplevel :execute) + (setf *readtable* (copy-readtable *readtable*)) + (%enable-sharpquote-reader))) + +(defun %enable-sharpquote-reader () + (set-dispatch-macro-character + ## #" + #'(lambda (s c1 c2) + (declare (ignore c2)) + (unread-char c1 s) + `(lookup-resource ,(read s) nil)))) + +(defun with-sharpquote-syntax () + "To be used with the curly reader from arnesi: {with-sharpquote-reader (foo #"locale-specific") }" + (lambda (handler) + (%enable-sharpquote-reader) + `(progn ,@(funcall handler))))

-;; (defparameter bundle (make-instance 'bundle))

-;; (add-resources (bundle "af_") -;; "showtime" "Dankie, die tyd is ~:@U~%")

-;; ;; an empty string as the locale matcher becomes the default -;; (add-resources (bundle "") -;; "showtime" "Thanks, the time is ~:@U~%") - -;; (set-dispatch-macro-character -;; ## #\i -;; #'(lambda (s c1 c2) -;; (declare (ignore c2)) -;; `(cl-l10n:gettext ,(read s) bundle))) - -;; or this -;; (defmacro _ (text) -;; `(cl-l10n:gettext ,text bundle)) - -;; (defun timey () -;; (format t #i"showtime" (get-universal-time))) - -(defclass bundle () - ((resources :accessor resources :initform (make-hash-table :test #'equal)))) - -(defgeneric add-resource (bundle from to lang)) -(defmethod add-resource (bundle from to lang) - (aif (assoc lang (gethash from (resources bundle)) :test #'equal) - (setf (cdr it) to) - (pushnew (cons lang to) (gethash from (resources bundle)) - :test #'equal)) - t) - -(defmacro add-resources ((bundle loc-name) &body args) - (with-gensyms (gloc gbundle) - `(let ((,gloc ,loc-name) (,gbundle ,bundle)) - ,@(mapcar #'(lambda (x) `(add-resource ,gbundle ,@x ,gloc)) - (group args 2))))) - -(defgeneric get-name (bundle name) - (:method ((bundle t) (name t)) - (gethash name (resources bundle)))) - -(defgeneric lookup-name (bundle name) - (:method ((bundle t) (name t)) - (when-let (name (get-name bundle name)) - ;; The match with the longest name is the most - ;; specific key. - (winner #'> - (load-time-value (compose #'length #'car)) - (remove-if-not #'(lambda (x) - (search (car x) - (locale-name *locale*))) - name))))) - -(defun gettext (name bundle &optional (loc *locale*)) - (let ((*locale* (locale-des->locale loc))) - (or (cdr (lookup-name bundle name)) - name))) +(defgeneric localize (object) + (:documentation "Override this generic method for various data types. Return (values result foundp)."))

+(defmethod localize ((str string)) + (lookup-resource str nil))

- - -;; EOF +(defmethod localize ((str symbol)) + (lookup-resource str nil)) --- /project/cl-l10n/cvsroot/cl-l10n/load-locale.lisp 2006/06/06 14:58:46 1.16 +++ /project/cl-l10n/cvsroot/cl-l10n/load-locale.lisp 2006/06/08 09:38:19 1.17 @@ -5,23 +5,69 @@ (defparameter *ignore-categories* (list "LC_CTYPE" "LC_COLLATE"))

+(defparameter *language->default-locale-name* (make-hash-table :test #'equal) + "This map specifies what is the default locale for locale specifications without a region (i.e. en_US for en)") + +(deftype locale-descriptor () + `(or locale string symbol)) + +(defun canonical-locale-name-from (locale) + (check-type locale locale-descriptor) + (if (typep locale 'locale) + (locale-name locale) + (let ((name locale)) + (when (and (not (null name)) + (symbolp name)) + (setf name (symbol-name name))) + (let* ((parts (split "_" name)) + (count (list-length parts)) + (first-length (length (first parts))) + (second-length (length (second parts)))) + (when (> count 2) + (error "Locale variants are not yet supported")) + (when (or (> first-length 3) + (< first-length 2) + (and (> count 1) + (or (> second-length 3) + (< second-length 2)))) + (error "~A is not a valid locale name (examples: en_GB, en_US, en)" locale)) + (let ((language (string-downcase (first parts))) + (region (when (> count 1) + (second parts)))) + (if (> count 1) + (concatenate 'string language "_" region) + (aif (gethash language *language->default-locale-name*) + it + (concatenate 'string language "_" (string-upcase language))))))))) + +;; set up the default region mappings while loading +(eval-when (:load-toplevel :execute) + (loop for (language locale) in + '((en "en_US")) do + (setf (gethash (string-downcase (symbol-name language)) *language->default-locale-name*) + (canonical-locale-name-from locale))) + (values)) + ;; Add a restart here? (defun locale (loc-name &key (use-cache t) (errorp t) (loader nil)) - "Find locale named by the string LOC-NAME. If USE-CACHE + "Find locale named by the specification LOC-NAME. If USE-CACHE is non-nil forcefully reload the locale from *locale-path* else the locale is first looked for in *locales*. If ERRORP is non-nil signal a warning rather than an error if the locale file cannot be found. If LOADER is non-nil skip everything and call loader with LOC-NAME." - (let ((name (aif (position #. loc-name) - (subseq loc-name 0 it) - loc-name))) - (acond ((and (not name) (not errorp)) nil) - ((and use-cache (get-locale name)) it) - (loader (setf (get-locale name) (funcall loader name))) - ((probe-file (merge-pathnames *locale-path* name)) - (setf (get-locale name) (load-locale name))) - (t (funcall (if errorp #'error #'warn) - "Can't find locale ~A." name))))) + (if (typep loc-name 'locale) + loc-name + (let ((name (canonical-locale-name-from + (aif (position #. loc-name) + (subseq loc-name 0 it) + loc-name)))) + (acond ((and (not name) (not errorp)) nil) + ((and use-cache (get-locale name)) it) + (loader (setf (get-locale name) (funcall loader name))) + ((probe-file (merge-pathnames *locale-path* name)) + (setf (get-locale name) (load-locale name))) + (t (funcall (if errorp #'error #'warn) + "Can't find locale ~A." name))))))

(defvar *locale-type* 'locale "The class of loaded locales.") @@ -29,18 +75,6 @@ (defvar *category-type* 'category "The class of loaded categories")

-(deftype locale-descriptor () - `(or locale string symbol)) - -(defun locale-des->locale (loc) - "Turns a locale descriptor(a string, symbol or locale) into an -actual locale object." - (check-type loc locale-descriptor) - (etypecase loc - (locale loc) - (string (locale loc)) - (symbol (locale (string loc))))) - (defun load-locale (name) (let ((path (merge-pathnames *locale-path* name)) (ef #+sbcl :iso-8859-1 @@ -360,16 +394,26 @@ (return-from next-header (trim line)))))

(defun set-locale (locale-des) - (setf *locale* (locale-des->locale locale-des))) + (setf *locale* (if (listp locale-des) + (loop for locale in locale-des + collect (locale locale)) + (locale locale-des)))) + +(defmacro with-locale (locale &body body) + `(let ((*locale* (locale ,locale))) + ,@body))

(defun load-default-locale () - (setf *locale* (get-default-locale))) + (set-locale (get-default-locale)))

(defun get-default-locale () - (or (locale (getenv "CL_LOCALE") :errorp nil) - (locale (getenv "LC_CTYPE") :errorp nil) - (locale (getenv "LANG") :errorp nil) - (locale "POSIX" :errorp nil))) + (macrolet ((try (name) + `(when-let (it (getenv ,name)) + (locale it :errorp nil)))) + (or (try "CL_LOCALE") + (try "LC_CTYPE") + (try "LANG") + (locale "POSIX" :errorp nil))))

(eval-when (:load-toplevel :execute) (load-default-locale)) --- /project/cl-l10n/cvsroot/cl-l10n/locale.lisp 2006/04/27 18:30:30 1.12 +++ /project/cl-l10n/cvsroot/cl-l10n/locale.lisp 2006/06/08 09:38:19 1.13 @@ -16,7 +16,14 @@ (merge-pathnames (make-pathname :directory '(:relative "locales")) (asdf:component-pathname (asdf:find-system :cl-l10n))))

-(defvar *locale* nil) +(defvar *locale* nil + "Either a locale or a list of locales in which case resources will be looked for in each locale in order.") + +(defun current-locale () + (declare (inline current-locale)) + (if (consp *locale*) + (car *locale*) + *locale*))

(defvar *locales* (make-hash-table :test #'equal) "Hash table containing all loaded locales keyed on name (eg. "af_ZA")") @@ -101,8 +108,8 @@ (defmacro defgetter (key cat &key (wrap '#'identity)) (let ((name (symb "LOCALE-" (substitute #- #_ (string-upcase key))))) `(progn - (defun ,name (&optional (locale *locale*)) - (let ((locale (locale-des->locale locale))) + (defun ,name (&optional (locale (current-locale))) + (let ((locale (locale locale))) (when locale (funcall ,wrap (locale-value locale ,cat ,key))))) (export ',name)))) --- /project/cl-l10n/cvsroot/cl-l10n/package.lisp 2006/04/27 18:30:30 1.8 +++ /project/cl-l10n/cvsroot/cl-l10n/package.lisp 2006/06/08 09:38:19 1.9 @@ -7,12 +7,16 @@ (:shadow cl:format cl:formatter) (:export #:locale-name #:category-name #:locale #:category #:locale-error #:get-category #:get-cat-val #:locale-value #:load-all-locales - #:*locale* #:*locale-path* #:*locales* #:load-default-locale + #:get-locale #:*locale-path* #:*locales* #:load-default-locale #:format-number #:print-number #:format-money #:print-money - #:format-time #:print-time #:add-resources #:bundle - #:add-resource #:gettext #:parse-number #:*float-digits* + #:format-time #:print-time #:add-resources + #:parse-number #:*float-digits* #:parse-time #:month #:day #:year #:hour #:minute #:second #:date-divider #:time-divider #:weekday #:noon-midn #:shadow-format - #:secondp #:am-pm #:zone #:parser-error #:set-locale)) + #:secondp #:am-pm #:zone #:parser-error #:set-locale + #:with-locale #:lookup-resource + #:lookup-resource-without-fallback #:localize + #:missing-resource #:defresources #:enable-sharpquote-reader + #:with-sharpquote-reader))

--- /project/cl-l10n/cvsroot/cl-l10n/parse-time.lisp 2006/04/27 18:30:30 1.3 +++ /project/cl-l10n/cvsroot/cl-l10n/parse-time.lisp 2006/06/08 09:38:19 1.4 @@ -600,7 +600,7 @@ ;; patterns have not been explicitly specified so we try ;; to match against locale a specific date pattern first. ;; eg. 03/04/2005 is 3rd April in UK but 4 March in US. - (dolist (pattern (parsers *locale*)) + (dolist (pattern (parsers (current-locale))) (let ((res (match-pattern pattern string-parts parts-length))) @@ -620,7 +620,7 @@ (default-hours nil) (default-day nil) (default-month nil) (default-year nil) (default-zone nil) (default-weekday nil) - (locale *locale*)) + (locale (current-locale))) "Tries very hard to make sense out of the argument time-string using locale and returns a single integer representing the universal time if successful. If not, it returns nil. If the :error-on-mismatch @@ -630,21 +630,21 @@ keywords can be given a numeric value or the keyword :current to set them to the current value. The default-default values are 00:00:00 on the current date, current time-zone." - (let* ((*error-on-mismatch* error-on-mismatch) - (*locale* (locale-des->locale locale)) - (string-parts (decompose-string time-string :start start :end end)) - (parts-length (length string-parts)) - (string-form (get-matching-pattern patterns string-parts parts-length))) - (if string-form - (let ((parsed-values (make-default-time default-seconds default-minutes - default-hours default-day - default-month default-year - default-zone default-weekday))) - (set-time-values string-form parsed-values) - (convert-to-unitime parsed-values)) - (if *error-on-mismatch* - (error 'parser-error :value time-string :reason "Not a recognized time/date format.") - nil)))) + (with-locale locale + (let* ((*error-on-mismatch* error-on-mismatch) + (string-parts (decompose-string time-string :start start :end end)) + (parts-length (length string-parts)) + (string-form (get-matching-pattern patterns string-parts parts-length))) + (if string-form + (let ((parsed-values (make-default-time default-seconds default-minutes + default-hours default-day + default-month default-year + default-zone default-weekday))) + (set-time-values string-form parsed-values) + (convert-to-unitime parsed-values)) + (if *error-on-mismatch* + (error 'parser-error :value time-string :reason "Not a recognized time/date format.") + nil)))))

; EOF --- /project/cl-l10n/cvsroot/cl-l10n/parsers.lisp 2005/05/18 15:34:08 1.4 +++ /project/cl-l10n/cvsroot/cl-l10n/parsers.lisp 2006/06/08 09:38:20 1.5 @@ -1,7 +1,7 @@ (in-package :cl-l10n)

-(defun parse-number (num &optional (locale *locale*)) - (let ((locale (locale-des->locale locale))) +(defun parse-number (num &optional (locale (current-locale))) + (let ((locale (locale locale))) (%parse-number (replace-dp (remove-ts num locale) locale))))

(defun remove-ts (num locale) --- /project/cl-l10n/cvsroot/cl-l10n/printers.lisp 2006/04/27 18:30:30 1.17 +++ /project/cl-l10n/cvsroot/cl-l10n/printers.lisp 2006/06/08 09:38:20 1.18 @@ -21,8 +21,8 @@ (princ "0" s)))))

(defun format-number (stream arg no-dp no-ts - &optional (locale *locale*)) - (let ((locale (locale-des->locale locale)) + &optional (locale (current-locale))) + (let ((locale (locale locale)) (float-part (float-part (coerce (abs arg) 'double-float)))) (cl:format stream (getf (printers locale) @@ -35,7 +35,7 @@ (values)))

(defun print-number (number &key (stream *standard-output*) - no-ts no-dp (locale *locale*)) + no-ts no-dp (locale (current-locale))) (format-number stream number no-dp no-ts locale) number)

@@ -60,8 +60,8 @@ :money-p-no-ts :money-p-ts)))

-(defun format-money (stream arg use-int-sym no-ts &optional (locale *locale*)) - (let* ((locale (locale-des->locale locale)) +(defun format-money (stream arg use-int-sym no-ts &optional (locale (current-locale))) + (let* ((locale (locale locale)) (frac-digits (max (if use-int-sym (locale-int-frac-digits locale) (locale-frac-digits locale)) @@ -85,7 +85,7 @@ (values))

(defun print-money (num &key (stream *standard-output*) use-int-sym no-ts - (locale *locale*)) + (locale (current-locale))) (format-money stream num use-int-sym no-ts locale) num)

@@ -119,15 +119,16 @@

(defun princ-pad-val (val stream &optional (pad "0") (size 2)) (declare (type stream stream) (optimize speed) - (type fixnum val)) + (type fixnum val size)) (assert (not (minusp val)) (val) "Value ~A cannot be smaller than 0." val) (cond ((zerop val) (dotimes (x (1- size)) (princ pad stream)) (princ 0 stream)) (t - (loop for x = (* val 10) then (* x 10) - until (>= x (expt 10 size)) do + (loop with stop-value = (expt 10 size) + for x integer = (* val 10) then (* x 10) + until (>= x stop-value) do (princ pad stream)) (princ val stream))))

@@ -316,8 +317,8 @@

(defvar *time-zone*)

-(defun format-time (stream ut show-date show-time &optional (locale *locale*) fmt time-zone) - (let ((locale (locale-des->locale (or locale *locale*))) +(defun format-time (stream ut show-date show-time &optional (locale (current-locale)) fmt time-zone) + (let ((locale (locale locale)) (*time-zone* (or time-zone (nth-value 8 (decode-universal-time ut))))) (print-time-string (or fmt (get-time-fmt-string locale show-date show-time)) @@ -348,7 +349,7 @@ (princ x stream)))))))

(defun print-time (ut &key show-date show-time (stream *standard-output*) - (locale *locale*) fmt time-zone) + (locale (current-locale)) fmt time-zone) (format-time stream ut show-date show-time locale fmt time-zone) ut)

@@ -386,7 +387,7 @@ string))

(defun really-parse-fmt-string (string) - (declare (optimize speed) (type string string)) + (declare (optimize speed) (type simple-string string)) (with-output-to-string (fmt-string) (loop for char across string with tilde = nil do