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))
36 (autoload 'mime-content-type-parameter "mime-parse")
37 (autoload 'mime-read-Content-Type "mime-parse"))
39 (defvar gettext-gmo-endian 1234)
40 (defvar gettext-message-domain-to-catalog-alist nil)
41 (defvar gettext-default-message-domain "emacs")
42 (defvar gettext-default-mime-charset default-mime-charset)
44 (defconst gettext-msgid-regexp "msgid\\s-*\"")
45 (defconst gettext-msgstr-regexp "msgstr\\s-*\"")
47 (defmacro gettext-hex-char-to-integer (character)
48 `(if (and (>= ,character ?0) (<= ,character ?9))
50 (let ((ch (logior ,character 32)))
51 (if (and (>= ch ?a) (<= ch ?f))
53 (error "Invalid hex digit `%c'" ch)))))
55 (defun gettext-hex-string-to-integer (hex-string)
57 (while (not (equal hex-string ""))
58 (setq hex-num (+ (* hex-num 16)
59 (gettext-hex-char-to-integer
60 (string-to-char hex-string)))
61 hex-string (substring hex-string 1)))
64 (defun gettext-gmo-read-32bit-word ()
65 (let ((word (string-to-char-list
66 (buffer-substring (point) (+ (point) 4)))))
68 (apply #'format "%02x%02x%02x%02x"
69 (mapcar (lambda (ch) (logand 255 ch))
70 (if (= gettext-gmo-endian 1234)
74 (defmacro gettext-gmo-header-revision (header)
77 (defmacro gettext-gmo-header-nn (header)
80 (defmacro gettext-gmo-header-oo (header)
83 (defmacro gettext-gmo-header-tt (header)
86 (defmacro gettext-gmo-header-ss (header)
89 (defmacro gettext-gmo-header-hh (header)
92 (defmacro gettext-gmo-read-header ()
94 (make-list 6 '(gettext-hex-string-to-integer
95 (gettext-gmo-read-32bit-word)))))
97 (defun gettext-gmo-collect-strings (nn)
98 (let (strings pos len off)
100 (setq len (gettext-hex-string-to-integer
101 (gettext-gmo-read-32bit-word))
102 off (gettext-hex-string-to-integer
103 (gettext-gmo-read-32bit-word))
106 (push (buffer-substring (point) (+ (point) len))
111 (defmacro gettext-parse-Content-Type (&optional header)
113 (if (module-installed-p 'mime-parse)
114 (list 'with-temp-buffer
115 (list 'insert header)
116 '(mime-content-type-parameter
117 (mime-read-Content-Type)
119 'gettext-default-mime-charset))
121 (defun gettext-mapcar* (function &rest args)
122 "Apply FUNCTION to successive cars of all ARGS.
123 Return the list of results."
124 (unless (memq nil args)
125 (cons (apply function (mapcar #'car args))
126 (apply #'gettext-mapcar* function
127 (mapcar #'cdr args)))))
129 (defun gettext-load-message-catalogue (file)
131 (let (header strings charset gettext-obarray)
132 (as-binary-input-file
133 (insert-file-contents file)
134 (goto-char (point-min))
135 (when (looking-at "\x95\x04\x12\xde")
136 (setq gettext-gmo-endian 4321))
138 (setq header (gettext-gmo-read-header)
140 (gettext-mapcar* #'cons
142 (goto-char (1+ (gettext-gmo-header-oo header)))
143 (gettext-gmo-collect-strings
144 (gettext-gmo-header-nn header)))
146 (goto-char (1+ (gettext-gmo-header-tt header)))
147 (gettext-gmo-collect-strings
148 (gettext-gmo-header-nn header))))
149 charset (or (gettext-parse-Content-Type
150 (cdr (assoc "" strings)))
152 gettext-obarray (make-vector
153 (* 2 (gettext-gmo-header-nn header))
155 (dolist (oott strings)
156 (set (intern (car oott) gettext-obarray)
157 (decode-mime-charset-string
158 (cdr oott) charset)))
161 (defun gettext-load-portable-message-catalogue (file)
163 (let (strings charset msgstr msgid state gettext-obarray)
164 (as-binary-input-file
165 (insert-file-contents file)
166 (goto-char (point-min))
169 ((looking-at gettext-msgid-regexp)
170 (if (eq state 'msgstr)
171 (push (cons msgid msgstr)
173 (setq msgid (buffer-substring (match-end 0)
174 (progn (end-of-line) (point))))
175 (when (string-match "\"\\s-*$" msgid)
176 (setq msgid (substring msgid 0 (match-beginning 0))))
178 ((looking-at gettext-msgstr-regexp)
179 (setq msgstr (buffer-substring (match-end 0)
180 (progn (end-of-line) (point))))
181 (when (string-match "\"\\s-*$" msgstr)
182 (setq msgstr (substring msgstr 0 (match-beginning 0))))
183 (setq state 'msgstr))
184 ((looking-at "\\s-*\"")
185 (let ((line (buffer-substring (match-end 0)
186 (progn (end-of-line) (point)))))
187 (when (string-match "\"\\s-*$" line)
188 (setq line (substring line 0 (match-beginning 0))))
189 (set state (concat (symbol-value state) line)))))
190 (beginning-of-line 2))
191 (if (eq state 'msgstr)
192 (push (cons msgid msgstr)
196 (goto-char (point-min))
197 (insert "(setq strings '(\n")
198 (dolist (oott strings)
199 (insert (format "(\"%s\" . \"%s\")\n"
200 (car oott) (cdr oott)))
202 (ignore-errors (eval-buffer))
203 (setq charset (or (gettext-parse-Content-Type
204 (cdr (assoc "" strings)))
206 (dolist (oott strings)
207 (set (intern (car oott) gettext-obarray)
208 (decode-mime-charset-string
209 (cdr oott) charset)))
212 (unless (featurep 'i18n3)
214 (defun dgettext (domain string)
215 "Look up STRING in the default message domain and return its translation.
216 \[XEmacs I18N level 3 emulating function]"
217 (let ((oott (assoc domain gettext-message-domain-to-catalog-alist)))
218 (when (stringp (cdr oott))
219 (setcdr oott (gettext-load-message-catalogue
222 (intern-soft string (or (cdr oott) (make-vector 1 0))))
225 (defun gettext (string)
226 "Look up STRING in the default message domain and return its translation.
227 \[XEmacs I18N level 3 emulating function]"
228 (dgettext gettext-default-message-domain string))
230 (defun bind-text-domain (domain pathname)
231 "Associate a pathname with a message domain.
232 Here's how the path to message files is constructed under SunOS 5.0:
233 {pathname}/{LANG}/LC_MESSAGES/{domain}.mo
234 \[XEmacs I18N level 3 emulating function]"
235 (let* ((lang (getenv "LANG"))
236 (file (concat domain ".mo"))
237 (catalog (expand-file-name
238 file (concat pathname "/" lang "/LC_MESSAGES"))))
239 (when (file-exists-p catalog)
240 ;;(file-exists-p (setq catalog (expand-file-name file pathname)))
241 (push (cons domain catalog) gettext-message-domain-to-catalog-alist))))
243 (defun set-domain (domain)
244 "Specify the domain used for translating messages in this source file.
245 The domain declaration may only appear at top-level, and should precede
246 all function and variable definitions.
248 The presence of this declaration in a compiled file effectively sets the
249 domain of all functions and variables which are defined in that file.
250 \[XEmacs I18N level 3 emulating function]"
251 (setq gettext-default-message-domain domain)))
255 ;;; gettext.el ends here