Source

liece / lisp / gettext.el

;;; gettext.el --- GNU gettext interface
;; Copyright (C) 1999 Daiki Ueno

;; Author: Daiki Ueno <ueno@unixuser.org>
;; Created: 1999-09-10
;; Keywords: i18n

;; This file is part of Liece.

;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.

;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.	 See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING.  If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.


;;; Commentary:
;; 

;;; Code:

(eval-when-compile (require 'cl))

(require 'mcharset)
(require 'static)
(require 'poem)

(eval-when-compile
  (autoload 'mime-content-type-parameter "mime-parse")
  (autoload 'mime-read-Content-Type "mime-parse"))

(static-if (fboundp 'string-to-list)
    (defalias 'gettext-string-to-list 'string-to-list)
  ;; Rely on `string-to-char-list' emulation is provided in poem.
  (defalias 'gettext-string-to-list 'string-to-char-list))

(defvar gettext-gmo-endian 1234)
(defvar gettext-message-domain-to-catalog-alist nil)
(defvar gettext-default-message-domain "emacs")
(defvar gettext-default-mime-charset default-mime-charset)
(defvar gettext-default-locale "C")

(defconst gettext-msgid-regexp "msgid\\s-*\"")
(defconst gettext-msgstr-regexp "msgstr\\s-*\"")

(defmacro gettext-hex-char-to-integer (character)
  `(if (and (>= ,character ?0) (<= ,character ?9))
       (- ,character ?0)
     (let ((ch (logior ,character 32)))
       (if (and (>= ch ?a) (<= ch ?f))
	   (- ch (- ?a 10))
	 (error "Invalid hex digit `%c'" ch)))))

(defun gettext-hex-string-to-integer (hex-string)
  (let ((hex-num 0))
    (while (not (equal hex-string ""))
      (setq hex-num (+ (* hex-num 16)
		       (gettext-hex-char-to-integer
			(string-to-char hex-string)))
	    hex-string (substring hex-string 1)))
    hex-num))

(defun gettext-gmo-read-32bit-word ()
  (let ((word (string-to-char-list
	       (buffer-substring (point) (+ (point) 4)))))
    (forward-char 4)
    (apply #'format "%02x%02x%02x%02x"
	   (mapcar (lambda (ch) (logand 255 ch))
		   (if (= gettext-gmo-endian 1234)
		       (nreverse word)
		     word)))))
    
(defmacro gettext-gmo-header-revision (header)
  `(aref header 0))

(defmacro gettext-gmo-header-nn (header)
  `(aref header 1))

(defmacro gettext-gmo-header-oo (header)
  `(aref header 2))

(defmacro gettext-gmo-header-tt (header)
  `(aref header 3))

(defmacro gettext-gmo-header-ss (header)
  `(aref header 4))

(defmacro gettext-gmo-header-hh (header)
  `(aref header 5))

(defmacro gettext-gmo-read-header ()
  (cons 'vector
	(make-list 6 '(gettext-hex-string-to-integer
		       (gettext-gmo-read-32bit-word)))))

(defun gettext-gmo-collect-strings (nn)
  (let (strings pos len off)
    (dotimes (i nn)
      (setq len (gettext-hex-string-to-integer
		 (gettext-gmo-read-32bit-word))
	    off (gettext-hex-string-to-integer
		 (gettext-gmo-read-32bit-word))
	    pos (point))
      (goto-char (1+ off))
      (push (buffer-substring (point) (+ (point) len))
	    strings)
      (goto-char pos))
    (nreverse strings)))

(defun gettext-parse-Content-Type (&optional header)
  "Return the MIME charset of PO file."
  (with-temp-buffer
    (insert header)
    (if (require 'mime-parse nil 'noerror)
	(mime-content-type-parameter (mime-read-Content-Type) "charset")
      (goto-char (point-min))
      (let ((case-fold-search t))
	(if (re-search-forward
	     "^\"Content-Type: *text/plain;[ \t]*charset=\\([^\\]+\\)"
	     nil t)
	    (find-mime-charset-by-charsets
	     (list (buffer-substring (match-beginning 1) (match-end 1))))
	  gettext-default-mime-charset)))))

(defun gettext-mapcar* (function &rest args)
  "Apply FUNCTION to successive cars of all ARGS.
Return the list of results."
  (let (result)
    (while (not (memq nil args))
      (push (apply function (mapcar #'car args)) result)
      (setq args (mapcar #'cdr args)))
    (nreverse result)))

(defun gettext-load-message-catalogue (file)
  (with-temp-buffer
    (let (header strings charset gettext-obarray)
      (as-binary-input-file
       (insert-file-contents file)
       (goto-char (point-min))
       (when (looking-at "\x95\x04\x12\xde")
	 (setq gettext-gmo-endian 4321))
       (forward-char 4)
       (setq header (gettext-gmo-read-header)
	     strings
	     (gettext-mapcar* #'cons
		     (progn
		       (goto-char (1+ (gettext-gmo-header-oo header)))
		       (gettext-gmo-collect-strings
			(gettext-gmo-header-nn header)))
		     (progn
		       (goto-char (1+ (gettext-gmo-header-tt header)))
		       (gettext-gmo-collect-strings
			(gettext-gmo-header-nn header))))
	     charset (or (gettext-parse-Content-Type
			  (cdr (assoc "" strings)))
			 'x-ctext)
	     gettext-obarray (make-vector
			      (* 2 (gettext-gmo-header-nn header))
			      0)))
      (dolist (oott strings)
	(set (intern (car oott) gettext-obarray)
	     (decode-mime-charset-string
	      (cdr oott) charset)))
      gettext-obarray)))

(defun gettext-load-portable-message-catalogue (file)
  (with-temp-buffer
    (let (strings charset msgstr msgid state gettext-obarray)
      (as-binary-input-file
       (insert-file-contents file)
       (goto-char (point-min))
       (while (not (eobp))
	 (cond
	  ((looking-at gettext-msgid-regexp)
	   (if (eq state 'msgstr)
	       (push (cons msgid msgstr)
		     strings))
	   (setq msgid (buffer-substring (match-end 0)
					 (progn (end-of-line) (point))))
	   (when (string-match "\"\\s-*$" msgid)
	     (setq msgid (substring msgid 0 (match-beginning 0))))
	   (setq state 'msgid))
	  ((looking-at gettext-msgstr-regexp)
	   (setq msgstr (buffer-substring (match-end 0)
					  (progn (end-of-line) (point))))
	   (when (string-match "\"\\s-*$" msgstr)
	     (setq msgstr (substring msgstr 0 (match-beginning 0))))
	   (setq state 'msgstr))
	  ((looking-at "\\s-*\"")
	   (let ((line (buffer-substring (match-end 0)
					 (progn (end-of-line) (point)))))
	     (when (string-match "\"\\s-*$" line)
	       (setq line (substring line 0 (match-beginning 0))))
	     (set state (concat (symbol-value state) line)))))
	 (beginning-of-line 2))
       (if (eq state 'msgstr)
	   (push (cons msgid msgstr)
		 strings))
       ;; Remove quotations
       (erase-buffer)
       (goto-char (point-min))
       (insert "(setq strings '(\n")
       (dolist (oott strings)
	 (insert (format "(\"%s\" . \"%s\")\n"
			 (car oott) (cdr oott)))
	 (insert "))"))
       (ignore-errors (eval-buffer))
       (setq charset (or (gettext-parse-Content-Type
			  (cdr (assoc "" strings)))
			 'x-ctext)))
      (dolist (oott strings)
	(set (intern (car oott) gettext-obarray)
	     (decode-mime-charset-string
	      (cdr oott) charset)))
      gettext-obarray)))

(unless (featurep 'i18n3)
  (eval-and-compile
    (defun dgettext (domain string)
      "Look up STRING in the default message domain and return its translation.
\[XEmacs I18N level 3 emulating function]"
      (let ((oott (assoc domain gettext-message-domain-to-catalog-alist)))
	(when (stringp (cdr oott))
	  (setcdr oott (gettext-load-message-catalogue
			(cdr oott))))
	(or (symbol-value
	     (intern-soft string (or (cdr oott) (make-vector 1 0))))
	    string))))
  
  (defun gettext (string)
    "Look up STRING in the default message domain and return its translation.
\[XEmacs I18N level 3 emulating function]"
    (dgettext gettext-default-message-domain string))

  (defun bind-text-domain (domain pathname)
    "Associate a pathname with a message domain.
Here's how the path to message files is constructed under SunOS 5.0:
  {pathname}/{LANG}/LC_MESSAGES/{domain}.mo
\[XEmacs I18N level 3 emulating function]"
    (let* ((lang (or (getenv "LC_ALL") (getenv "LC_MESSAGES") (getenv "LANG")
		     gettext-default-locale))
	   (language (progn
		       (string-match "\\([^_.]+\\)\\(_[^.]+\\)?\\(\\.[^@]+\\)?"
				     lang)
		       (match-string 1 lang)))
	   (territory (match-string 2 lang))
	   (code-set (match-string 3 lang))
	   (lang-path (if lang
			  (delq nil (list (if (and territory code-set)
					      (concat language territory
						      code-set))
					  (if territory
					      (concat language territory))
					  (if code-set
					      (concat language code-set))
					  language))))
	   (file (concat domain ".mo"))
	   catalog)
      (while (and (setq lang (car lang-path))
		  (setq catalog
			(expand-file-name file
					  (concat pathname
						  "/" lang "/LC_MESSAGES")))
		  (not (file-exists-p catalog)))
	(setq lang-path (cdr lang-path)))
      (when (file-exists-p catalog)
	;;(file-exists-p (setq catalog (expand-file-name file pathname)))
	(push (cons domain catalog) gettext-message-domain-to-catalog-alist))))

  (defun set-domain (domain)
    "Specify the domain used for translating messages in this source file.
The domain declaration may only appear at top-level, and should precede
all function and variable definitions.

The presence of this declaration in a compiled file effectively sets the
domain of all functions and variables which are defined in that file.
\[XEmacs I18N level 3 emulating function]"
    (setq gettext-default-message-domain domain)))

(provide 'gettext)

;;; gettext.el ends here
Tip: Filter by directory path e.g. /media app.js to search for public/media/app.js.
Tip: Use camelCasing e.g. ProjME to search for ProjectModifiedEvent.java.
Tip: Filter by extension type e.g. /repo .js to search for all .js files in the /repo directory.
Tip: Separate your search with spaces e.g. /ssh pom.xml to search for src/ssh/pom.xml.
Tip: Use ↑ and ↓ arrow keys to navigate and return to view the file.
Tip: You can also navigate files with Ctrl+j (next) and Ctrl+k (previous) and view the file with Ctrl+o.
Tip: You can also navigate files with Alt+j (next) and Alt+k (previous) and view the file with Alt+o.