/[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.15 - (show annotations)
Thu Apr 27 18:30:30 2006 UTC (7 years, 11 months ago) by sross
Branch: MAIN
Changes since 1.14: +17 -12 lines
* parse-number.lisp: Changed parse-error to extend parser-error
* parse-time.lisp: Changed uses of eq to eql when using numbers
  or characters.
* printers.lisp: Default length fraction digits to 0 if it can't
  be found in the current locale. Fixed printers of %R time format directive.
* load-locale.lisp: Search environment variable LANG before trying using
  POSIX locale when loading default locale.
  Add shadowing-format which shadows format and formatter into the current package.
* package.lisp: Export load-default-locale
* doc/cl-l10n.texi: Rename the Index node to Comprehensive Index in
  order to avoid a name clash with index.html on platforms with
  case-insensitive filesystems.  Prettify the copyright notice.
* doc/Makefile, doc/style.css, doc/gendocs.sh, doc/gendocs_template, doc/style.css:
  New files.
* load-locale.lisp (load-locale): Specify an explicit
  external-format for CLISP
* test.lisp: Fix indentation of deftest forms.
  (time.2): Obtain the o-with-diaeresis in a slightly more portable way.
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 (list "LC_CTYPE" "LC_COLLATE"))
7
8 ;; Add a restart here?
9 (defun locale (loc-name &key (use-cache t) (errorp t) (loader nil))
10 "Find locale named by the string LOC-NAME. If USE-CACHE
11 is non-nil forcefully reload the locale from *locale-path* else
12 the locale is first looked for in *locales*. If ERRORP is non-nil
13 signal a warning rather than an error if the locale file cannot be found.
14 If LOADER is non-nil skip everything and call loader with LOC-NAME."
15 (let ((name (aif (position #\. loc-name)
16 (subseq loc-name 0 it)
17 loc-name)))
18 (acond ((and (not name) (not errorp)) nil)
19 ((and use-cache (get-locale name)) it)
20 (loader (setf (get-locale name) (funcall loader name)))
21 ((probe-file (merge-pathnames *locale-path* name))
22 (setf (get-locale name) (load-locale name)))
23 (t (funcall (if errorp #'error #'warn)
24 "Can't find locale ~A." name)))))
25
26 (defvar *locale-type* 'locale
27 "The class of loaded locales.")
28
29 (defvar *category-type* 'category
30 "The class of loaded categories")
31
32 (deftype locale-descriptor ()
33 `(or locale string symbol))
34
35 (defun locale-des->locale (loc)
36 "Turns a locale descriptor(a string, symbol or locale) into an
37 actual locale object."
38 (check-type loc locale-descriptor)
39 (etypecase loc
40 (locale loc)
41 (string (locale loc))
42 (symbol (locale (string loc)))))
43
44 (defun load-locale (name)
45 (let ((path (merge-pathnames *locale-path* name))
46 (ef #+sbcl :iso-8859-1
47 #+clisp (ext:make-encoding :charset 'charset:iso-8859-1
48 :line-terminator :unix)
49 #-(or sbcl clisp) :default))
50 (cl:format *debug-io* "~&;; Loading locale from ~A.~%" path)
51 (let ((locale (make-instance *locale-type* :name name)))
52 (with-open-file (stream path :external-format ef)
53 (multiple-value-bind (escape comment) (munge-headers stream)
54 (loop for header = (next-header stream)
55 while header do
56 (when-let (cat (make-category locale header
57 (parse-category header stream
58 escape comment)))
59 (setf (get-category locale header) cat)))))
60 (add-printers locale)
61 (add-parsers locale)
62 locale)))
63
64 (defun load-all-locales (&key (path *locale-path*) (ignore-errors nil) (use-cache nil))
65 "Load all locale found in pathname designator PATH."
66 (let ((*locale-path* path))
67 (dolist (x (list-directory *locale-path*))
68 (when (and (not (directory-pathname-p x)) (pathname-name x))
69 (let ((locale (pathname-name x)))
70 (with-simple-restart (continue "Ignore locale ~A." x)
71 (handler-bind ((error (lambda (&optional c)
72 (when ignore-errors
73 (warn "Failed to load locale ~S, Ignoring." locale)
74 (invoke-restart (find-restart 'continue c))))))
75 (locale locale :use-cache use-cache))))))))
76
77 (defvar *default-thousands-sep* #\,)
78
79 (defun thousands-sep-char (sep)
80 (if (> (length sep) 0)
81 (schar sep 0)
82 *default-thousands-sep*))
83
84 (defun create-number-fmt-string (locale no-ts)
85 (cl:format nil "~~A~~,,'~A,~A~A~~{~~A~~}"
86 (thousands-sep-char (locale-thousands-sep locale))
87 (if (minusp (locale-grouping locale)) 3 (locale-grouping locale))
88 (if no-ts "D" ":D")))
89
90 (defun get-descriptors (minusp locale)
91 (if minusp
92 (values (locale-n-sep-by-space locale)
93 (= 1 (locale-n-cs-precedes locale))
94 (locale-n-sign-posn locale)
95 (locale-negative-sign locale))
96 (values (locale-p-sep-by-space locale)
97 (= 1 (locale-p-cs-precedes locale))
98 (locale-p-sign-posn locale)
99 (locale-positive-sign locale))))
100
101 (defun create-money-fmt-string (locale no-ts minusp)
102 (multiple-value-bind (sep-by-space prec spos sign)
103 (get-descriptors minusp locale)
104 (let ((sym-sep (if (zerop sep-by-space) "" " ")))
105 (with-output-to-string (stream)
106 ;; sign and sign separator
107 (when (or* (= spos 0 1 3))
108 (princ (if (zerop spos) "(" sign) stream)
109 (when (= 2 sep-by-space)
110 (princ #\Space stream)))
111 ;; Sym and seperator
112 (princ "~A" stream)
113 (when prec
114 (princ sym-sep stream))
115 ;; Actual number
116 (cl:format stream "~~,,'~A,~A~A~~{~~A~~}"
117 (thousands-sep-char (locale-mon-thousands-sep locale))
118 (if (minusp (locale-mon-grouping locale)) 3 (locale-mon-grouping locale))
119 (if no-ts "D" ":D"))
120 (unless prec
121 (princ sym-sep stream))
122 (princ "~A" stream)
123 (when (or* (= spos 0 2 4))
124 (when (= 2 sep-by-space)
125 (princ #\Space stream))
126 (princ (if (zerop spos) ")" sign) stream))))))
127
128 (defun add-printers (locale)
129 "Creates monetary and numeric format strings for locale LOCALE."
130 (when (and (get-category locale "LC_MONETARY")
131 (get-category locale "LC_NUMERIC"))
132 ;; otherwise its an include locale (tranlit* etc)
133 (setf (printers locale)
134 (nconc (list :number-no-ts
135 (create-number-fmt-string locale t))
136 (list :number-ts
137 (create-number-fmt-string locale nil))
138 (list :money-p-no-ts
139 (create-money-fmt-string locale t nil))
140 (list :money-p-ts
141 (create-money-fmt-string locale nil nil))
142 (list :money-n-no-ts
143 (create-money-fmt-string locale t t))
144 (list :money-n-ts
145 (create-money-fmt-string locale nil t))
146 (printers locale)))))
147
148 (defun day-element-p (x)
149 (member x '(#\d #\e)))
150
151 (defun month-element-p (x)
152 (member x '(#\m #\b #\B)))
153
154 (defun year-element-p (x)
155 (member x '(#\y #\Y)))
156
157 (defun element-type (char)
158 (cond ((day-element-p char) 'day)
159 ((month-element-p char) 'month)
160 ((year-element-p char) 'year)))
161
162 (defvar date-dividers '(#\\ #\/ #\-))
163
164 ;; FIXME
165 ;; this effort definitely doesn't cover
166 ;; every single case but it will do for now.
167 (defun locale-date-month-order (locale)
168 (let ((fmt (locale-d-fmt locale)))
169 (cond ((string= fmt "%D") '(month day year))
170 ((string= fmt "%F") '(year month day))
171 (t (compute-order fmt)))))
172
173 (defun compute-order (fmt)
174 (let ((res nil))
175 (loop for char across fmt
176 with perc = nil
177 with in-dot = nil do
178 (cond ((char= char #\%) (setf perc (not perc)))
179 ((member char date-dividers) nil)
180 ((and perc (char= char #\.)) (setf in-dot t))
181 ((and perc in-dot (char= char #\1))
182 (setf in-dot nil))
183 (perc (unless (char= char #\E)
184 ;; some locales (eg lo_LA) have this funny E before
185 ;; various time format designators. Debian
186 ;; treats this as if it wasn't there so neither do we.
187 (let ((val (element-type char)))
188 (when val (push val res))
189 (setf perc nil))))))
190 (nreverse res)))
191
192 (defun add-parsers (locale)
193 (when (get-category locale "LC_TIME")
194 (destructuring-bind (first second third)
195 (locale-date-month-order locale)
196 (setf (parsers locale)
197 (list `((noon-midn) (weekday) ,first (date-divider) ,second (date-divider) ,third (noon-midn))
198 `((weekday) ,first (date-divider) ,second (date-divider) ,third hour (time-divider) minute
199 (time-divider) (secondp) (am-pm) (date-divider) (zone))
200 `(hour (time-divider) minute (time-divider) (secondp) (am-pm) (weekday) ,first (date-divider)
201 (secondp) (date-divider) ,third (date-divider) (zone)))))))
202
203 (defvar *category-loaders*
204 '(("LC_IDENTIFICATION" . load-identification)
205 ("LC_MONETARY" . load-category)
206 ("LC_NUMERIC" . load-category)
207 ("LC_TIME" . load-category)
208 ("LC_MESSAGES" . load-category)
209 ("LC_PAPER" . load-category)
210 ("LC_TELEPHONE" . load-category)
211 ("LC_MEASUREMENT" . load-category)
212 ("LC_NAME" . load-category)
213 ("LC_ADDRESS" . load-category))
214 "Map of category names to the function which will load them.")
215
216 (defun get-loader (name)
217 (cdr (assoc name *category-loaders* :test #'string=)))
218
219 (defun make-category (locale name vals)
220 (when-let (loader (get-loader name))
221 (funcall loader locale name vals)))
222
223 (defgeneric load-category (locale name vals)
224 (:documentation "Load a category for LOCALE using VALS.")
225 (:method ((locale locale) (name string) (vals category))
226 vals)
227 (:method ((locale locale) (name string) (vals cons))
228 (let ((cat (make-instance *category-type* :name name)))
229 (dolist (x vals)
230 (setf (category-value cat (car x)) (cdr x)))
231 cat)))
232
233 (defvar *id-vals*
234 '(("title" . title)
235 ("source" . source)
236 ("language" . language)
237 ("territory" . territory)
238 ("revision" . revision)
239 ("date" . date)
240 ("categories" . categories)))
241
242 (defun load-identification (locale name vals)
243 (declare (ignore name))
244 (dolist (x *id-vals*)
245 (aif (cdr (assoc (car x) vals :test #'string=))
246 (setf (slot-value locale (cdr x))
247 (remove #\" it)))))
248
249 (defun line-comment-p (line comment)
250 (or (string= line "")
251 (and (> (length line) 0)
252 (char= (schar line 0) comment))))
253
254
255 (defun copy-category (cat line)
256 (let ((from (trim (subseq line (position #\Space line))
257 (cons #\" *whitespace*))))
258 (handler-case (let* ((locale (locale from)))
259 (or (get-category locale cat)
260 (locale-error "No category ~A in locale ~A."
261 cat from)))
262 (error (c) (locale-error "Unable to copy Category ~A from ~A. ~A."
263 cat from c)))))
264
265 (defun parse-category (name stream escape comment)
266 (let ((end (mkstr "END " name))
267 (ret nil))
268 (loop for line = (read-line stream nil stream)
269 until (eq line stream) do
270 (cond ((line-comment-p line comment))
271 ((search end line) (return-from parse-category ret))
272 ((search "END" line)
273 (locale-error "End of wrong block reached ~S. Expected ~S."
274 line end))
275 ((and (> (length line) 3) (search "copy" line :end2 4))
276 (return-from parse-category
277 (copy-category name line)))
278 (t (push (get-value line stream escape) ret))))))
279
280 (defun munge-headers (stream)
281 (let ((escape #\\) (comment-char #\#))
282 (loop for line = (read-line stream nil stream)
283 for i from 1 do
284 ;; HACK We assume that if the escape and comment
285 ;; lines don't appear right away that they don't exist
286 ;; This is to work around lispworks being unable
287 ;; to unread a line of text character by character.
288 (cond ((> i 3) (return nil))
289 ((line-comment-p line comment-char))
290 ((search "escape_char" line)
291 (setf escape
292 (schar (cdr (get-value line stream escape)) 0)))
293 ((search "comment_char" line)
294 (setf comment-char
295 (schar (cdr (get-value line stream escape)) 0)))))
296 (values escape comment-char)))
297
298 (defun get-full-line (line stream escape)
299 (let ((length (length line)))
300 (if (char= (elt line (1- length)) escape)
301 (let ((next-line (read-line stream nil stream)))
302 (if (eq next-line stream)
303 (locale-error "EOF Looking for next line of ~A." line)
304 (get-full-line (concatenate
305 'string
306 (subseq line 0 (1- length))
307 (trim next-line))
308 stream
309 escape)))
310 line)))
311
312 (defun real-value (string)
313 (loop for char across string
314 with in-special = nil
315 with result = ()
316 with special-val = () do
317 (cond ((eql char #\") nil) ;;ignore
318 ((eql char #\<) (setf in-special t))
319 ((and in-special (eql char #\>))
320 (push (code-char
321 (parse-integer (coerce (cdr (nreverse special-val)) 'string)
322 :radix 16))
323 result)
324 (setf in-special nil
325 special-val nil))
326 (in-special (push char special-val))
327 (t (push char result)))
328 finally (return (coerce (nreverse result)
329 #-lispworks 'string
330 #+lispworks 'lw:text-string))))
331
332 (defvar *split-scanner*
333 (cl-ppcre:create-scanner '(:char-class #\;)))
334
335 (defun parse-value (val)
336 (let ((all-vals (split *split-scanner* val)))
337 (if (singlep all-vals)
338 (real-value (car all-vals))
339 (mapcar #'real-value all-vals))))
340
341 (defun get-value (line stream escape)
342 "Return a cons containing the key of line and its value.
343 Honors lines ending with ESCAPE"
344 (let* ((line (get-full-line line stream escape))
345 (first-space (position-if #'(lambda (x)
346 (or* (char= x #\Space #\Tab)))
347 line)))
348 (if (null first-space)
349 (locale-error "No Space in line ~A." line)
350 (cons (trim (subseq line 0 first-space))
351 (parse-value (trim (subseq line first-space)))))))
352
353 (defun next-header (stream)
354 (loop for line = (read-line stream nil stream)
355 until (eq line stream) do
356 (if (and (> (length line) 3) (search "LC_" line :end2 3)
357 (notany #'(lambda (x)
358 (search x line :test #'string=))
359 *ignore-categories*))
360 (return-from next-header (trim line)))))
361
362 (defun set-locale (locale-des)
363 (setf *locale* (locale-des->locale locale-des)))
364
365 (defun load-default-locale ()
366 (setf *locale* (get-default-locale)))
367
368 (defun get-default-locale ()
369 (or (locale (getenv "CL_LOCALE") :errorp nil)
370 (locale (getenv "LC_CTYPE") :errorp nil)
371 (locale (getenv "LANG") :errorp nil)
372 (locale "POSIX" :errorp nil)))
373
374 (load-default-locale)
375
376 ;; EOF

  ViewVC Help
Powered by ViewVC 1.1.5