/[cl-l10n]/cl-l10n/load-locale.lisp
ViewVC logotype

Diff of /cl-l10n/load-locale.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.1.1.1 by sross, Mon Nov 29 09:56:55 2004 UTC revision 1.19 by alendvai, Thu Jun 15 22:56:18 2006 UTC
# Line 3  Line 3 
3  (in-package :cl-l10n)  (in-package :cl-l10n)
4    
5  (defparameter *ignore-categories*  (defparameter *ignore-categories*
6    (list  "LC_CTYPE"  "LC_COLLATE"))    (list "LC_CTYPE" "LC_COLLATE"))
7    
8  (defun locale (loc-name &key (use-cache t) (errorp t))  (defparameter *language->default-locale-name* (make-hash-table :test #'equal)
9    (let ((name (aif (position #\. loc-name)    "This map specifies what is the default locale for locale specifications without a region (i.e. en_US for en)")
10                     (subseq loc-name 0 it)  
11                     loc-name)))  (deftype locale-descriptor ()
12      (acond ((and (not name) (not errorp)) "No Locale NIL.")    `(or locale string symbol))
13             ((and use-cache (get-locale name)) it)  
14             ((probe-file (merge-pathnames *locale-path* name))  (defun canonical-locale-name-from (locale)
15              (load-locale name))    (check-type locale locale-descriptor)
16             ((not errorp) (warn "Can't find locale ~A." name))    (if (typep locale 'locale)
17             (errorp (locale-error "Can't find locale ~A." name)))))        (locale-name locale)
18          (let ((name locale))
19            (when (and (not (null name))
20                       (symbolp name))
21              (setf name (symbol-name name)))
22            (let* ((parts (split "_" name))
23                   (count (list-length parts))
24                   (first-length (length (first parts)))
25                   (second-length (length (second parts))))
26              (when (> count 2)
27                (error "Locale variants are not yet supported"))
28              (when (or (> first-length 3)
29                        (< first-length 2)
30                        (and (> count 1)
31                             (or (> second-length 3)
32                                 (< second-length 2))))
33                (error "~A is not a valid locale name (examples: en_GB, en_US, en)" locale))
34              (let ((language (string-downcase (first parts)))
35                    (region (when (> count 1)
36                              (second parts))))
37                (if (> count 1)
38                    (concatenate 'string language "_" region)
39                    (aif (gethash language *language->default-locale-name*)
40                         it
41                         (concatenate 'string language "_" (string-upcase language)))))))))
42    
43    ;; set up the default region mappings while loading
44    (eval-when (:load-toplevel :execute)
45      (loop for (language locale) in
46            '((en "en_US")) do
47            (setf (gethash (string-downcase (symbol-name language)) *language->default-locale-name*)
48                  (canonical-locale-name-from locale)))
49      (values))
50    
51    ;; Add a restart here?
52    (defun locale (loc-name &key (use-cache t) (errorp t) (loader nil))
53      "Find locale named by the specification LOC-NAME. If USE-CACHE
54    is non-nil forcefully reload the locale from *locale-path* else
55    the locale is first looked for in *locales*. If ERRORP is non-nil
56    signal a warning rather than an error if the locale file cannot be found.
57    If LOADER is non-nil skip everything and call loader with LOC-NAME."
58      (if (typep loc-name 'locale)
59          loc-name
60          (let ((name (canonical-locale-name-from
61                       (aif (position #\. loc-name)
62                            (subseq loc-name 0 it)
63                            loc-name))))
64            (acond ((and (not name) (not errorp)) nil)
65                   ((and use-cache (get-locale name)) it)
66                   (loader (setf (get-locale name) (funcall loader name)))
67                   ((probe-file (merge-pathnames *locale-path* name))
68                    (setf (get-locale name) (load-locale name)))
69                   (t (funcall (if errorp #'error #'warn)
70                               "Can't find locale ~A." name))))))
71    
72    (defvar *locale-type* 'locale
73      "The class of loaded locales.")
74    
75    (defvar *category-type* 'category
76      "The class of loaded categories")
77    
78  (defun load-locale (name)  (defun load-locale (name)
79    (let ((path (merge-pathnames *locale-path* name)))    (let ((path (merge-pathnames *locale-path* name))
80      (format t ";; Loading locale from ~A.~%" path)          (ef #+sbcl :iso-8859-1
81      (let ((locale (make-instance 'locale :name name))              #+clisp (ext:make-encoding :charset 'charset:iso-8859-1
82            (*read-eval* nil)                                         :line-terminator :unix)
83            (*print-circle* nil))              #-(or sbcl clisp) :default))
84        (with-open-file (stream path      (cl:format *debug-io* "~&;; Loading locale from ~A.~%" path)
85                         :external-format #+sbcl :latin1 #-sbcl :default)      (let ((locale (make-instance *locale-type* :name name)))
86          (with-open-file (stream path :external-format ef)
87          (multiple-value-bind (escape comment) (munge-headers stream)          (multiple-value-bind (escape comment) (munge-headers stream)
88            (awhile (next-header stream)            (loop for header = (next-header stream)
89              (awhen (make-category locale it (parse-category it stream                  while header do
90                                                              escape comment))                  (when-bind cat (make-category locale header
91                (setf (get-category (category-name it) locale) it)))))                                                (parse-category header stream
92        (setf (get-locale name) locale))))                                                                escape comment))
93                      (setf (get-category locale header) cat)))))
94  (defun load-all-locales (&optional (path *locale-path*))        (add-printers locale)
95    (dolist (x (directory (merge-pathnames path "*")))        (add-parsers locale)
96      (load-locale (pathname-name x))))        locale)))
97    
98    (defun load-all-locales (&key (path *locale-path*) (ignore-errors nil) (use-cache nil))
99      "Load all locale found in pathname designator PATH."
100      (let ((*locale-path* path))
101        (dolist (x (list-directory *locale-path*))
102          (when (and (not (directory-pathname-p x)) (pathname-name x))
103            (let ((locale (pathname-name x)))
104              (with-simple-restart (continue "Ignore locale ~A." x)
105                (handler-bind ((error (lambda (&optional c)
106                                        (when ignore-errors
107                                          (warn "Failed to load locale ~S, Ignoring." locale)
108                                          (invoke-restart (find-restart 'continue c))))))
109                  (locale locale :use-cache use-cache))))))))
110    
111    (defvar *default-thousands-sep* #\,)
112    
113    (defun thousands-sep-char (sep)
114      (if (> (length sep) 0)
115          (schar sep 0)
116          *default-thousands-sep*))
117    
118    (defun create-number-fmt-string (locale no-ts)
119      (cl:format nil "~~A~~,,'~A,~A~A~~{~~A~~}"
120                 (thousands-sep-char (locale-thousands-sep locale))
121                 (if (minusp (locale-grouping locale)) 3 (locale-grouping locale))
122                 (if no-ts "D" ":D")))
123    
124    (defun get-descriptors (minusp locale)
125      (if minusp
126          (values (locale-n-sep-by-space locale)
127                  (= 1 (locale-n-cs-precedes locale))
128                  (locale-n-sign-posn locale)
129                  (locale-negative-sign locale))
130          (values (locale-p-sep-by-space locale)
131                  (= 1 (locale-p-cs-precedes locale))
132                  (locale-p-sign-posn locale)
133                  (locale-positive-sign locale))))
134    
135    (defun create-money-fmt-string (locale no-ts minusp)
136      (multiple-value-bind (sep-by-space prec spos sign)
137          (get-descriptors minusp locale)
138        (let ((sym-sep (if (zerop sep-by-space) "" " ")))
139          (with-output-to-string (stream)
140            ;; sign and sign separator
141            (when (or* (= spos 0 1 3))
142              (princ (if (zerop spos) "(" sign) stream)
143              (when (= 2 sep-by-space)
144                (princ #\Space stream)))
145            ;; Sym and seperator
146            (princ "~A" stream)
147            (when prec
148              (princ sym-sep stream))
149            ;; Actual number
150            (cl:format stream "~~,,'~A,~A~A~~{~~A~~}"
151                       (thousands-sep-char (locale-mon-thousands-sep locale))
152                       (if (minusp (locale-mon-grouping locale)) 3 (locale-mon-grouping locale))
153                       (if no-ts "D" ":D"))
154            (unless prec
155              (princ sym-sep stream))
156            (princ "~A" stream)
157            (when (or* (= spos 0 2 4))
158              (when (= 2 sep-by-space)
159                (princ #\Space stream))
160              (princ (if (zerop spos) ")" sign) stream))))))
161    
162    (defun add-printers (locale)
163      "Creates monetary and numeric format strings for locale LOCALE."
164      (when (and (get-category locale "LC_MONETARY")
165                 (get-category locale "LC_NUMERIC"))
166        ;; otherwise its an include locale (tranlit* etc)
167        (setf (printers locale)
168              (nconc (list :number-no-ts
169                           (create-number-fmt-string locale t))
170                     (list :number-ts
171                           (create-number-fmt-string locale nil))
172                     (list :money-p-no-ts
173                           (create-money-fmt-string locale t nil))
174                     (list :money-p-ts
175                           (create-money-fmt-string locale nil nil))
176                     (list :money-n-no-ts
177                           (create-money-fmt-string locale t t))
178                     (list :money-n-ts
179                           (create-money-fmt-string locale nil t))
180                     (printers locale)))))
181    
182    (defun day-element-p (x)
183      (member x '(#\d #\e)))
184    
185    (defun month-element-p (x)
186      (member x '(#\m #\b #\B)))
187    
188    (defun year-element-p (x)
189      (member x '(#\y #\Y)))
190    
191    (defun element-type (char)
192      (cond ((day-element-p char) 'day)
193            ((month-element-p char) 'month)
194            ((year-element-p char) 'year)))
195    
196    (defvar date-dividers '(#\\ #\/ #\-))
197    
198    ;; FIXME
199    ;; this effort definitely doesn't cover
200    ;; every single case but it will do for now.
201    (defun locale-date-month-order (locale)
202      (let ((fmt (locale-d-fmt locale)))
203        (cond ((string= fmt "%D") '(month day year))
204              ((string= fmt "%F") '(year month day))
205              (t (compute-order fmt)))))
206    
207    (defun compute-order (fmt)
208      (let ((res nil))
209        (loop for char across fmt
210              with perc = nil
211              with in-dot = nil do
212              (cond ((char= char #\%) (setf perc (not perc)))
213                    ((member char date-dividers) nil)
214                    ((and perc (char= char #\.))  (setf in-dot t))
215                    ((and perc in-dot (char= char #\1))
216                     (setf in-dot nil))
217                    (perc (unless (char= char #\E)
218                            ;; some locales (eg lo_LA) have this funny E before
219                            ;; various time format designators. Debian
220                            ;; treats this as if it wasn't there so neither do we.
221                            (let ((val (element-type char)))
222                              (when val (push val res))
223                              (setf perc nil))))))
224        (nreverse res)))
225    
226    (defun add-parsers (locale)
227      (when (get-category locale "LC_TIME")
228        (destructuring-bind (first second third)
229            (locale-date-month-order locale)
230          (setf (parsers locale)
231                (list `((noon-midn) (weekday) ,first (date-divider) ,second (date-divider) ,third (noon-midn))
232                      `((weekday) ,first (date-divider) ,second (date-divider) ,third hour (time-divider) minute
233                        (time-divider) (secondp) (am-pm) (date-divider) (zone))
234                      `(hour (time-divider) minute (time-divider) (secondp) (am-pm) (weekday) ,first (date-divider)
235                             (secondp) (date-divider) ,third (date-divider) (zone)))))))
236    
237  (defvar *category-loaders*  (defvar *category-loaders*
238    '(("LC_IDENTIFICATION" . load-identification)    '(("LC_IDENTIFICATION" . load-identification)
# Line 45  Line 244 
244      ("LC_TELEPHONE" . load-category)      ("LC_TELEPHONE" . load-category)
245      ("LC_MEASUREMENT" . load-category)      ("LC_MEASUREMENT" . load-category)
246      ("LC_NAME" . load-category)      ("LC_NAME" . load-category)
247      ("LC_ADDRESS" . load-category)))      ("LC_ADDRESS" . load-category))
248      "Map of category names to the function which will load them.")
249    
250  (defun get-loader (name)  (defun get-loader (name)
251    (cdr (assoc name *category-loaders* :test #'string=)))    (cdr (assoc name *category-loaders* :test #'string=)))
# Line 54  Line 254 
254    (awhen (get-loader name)    (awhen (get-loader name)
255      (funcall it locale name vals)))      (funcall it locale name vals)))
256    
257  (defun load-category (locale name vals)  (defgeneric load-category (locale name vals)
258    (declare (ignore locale))    (:documentation "Load a category for LOCALE using VALS.")
259    (let ((cat (make-instance 'category :name name)))    (:method ((locale locale) (name string) (vals category))
260      (typecase vals      vals)
261        (category vals)    (:method ((locale locale) (name string) (vals cons))
262        (t (dolist (x vals)      (let ((cat (make-instance *category-type* :name name)))
263             (setf (get-cat-val (car x) cat) (cdr x)))        (dolist (x vals)
264           cat))))          (setf (category-value cat (car x)) (cdr x)))
265          cat)))
266    
267  (defvar *id-vals*  (defvar *id-vals*
268    '(("title" . title)    '(("title" . title)
# Line 71  Line 272 
272      ("revision" . revision)      ("revision" . revision)
273      ("date" . date)      ("date" . date)
274      ("categories" . categories)))      ("categories" . categories)))
   
275    
276  (defun load-identification (locale name vals)  (defun load-identification (locale name vals)
277    (declare (ignore name))    (declare (ignore name))
278    (dolist (x *id-vals*)    (dolist (x *id-vals*)
279      (aif (cdr (assoc (car x) vals :test #'string=))      (aif (cdr (assoc (car x) vals :test #'string=))
280           (setf (slot-value locale (cdr x))           (setf (slot-value locale (cdr x))
281                 (read-from-string it nil "")))))                 (remove #\" it)))))
282    
283  (defun line-comment-p (line comment)  (defun line-comment-p (line comment)
284    (or (string= line "")    (or (string= line "")
285        (and (> (length line) 0) ;; Ignore a comment line        (and (> (length line) 0)
286             (char= (schar line 0) comment))))             (char= (schar line 0) comment))))
287    
288    
# Line 90  Line 290 
290    (let ((from (trim (subseq line (position #\Space line))    (let ((from (trim (subseq line (position #\Space line))
291                      (cons #\" *whitespace*))))                      (cons #\" *whitespace*))))
292      (handler-case (let* ((locale (locale from)))      (handler-case (let* ((locale (locale from)))
293                      (or (get-category cat locale)                      (or (get-category locale cat)
294                          (locale-error "No category ~A in locale ~A."                          (locale-error "No category ~A in locale ~A."
295                                        cat from)))                                        cat from)))
296        (error (c) (locale-error "Unable to copy Category ~A from ~A. ~A."        (error (c) (locale-error "Unable to copy Category ~A from ~A. ~A."
297                                 cat from c)))))                                 cat from c)))))
298    
299  (defun parse-category (name stream escape comment)  (defun parse-category (name stream escape comment)
300    (let ((end (mkstr "END " name))    (let ((end (strcat "END " name))
301          (ret nil))          (ret nil))
302      (loop for line = (read-line stream nil stream)      (loop for line = (read-line stream nil stream)
303            until (eq line stream) do            until (eq line stream) do
# Line 129  Line 329 
329                     (schar (cdr (get-value line stream escape)) 0)))))                     (schar (cdr (get-value line stream escape)) 0)))))
330      (values escape comment-char)))      (values escape comment-char)))
331    
   
   
332  (defun get-full-line (line stream escape)  (defun get-full-line (line stream escape)
333    (let ((length (length line)))    (let ((length (length line)))
334      (if (char= (elt line (1- length)) escape)      (if (char= (elt line (1- length)) escape)
# Line 145  Line 343 
343                               escape)))                               escape)))
344          line)))          line)))
345    
346    (defun real-value (string)
347  (defun real-character (char)    (loop for char across string
348    (let ((int (parse-integer (trim char (list* #\U #\> #\< *whitespace*))          with in-special = nil
349                              :radix 16)))          with result = ()
350      (handler-case (code-char int)          with special-val = () do
351        (type-error (c)          (cond ((eql char #\") nil) ;;ignore
352          (declare (ignore c))                ((eql char #\<) (setf in-special t))
353          (locale-error "Cannot represent ~A as a character." int)))))                ((and in-special (eql char #\>))
354                   (push (code-char
355  (defvar *regex* '(:sequence                        (parse-integer (coerce (cdr (nreverse special-val)) 'string)
356                    #\<                                       :radix 16))
357                    (:greedy-repetition 0 nil                       result)
358                     (:inverted-char-class #\> #\<)                 (setf in-special nil
359                     :everything)                       special-val nil))
360                    #\>))                (in-special (push char special-val))
361                  (t (push char result)))
362  (defun old-real-value (val)          finally (return (coerce (nreverse result)
363    (aif (all-matches-as-strings *regex* val)                                  #-lispworks 'string
364         (map #-lispworks 'string #+lispworks                                  #+lispworks 'lw:text-string))))
365              'lw:text-string #'real-character it)  
366         val))  (defvar *split-scanner*
367      (cl-ppcre:create-scanner '(:char-class #\;)))
368  ;; KLUDGE  
 (defun real-value (val)  
   (let ((val (old-real-value val)))  
     (if (string= val "\"\"")  
         ""  
         val)))  
   
   
369  (defun parse-value (val)  (defun parse-value (val)
370    (let ((all-vals (split '(:char-class #\;) val)))    (let ((all-vals (split *split-scanner* val)))
371      (if (singlep all-vals)      (if (singlep all-vals)
372          (real-value (car all-vals))          (real-value (car all-vals))
373          (mapcar #'real-value all-vals))))          (mapcar #'real-value all-vals))))
# Line 197  Line 388 
388    (loop for line = (read-line stream nil stream)    (loop for line = (read-line stream nil stream)
389          until (eq line stream) do          until (eq line stream) do
390      (if (and (> (length line) 3) (search "LC_" line :end2 3)      (if (and (> (length line) 3) (search "LC_" line :end2 3)
391               (not (some #'(lambda (x)               (notany #'(lambda (x)
392                              (search x line :test #'string=))                           (search x line :test #'string=))
393                          *ignore-categories*)))                       *ignore-categories*))
394          (return-from next-header line))))          (return-from next-header (trim line)))))
395    
396    (defun set-locale (locale-des)
397      (setf *locale* (if (listp locale-des)
398                         (loop for locale in locale-des
399                               collect (locale locale))
400                         (locale locale-des))))
401    
402    (defmacro with-locale (locale &body body)
403      (rebinding (locale)
404        `(let ((*locale* (if (consp ,locale)
405                             ,locale
406                             (locale ,locale))))
407          ,@body)))
408    
409  (defun load-default-locale ()  (defun load-default-locale ()
410    (setf *locale* (get-default-locale)))    (set-locale (get-default-locale)))
411    
412  (defun get-default-locale ()  (defun get-default-locale ()
413    (or (locale (getenv "CL_LOCALE") :errorp nil)    (macrolet ((try (name)
414        (locale (getenv "LC_CTYPE") :errorp nil)                 `(awhen (getenv ,name)
415        (locale "POSIX")))                   (locale it :errorp nil))))
416        (or (try "CL_LOCALE")
417  (load-default-locale)          (try "LC_CTYPE")
418            (try "LANG")
419            (locale "POSIX" :errorp nil))))
420    
421    (eval-when (:load-toplevel :execute)
422      (load-default-locale))
423    
 ;; EOF  
424    ;; EOF

Legend:
Removed from v.1.1.1.1  
changed lines
  Added in v.1.19

  ViewVC Help
Powered by ViewVC 1.1.5