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)
51 (defconst gettext-msgid-regexp "msgid\\s-*\"")
52 (defconst gettext-msgstr-regexp "msgstr\\s-*\"")
54 (defmacro gettext-hex-char-to-integer (character)
55 `(if (and (>= ,character ?0) (<= ,character ?9))
57 (let ((ch (logior ,character 32)))
58 (if (and (>= ch ?a) (<= ch ?f))
60 (error "Invalid hex digit `%c'" ch)))))
62 (defun gettext-hex-string-to-integer (hex-string)
64 (while (not (equal hex-string ""))
65 (setq hex-num (+ (* hex-num 16)
66 (gettext-hex-char-to-integer
67 (string-to-char hex-string)))
68 hex-string (substring hex-string 1)))
71 (defun gettext-gmo-read-32bit-word ()
72 (let ((word (string-to-char-list
73 (buffer-substring (point) (+ (point) 4)))))
75 (apply #'format "%02x%02x%02x%02x"
76 (mapcar (lambda (ch) (logand 255 ch))
77 (if (= gettext-gmo-endian 1234)
81 (defmacro gettext-gmo-header-revision (header)
84 (defmacro gettext-gmo-header-nn (header)
87 (defmacro gettext-gmo-header-oo (header)
90 (defmacro gettext-gmo-header-tt (header)
93 (defmacro gettext-gmo-header-ss (header)
96 (defmacro gettext-gmo-header-hh (header)
99 (defmacro gettext-gmo-read-header ()
101 (make-list 6 '(gettext-hex-string-to-integer
102 (gettext-gmo-read-32bit-word)))))
104 (defun gettext-gmo-collect-strings (nn)
105 (let (strings pos len off)
107 (setq len (gettext-hex-string-to-integer
108 (gettext-gmo-read-32bit-word))
109 off (gettext-hex-string-to-integer
110 (gettext-gmo-read-32bit-word))
113 (push (buffer-substring (point) (+ (point) len))
118 (defun gettext-parse-Content-Type (&optional header)
119 "Return the MIME charset of PO file."
122 (if (require 'mime-parse nil 'noerror)
123 (mime-content-type-parameter (mime-read-Content-Type) "charset")
124 (goto-char (point-min))
125 (let ((case-fold-search t))
126 (if (re-search-forward
127 "^\"Content-Type: *text/plain;[ \t]*charset=\\([^\\]+\\)"
129 (find-mime-charset-by-charsets
130 (list (buffer-substring (match-beginning 1) (match-end 1))))
131 gettext-default-mime-charset)))))
133 (defun gettext-mapcar* (function &rest args)
134 "Apply FUNCTION to successive cars of all ARGS.
135 Return the list of results."
136 (unless (memq nil args)
137 (cons (apply function (mapcar #'car args))
138 (apply #'gettext-mapcar* function
139 (mapcar #'cdr args)))))
141 (defun gettext-load-message-catalogue (file)
143 (let (header strings charset gettext-obarray)
144 (as-binary-input-file
145 (insert-file-contents file)
146 (goto-char (point-min))
147 (when (looking-at "\x95\x04\x12\xde")
148 (setq gettext-gmo-endian 4321))
150 (setq header (gettext-gmo-read-header)
152 (gettext-mapcar* #'cons
154 (goto-char (1+ (gettext-gmo-header-oo header)))
155 (gettext-gmo-collect-strings
156 (gettext-gmo-header-nn header)))
158 (goto-char (1+ (gettext-gmo-header-tt header)))
159 (gettext-gmo-collect-strings
160 (gettext-gmo-header-nn header))))
161 charset (or (gettext-parse-Content-Type
162 (cdr (assoc "" strings)))
164 gettext-obarray (make-vector
165 (* 2 (gettext-gmo-header-nn header))
167 (dolist (oott strings)
168 (set (intern (car oott) gettext-obarray)
169 (decode-mime-charset-string
170 (cdr oott) charset)))
173 (defun gettext-load-portable-message-catalogue (file)
175 (let (strings charset msgstr msgid state gettext-obarray)
176 (as-binary-input-file
177 (insert-file-contents file)
178 (goto-char (point-min))
181 ((looking-at gettext-msgid-regexp)
182 (if (eq state 'msgstr)
183 (push (cons msgid msgstr)
185 (setq msgid (buffer-substring (match-end 0)
186 (progn (end-of-line) (point))))
187 (when (string-match "\"\\s-*$" msgid)
188 (setq msgid (substring msgid 0 (match-beginning 0))))
190 ((looking-at gettext-msgstr-regexp)
191 (setq msgstr (buffer-substring (match-end 0)
192 (progn (end-of-line) (point))))
193 (when (string-match "\"\\s-*$" msgstr)
194 (setq msgstr (substring msgstr 0 (match-beginning 0))))
195 (setq state 'msgstr))
196 ((looking-at "\\s-*\"")
197 (let ((line (buffer-substring (match-end 0)
198 (progn (end-of-line) (point)))))
199 (when (string-match "\"\\s-*$" line)
200 (setq line (substring line 0 (match-beginning 0))))
201 (set state (concat (symbol-value state) line)))))
202 (beginning-of-line 2))
203 (if (eq state 'msgstr)
204 (push (cons msgid msgstr)
208 (goto-char (point-min))
209 (insert "(setq strings '(\n")
210 (dolist (oott strings)
211 (insert (format "(\"%s\" . \"%s\")\n"
212 (car oott) (cdr oott)))
214 (ignore-errors (eval-buffer))
215 (setq charset (or (gettext-parse-Content-Type
216 (cdr (assoc "" strings)))
218 (dolist (oott strings)
219 (set (intern (car oott) gettext-obarray)
220 (decode-mime-charset-string
221 (cdr oott) charset)))
224 (unless (featurep 'i18n3)
226 (defun dgettext (domain string)
227 "Look up STRING in the default message domain and return its translation.
228 \[XEmacs I18N level 3 emulating function]"
229 (let ((oott (assoc domain gettext-message-domain-to-catalog-alist)))
230 (when (stringp (cdr oott))
231 (setcdr oott (gettext-load-message-catalogue
234 (intern-soft string (or (cdr oott) (make-vector 1 0))))
237 (defun gettext (string)
238 "Look up STRING in the default message domain and return its translation.
239 \[XEmacs I18N level 3 emulating function]"
240 (dgettext gettext-default-message-domain string))
242 (defun bind-text-domain (domain pathname)
243 "Associate a pathname with a message domain.
244 Here's how the path to message files is constructed under SunOS 5.0:
245 {pathname}/{LANG}/LC_MESSAGES/{domain}.mo
246 \[XEmacs I18N level 3 emulating function]"
247 (let* ((lang (getenv "LANG"))
248 (file (concat domain ".mo"))
249 (catalog (expand-file-name
250 file (concat pathname "/" lang "/LC_MESSAGES"))))
251 (when (file-exists-p catalog)
252 ;;(file-exists-p (setq catalog (expand-file-name file pathname)))
253 (push (cons domain catalog) gettext-message-domain-to-catalog-alist))))
255 (defun set-domain (domain)
256 "Specify the domain used for translating messages in this source file.
257 The domain declaration may only appear at top-level, and should precede
258 all function and variable definitions.
260 The presence of this declaration in a compiled file effectively sets the
261 domain of all functions and variables which are defined in that file.
262 \[XEmacs I18N level 3 emulating function]"
263 (setq gettext-default-message-domain domain)))
267 ;;; gettext.el ends here