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

  ViewVC Help
Powered by ViewVC 1.1.5