/[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.2 - (show annotations)
Mon Nov 29 10:40:59 2004 UTC (9 years, 4 months ago) by sross
Branch: MAIN
Changes since 1.1: +2 -1 lines
added changelog, fixed load-all-locales
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 (acond ((and (not name) (not errorp)) "No Locale NIL.")
13 ((and use-cache (get-locale name)) it)
14 ((probe-file (merge-pathnames *locale-path* name))
15 (load-locale name))
16 ((not errorp) (warn "Can't find locale ~A." name))
17 (errorp (locale-error "Can't find locale ~A." name)))))
18
19 (defun load-locale (name)
20 (let ((path (merge-pathnames *locale-path* name)))
21 (format t ";; Loading locale from ~A.~%" path)
22 (let ((locale (make-instance 'locale :name name))
23 (*read-eval* nil)
24 (*print-circle* nil))
25 (with-open-file (stream path
26 :external-format #+sbcl :latin1 #-sbcl :default)
27 (multiple-value-bind (escape comment) (munge-headers stream)
28 (awhile (next-header stream)
29 (awhen (make-category locale it (parse-category it stream
30 escape comment))
31 (setf (get-category (category-name it) locale) it)))))
32 (setf (get-locale name) locale))))
33
34 (defun load-all-locales (&optional (path *locale-path*))
35 (dolist (x (directory (merge-pathnames path "*")))
36 (when (pathname-name x)
37 (load-locale (pathname-name x)))))
38
39 (defvar *category-loaders*
40 '(("LC_IDENTIFICATION" . load-identification)
41 ("LC_MONETARY" . load-category)
42 ("LC_NUMERIC" . load-category)
43 ("LC_TIME" . load-category)
44 ("LC_MESSAGES" . load-category)
45 ("LC_PAPER" . load-category)
46 ("LC_TELEPHONE" . load-category)
47 ("LC_MEASUREMENT" . load-category)
48 ("LC_NAME" . load-category)
49 ("LC_ADDRESS" . load-category)))
50
51 (defun get-loader (name)
52 (cdr (assoc name *category-loaders* :test #'string=)))
53
54 (defun make-category (locale name vals)
55 (awhen (get-loader name)
56 (funcall it locale name vals)))
57
58 (defun load-category (locale name vals)
59 (declare (ignore locale))
60 (let ((cat (make-instance 'category :name name)))
61 (typecase vals
62 (category vals)
63 (t (dolist (x vals)
64 (setf (get-cat-val (car x) cat) (cdr x)))
65 cat))))
66
67 (defvar *id-vals*
68 '(("title" . title)
69 ("source" . source)
70 ("language" . language)
71 ("territory" . territory)
72 ("revision" . revision)
73 ("date" . date)
74 ("categories" . categories)))
75
76
77 (defun load-identification (locale name vals)
78 (declare (ignore name))
79 (dolist (x *id-vals*)
80 (aif (cdr (assoc (car x) vals :test #'string=))
81 (setf (slot-value locale (cdr x))
82 (read-from-string it nil "")))))
83
84 (defun line-comment-p (line comment)
85 (or (string= line "")
86 (and (> (length line) 0) ;; Ignore a comment line
87 (char= (schar line 0) comment))))
88
89
90 (defun copy-category (cat line)
91 (let ((from (trim (subseq line (position #\Space line))
92 (cons #\" *whitespace*))))
93 (handler-case (let* ((locale (locale from)))
94 (or (get-category cat locale)
95 (locale-error "No category ~A in locale ~A."
96 cat from)))
97 (error (c) (locale-error "Unable to copy Category ~A from ~A. ~A."
98 cat from c)))))
99
100 (defun parse-category (name stream escape comment)
101 (let ((end (mkstr "END " name))
102 (ret nil))
103 (loop for line = (read-line stream nil stream)
104 until (eq line stream) do
105 (cond ((line-comment-p line comment))
106 ((search end line) (return-from parse-category ret))
107 ((search "END" line)
108 (locale-error "End of wrong block reached ~S. Expected ~S."
109 line end))
110 ((and (> (length line) 3) (search "copy" line :end2 4))
111 (return-from parse-category
112 (copy-category name line)))
113 (t (push (get-value line stream escape) ret))))))
114
115 (defun munge-headers (stream)
116 (let ((escape #\\) (comment-char #\#))
117 (loop for line = (read-line stream nil stream)
118 for i from 1 do
119 ;; HACK We assume that if the escape and comment
120 ;; lines don't appear right away that they don't exist
121 ;; This is to work around lispworks being unable
122 ;; to unread a line of text character by character.
123 (cond ((> i 3) (return nil))
124 ((line-comment-p line comment-char))
125 ((search "escape_char" line)
126 (setf escape
127 (schar (cdr (get-value line stream escape)) 0)))
128 ((search "comment_char" line)
129 (setf comment-char
130 (schar (cdr (get-value line stream escape)) 0)))))
131 (values escape comment-char)))
132
133
134
135 (defun get-full-line (line stream escape)
136 (let ((length (length line)))
137 (if (char= (elt line (1- length)) escape)
138 (let ((next-line (read-line stream nil stream)))
139 (if (eq next-line stream)
140 (locale-error "EOF Looking for next line of ~A." line)
141 (get-full-line (concatenate
142 'string
143 (subseq line 0 (1- length))
144 (trim next-line))
145 stream
146 escape)))
147 line)))
148
149
150 (defun real-character (char)
151 (let ((int (parse-integer (trim char (list* #\U #\> #\< *whitespace*))
152 :radix 16)))
153 (handler-case (code-char int)
154 (type-error (c)
155 (declare (ignore c))
156 (locale-error "Cannot represent ~A as a character." int)))))
157
158 (defvar *regex* '(:sequence
159 #\<
160 (:greedy-repetition 0 nil
161 (:inverted-char-class #\> #\<)
162 :everything)
163 #\>))
164
165 (defun old-real-value (val)
166 (aif (all-matches-as-strings *regex* val)
167 (map #-lispworks 'string #+lispworks
168 'lw:text-string #'real-character it)
169 val))
170
171 ;; KLUDGE
172 (defun real-value (val)
173 (let ((val (old-real-value val)))
174 (if (string= val "\"\"")
175 ""
176 val)))
177
178
179 (defun parse-value (val)
180 (let ((all-vals (split '(:char-class #\;) val)))
181 (if (singlep all-vals)
182 (real-value (car all-vals))
183 (mapcar #'real-value all-vals))))
184
185 (defun get-value (line stream escape)
186 "Return a cons containing the key of line and its value.
187 Honors lines ending with ESCAPE"
188 (let* ((line (get-full-line line stream escape))
189 (first-space (position-if #'(lambda (x)
190 (or* (char= x #\Space #\Tab)))
191 line)))
192 (if (null first-space)
193 (locale-error "No Space in line ~A." line)
194 (cons (trim (subseq line 0 first-space))
195 (parse-value (trim (subseq line first-space)))))))
196
197 (defun next-header (stream)
198 (loop for line = (read-line stream nil stream)
199 until (eq line stream) do
200 (if (and (> (length line) 3) (search "LC_" line :end2 3)
201 (not (some #'(lambda (x)
202 (search x line :test #'string=))
203 *ignore-categories*)))
204 (return-from next-header line))))
205
206 (defun load-default-locale ()
207 (setf *locale* (get-default-locale)))
208
209 (defun get-default-locale ()
210 (or (locale (getenv "CL_LOCALE") :errorp nil)
211 (locale (getenv "LC_CTYPE") :errorp nil)
212 (locale "POSIX")))
213
214 (load-default-locale)
215
216
217 ;; EOF

  ViewVC Help
Powered by ViewVC 1.1.5