/[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 - (hide 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 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 ;; Add a restart here?
9 sross 1.10 (defun locale (loc-name &key (use-cache t) (errorp t) (loader nil))
10 sross 1.8 "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 sross 1.10 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 sross 1.1 (let ((name (aif (position #\. loc-name)
16     (subseq loc-name 0 it)
17     loc-name)))
18 sross 1.4 (acond ((and (not name) (not errorp)) nil)
19 sross 1.1 ((and use-cache (get-locale name)) it)
20 sross 1.10 (loader (setf (get-locale name) (funcall loader name)))
21 sross 1.1 ((probe-file (merge-pathnames *locale-path* name))
22 sross 1.10 (setf (get-locale name) (load-locale name)))
23 sross 1.8 (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 sross 1.1
32 sross 1.8 (deftype locale-descriptor ()
33     `(or locale string symbol))
34 sross 1.7
35     (defun locale-des->locale (loc)
36 sross 1.8 "Turns a locale descriptor(a string, symbol or locale) into an
37     actual locale object."
38     (check-type loc locale-descriptor)
39 sross 1.7 (etypecase loc
40     (locale loc)
41     (string (locale loc))
42     (symbol (locale (string loc)))))
43    
44 sross 1.1 (defun load-locale (name)
45 sross 1.15 (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 sross 1.10 (cl:format *debug-io* "~&;; Loading locale from ~A.~%" path)
51 sross 1.13 (let ((locale (make-instance *locale-type* :name name)))
52 sross 1.15 (with-open-file (stream path :external-format ef)
53 sross 1.1 (multiple-value-bind (escape comment) (munge-headers stream)
54 sross 1.13 (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 sross 1.7 (add-printers locale)
61 sross 1.12 (add-parsers locale)
62 sross 1.10 locale)))
63 sross 1.1
64 sross 1.13 (defun load-all-locales (&key (path *locale-path*) (ignore-errors nil) (use-cache nil))
65 sross 1.8 "Load all locale found in pathname designator PATH."
66     (let ((*locale-path* path))
67 sross 1.13 (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 sross 1.1
77 sross 1.9 (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 sross 1.7
84     (defun create-number-fmt-string (locale no-ts)
85 sross 1.9 (cl:format nil "~~A~~,,'~A,~A~A~~{~~A~~}"
86     (thousands-sep-char (locale-thousands-sep locale))
87 sross 1.15 (if (minusp (locale-grouping locale)) 3 (locale-grouping locale))
88 sross 1.7 (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 sross 1.9 (thousands-sep-char (locale-mon-thousands-sep locale))
118 sross 1.15 (if (minusp (locale-mon-grouping locale)) 3 (locale-mon-grouping locale))
119 sross 1.7 (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 sross 1.8 "Creates monetary and numeric format strings for locale LOCALE."
130 sross 1.13 (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 sross 1.7
148 sross 1.12 (defun day-element-p (x)
149     (member x '(#\d #\e)))
150    
151     (defun month-element-p (x)
152 sross 1.13 (member x '(#\m #\b #\B)))
153 sross 1.12
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 sross 1.14 with perc = nil
177     with in-dot = nil do
178 sross 1.12 (cond ((char= char #\%) (setf perc (not perc)))
179     ((member char date-dividers) nil)
180 sross 1.14 ((and perc (char= char #\.)) (setf in-dot t))
181     ((and perc in-dot (char= char #\1))
182     (setf in-dot nil))
183 sross 1.13 (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 sross 1.12 (nreverse res)))
191    
192     (defun add-parsers (locale)
193 sross 1.13 (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 sross 1.12
203 sross 1.1 (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 sross 1.8 ("LC_ADDRESS" . load-category))
214     "Map of category names to the function which will load them.")
215 sross 1.1
216     (defun get-loader (name)
217     (cdr (assoc name *category-loaders* :test #'string=)))
218    
219     (defun make-category (locale name vals)
220 sross 1.13 (when-let (loader (get-loader name))
221     (funcall loader locale name vals)))
222 sross 1.1
223 sross 1.8 (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 sross 1.1
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 sross 1.5 (remove #\" it)))))
248 sross 1.1
249     (defun line-comment-p (line comment)
250     (or (string= line "")
251 sross 1.8 (and (> (length line) 0)
252 sross 1.1 (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 sross 1.11 (or (get-category locale cat)
260 sross 1.1 (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 sross 1.13 (defun real-value (string)
313     (loop for char across string
314     with in-special = nil
315     with result = ()
316     with special-val = () do
317 sross 1.15 (cond ((eql char #\") nil) ;;ignore
318 sross 1.13 ((eql char #\<) (setf in-special t))
319 sross 1.15 ((and in-special (eql char #\>))
320 sross 1.13 (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 sross 1.1
332 sross 1.7 (defvar *split-scanner*
333     (cl-ppcre:create-scanner '(:char-class #\;)))
334    
335 sross 1.1 (defun parse-value (val)
336 sross 1.7 (let ((all-vals (split *split-scanner* val)))
337 sross 1.1 (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 sross 1.7 (notany #'(lambda (x)
358     (search x line :test #'string=))
359     *ignore-categories*))
360 sross 1.12 (return-from next-header (trim line)))))
361 sross 1.1
362 sross 1.15 (defun set-locale (locale-des)
363     (setf *locale* (locale-des->locale locale-des)))
364    
365 sross 1.1 (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 sross 1.15 (locale (getenv "LANG") :errorp nil)
372     (locale "POSIX" :errorp nil)))
373 sross 1.1
374 sross 1.15 (load-default-locale)
375 sross 1.1
376 sross 1.15 ;; EOF

  ViewVC Help
Powered by ViewVC 1.1.5