1cccd7e3e6ccc27212ea16be48bab141d48d238b
[riece] / lisp / riece-mcat.el
1 ;;; riece-mcat.el --- message catalog
2 ;; Copyright (C) 2007 Daiki Ueno
3
4 ;; Author: Daiki Ueno <ueno@unixuser.org>
5
6 ;; This file is part of Riece.
7
8 ;; This program is free software; you can redistribute it and/or modify
9 ;; it under the terms of the GNU General Public License as published by
10 ;; the Free Software Foundation; either version 2, or (at your option)
11 ;; any later version.
12
13 ;; This program is distributed in the hope that it will be useful,
14 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
15 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
16 ;; GNU General Public License for more details.
17
18 ;; You should have received a copy of the GNU General Public License
19 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
20 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
21 ;; Boston, MA 02110-1301, USA.
22
23 ;;; Code:
24
25 (require 'pp)
26
27 (defun riece-mcat (string)
28   "Translate STRING in the current language environment."
29   (let ((feature (if (featurep 'mule)
30                      (get-language-info current-language-environment
31                                         'riece-mcat-feature))))
32     (if feature
33         (progn
34           (require feature)
35           (or (cdr (assoc string
36                           (symbol-value
37                            (intern (concat (symbol-name feature) "-alist")))))
38               string))
39       string)))
40
41 (defun riece-mcat-extract-from-form (form)
42   (if (and form (listp form) (listp (cdr form)))
43       (if (and (= (length form) 2)
44                (eq (car form) 'riece-mcat)
45                (stringp (car (cdr form))))
46           (cdr form)
47         (delq nil (apply #'nconc
48                          (mapcar #'riece-mcat-extract-from-form form))))))
49
50 (defun riece-mcat-extract (files)
51   (save-excursion
52     (let (message-list pointer)
53       (while files
54         (with-temp-buffer
55           (insert-file-contents (car files))
56           (goto-char (point-min))
57           (while (progn
58                    (while (progn (skip-chars-forward " \t\n\f")
59                                  (looking-at ";"))
60                      (forward-line 1))
61                    (not (eobp)))
62             (setq message-list
63                   (nconc message-list
64                          (riece-mcat-extract-from-form
65                           (read (current-buffer)))))))
66         (setq files (cdr files)))
67       (setq message-list (sort message-list #'string-lessp)
68             pointer message-list)
69       (while pointer
70         (if (member (car pointer) (cdr pointer))
71             (setcar pointer nil))
72         (setq pointer (cdr pointer)))
73       (delq nil message-list))))
74
75 (defun riece-mcat-update (files mcat-file mcat-alist-symbol)
76   "Update MCAT-FILE."
77   (let ((pp-escape-newlines t)
78         alist)
79     (save-excursion
80       (set-buffer (find-file-noselect mcat-file))
81       (goto-char (point-min))
82       (if (re-search-forward (concat "^\\s-*(\\(defvar\\|defconst\\)\\s-+"
83                                      (regexp-quote (symbol-name
84                                                     mcat-alist-symbol)))
85                              nil t)
86           (progn
87             (goto-char (match-beginning 0))
88             (save-excursion
89               (eval (read (current-buffer))))
90             (delete-region (point) (progn (forward-sexp) (point))))
91         (set mcat-alist-symbol nil))
92       (setq alist (mapcar (lambda (message)
93                             (or (assoc message
94                                        (symbol-value mcat-alist-symbol))
95                                 (list message)))
96                           (riece-mcat-extract files)))
97       (insert "(defconst " (symbol-name mcat-alist-symbol) "\n  '(")
98       (while alist
99         (insert "(" (pp-to-string (car (car alist))) " . "
100                 (pp-to-string (cdr (car alist))) ")")
101         (if (cdr alist)
102             (insert "\n    "))
103         (setq alist (cdr alist)))
104       (insert "))")
105       (save-buffer))))
106
107 (defconst riece-mcat-description "Translate messages.")
108
109 (defun riece-mcat-insinuate ()
110   (set-language-info "Japanese" 'riece-mcat-feature 'riece-mcat-japanese))
111
112 (defun riece-mcat-uninstall ()
113   (set-language-info "Japanese" 'riece-mcat-feature nil))
114
115 (provide 'riece-mcat)
116
117 ;;; riece-mcat.el ends here