/[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 - (hide 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 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 sross 1.2 (when (pathname-name x)
37     (load-locale (pathname-name x)))))
38 sross 1.1
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