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

  ViewVC Help
Powered by ViewVC 1.1.5