/[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 - (hide 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 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     (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 sross 1.7 (unless use-cache
13     ;; The local file might have changed so ...
14     (clear-getter-cache))
15 sross 1.4 (acond ((and (not name) (not errorp)) nil)
16 sross 1.1 ((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 sross 1.7 (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 sross 1.1 (defun load-locale (name)
31     (let ((path (merge-pathnames *locale-path* name)))
32 sross 1.7 (cl:format t "~&;; Loading locale from ~A.~%" path)
33     (let ((locale (make-instance *locale-type* :name name))
34 sross 1.1 (*read-eval* nil)
35     (*print-circle* nil))
36     (with-open-file (stream path
37 sross 1.3 :external-format #+(and sbcl sb-unicode) :latin1
38     #-(and sbcl sb-unicode) :default)
39 sross 1.1 (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 sross 1.7 (add-printers locale)
45 sross 1.1 (setf (get-locale name) locale))))
46    
47 sross 1.5 (defun load-all-locales (&optional (*locale-path* *locale-path*))
48     (dolist (x (directory (merge-pathnames *locale-path* "*")))
49 sross 1.2 (when (pathname-name x)
50 sross 1.5 (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 sross 1.1
54 sross 1.7
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 sross 1.1 (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 sross 1.7 (etypecase vals
138 sross 1.1 (category vals)
139 sross 1.7 (cons (dolist (x vals)
140     (setf (get-cat-val (car x) cat) (cdr x)))
141     cat))))
142 sross 1.1
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 sross 1.5 (remove #\" it)))))
159 sross 1.1
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 sross 1.7 (defvar *match-scanner* (cl-ppcre:create-scanner *regex*))
242    
243 sross 1.1 (defun old-real-value (val)
244 sross 1.7 (aif (all-matches-as-strings *match-scanner* val)
245 sross 1.1 (map #-lispworks 'string #+lispworks
246     'lw:text-string #'real-character it)
247     val))
248    
249     ;; KLUDGE
250     (defun real-value (val)
251 sross 1.7 (remove #\" (old-real-value val)))
252 sross 1.1
253    
254 sross 1.7 (defvar *split-scanner*
255     (cl-ppcre:create-scanner '(:char-class #\;)))
256    
257 sross 1.1 (defun parse-value (val)
258 sross 1.7 (let ((all-vals (split *split-scanner* val)))
259 sross 1.1 (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 sross 1.7 (notany #'(lambda (x)
280     (search x line :test #'string=))
281     *ignore-categories*))
282 sross 1.1 (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