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

  ViewVC Help
Powered by ViewVC 1.1.5