;;; 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)

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

(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)

(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)))

(defmacro gettext-parse-Content-Type (&optional header)
  (require 'path-util)
  (if (module-installed-p 'mime-parse)
      (list 'with-temp-buffer
	    (list 'insert header)
	    '(mime-content-type-parameter
	      (mime-read-Content-Type)
	      "charset"))
    'gettext-default-mime-charset))

(defun gettext-mapcar* (function &rest args)
  "Apply FUNCTION to successive cars of all ARGS.
Return the list of results."
  (unless (memq nil args)
    (cons (apply function (mapcar #'car args))
	  (apply #'gettext-mapcar* function
		 (mapcar #'cdr args)))))

(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 (getenv "LANG"))
	   (file (concat domain ".mo"))
	   (catalog (expand-file-name
		     file (concat pathname "/" lang "/LC_MESSAGES"))))
      (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