cgit.sxemacs.org Git - riece/blob - lisp/riece-mcat.el

   1 (defvar riece-mcat-alist
   2   '(("Japanese" . riece-mcat-japanese)))
   3
   4 (defun riece-mcat (string)
   5   (let ((entry (assoc current-language-environment riece-mcat-alist)))
   6     (when entry
   7       (require (cdr entry))
   8       (or (cdr (assoc string (symbol-value (intern
   9                                             (concat (symbol-name (cdr entry))
  10                                                     "-alist")))))
  11           string))))
  12
  13 (defun riece-mcat-extract-from-form (form)
  14   (if (and form (listp form))
  15       (if (eq (car form) 'riece-mcat)
  16           (cdr form)
  17         (delq nil (apply #'nconc
  18                          (mapcar #'riece-mcat-extract-from-form form))))))
  19
  20 (defun riece-mcat-extract (files alist)
  21   (let (message-list pointer)
  22     (while files
  23       (save-excursion
  24         (set-buffer (find-file-noselect (car files)))
  25         (goto-char (point-min))
  26         (while (progn
  27              (while (progn (skip-chars-forward " \t\n\f")
  28                            (looking-at ";"))
  29                (forward-line 1))
  30              (not (eobp)))
  31           (setq message-list
  32                 (nconc message-list
  33                        (riece-mcat-extract-from-form
  34                         (read (current-buffer)))))))
  35       (setq files (cdr files)))
  36     (setq message-list (sort message-list #'string-lessp)
  37           pointer message-list)
  38     (while pointer
  39       (if (equal (car pointer)
  40                  (nth 1 pointer))
  41           (setcdr pointer (nth 2 pointer))
  42         (unless (assoc (car pointer) alist)
  43           (setq alist (cons (list (car pointer)) alist))))
  44       (setq pointer (cdr pointer)))
  45     alist))
  46
  47 (provide 'riece-mcat)