/[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.7 - (show annotations)
Thu Dec 30 11:56:38 2004 UTC (9 years, 3 months ago) by sross
Branch: MAIN
Changes since 1.6: +90 -15 lines
ChangeLog 2004-12-30
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 (defun locale (loc-name &key (use-cache t) (errorp t))
9 (let ((name (aif (position #\. loc-name)
10 (subseq loc-name 0 it)
11 loc-name)))
12 (unless use-cache
13 ;; The local file might have changed so ...
14 (clear-getter-cache))
15 (acond ((and (not name) (not errorp)) nil)
16 ((and use-cache (get-locale name)) it)
17 ((probe-file (merge-pathnames *locale-path* name))
18 (load-locale name))
19 ((not errorp) (warn "Can't find locale ~A." name))
20 (errorp (locale-error "Can't find locale ~A." name)))))
21
22 (defvar *locale-type* 'locale)
23
24 (defun locale-des->locale (loc)
25 (etypecase loc
26 (locale loc)
27 (string (locale loc))
28 (symbol (locale (string loc)))))
29
30 (defun load-locale (name)
31 (let ((path (merge-pathnames *locale-path* name)))
32 (cl:format t "~&;; Loading locale from ~A.~%" path)
33 (let ((locale (make-instance *locale-type* :name name))
34 (*read-eval* nil)
35 (*print-circle* nil))
36 (with-open-file (stream path
37 :external-format #+(and sbcl sb-unicode) :latin1
38 #-(and sbcl sb-unicode) :default)
39 (multiple-value-bind (escape comment) (munge-headers stream)
40 (awhile (next-header stream)
41 (awhen (make-category locale it (parse-category it stream
42 escape comment))
43 (setf (get-category (category-name it) locale) it)))))
44 (add-printers locale)
45 (setf (get-locale name) locale))))
46
47 (defun load-all-locales (&optional (*locale-path* *locale-path*))
48 (dolist (x (directory (merge-pathnames *locale-path* "*")))
49 (when (pathname-name x)
50 (with-simple-restart (continue "Ignore locale ~A." x)
51 (handler-case (load-locale (pathname-name x))
52 (locale-error (c) (warn "Unable to load locale ~A. ~%~A." x c)))))))
53
54
55 (defun create-number-fmt-string (locale no-ts)
56 (cl:format nil "~~A~~,,'~A,~A~A~~{~~A~~}" (schar (locale-thousands-sep locale) 0)
57 (locale-grouping locale)
58 (if no-ts "D" ":D")))
59
60 (defun get-descriptors (minusp locale)
61 (if minusp
62 (values (locale-n-sep-by-space locale)
63 (= 1 (locale-n-cs-precedes locale))
64 (locale-n-sign-posn locale)
65 (locale-negative-sign locale))
66 (values (locale-p-sep-by-space locale)
67 (= 1 (locale-p-cs-precedes locale))
68 (locale-p-sign-posn locale)
69 (locale-positive-sign locale))))
70
71 (defun create-money-fmt-string (locale no-ts minusp)
72 (multiple-value-bind (sep-by-space prec spos sign)
73 (get-descriptors minusp locale)
74 (let ((sym-sep (if (zerop sep-by-space) "" " ")))
75 (with-output-to-string (stream)
76 ;; sign and sign separator
77 (when (or* (= spos 0 1 3))
78 (princ (if (zerop spos) "(" sign) stream)
79 (when (= 2 sep-by-space)
80 (princ #\Space stream)))
81 ;; Sym and seperator
82 (princ "~A" stream)
83 (when prec
84 (princ sym-sep stream))
85 ;; Actual number
86 (cl:format stream "~~,,'~A,~A~A~~{~~A~~}"
87 (schar (locale-mon-thousands-sep locale) 0)
88 (locale-mon-grouping locale)
89 (if no-ts "D" ":D"))
90 (unless prec
91 (princ sym-sep stream))
92 (princ "~A" stream)
93 (when (or* (= spos 0 2 4))
94 (when (= 2 sep-by-space)
95 (princ #\Space stream))
96 (princ (if (zerop spos) ")" sign) stream))))))
97
98 (defun add-printers (locale)
99 (setf (printers locale)
100 (nconc (list :number-no-ts
101 (create-number-fmt-string locale t))
102 (list :number-ts
103 (create-number-fmt-string locale nil))
104 (list :money-p-no-ts
105 (create-money-fmt-string locale t nil))
106 (list :money-p-ts
107 (create-money-fmt-string locale nil nil))
108 (list :money-n-no-ts
109 (create-money-fmt-string locale t t))
110 (list :money-n-ts
111 (create-money-fmt-string locale nil t))
112 (printers locale))))
113
114
115 (defvar *category-loaders*
116 '(("LC_IDENTIFICATION" . load-identification)
117 ("LC_MONETARY" . load-category)
118 ("LC_NUMERIC" . load-category)
119 ("LC_TIME" . load-category)
120 ("LC_MESSAGES" . load-category)
121 ("LC_PAPER" . load-category)
122 ("LC_TELEPHONE" . load-category)
123 ("LC_MEASUREMENT" . load-category)
124 ("LC_NAME" . load-category)
125 ("LC_ADDRESS" . load-category)))
126
127 (defun get-loader (name)
128 (cdr (assoc name *category-loaders* :test #'string=)))
129
130 (defun make-category (locale name vals)
131 (awhen (get-loader name)
132 (funcall it locale name vals)))
133
134 (defun load-category (locale name vals)
135 (declare (ignore locale))
136 (let ((cat (make-instance 'category :name name)))
137 (etypecase vals
138 (category vals)
139 (cons (dolist (x vals)
140 (setf (get-cat-val (car x) cat) (cdr x)))
141 cat))))
142
143 (defvar *id-vals*
144 '(("title" . title)
145 ("source" . source)
146 ("language" . language)
147 ("territory" . territory)
148 ("revision" . revision)
149 ("date" . date)
150 ("categories" . categories)))
151
152
153 (defun load-identification (locale name vals)
154 (declare (ignore name))
155 (dolist (x *id-vals*)
156 (aif (cdr (assoc (car x) vals :test #'string=))
157 (setf (slot-value locale (cdr x))
158 (remove #\" it)))))
159
160 (defun line-comment-p (line comment)
161 (or (string= line "")
162 (and (> (length line) 0) ;; Ignore a comment line
163 (char= (schar line 0) comment))))
164
165
166 (defun copy-category (cat line)
167 (let ((from (trim (subseq line (position #\Space line))
168 (cons #\" *whitespace*))))
169 (handler-case (let* ((locale (locale from)))
170 (or (get-category cat locale)
171 (locale-error "No category ~A in locale ~A."
172 cat from)))
173 (error (c) (locale-error "Unable to copy Category ~A from ~A. ~A."
174 cat from c)))))
175
176 (defun parse-category (name stream escape comment)
177 (let ((end (mkstr "END " name))
178 (ret nil))
179 (loop for line = (read-line stream nil stream)
180 until (eq line stream) do
181 (cond ((line-comment-p line comment))
182 ((search end line) (return-from parse-category ret))
183 ((search "END" line)
184 (locale-error "End of wrong block reached ~S. Expected ~S."
185 line end))
186 ((and (> (length line) 3) (search "copy" line :end2 4))
187 (return-from parse-category
188 (copy-category name line)))
189 (t (push (get-value line stream escape) ret))))))
190
191 (defun munge-headers (stream)
192 (let ((escape #\\) (comment-char #\#))
193 (loop for line = (read-line stream nil stream)
194 for i from 1 do
195 ;; HACK We assume that if the escape and comment
196 ;; lines don't appear right away that they don't exist
197 ;; This is to work around lispworks being unable
198 ;; to unread a line of text character by character.
199 (cond ((> i 3) (return nil))
200 ((line-comment-p line comment-char))
201 ((search "escape_char" line)
202 (setf escape
203 (schar (cdr (get-value line stream escape)) 0)))
204 ((search "comment_char" line)
205 (setf comment-char
206 (schar (cdr (get-value line stream escape)) 0)))))
207 (values escape comment-char)))
208
209
210
211 (defun get-full-line (line stream escape)
212 (let ((length (length line)))
213 (if (char= (elt line (1- length)) escape)
214 (let ((next-line (read-line stream nil stream)))
215 (if (eq next-line stream)
216 (locale-error "EOF Looking for next line of ~A." line)
217 (get-full-line (concatenate
218 'string
219 (subseq line 0 (1- length))
220 (trim next-line))
221 stream
222 escape)))
223 line)))
224
225
226 (defun real-character (char)
227 (let ((int (parse-integer (trim char (list* #\U #\> #\< *whitespace*))
228 :radix 16)))
229 (handler-case (code-char int)
230 (type-error (c)
231 (declare (ignore c))
232 (locale-error "Cannot represent ~A as a character." int)))))
233
234 (defvar *regex* '(:sequence
235 #\<
236 (:greedy-repetition 0 nil
237 (:inverted-char-class #\> #\<)
238 :everything)
239 #\>))
240
241 (defvar *match-scanner* (cl-ppcre:create-scanner *regex*))
242
243 (defun old-real-value (val)
244 (aif (all-matches-as-strings *match-scanner* val)
245 (map #-lispworks 'string #+lispworks
246 'lw:text-string #'real-character it)
247 val))
248
249 ;; KLUDGE
250 (defun real-value (val)
251 (remove #\" (old-real-value val)))
252
253
254 (defvar *split-scanner*
255 (cl-ppcre:create-scanner '(:char-class #\;)))
256
257 (defun parse-value (val)
258 (let ((all-vals (split *split-scanner* val)))
259 (if (singlep all-vals)
260 (real-value (car all-vals))
261 (mapcar #'real-value all-vals))))
262
263 (defun get-value (line stream escape)
264 "Return a cons containing the key of line and its value.
265 Honors lines ending with ESCAPE"
266 (let* ((line (get-full-line line stream escape))
267 (first-space (position-if #'(lambda (x)
268 (or* (char= x #\Space #\Tab)))
269 line)))
270 (if (null first-space)
271 (locale-error "No Space in line ~A." line)
272 (cons (trim (subseq line 0 first-space))
273 (parse-value (trim (subseq line first-space)))))))
274
275 (defun next-header (stream)
276 (loop for line = (read-line stream nil stream)
277 until (eq line stream) do
278 (if (and (> (length line) 3) (search "LC_" line :end2 3)
279 (notany #'(lambda (x)
280 (search x line :test #'string=))
281 *ignore-categories*))
282 (return-from next-header line))))
283
284 (defun load-default-locale ()
285 (setf *locale* (get-default-locale)))
286
287 (defun get-default-locale ()
288 (or (locale (getenv "CL_LOCALE") :errorp nil)
289 (locale (getenv "LC_CTYPE") :errorp nil)
290 (locale "POSIX")))
291
292 (load-default-locale)
293
294
295 ;; EOF

  ViewVC Help
Powered by ViewVC 1.1.5