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
  35 (eval-and-compile
  36   (autoload 'mime-content-type-parameter "mime-parse")
  37   (autoload 'mime-read-Content-Type "mime-parse"))
  38
  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)
  43
  44 (defconst gettext-msgid-regexp "msgid\\s-*\"")
  45 (defconst gettext-msgstr-regexp "msgstr\\s-*\"")
  46
  47 (defmacro gettext-hex-char-to-integer (character)
  48   `(if (and (>= ,character ?0) (<= ,character ?9))
  49        (- ,character ?0)
  50      (let ((ch (logior ,character 32)))
  51        (if (and (>= ch ?a) (<= ch ?f))
  52            (- ch (- ?a 10))
  53          (error "Invalid hex digit `%c'" ch)))))
  54
  55 (defun gettext-hex-string-to-integer (hex-string)
  56   (let ((hex-num 0))
  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)))
  62     hex-num))
  63
  64 (defun gettext-gmo-read-32bit-word ()
  65   (let ((word (string-to-char-list
  66                (buffer-substring (point) (+ (point) 4)))))
  67     (forward-char 4)
  68     (apply #'format "%02x%02x%02x%02x"
  69            (mapcar (lambda (ch) (logand 255 ch))
  70                    (if (= gettext-gmo-endian 1234)
  71                        (nreverse word)
  72                      word)))))
  73
  74 (defmacro gettext-gmo-header-revision (header)
  75   `(aref header 0))
  76
  77 (defmacro gettext-gmo-header-nn (header)
  78   `(aref header 1))
  79
  80 (defmacro gettext-gmo-header-oo (header)
  81   `(aref header 2))
  82
  83 (defmacro gettext-gmo-header-tt (header)
  84   `(aref header 3))
  85
  86 (defmacro gettext-gmo-header-ss (header)
  87   `(aref header 4))
  88
  89 (defmacro gettext-gmo-header-hh (header)
  90   `(aref header 5))
  91
  92 (defmacro gettext-gmo-read-header ()
  93   (cons 'vector
  94         (make-list 6 '(gettext-hex-string-to-integer
  95                        (gettext-gmo-read-32bit-word)))))
  96
  97 (defun gettext-gmo-collect-strings (nn)
  98   (let (strings pos len off)
  99     (dotimes (i nn)
 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))
 104             pos (point))
 105       (goto-char (1+ off))
 106       (push (buffer-substring (point) (+ (point) len))
 107             strings)
 108       (goto-char pos))
 109     (nreverse strings)))
 110
 111 (defmacro gettext-parse-Content-Type (&optional header)
 112   (require 'path-util)
 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)
 118               "charset"))
 119     'gettext-default-mime-charset))
 120
 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)))))
 128
 129 (defun gettext-load-message-catalogue (file)
 130   (with-temp-buffer
 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))
 137        (forward-char 4)
 138        (setq header (gettext-gmo-read-header)
 139              strings
 140              (gettext-mapcar* #'cons
 141                      (progn
 142                        (goto-char (1+ (gettext-gmo-header-oo header)))
 143                        (gettext-gmo-collect-strings
 144                         (gettext-gmo-header-nn header)))
 145                      (progn
 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)))
 151                          'x-ctext)
 152              gettext-obarray (make-vector
 153                               (* 2 (gettext-gmo-header-nn header))
 154                               0)))
 155       (dolist (oott strings)
 156         (set (intern (car oott) gettext-obarray)
 157              (decode-mime-charset-string
 158               (cdr oott) charset)))
 159       gettext-obarray)))
 160
 161 (defun gettext-load-portable-message-catalogue (file)
 162   (with-temp-buffer
 163     (let (strings charset msgstr msgid state gettext-obarray)
 164       (as-binary-input-file
 165        (insert-file-contents file)
 166        (goto-char (point-min))
 167        (while (not (eobp))
 168          (cond
 169           ((looking-at gettext-msgid-regexp)
 170            (if (eq state 'msgstr)
 171                (push (cons msgid msgstr)
 172                      strings))
 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))))
 177            (setq state 'msgid))
 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)
 193                  strings))
 194        ;; Remove quotations
 195        (erase-buffer)
 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)))
 201          (insert "))"))
 202        (ignore-errors (eval-buffer))
 203        (setq charset (or (gettext-parse-Content-Type
 204                           (cdr (assoc "" strings)))
 205                          'x-ctext)))
 206       (dolist (oott strings)
 207         (set (intern (car oott) gettext-obarray)
 208              (decode-mime-charset-string
 209               (cdr oott) charset)))
 210       gettext-obarray)))
 211
 212 (unless (featurep 'i18n3)
 213   (eval-and-compile
 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
 220                         (cdr oott))))
 221         (or (symbol-value
 222              (intern-soft string (or (cdr oott) (make-vector 1 0))))
 223             string))))
 224
 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))
 229
 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))))
 242
 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.
 247
 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)))
 252
 253 (provide 'gettext)
 254
 255 ;;; gettext.el ends here