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