1 ;;; gettext.el --- GNU gettext interface
2 ;; Copyright (C) 1999 Daiki Ueno
4 ;; Author: Daiki Ueno <ueno@unixuser.org>
8 ;; This file is part of Liece.
10 ;; This program is free software; you can redistribute it and/or modify
11 ;; it under the terms of the GNU General Public License as published by
12 ;; the Free Software Foundation; either version 2, or (at your option)
15 ;; This program is distributed in the hope that it will be useful,
16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18 ;; GNU General Public License for more details.
20 ;; You should have received a copy of the GNU General Public License
21 ;; along with GNU Emacs; see the file COPYING. If not, write to the
22 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
23 ;; Boston, MA 02111-1307, USA.
31 (eval-when-compile (require 'cl))
38 (autoload 'mime-content-type-parameter "mime-parse")
39 (autoload 'mime-read-Content-Type "mime-parse"))
41 (static-if (fboundp 'string-to-list)
42 (defalias 'gettext-string-to-list 'string-to-list)
43 ;; Rely on `string-to-char-list' emulation is provided in poem.
44 (defalias 'gettext-string-to-list 'string-to-char-list))
46 (defvar gettext-gmo-endian 1234)
47 (defvar gettext-message-domain-to-catalog-alist nil)
48 (defvar gettext-default-message-domain "emacs")
49 (defvar gettext-default-mime-charset default-mime-charset)
50 (defvar gettext-default-locale "C")
52 (defconst gettext-msgid-regexp "msgid\\s-*\"")
53 (defconst gettext-msgstr-regexp "msgstr\\s-*\"")
55 (defmacro gettext-hex-char-to-integer (character)
56 `(if (and (>= ,character ?0) (<= ,character ?9))
58 (let ((ch (logior ,character 32)))
59 (if (and (>= ch ?a) (<= ch ?f))
61 (error "Invalid hex digit `%c'" ch)))))
63 (defun gettext-hex-string-to-integer (hex-string)
65 (while (not (equal hex-string ""))
66 (setq hex-num (+ (* hex-num 16)
67 (gettext-hex-char-to-integer
68 (string-to-char hex-string)))
69 hex-string (substring hex-string 1)))
72 (defun gettext-gmo-read-32bit-word ()
73 (let ((word (string-to-char-list
74 (buffer-substring (point) (+ (point) 4)))))
76 (apply #'format "%02x%02x%02x%02x"
77 (mapcar (lambda (ch) (logand 255 ch))
78 (if (= gettext-gmo-endian 1234)
82 (defmacro gettext-gmo-header-revision (header)
85 (defmacro gettext-gmo-header-nn (header)
88 (defmacro gettext-gmo-header-oo (header)
91 (defmacro gettext-gmo-header-tt (header)
94 (defmacro gettext-gmo-header-ss (header)
97 (defmacro gettext-gmo-header-hh (header)
100 (defmacro gettext-gmo-read-header ()
102 (make-list 6 '(gettext-hex-string-to-integer
103 (gettext-gmo-read-32bit-word)))))
105 (defun gettext-gmo-collect-strings (nn)
106 (let (strings pos len off)
108 (setq len (gettext-hex-string-to-integer
109 (gettext-gmo-read-32bit-word))
110 off (gettext-hex-string-to-integer
111 (gettext-gmo-read-32bit-word))
114 (push (buffer-substring (point) (+ (point) len))
119 (defun gettext-parse-Content-Type (&optional header)
120 "Return the MIME charset of PO file."
123 (if (require 'mime-parse nil 'noerror)
124 (mime-content-type-parameter (mime-read-Content-Type) "charset")
125 (goto-char (point-min))
126 (let ((case-fold-search t))
127 (if (re-search-forward
128 "^\"Content-Type: *text/plain;[ \t]*charset=\\([^\\]+\\)"
130 (find-mime-charset-by-charsets
131 (list (buffer-substring (match-beginning 1) (match-end 1))))
132 gettext-default-mime-charset)))))
134 (defun gettext-mapcar* (function &rest args)
135 "Apply FUNCTION to successive cars of all ARGS.
136 Return the list of results."
138 (while (not (memq nil args))
139 (push (apply function (mapcar #'car args)) result)
140 (setq args (mapcar #'cdr args)))
143 (defun gettext-load-message-catalogue (file)
145 (let (header strings charset gettext-obarray)
146 (as-binary-input-file
147 (insert-file-contents file)
148 (goto-char (point-min))
149 (when (looking-at "\x95\x04\x12\xde")
150 (setq gettext-gmo-endian 4321))
152 (setq header (gettext-gmo-read-header)
154 (gettext-mapcar* #'cons
156 (goto-char (1+ (gettext-gmo-header-oo header)))
157 (gettext-gmo-collect-strings
158 (gettext-gmo-header-nn header)))
160 (goto-char (1+ (gettext-gmo-header-tt header)))
161 (gettext-gmo-collect-strings
162 (gettext-gmo-header-nn header))))
163 charset (or (gettext-parse-Content-Type
164 (cdr (assoc "" strings)))
166 gettext-obarray (make-vector
167 (* 2 (gettext-gmo-header-nn header))
169 (dolist (oott strings)
170 (set (intern (car oott) gettext-obarray)
171 (decode-mime-charset-string
172 (cdr oott) charset)))
175 (defun gettext-load-portable-message-catalogue (file)
177 (let (strings charset msgstr msgid state gettext-obarray)
178 (as-binary-input-file
179 (insert-file-contents file)
180 (goto-char (point-min))
183 ((looking-at gettext-msgid-regexp)
184 (if (eq state 'msgstr)
185 (push (cons msgid msgstr)
187 (setq msgid (buffer-substring (match-end 0)
188 (progn (end-of-line) (point))))
189 (when (string-match "\"\\s-*$" msgid)
190 (setq msgid (substring msgid 0 (match-beginning 0))))
192 ((looking-at gettext-msgstr-regexp)
193 (setq msgstr (buffer-substring (match-end 0)
194 (progn (end-of-line) (point))))
195 (when (string-match "\"\\s-*$" msgstr)
196 (setq msgstr (substring msgstr 0 (match-beginning 0))))
197 (setq state 'msgstr))
198 ((looking-at "\\s-*\"")
199 (let ((line (buffer-substring (match-end 0)
200 (progn (end-of-line) (point)))))
201 (when (string-match "\"\\s-*$" line)
202 (setq line (substring line 0 (match-beginning 0))))
203 (set state (concat (symbol-value state) line)))))
204 (beginning-of-line 2))
205 (if (eq state 'msgstr)
206 (push (cons msgid msgstr)
210 (goto-char (point-min))
211 (insert "(setq strings '(\n")
212 (dolist (oott strings)
213 (insert (format "(\"%s\" . \"%s\")\n"
214 (car oott) (cdr oott)))
216 (ignore-errors (eval-buffer))
217 (setq charset (or (gettext-parse-Content-Type
218 (cdr (assoc "" strings)))
220 (dolist (oott strings)
221 (set (intern (car oott) gettext-obarray)
222 (decode-mime-charset-string
223 (cdr oott) charset)))
226 (unless (featurep 'i18n3)
228 (defun dgettext (domain string)
229 "Look up STRING in the default message domain and return its translation.
230 \[XEmacs I18N level 3 emulating function]"
231 (let ((oott (assoc domain gettext-message-domain-to-catalog-alist)))
232 (when (stringp (cdr oott))
233 (setcdr oott (gettext-load-message-catalogue
236 (intern-soft string (or (cdr oott) (make-vector 1 0))))
239 (defun gettext (string)
240 "Look up STRING in the default message domain and return its translation.
241 \[XEmacs I18N level 3 emulating function]"
242 (dgettext gettext-default-message-domain string))
244 (defun bind-text-domain (domain pathname)
245 "Associate a pathname with a message domain.
246 Here's how the path to message files is constructed under SunOS 5.0:
247 {pathname}/{LANG}/LC_MESSAGES/{domain}.mo
248 \[XEmacs I18N level 3 emulating function]"
249 (let* ((lang (or (getenv "LC_ALL") (getenv "LC_MESSAGES") (getenv "LANG")
250 gettext-default-locale))
252 (string-match "\\([^_.]+\\)\\(_[^.]+\\)?\\(\\.[^@]+\\)?"
254 (match-string 1 lang)))
255 (territory (match-string 2 lang))
256 (code-set (match-string 3 lang))
258 (delq nil (list (if (and territory code-set)
259 (concat language territory
262 (concat language territory))
264 (concat language code-set))
266 (file (concat domain ".mo"))
268 (while (and (setq lang (car lang-path))
270 (expand-file-name file
272 "/" lang "/LC_MESSAGES")))
273 (not (file-exists-p catalog)))
274 (setq lang-path (cdr lang-path)))
275 (when (file-exists-p catalog)
276 ;;(file-exists-p (setq catalog (expand-file-name file pathname)))
277 (push (cons domain catalog) gettext-message-domain-to-catalog-alist))))
279 (defun set-domain (domain)
280 "Specify the domain used for translating messages in this source file.
281 The domain declaration may only appear at top-level, and should precede
282 all function and variable definitions.
284 The presence of this declaration in a compiled file effectively sets the
285 domain of all functions and variables which are defined in that file.
286 \[XEmacs I18N level 3 emulating function]"
287 (setq gettext-default-message-domain domain)))
291 ;;; gettext.el ends here