lisp/gettext.el

   1 ;;; gettext.el --- GNU gettext interface
   2 ;; Copyright (C) 1999 Daiki Ueno
   3
   4 ;; Author: Daiki Ueno <ueno@unixuser.org>
   5 ;; Created: 1999-09-10
   6 ;; Keywords: i18n
   7
   8 ;; This file is part of Liece.
   9
  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)
  13 ;; any later version.
  14
  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.
  19
  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.
  24
  25
  26 ;;; Commentary:
  27 ;;
  28
  29 ;;; Code:
  30
  31 (eval-when-compile (require 'cl))
  32
  33 (require 'mcharset)
  34 (require 'static)
  35 (require 'poem)
  36
  37 (eval-when-compile
  38   (autoload 'mime-content-type-parameter "mime-parse")
  39   (autoload 'mime-read-Content-Type "mime-parse"))
  40
  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))
  45
  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
  51 (defconst gettext-msgid-regexp "msgid\\s-*\"")
  52 (defconst gettext-msgstr-regexp "msgstr\\s-*\"")
  53
  54 (defmacro gettext-hex-char-to-integer (character)
  55   `(if (and (>= ,character ?0) (<= ,character ?9))
  56        (- ,character ?0)
  57      (let ((ch (logior ,character 32)))
  58        (if (and (>= ch ?a) (<= ch ?f))
  59            (- ch (- ?a 10))
  60          (error "Invalid hex digit `%c'" ch)))))
  61
  62 (defun gettext-hex-string-to-integer (hex-string)
  63   (let ((hex-num 0))
  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)))
  69     hex-num))
  70
  71 (defun gettext-gmo-read-32bit-word ()
  72   (let ((word (string-to-char-list
  73                (buffer-substring (point) (+ (point) 4)))))
  74     (forward-char 4)
  75     (apply #'format "%02x%02x%02x%02x"
  76            (mapcar (lambda (ch) (logand 255 ch))
  77                    (if (= gettext-gmo-endian 1234)
  78                        (nreverse word)
  79                      word)))))
  80
  81 (defmacro gettext-gmo-header-revision (header)
  82   `(aref header 0))
  83
  84 (defmacro gettext-gmo-header-nn (header)
  85   `(aref header 1))
  86
  87 (defmacro gettext-gmo-header-oo (header)
  88   `(aref header 2))
  89
  90 (defmacro gettext-gmo-header-tt (header)
  91   `(aref header 3))
  92
  93 (defmacro gettext-gmo-header-ss (header)
  94   `(aref header 4))
  95
  96 (defmacro gettext-gmo-header-hh (header)
  97   `(aref header 5))
  98
  99 (defmacro gettext-gmo-read-header ()
 100   (cons 'vector
 101         (make-list 6 '(gettext-hex-string-to-integer
 102                        (gettext-gmo-read-32bit-word)))))
 103
 104 (defun gettext-gmo-collect-strings (nn)
 105   (let (strings pos len off)
 106     (dotimes (i nn)
 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))
 111             pos (point))
 112       (goto-char (1+ off))
 113       (push (buffer-substring (point) (+ (point) len))
 114             strings)
 115       (goto-char pos))
 116     (nreverse strings)))
 117
 118 (defun gettext-parse-Content-Type (&optional header)
 119   "Return the MIME charset of PO file."
 120   (with-temp-buffer
 121     (insert header)
 122     (if (require 'mime-parse nil 'noerror)
 123         (mime-content-type-parameter (mime-read-Content-Type) "charset")
 124       (goto-char (point-min))
 125       (if (re-search-forward
 126            "^\"Content-Type: *text/plain;[ \t]*charset=\\([^\\]+\\)"
 127            nil t)
 128           (find-mime-charset-by-charsets
 129            (list (buffer-substring (match-beginning 1) (match-end 1))))
 130         gettext-default-mime-charset))))
 131
 132 (defun gettext-mapcar* (function &rest args)
 133   "Apply FUNCTION to successive cars of all ARGS.
 134 Return the list of results."
 135   (unless (memq nil args)
 136     (cons (apply function (mapcar #'car args))
 137           (apply #'gettext-mapcar* function
 138                  (mapcar #'cdr args)))))
 139
 140 (defun gettext-load-message-catalogue (file)
 141   (with-temp-buffer
 142     (let (header strings charset gettext-obarray)
 143       (as-binary-input-file
 144        (insert-file-contents file)
 145        (goto-char (point-min))
 146        (when (looking-at "\x95\x04\x12\xde")
 147          (setq gettext-gmo-endian 4321))
 148        (forward-char 4)
 149        (setq header (gettext-gmo-read-header)
 150              strings
 151              (gettext-mapcar* #'cons
 152                      (progn
 153                        (goto-char (1+ (gettext-gmo-header-oo header)))
 154                        (gettext-gmo-collect-strings
 155                         (gettext-gmo-header-nn header)))
 156                      (progn
 157                        (goto-char (1+ (gettext-gmo-header-tt header)))
 158                        (gettext-gmo-collect-strings
 159                         (gettext-gmo-header-nn header))))
 160              charset (or (gettext-parse-Content-Type
 161                           (cdr (assoc "" strings)))
 162                          'x-ctext)
 163              gettext-obarray (make-vector
 164                               (* 2 (gettext-gmo-header-nn header))
 165                               0)))
 166       (dolist (oott strings)
 167         (set (intern (car oott) gettext-obarray)
 168              (decode-mime-charset-string
 169               (cdr oott) charset)))
 170       gettext-obarray)))
 171
 172 (defun gettext-load-portable-message-catalogue (file)
 173   (with-temp-buffer
 174     (let (strings charset msgstr msgid state gettext-obarray)
 175       (as-binary-input-file
 176        (insert-file-contents file)
 177        (goto-char (point-min))
 178        (while (not (eobp))
 179          (cond
 180           ((looking-at gettext-msgid-regexp)
 181            (if (eq state 'msgstr)
 182                (push (cons msgid msgstr)
 183                      strings))
 184            (setq msgid (buffer-substring (match-end 0)
 185                                          (progn (end-of-line) (point))))
 186            (when (string-match "\"\\s-*$" msgid)
 187              (setq msgid (substring msgid 0 (match-beginning 0))))
 188            (setq state 'msgid))
 189           ((looking-at gettext-msgstr-regexp)
 190            (setq msgstr (buffer-substring (match-end 0)
 191                                           (progn (end-of-line) (point))))
 192            (when (string-match "\"\\s-*$" msgstr)
 193              (setq msgstr (substring msgstr 0 (match-beginning 0))))
 194            (setq state 'msgstr))
 195           ((looking-at "\\s-*\"")
 196            (let ((line (buffer-substring (match-end 0)
 197                                          (progn (end-of-line) (point)))))
 198              (when (string-match "\"\\s-*$" line)
 199                (setq line (substring line 0 (match-beginning 0))))
 200              (set state (concat (symbol-value state) line)))))
 201          (beginning-of-line 2))
 202        (if (eq state 'msgstr)
 203            (push (cons msgid msgstr)
 204                  strings))
 205        ;; Remove quotations
 206        (erase-buffer)
 207        (goto-char (point-min))
 208        (insert "(setq strings '(\n")
 209        (dolist (oott strings)
 210          (insert (format "(\"%s\" . \"%s\")\n"
 211                          (car oott) (cdr oott)))
 212          (insert "))"))
 213        (ignore-errors (eval-buffer))
 214        (setq charset (or (gettext-parse-Content-Type
 215                           (cdr (assoc "" strings)))
 216                          'x-ctext)))
 217       (dolist (oott strings)
 218         (set (intern (car oott) gettext-obarray)
 219              (decode-mime-charset-string
 220               (cdr oott) charset)))
 221       gettext-obarray)))
 222
 223 (unless (featurep 'i18n3)
 224   (eval-and-compile
 225     (defun dgettext (domain string)
 226       "Look up STRING in the default message domain and return its translation.
 227 \[XEmacs I18N level 3 emulating function]"
 228       (let ((oott (assoc domain gettext-message-domain-to-catalog-alist)))
 229         (when (stringp (cdr oott))
 230           (setcdr oott (gettext-load-message-catalogue
 231                         (cdr oott))))
 232         (or (symbol-value
 233              (intern-soft string (or (cdr oott) (make-vector 1 0))))
 234             string))))
 235
 236   (defun gettext (string)
 237     "Look up STRING in the default message domain and return its translation.
 238 \[XEmacs I18N level 3 emulating function]"
 239     (dgettext gettext-default-message-domain string))
 240
 241   (defun bind-text-domain (domain pathname)
 242     "Associate a pathname with a message domain.
 243 Here's how the path to message files is constructed under SunOS 5.0:
 244   {pathname}/{LANG}/LC_MESSAGES/{domain}.mo
 245 \[XEmacs I18N level 3 emulating function]"
 246     (let* ((lang (getenv "LANG"))
 247            (file (concat domain ".mo"))
 248            (catalog (expand-file-name
 249                      file (concat pathname "/" lang "/LC_MESSAGES"))))
 250       (when (file-exists-p catalog)
 251         ;;(file-exists-p (setq catalog (expand-file-name file pathname)))
 252         (push (cons domain catalog) gettext-message-domain-to-catalog-alist))))
 253
 254   (defun set-domain (domain)
 255     "Specify the domain used for translating messages in this source file.
 256 The domain declaration may only appear at top-level, and should precede
 257 all function and variable definitions.
 258
 259 The presence of this declaration in a compiled file effectively sets the
 260 domain of all functions and variables which are defined in that file.
 261 \[XEmacs I18N level 3 emulating function]"
 262     (setq gettext-default-message-domain domain)))
 263
 264 (provide 'gettext)
 265
 266 ;;; gettext.el ends here