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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.19 - (hide annotations)
Thu Jun 15 22:56:18 2006 UTC (7 years, 10 months ago) by alendvai
Branch: MAIN
CVS Tags: HEAD
Changes since 1.18: +5 -2 lines
Some fixes
1 sross 1.1 ;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
2     ;; See the file LICENCE for licence information.
3     (in-package :cl-l10n)
4    
5     (defparameter *ignore-categories*
6 sross 1.8 (list "LC_CTYPE" "LC_COLLATE"))
7 sross 1.1
8 alendvai 1.17 (defparameter *language->default-locale-name* (make-hash-table :test #'equal)
9     "This map specifies what is the default locale for locale specifications without a region (i.e. en_US for en)")
10    
11     (deftype locale-descriptor ()
12     `(or locale string symbol))
13    
14     (defun canonical-locale-name-from (locale)
15     (check-type locale locale-descriptor)
16     (if (typep locale 'locale)
17     (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 sross 1.8 ;; Add a restart here?
52 sross 1.10 (defun locale (loc-name &key (use-cache t) (errorp t) (loader nil))
53 alendvai 1.17 "Find locale named by the specification LOC-NAME. If USE-CACHE
54 sross 1.8 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 sross 1.10 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 alendvai 1.17 (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 sross 1.8
72     (defvar *locale-type* 'locale
73     "The class of loaded locales.")
74    
75     (defvar *category-type* 'category
76     "The class of loaded categories")
77 sross 1.1
78     (defun load-locale (name)
79 sross 1.15 (let ((path (merge-pathnames *locale-path* name))
80     (ef #+sbcl :iso-8859-1
81     #+clisp (ext:make-encoding :charset 'charset:iso-8859-1
82     :line-terminator :unix)
83     #-(or sbcl clisp) :default))
84 sross 1.10 (cl:format *debug-io* "~&;; Loading locale from ~A.~%" path)
85 sross 1.13 (let ((locale (make-instance *locale-type* :name name)))
86 sross 1.15 (with-open-file (stream path :external-format ef)
87 sross 1.1 (multiple-value-bind (escape comment) (munge-headers stream)
88 sross 1.13 (loop for header = (next-header stream)
89     while header do
90 alendvai 1.18 (when-bind cat (make-category locale header
91     (parse-category header stream
92     escape comment))
93     (setf (get-category locale header) cat)))))
94 sross 1.7 (add-printers locale)
95 sross 1.12 (add-parsers locale)
96 sross 1.10 locale)))
97 sross 1.1
98 sross 1.13 (defun load-all-locales (&key (path *locale-path*) (ignore-errors nil) (use-cache nil))
99 sross 1.8 "Load all locale found in pathname designator PATH."
100     (let ((*locale-path* path))
101 sross 1.13 (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 sross 1.1
111 sross 1.9 (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 sross 1.7
118     (defun create-number-fmt-string (locale no-ts)
119 sross 1.9 (cl:format nil "~~A~~,,'~A,~A~A~~{~~A~~}"
120     (thousands-sep-char (locale-thousands-sep locale))
121 sross 1.15 (if (minusp (locale-grouping locale)) 3 (locale-grouping locale))
122 sross 1.7 (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 sross 1.9 (thousands-sep-char (locale-mon-thousands-sep locale))
152 sross 1.15 (if (minusp (locale-mon-grouping locale)) 3 (locale-mon-grouping locale))
153 sross 1.7 (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 sross 1.8 "Creates monetary and numeric format strings for locale LOCALE."
164 sross 1.13 (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 sross 1.7
182 sross 1.12 (defun day-element-p (x)
183     (member x '(#\d #\e)))
184    
185     (defun month-element-p (x)
186 sross 1.13 (member x '(#\m #\b #\B)))
187 sross 1.12
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 sross 1.14 with perc = nil
211     with in-dot = nil do
212 sross 1.12 (cond ((char= char #\%) (setf perc (not perc)))
213     ((member char date-dividers) nil)
214 sross 1.14 ((and perc (char= char #\.)) (setf in-dot t))
215     ((and perc in-dot (char= char #\1))
216     (setf in-dot nil))
217 sross 1.13 (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 sross 1.12 (nreverse res)))
225    
226     (defun add-parsers (locale)
227 sross 1.13 (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 sross 1.12
237 sross 1.1 (defvar *category-loaders*
238     '(("LC_IDENTIFICATION" . load-identification)
239     ("LC_MONETARY" . load-category)
240     ("LC_NUMERIC" . load-category)
241     ("LC_TIME" . load-category)
242     ("LC_MESSAGES" . load-category)
243     ("LC_PAPER" . load-category)
244     ("LC_TELEPHONE" . load-category)
245     ("LC_MEASUREMENT" . load-category)
246     ("LC_NAME" . load-category)
247 sross 1.8 ("LC_ADDRESS" . load-category))
248     "Map of category names to the function which will load them.")
249 sross 1.1
250     (defun get-loader (name)
251     (cdr (assoc name *category-loaders* :test #'string=)))
252    
253     (defun make-category (locale name vals)
254 alendvai 1.18 (awhen (get-loader name)
255     (funcall it locale name vals)))
256 sross 1.1
257 sross 1.8 (defgeneric load-category (locale name vals)
258     (:documentation "Load a category for LOCALE using VALS.")
259     (:method ((locale locale) (name string) (vals category))
260     vals)
261     (:method ((locale locale) (name string) (vals cons))
262     (let ((cat (make-instance *category-type* :name name)))
263     (dolist (x vals)
264     (setf (category-value cat (car x)) (cdr x)))
265     cat)))
266 sross 1.1
267     (defvar *id-vals*
268     '(("title" . title)
269     ("source" . source)
270     ("language" . language)
271     ("territory" . territory)
272     ("revision" . revision)
273     ("date" . date)
274     ("categories" . categories)))
275    
276     (defun load-identification (locale name vals)
277     (declare (ignore name))
278     (dolist (x *id-vals*)
279     (aif (cdr (assoc (car x) vals :test #'string=))
280     (setf (slot-value locale (cdr x))
281 sross 1.5 (remove #\" it)))))
282 sross 1.1
283     (defun line-comment-p (line comment)
284     (or (string= line "")
285 sross 1.8 (and (> (length line) 0)
286 sross 1.1 (char= (schar line 0) comment))))
287    
288    
289     (defun copy-category (cat line)
290     (let ((from (trim (subseq line (position #\Space line))
291     (cons #\" *whitespace*))))
292     (handler-case (let* ((locale (locale from)))
293 sross 1.11 (or (get-category locale cat)
294 sross 1.1 (locale-error "No category ~A in locale ~A."
295     cat from)))
296     (error (c) (locale-error "Unable to copy Category ~A from ~A. ~A."
297     cat from c)))))
298    
299     (defun parse-category (name stream escape comment)
300 alendvai 1.18 (let ((end (strcat "END " name))
301 sross 1.1 (ret nil))
302     (loop for line = (read-line stream nil stream)
303     until (eq line stream) do
304     (cond ((line-comment-p line comment))
305     ((search end line) (return-from parse-category ret))
306     ((search "END" line)
307     (locale-error "End of wrong block reached ~S. Expected ~S."
308     line end))
309     ((and (> (length line) 3) (search "copy" line :end2 4))
310     (return-from parse-category
311     (copy-category name line)))
312     (t (push (get-value line stream escape) ret))))))
313    
314     (defun munge-headers (stream)
315     (let ((escape #\\) (comment-char #\#))
316     (loop for line = (read-line stream nil stream)
317     for i from 1 do
318     ;; HACK We assume that if the escape and comment
319     ;; lines don't appear right away that they don't exist
320     ;; This is to work around lispworks being unable
321     ;; to unread a line of text character by character.
322     (cond ((> i 3) (return nil))
323     ((line-comment-p line comment-char))
324     ((search "escape_char" line)
325     (setf escape
326     (schar (cdr (get-value line stream escape)) 0)))
327     ((search "comment_char" line)
328     (setf comment-char
329     (schar (cdr (get-value line stream escape)) 0)))))
330     (values escape comment-char)))
331    
332     (defun get-full-line (line stream escape)
333     (let ((length (length line)))
334     (if (char= (elt line (1- length)) escape)
335     (let ((next-line (read-line stream nil stream)))
336     (if (eq next-line stream)
337     (locale-error "EOF Looking for next line of ~A." line)
338     (get-full-line (concatenate
339     'string
340     (subseq line 0 (1- length))
341     (trim next-line))
342     stream
343     escape)))
344     line)))
345    
346 sross 1.13 (defun real-value (string)
347     (loop for char across string
348     with in-special = nil
349     with result = ()
350     with special-val = () do
351 sross 1.15 (cond ((eql char #\") nil) ;;ignore
352 sross 1.13 ((eql char #\<) (setf in-special t))
353 sross 1.15 ((and in-special (eql char #\>))
354 sross 1.13 (push (code-char
355     (parse-integer (coerce (cdr (nreverse special-val)) 'string)
356     :radix 16))
357     result)
358     (setf in-special nil
359     special-val nil))
360     (in-special (push char special-val))
361     (t (push char result)))
362     finally (return (coerce (nreverse result)
363     #-lispworks 'string
364     #+lispworks 'lw:text-string))))
365 sross 1.1
366 sross 1.7 (defvar *split-scanner*
367     (cl-ppcre:create-scanner '(:char-class #\;)))
368    
369 sross 1.1 (defun parse-value (val)
370 sross 1.7 (let ((all-vals (split *split-scanner* val)))
371 sross 1.1 (if (singlep all-vals)
372     (real-value (car all-vals))
373     (mapcar #'real-value all-vals))))
374    
375     (defun get-value (line stream escape)
376     "Return a cons containing the key of line and its value.
377     Honors lines ending with ESCAPE"
378     (let* ((line (get-full-line line stream escape))
379     (first-space (position-if #'(lambda (x)
380     (or* (char= x #\Space #\Tab)))
381     line)))
382     (if (null first-space)
383     (locale-error "No Space in line ~A." line)
384     (cons (trim (subseq line 0 first-space))
385     (parse-value (trim (subseq line first-space)))))))
386    
387     (defun next-header (stream)
388     (loop for line = (read-line stream nil stream)
389     until (eq line stream) do
390     (if (and (> (length line) 3) (search "LC_" line :end2 3)
391 sross 1.7 (notany #'(lambda (x)
392     (search x line :test #'string=))
393     *ignore-categories*))
394 sross 1.12 (return-from next-header (trim line)))))
395 sross 1.1
396 sross 1.15 (defun set-locale (locale-des)
397 alendvai 1.17 (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 alendvai 1.19 (rebinding (locale)
404     `(let ((*locale* (if (consp ,locale)
405     ,locale
406     (locale ,locale))))
407     ,@body)))
408 sross 1.15
409 sross 1.1 (defun load-default-locale ()
410 alendvai 1.17 (set-locale (get-default-locale)))
411 sross 1.1
412     (defun get-default-locale ()
413 alendvai 1.17 (macrolet ((try (name)
414 alendvai 1.18 `(awhen (getenv ,name)
415 alendvai 1.17 (locale it :errorp nil))))
416     (or (try "CL_LOCALE")
417     (try "LC_CTYPE")
418     (try "LANG")
419     (locale "POSIX" :errorp nil))))
420 sross 1.1
421 alendvai 1.16 (eval-when (:load-toplevel :execute)
422     (load-default-locale))
423 sross 1.1
424 sross 1.15 ;; EOF

  ViewVC Help
Powered by ViewVC 1.1.5