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       (let ((case-fold-search t))
 126         (if (re-search-forward
 127              "^\"Content-Type: *text/plain;[ \t]*charset=\\([^\\]+\\)"
 128              nil t)
 129             (find-mime-charset-by-charsets
 130              (list (buffer-substring (match-beginning 1) (match-end 1))))
 131           gettext-default-mime-charset)))))
 132
 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)))))
 140
 141 (defun gettext-load-message-catalogue (file)
 142   (with-temp-buffer
 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))
 149        (forward-char 4)
 150        (setq header (gettext-gmo-read-header)
 151              strings
 152              (gettext-mapcar* #'cons
 153                      (progn
 154                        (goto-char (1+ (gettext-gmo-header-oo header)))
 155                        (gettext-gmo-collect-strings
 156                         (gettext-gmo-header-nn header)))
 157                      (progn
 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)))
 163                          'x-ctext)
 164              gettext-obarray (make-vector
 165                               (* 2 (gettext-gmo-header-nn header))
 166                               0)))
 167       (dolist (oott strings)
 168         (set (intern (car oott) gettext-obarray)
 169              (decode-mime-charset-string
 170               (cdr oott) charset)))
 171       gettext-obarray)))
 172
 173 (defun gettext-load-portable-message-catalogue (file)
 174   (with-temp-buffer
 175     (let (strings charset msgstr msgid state gettext-obarray)
 176       (as-binary-input-file
 177        (insert-file-contents file)
 178        (goto-char (point-min))
 179        (while (not (eobp))
 180          (cond
 181           ((looking-at gettext-msgid-regexp)
 182            (if (eq state 'msgstr)
 183                (push (cons msgid msgstr)
 184                      strings))
 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))))
 189            (setq state 'msgid))
 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)
 205                  strings))
 206        ;; Remove quotations
 207        (erase-buffer)
 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)))
 213          (insert "))"))
 214        (ignore-errors (eval-buffer))
 215        (setq charset (or (gettext-parse-Content-Type
 216                           (cdr (assoc "" strings)))
 217                          'x-ctext)))
 218       (dolist (oott strings)
 219         (set (intern (car oott) gettext-obarray)
 220              (decode-mime-charset-string
 221               (cdr oott) charset)))
 222       gettext-obarray)))
 223
 224 (unless (featurep 'i18n3)
 225   (eval-and-compile
 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
 232                         (cdr oott))))
 233         (or (symbol-value
 234              (intern-soft string (or (cdr oott) (make-vector 1 0))))
 235             string))))
 236
 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))
 241
 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))))
 254
 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.
 259
 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)))
 264
 265 (provide 'gettext)
 266
 267 ;;; gettext.el ends here