Merge handa-2001-2-14 of rmail-mime. handa-2001-2-14
authortomo <tomo>
Wed, 28 Mar 2001 10:32:00 +0000 (10:32 +0000)
committertomo <tomo>
Wed, 28 Mar 2001 10:32:00 +0000 (10:32 +0000)
73 files changed:
emacs-lisp/alist.el [new file with mode: 0644]
emacs-lisp/broken.el [new file with mode: 0644]
emacs-lisp/calist.el [new file with mode: 0644]
emacs-lisp/filename.el [new file with mode: 0644]
emacs-lisp/install.el [new file with mode: 0644]
emacs-lisp/luna.el [new file with mode: 0644]
emacs-lisp/path-util.el [new file with mode: 0644]
emacs-lisp/static.el [new file with mode: 0644]
mail/hex-util.el [new file with mode: 0644]
mail/hmac-def.el [new file with mode: 0644]
mail/hmac-md5.el [new file with mode: 0644]
mail/hmac-sha1.el [new file with mode: 0644]
mail/qmtp.el [new file with mode: 0644]
mail/rmail-mime.el [new file with mode: 0644]
mail/sasl-cram.el [new file with mode: 0644]
mail/sasl-digest.el [new file with mode: 0644]
mail/sasl.el [new file with mode: 0644]
mail/sha1.el [new file with mode: 0644]
mail/smtp.el [new file with mode: 0644]
mime/emh-comp.el [new file with mode: 0644]
mime/emh-def.el [new file with mode: 0644]
mime/emh-face.el [new file with mode: 0644]
mime/emh-setup.el [new file with mode: 0644]
mime/emh.el [new file with mode: 0644]
mime/eword-decode.el [new file with mode: 0644]
mime/eword-encode.el [new file with mode: 0644]
mime/mail-mime-setup.el [new file with mode: 0644]
mime/mcharset.el [new file with mode: 0644]
mime/mcs-20.el [new file with mode: 0644]
mime/mcs-e20.el [new file with mode: 0644]
mime/mel-b-ccl.el [new file with mode: 0644]
mime/mel-b.el [new file with mode: 0644]
mime/mel-g.el [new file with mode: 0644]
mime/mel-q-ccl.el [new file with mode: 0644]
mime/mel-u.el [new file with mode: 0644]
mime/mel.el [new file with mode: 0644]
mime/mime-bbdb.el [new file with mode: 0644]
mime/mime-conf.el [new file with mode: 0644]
mime/mime-def.el [new file with mode: 0644]
mime/mime-edit.el [new file with mode: 0644]
mime/mime-image.el [new file with mode: 0644]
mime/mime-parse.el [new file with mode: 0644]
mime/mime-partial.el [new file with mode: 0644]
mime/mime-pgp.el [new file with mode: 0644]
mime/mime-play.el [new file with mode: 0644]
mime/mime-setup.el [new file with mode: 0644]
mime/mime-view.el [new file with mode: 0644]
mime/mime-w3.el [new file with mode: 0644]
mime/mime.el [new file with mode: 0644]
mime/mmbabyl.el [new file with mode: 0644]
mime/mmbuffer.el [new file with mode: 0644]
mime/mmcooked.el [new file with mode: 0644]
mime/mmexternal.el [new file with mode: 0644]
mime/mmgeneric.el [new file with mode: 0644]
mime/pgg-def.el [new file with mode: 0644]
mime/pgg-gpg.el [new file with mode: 0644]
mime/pgg-parse.el [new file with mode: 0644]
mime/pgg-pgp.el [new file with mode: 0644]
mime/pgg-pgp5.el [new file with mode: 0644]
mime/pgg.el [new file with mode: 0644]
mime/postpet.el [new file with mode: 0644]
mime/semi-def.el [new file with mode: 0644]
mime/semi-setup.el [new file with mode: 0644]
mime/signature.el [new file with mode: 0644]
mime/smime.el [new file with mode: 0644]
mime/std11.el [new file with mode: 0644]
poe/apel-ver.el [new file with mode: 0644]
poe/inv-19.el [new file with mode: 0644]
poe/invisible.el [new file with mode: 0644]
poe/pccl-20.el [new file with mode: 0644]
poe/pccl.el [new file with mode: 0644]
poe/product.el [new file with mode: 0644]
richtext.el [new file with mode: 0644]

diff --git a/emacs-lisp/alist.el b/emacs-lisp/alist.el
new file mode 100644 (file)
index 0000000..4b656de
--- /dev/null
@@ -0,0 +1,110 @@
+;;; alist.el --- utility functions for association list
+
+;; Copyright (C) 1993,1994,1995,1996,1998,2000 Free Software Foundation, Inc.
+
+;; Author: MORIOKA Tomohiko <tomo@m17n.org>
+;; Keywords: alist
+
+;; This file is part of GNU Emacs.
+
+;; 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.
+
+;;; Code:
+
+;;;###autoload
+(defun put-alist (key value alist)
+  "Set cdr of an element (KEY . ...) in ALIST to VALUE and return ALIST.
+If there is no such element, create a new pair (KEY . VALUE) and
+return a new alist whose car is the new pair and cdr is ALIST."
+  (let ((elm (assoc key alist)))
+    (if elm
+       (progn
+         (setcdr elm value)
+         alist)
+      (cons (cons key value) alist))))
+
+;;;###autoload
+(defun del-alist (key alist)
+  "Delete an element whose car equals KEY from ALIST.
+Return the modified ALIST."
+  (if (equal key (car (car alist)))
+      (cdr alist)
+    (let ((pr alist)
+         (r (cdr alist)))
+      (catch 'tag
+       (while (not (null r))
+         (if (equal key (car (car r)))
+             (progn
+               (rplacd pr (cdr r))
+               (throw 'tag alist)))
+         (setq pr r)
+         (setq r (cdr r)))
+       alist))))
+
+;;;###autoload
+(defun set-alist (symbol key value)
+  "Set cdr of an element (KEY . ...) in the alist bound to SYMBOL to VALUE."
+  (or (boundp symbol)
+      (set symbol nil))
+  (set symbol (put-alist key value (symbol-value symbol))))
+
+;;;###autoload
+(defun remove-alist (symbol key)
+  "Delete an element whose car equals KEY from the alist bound to SYMBOL."
+  (and (boundp symbol)
+       (set symbol (del-alist key (symbol-value symbol)))))
+
+;;;###autoload
+(defun modify-alist (modifier default)
+  "Store elements in the alist MODIFIER in the alist DEFAULT.
+Return the modified alist."
+  (mapcar (function
+          (lambda (as)
+            (setq default (put-alist (car as)(cdr as) default))))
+         modifier)
+  default)
+
+;;;###autoload
+(defun set-modified-alist (symbol modifier)
+  "Store elements in the alist MODIFIER in an alist bound to SYMBOL.
+If SYMBOL is not bound, set it to nil at first."
+  (if (not (boundp symbol))
+      (set symbol nil))
+  (set symbol (modify-alist modifier (eval symbol))))
+
+
+;;; @ association-vector-list
+;;;
+
+;;;###autoload
+(defun vassoc (key avlist)
+  "Search AVLIST for an element whose first element equals KEY.
+AVLIST is a list of vectors.
+See also `assoc'."
+  (while (and avlist
+             (not (equal key (aref (car avlist) 0))))
+    (setq avlist (cdr avlist)))
+  (and avlist
+       (car avlist)))
+
+
+;;; @ end
+;;;
+
+(require 'product)
+(product-provide (provide 'alist) (require 'apel-ver))
+
+;;; alist.el ends here
diff --git a/emacs-lisp/broken.el b/emacs-lisp/broken.el
new file mode 100644 (file)
index 0000000..d30d97c
--- /dev/null
@@ -0,0 +1,113 @@
+;;; broken.el --- Emacs broken facility infomation registry.
+
+;; Copyright (C) 1998, 1999 Tanaka Akira <akr@jaist.ac.jp>
+
+;; Author: Tanaka Akira <akr@jaist.ac.jp>
+;; Keywords: emulation, compatibility, incompatibility, Mule
+
+;; This file is part of APEL (A Portable Emacs Library).
+
+;; 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.
+
+;;; Code:
+
+(require 'static)
+
+(eval-and-compile
+
+  (defvar notice-non-obvious-broken-facility t
+    "If the value is t, non-obvious broken facility is noticed when
+`broken-facility' macro is expanded.")
+
+  (defun broken-facility-internal (facility &optional docstring assertion)
+    "Declare that FACILITY emulation is broken if ASSERTION is nil."
+    (when docstring
+      (put facility 'broken-docstring docstring))
+    (put facility 'broken (not assertion)))
+
+  (defun broken-p (facility)
+    "t if FACILITY emulation is broken."
+    (get facility 'broken))
+
+  (defun broken-facility-description (facility)
+    "Return description for FACILITY."
+    (get facility 'broken-docstring))
+
+  )
+
+(put 'broken-facility 'lisp-indent-function 1)
+(defmacro broken-facility (facility &optional docstring assertion no-notice)
+  "Declare that FACILITY emulation is broken if ASSERTION is nil.
+ASSERTION is evaluated statically.
+
+FACILITY must be symbol.
+
+If ASSERTION is not ommited and evaluated to nil and NO-NOTICE is nil,
+it is noticed."
+  (` (static-if (, assertion)
+        (eval-and-compile
+          (broken-facility-internal '(, facility) (, docstring) t))
+       (eval-when-compile
+        (when (and '(, assertion) (not '(, no-notice))
+                   notice-non-obvious-broken-facility)
+          (message "BROKEN FACILITY DETECTED: %s" (, docstring)))
+        nil)
+       (eval-and-compile
+        (broken-facility-internal '(, facility) (, docstring) nil)))))
+
+(put 'if-broken 'lisp-indent-function 2)
+(defmacro if-broken (facility then &rest else)
+  "If FACILITY is broken, expand to THEN, otherwise (progn . ELSE)."
+  (` (static-if (broken-p '(, facility))
+        (, then)
+       (,@ else))))
+
+
+(put 'when-broken 'lisp-indent-function 1)
+(defmacro when-broken (facility &rest body)
+  "If FACILITY is broken, expand to (progn . BODY), otherwise nil."
+  (` (static-when (broken-p '(, facility))
+       (,@ body))))
+
+(put 'unless-broken 'lisp-indent-function 1)
+(defmacro unless-broken (facility &rest body)
+  "If FACILITY is not broken, expand to (progn . BODY), otherwise nil."
+  (` (static-unless (broken-p '(, facility))
+       (,@ body))))
+
+(defmacro check-broken-facility (facility)
+  "Check FACILITY is broken or not. If the status is different on
+compile(macro expansion) time and run time, warn it."
+  (` (if-broken (, facility)
+        (unless (broken-p '(, facility))
+          (message "COMPILE TIME ONLY BROKEN FACILITY DETECTED: %s" 
+                   (or
+                    '(, (broken-facility-description facility))
+                    (broken-facility-description '(, facility)))))
+       (when (broken-p '(, facility))
+        (message "RUN TIME ONLY BROKEN FACILITY DETECTED: %s" 
+                 (or
+                  (broken-facility-description '(, facility))
+                  '(, (broken-facility-description facility))))))))
+
+
+;;; @ end
+;;;
+
+(require 'product)
+(product-provide (provide 'broken) (require 'apel-ver))
+
+;;; broken.el ends here
diff --git a/emacs-lisp/calist.el b/emacs-lisp/calist.el
new file mode 100644 (file)
index 0000000..fbef680
--- /dev/null
@@ -0,0 +1,331 @@
+;;; calist.el --- Condition functions
+
+;; Copyright (C) 1998 Free Software Foundation, Inc.
+;; Copyright (C) 1999 Electrotechnical Laboratory, JAPAN.
+;; Licensed to the Free Software Foundation.
+
+;; Author: MORIOKA Tomohiko <tomo@m17n.org>
+;; Keywords: condition, alist, tree
+
+;; This file is part of APEL (A Portable Emacs Library).
+
+;; 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.
+
+;;; Code:
+
+(eval-when-compile (require 'cl))
+
+(require 'alist)
+
+(defvar calist-package-alist nil)
+(defvar calist-field-match-method-obarray nil)
+
+(defun find-calist-package (name)
+  "Return a calist-package by NAME."
+  (cdr (assq name calist-package-alist)))
+
+(defun define-calist-field-match-method (field-type function)
+  "Set field-match-method for FIELD-TYPE to FUNCTION."
+  (fset (intern (symbol-name field-type) calist-field-match-method-obarray)
+       function))
+
+(defun use-calist-package (name)
+  "Make the symbols of package NAME accessible in the current package."
+  (mapatoms (lambda (sym)
+             (if (intern-soft (symbol-name sym)
+                              calist-field-match-method-obarray)
+                 (signal 'conflict-of-calist-symbol
+                         (list (format "Conflict of symbol %s")))
+               (if (fboundp sym)
+                   (define-calist-field-match-method
+                     sym (symbol-function sym))
+                 )))
+           (find-calist-package name)))
+
+(defun make-calist-package (name &optional use)
+  "Create a new calist-package."
+  (let ((calist-field-match-method-obarray (make-vector 7 0)))
+    (set-alist 'calist-package-alist name
+              calist-field-match-method-obarray)
+    (use-calist-package (or use 'standard))
+    calist-field-match-method-obarray))
+
+(defun in-calist-package (name)
+  "Set the current calist-package to a new or existing calist-package."
+  (setq calist-field-match-method-obarray
+       (or (find-calist-package name)
+           (make-calist-package name))))
+
+(in-calist-package 'standard)
+
+(defun calist-default-field-match-method (calist field-type field-value)
+  (let ((s-field (assoc field-type calist)))
+    (cond ((null s-field)
+          (cons (cons field-type field-value) calist)
+          )
+         ((eq field-value t)
+          calist)
+         ((equal (cdr s-field) field-value)
+          calist))))
+
+(define-calist-field-match-method t (function calist-default-field-match-method))
+
+(defsubst calist-field-match-method (field-type)
+  (symbol-function
+   (or (intern-soft (if (symbolp field-type)
+                       (symbol-name field-type)
+                     field-type)
+                   calist-field-match-method-obarray)
+       (intern-soft "t" calist-field-match-method-obarray))))
+
+(defsubst calist-field-match (calist field-type field-value)
+  (funcall (calist-field-match-method field-type)
+          calist field-type field-value))
+
+(defun ctree-match-calist (rule-tree alist)
+  "Return matched condition-alist if ALIST matches RULE-TREE."
+  (if (null rule-tree)
+      alist
+    (let ((type (car rule-tree))
+         (choices (cdr rule-tree))
+         default)
+      (catch 'tag
+       (while choices
+         (let* ((choice (car choices))
+                (choice-value (car choice)))
+           (if (eq choice-value t)
+               (setq default choice)
+             (let ((ret-alist (calist-field-match alist type (car choice))))
+               (if ret-alist
+                   (throw 'tag
+                          (if (cdr choice)
+                              (ctree-match-calist (cdr choice) ret-alist)
+                            ret-alist))
+                 ))))
+         (setq choices (cdr choices)))
+       (if default
+           (let ((ret-alist (calist-field-match alist type t)))
+             (if ret-alist
+                 (if (cdr default)
+                     (ctree-match-calist (cdr default) ret-alist)
+                   ret-alist))))
+       ))))
+
+(defun ctree-match-calist-partially (rule-tree alist)
+  "Return matched condition-alist if ALIST matches RULE-TREE."
+  (if (null rule-tree)
+      alist
+    (let ((type (car rule-tree))
+         (choices (cdr rule-tree))
+         default)
+      (catch 'tag
+       (while choices
+         (let* ((choice (car choices))
+                (choice-value (car choice)))
+           (if (eq choice-value t)
+               (setq default choice)
+             (let ((ret-alist (calist-field-match alist type (car choice))))
+               (if ret-alist
+                   (throw 'tag
+                          (if (cdr choice)
+                              (ctree-match-calist-partially
+                               (cdr choice) ret-alist)
+                            ret-alist))
+                 ))))
+         (setq choices (cdr choices)))
+       (if default
+           (let ((ret-alist (calist-field-match alist type t)))
+             (if ret-alist
+                 (if (cdr default)
+                     (ctree-match-calist-partially (cdr default) ret-alist)
+                   ret-alist)))
+         (calist-field-match alist type t))
+       ))))
+
+(defun ctree-find-calist (rule-tree alist &optional all)
+  "Return list of condition-alist which matches ALIST in RULE-TREE.
+If optional argument ALL is specified, default rules are not ignored
+even if other rules are matched for ALIST."
+  (if (null rule-tree)
+      (list alist)
+    (let ((type (car rule-tree))
+         (choices (cdr rule-tree))
+         default dest)
+      (while choices
+       (let* ((choice (car choices))
+              (choice-value (car choice)))
+         (if (eq choice-value t)
+             (setq default choice)
+           (let ((ret-alist (calist-field-match alist type (car choice))))
+             (if ret-alist
+                 (if (cdr choice)
+                     (let ((ret (ctree-find-calist
+                                 (cdr choice) ret-alist all)))
+                       (while ret
+                         (let ((elt (car ret)))
+                           (or (member elt dest)
+                               (setq dest (cons elt dest))
+                               ))
+                         (setq ret (cdr ret))
+                         ))
+                   (or (member ret-alist dest)
+                       (setq dest (cons ret-alist dest)))
+                   )))))
+       (setq choices (cdr choices)))
+      (or (and (not all) dest)
+         (if default
+             (let ((ret-alist (calist-field-match alist type t)))
+               (if ret-alist
+                   (if (cdr default)
+                       (let ((ret (ctree-find-calist
+                                   (cdr default) ret-alist all)))
+                         (while ret
+                           (let ((elt (car ret)))
+                             (or (member elt dest)
+                                 (setq dest (cons elt dest))
+                                 ))
+                           (setq ret (cdr ret))
+                           ))
+                     (or (member ret-alist dest)
+                         (setq dest (cons ret-alist dest)))
+                     ))))
+         )
+      dest)))
+
+(defun calist-to-ctree (calist)
+  "Convert condition-alist CALIST to condition-tree."
+  (if calist
+      (let* ((cell (car calist)))
+       (cons (car cell)
+             (list (cons (cdr cell)
+                         (calist-to-ctree (cdr calist))
+                         ))))))
+
+(defun ctree-add-calist-strictly (ctree calist)
+  "Add condition CALIST to condition-tree CTREE without default clause."
+  (cond ((null calist) ctree)
+       ((null ctree)
+        (calist-to-ctree calist)
+        )
+       (t
+        (let* ((type (car ctree))
+               (values (cdr ctree))
+               (ret (assoc type calist)))
+          (if ret
+              (catch 'tag
+                (while values
+                  (let ((cell (car values)))
+                    (if (equal (car cell)(cdr ret))
+                        (throw 'tag
+                               (setcdr cell
+                                       (ctree-add-calist-strictly
+                                        (cdr cell)
+                                        (delete ret (copy-alist calist)))
+                                       ))))
+                  (setq values (cdr values)))
+                (setcdr ctree (cons (cons (cdr ret)
+                                          (calist-to-ctree
+                                           (delete ret (copy-alist calist))))
+                                    (cdr ctree)))
+                )
+            (catch 'tag
+              (while values
+                (let ((cell (car values)))
+                  (setcdr cell
+                          (ctree-add-calist-strictly (cdr cell) calist))
+                  )
+                (setq values (cdr values))))
+            )
+          ctree))))
+
+(defun ctree-add-calist-with-default (ctree calist)
+  "Add condition CALIST to condition-tree CTREE with default clause."
+  (cond ((null calist) ctree)
+       ((null ctree)
+        (let* ((cell (car calist))
+               (type (car cell))
+               (value (cdr cell)))
+          (cons type
+                (list (list t)
+                      (cons value (calist-to-ctree (cdr calist)))))
+          ))
+       (t
+        (let* ((type (car ctree))
+               (values (cdr ctree))
+               (ret (assoc type calist)))
+          (if ret
+              (catch 'tag
+                (while values
+                  (let ((cell (car values)))
+                    (if (equal (car cell)(cdr ret))
+                        (throw 'tag
+                               (setcdr cell
+                                       (ctree-add-calist-with-default
+                                        (cdr cell)
+                                        (delete ret (copy-alist calist)))
+                                       ))))
+                  (setq values (cdr values)))
+                (if (assq t (cdr ctree))
+                    (setcdr ctree
+                            (cons (cons (cdr ret)
+                                        (calist-to-ctree
+                                         (delete ret (copy-alist calist))))
+                                  (cdr ctree)))
+                  (setcdr ctree
+                          (list* (list t)
+                                 (cons (cdr ret)
+                                       (calist-to-ctree
+                                        (delete ret (copy-alist calist))))
+                                 (cdr ctree)))
+                  ))
+            (catch 'tag
+              (while values
+                (let ((cell (car values)))
+                  (setcdr cell
+                          (ctree-add-calist-with-default (cdr cell) calist))
+                  )
+                (setq values (cdr values)))
+              (let ((cell (assq t (cdr ctree))))
+                (if cell
+                    (setcdr cell
+                            (ctree-add-calist-with-default (cdr cell)
+                                                           calist))
+                  (let ((elt (cons t (calist-to-ctree calist))))
+                    (or (member elt (cdr ctree))
+                        (setcdr ctree (cons elt (cdr ctree)))
+                        ))
+                  )))
+            )
+          ctree))))
+
+(defun ctree-set-calist-strictly (ctree-var calist)
+  "Set condition CALIST in CTREE-VAR without default clause."
+  (set ctree-var
+       (ctree-add-calist-strictly (symbol-value ctree-var) calist)))
+
+(defun ctree-set-calist-with-default (ctree-var calist)
+  "Set condition CALIST to CTREE-VAR with default clause."
+  (set ctree-var
+       (ctree-add-calist-with-default (symbol-value ctree-var) calist)))
+
+
+;;; @ end
+;;;
+
+(require 'product)
+(product-provide (provide 'calist) (require 'apel-ver))
+
+;;; calist.el ends here
diff --git a/emacs-lisp/filename.el b/emacs-lisp/filename.el
new file mode 100644 (file)
index 0000000..2efdb09
--- /dev/null
@@ -0,0 +1,164 @@
+;;; filename.el --- file name filter
+
+;; Copyright (C) 1996,1997,2000 Free Software Foundation, Inc.
+
+;; Author: MORIOKA Tomohiko <tomo@m17n.org>
+;; Keywords: file name, string
+
+;; This file is part of APEL (A Portable Emacs Library).
+
+;; 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.
+
+;;; Code:
+
+(require 'path-util)
+
+(or (fboundp 'char-int)
+    (defalias 'char-int 'identity))
+
+;; Emacs 20.1/XEmacs 20.3 (but first appeared in Epoch?): (functionp OBJECT)
+(or (fboundp 'functionp)
+    (defun functionp (object)
+      "Non-nil if OBJECT is a type of object that can be called as a function."
+      (or (subrp object) (byte-code-function-p object)
+         (eq (car-safe object) 'lambda)
+         (and (symbolp object) (fboundp object)))))
+
+
+(defsubst poly-funcall (functions argument)
+  "Apply initial ARGUMENT to sequence of FUNCTIONS.
+FUNCTIONS is list of functions.
+
+(poly-funcall '(f1 f2 .. fn) arg) is as same as
+(fn .. (f2 (f1 arg)) ..).
+
+For example, (poly-funcall '(car number-to-string) '(100)) returns
+\"100\"."
+  (while functions
+    (setq argument (funcall (car functions) argument)
+         functions (cdr functions)))
+  argument)
+
+
+;;; @ variables
+;;;
+
+(defvar filename-limit-length 21 "Limit size of file-name.")
+
+(defvar filename-replacement-alist
+  '(((?\  ?\t) . "_")
+    ((?! ?\" ?# ?$ ?% ?& ?' ?\( ?\) ?* ?/
+        ?: ?\; ?< ?> ?? ?\[ ?\\ ?\] ?` ?{ ?| ?}) . "_")
+    (filename-control-p . ""))
+  "Alist list of characters vs. string as replacement.
+List of characters represents characters not allowed as file-name.")
+
+(defvar filename-filters
+  (let ((filters '(filename-special-filter
+                  filename-eliminate-top-low-lines
+                  filename-canonicalize-low-lines
+                  filename-maybe-truncate-by-size
+                  filename-eliminate-bottom-low-lines
+                  )))
+    (if (exec-installed-p "kakasi")
+       (cons 'filename-japanese-to-roman-string filters)
+      filters))
+  "List of functions for file-name filter.")
+
+
+;;; @ filters
+;;;
+
+(defun filename-japanese-to-roman-string (str)
+  (save-excursion
+    (set-buffer (get-buffer-create " *temp kakasi*"))
+    (erase-buffer)
+    (insert str)
+    (call-process-region
+     (point-min)(point-max)
+     "kakasi" t t t "-Ha" "-Ka" "-Ja" "-Ea" "-ka")
+    (buffer-string)))
+
+(defun filename-control-p (character)
+  (let ((code (char-int character)))
+    (or (< code 32)(= code 127))))
+
+(defun filename-special-filter (string)
+  (let ((len (length string))
+       (b 0)(i 0)
+       (dest ""))
+    (while (< i len)
+      (let ((chr (sref string i))
+            (lst filename-replacement-alist)
+            ret)
+        (while (and lst (not ret))
+          (if (if (functionp (car (car lst)))
+                  (setq ret (funcall (car (car lst)) chr))
+                (setq ret (memq chr (car (car lst)))))
+              t                         ; quit this loop.
+            (setq lst (cdr lst))))
+       (if ret
+           (setq dest (concat dest (substring string b i)(cdr (car lst)))
+                 i (1+ i)
+                  ;; i (+ i (char-length chr))
+                 b i)
+         (setq i (1+ i))
+          ;; (setq i (+ i (char-length chr)))
+         )))
+    (concat dest (substring string b))))
+
+(defun filename-eliminate-top-low-lines (string)
+  (if (string-match "^_+" string)
+      (substring string (match-end 0))
+    string))
+
+(defun filename-canonicalize-low-lines (string)
+  (let ((dest ""))
+    (while (string-match "__+" string)
+      (setq dest (concat dest (substring string 0 (1+ (match-beginning 0)))))
+      (setq string (substring string (match-end 0))))
+    (concat dest string)))
+
+(defun filename-maybe-truncate-by-size (string)
+  (if (and (> (length string) filename-limit-length)
+          (string-match "_" string filename-limit-length))
+      (substring string 0 (match-beginning 0))
+    string))
+
+(defun filename-eliminate-bottom-low-lines (string)
+  (if (string-match "_+$" string)
+      (substring string 0 (match-beginning 0))
+    string))
+
+
+;;; @ interface
+;;;
+
+(defun replace-as-filename (string)
+  "Return safety filename from STRING.
+It refers variable `filename-filters' and default filters refers
+`filename-limit-length', `filename-replacement-alist'."
+  (and string
+       (poly-funcall filename-filters string)))
+
+
+;;; @ end
+;;;
+
+(require 'product)
+(product-provide (provide 'filename) (require 'apel-ver))
+
+;;; filename.el ends here
diff --git a/emacs-lisp/install.el b/emacs-lisp/install.el
new file mode 100644 (file)
index 0000000..eb20781
--- /dev/null
@@ -0,0 +1,200 @@
+;;; install.el --- Emacs Lisp package install utility
+
+;; Copyright (C) 1996,1997,1998,1999 Free Software Foundation, Inc.
+
+;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
+;; Created: 1996/08/18
+;; Keywords: install, byte-compile, directory detection
+
+;; This file is part of APEL (A Portable Emacs Library).
+
+;; 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.
+
+;;; Code:
+
+;; (require 'poe)                      ; make-directory for v18
+(require 'path-util)                   ; default-load-path
+
+
+;;; @ compile Emacs Lisp files
+;;;
+
+(defun compile-elisp-module (module &optional path every-time)
+  (setq module (expand-file-name (symbol-name module) path))
+  (let ((el-file (concat module ".el"))
+       (elc-file (concat module ".elc")))
+    (if (or every-time
+           (file-newer-than-file-p el-file elc-file))
+       (byte-compile-file el-file))))
+
+(defun compile-elisp-modules (modules &optional path every-time)
+  (mapcar
+   (function
+    (lambda (module)
+      (compile-elisp-module module path every-time)))
+   modules))
+
+
+;;; @ install files
+;;;
+
+(defvar install-overwritten-file-modes (+ (* 64 6)(* 8 4) 4)) ; 0644
+
+(defun install-file (file src dest &optional move overwrite just-print)
+  (if just-print
+      (princ (format "%s -> %s\n" file dest))
+    (let ((src-file (expand-file-name file src)))
+      (if (file-exists-p src-file)
+         (let ((full-path (expand-file-name file dest)))
+           (if (and (file-exists-p full-path) overwrite)
+               (delete-file full-path))
+           (copy-file src-file full-path t t)
+           (if move
+               (catch 'tag
+                 (while (and (file-exists-p src-file)
+                             (file-writable-p src-file))
+                   (condition-case err
+                       (progn
+                         (delete-file src-file)
+                         (throw 'tag nil))
+                     (error (princ (format "%s\n" (nth 1 err))))))))
+           (princ (format "%s -> %s\n" file dest)))))))
+
+(defun install-files (files src dest &optional move overwrite just-print)
+  (or (file-exists-p dest)
+      (make-directory dest t))
+  (mapcar
+   (function
+    (lambda (file)
+      (install-file file src dest move overwrite just-print)))
+   files))
+
+
+;;; @@ install Emacs Lisp files
+;;;
+
+(defun install-elisp-module (module src dest &optional just-print)
+  (let (el-file elc-file)
+    (let ((name (symbol-name module)))
+      (setq el-file (concat name ".el"))
+      (setq elc-file (concat name ".elc")))
+    (let ((src-file (expand-file-name el-file src)))
+      (if (not (file-exists-p src-file))
+         nil 
+       (if just-print
+           (princ (format "%s -> %s\n" el-file dest))
+         (let ((full-path (expand-file-name el-file dest)))
+           (if (file-exists-p full-path)
+               (delete-file full-path))
+           (copy-file src-file full-path t t)
+           (princ (format "%s -> %s\n" el-file dest)))))
+      (setq src-file (expand-file-name elc-file src))
+      (if (not (file-exists-p src-file))
+         nil 
+       (if just-print
+           (princ (format "%s -> %s\n" elc-file dest))
+         (let ((full-path (expand-file-name elc-file dest)))
+            (if (file-exists-p full-path)
+                (delete-file full-path))
+           (copy-file src-file full-path t t)
+           (catch 'tag
+             (while (file-exists-p src-file)
+               (condition-case err
+                   (progn
+                     (delete-file src-file)
+                     (throw 'tag nil))
+                 (error (princ (format "%s\n" (nth 1 err)))))))
+           (princ (format "%s -> %s\n" elc-file dest))))))))
+
+(defun install-elisp-modules (modules src dest &optional just-print)
+  (or (file-exists-p dest)
+      (make-directory dest t))
+  (mapcar
+   (function
+    (lambda (module)
+      (install-elisp-module module src dest just-print)))
+   modules))
+
+
+;;; @ detect install path
+;;;
+
+;; install to shared directory (maybe "/usr/local")
+(defvar install-prefix
+  (if (or (<= emacs-major-version 18)
+         (featurep 'xemacs)
+         (and (boundp 'system-configuration-options) ; 19.29 or later
+              (string= system-configuration-options "NT"))) ; for Meadow
+      (expand-file-name "../../.." exec-directory)
+    (expand-file-name "../../../.." data-directory)))
+
+(defvar install-elisp-prefix
+  (if (>= emacs-major-version 19)
+      "site-lisp"
+    ;; v18 does not have standard site directory.
+    "local.lisp"))
+
+(defun install-detect-elisp-directory (&optional prefix elisp-prefix
+                                                allow-version-specific)
+  (or prefix
+      (setq prefix install-prefix))
+  (or elisp-prefix
+      (setq elisp-prefix install-elisp-prefix))
+  (or (catch 'tag
+       (let ((rest default-load-path)
+             (regexp (concat "^"
+                             (expand-file-name (concat ".*/" elisp-prefix)
+                                               prefix)
+                             "/?$")))
+         (while rest
+           (if (string-match regexp (car rest))
+               (if (or allow-version-specific
+                       (not (string-match (format "/%d\\.%d"
+                                                  emacs-major-version
+                                                  emacs-minor-version)
+                                          (car rest))))
+                   (throw 'tag (car rest))))
+           (setq rest (cdr rest)))))
+      (expand-file-name (concat (if (and (not (featurep 'xemacs))
+                                        (or (>= emacs-major-version 20)
+                                            (and (= emacs-major-version 19)
+                                                 (> emacs-minor-version 28))))
+                                   "share/"
+                                 "lib/")
+                               (cond
+                                ((featurep 'xemacs)
+                                 (if (featurep 'mule)
+                                     "xmule/"
+                                   "xemacs/"))
+                                ;; unfortunately, unofficial mule based on
+                                ;; 19.29 and later use "emacs/" by default.
+                                ((boundp 'MULE) "mule/")
+                                ((boundp 'NEMACS) "nemacs/")
+                                (t "emacs/"))
+                               elisp-prefix)
+                       prefix)))
+
+(defvar install-default-elisp-directory
+  (install-detect-elisp-directory))
+
+
+;;; @ end
+;;;
+
+(require 'product)
+(product-provide (provide 'install) (require 'apel-ver))
+
+;;; install.el ends here
diff --git a/emacs-lisp/luna.el b/emacs-lisp/luna.el
new file mode 100644 (file)
index 0000000..b307ad9
--- /dev/null
@@ -0,0 +1,437 @@
+;;; luna.el --- tiny OOP system kernel
+
+;; Copyright (C) 1999,2000 Free Software Foundation, Inc.
+
+;; Author: MORIOKA Tomohiko <tomo@m17n.org>
+;; Keywords: OOP
+
+;; This file is part of FLIM (Faithful Library about Internet Message).
+
+;; 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.
+
+;;; Code:
+
+(eval-when-compile (require 'cl))
+
+
+;;; @ class
+;;;
+
+(defmacro luna-find-class (name)
+  "Return a luna-class that has NAME."
+  `(get ,name 'luna-class))
+
+;; Give NAME (symbol) the luna-class CLASS.
+(defmacro luna-set-class (name class)
+  `(put ,name 'luna-class ,class))
+
+;; Return the obarray of luna-class CLASS.
+(defmacro luna-class-obarray (class)
+  `(aref ,class 1))
+
+;; Return the parents of luna-class CLASS.
+(defmacro luna-class-parents (class)
+  `(aref ,class 2))
+
+;; Return the number of slots of luna-class CLASS.
+(defmacro luna-class-number-of-slots (class)
+  `(aref ,class 3))
+
+(defmacro luna-define-class (class &optional parents slots)
+  "Define CLASS as a luna-class.
+CLASS always inherits the luna-class `standard-object'.
+
+The optional 1st arg PARENTS is a list luna-class names.  These
+luna-classes are also inheritted by CLASS.
+
+The optional 2nd arg SLOTS is a list of slots CLASS will have."
+  `(luna-define-class-function ',class ',(append parents '(standard-object))
+                              ',slots))
+
+
+;; Define CLASS as a luna-class.  PARENTS, if non-nil, is a list of
+;; luna-class names inherited by CLASS.  SLOTS, if non-nil, is a list
+;; of slots belonging to CLASS.
+
+(defun luna-define-class-function (class &optional parents slots)
+  (let ((oa (make-vector 31 0))
+       (rest parents)
+       parent name
+       (i 2)
+       b j)
+    (while rest
+      (setq parent (pop rest)
+           b (- i 2))
+      (mapatoms (lambda (sym)
+                 (when (setq j (get sym 'luna-slot-index))
+                   (setq name (symbol-name sym))
+                   (unless (intern-soft name oa)
+                     (put (intern name oa) 'luna-slot-index (+ j b))
+                     (setq i (1+ i)))))
+               (luna-class-obarray (luna-find-class parent))))
+    (setq rest slots)
+    (while rest
+      (setq name (symbol-name (pop rest)))
+      (unless (intern-soft name oa)
+       (put (intern name oa) 'luna-slot-index i)
+       (setq i (1+ i))))
+    (luna-set-class class (vector 'class oa parents i))))
+
+
+;; Return a member (slot or method) of CLASS that has name
+;; MEMBER-NAME.
+
+(defun luna-class-find-member (class member-name)
+  (or (stringp member-name)
+      (setq member-name (symbol-name member-name)))
+  (or (intern-soft member-name (luna-class-obarray class))
+      (let ((parents (luna-class-parents class))
+           ret)
+       (while (and parents
+                   (null
+                    (setq ret (luna-class-find-member
+                               (luna-find-class (pop parents))
+                               member-name)))))
+       ret)))
+
+
+;; Return a member (slot or method) of CLASS that has name
+;; MEMBER-NAME.  If CLASS doesnt' have such a member, make it in
+;; CLASS.
+
+(defsubst luna-class-find-or-make-member (class member-name)
+  (or (stringp member-name)
+      (setq member-name (symbol-name member-name)))
+  (intern member-name (luna-class-obarray class)))
+
+
+;; Return the index number of SLOT-NAME in CLASS.
+
+(defmacro luna-class-slot-index (class slot-name)
+  `(get (luna-class-find-member ,class ,slot-name) 'luna-slot-index))
+
+(defmacro luna-define-method (name &rest definition)
+  "Define NAME as a method of a luna class.
+
+Usage of this macro follows:
+
+  (luna-define-method NAME [METHOD-QUALIFIER] ARGLIST [DOCSTRING] BODY...)
+
+The optional 1st argument METHOD-QUALIFIER specifies when and how the
+method is called.
+
+If it is :before, call the method before calling the parents' methods.
+
+If it is :after, call the method after calling the parents' methods.
+
+If it is :around, call the method only.  The parents' methods can be
+executed by calling the function `luna-call-next-method' in BODY.
+
+Otherwize, call the method only, and the parents' methods are never
+executed.  In this case, METHOD-QUALIFIER is treated as ARGLIST.
+
+ARGLIST has the form ((VAR CLASS) METHOD-ARG ...), where VAR is a
+variable name that should be bound to an entity that receives the
+message NAME, CLASS is a class name.  The first argument to the method
+is VAR, and the remaining arguments are METHOD-ARGs.
+
+If VAR is nil, arguments to the method are METHOD-ARGs.  This kind of
+methods can't be called from generic-function (see
+`luna-define-generic').
+
+The optional 4th argument DOCSTRING is the documentation of the
+method.  If it is not string, it is treated as BODY.
+
+The optional 5th BODY is the body of the method."
+  (let ((method-qualifier (pop definition))
+       args specializer class self)
+    (if (memq method-qualifier '(:before :after :around))
+       (setq args (pop definition))
+      (setq args method-qualifier
+           method-qualifier nil))
+    (setq specializer (car args)
+         class (nth 1 specializer)
+         self (car specializer))
+    `(let ((func (lambda ,(if self
+                             (cons self (cdr args))
+                           (cdr args))
+                  ,@definition))
+          (sym (luna-class-find-or-make-member
+                (luna-find-class ',class) ',name))
+          (cache (get ',name 'luna-method-cache)))
+       (if cache
+          (unintern ',class cache))
+       (fset sym func)
+       (put sym 'luna-method-qualifier ,method-qualifier))))
+
+(put 'luna-define-method 'lisp-indent-function 'defun)
+
+(def-edebug-spec luna-define-method
+  (&define name [&optional &or ":before" ":after" ":around"]
+          ((arg symbolp)
+           [&rest arg]
+           [&optional ["&optional" arg &rest arg]]
+           &optional ["&rest" arg])
+          def-body))
+
+
+;; Return a list of method functions named SERVICE registered in the
+;; parents of CLASS.
+
+(defun luna-class-find-parents-functions (class service)
+  (let ((parents (luna-class-parents class))
+       ret)
+    (while (and parents
+               (null
+                (setq ret (luna-class-find-functions
+                           (luna-find-class (pop parents))
+                           service)))))
+    ret))
+
+;; Return a list of method functions named SERVICE registered in CLASS
+;; and the parents..
+
+(defun luna-class-find-functions (class service)
+  (let ((sym (luna-class-find-member class service)))
+    (if (fboundp sym)
+       (cond ((eq (get sym 'luna-method-qualifier) :before)
+              (cons (symbol-function sym)
+                    (luna-class-find-parents-functions class service)))
+             ((eq (get sym 'luna-method-qualifier) :after)
+              (nconc (luna-class-find-parents-functions class service)
+                     (list (symbol-function sym))))
+             ((eq (get sym 'luna-method-qualifier) :around)
+              (cons sym (luna-class-find-parents-functions class service)))
+             (t
+              (list (symbol-function sym))))
+      (luna-class-find-parents-functions class service))))
+
+
+;;; @ instance (entity)
+;;;
+
+(defmacro luna-class-name (entity)
+  "Return class-name of the ENTITY."
+  `(aref ,entity 0))
+
+(defmacro luna-set-class-name (entity name)
+  `(aset ,entity 0 ,name))
+
+(defmacro luna-get-obarray (entity)
+  `(aref ,entity 1))
+
+(defmacro luna-set-obarray (entity obarray)
+  `(aset ,entity 1 ,obarray))
+
+(defmacro luna-slot-index (entity slot-name)
+  `(luna-class-slot-index (luna-find-class (luna-class-name ,entity))
+                         ,slot-name))
+
+(defsubst luna-slot-value (entity slot)
+  "Return the value of SLOT of ENTITY."
+  (aref entity (luna-slot-index entity slot)))
+
+(defsubst luna-set-slot-value (entity slot value)
+  "Store VALUE into SLOT of ENTITY."
+  (aset entity (luna-slot-index entity slot) value))
+
+(defmacro luna-find-functions (entity service)
+  `(luna-class-find-functions (luna-find-class (luna-class-name ,entity))
+                             ,service))
+
+(defsubst luna-send (entity message &rest luna-current-method-arguments)
+  "Send MESSAGE to ENTITY, and return the result.
+ENTITY is an instance of a luna class, and MESSAGE is a method name of
+the luna class.
+LUNA-CURRENT-METHOD-ARGUMENTS is arguments of the MESSAGE."
+  (let ((luna-next-methods (luna-find-functions entity message))
+       luna-current-method
+       luna-previous-return-value)
+    (while (and luna-next-methods
+               (progn
+                 (setq luna-current-method (pop luna-next-methods)
+                       luna-previous-return-value
+                       (apply luna-current-method
+                              luna-current-method-arguments))
+                 (if (symbolp luna-current-method)
+                     (not (eq (get luna-current-method
+                                   'luna-method-qualifier) :around))
+                   t))))
+    luna-previous-return-value))
+
+(eval-when-compile
+  (defvar luna-next-methods nil)
+  (defvar luna-current-method-arguments nil))
+
+(defun luna-call-next-method ()
+  "Call the next method in the current method function.
+A method function that has :around qualifier should call this function
+to execute the parents' methods."
+  (let (luna-current-method
+       luna-previous-return-value)
+    (while (and luna-next-methods
+               (progn
+                 (setq luna-current-method (pop luna-next-methods)
+                       luna-previous-return-value
+                       (apply luna-current-method
+                              luna-current-method-arguments))
+                 (if (symbolp luna-current-method)
+                     (not (eq (get luna-current-method
+                                   'luna-method-qualifier) :around))
+                   t))))
+    luna-previous-return-value))
+
+(defun luna-make-entity (class &rest init-args)
+  "Make an entity (instance) of luna-class CLASS and return it.
+INIT-ARGS is a plist of the form (:SLOT1 VAL1 :SLOT2 VAL2 ...),
+where SLOTs are slots of CLASS and the VALs are initial values of
+the corresponding SLOTs."
+  (let* ((c (get class 'luna-class))
+        (v (make-vector (luna-class-number-of-slots c) nil)))
+    (luna-set-class-name v class)
+    (luna-set-obarray v (make-vector 7 0))
+    (apply #'luna-send v 'initialize-instance v init-args)))
+
+
+;;; @ interface (generic function)
+;;;
+
+;; Find a method of ENTITY that handles MESSAGE, and call it with
+;; arguments LUNA-CURRENT-METHOD-ARGUMENTS.
+
+(defun luna-apply-generic (entity message &rest luna-current-method-arguments)
+  (let* ((class (luna-class-name entity))
+        (cache (get message 'luna-method-cache))
+        (sym (intern-soft (symbol-name class) cache))
+        luna-next-methods)
+    (if sym
+       (setq luna-next-methods (symbol-value sym))
+      (setq luna-next-methods
+           (luna-find-functions entity message))
+      (set (intern (symbol-name class) cache)
+          luna-next-methods))
+    (luna-call-next-method)))
+
+
+;; Convert ARGLIST (argument list spec for a method function) to the
+;; actual list of arguments.
+
+(defsubst luna-arglist-to-arguments (arglist)
+  (let (dest)
+    (while arglist
+      (let ((arg (car arglist)))
+       (or (memq arg '(&optional &rest))
+           (setq dest (cons arg dest))))
+      (setq arglist (cdr arglist)))
+    (nreverse dest)))
+
+
+(defmacro luna-define-generic (name args &optional doc)
+  "Define a function NAME that provides a generic interface to the method NAME.
+ARGS is the argument list for NAME.  The first element of ARGS is an
+entity.
+
+The function handles a message sent to the entity by calling the
+method with proper arguments.
+
+The optional 3rd argument DOC is the documentation string for NAME."
+  (if doc
+      `(progn
+        (defun ,(intern (symbol-name name)) ,args
+          ,doc
+          (luna-apply-generic ,(car args) ',name
+                              ,@(luna-arglist-to-arguments args)))
+        (put ',name 'luna-method-cache (make-vector 31 0)))
+    `(progn
+       (defun ,(intern (symbol-name name)) ,args
+        (luna-apply-generic ,(car args) ',name
+                            ,@(luna-arglist-to-arguments args)))
+       (put ',name 'luna-method-cache (make-vector 31 0)))))
+
+(put 'luna-define-generic 'lisp-indent-function 'defun)
+
+
+;;; @ accessor
+;;;
+
+(defun luna-define-internal-accessors (class-name)
+  "Define internal accessors for instances of the luna class CLASS-NAME.
+
+Internal accessors are macros to refer and set a slot value of the
+instances.  For instance, if the class has SLOT, macros
+CLASS-NAME-SLOT-internal and CLASS-NAME-set-SLOT-internal are defined.
+
+CLASS-NAME-SLOT-internal accepts one argument INSTANCE, and returns
+the value of SLOT.
+
+CLASS-NAME-set-SLOT-internal accepts two arguemnt INSTANCE and VALUE,
+and sets SLOT to VALUE."
+  (let ((entity-class (luna-find-class class-name))
+       parents parent-class)
+    (mapatoms
+     (lambda (slot)
+       (if (luna-class-slot-index entity-class slot)
+          (catch 'derived
+            (setq parents (luna-class-parents entity-class))
+            (while parents
+              (setq parent-class (luna-find-class (car parents)))
+              (if (luna-class-slot-index parent-class slot)
+                  (throw 'derived nil))
+              (setq parents (cdr parents)))
+            (eval
+             `(progn
+                (defmacro ,(intern (format "%s-%s-internal"
+                                           class-name slot))
+                  (entity)
+                  (list 'aref entity
+                        ,(luna-class-slot-index entity-class
+                                                (intern (symbol-name slot)))))
+                (defmacro ,(intern (format "%s-set-%s-internal"
+                                           class-name slot))
+                  (entity value)
+                  (list 'aset entity
+                        ,(luna-class-slot-index
+                          entity-class (intern (symbol-name slot)))
+                        value)))))))
+     (luna-class-obarray entity-class))))
+
+
+;;; @ standard object
+;;;
+
+;; Define super class of all luna classes.
+(luna-define-class-function 'standard-object)
+
+(luna-define-method initialize-instance ((entity standard-object)
+                                        &rest init-args)
+  "Initialize slots of ENTITY by INIT-ARGS."
+  (let* ((c (luna-find-class (luna-class-name entity)))
+        (oa (luna-class-obarray c))
+        s i)
+    (while init-args
+      (setq s (intern-soft (substring (symbol-name (pop init-args)) 1) oa)
+           i (pop init-args))
+      (if s
+         (aset entity (get s 'luna-slot-index) i)))
+    entity))
+
+
+;;; @ end
+;;;
+
+(provide 'luna)
+
+;; luna.el ends here
diff --git a/emacs-lisp/path-util.el b/emacs-lisp/path-util.el
new file mode 100644 (file)
index 0000000..385aecd
--- /dev/null
@@ -0,0 +1,201 @@
+;;; path-util.el --- Emacs Lisp file detection utility
+
+;; Copyright (C) 1996,1997,1999 Free Software Foundation, Inc.
+
+;; Author: MORIOKA Tomohiko <tomo@m17n.org>
+;; Keywords: file detection, install, module
+
+;; This file is part of APEL (A Portable Emacs Library).
+
+;; 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.
+
+;;; Code:
+
+(defvar default-load-path load-path
+  "*Base of `load-path'.
+It is used as default value of target path to search file or
+subdirectory under load-path.")
+
+;;;###autoload
+(defun add-path (path &rest options)
+  "Add PATH to `load-path' if it exists under `default-load-path'
+directories and it does not exist in `load-path'.
+
+You can use following PATH styles:
+       load-path relative: \"PATH/\"
+                       (it is searched from `defaul-load-path')
+       home directory relative: \"~/PATH/\" \"~USER/PATH/\"
+       absolute path: \"/HOO/BAR/BAZ/\"
+
+You can specify following OPTIONS:
+       'all-paths      search from `load-path'
+                       instead of `default-load-path'
+       'append         add PATH to the last of `load-path'"
+  (let ((rest (if (memq 'all-paths options)
+                 load-path
+               default-load-path))
+       p)
+    (if (and (catch 'tag
+              (while rest
+                (setq p (expand-file-name path (car rest)))
+                (if (file-directory-p p)
+                    (throw 'tag p)
+                  )
+                (setq rest (cdr rest))
+                ))
+            (not (member p load-path))
+            )
+       (setq load-path
+             (if (memq 'append options)
+                 (append load-path (list p))
+               (cons p load-path)
+               ))
+      )))
+
+;;;###autoload
+(defun add-latest-path (pattern &optional all-paths)
+  "Add latest path matched by PATTERN to `load-path'
+if it exists under `default-load-path' directories
+and it does not exist in `load-path'.
+
+If optional argument ALL-PATHS is specified, it is searched from all
+of load-path instead of default-load-path."
+  (let ((path (get-latest-path pattern all-paths)))
+    (if path
+       (add-to-list 'load-path path)
+      )))
+
+;;;###autoload
+(defun get-latest-path (pattern &optional all-paths)
+  "Return latest directory in default-load-path
+which is matched to regexp PATTERN.
+If optional argument ALL-PATHS is specified,
+it is searched from all of load-path instead of default-load-path."
+  (catch 'tag
+    (let ((paths (if all-paths
+                   load-path
+                 default-load-path))
+         dir)
+      (while (setq dir (car paths))
+       (if (and (file-exists-p dir)
+                (file-directory-p dir)
+                )
+           (let ((files (sort (directory-files dir t pattern t)
+                              (function file-newer-than-file-p)))
+                 file)
+             (while (setq file (car files))
+               (if (file-directory-p file)
+                   (throw 'tag file)
+                 )
+               (setq files (cdr files))
+               )))
+       (setq paths (cdr paths))
+       ))))
+
+;;;###autoload
+(defun file-installed-p (file &optional paths)
+  "Return absolute-path of FILE if FILE exists in PATHS.
+If PATHS is omitted, `load-path' is used."
+  (if (null paths)
+      (setq paths load-path)
+    )
+  (catch 'tag
+    (let (path)
+      (while paths
+       (setq path (expand-file-name file (car paths)))
+       (if (file-exists-p path)
+           (throw 'tag path)
+         )
+       (setq paths (cdr paths))
+       ))))
+
+;;;###autoload
+(defvar exec-suffix-list '("")
+  "*List of suffixes for executable.")
+
+;;;###autoload
+(defun exec-installed-p (file &optional paths suffixes)
+  "Return absolute-path of FILE if FILE exists in PATHS.
+If PATHS is omitted, `exec-path' is used.
+If suffixes is omitted, `exec-suffix-list' is used."
+  (or paths
+      (setq paths exec-path)
+      )
+  (or suffixes
+      (setq suffixes exec-suffix-list)
+      )
+  (let (files)
+    (catch 'tag
+      (while suffixes
+       (let ((suf (car suffixes)))
+         (if (and (not (string= suf ""))
+                  (string-match (concat (regexp-quote suf) "$") file))
+             (progn
+               (setq files (list file))
+               (throw 'tag nil)
+               )
+           (setq files (cons (concat file suf) files))
+           )
+         (setq suffixes (cdr suffixes))
+         )))
+    (setq files (nreverse files))
+    (catch 'tag
+      (while paths
+       (let ((path (car paths))
+             (files files)
+             )
+         (while files
+           (setq file (expand-file-name (car files) path))
+           (if (file-executable-p file)
+               (throw 'tag file)
+             )
+           (setq files (cdr files))
+           )
+         (setq paths (cdr paths))
+         )))))
+
+;;;###autoload
+(defun module-installed-p (module &optional paths)
+  "Return t if module is provided or exists in PATHS.
+If PATHS is omitted, `load-path' is used."
+  (or (featurep module)
+      (let ((file (symbol-name module)))
+       (or paths
+           (setq paths load-path)
+           )
+       (catch 'tag
+         (while paths
+           (let ((stem (expand-file-name file (car paths)))
+                 (sufs '(".elc" ".el"))
+                 )
+             (while sufs
+               (let ((file (concat stem (car sufs))))
+                 (if (file-exists-p file)
+                     (throw 'tag file)
+                   ))
+               (setq sufs (cdr sufs))
+               ))
+           (setq paths (cdr paths))
+           )))))
+
+
+;;; @ end
+;;;
+
+(require 'product)
+(product-provide (provide 'path-util) (require 'apel-ver))
+
+;;; path-util.el ends here
diff --git a/emacs-lisp/static.el b/emacs-lisp/static.el
new file mode 100644 (file)
index 0000000..a42d816
--- /dev/null
@@ -0,0 +1,89 @@
+;;; static.el --- tools for static evaluation.
+
+;; Copyright (C) 1999 Tanaka Akira <akr@jaist.ac.jp>
+
+;; Author: Tanaka Akira <akr@jaist.ac.jp>
+;; Keywords: byte compile, evaluation
+
+;; This file is part of APEL (A Portable Emacs Library).
+
+;; 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.
+
+;;; Code:
+
+(put 'static-if 'lisp-indent-function 2)
+(defmacro static-if (cond then &rest else)
+  "Like `if', but evaluate COND at compile time."
+  (if (eval cond)
+      then
+    (` (progn  (,@ else)))))
+
+(put 'static-when 'lisp-indent-function 1)
+(defmacro static-when (cond &rest body)
+  "Like `when', but evaluate COND at compile time."
+  (if (eval cond)
+      (` (progn (,@ body)))))
+
+(put 'static-unless 'lisp-indent-function 1)
+(defmacro static-unless (cond &rest body)
+  "Like `unless', but evaluate COND at compile time."
+  (if (eval cond)
+      nil
+    (` (progn (,@ body)))))
+
+(put 'static-condition-case 'lisp-indent-function 2)
+(defmacro static-condition-case (var bodyform &rest handlers)
+  "Like `condition-case', but evaluate BODYFORM at compile time."
+  (eval (` (condition-case (, var)
+              (list (quote quote) (, bodyform))
+            (,@ (mapcar
+                 (if var
+                     (function
+                      (lambda (h)
+                        (` ((, (car h))
+                            (list (quote funcall)
+                                  (function (lambda ((, var)) (,@ (cdr h))))
+                                  (list (quote quote) (, var)))))))
+                   (function
+                    (lambda (h)
+                      (` ((, (car h)) (quote (progn (,@ (cdr h)))))))))
+                 handlers))))))
+
+(put 'static-defconst 'lisp-indent-function 'defun)
+(defmacro static-defconst (symbol initvalue &optional docstring)
+  "Like `defconst', but evaluate INITVALUE at compile time.
+
+The variable SYMBOL can be referred at both compile time and run time."
+  (let ((value (eval initvalue)))
+    (eval (` (defconst (, symbol) (quote (, value)) (, docstring))))
+    (` (defconst (, symbol) (quote (, value)) (, docstring)))))
+
+(defmacro static-cond (&rest clauses)
+  "Like `cond', but evaluate CONDITION part of each clause at compile time."
+  (while (and clauses
+             (not (eval (car (car clauses)))))
+    (setq clauses (cdr clauses)))
+  (if clauses
+      (cons 'progn (cdr (car clauses)))))
+
+
+;;; @ end
+;;;
+
+(require 'product)
+(product-provide (provide 'static) (require 'apel-ver))
+
+;;; static.el ends here
diff --git a/mail/hex-util.el b/mail/hex-util.el
new file mode 100644 (file)
index 0000000..92a09ff
--- /dev/null
@@ -0,0 +1,73 @@
+;;; hex-util.el --- Functions to encode/decode hexadecimal string.
+
+;; Copyright (C) 1999 Shuhei KOBAYASHI
+
+;; Author: Shuhei KOBAYASHI <shuhei@aqua.ocn.ne.jp>
+;; Keywords: data
+
+;; This file is part of FLIM (Faithful Library about Internet Message).
+
+;; 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 this program; 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
+  (defmacro hex-char-to-num (chr)
+    (` (let ((chr (, chr)))
+        (cond
+         ((and (<= ?a chr)(<= chr ?f)) (+ (- chr ?a) 10))
+         ((and (<= ?A chr)(<= chr ?F)) (+ (- chr ?A) 10))
+         ((and (<= ?0 chr)(<= chr ?9)) (- chr ?0))
+         (t (error "Invalid hexadecimal digit `%c'" chr))))))
+  (defmacro num-to-hex-char (num)
+    (` (aref "0123456789abcdef" (, num)))))
+
+(defun decode-hex-string (string)
+  "Decode hexadecimal STRING to octet string."
+  (let* ((len (length string))
+        (dst (make-string (/ len 2) 0))
+        (idx 0)(pos 0))
+    (while (< pos len)
+;;; logior and lsh are not byte-coded.
+;;;  (aset dst idx (logior (lsh (hex-char-to-num (aref string pos)) 4)
+;;;                        (hex-char-to-num (aref string (1+ pos)))))
+      (aset dst idx (+ (* (hex-char-to-num (aref string pos)) 16)
+                      (hex-char-to-num (aref string (1+ pos)))))
+      (setq idx (1+ idx)
+            pos (+ 2 pos)))
+    dst))
+
+(defun encode-hex-string (string)
+  "Encode octet STRING to hexadecimal string."
+  (let* ((len (length string))
+        (dst (make-string (* len 2) 0))
+        (idx 0)(pos 0))
+    (while (< pos len)
+;;; logand and lsh are not byte-coded.
+;;;  (aset dst idx (num-to-hex-char (logand (lsh (aref string pos) -4) 15)))
+      (aset dst idx (num-to-hex-char (/ (aref string pos) 16)))
+      (setq idx (1+ idx))
+;;;  (aset dst idx (num-to-hex-char (logand (aref string pos) 15)))
+      (aset dst idx (num-to-hex-char (% (aref string pos) 16)))
+      (setq idx (1+ idx)
+            pos (1+ pos)))
+    dst))
+
+(provide 'hex-util)
+
+;;; hex-util.el ends here
diff --git a/mail/hmac-def.el b/mail/hmac-def.el
new file mode 100644 (file)
index 0000000..7525c89
--- /dev/null
@@ -0,0 +1,85 @@
+;;; hmac-def.el --- A macro for defining HMAC functions.
+
+;; Copyright (C) 1999 Shuhei KOBAYASHI
+
+;; Author: Shuhei KOBAYASHI <shuhei@aqua.ocn.ne.jp>
+;; Keywords: HMAC, RFC 2104
+
+;; This file is part of FLIM (Faithful Library about Internet Message).
+
+;; 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 this program; see the file COPYING.  If not, write to
+;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Commentary:
+
+;; This program is implemented from RFC 2104,
+;; "HMAC: Keyed-Hashing for Message Authentication".
+
+;;; Code:
+
+(defmacro define-hmac-function (name H B L &optional bit)
+  "Define a function NAME(TEXT KEY) which computes HMAC with function H.
+
+HMAC function is H(KEY XOR opad, H(KEY XOR ipad, TEXT)):
+
+H is a cryptographic hash function, such as SHA1 and MD5, which takes
+a string and return a digest of it (in binary form).
+B is a byte-length of a block size of H. (B=64 for both SHA1 and MD5.)
+L is a byte-length of hash outputs. (L=16 for MD5, L=20 for SHA1.)
+If BIT is non-nil, truncate output to specified bits."
+  (` (defun (, name) (text key)
+       (, (concat "Compute "
+                 (upcase (symbol-name name))
+                 " over TEXT with KEY."))
+       (let ((key-xor-ipad (make-string (, B) ?\x36))
+            (key-xor-opad (make-string (, B) ?\x5C))
+            (len (length key))
+            (pos 0))
+        (unwind-protect
+            (progn
+              ;; if `key' is longer than the block size, apply hash function
+              ;; to `key' and use the result as a real `key'.
+              (if (> len (, B))
+                  (setq key ((, H) key)
+                        len (, L)))
+              (while (< pos len)
+                (aset key-xor-ipad pos (logxor (aref key pos) ?\x36))
+                (aset key-xor-opad pos (logxor (aref key pos) ?\x5C))
+                (setq pos (1+ pos)))
+              (setq key-xor-ipad (unwind-protect
+                                     (concat key-xor-ipad text)
+                                   (fillarray key-xor-ipad 0))
+                    key-xor-ipad (unwind-protect
+                                     ((, H) key-xor-ipad)
+                                   (fillarray key-xor-ipad 0))
+                    key-xor-opad (unwind-protect
+                                     (concat key-xor-opad key-xor-ipad)
+                                   (fillarray key-xor-opad 0))
+                    key-xor-opad (unwind-protect
+                                     ((, H) key-xor-opad)
+                                   (fillarray key-xor-opad 0)))
+              ;; now `key-xor-opad' contains
+              ;; H(KEY XOR opad, H(KEY XOR ipad, TEXT)).
+              (, (if (and bit (< (/ bit 8) L))
+                     (` (substring key-xor-opad 0 (, (/ bit 8))))
+                   ;; return a copy of `key-xor-opad'.
+                   (` (concat key-xor-opad)))))
+          ;; cleanup.
+          (fillarray key-xor-ipad 0)
+          (fillarray key-xor-opad 0))))))
+
+(provide 'hmac-def)
+
+;;; hmac-def.el ends here
diff --git a/mail/hmac-md5.el b/mail/hmac-md5.el
new file mode 100644 (file)
index 0000000..9c936d0
--- /dev/null
@@ -0,0 +1,95 @@
+;;; hmac-md5.el --- Compute HMAC-MD5.
+
+;; Copyright (C) 1999 Shuhei KOBAYASHI
+
+;; Author: Shuhei KOBAYASHI <shuhei@aqua.ocn.ne.jp>
+;;     Kenichi OKADA <okada@opaopa.org>
+;; Maintainer: Kenichi OKADA <okada@opaopa.org>
+;; Keywords: HMAC, RFC 2104, HMAC-MD5, MD5, KEYED-MD5, CRAM-MD5
+
+;; This file is part of FLIM (Faithful Library about Internet Message).
+
+;; 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 this program; see the file COPYING.  If not, write to
+;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Commentary:
+
+;; Test cases from RFC 2202, "Test Cases for HMAC-MD5 and HMAC-SHA-1".
+;;
+;; (encode-hex-string (hmac-md5 "Hi There" (make-string 16 ?\x0b)))
+;;  => "9294727a3638bb1c13f48ef8158bfc9d"
+;;
+;; (encode-hex-string (hmac-md5 "what do ya want for nothing?" "Jefe"))
+;;  => "750c783e6ab0b503eaa86e310a5db738"
+;;
+;; (encode-hex-string (hmac-md5 (make-string 50 ?\xdd) (make-string 16 ?\xaa)))
+;;  => "56be34521d144c88dbb8c733f0e8b3f6"
+;;
+;; (encode-hex-string
+;;  (hmac-md5
+;;   (make-string 50 ?\xcd)
+;;   (decode-hex-string "0102030405060708090a0b0c0d0e0f10111213141516171819")))
+;;  => "697eaf0aca3a3aea3a75164746ffaa79"
+;;
+;; (encode-hex-string
+;;  (hmac-md5 "Test With Truncation" (make-string 16 ?\x0c)))
+;;  => "56461ef2342edc00f9bab995690efd4c"
+;; (encode-hex-string
+;;  (hmac-md5-96 "Test With Truncation" (make-string 16 ?\x0c)))
+;;  => "56461ef2342edc00f9bab995"
+;;
+;; (encode-hex-string
+;;  (hmac-md5
+;;   "Test Using Larger Than Block-Size Key - Hash Key First"
+;;   (make-string 80 ?\xaa)))
+;;  => "6b1ab7fe4bd7bf8f0b62e6ce61b9d0cd"
+;;
+;; (encode-hex-string
+;;  (hmac-md5
+;;   "Test Using Larger Than Block-Size Key and Larger Than One Block-Size Data"
+;;   (make-string 80 ?\xaa)))
+;;  => "6f630fad67cda0ee1fb1f562db3aa53e"
+
+;;; Code:
+
+(eval-when-compile (require 'hmac-def))
+(require 'hex-util)                    ; (decode-hex-string STRING)
+(require 'md5)                         ; expects (md5 STRING)
+
+;; We cannot define this function in md5.el because recent XEmacs provides
+;; built-in md5 function and provides feature 'md5 at startup.
+(if (and (featurep 'xemacs)
+        (fboundp 'md5)
+        (subrp (symbol-function 'md5))
+        (condition-case nil
+            ;; `md5' of XEmacs 21 takes 4th arg CODING (and 5th arg NOERROR).
+            (md5 "" nil nil 'binary)   ; => "fb5d2156096fa1f254352f3cc3fada7e"
+          (error nil)))
+    ;; XEmacs 21.
+    (defun md5-binary (string &optional start end)
+      "Return the MD5 of STRING in binary form."
+      (decode-hex-string (md5 string start end 'binary)))
+  ;; not XEmacs 21 and not DL.
+  (if (not (fboundp 'md5-binary))
+      (defun md5-binary (string)
+       "Return the MD5 of STRING in binary form."
+       (decode-hex-string (md5 string)))))
+
+(define-hmac-function hmac-md5 md5-binary 64 16) ; => (hmac-md5 TEXT KEY)
+;; (define-hmac-function hmac-md5-96 md5-binary 64 16 96)
+
+(provide 'hmac-md5)
+
+;;; hmac-md5.el ends here
diff --git a/mail/hmac-sha1.el b/mail/hmac-sha1.el
new file mode 100644 (file)
index 0000000..6b2beea
--- /dev/null
@@ -0,0 +1,80 @@
+;;; hmac-sha1.el --- Compute HMAC-SHA1.
+
+;; Copyright (C) 1999 Shuhei KOBAYASHI
+
+;; Author: Shuhei KOBAYASHI <shuhei@aqua.ocn.ne.jp>
+;; Keywords: HMAC, RFC 2104, HMAC-SHA1, SHA1, Cancel-Lock
+
+;; This file is part of FLIM (Faithful Library about Internet Message).
+
+;; 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 this program; see the file COPYING.  If not, write to
+;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Commentary:
+
+;; Test cases from RFC 2202, "Test Cases for HMAC-MD5 and HMAC-SHA-1".
+;;
+;; (encode-hex-string (hmac-sha1 "Hi There" (make-string 20 ?\x0b)))
+;;  => "b617318655057264e28bc0b6fb378c8ef146be00"
+;;
+;; (encode-hex-string (hmac-sha1 "what do ya want for nothing?" "Jefe"))
+;;  => "effcdf6ae5eb2fa2d27416d5f184df9c259a7c79"
+;;
+;; (encode-hex-string (hmac-sha1 (make-string 50 ?\xdd) (make-string 20 ?\xaa)))
+;;  => "125d7342b9ac11cd91a39af48aa17b4f63f175d3"
+;;
+;; (encode-hex-string
+;;  (hmac-sha1
+;;   (make-string 50 ?\xcd)
+;;   (decode-hex-string "0102030405060708090a0b0c0d0e0f10111213141516171819")))
+;;  => "4c9007f4026250c6bc8414f9bf50c86c2d7235da"
+;;
+;; (encode-hex-string
+;;  (hmac-sha1 "Test With Truncation" (make-string 20 ?\x0c)))
+;;  => "4c1a03424b55e07fe7f27be1d58bb9324a9a5a04"
+;; (encode-hex-string
+;;  (hmac-sha1-96 "Test With Truncation" (make-string 20 ?\x0c)))
+;;  => "4c1a03424b55e07fe7f27be1"
+;;
+;; (encode-hex-string
+;;  (hmac-sha1
+;;   "Test Using Larger Than Block-Size Key - Hash Key First"
+;;   (make-string 80 ?\xaa)))
+;;  => "aa4ae5e15272d00e95705637ce8a3b55ed402112"
+;;
+;; (encode-hex-string
+;;  (hmac-sha1
+;;   "Test Using Larger Than Block-Size Key and Larger Than One Block-Size Data"
+;;   (make-string 80 ?\xaa)))
+;;  => "e8e99d0f45237d786d6bbaa7965c7808bbff1a91"
+
+;;; Code:
+
+(eval-when-compile (require 'hmac-def))
+(require 'hex-util)                    ; (decode-hex-string STRING)
+(require 'sha1)                                ; expects (sha1 STRING)
+
+;;; For consintency with hmac-md5.el, we define this function here.
+(or (fboundp 'sha1-binary)
+    (defun sha1-binary (string)
+      "Return the SHA1 of STRING in binary form."
+      (decode-hex-string (sha1 string))))
+
+(define-hmac-function hmac-sha1 sha1-binary 64 20) ; => (hmac-sha1 TEXT KEY)
+;; (define-hmac-function hmac-sha1-96 sha1-binary 64 20 96)
+
+(provide 'hmac-sha1)
+
+;;; hmac-sha1.el ends here
diff --git a/mail/qmtp.el b/mail/qmtp.el
new file mode 100644 (file)
index 0000000..e74f798
--- /dev/null
@@ -0,0 +1,143 @@
+;;; qmtp.el --- basic functions to send mail with QMTP server
+
+;; Copyright (C) 2000 Free Software Foundation, Inc.
+
+;; Author: Daiki Ueno <ueno@unixuser.org>
+;; Keywords: QMTP, qmail
+
+;; This file is part of FLIM (Faithful Library about Internet Message).
+
+;; 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 this program; see the file COPYING.  If not, write to the
+;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+
+;;; Commentary:
+
+;; Installation:
+
+;; To send mail using QMTP instead of SMTP, do
+
+;; (fset 'smtp-send-buffer 'qmtp-send-buffer)
+
+;;; Code:
+
+(require 'custom)
+(require 'mel) ; binary-funcall
+
+(defgroup qmtp nil
+  "QMTP protocol for sending mail."
+  :group 'mail)
+
+(defcustom qmtp-default-server nil
+  "Specify default QMTP server."
+  :type '(choice (const nil) string)
+  :group 'qmtp)
+
+(defvar qmtp-server qmtp-default-server
+  "The name of the host running QMTP server.
+It can also be a function
+called from `qmtp-via-qmtp' with arguments SENDER and RECIPIENTS.")
+
+(defcustom qmtp-service "qmtp"
+  "QMTP service port number.  \"qmtp\" or 209."
+  :type '(choice (integer :tag "209" 209)
+                 (string :tag "qmtp" "qmtp"))
+  :group 'qmtp)
+
+(defcustom qmtp-timeout 30
+  "Timeout for each QMTP session."
+  :type 'integer
+  :group 'qmtp)
+
+;;;###autoload
+(defvar qmtp-open-connection-function (function open-network-stream))
+
+(defvar qmtp-error-response-alist
+  '((?Z "Temporary failure")
+    (?D "Permanent failure")))
+
+(defvar qmtp-read-point nil)
+
+(defun qmtp-encode-netstring-string (string)
+  (format "%d:%s," (length string) string))
+
+(defun qmtp-send-package (process sender recipients buffer)
+  (with-temp-buffer
+    (buffer-disable-undo)
+    (erase-buffer)
+    (set-buffer-multibyte nil)
+    (insert
+     (format "%d:\n"
+            (with-current-buffer buffer
+              (1+ (point-max));; for the "\n"
+              )))
+    (insert-buffer-substring buffer)
+    (insert
+     "\n,"
+     (qmtp-encode-netstring-string sender)
+     (qmtp-encode-netstring-string
+      (mapconcat #'qmtp-encode-netstring-string
+                recipients "")))
+    (process-send-region process (point-min)(point-max)))
+  (goto-char qmtp-read-point)
+  (while (and (memq (process-status process) '(open run))
+             (not (re-search-forward "^[0-9]+:" nil 'noerror)))
+    (unless (accept-process-output process qmtp-timeout)
+      (error "timeout expired: %d" qmtp-timeout))
+    (goto-char qmtp-read-point))
+  (let ((response (char-after (match-end 0))))
+    (unless (eq response ?K)
+      (error (nth 1 (assq response qmtp-error-response-alist))))
+    (setq recipients (cdr recipients))
+    (beginning-of-line 2)
+    (setq qmtp-read-point (point))))
+
+;;;###autoload
+(defun qmtp-via-qmtp (sender recipients buffer)
+  (condition-case nil
+      (progn
+       (qmtp-send-buffer sender recipients buffer)
+       t)
+    (error)))
+
+(make-obsolete 'qmtp-via-qmtp "It's old API.")
+
+;;;###autoload
+(defun qmtp-send-buffer (sender recipients buffer)
+  (save-excursion
+    (set-buffer
+     (get-buffer-create
+      (format "*trace of QMTP session to %s*" qmtp-server)))
+    (buffer-disable-undo)
+    (erase-buffer)
+    (make-local-variable 'qmtp-read-point)
+    (setq qmtp-read-point (point-min))
+    (let (process)
+      (unwind-protect
+         (progn
+           (setq process
+                 (binary-funcall qmtp-open-connection-function
+                                 "QMTP" (current-buffer)
+                                 qmtp-server qmtp-service))
+           (qmtp-send-package process sender recipients buffer))
+       (when (and process
+                  (memq (process-status process) '(open run)))
+         ;; QUIT
+         (process-send-eof process)
+         (delete-process process))))))
+
+(provide 'qmtp)
+
+;;; qmtp.el ends here
diff --git a/mail/rmail-mime.el b/mail/rmail-mime.el
new file mode 100644 (file)
index 0000000..53e8d33
--- /dev/null
@@ -0,0 +1,198 @@
+;;; rmail-mime.el --- Add MIME handling facility to RMAIL
+
+;; Copyright (C) 2001 Free Software Foundation, Inc.
+
+;; Author: MORIOKA Tomohiko <tomo@m17n.org>
+;; Keywords: mail, news, MIME, multimedia, multilingual, encoded-word
+
+;; This file is part of SEMI (Setting for Emacs MIME Interfaces).
+
+;; 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.
+
+;;; Code:
+
+(require 'mime-view)
+
+(defun rmail-decode-header (decoded-buffer original-buffer start end)
+  (set-buffer (get-buffer-create decoded-buffer))
+  (erase-buffer)
+  (insert-buffer-substring original-buffer start end)
+  (mime-decode-header-in-buffer rmail-enable-mime))
+
+(defun rmail-decode-mime-message (decoded-buffer original-buffer start end)
+  (save-excursion
+    (set-buffer original-buffer)
+    (save-restriction
+      (narrow-to-region start end)
+      (mime-view-buffer nil decoded-buffer)))
+  (set-buffer decoded-buffer))
+
+(defun rmail-view-kill-rmail-buffer ()
+  (if rmail-buffer (kill-buffer rmail-buffer)))
+
+(defvar rmail-view-mode-map nil)
+
+(defun rmail-show-mime-message ()
+  (let ((abuf (current-buffer))
+       (buf-name (concat (buffer-name) "-view"))
+       buf win)
+    (setq mime-message-structure
+         (mime-open-entity 'babyl abuf))
+    (set-buffer (mime-display-message mime-message-structure
+                                     buf-name nil
+                                     nil nil rmail-view-mode-map))
+    (setq buf (current-buffer))
+    (make-local-variable 'font-lock-defaults)
+    (setq font-lock-defaults
+         '(rmail-font-lock-keywords
+           t nil nil nil
+           (font-lock-maximum-size . nil)
+           (font-lock-fontify-buffer-function
+            . rmail-fontify-buffer-function)
+           (font-lock-unfontify-buffer-function
+            . rmail-unfontify-buffer-function)
+           (font-lock-inhibit-thing-lock
+            . (lazy-lock-mode fast-lock-mode))))
+    (make-local-variable 'rmail-buffer)
+    (setq rmail-buffer abuf)
+    (make-local-variable 'rmail-view-buffer)
+    (setq rmail-view-buffer (current-buffer))
+    (make-local-variable 'rmail-summary-buffer)
+    (setq rmail-summary-buffer
+         (with-current-buffer rmail-buffer
+           rmail-summary-buffer))
+    (make-local-variable 'rmail-current-message)
+    (setq rmail-current-message
+         (with-current-buffer rmail-buffer
+           rmail-current-message))
+    (make-local-variable 'kill-buffer-hook)
+    (add-hook 'kill-buffer-hook 'rmail-view-kill-rmail-buffer)
+    (let ((mode-line
+          (with-current-buffer abuf
+            (setq rmail-view-buffer buf)
+            mode-line-process)))
+      (setq mode-line-process mode-line))
+    (if (and (setq win (get-buffer-window abuf))
+            buf)
+       (set-window-buffer win buf))
+    (bury-buffer rmail-buffer)
+    (run-hooks 'rmail-show-mime-message-hook)))
+
+(defun rmail-insert-mime-forwarded-message (forward-buffer)
+  (insert (mime-make-tag "message" "rfc822"))
+  (insert "\n")
+  (mime-insert-entity (with-current-buffer forward-buffer
+                       mime-message-structure)))
+
+(defun rmail-enable-mime ()
+  (interactive)
+  (setq rmail-enable-mime t)
+  (rmail-show-message))
+
+(defun rmail-disable-mime ()
+  (interactive)
+  (let ((buf rmail-buffer))
+    (when rmail-enable-mime
+      (remove-hook 'kill-buffer-hook 'rmail-view-kill-rmail-buffer)
+      (set-window-buffer (selected-window) buf)
+      (kill-buffer rmail-view-buffer))
+    (set-buffer buf))
+  (setq rmail-enable-mime nil
+       rmail-view-buffer (current-buffer))
+  (rmail-show-message))
+
+(defun rmail-search-mime-message (msg regexp)
+  "Search the message of number MSG for REGEXP.
+If the search succeeds, return non-nil.  Otherwise, return nil."
+  (save-excursion
+    (rmail-decode-mime-message " *RMAIL-temp-VIEW*"
+                              (current-buffer)
+                              (if (search-forward "\n*** EOOH ***\n"
+                                                  (rmail-msgend msg) t)
+                                  (match-end 0)
+                                (point))
+                              (rmail-msgend msg))
+    (goto-char (point-min))
+    (prog1 (re-search-forward regexp nil t)
+      (kill-buffer " *RMAIL-temp-VIEW*"))))
+
+(defun rmail-search-mime-header (msg beg end regexp)
+  "Search the message header of number MSG for REGEXP.
+If the search succeeds, return non-nil.  Otherwise, return nil."
+  (save-excursion
+    (rmail-decode-header " *RMAIL-temp-VIEW*"
+                        (current-buffer)
+                        beg end)
+    (goto-char (point-min))
+    (prog1 (re-search-forward regexp nil t)
+      (kill-buffer " *RMAIL-temp-VIEW*"))))
+
+(set-alist 'mime-raw-representation-type-alist 'rmail-mode
+          (if rmail-enable-mime
+              'binary
+            'cooked))
+
+(set-alist 'mime-preview-over-to-previous-method-alist
+          'rmail-mode
+          (function
+           (lambda ()
+             (message "Beginning of buffer")
+             ;; (rmail-previous-undeleted-message 1)
+             )))
+
+(set-alist 'mime-preview-over-to-next-method-alist
+          'rmail-mode
+          (function
+           (lambda ()
+             (message "End of buffer")
+             ;; (rmail-next-undeleted-message 1)
+             )))
+
+(set-alist 'mime-preview-quitting-method-alist 'rmail-mode #'rmail-quit)
+
+;; Override values defined in rmail.
+(eval-after-load "rmail"
+  '(progn
+     (define-key rmail-mode-map "v" 'rmail-enable-mime)
+     (setq rmail-show-mime-function (function rmail-show-mime-message))
+     (unless rmail-view-mode-map
+       (setq rmail-view-mode-map (mime-view-define-keymap rmail-mode-map))
+       (define-key rmail-view-mode-map
+        "p" (function rmail-previous-undeleted-message))
+       (define-key rmail-view-mode-map
+        "n" (function rmail-next-undeleted-message))
+       (define-key rmail-view-mode-map
+        "u" (function rmail-undelete-previous-message))
+       (define-key rmail-view-mode-map
+        "a" (function rmail-add-label))
+       (define-key rmail-view-mode-map
+        "\C-c\C-c" (function rmail-disable-mime)))))
+
+;; Override values defined in rmailsum.
+(eval-after-load "rmailsum"
+  '(setq rmail-summary-line-decoder
+        (function
+         (lambda (string)
+           (eword-decode-string
+            (decode-coding-string string 'undecided))))))
+
+;; Override values defined in sendmail.
+(eval-after-load "sendmail"
+  '(progn
+     (add-hook 'mail-setup-hook 'turn-on-mime-edit)
+     (add-hook 'mail-send-hook 'mime-edit-maybe-translate)))
+
+(provide 'rmail-mime)
diff --git a/mail/sasl-cram.el b/mail/sasl-cram.el
new file mode 100644 (file)
index 0000000..25d1082
--- /dev/null
@@ -0,0 +1,51 @@
+;;; sasl-cram.el --- CRAM-MD5 module for the SASL client framework
+
+;; Copyright (C) 2000 Free Software Foundation, Inc.
+
+;; Author: Daiki Ueno <ueno@unixuser.org>
+;;     Kenichi OKADA <okada@opaopa.org>
+;; Keywords: SASL, CRAM-MD5
+
+;; This file is part of FLIM (Faithful Library about Internet Message).
+
+;; 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 this program; see the file COPYING.  If not, write to the
+;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Commentary:
+
+(require 'sasl)
+(require 'hmac-md5)
+
+(defconst sasl-cram-md5-steps
+  '(ignore                             ;no initial response
+    sasl-cram-md5-response))
+
+(defun sasl-cram-md5-response (client step)
+  (let ((passphrase
+        (sasl-read-passphrase
+         (format "CRAM-MD5 passphrase for %s: "
+                 (sasl-client-name client)))))
+    (unwind-protect
+       (concat (sasl-client-name client) " "
+               (encode-hex-string
+                (hmac-md5 (sasl-step-data step) passphrase)))
+      (fillarray passphrase 0))))
+
+(put 'sasl-cram 'sasl-mechanism
+     (sasl-make-mechanism "CRAM-MD5" sasl-cram-md5-steps))
+
+(provide 'sasl-cram)
+
+;;; sasl-cram.el ends here
diff --git a/mail/sasl-digest.el b/mail/sasl-digest.el
new file mode 100644 (file)
index 0000000..9e061b7
--- /dev/null
@@ -0,0 +1,156 @@
+;;; sasl-digest.el --- DIGEST-MD5 module for the SASL client framework
+
+;; Copyright (C) 2000 Free Software Foundation, Inc.
+
+;; Author: Daiki Ueno <ueno@unixuser.org>
+;;     Kenichi OKADA <okada@opaopa.org>
+;; Keywords: SASL, DIGEST-MD5
+
+;; This file is part of FLIM (Faithful Library about Internet Message).
+
+;; 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 this program; see the file COPYING.  If not, write to the
+;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;; This program is implemented from draft-leach-digest-sasl-05.txt.
+;;
+;; It is caller's responsibility to base64-decode challenges and
+;; base64-encode responses in IMAP4 AUTHENTICATE command.
+;;
+;; Passphrase should be longer than 16 bytes. (See RFC 2195)
+
+;;; Commentary:
+
+(require 'sasl)
+(require 'hmac-md5)
+
+(defvar sasl-digest-md5-nonce-count 1)
+(defvar sasl-digest-md5-unique-id-function
+  sasl-unique-id-function)
+
+(defvar sasl-digest-md5-syntax-table
+  (let ((table (make-syntax-table)))
+    (modify-syntax-entry ?= "." table)
+    (modify-syntax-entry ?, "." table)
+    table)
+  "A syntax table for parsing digest-challenge attributes.")
+
+(defconst sasl-digest-md5-steps
+  '(ignore                             ;no initial response
+    sasl-digest-md5-response
+    ignore))                           ;""
+
+(defun sasl-digest-md5-parse-string (string)
+  "Parse STRING and return a property list.
+The value is a cons cell of the form \(realm nonce qop-options stale maxbuf
+charset algorithm cipher-opts auth-param)."
+  (with-temp-buffer
+    (set-syntax-table sasl-digest-md5-syntax-table)
+    (save-excursion
+      (insert string)
+      (goto-char (point-min))
+      (insert "(")
+      (while (progn (forward-sexp) (not (eobp)))
+       (delete-char 1)
+       (insert " "))
+      (insert ")")
+      (read (point-min-marker)))))
+
+(defun sasl-digest-md5-digest-uri (serv-type host &optional serv-name)
+  (concat serv-type "/" host
+         (if (and serv-name
+                  (not (string= host serv-name)))
+             (concat "/" serv-name))))
+
+(defun sasl-digest-md5-cnonce ()
+  (let ((sasl-unique-id-function sasl-digest-md5-unique-id-function))
+    (sasl-unique-id)))
+
+(defun sasl-digest-md5-response-value (username
+                                      realm
+                                      nonce
+                                      cnonce
+                                      nonce-count
+                                      qop
+                                      digest-uri
+                                      authzid)
+  (let ((passphrase
+        (sasl-read-passphrase
+         (format "DIGEST-MD5 passphrase for %s: "
+                 username))))
+    (unwind-protect
+       (encode-hex-string
+        (md5-binary
+         (concat
+          (encode-hex-string
+           (md5-binary (concat (md5-binary 
+                                (concat username ":" realm ":" passphrase))
+                               ":" nonce ":" cnonce
+                               (if authzid 
+                                   (concat ":" authzid)))))
+          ":" nonce
+          ":" (format "%08x" nonce-count) ":" cnonce ":" qop ":"
+          (encode-hex-string
+           (md5-binary
+            (concat "AUTHENTICATE:" digest-uri
+                    (if (member qop '("auth-int" "auth-conf"))
+                        ":00000000000000000000000000000000")))))))
+      (fillarray passphrase 0))))
+
+(defun sasl-digest-md5-response (client step)
+  (let* ((plist
+         (sasl-digest-md5-parse-string (sasl-step-data step)))
+        (realm
+         (or (sasl-client-property client 'realm)
+             (plist-get plist 'realm))) ;need to check
+        (nonce-count
+         (or (sasl-client-property client 'nonce-count)
+              sasl-digest-md5-nonce-count))
+        (qop
+         (or (sasl-client-property client 'qop)
+             "auth"))
+        (digest-uri
+         (sasl-digest-md5-digest-uri
+          (sasl-client-service client)(sasl-client-server client)))
+        (cnonce
+         (or (sasl-client-property client 'cnonce)
+             (sasl-digest-md5-cnonce))))
+    (sasl-client-set-property client 'nonce-count (1+ nonce-count))
+    (unless (string= qop "auth")
+      (sasl-error (format "Unsupported \"qop-value\": %s" qop)))
+    (concat
+     "username=\"" (sasl-client-name client) "\","
+     "realm=\"" realm "\","
+     "nonce=\"" (plist-get plist 'nonce) "\","
+     "cnonce=\"" cnonce "\","
+     (format "nc=%08x," nonce-count)
+     "digest-uri=\"" digest-uri "\","
+     "qop=" qop ","
+     "response="
+     (sasl-digest-md5-response-value
+      (sasl-client-name client)
+      realm
+      (plist-get plist 'nonce)
+      cnonce
+      nonce-count
+      qop
+      digest-uri
+      (plist-get plist 'authzid)))))
+
+(put 'sasl-digest 'sasl-mechanism
+     (sasl-make-mechanism "DIGEST-MD5" sasl-digest-md5-steps))
+
+(provide 'sasl-digest)
+
+;;; sasl-digest.el ends here
diff --git a/mail/sasl.el b/mail/sasl.el
new file mode 100644 (file)
index 0000000..8528898
--- /dev/null
@@ -0,0 +1,269 @@
+;;; sasl.el --- SASL client framework
+
+;; Copyright (C) 2000 Free Software Foundation, Inc.
+
+;; Author: Daiki Ueno <ueno@unixuser.org>
+;; Keywords: SASL
+
+;; This file is part of FLIM (Faithful Library about Internet Message).
+
+;; 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 this program; see the file COPYING.  If not, write to the
+;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Commentary:
+
+;; This module provides common interface functions to share several
+;; SASL mechanism drivers.  The toplevel is designed to be mostly
+;; compatible with [Java-SASL].
+;;
+;; [SASL] J. Myers, "Simple Authentication and Security Layer (SASL)",
+;;     RFC 2222, October 1997.
+;;
+;; [Java-SASL] R. Weltman & R. Lee, "The Java SASL Application Program
+;;     Interface", draft-weltman-java-sasl-03.txt, March 2000.
+
+;;; Code:
+
+(defvar sasl-mechanisms
+  '("CRAM-MD5" "DIGEST-MD5" "PLAIN" "LOGIN" "ANONYMOUS"))
+
+(defvar sasl-mechanism-alist
+  '(("CRAM-MD5" sasl-cram)
+    ("DIGEST-MD5" sasl-digest)
+    ("PLAIN" sasl-plain)
+    ("LOGIN" sasl-login)
+    ("ANONYMOUS" sasl-anonymous)))
+
+(defvar sasl-unique-id-function #'sasl-unique-id-function)
+
+(put 'sasl-error 'error-message "SASL error")
+(put 'sasl-error 'error-conditions '(sasl-error error))
+
+(defun sasl-error (datum)
+  (signal 'sasl-error (list datum)))
+
+;;; @ SASL client
+;;;
+
+(defun sasl-make-client (mechanism name service server)
+  "Return a newly allocated SASL client.
+NAME is name of the authorization.  SERVICE is name of the service desired.
+SERVER is the fully qualified host name of the server to authenticate to."
+  (vector mechanism name service server (make-symbol "sasl-client-properties")))
+
+(defun sasl-client-mechanism (client)
+  "Return the authentication mechanism driver of CLIENT."
+  (aref client 0))
+
+(defun sasl-client-name (client)
+  "Return the authorization name of CLIENT, a string."
+  (aref client 1))
+
+(defun sasl-client-service (client)
+  "Return the service name of CLIENT, a string."
+  (aref client 2))
+
+(defun sasl-client-server (client)
+  "Return the server name of CLIENT, a string."
+  (aref client 3))
+
+(defun sasl-client-set-properties (client plist)
+  "Destructively set the properties of CLIENT.
+The second argument PLIST is the new property list."
+  (setplist (aref client 4) plist))
+
+(defun sasl-client-set-property (client property value)
+  "Add the given property/value to CLIENT."
+  (put (aref client 4) property value))
+
+(defun sasl-client-property (client property)
+  "Return the value of the PROPERTY of CLIENT."
+  (get (aref client 4) property))
+
+(defun sasl-client-properties (client)
+  "Return the properties of CLIENT."
+  (symbol-plist (aref client 4)))
+
+;;; @ SASL mechanism
+;;;
+
+(defun sasl-make-mechanism (name steps)
+  "Make an authentication mechanism.
+NAME is a IANA registered SASL mechanism name.
+STEPS is list of continuation function."
+  (vector name
+         (mapcar
+          (lambda (step)
+            (let ((symbol (make-symbol (symbol-name step))))
+              (fset symbol (symbol-function step))
+              symbol))
+          steps)))
+
+(defun sasl-mechanism-name (mechanism)
+  "Return name of MECHANISM, a string."
+  (aref mechanism 0))
+
+(defun sasl-mechanism-steps (mechanism)
+  "Return the authentication steps of MECHANISM, a list of functions."
+  (aref mechanism 1))
+
+(defun sasl-find-mechanism (mechanisms)
+  "Retrieve an apropriate mechanism object from MECHANISMS hints."
+  (let* ((sasl-mechanisms sasl-mechanisms)
+        (mechanism
+         (catch 'done
+           (while sasl-mechanisms
+             (if (member (car sasl-mechanisms) mechanisms)
+                 (throw 'done (nth 1 (assoc (car sasl-mechanisms)
+                                            sasl-mechanism-alist))))
+             (setq sasl-mechanisms (cdr sasl-mechanisms))))))
+    (if mechanism
+       (require mechanism))
+    (get mechanism 'sasl-mechanism)))
+
+;;; @ SASL authentication step
+;;;
+
+(defun sasl-step-data (step)
+  "Return the data which STEP holds, a string."
+  (aref step 1))
+
+(defun sasl-step-set-data (step data)
+  "Store DATA string to STEP."
+  (aset step 1 data))
+
+(defun sasl-next-step (client step)
+  "Evaluate the challenge and prepare an appropriate next response.
+The data type of the value and optional 2nd argument STEP is nil or
+opaque authentication step which holds the reference to the next action
+and the current challenge.  At the first time STEP should be set to nil."
+  (let* ((steps
+         (sasl-mechanism-steps
+          (sasl-client-mechanism client)))
+        (function
+         (if (vectorp step)
+             (nth 1 (memq (aref step 0) steps))
+           (car steps))))
+    (if function
+       (vector function (funcall function client step)))))
+
+(defvar sasl-read-passphrase nil)
+(defun sasl-read-passphrase (prompt)
+  (if (not sasl-read-passphrase)
+      (if (functionp 'read-passwd)
+         (setq sasl-read-passphrase 'read-passwd)
+       (if (load "passwd" t)
+           (setq sasl-read-passphrase 'read-passwd)
+         (autoload 'ange-ftp-read-passwd "ange-ftp")
+         (setq sasl-read-passphrase 'ange-ftp-read-passwd))))
+  (funcall sasl-read-passphrase prompt))
+
+(defun sasl-unique-id ()
+  "Compute a data string which must be different each time.
+It contain at least 64 bits of entropy."
+  (concat (funcall sasl-unique-id-function)(funcall sasl-unique-id-function)))
+
+(defvar sasl-unique-id-char nil)
+
+;; stolen (and renamed) from message.el
+(defun sasl-unique-id-function ()
+  ;; Don't use microseconds from (current-time), they may be unsupported.
+  ;; Instead we use this randomly inited counter.
+  (setq sasl-unique-id-char
+       (% (1+ (or sasl-unique-id-char (logand (random t) (1- (lsh 1 20)))))
+          ;; (current-time) returns 16-bit ints,
+          ;; and 2^16*25 just fits into 4 digits i base 36.
+          (* 25 25)))
+  (let ((tm (current-time)))
+    (concat
+     (sasl-unique-id-number-base36
+      (+ (car   tm)
+        (lsh (% sasl-unique-id-char 25) 16)) 4)
+     (sasl-unique-id-number-base36
+      (+ (nth 1 tm)
+        (lsh (/ sasl-unique-id-char 25) 16)) 4))))
+
+(defun sasl-unique-id-number-base36 (num len)
+  (if (if (< len 0)
+         (<= num 0)
+       (= len 0))
+      ""
+    (concat (sasl-unique-id-number-base36 (/ num 36) (1- len))
+           (char-to-string (aref "zyxwvutsrqponmlkjihgfedcba9876543210"
+                                 (% num 36))))))
+
+;;; PLAIN (RFC2595 Section 6)
+(defconst sasl-plain-steps
+  '(sasl-plain-response))
+
+(defun sasl-plain-response (client step)
+  (let ((passphrase
+        (sasl-read-passphrase
+         (format "PLAIN passphrase for %s: " (sasl-client-name client))))
+       (authenticator-name
+        (sasl-client-property
+         client 'authenticator-name))
+       (name (sasl-client-name client)))
+    (unwind-protect
+       (if (and authenticator-name
+                (not (string= authenticator-name name)))
+           (concat authenticator-name "\0" name "\0" passphrase)
+         (concat "\0" name "\0" passphrase))
+      (fillarray passphrase 0))))
+
+(put 'sasl-plain 'sasl-mechanism
+     (sasl-make-mechanism "PLAIN" sasl-plain-steps))
+
+(provide 'sasl-plain)
+
+;;; LOGIN (No specification exists)
+(defconst sasl-login-steps
+  '(ignore                             ;no initial response
+    sasl-login-response-1
+    sasl-login-response-2))
+
+(defun sasl-login-response-1 (client step)
+;;;  (unless (string-match "^Username:" (sasl-step-data step))
+;;;    (sasl-error (format "Unexpected response: %s" (sasl-step-data step))))
+  (sasl-client-name client))
+
+(defun sasl-login-response-2 (client step)
+;;;  (unless (string-match "^Password:" (sasl-step-data step))
+;;;    (sasl-error (format "Unexpected response: %s" (sasl-step-data step))))
+  (sasl-read-passphrase
+   (format "LOGIN passphrase for %s: " (sasl-client-name client))))
+
+(put 'sasl-login 'sasl-mechanism
+     (sasl-make-mechanism "LOGIN" sasl-login-steps))
+
+(provide 'sasl-login)
+
+;;; ANONYMOUS (RFC2245)
+(defconst sasl-anonymous-steps
+  '(ignore                             ;no initial response
+    sasl-anonymous-response))
+
+(defun sasl-anonymous-response (client step)
+  (or (sasl-client-property client 'trace)
+      (sasl-client-name client)))
+
+(put 'sasl-anonymous 'sasl-mechanism
+     (sasl-make-mechanism "ANONYMOUS" sasl-anonymous-steps))
+
+(provide 'sasl-anonymous)
+
+(provide 'sasl)
+
+;;; sasl.el ends here
diff --git a/mail/sha1.el b/mail/sha1.el
new file mode 100644 (file)
index 0000000..24a3af5
--- /dev/null
@@ -0,0 +1,78 @@
+;;; sha1.el --- SHA1 Secure Hash Algorithm.
+
+;; Copyright (C) 1999 Shuhei KOBAYASHI
+
+;; Author: Shuhei KOBAYASHI <shuhei@aqua.ocn.ne.jp>
+;;     Kenichi OKADA <okada@opaopa.org>
+;; Maintainer: Kenichi OKADA <okada@opaopa.org>
+;; Keywords: SHA1, FIPS 180-1
+
+;; This file is part of FLIM (Faithful Library about Internet Message).
+
+;; 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 this program; see the file COPYING.  If not, write to
+;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Commentary:
+
+;; Examples from FIPS PUB 180-1.
+;; <URL:http://www.itl.nist.gov/div897/pubs/fip180-1.htm>
+;;
+;; (sha1 "abc")
+;; => a9993e364706816aba3e25717850c26c9cd0d89d
+;;
+;; (sha1 "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq")
+;; => 84983e441c3bd26ebaae4aa1f95129e5e54670f1
+;;
+;; (sha1 (make-string 1000000 ?a))
+;; => 34aa973cd4c4daa4f61eeb2bdbad27316534016f
+
+;;; Code:
+
+(require 'hex-util)
+
+(eval-when-compile
+  (or (fboundp 'sha1-string)
+      (defun sha1-string (a))))
+
+(defvar sha1-dl-module
+  (if (and (fboundp 'sha1-string)
+          (subrp (symbol-function 'sha1-string)))
+      nil
+    (if (fboundp 'dynamic-link)
+       (let ((path (expand-file-name "sha1.so" exec-directory)))
+         (and (file-exists-p path)
+              path)))))
+
+(cond
+ (sha1-dl-module
+  ;; Emacs with DL patch.
+  (require 'sha1-dl))
+ (t
+  (require 'sha1-el)))
+
+;; compatibility for another sha1.el by Keiichi Suzuki.
+(defun sha1-encode (string)
+  (decode-hex-string 
+   (sha1-string string)))
+(defun sha1-encode-binary (string)
+  (decode-hex-string
+   (sha1-string string)))
+
+(make-obsolete 'sha1-encode "It's old API.")
+(make-obsolete 'sha1-encode-binary "It's old API.")
+
+(provide 'sha1)
+
+;;; sha1.el ends here
diff --git a/mail/smtp.el b/mail/smtp.el
new file mode 100644 (file)
index 0000000..4265bbd
--- /dev/null
@@ -0,0 +1,614 @@
+;;; smtp.el --- basic functions to send mail with SMTP server
+
+;; Copyright (C) 1995, 1996, 1998, 1999, 2000 Free Software Foundation, Inc.
+
+;; Author: Tomoji Kagatani <kagatani@rbc.ncl.omron.co.jp>
+;;     Simon Leinen <simon@switch.ch> (ESMTP support)
+;;     Shuhei KOBAYASHI <shuhei@aqua.ocn.ne.jp>
+;;     Daiki Ueno <ueno@unixuser.org>
+;; Keywords: SMTP, mail
+
+;; This file is part of FLIM (Faithful Library about Internet Message).
+
+;; 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 this program; 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:
+
+(require 'custom)
+(require 'mail-utils)                  ; mail-strip-quoted-names
+(require 'sasl)
+(require 'luna)
+(require 'mel) ; binary-funcall
+
+(defgroup smtp nil
+  "SMTP protocol for sending mail."
+  :group 'mail)
+
+(defgroup smtp-extensions nil
+  "SMTP service extensions (RFC1869)."
+  :group 'smtp)
+
+(defcustom smtp-default-server nil
+  "Specify default SMTP server."
+  :type '(choice (const nil) string)
+  :group 'smtp)
+
+(defcustom smtp-server (or (getenv "SMTPSERVER") smtp-default-server)
+  "The name of the host running SMTP server.
+It can also be a function
+called from `smtp-via-smtp' with arguments SENDER and RECIPIENTS."
+  :type '(choice (string :tag "Name")
+                (function :tag "Function"))
+  :group 'smtp)
+
+(defcustom smtp-service "smtp"
+  "SMTP service port number.  \"smtp\" or 25."
+  :type '(choice (integer :tag "25" 25)
+                 (string :tag "smtp" "smtp"))
+  :group 'smtp)
+
+(defcustom smtp-local-domain nil
+  "Local domain name without a host name.
+If the function (system-name) returns the full internet address,
+don't define this value."
+  :type '(choice (const nil) string)
+  :group 'smtp)
+
+(defcustom smtp-fqdn nil
+  "Fully qualified domain name used for Message-ID."
+  :type '(choice (const nil) string)
+  :group 'smtp)
+
+(defcustom smtp-use-8bitmime t
+  "If non-nil, use ESMTP 8BITMIME (RFC1652) if available."
+  :type 'boolean
+  :group 'smtp-extensions)
+
+(defcustom smtp-use-size t
+  "If non-nil, use ESMTP SIZE (RFC1870) if available."
+  :type 'boolean
+  :group 'smtp-extensions)
+
+(defcustom smtp-use-starttls nil
+  "If non-nil, use STARTTLS (RFC2595) if available."
+  :type 'boolean
+  :group 'smtp-extensions)
+
+(defcustom smtp-use-sasl nil
+  "If non-nil, use SMTP Authentication (RFC2554) if available."
+  :type 'boolean
+  :group 'smtp-extensions)
+
+(defcustom smtp-sasl-user-name (user-login-name)
+  "Identification to be used for authorization."
+  :type 'string
+  :group 'smtp-extensions)
+
+(defcustom smtp-sasl-properties nil
+  "Properties set to SASL client."
+  :type 'string
+  :group 'smtp-extensions)
+
+(defcustom smtp-sasl-mechanisms nil
+  "List of authentication mechanisms."
+  :type '(repeat string)
+  :group 'smtp-extensions)
+
+(defvar sasl-mechanisms)
+
+;;;###autoload
+(defvar smtp-open-connection-function #'open-network-stream)
+
+(defvar smtp-read-point nil)
+
+(defvar smtp-connection-alist nil)
+
+(defvar smtp-submit-package-function #'smtp-submit-package)
+
+;;; @ SMTP package
+;;; A package contains a mail message, an envelope sender address,
+;;; and one or more envelope recipient addresses.  In ESMTP model
+;;; the current sending package should be guaranteed to be accessible
+;;; anywhere from the hook methods (or SMTP commands).
+
+(eval-and-compile
+  (luna-define-class smtp-package ()
+                    (sender
+                     recipients
+                     buffer))
+
+  (luna-define-internal-accessors 'smtp-package))
+
+(defun smtp-make-package (sender recipients buffer)
+  "Create a new package structure.
+A package is a unit of SMTP message
+SENDER specifies the package sender, a string.
+RECIPIENTS is a list of recipients.
+BUFFER may be a buffer or a buffer name which contains mail message."
+  (luna-make-entity 'smtp-package :sender sender :recipients recipients :buffer buffer))
+
+(defun smtp-package-buffer-internal-size (package)
+  "Return the size of PACKAGE, an integer."
+  (save-excursion
+    (set-buffer (smtp-package-buffer-internal package))
+    (let ((size
+          (+ (buffer-size)
+             ;; Add one byte for each change-of-line
+             ;; because or CR-LF representation:
+             (count-lines (point-min) (point-max))
+             ;; For some reason, an empty line is
+             ;; added to the message.  Maybe this
+             ;; is a bug, but it can't hurt to add
+             ;; those two bytes anyway:
+             2)))
+      (goto-char (point-min))
+      (while (re-search-forward "^\\." nil t)
+       (setq size (1+ size)))
+      size)))
+
+;;; @ SMTP connection
+;;; We should consider the function `open-network-stream' is a emulation
+;;; for another network stream.  They are likely to be implemented with an
+;;; external program and the function `process-contact' returns the
+;;; process id instead of `(HOST SERVICE)' pair.
+
+(eval-and-compile
+  (luna-define-class smtp-connection ()
+                    (process
+                     server
+                     service
+                     extensions
+                     encoder
+                     decoder))
+
+  (luna-define-internal-accessors 'smtp-connection))
+
+(defun smtp-make-connection (process server service)
+  "Create a new connection structure.
+PROCESS is an internal subprocess-object.  SERVER is name of the host
+to connect to.  SERVICE is name of the service desired."
+  (luna-make-entity 'smtp-connection :process process :server server :service service))
+
+(luna-define-generic smtp-connection-opened (connection)
+  "Say whether the CONNECTION to server has been opened.")
+
+(luna-define-generic smtp-close-connection (connection)
+  "Close the CONNECTION to server.")
+
+(luna-define-method smtp-connection-opened ((connection smtp-connection))
+  (let ((process (smtp-connection-process-internal connection)))
+    (if (memq (process-status process) '(open run))
+       t)))
+
+(luna-define-method smtp-close-connection ((connection smtp-connection))
+  (let ((process (smtp-connection-process-internal connection)))
+    (delete-process process)))
+
+(defun smtp-make-fqdn ()
+  "Return user's fully qualified domain name."
+  (if smtp-fqdn
+      smtp-fqdn
+    (let ((system-name (system-name)))
+      (cond
+       (smtp-local-domain
+       (concat system-name "." smtp-local-domain))
+       ((string-match "[^.]\\.[^.]" system-name)
+       system-name)
+       (t
+       (error "Cannot generate valid FQDN"))))))
+
+(defun smtp-find-connection (buffer)
+  "Find the connection delivering to BUFFER."
+  (let ((entry (assq buffer smtp-connection-alist))
+       connection)
+    (when entry
+      (setq connection (nth 1 entry))
+      (if (smtp-connection-opened connection)
+         connection
+       (setq smtp-connection-alist
+             (delq entry smtp-connection-alist))
+       nil))))
+
+(eval-and-compile
+  (autoload 'starttls-open-stream "starttls")
+  (autoload 'starttls-negotiate "starttls"))
+
+(defun smtp-open-connection (buffer server service)
+  "Open a SMTP connection for a service to a host.
+Return a newly allocated connection-object.
+BUFFER is the buffer to associate with the connection.  SERVER is name
+of the host to connect to.  SERVICE is name of the service desired."
+  (let ((process
+        (binary-funcall smtp-open-connection-function
+                        "SMTP" buffer server service))
+       connection)
+    (when process
+      (setq connection (smtp-make-connection process server service))
+      (set-process-filter process 'smtp-process-filter)
+      (setq smtp-connection-alist
+           (cons (list buffer connection)
+                 smtp-connection-alist))
+      connection)))
+
+;;;###autoload
+(defun smtp-via-smtp (sender recipients buffer)
+  "Like `smtp-send-buffer', but sucks in any errors."
+  (condition-case nil
+      (progn
+       (smtp-send-buffer sender recipients buffer)
+       t)
+    (smtp-error)))
+
+(make-obsolete 'smtp-via-smtp "It's old API.")
+
+;;;###autoload
+(defun smtp-send-buffer (sender recipients buffer)
+  "Send a message.
+SENDER is an envelope sender address.
+RECIPIENTS is a list of envelope recipient addresses.
+BUFFER may be a buffer or a buffer name which contains mail message."
+  (let ((server
+        (if (functionp smtp-server)
+            (funcall smtp-server sender recipients)
+          smtp-server))
+       (package
+        (smtp-make-package sender recipients buffer))
+       (smtp-open-connection-function
+        (if smtp-use-starttls
+            #'starttls-open-stream
+          smtp-open-connection-function)))
+    (save-excursion
+      (set-buffer
+       (get-buffer-create
+       (format "*trace of SMTP session to %s*" server)))
+      (erase-buffer)
+      (buffer-disable-undo)
+      (unless (smtp-find-connection (current-buffer))
+       (smtp-open-connection (current-buffer) server smtp-service))
+      (make-local-variable 'smtp-read-point)
+      (setq smtp-read-point (point-min))
+      (funcall smtp-submit-package-function package))))
+
+(defun smtp-submit-package (package)
+  (unwind-protect
+      (progn
+       (smtp-primitive-greeting package)
+       (condition-case nil
+           (smtp-primitive-ehlo package)
+         (smtp-response-error
+          (smtp-primitive-helo package)))
+       (if smtp-use-starttls
+           (smtp-primitive-starttls package))
+       (if smtp-use-sasl
+           (smtp-primitive-auth package))
+       (smtp-primitive-mailfrom package)
+       (smtp-primitive-rcptto package)
+       (smtp-primitive-data package))
+    (let ((connection (smtp-find-connection (current-buffer))))
+      (when (smtp-connection-opened connection)
+       (smtp-primitive-quit package)
+       (smtp-close-connection connection)))))
+
+;;; @ hook methods for `smtp-submit-package'
+;;;
+
+(defun smtp-primitive-greeting (package)
+  (let* ((connection
+         (smtp-find-connection (current-buffer)))
+        (response
+         (smtp-read-response connection)))
+    (if (/= (car response) 220)
+       (smtp-response-error response))))
+
+(defun smtp-primitive-ehlo (package)
+  (let* ((connection
+         (smtp-find-connection (current-buffer)))
+        response)
+    (smtp-send-command connection (format "EHLO %s" (smtp-make-fqdn)))
+    (setq response (smtp-read-response connection))
+    (if (/= (car response) 250)
+       (smtp-response-error response))
+    (smtp-connection-set-extensions-internal
+     connection (mapcar
+                (lambda (extension)
+                  (let ((extensions
+                         (split-string extension)))
+                    (setcar extensions
+                            (car (read-from-string
+                                  (downcase (car extensions)))))
+                    extensions))
+                (cdr response)))))
+
+(defun smtp-primitive-helo (package)
+  (let* ((connection
+         (smtp-find-connection (current-buffer)))
+        response)
+    (smtp-send-command connection (format "HELO %s" (smtp-make-fqdn)))
+    (setq response (smtp-read-response connection))
+    (if (/= (car response) 250)
+       (smtp-response-error response))))
+
+(defun smtp-primitive-auth (package)
+  (let* ((connection
+         (smtp-find-connection (current-buffer)))
+        (mechanisms
+         (cdr (assq 'auth (smtp-connection-extensions-internal connection))))
+        (sasl-mechanisms
+         (or smtp-sasl-mechanisms sasl-mechanisms))
+        (mechanism
+         (sasl-find-mechanism mechanisms))
+        client
+        name
+        step
+        response)
+    (unless mechanism
+      (error "No authentication mechanism available"))
+    (setq client (sasl-make-client mechanism smtp-sasl-user-name "smtp"
+                                  (smtp-connection-server-internal connection)))
+    (if smtp-sasl-properties
+       (sasl-client-set-properties client smtp-sasl-properties))
+    (setq name (sasl-mechanism-name mechanism)
+         ;; Retrieve the initial response
+         step (sasl-next-step client nil))
+    (smtp-send-command
+     connection
+     (if (sasl-step-data step)
+        (format "AUTH %s %s" name (base64-encode-string (sasl-step-data step) t))
+       (format "AUTH %s" name)))
+    (catch 'done
+      (while t
+       (setq response (smtp-read-response connection))
+       (when (= (car response) 235)
+         ;; The authentication process is finished.
+         (setq step (sasl-next-step client step))
+         (if (null step)
+             (throw 'done nil))
+         (smtp-response-error response)) ;Bogus server?
+       (if (/= (car response) 334)
+           (smtp-response-error response))
+       (sasl-step-set-data step (base64-decode-string (nth 1 response)))
+       (setq step (sasl-next-step client step))
+       (smtp-send-command
+        connection
+        (if (sasl-step-data step)
+            (base64-encode-string (sasl-step-data step) t)
+          ""))))
+;;;    (smtp-connection-set-encoder-internal
+;;;     connection (sasl-client-encoder client))
+;;;    (smtp-connection-set-decoder-internal
+;;;     connection (sasl-client-decoder client))
+    ))
+
+(defun smtp-primitive-starttls (package)
+  (let* ((connection
+         (smtp-find-connection (current-buffer)))
+        response)
+    ;; STARTTLS --- begin a TLS negotiation (RFC 2595)
+    (smtp-send-command connection "STARTTLS")
+    (setq response (smtp-read-response connection))
+    (if (/= (car response) 220)
+       (smtp-response-error response))
+    (starttls-negotiate (smtp-connection-process-internal connection))))
+
+(defun smtp-primitive-mailfrom (package)
+  (let* ((connection
+         (smtp-find-connection (current-buffer)))
+        (extensions
+         (smtp-connection-extensions-internal
+          connection))
+        (sender
+         (smtp-package-sender-internal package))
+        extension
+        response)
+    ;; SIZE --- Message Size Declaration (RFC1870)
+    (if (and smtp-use-size
+            (assq 'size extensions))
+       (setq extension (format "SIZE=%d" (smtp-package-buffer-internal-size package))))
+    ;; 8BITMIME --- 8bit-MIMEtransport (RFC1652)
+    (if (and smtp-use-8bitmime
+            (assq '8bitmime extensions))
+       (setq extension (concat extension " BODY=8BITMIME")))
+    (smtp-send-command
+     connection
+     (if extension
+        (format "MAIL FROM:<%s> %s" sender extension)
+       (format "MAIL FROM:<%s>" sender)))
+    (setq response (smtp-read-response connection))
+    (if (/= (car response) 250)
+       (smtp-response-error response))))
+
+(defun smtp-primitive-rcptto (package)
+  (let* ((connection
+         (smtp-find-connection (current-buffer)))
+        (recipients
+         (smtp-package-recipients-internal package))
+        response)
+    (while recipients
+      (smtp-send-command
+       connection (format "RCPT TO:<%s>" (pop recipients)))
+      (setq response (smtp-read-response connection))
+      (unless (memq (car response) '(250 251))
+       (smtp-response-error response)))))
+
+(defun smtp-primitive-data (package)
+  (let* ((connection
+         (smtp-find-connection (current-buffer)))
+        response)
+    (smtp-send-command connection "DATA")
+    (setq response (smtp-read-response connection))
+    (if (/= (car response) 354)
+       (smtp-response-error response))
+    (save-excursion
+      (set-buffer (smtp-package-buffer-internal package))
+      (goto-char (point-min))
+      (while (not (eobp))
+       (smtp-send-data
+        connection (buffer-substring (point) (progn (end-of-line)(point))))
+       (beginning-of-line 2)))
+    (smtp-send-command connection ".")
+    (setq response (smtp-read-response connection))
+    (if (/= (car response) 250)
+       (smtp-response-error response))))
+
+(defun smtp-primitive-quit (package)
+  (let* ((connection
+         (smtp-find-connection (current-buffer)))
+        response)
+    (smtp-send-command connection "QUIT")
+    (setq response (smtp-read-response connection))
+    (if (/= (car response) 221)
+       (smtp-response-error response))))
+
+;;; @ low level process manipulating function
+;;;
+(defun smtp-process-filter (process output)
+  (save-excursion
+    (set-buffer (process-buffer process))
+    (goto-char (point-max))
+    (insert output)))
+
+(put 'smtp-error 'error-message "SMTP error")
+(put 'smtp-error 'error-conditions '(smtp-error error))
+
+(put 'smtp-response-error 'error-message "SMTP response error")
+(put 'smtp-response-error 'error-conditions '(smtp-response-error smtp-error error))
+
+(defun smtp-response-error (response)
+  (signal 'smtp-response-error response))
+
+(defun smtp-read-response (connection)
+  (let ((decoder
+        (smtp-connection-decoder-internal connection))
+       (response-continue t)
+       response)
+    (while response-continue
+      (goto-char smtp-read-point)
+      (while (not (search-forward "\r\n" nil t))
+       (accept-process-output (smtp-connection-process-internal connection))
+       (goto-char smtp-read-point))
+      (if decoder
+         (let ((string (buffer-substring smtp-read-point (- (point) 2))))
+           (delete-region smtp-read-point (point))
+           (insert (funcall decoder string) "\r\n")))
+      (setq response
+           (nconc response
+                  (list (buffer-substring
+                         (+ 4 smtp-read-point)
+                         (- (point) 2)))))
+      (goto-char
+       (prog1 smtp-read-point
+        (setq smtp-read-point (point))))
+      (if (looking-at "[1-5][0-9][0-9] ")
+         (setq response (cons (read (point-marker)) response)
+               response-continue nil)))
+    response))
+
+(defun smtp-send-command (connection command)
+  (save-excursion
+    (let ((process
+          (smtp-connection-process-internal connection))
+         (encoder
+          (smtp-connection-encoder-internal connection)))
+      (set-buffer (process-buffer process))
+      (goto-char (point-max))
+      (setq command (concat command "\r\n"))
+      (insert command)
+      (setq smtp-read-point (point))
+      (if encoder
+         (setq command (funcall encoder command)))
+      (process-send-string process command))))
+
+(defun smtp-send-data (connection data)
+  (let ((process
+        (smtp-connection-process-internal connection))
+       (encoder
+        (smtp-connection-encoder-internal connection)))
+    ;; Escape "." at start of a line.
+    (if (eq (string-to-char data) ?.)
+       (setq data (concat "." data "\r\n"))
+      (setq data (concat data "\r\n")))
+    (if encoder
+       (setq data (funcall encoder data)))
+    (process-send-string process data)))
+
+(defun smtp-deduce-address-list (smtp-text-buffer header-start header-end)
+  "Get address list suitable for smtp RCPT TO:<address>."
+  (let ((simple-address-list "")
+       this-line
+       this-line-end
+       addr-regexp
+       (smtp-address-buffer (generate-new-buffer " *smtp-mail*")))
+    (unwind-protect
+       (save-excursion
+         ;;
+         (set-buffer smtp-address-buffer)
+         (setq case-fold-search t)
+         (erase-buffer)
+         (insert (save-excursion
+                   (set-buffer smtp-text-buffer)
+                   (buffer-substring-no-properties header-start header-end)))
+         (goto-char (point-min))
+         ;; RESENT-* fields should stop processing of regular fields.
+         (save-excursion
+           (if (re-search-forward "^RESENT-TO:" header-end t)
+               (setq addr-regexp
+                     "^\\(RESENT-TO:\\|RESENT-CC:\\|RESENT-BCC:\\)")
+             (setq addr-regexp  "^\\(TO:\\|CC:\\|BCC:\\)")))
+
+         (while (re-search-forward addr-regexp header-end t)
+           (replace-match "")
+           (setq this-line (match-beginning 0))
+           (forward-line 1)
+           ;; get any continuation lines.
+           (while (and (looking-at "^[ \t]+") (< (point) header-end))
+             (forward-line 1))
+           (setq this-line-end (point-marker))
+           (setq simple-address-list
+                 (concat simple-address-list " "
+                         (mail-strip-quoted-names
+                          (buffer-substring this-line this-line-end)))))
+         (erase-buffer)
+         (insert-string " ")
+         (insert-string simple-address-list)
+         (insert-string "\n")
+         ;; newline --> blank
+         (subst-char-in-region (point-min) (point-max) 10 ?  t)
+         ;; comma   --> blank
+         (subst-char-in-region (point-min) (point-max) ?, ?  t)
+         ;; tab     --> blank
+         (subst-char-in-region (point-min) (point-max)  9 ?  t)
+
+         (goto-char (point-min))
+         ;; tidyness in case hook is not robust when it looks at this
+         (while (re-search-forward "[ \t]+" header-end t) (replace-match " "))
+
+         (goto-char (point-min))
+         (let (recipient-address-list)
+           (while (re-search-forward " \\([^ ]+\\) " (point-max) t)
+             (backward-char 1)
+             (setq recipient-address-list
+                   (cons (buffer-substring (match-beginning 1) (match-end 1))
+                         recipient-address-list)))
+           recipient-address-list))
+      (kill-buffer smtp-address-buffer))))
+
+(provide 'smtp)
+
+;;; smtp.el ends here
diff --git a/mime/emh-comp.el b/mime/emh-comp.el
new file mode 100644 (file)
index 0000000..dcbe6c6
--- /dev/null
@@ -0,0 +1,527 @@
+;;; emh-comp.el --- emh functions for composing messages
+
+;; Copyright (C) 1993,94,95,96,97,98,99,2000 Free Software Foundation, Inc.
+
+;; Author: MORIOKA Tomohiko <tomo@m17n.org>
+;;         OKABE Yasuo <okabe@kudpc.kyoto-u.ac.jp>
+;; Created: 1996/2/29 (separated from tm-mh-e.el)
+;;     Renamed: 1997/2/21 from tmh-comp.el
+;; Keywords: mail composing, MH, MIME, mail
+
+;; This file is part of emh.
+
+;; 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.
+
+;;; Code:
+
+(require 'mh-comp)
+(require 'mime-edit)
+(require 'emh-def)
+
+;; Avoid byte compile warnings.
+;; (defvar gnus-article-buffer)
+;; (defvar gnus-article-copy)
+;; (defvar gnus-original-article-buffer)
+;; (eval-when-compile
+;;   (fset 'gnus-copy-article-buffer 'ignore)
+;;   )
+
+
+;;; @ variable
+;;;
+
+(defvar emh-forwcomps "forwcomps"
+  "Name of file to be used as a skeleton for forwarding messages.
+Default is \"forwcomps\".  If not a complete path name, the file
+is searched for first in the user's MH directory, then in the
+system MH lib directory.")
+
+;; (defvar emh-message-yank-function 'mh-yank-cur-msg)
+
+
+;;; @ for tm-edit
+;;;
+
+(defun emh::make-message (folder number)
+  (vector folder number)
+  )
+
+(defun emh::message/folder (message)
+  (elt message 0)
+  )
+
+(defun emh::message/number (message)
+  (elt message 1)
+  )
+
+(defun emh::message/file-name (message)
+  (expand-file-name
+   (emh::message/number message)
+   (mh-expand-file-name (emh::message/folder message))
+   ))
+
+;;; modified by OKABE Yasuo <okabe@kudpc.kyoto-u.ac.jp>
+;;;    1995/11/14 (cf. [tm-ja:1096])
+(defun emh-prompt-for-message (prompt folder &optional default)
+  (let* ((files
+         (directory-files (mh-expand-file-name folder) nil "^[0-9]+$")
+         )
+        (folder-buf (get-buffer folder))
+        (default
+          (if folder-buf
+              (save-excursion
+                (set-buffer folder-buf)
+                (let* ((show-buffer (get-buffer mh-show-buffer))
+                       (show-buffer-file-name
+                        (buffer-file-name show-buffer)))
+                  (if show-buffer-file-name
+                      (file-name-nondirectory show-buffer-file-name)))))))
+    (if (or (null default)
+           (not (string-match "^[0-9]+$" default)))
+       (setq default
+             (if (and (string= folder mh-sent-from-folder)
+                      mh-sent-from-msg)
+                 (int-to-string mh-sent-from-msg)
+               (save-excursion
+                 (let (cur-msg)
+                   (if (and
+                        (= 0 (mh-exec-cmd-quiet nil "pick" folder "cur"))
+                        (set-buffer mh-temp-buffer)
+                        (setq cur-msg (buffer-string))
+                        (string-match "^[0-9]+$" cur-msg))
+                       (substring cur-msg 0 (match-end 0))
+                     (car files)))))))
+    (completing-read prompt
+                    (let ((i 0))
+                      (mapcar (function
+                               (lambda (file)
+                                 (setq i (+ i 1))
+                                 (list file i)
+                                 ))
+                              files)
+                      ) nil nil default)
+    ))
+
+;;; modified by OKABE Yasuo <okabe@kudpc.kyoto-u.ac.jp>
+;;;    1995/11/14 (cf. [tm-ja:1096])
+(defun emh-query-message (&optional message)
+  (let (folder number)
+    (if message
+       (progn
+         (setq folder (emh::message/folder message))
+         (setq number (emh::message/number message))
+         ))
+    (or (stringp folder)
+       (setq folder (mh-prompt-for-folder
+                     "Message from"
+                     (if (and (stringp mh-sent-from-folder)
+                              (string-match "^\\+" mh-sent-from-folder))
+                         mh-sent-from-folder "+inbox")
+                     nil)))
+    (setq number
+         (if (numberp number)
+             (number-to-string number)
+           (emh-prompt-for-message "Message number: " folder)
+           ))
+    (emh::make-message folder number)
+    ))
+
+(defun emh-insert-message (&optional message)
+  ;; always ignores message
+  ;; (let ((article-buffer
+  ;;        (if (not (and (stringp mh-sent-from-folder)
+  ;;                      (numberp mh-sent-from-msg)
+  ;;                      ))
+  ;;            (cond ((and (boundp 'gnus-original-article-buffer)
+  ;;                        (bufferp mh-sent-from-folder)
+  ;;                        (get-buffer gnus-original-article-buffer)
+  ;;                        )
+  ;;                   gnus-original-article-buffer)
+  ;;                  ((and (boundp 'gnus-article-buffer)
+  ;;                        (get-buffer gnus-article-buffer)
+  ;;                        (bufferp mh-sent-from-folder)
+  ;;                        )
+  ;;                   (save-excursion
+  ;;                     (set-buffer gnus-article-buffer)
+  ;;                     (if (eq major-mode 'mime-view-mode)
+  ;;                         mime-raw-buffer
+  ;;                       (current-buffer)
+  ;;                       )))
+  ;;                  ))))
+  (if (null article-buffer)
+      (emh-insert-mail
+       (emh::make-message mh-sent-from-folder mh-sent-from-msg))
+    ;; (insert-buffer article-buffer)
+    ;; (mime-edit-inserted-message-filter)
+    ;; )
+    ))
+
+(defun emh-insert-mail (&optional message)
+  (save-excursion
+    (save-restriction
+      (let ((message-file
+            (emh::message/file-name (emh-query-message message))))
+       (narrow-to-region (point) (point))
+       (insert-file-contents message-file)
+       (push-mark (point-max))
+       (mime-edit-inserted-message-filter)
+    ))))
+
+(set-alist 'mime-edit-message-inserter-alist
+          'mh-letter-mode (function emh-insert-message))
+(set-alist 'mime-edit-mail-inserter-alist
+          'mh-letter-mode (function emh-insert-mail))
+(set-alist 'mime-edit-mail-inserter-alist
+          'news-reply-mode (function emh-insert-mail))
+(set-alist
+ 'mime-edit-split-message-sender-alist
+ 'mh-letter-mode
+ (function
+  (lambda (&optional arg)
+    (interactive "P")
+    (write-region (point-min) (point-max)
+                 mime-edit-draft-file-name nil 'no-message)
+    (cond (arg
+          (pop-to-buffer "MH mail delivery")
+          (erase-buffer)
+          (mh-exec-cmd-output mh-send-prog t "-watch" "-nopush"
+                              "-nodraftfolder"
+                              mh-send-args
+                              mime-edit-draft-file-name)
+          (goto-char (point-max))      ; show the interesting part
+          (recenter -1)
+          (sit-for 1))
+         (t
+          (apply 'mh-exec-cmd-quiet t mh-send-prog 
+                 (mh-list-to-string
+                  (list "-nopush" "-nodraftfolder"
+                        "-noverbose" "-nowatch"
+                        mh-send-args mime-edit-draft-file-name)))))
+    )))
+
+
+;;; @ commands using tm-edit features
+;;;
+
+(defun emh-edit-again (msg)
+  "Clean-up a draft or a message previously sent and make it resendable.
+Default is the current message.
+The variable mh-new-draft-cleaned-headers specifies the headers to remove.
+See also documentation for `\\[mh-send]' function."
+  (interactive (list (mh-get-msg-num t)))
+  (catch 'tag
+    (let* ((from-folder mh-current-folder)
+          (config (current-window-configuration))
+          (draft
+           (cond ((and mh-draft-folder (equal from-folder mh-draft-folder))
+                  (let ((name (format "draft-%d" msg)))
+                    (if (get-buffer name)
+                        (throw 'tag (pop-to-buffer name))
+                      )
+                    (let ((filename
+                           (mh-msg-filename msg mh-draft-folder)
+                           ))
+                      (set-buffer (get-buffer-create name))
+                      (binary-insert-file-contents filename)
+                      (setq buffer-file-name filename)
+                      )
+                    (pop-to-buffer name)
+                    (if (re-search-forward "^-+$" nil t)
+                        (replace-match "")
+                        )
+                    name))
+                 (t
+                  (let ((flag enable-multibyte-characters)
+                        (coding-system-for-read 'binary))
+                    (prog1
+                        (mh-read-draft "clean-up"
+                                       (mh-msg-filename msg) nil)
+                      (set-buffer-multibyte flag)
+                      ))
+                  ))))
+      (goto-char (point-min))
+      (mh-clean-msg-header (point-min) mh-new-draft-cleaned-headers nil)
+      (let ((cs (detect-coding-region (point-min)(point-max))))
+       (set-buffer-file-coding-system
+        (if (listp cs)
+            (car cs)
+          cs)))
+      (save-buffer)
+      (mime-edit-again nil 'no-separator 'not-turn-on)
+      (goto-char (point-min))
+      (mh-compose-and-send-mail draft "" from-folder nil nil nil nil nil nil
+                               config)
+      )))
+
+;;; by OKABE Yasuo <okabe@kudpc.kyoto-u.ac.jp>
+;;;    1996/2/29 (cf. [tm-ja:1643])
+(defun emh-extract-rejected-mail (msg)
+  "Extract a letter returned by the mail system and make it re-editable.
+Default is the current message.  The variable mh-new-draft-cleaned-headers
+gives the headers to clean out of the original message."
+  (interactive (list (mh-get-msg-num t)))
+  (let ((from-folder mh-current-folder)
+       (config (current-window-configuration))
+       (draft (mh-read-draft "extraction" (mh-msg-filename msg) nil)))
+    (setq buffer-read-only nil)
+    (goto-char (point-min))
+    (cond 
+     ((and
+       (re-search-forward
+       (concat "^\\($\\|[Cc]ontent-[Tt]ype:[ \t]+multipart/\\)") nil t)
+       (not (bolp))
+       (re-search-forward "boundary=\"\\([^\"]+\\)\"" nil t))
+      (let ((case-fold-search t)
+           (boundary (buffer-substring (match-beginning 1) (match-end 1))))
+       (cond
+        ((re-search-forward
+          (concat "^--" boundary "\n"
+                  "content-type:[ \t]+"
+                  "\\(message/rfc822\\|text/rfc822-headers\\)\n"
+                  "\\(.+\n\\)*\n") nil t)
+         (delete-region (point-min) (point))
+         (mh-clean-msg-header (point-min) mh-new-draft-cleaned-headers nil)
+         (search-forward
+          (concat "\n--" boundary "--\n") nil t)
+         (delete-region (match-beginning 0) (point-max)))
+        (t
+         (message "Seems no message/rfc822 part.")))))
+     ((re-search-forward mh-rejected-letter-start nil t)
+      (skip-chars-forward " \t\n")
+      (delete-region (point-min) (point))
+      (mh-clean-msg-header (point-min) mh-new-draft-cleaned-headers nil))
+     (t
+      (message "Does not appear to be a rejected letter.")))
+    (goto-char (point-min))
+    (if (re-search-forward "^-+$" nil t)
+       (replace-match "")
+      )
+    (mime-edit-again nil t t)
+    (goto-char (point-min))
+    (set-buffer-modified-p nil)
+    (mh-compose-and-send-mail draft "" from-folder msg
+                             (mh-get-header-field "To:")
+                             (mh-get-header-field "From:")
+                             (mh-get-header-field "Cc:")
+                             nil nil config)))
+
+;;; by OKABE Yasuo <okabe@kudpc.kyoto-u.ac.jp>
+;;;    1995/11/14 (cf. [tm-ja:1099])
+(defun emh-forward (to cc &optional msg-or-seq)
+  "Forward a message or message sequence as MIME message/rfc822.
+Defaults to displayed message. If optional prefix argument provided,
+then prompt for the message sequence. See also documentation for
+`\\[mh-send]' function."
+  (interactive (list (mh-read-address "To: ")
+                    (mh-read-address "Cc: ")
+                    (if current-prefix-arg
+                        (mh-read-seq-default "Forward" t)
+                      (mh-get-msg-num t)
+                      )))
+  (or msg-or-seq
+      (setq msg-or-seq (mh-get-msg-num t)))
+  (let* ((folder mh-current-folder)
+        (config (current-window-configuration))
+        ;; uses "draft" for compatibility with forw.
+        ;; forw always leaves file in "draft" since it doesn't have -draft
+        (draft-name (expand-file-name "draft" mh-user-path))
+        (draft (cond ((or (not (file-exists-p draft-name))
+                          (y-or-n-p "The file `draft' exists.  Discard it? "))
+                      (mh-exec-cmd "comp"
+                                   "-noedit" "-nowhatnowproc"
+                                   "-form" emh-forwcomps
+                                   "-nodraftfolder")
+                      (prog1
+                          (mh-read-draft "" draft-name t)
+                        (mh-insert-fields "To:" to "Cc:" cc)
+                        (set-buffer-modified-p nil)))
+                     (t
+                      (mh-read-draft "" draft-name nil)))))
+    (let ((tag-regexp
+          (concat "^" (regexp-quote (mime-make-tag "message" "rfc822"))))
+         orig-from orig-subject multipart-flag)
+      (goto-char (point-min))
+      (save-excursion
+       (save-restriction
+         (goto-char (point-max))
+         (if (not (bolp)) (insert "\n"))
+         (let ((beg (point)))
+           (narrow-to-region beg beg)
+           (mh-exec-cmd-output "pick" nil folder msg-or-seq)
+           (if (> (count-lines (point) (point-max)) 1)
+               (setq multipart-flag t)
+             )
+           (while (re-search-forward "^\\([0-9]+\\)\n" nil t)
+             (let ((forw-msg
+                    (buffer-substring (match-beginning 1) (match-end 1)))
+                   (beg (match-beginning 0))
+                   (end (match-end 0))
+                   )
+               (save-restriction
+                 (narrow-to-region beg end)
+                 ;; modified for Emacs 18
+                 (delete-region beg end)
+                 (insert-file-contents
+                  (mh-expand-file-name forw-msg
+                                       (mh-expand-file-name folder))
+                  )
+                 (save-excursion
+                   (push-mark (point-max))
+                   (mime-edit-inserted-message-filter))
+                 (goto-char (point-max))
+                 )
+               (save-excursion
+                 (goto-char beg)
+                 (mime-edit-insert-tag "message" "rfc822")
+                 )))
+           (delete-region (point) (point-max))
+           (if multipart-flag
+               (mime-edit-enclose-digest-region beg (point))
+             ))))
+      (re-search-forward tag-regexp)
+      (forward-line 1)
+      (save-restriction
+       (narrow-to-region (point) (point-max))
+       (setq orig-from (eword-decode-string
+                        (mh-get-header-field "From:")))
+       (setq orig-subject (eword-decode-string
+                           (mh-get-header-field "Subject:")))
+       )
+      (let ((forw-subject
+            (mh-forwarded-letter-subject orig-from orig-subject)))
+       (mh-insert-fields "Subject:" forw-subject)
+       (goto-char (point-min))
+       (re-search-forward tag-regexp)
+       (forward-line -1)
+       (delete-other-windows)
+       (if (numberp msg-or-seq)
+           (mh-add-msgs-to-seq msg-or-seq 'forwarded t)
+         (mh-add-msgs-to-seq (mh-seq-to-msgs msg-or-seq) 'forwarded t))
+       (mh-compose-and-send-mail draft "" folder msg-or-seq
+                                 to forw-subject cc
+                                 mh-note-forw "Forwarded:"
+                                 config)))))
+
+(cond ((not (featurep 'mh-utils))
+       (defun emh::insert-letter (folder number verbatim)
+        (mh-insert-letter verbatim folder number)
+        )
+       )
+      ((and (boundp 'mh-e-version)
+           (string-lessp mh-e-version "5"))
+       (defun emh::insert-letter (folder number verbatim)
+        (mh-insert-letter number folder verbatim)
+        )
+       )
+      (t
+       (defalias 'emh::insert-letter 'mh-insert-letter)
+       ))
+
+(defun emh-insert-letter (verbatim)
+  "Interface to mh-insert-letter."
+  (interactive "P")
+  (let*
+      ((folder (mh-prompt-for-folder
+               "Message from"
+               (if (and (stringp mh-sent-from-folder)
+                        (string-match "^\\+" mh-sent-from-folder))
+                   mh-sent-from-folder "+inbox")
+               nil))
+       (number (emh-prompt-for-message "Message number: " folder)))
+    (emh::insert-letter folder number verbatim)))
+
+;; (defun emh-yank-cur-msg-with-no-filter ()
+;;   "Insert the current message into the draft buffer.
+;; This function makes new show-buffer from article-buffer to disable
+;; variable `mime-preview-text/plain-hook'. If you don't want to use text
+;; filters for replying message, please set it to
+;; `emh-message-yank-function'.
+;; Prefix each non-blank line in the message with the string in
+;; `mh-ins-buf-prefix'. The entire message will be inserted if
+;; `mh-yank-from-start-of-msg' is non-nil. If this variable is nil, the
+;; portion of the message following the point will be yanked.  If
+;; `mh-delete-yanked-msg-window' is non-nil, any window displaying the
+;; yanked message will be deleted."
+;;   (interactive)
+;;   (if (and mh-sent-from-folder mh-sent-from-msg)
+;;       (let ((to-point (point))
+;;             (to-buffer (current-buffer)))
+;;         (set-buffer mh-sent-from-folder)
+;;         (if mh-delete-yanked-msg-window
+;;             (delete-windows-on mh-show-buffer))
+;;         (set-buffer mh-show-buffer)     ; Find displayed message
+;;         (let ((mh-ins-str
+;;                (if mime-raw-buffer
+;;                    (let (mime-display-text/plain-hook buf)
+;;                      (prog1
+;;                          (save-window-excursion
+;;                            (set-buffer mime-raw-buffer)
+;;                            (setq buf (mime-view-mode))
+;;                            (buffer-string)
+;;                            )
+;;                        (kill-buffer buf)
+;;                        ))
+;;                  (buffer-string)
+;;                  )))
+;;           (set-buffer to-buffer)
+;;           (save-restriction
+;;             (narrow-to-region to-point to-point)
+;;             (push-mark)
+;;             (insert mh-ins-str)
+;;             (mh-insert-prefix-string mh-ins-buf-prefix)
+;;             (insert "\n"))))
+;;     (error "There is no current message")))
+
+;; (defun emh-yank-current-message ()
+;;   "Insert the current message into the draft buffer.
+;; It uses variable `emh-message-yank-function'
+;; to select message yanking function."
+;;   (interactive)
+;;   (let ((mh-sent-from-folder mh-sent-from-folder)
+;;         (mh-sent-from-msg mh-sent-from-msg))
+;;     (if (and (not (stringp mh-sent-from-folder))
+;;              (boundp 'gnus-article-buffer)
+;;              (get-buffer gnus-article-buffer)
+;;              (bufferp mh-sent-from-folder)
+;;              ) ; might be called from GNUS
+;;         (if (boundp 'gnus-article-copy) ; might be sgnus
+;;             (save-excursion
+;;               (gnus-copy-article-buffer)
+;;               (setq mh-sent-from-folder gnus-article-copy)
+;;               (set-buffer mh-sent-from-folder)
+;;               (setq mh-show-buffer gnus-article-copy)
+;;               )
+;;           (save-excursion
+;;             (setq mh-sent-from-folder gnus-article-buffer)
+;;             (set-buffer gnus-article-buffer)
+;;             (setq mh-show-buffer (current-buffer))
+;;             )))
+;;     (funcall emh-message-yank-function)
+;;     ))
+
+;; (substitute-key-definition
+;;  'mh-yank-cur-msg 'emh-yank-current-message mh-letter-mode-map)
+;; (substitute-key-definition
+;;  'mh-insert-letter 'emh-insert-letter mh-letter-mode-map)
+
+
+;;; @ end
+;;;
+
+(provide 'emh-comp)
+(require 'emh)
+
+;;; emh-comp.el ends here
diff --git a/mime/emh-def.el b/mime/emh-def.el
new file mode 100644 (file)
index 0000000..cf80a48
--- /dev/null
@@ -0,0 +1,41 @@
+;;; emh-def.el --- definition for emh
+
+;; Copyright (C) 2000 Free Software Foundation, Inc.
+
+;; Author: MORIOKA Tomohiko <tomo@m17n.org>
+;; Keywords: mail composing, MH, MIME, mail
+
+;; This file is part of emh.
+
+;; 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.
+
+;;; Code:
+
+(or (fboundp 'find-face)
+    (defun find-face (face-or-name)
+      "Retrieve the face of the given name.
+If FACE-OR-NAME is a face object, it is simply returned.
+Otherwise, FACE-OR-NAME should be a symbol.  If there is no such face,
+nil is returned.  Otherwise the associated face object is returned."
+      (car (memq face-or-name (face-list)))))
+
+
+;;; @ end
+;;;
+
+(provide 'emh-def)
+
+;;; emh-def.el ends here
diff --git a/mime/emh-face.el b/mime/emh-face.el
new file mode 100644 (file)
index 0000000..f37af61
--- /dev/null
@@ -0,0 +1,156 @@
+;;; emh-face.el --- header highlighting in emh.
+
+;; Copyright (C) 1997,2000 Free Software Foundation, Inc.
+
+;; Author: MORIOKA Tomohiko <tomo@m17n.org>
+;; Created: 1997/3/4
+;; Keywords: header, highlighting
+
+;; This file is part of emh.
+
+;; 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.
+
+;;; Code:
+
+(require 'emh-def)
+(require 'std11)
+
+(defsubst emh-set-face-foreground (face color)
+  (condition-case nil
+      (set-face-foreground face color)
+    (error (message "Color `%s' is not found." color))))
+
+(defsubst emh-make-face-bold (face)
+  (set-face-font face (face-font 'bold)))
+
+(defsubst emh-make-face-italic (face)
+  (set-face-font face (face-font 'italic)))
+
+(or (find-face 'from-field-body)
+    (progn
+      (make-face 'from-field-body)
+      (emh-set-face-foreground 'from-field-body "dark slate blue")
+      (emh-make-face-bold 'from-field-body)
+      ))
+
+(or (find-face 'subject-field-body)
+    (progn
+      (make-face 'subject-field-body)
+      (emh-set-face-foreground 'subject-field-body "violet red")
+      (emh-make-face-bold 'subject-field-body)
+      ))
+
+(or (find-face 'to-field-body)
+    (progn
+      (make-face 'to-field-body)
+      (emh-set-face-foreground 'to-field-body "red")
+      (emh-make-face-bold 'to-field-body)
+      ))
+
+(or (find-face 'cc-field-body)
+    (progn
+      (make-face 'cc-field-body)
+      (emh-set-face-foreground 'cc-field-body "salmon")
+      (emh-make-face-bold 'cc-field-body)
+      ))
+
+(or (find-face 'reply-to-field-body)
+    (progn
+      (make-face 'reply-to-field-body)
+      (emh-set-face-foreground 'reply-to-field-body "salmon")
+      (emh-make-face-bold 'reply-to-field-body)
+      ))
+
+(or (find-face '-to-field-body)
+    (progn
+      (make-face '-to-field-body)
+      (emh-set-face-foreground '-to-field-body "red")
+      ))
+
+(or (find-face 'date-field-body)
+    (progn
+      (make-face 'date-field-body)
+      (emh-set-face-foreground 'date-field-body "blue violet")
+      (emh-make-face-bold 'date-field-body)
+      ))
+
+(or (find-face 'message-id-field-body)
+    (progn
+      (make-face 'message-id-field-body)
+      (emh-set-face-foreground 'message-id-field-body "royal blue")
+      (emh-make-face-bold 'message-id-field-body)
+      ))
+
+(or (find-face 'field-body)
+    (progn
+      (make-face 'field-body)
+      (emh-set-face-foreground 'field-body "dark green")
+      (emh-make-face-italic 'field-body)
+      ))
+
+(or (find-face 'field-name)
+    (progn
+      (make-face 'field-name)
+      (emh-set-face-foreground 'field-name "dark green")
+      (emh-make-face-bold 'field-name)
+      ))
+
+(defvar emh-header-face
+  '(("^From:"          field-name      from-field-body)
+    ("^Subject:"       field-name      subject-field-body)
+    ("^To:"            field-name      to-field-body)
+    ("^cc:"            field-name      cc-field-body)
+    ("^Reply-To:"      field-name      reply-to-field-body)
+    ("^.+-To:"         field-name      -to-field-body)
+    ("^Date:"          field-name      date-field-body)
+    ("^Message-Id:"    field-name      message-id-field-body)
+    (t                 field-name      field-body)
+    ))
+
+(defun emh-highlight-header ()
+  (goto-char (point-min))
+  (while (looking-at "^[^:]+:")
+    (let* ((beg (match-beginning 0))
+          (med (match-end 0))
+          (end (std11-field-end))
+          (field-name (buffer-substring beg med))
+          (rule (catch 'found
+                  (let ((rest emh-header-face))
+                    (while rest
+                      (let* ((rule (car rest))
+                             (key (car rule)))
+                        (if (and (stringp key)
+                                 (string-match key field-name))
+                            (throw 'found (cdr rule))
+                          ))
+                      (setq rest (cdr rest))
+                      )
+                    (cdr (assq t emh-header-face))
+                    )))
+          )
+      (overlay-put (make-overlay beg med) 'face (car rule))
+      (overlay-put (make-overlay med end) 'face (cadr rule))
+      )
+    (forward-char)
+    ))
+
+
+;;; @ end
+;;;
+
+(provide 'emh-face)
+
+;;; emh-face.el ends here
diff --git a/mime/emh-setup.el b/mime/emh-setup.el
new file mode 100644 (file)
index 0000000..5e64f05
--- /dev/null
@@ -0,0 +1,97 @@
+;;; emh-setup.el --- setup file for emh.
+
+;; Copyright (C) 1994,1995,1996,1997,1998 Free Software Foundation, Inc.
+
+;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
+;; Keywords: mh-e, mail, news, MIME, multimedia, multilingual
+
+;; This file is part of emh.
+
+;; 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.
+
+;;; Code:
+
+(require 'semi-setup)
+
+
+;;; @ for emh
+;;;
+
+(eval-after-load "mh-e" '(require 'emh))
+
+
+;;; @ for mime-edit
+;;;
+
+(autoload 'turn-on-mime-edit "mime-edit"
+  "Unconditionally turn on MIME-Edit minor mode." t)
+
+(defun emh-setup-mh-draft-setting ()
+  (make-local-variable 'mail-header-separator)
+  (setq mail-header-separator "--------")
+  (mime-decode-header-in-buffer nil mail-header-separator)
+  (let ((ua mime-edit-user-agent-value))
+    (make-local-variable 'mime-edit-user-agent-value)
+    (setq mime-edit-user-agent-value (concat "EMH/" emh-version " " ua))
+    )
+  (turn-on-mime-edit)
+  (save-excursion
+    (goto-char (point-min))
+    (setq buffer-read-only nil)
+    (if (re-search-forward "^-*$" nil t)
+       (progn
+         (replace-match mail-header-separator)
+         (set-buffer-modified-p (buffer-modified-p))
+         ))
+    ))
+
+(add-hook 'mh-letter-mode-hook 'emh-setup-mh-draft-setting t)
+(add-hook 'mh-before-send-letter-hook 'mime-edit-maybe-translate)
+
+
+;;; @@ for emh-comp.el
+;;;
+
+(autoload 'emh-edit-again "emh-comp"
+  "Clean-up a draft or a message previously sent and make it resendable." t)
+(autoload 'emh-extract-rejected-mail "emh-comp"
+  "Extract a letter returned by the mail system and make it re-editable." t)
+(autoload 'emh-forward "emh-comp"
+  "Forward a message or message sequence by MIME style." t)
+
+(eval-after-load
+    "mh-e"
+  '(progn
+     (substitute-key-definition
+      'mh-edit-again 'emh-edit-again
+      mh-folder-mode-map)
+     (substitute-key-definition
+      'mh-extract-rejected-mail 'emh-extract-rejected-mail
+      mh-folder-mode-map)
+     (substitute-key-definition
+      'mh-forward 'emh-forward
+      mh-folder-mode-map)
+     ))
+
+(eval-after-load "mh-comp" '(require 'emh-comp))
+
+
+;;; @ end
+;;;
+
+(provide 'emh-setup)
+
+;;; emh-setup.el ends here
diff --git a/mime/emh.el b/mime/emh.el
new file mode 100644 (file)
index 0000000..2da4435
--- /dev/null
@@ -0,0 +1,355 @@
+;;; emh.el --- MIME extender for mh-e
+
+;; Copyright (C) 1995,1996,1997,1998,2000 Free Software Foundation, Inc.
+
+;; Author: MORIOKA Tomohiko <tomo@m17n.org>
+;;         OKABE Yasuo <okabe@kudpc.kyoto-u.ac.jp>
+;; Maintainer: MORIOKA Tomohiko <tomo@m17n.org>
+;; Created: 1993/11/21
+;;     Renamed: 1993/11/27 from mh-e-mime.el
+;;     Renamed: 1997/02/21 from tm-mh-e.el
+;; Keywords: MH, MIME, multimedia, encoded-word, multilingual, mail
+
+;; This file is part of emh.
+
+;; 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.
+
+;;; Code:
+
+(require 'mh-e)
+(require 'alist)
+(require 'mime-view)
+
+
+;;; @ version
+;;;
+
+(defconst emh-version "1.14.1")
+
+
+;;; @ variable
+;;;
+
+(defgroup emh nil
+  "MIME Extension for mh-e"
+  :group 'mime
+  :group 'mh)
+
+(defcustom emh-automatic-mime-preview t
+  "*If non-nil, show MIME processed message."
+  :group 'emh
+  :type 'boolean)
+
+(defcustom emh-decode-encoded-word t
+  "*If non-nil, decode encoded-word when it is not MIME preview mode."
+  :group 'emh
+  :type 'boolean)
+
+
+;;; @ functions
+;;;
+
+(defsubst emh-raw-buffer (folder-buffer)
+  (concat "article-" (if (bufferp folder-buffer)
+                        (buffer-name folder-buffer)
+                      folder-buffer)))
+
+(defun mh-display-msg (msg-num folder &optional show-buffer mode)
+  "Display message number MSG-NUM of FOLDER.
+This function uses `mime-view-mode' if MODE is not nil.  If MODE is
+nil, `emh-automatic-mime-preview' is used as default value."
+  (or mode
+      (setq mode emh-automatic-mime-preview)
+      )
+  ;; Display message NUMBER of FOLDER.
+  ;; Sets the current buffer to the show buffer.
+  (set-buffer folder)
+  (or show-buffer
+      (setq show-buffer mh-show-buffer))
+  ;; Bind variables in folder buffer in case they are local
+  (let ((msg-filename (mh-msg-filename msg-num)))
+    (if (not (file-exists-p msg-filename))
+       (error "Message %d does not exist" msg-num))
+    (set-buffer show-buffer)
+    (cond ((not (equal msg-filename buffer-file-name))
+          ;; Buffer does not yet contain message.
+          (clear-visited-file-modtime)
+          (unlock-buffer)
+          (setq buffer-file-name nil)  ; no locking during setup
+          (setq buffer-read-only nil)
+          (erase-buffer)
+          (if mode
+              (let* ((aname (emh-raw-buffer folder))
+                     (abuf (get-buffer aname)))
+                (if abuf
+                    (progn
+                      (set-buffer abuf)
+                      (setq buffer-read-only nil)
+                      (erase-buffer))
+                  (setq abuf (get-buffer-create aname))
+                  (set-buffer abuf)
+                  (set-buffer-multibyte nil))
+                (8bit-insert-encoded-file msg-filename)
+                (set-buffer-modified-p nil)
+                (setq buffer-read-only t)
+                (setq buffer-file-name msg-filename)
+                (mh-show-mode)
+                (mime-display-message (mime-open-entity 'buffer aname)
+                                      (concat "show-" folder))
+                (goto-char (point-min)))
+            (let ((clean-message-header mh-clean-message-header)
+                  (invisible-headers mh-invisible-headers)
+                  (visible-headers mh-visible-headers))
+              ;; 1995/9/21
+              ;;   modified by ARIURA <ariura@cc.tuat.ac.jp>
+              ;;   to support mhl.
+              (if mhl-formfile
+                  (mh-exec-lib-cmd-output "mhl" "-nobell" "-noclear"
+                                          (if (stringp mhl-formfile)
+                                              (list "-form" mhl-formfile))
+                                          msg-filename)
+                (insert-file-contents msg-filename))
+              ;; end
+              (goto-char (point-min))
+              (cond (clean-message-header
+                     (mh-clean-msg-header (point-min)
+                                          invisible-headers
+                                          visible-headers)
+                     (goto-char (point-min)))
+                    (t
+                     (mh-start-of-uncleaned-message)))
+              (if emh-decode-encoded-word
+                  (mime-decode-header-in-buffer))
+              (set-buffer-modified-p nil)
+              (setq buffer-read-only t)
+              (setq buffer-file-name msg-filename)
+              (mh-show-mode)
+              ))
+          (or (eq buffer-undo-list t)  ;don't save undo info for prev msgs
+              (setq buffer-undo-list nil))
+;;; Added by itokon (02/19/96)
+          (setq buffer-file-name msg-filename)
+;;;
+          (set-mark nil)
+          (setq mode-line-buffer-identification
+                (list (format mh-show-buffer-mode-line-buffer-id
+                              folder msg-num)))
+          (set-buffer folder)
+          (setq mh-showing-with-headers nil)))))
+
+(defun emh-view-message (&optional msg)
+  "MIME decode and play this message."
+  (interactive)
+  (if (or (null emh-automatic-mime-preview)
+         (null (get-buffer mh-show-buffer))
+         (save-excursion
+           (set-buffer mh-show-buffer)
+           (not (eq major-mode 'mime-view-mode))
+           ))
+      (let ((emh-automatic-mime-preview t))
+       (mh-invalidate-show-buffer)
+       (mh-show-msg msg)
+       ))
+  (pop-to-buffer mh-show-buffer)
+  )
+
+(defun emh-toggle-decoding-mode (arg)
+  "Toggle MIME processing mode.
+With arg, turn MIME processing on if arg is positive."
+  (interactive "P")
+  (setq emh-automatic-mime-preview
+       (if (null arg)
+           (not emh-automatic-mime-preview)
+         arg))
+  (let ((raw-buffer (emh-raw-buffer (current-buffer))))
+    (if (get-buffer raw-buffer)
+       (kill-buffer raw-buffer)
+      ))
+  (mh-invalidate-show-buffer)
+  (mh-show (mh-get-msg-num t))
+  )
+
+(defun emh-show (&optional message)
+  (interactive)
+  (mh-invalidate-show-buffer)
+  (mh-show message)
+  )
+
+(defun emh-header-display ()
+  (interactive)
+  (mh-invalidate-show-buffer)
+  (let (mime-view-ignored-field-list
+       mime-view-visible-field-list
+       emh-decode-encoded-word)
+    (mh-header-display)
+    ))
+
+(defun emh-raw-display ()
+  (interactive)
+  (mh-invalidate-show-buffer)
+  (let (emh-automatic-mime-preview
+       emh-decode-encoded-word)
+    (mh-header-display)
+    ))
+
+(defun emh-burst-multipart/digest ()
+  "Burst apart the current message, which should be a multipart/digest.
+The message is replaced by its table of contents and the letters from the
+digest are inserted into the folder after that message."
+  (interactive)
+  (let ((digest (mh-get-msg-num t)))
+    (mh-process-or-undo-commands mh-current-folder)
+    (mh-set-folder-modified-p t)               ; lock folder while bursting
+    (message "Bursting digest...")
+    (mh-exec-cmd "mhn" "-store" mh-current-folder digest)
+    (mh-scan-folder mh-current-folder (format "%d-last" mh-first-msg-num))
+    (message "Bursting digest...done")
+    ))
+
+
+;;; @ for mime-view
+;;;
+
+(defvar emh-display-header-hook (if window-system '(emh-highlight-header))
+  "Hook for header filtering.")
+
+(autoload 'emh-highlight-header "emh-face")
+
+(defun emh-header-presentation-method (entity situation)
+  (mime-insert-header entity
+                     mime-view-ignored-field-list
+                     mime-view-visible-field-list)
+  (run-hooks 'emh-display-header-hook)
+  )
+
+(set-alist 'mime-header-presentation-method-alist
+          'mh-show-mode #'emh-header-presentation-method)
+
+
+(defun emh-quitting-method ()
+  (let ((buf (current-buffer)))
+    (mime-maybe-hide-echo-buffer)
+    (pop-to-buffer
+     (let ((name (buffer-name buf)))
+       (substring name 5)
+       ))
+    (if (not emh-automatic-mime-preview)
+       (mh-invalidate-show-buffer)
+      )
+    (mh-show (mh-get-msg-num t))
+    ))
+
+(set-alist 'mime-preview-quitting-method-alist
+          'mh-show-mode #'emh-quitting-method)
+
+
+(defun emh-following-method (buf)
+  (save-excursion
+    (set-buffer buf)
+    (goto-char (point-max))
+    (setq mh-show-buffer buf)
+    (apply (function mh-send)
+          (std11-field-bodies '("From" "cc" "Subject") ""))
+    (setq mh-sent-from-folder buf)
+    (setq mh-sent-from-msg 1)
+    (let ((last (point)))
+      (mh-yank-cur-msg)
+      (goto-char last)
+      )))
+
+(set-alist 'mime-preview-following-method-alist
+          'mh-show-mode #'emh-following-method)
+
+
+;;; @@ for mime-partial
+;;;
+
+(defun emh-request-partial-message ()
+  (let ((msg-filename (mh-msg-filename (mh-get-msg-num t)))
+       (show-buffer mh-show-buffer))
+    (set-buffer (get-buffer-create " *Partial Article*"))
+    (erase-buffer)
+    (setq mime-preview-buffer show-buffer)
+    (raw-text-insert-file-contents msg-filename)
+    (mime-parse-buffer)
+    ))
+
+(defun emh-get-folder-buffer ()
+  (let ((buffer-name (buffer-name (current-buffer))))
+    (and (or (string-match "^article-\\(.+\\)$" buffer-name)
+            (string-match "^show-\\(.+\\)$" buffer-name))
+        (substring buffer-name
+                   (match-beginning 1) (match-end 1))
+        )))
+
+(autoload 'mime-combine-message/partial-pieces-automatically
+  "mime-partial"
+  "Internal method to combine message/partial messages automatically.")
+
+(mime-add-condition
+ 'action
+ '((type . message)(subtype . partial)
+   (major-mode . mh-show-mode)
+   (method . mime-combine-message/partial-pieces-automatically)
+   (summary-buffer-exp . (emh-get-folder-buffer))
+   (request-partial-message-method . emh-request-partial-message)
+   ))
+
+
+;;; @ set up
+;;;
+
+(define-key mh-folder-mode-map "v" (function emh-view-message))
+(define-key mh-folder-mode-map "\et" (function emh-toggle-decoding-mode))
+(define-key mh-folder-mode-map "." (function emh-show))
+(define-key mh-folder-mode-map "," (function emh-header-display))
+(define-key mh-folder-mode-map "\e," (function emh-raw-display))
+(define-key mh-folder-mode-map "\C-c\C-b"
+  (function emh-burst-multipart/digest))
+
+(defun emh-summary-before-quit ()
+  (let ((buf (get-buffer mh-show-buffer)))
+    (if buf
+       (let ((the-buf (current-buffer)))
+         (switch-to-buffer buf)
+         (if (and mime-preview-buffer
+                  (setq buf (get-buffer mime-preview-buffer))
+                  )
+             (progn
+               (switch-to-buffer the-buf)
+               (kill-buffer buf)
+               )
+           (switch-to-buffer the-buf)
+           )
+         ))))
+
+(add-hook 'mh-before-quit-hook (function emh-summary-before-quit))
+
+
+;;; @ for BBDB
+;;;
+
+(eval-after-load "bbdb" '(require 'mime-bbdb))
+
+
+;;; @ end
+;;;
+
+(provide 'emh)
+
+(run-hooks 'emh-load-hook)
+
+;;; emh.el ends here
diff --git a/mime/eword-decode.el b/mime/eword-decode.el
new file mode 100644 (file)
index 0000000..0fc7d33
--- /dev/null
@@ -0,0 +1,823 @@
+;;; eword-decode.el --- RFC 2047 based encoded-word decoder for GNU Emacs
+
+;; Copyright (C) 1995,1996,1997,1998,1999,2000 Free Software Foundation, Inc.
+
+;; Author: ENAMI Tsugutomo <enami@sys.ptg.sony.co.jp>
+;;         MORIOKA Tomohiko <tomo@m17n.org>
+;;         TANAKA Akira <akr@m17n.org>
+;; Created: 1995/10/03
+;; Original: 1992/07/20 ENAMI Tsugutomo's `mime.el'.
+;;     Renamed: 1993/06/03 to tiny-mime.el by MORIOKA Tomohiko
+;;     Renamed: 1995/10/03 to tm-ew-d.el (split off encoder)
+;;               by MORIOKA Tomohiko
+;;     Renamed: 1997/02/22 from tm-ew-d.el by MORIOKA Tomohiko
+;; Keywords: encoded-word, MIME, multilingual, header, mail, news
+
+;; This file is part of FLIM (Faithful Library about Internet Message).
+
+;; 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.
+
+;;; Code:
+
+(require 'mime-def)
+(require 'mel)
+(require 'std11)
+
+(eval-when-compile (require 'cl))      ; list*, pop
+
+
+;;; @ Variables
+;;;
+
+;; User options are defined in mime-def.el.
+
+
+;;; @ MIME encoded-word definition
+;;;
+
+(eval-and-compile
+  (defconst eword-encoded-text-regexp "[!->@-~]+")
+
+  (defconst eword-encoded-word-regexp
+    (eval-when-compile
+      (concat (regexp-quote "=?")
+             "\\("
+             mime-charset-regexp
+             "\\)"
+             (regexp-quote "?")
+             "\\([BbQq]\\)"
+             (regexp-quote "?")
+             "\\("
+             eword-encoded-text-regexp
+             "\\)"
+             (regexp-quote "?="))))
+  )
+
+
+;;; @ for string
+;;;
+
+(defun eword-decode-string (string &optional must-unfold)
+  "Decode MIME encoded-words in STRING.
+
+STRING is unfolded before decoding.
+
+If an encoded-word is broken or your emacs implementation can not
+decode the charset included in it, it is not decoded.
+
+If MUST-UNFOLD is non-nil, it unfolds and eliminates line-breaks even
+if there are in decoded encoded-words (generated by bad manner MUA
+such as a version of Net$cape)."
+  (setq string (std11-unfold-string string))
+  (let ((dest "")(ew nil)
+       beg end)
+    (while (and (string-match eword-encoded-word-regexp string)
+               (setq beg (match-beginning 0)
+                     end (match-end 0))
+               )
+      (if (> beg 0)
+         (if (not
+              (and (eq ew t)
+                   (string-match "^[ \t]+$" (substring string 0 beg))
+                   ))
+             (setq dest (concat dest (substring string 0 beg)))
+           )
+       )
+      (setq dest
+           (concat dest
+                   (eword-decode-encoded-word
+                    (substring string beg end) must-unfold)
+                   ))
+      (setq string (substring string end))
+      (setq ew t)
+      )
+    (concat dest string)
+    ))
+
+(defun eword-decode-structured-field-body (string
+                                          &optional start-column max-column
+                                          start)
+  (let ((tokens (eword-lexical-analyze string start 'must-unfold))
+       (result "")
+       token)
+    (while tokens
+      (setq token (car tokens))
+      (setq result (concat result (eword-decode-token token)))
+      (setq tokens (cdr tokens)))
+    result))
+
+(defun eword-decode-and-unfold-structured-field-body (string
+                                                     &optional
+                                                     start-column
+                                                     max-column
+                                                     start)
+  "Decode and unfold STRING as structured field body.
+It decodes non us-ascii characters in FULL-NAME encoded as
+encoded-words or invalid \"raw\" string.  \"Raw\" non us-ascii
+characters are regarded as variable `default-mime-charset'.
+
+If an encoded-word is broken or your emacs implementation can not
+decode the charset included in it, it is not decoded."
+  (let ((tokens (eword-lexical-analyze string start 'must-unfold))
+       (result ""))
+    (while tokens
+      (let* ((token (car tokens))
+            (type (car token)))
+       (setq tokens (cdr tokens))
+       (setq result
+             (if (eq type 'spaces)
+                 (concat result " ")
+               (concat result (eword-decode-token token))
+               ))))
+    result))
+
+(defun eword-decode-and-fold-structured-field-body (string
+                                                   start-column
+                                                   &optional max-column
+                                                   start)
+  (if (and mime-field-decoding-max-size
+          (> (length string) mime-field-decoding-max-size))
+      string
+    (or max-column
+       (setq max-column fill-column))
+    (let ((c start-column)
+         (tokens (eword-lexical-analyze string start 'must-unfold))
+         (result "")
+         token)
+      (while (and (setq token (car tokens))
+                 (setq tokens (cdr tokens)))
+       (let* ((type (car token)))
+         (if (eq type 'spaces)
+             (let* ((next-token (car tokens))
+                    (next-str (eword-decode-token next-token))
+                    (next-len (string-width next-str))
+                    (next-c (+ c next-len 1)))
+               (if (< next-c max-column)
+                   (setq result (concat result " " next-str)
+                         c next-c)
+                 (setq result (concat result "\n " next-str)
+                       c (1+ next-len)))
+               (setq tokens (cdr tokens))
+               )
+           (let* ((str (eword-decode-token token)))
+             (setq result (concat result str)
+                   c (+ c (string-width str)))
+             ))))
+      (if token
+         (concat result (eword-decode-token token))
+       result))))
+
+(defun eword-decode-unstructured-field-body (string &optional start-column
+                                                   max-column)
+  (eword-decode-string
+   (decode-mime-charset-string string default-mime-charset)))
+
+(defun eword-decode-and-unfold-unstructured-field-body (string
+                                                       &optional start-column
+                                                       max-column)
+  (eword-decode-string
+   (decode-mime-charset-string (std11-unfold-string string)
+                              default-mime-charset)
+   'must-unfold))
+
+(defun eword-decode-unfolded-unstructured-field-body (string
+                                                     &optional start-column
+                                                     max-column)
+  (eword-decode-string
+   (decode-mime-charset-string string default-mime-charset)
+   'must-unfold))
+
+
+;;; @ for region
+;;;
+
+(defun eword-decode-region (start end &optional unfolding must-unfold)
+  "Decode MIME encoded-words in region between START and END.
+
+If UNFOLDING is not nil, it unfolds before decoding.
+
+If MUST-UNFOLD is non-nil, it unfolds and eliminates line-breaks even
+if there are in decoded encoded-words (generated by bad manner MUA
+such as a version of Net$cape)."
+  (interactive "*r")
+  (save-excursion
+    (save-restriction
+      (narrow-to-region start end)
+      (if unfolding
+         (eword-decode-unfold)
+       )
+      (goto-char (point-min))
+      (while (re-search-forward (concat "\\(" eword-encoded-word-regexp "\\)"
+                                        "\\(\n?[ \t]\\)+"
+                                        "\\(" eword-encoded-word-regexp "\\)")
+                                nil t)
+       (replace-match "\\1\\6")
+        (goto-char (point-min))
+       )
+      (while (re-search-forward eword-encoded-word-regexp nil t)
+       (insert (eword-decode-encoded-word
+                (prog1
+                    (buffer-substring (match-beginning 0) (match-end 0))
+                  (delete-region (match-beginning 0) (match-end 0))
+                  ) must-unfold))
+       )
+      )))
+
+(defun eword-decode-unfold ()
+  (goto-char (point-min))
+  (let (field beg end)
+    (while (re-search-forward std11-field-head-regexp nil t)
+      (setq beg (match-beginning 0)
+            end (std11-field-end))
+      (setq field (buffer-substring beg end))
+      (if (string-match eword-encoded-word-regexp field)
+          (save-restriction
+            (narrow-to-region (goto-char beg) end)
+            (while (re-search-forward "\n\\([ \t]\\)" nil t)
+              (replace-match (match-string 1))
+              )
+           (goto-char (point-max))
+           ))
+      )))
+
+
+;;; @ for message header
+;;;
+
+(defvar mime-field-decoder-alist nil)
+
+(defvar mime-field-decoder-cache nil)
+
+(defvar mime-update-field-decoder-cache 'mime-update-field-decoder-cache
+  "*Field decoder cache update function.")
+
+;;;###autoload
+(defun mime-set-field-decoder (field &rest specs)
+  "Set decoder of FIELD.
+SPECS must be like `MODE1 DECODER1 MODE2 DECODER2 ...'.
+Each mode must be `nil', `plain', `wide', `summary' or `nov'.
+If mode is `nil', corresponding decoder is set up for every modes."
+  (when specs
+    (let ((mode (pop specs))
+         (function (pop specs)))
+      (if mode
+         (progn
+           (let ((cell (assq mode mime-field-decoder-alist)))
+             (if cell
+                 (setcdr cell (put-alist field function (cdr cell)))
+               (setq mime-field-decoder-alist
+                     (cons (cons mode (list (cons field function)))
+                           mime-field-decoder-alist))
+               ))
+           (apply (function mime-set-field-decoder) field specs)
+           )
+       (mime-set-field-decoder field
+                               'plain function
+                               'wide function
+                               'summary function
+                               'nov function)
+       ))))
+
+;;;###autoload
+(defmacro mime-find-field-presentation-method (name)
+  "Return field-presentation-method from NAME.
+NAME must be `plain', `wide', `summary' or `nov'."
+  (cond ((eq name nil)
+        `(or (assq 'summary mime-field-decoder-cache)
+             '(summary))
+        )
+       ((and (consp name)
+             (car name)
+             (consp (cdr name))
+             (symbolp (car (cdr name)))
+             (null (cdr (cdr name))))
+        `(or (assq ,name mime-field-decoder-cache)
+             (cons ,name nil))
+        )
+       (t
+        `(or (assq (or ,name 'summary) mime-field-decoder-cache)
+             (cons (or ,name 'summary) nil))
+        )))
+
+(defun mime-find-field-decoder-internal (field &optional mode)
+  "Return function to decode field-body of FIELD in MODE.
+Optional argument MODE must be object of field-presentation-method."
+  (cdr (or (assq field (cdr mode))
+          (prog1
+              (funcall mime-update-field-decoder-cache
+                       field (car mode))
+            (setcdr mode
+                    (cdr (assq (car mode) mime-field-decoder-cache)))
+            ))))
+
+;;;###autoload
+(defun mime-find-field-decoder (field &optional mode)
+  "Return function to decode field-body of FIELD in MODE.
+Optional argument MODE must be object or name of
+field-presentation-method.  Name of field-presentation-method must be
+`plain', `wide', `summary' or `nov'.
+Default value of MODE is `summary'."
+  (if (symbolp mode)
+      (let ((p (cdr (mime-find-field-presentation-method mode))))
+       (if (and p (setq p (assq field p)))
+           (cdr p)
+         (cdr (funcall mime-update-field-decoder-cache
+                       field (or mode 'summary)))))
+    (inline (mime-find-field-decoder-internal field mode))
+    ))
+
+;;;###autoload
+(defun mime-update-field-decoder-cache (field mode &optional function)
+  "Update field decoder cache `mime-field-decoder-cache'."
+  (cond ((eq function 'identity)
+        (setq function nil)
+        )
+       ((null function)
+        (let ((decoder-alist
+               (cdr (assq (or mode 'summary) mime-field-decoder-alist))))
+          (setq function (cdr (or (assq field decoder-alist)
+                                  (assq t decoder-alist)))))
+        ))
+  (let ((cell (assq mode mime-field-decoder-cache))
+        ret)
+    (if cell
+        (if (setq ret (assq field (cdr cell)))
+            (setcdr ret function)
+          (setcdr cell (cons (setq ret (cons field function)) (cdr cell))))
+      (setq mime-field-decoder-cache
+            (cons (cons mode (list (setq ret (cons field function))))
+                  mime-field-decoder-cache)))
+    ret))
+
+;; ignored fields
+(mime-set-field-decoder 'Archive                nil nil)
+(mime-set-field-decoder 'Content-Md5            nil nil)
+(mime-set-field-decoder 'Control                nil nil)
+(mime-set-field-decoder 'Date                  nil nil)
+(mime-set-field-decoder 'Distribution           nil nil)
+(mime-set-field-decoder 'Followup-Host          nil nil)
+(mime-set-field-decoder 'Followup-To            nil nil)
+(mime-set-field-decoder 'Lines                 nil nil)
+(mime-set-field-decoder 'Message-Id            nil nil)
+(mime-set-field-decoder 'Newsgroups            nil nil)
+(mime-set-field-decoder 'Nntp-Posting-Host     nil nil)
+(mime-set-field-decoder 'Path                  nil nil)
+(mime-set-field-decoder 'Posted-And-Mailed      nil nil)
+(mime-set-field-decoder 'Received              nil nil)
+(mime-set-field-decoder 'Status                 nil nil)
+(mime-set-field-decoder 'X-Face                 nil nil)
+(mime-set-field-decoder 'X-Face-Version         nil nil)
+(mime-set-field-decoder 'X-Info                 nil nil)
+(mime-set-field-decoder 'X-Pgp-Key-Info         nil nil)
+(mime-set-field-decoder 'X-Pgp-Sig              nil nil)
+(mime-set-field-decoder 'X-Pgp-Sig-Version      nil nil)
+(mime-set-field-decoder 'Xref                   nil nil)
+
+;; structured fields
+(let ((fields
+       '(Reply-To Resent-Reply-To From Resent-From Sender Resent-Sender
+        To Resent-To Cc Resent-Cc Bcc Resent-Bcc Dcc
+        Mail-Followup-To
+        Mime-Version Content-Type Content-Transfer-Encoding
+        Content-Disposition User-Agent))
+      field)
+  (while fields
+    (setq field (pop fields))
+    (mime-set-field-decoder
+     field
+     'plain    #'eword-decode-structured-field-body
+     'wide     #'eword-decode-and-fold-structured-field-body
+     'summary  #'eword-decode-and-unfold-structured-field-body
+     'nov      #'eword-decode-and-unfold-structured-field-body)
+    ))
+
+;; unstructured fields (default)
+(mime-set-field-decoder
+ t
+ 'plain        #'eword-decode-unstructured-field-body
+ 'wide #'eword-decode-unstructured-field-body
+ 'summary #'eword-decode-and-unfold-unstructured-field-body
+ 'nov  #'eword-decode-unfolded-unstructured-field-body)
+
+;;;###autoload
+(defun mime-decode-field-body (field-body field-name
+                                         &optional mode max-column)
+  "Decode FIELD-BODY as FIELD-NAME in MODE, and return the result.
+Optional argument MODE must be `plain', `wide', `summary' or `nov'.
+Default mode is `summary'.
+
+If MODE is `wide' and MAX-COLUMN is non-nil, the result is folded with
+MAX-COLUMN.
+
+Non MIME encoded-word part in FILED-BODY is decoded with
+`default-mime-charset'."
+  (let (field-name-symbol len decoder)
+    (if (symbolp field-name)
+        (setq field-name-symbol field-name
+              len (1+ (string-width (symbol-name field-name))))
+      (setq field-name-symbol (intern (capitalize field-name))
+            len (1+ (string-width field-name))))
+    (setq decoder (mime-find-field-decoder field-name-symbol mode))
+    (if decoder
+       (funcall decoder field-body len max-column)
+      ;; Don't decode
+      (if (eq mode 'summary)
+         (std11-unfold-string field-body)
+       field-body)
+      )))
+
+;;;###autoload
+(defun mime-decode-header-in-region (start end
+                                          &optional code-conversion)
+  "Decode MIME encoded-words in region between START and END.
+If CODE-CONVERSION is nil, it decodes only encoded-words.  If it is
+mime-charset, it decodes non-ASCII bit patterns as the mime-charset.
+Otherwise it decodes non-ASCII bit patterns as the
+default-mime-charset."
+  (interactive "*r")
+  (save-excursion
+    (save-restriction
+      (narrow-to-region start end)
+      (let ((default-charset
+             (if code-conversion
+                 (if (mime-charset-to-coding-system code-conversion)
+                     code-conversion
+                   default-mime-charset))))
+       (if default-charset
+           (let ((mode-obj (mime-find-field-presentation-method 'wide))
+                 beg p end field-name len field-decoder)
+             (goto-char (point-min))
+             (while (re-search-forward std11-field-head-regexp nil t)
+               (setq beg (match-beginning 0)
+                     p (match-end 0)
+                     field-name (buffer-substring beg (1- p))
+                     len (string-width field-name)
+                     field-name (intern (capitalize field-name))
+                     field-decoder (inline
+                                     (mime-find-field-decoder-internal
+                                      field-name mode-obj)))
+               (when field-decoder
+                 (setq end (std11-field-end))
+                 (let ((body (buffer-substring p end))
+                       (default-mime-charset default-charset))
+                   (delete-region p end)
+                   (insert (funcall field-decoder body (1+ len)))
+                   ))
+               ))
+         (eword-decode-region (point-min) (point-max) t)
+         )))))
+
+;;;###autoload
+(defun mime-decode-header-in-buffer (&optional code-conversion separator)
+  "Decode MIME encoded-words in header fields.
+If CODE-CONVERSION is nil, it decodes only encoded-words.  If it is
+mime-charset, it decodes non-ASCII bit patterns as the mime-charset.
+Otherwise it decodes non-ASCII bit patterns as the
+default-mime-charset.
+If SEPARATOR is not nil, it is used as header separator."
+  (interactive "*")
+  (mime-decode-header-in-region
+   (point-min)
+   (save-excursion
+     (goto-char (point-min))
+     (if (re-search-forward
+         (concat "^\\(" (regexp-quote (or separator "")) "\\)?$")
+         nil t)
+        (match-beginning 0)
+       (point-max)
+       ))
+   code-conversion))
+
+(defalias 'eword-decode-header 'mime-decode-header-in-buffer)
+(make-obsolete 'eword-decode-header 'mime-decode-header-in-buffer)
+
+
+;;; @ encoded-word decoder
+;;;
+
+(defvar eword-decode-encoded-word-error-handler
+  'eword-decode-encoded-word-default-error-handler)
+
+(defvar eword-warning-face nil
+  "Face used for invalid encoded-word.")
+
+(defun eword-decode-encoded-word-default-error-handler (word signal)
+  (and (add-text-properties 0 (length word)
+                           (and eword-warning-face
+                                (list 'face eword-warning-face))
+                           word)
+       word))
+
+(defun eword-decode-encoded-word (word &optional must-unfold)
+  "Decode WORD if it is an encoded-word.
+
+If your emacs implementation can not decode the charset of WORD, it
+returns WORD.  Similarly the encoded-word is broken, it returns WORD.
+
+If MUST-UNFOLD is non-nil, it unfolds and eliminates line-breaks even
+if there are in decoded encoded-word (generated by bad manner MUA such
+as a version of Net$cape)."
+  (or (if (string-match eword-encoded-word-regexp word)
+         (let ((charset
+                (substring word (match-beginning 1) (match-end 1))
+                )
+               (encoding
+                (upcase
+                 (substring word (match-beginning 2) (match-end 2))
+                 ))
+               (text
+                (substring word (match-beginning 3) (match-end 3))
+                ))
+            (condition-case err
+                (eword-decode-encoded-text charset encoding text must-unfold)
+              (error
+              (funcall eword-decode-encoded-word-error-handler word err)
+               ))
+            ))
+      word))
+
+
+;;; @ encoded-text decoder
+;;;
+
+(defun eword-decode-encoded-text (charset encoding string
+                                         &optional must-unfold)
+  "Decode STRING as an encoded-text.
+
+If your emacs implementation can not decode CHARSET, it returns nil.
+
+If ENCODING is not \"B\" or \"Q\", it occurs error.
+So you should write error-handling code if you don't want break by errors.
+
+If MUST-UNFOLD is non-nil, it unfolds and eliminates line-breaks even
+if there are in decoded encoded-text (generated by bad manner MUA such
+as a version of Net$cape)."
+  (let ((cs (mime-charset-to-coding-system charset)))
+    (if cs
+       (let ((dest (encoded-text-decode-string string encoding)))
+         (when dest
+           (setq dest (decode-mime-charset-string dest charset))
+           (if must-unfold
+               (mapconcat (function
+                           (lambda (chr)
+                             (cond ((eq chr ?\n) "")
+                                   ((eq chr ?\t) " ")
+                                   (t (char-to-string chr)))
+                             ))
+                          (std11-unfold-string dest)
+                          "")
+             dest))))))
+
+
+;;; @ lexical analyze
+;;;
+
+(defvar eword-lexical-analyze-cache nil)
+(defvar eword-lexical-analyze-cache-max 299
+  "*Max position of eword-lexical-analyze-cache.
+It is max size of eword-lexical-analyze-cache - 1.")
+
+(defvar mime-header-lexical-analyzer
+  '(eword-analyze-quoted-string
+    eword-analyze-domain-literal
+    eword-analyze-comment
+    eword-analyze-spaces
+    eword-analyze-special
+    eword-analyze-encoded-word
+    eword-analyze-atom)
+  "*List of functions to return result of lexical analyze.
+Each function must have three arguments: STRING, START and MUST-UNFOLD.
+STRING is the target string to be analyzed.
+START is start position of STRING to analyze.
+If MUST-UNFOLD is not nil, each function must unfold and eliminate
+bare-CR and bare-LF from the result even if they are included in
+content of the encoded-word.
+Each function must return nil if it can not analyze STRING as its
+format.
+
+Previous function is preferred to next function.  If a function
+returns nil, next function is used.  Otherwise the return value will
+be the result.")
+
+(defun eword-analyze-quoted-string (string start &optional must-unfold)
+  (let ((p (std11-check-enclosure string ?\" ?\" nil start)))
+    (if p
+       (cons (cons 'quoted-string
+                   (decode-mime-charset-string
+                    (std11-strip-quoted-pair
+                     (substring string (1+ start) (1- p)))
+                    default-mime-charset))
+             ;;(substring string p))
+             p)
+      )))
+
+(defun eword-analyze-domain-literal (string start &optional must-unfold)
+  (std11-analyze-domain-literal string start))
+
+(defun eword-analyze-comment (string from &optional must-unfold)
+  (let ((len (length string))
+       (i (or from 0))
+       dest last-str
+       chr ret)
+    (when (and (> len i)
+              (eq (aref string i) ?\())
+      (setq i (1+ i)
+           from i)
+      (catch 'tag
+       (while (< i len)
+         (setq chr (aref string i))
+         (cond ((eq chr ?\\)
+                (setq i (1+ i))
+                (if (>= i len)
+                    (throw 'tag nil)
+                  )
+                (setq last-str (concat last-str
+                                       (substring string from (1- i))
+                                       (char-to-string (aref string i)))
+                      i (1+ i)
+                      from i)
+                )
+               ((eq chr ?\))
+                (setq ret (concat last-str
+                                  (substring string from i)))
+                (throw 'tag (cons
+                             (cons 'comment
+                                   (nreverse
+                                    (if (string= ret "")
+                                        dest
+                                      (cons
+                                       (eword-decode-string
+                                        (decode-mime-charset-string
+                                         ret default-mime-charset)
+                                        must-unfold)
+                                       dest)
+                                      )))
+                             (1+ i)))
+                )
+               ((eq chr ?\()
+                (if (setq ret (eword-analyze-comment string i must-unfold))
+                    (setq last-str
+                          (concat last-str
+                                  (substring string from i))
+                          dest
+                          (if (string= last-str "")
+                              (cons (car ret) dest)
+                            (list* (car ret)
+                                   (eword-decode-string
+                                    (decode-mime-charset-string
+                                     last-str default-mime-charset)
+                                    must-unfold)
+                                   dest)
+                            )
+                          i (cdr ret)
+                          from i
+                          last-str "")
+                  (throw 'tag nil)
+                  ))
+               (t
+                (setq i (1+ i))
+                ))
+         )))))
+
+(defun eword-analyze-spaces (string start &optional must-unfold)
+  (std11-analyze-spaces string start))
+
+(defun eword-analyze-special (string start &optional must-unfold)
+  (std11-analyze-special string start))
+
+(defun eword-analyze-encoded-word (string start &optional must-unfold)
+  (if (and (string-match eword-encoded-word-regexp string start)
+          (= (match-beginning 0) start))
+      (let ((end (match-end 0))
+           (dest (eword-decode-encoded-word (match-string 0 string)
+                                            must-unfold))
+           )
+       ;;(setq string (substring string end))
+       (setq start end)
+       (while (and (string-match (eval-when-compile
+                                   (concat "[ \t\n]*\\("
+                                           eword-encoded-word-regexp
+                                           "\\)"))
+                                 string start)
+                   (= (match-beginning 0) start))
+         (setq end (match-end 0))
+         (setq dest
+               (concat dest
+                       (eword-decode-encoded-word (match-string 1 string)
+                                                  must-unfold))
+               ;;string (substring string end))
+               start end)
+         )
+       (cons (cons 'atom dest) ;;string)
+             end)
+       )))
+
+(defun eword-analyze-atom (string start &optional must-unfold)
+  (if (and (string-match std11-atom-regexp string start)
+          (= (match-beginning 0) start))
+      (let ((end (match-end 0)))
+       (cons (cons 'atom (decode-mime-charset-string
+                          (substring string start end)
+                          default-mime-charset))
+             ;;(substring string end)
+             end)
+       )))
+
+(defun eword-lexical-analyze-internal (string start must-unfold)
+  (let ((len (length string))
+       dest ret)
+    (while (< start len)
+      (setq ret
+           (let ((rest mime-header-lexical-analyzer)
+                 func r)
+             (while (and (setq func (car rest))
+                         (null
+                          (setq r (funcall func string start must-unfold)))
+                         )
+               (setq rest (cdr rest)))
+             (or r
+                 (list (cons 'error (substring string start)) (1+ len)))
+             ))
+      (setq dest (cons (car ret) dest)
+           start (cdr ret))
+      )
+    (nreverse dest)
+    ))
+
+(defun eword-lexical-analyze (string &optional start must-unfold)
+  "Return lexical analyzed list corresponding STRING.
+It is like std11-lexical-analyze, but it decodes non us-ascii
+characters encoded as encoded-words or invalid \"raw\" format.
+\"Raw\" non us-ascii characters are regarded as variable
+`default-mime-charset'."
+  (let ((key (substring string (or start 0)))
+       ret cell)
+    (set-text-properties 0 (length key) nil key)
+    (if (setq ret (assoc key eword-lexical-analyze-cache))
+       (cdr ret)
+      (setq ret (eword-lexical-analyze-internal key 0 must-unfold))
+      (setq eword-lexical-analyze-cache
+           (cons (cons key ret)
+                 eword-lexical-analyze-cache))
+      (if (cdr (setq cell (nthcdr eword-lexical-analyze-cache-max
+                                 eword-lexical-analyze-cache)))
+         (setcdr cell nil))
+      ret)))
+
+(defun eword-decode-token (token)
+  (let ((type (car token))
+       (value (cdr token)))
+    (cond ((eq type 'quoted-string)
+          (std11-wrap-as-quoted-string value))
+         ((eq type 'comment)
+          (let ((dest ""))
+            (while value
+              (setq dest (concat dest
+                                 (if (stringp (car value))
+                                     (std11-wrap-as-quoted-pairs
+                                      (car value) '(?( ?)))
+                                   (eword-decode-token (car value))
+                                   ))
+                    value (cdr value))
+              )
+            (concat "(" dest ")")
+            ))
+         (t value))))
+
+(defun eword-extract-address-components (string &optional start)
+  "Extract full name and canonical address from STRING.
+Returns a list of the form (FULL-NAME CANONICAL-ADDRESS).
+If no name can be extracted, FULL-NAME will be nil.
+It decodes non us-ascii characters in FULL-NAME encoded as
+encoded-words or invalid \"raw\" string.  \"Raw\" non us-ascii
+characters are regarded as variable `default-mime-charset'."
+  (let* ((structure (car (std11-parse-address
+                         (eword-lexical-analyze
+                          (std11-unfold-string string) start
+                          'must-unfold))))
+         (phrase  (std11-full-name-string structure))
+         (address (std11-address-string structure))
+         )
+    (list phrase address)
+    ))
+
+
+;;; @ end
+;;;
+
+(provide 'eword-decode)
+
+;;; eword-decode.el ends here
diff --git a/mime/eword-encode.el b/mime/eword-encode.el
new file mode 100644 (file)
index 0000000..f075db3
--- /dev/null
@@ -0,0 +1,694 @@
+;;; eword-encode.el --- RFC 2047 based encoded-word encoder for GNU Emacs
+
+;; Copyright (C) 1995,1996,1997,1998,1999,2000 Free Software Foundation, Inc.
+
+;; Author: MORIOKA Tomohiko <tomo@m17n.org>
+;; Keywords: encoded-word, MIME, multilingual, header, mail, news
+
+;; This file is part of FLIM (Faithful Library about Internet Message).
+
+;; 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.
+
+;;; Code:
+
+(require 'mime-def)
+(require 'mel)
+(require 'std11)
+(require 'eword-decode)
+
+
+;;; @ variables
+;;;
+
+;; User options are defined in mime-def.el.
+
+(defvar mime-header-charset-encoding-alist
+  '((us-ascii          . nil)
+    (iso-8859-1                . "Q")
+    (iso-8859-2                . "Q")
+    (iso-8859-3                . "Q")
+    (iso-8859-4                . "Q")
+    (iso-8859-5                . "Q")
+    (koi8-r            . "Q")
+    (iso-8859-7                . "Q")
+    (iso-8859-8                . "Q")
+    (iso-8859-9                . "Q")
+    (iso-2022-jp       . "B")
+    (iso-2022-jp-3     . "B")
+    (iso-2022-kr       . "B")
+    (gb2312            . "B")
+    (cn-gb             . "B")
+    (cn-gb-2312                . "B")
+    (euc-kr            . "B")
+    (tis-620           . "B")
+    (iso-2022-jp-2     . "B")
+    (iso-2022-int-1    . "B")
+    (utf-8             . "B")
+    ))
+
+(defvar mime-header-default-charset-encoding "Q")
+
+
+;;; @ encoded-text encoder
+;;;
+
+(defun eword-encode-text (charset encoding string &optional mode)
+  "Encode STRING as an encoded-word, and return the result.
+CHARSET is a symbol to indicate MIME charset of the encoded-word.
+ENCODING allows \"B\" or \"Q\".
+MODE is allows `text', `comment', `phrase' or nil.  Default value is
+`phrase'."
+  (let ((text (encoded-text-encode-string string encoding mode)))
+    (if text
+       (concat "=?" (upcase (symbol-name charset)) "?"
+               encoding "?" text "?=")
+      )))
+
+
+;;; @ charset word
+;;;
+
+(defsubst eword-encode-char-type (character)
+  (if (memq character '(?  ?\t ?\n))
+      nil
+    (char-charset character)
+    ))
+
+(defun eword-encode-divide-into-charset-words (string)
+  (let ((len (length string))
+       dest)
+    (while (> len 0)
+      (let* ((chr (aref string 0))
+             ;; (chr (sref string 0))
+            (charset (eword-encode-char-type chr))
+             (i 1)
+            ;; (i (char-length chr))
+            )
+       (while (and (< i len)
+                   (setq chr (aref string i))
+                    ;; (setq chr (sref string i))
+                   (eq charset (eword-encode-char-type chr)))
+         (setq i (1+ i))
+          ;; (setq i (char-next-index chr i))
+         )
+       (setq dest (cons (cons charset (substring string 0 i)) dest)
+             string (substring string i)
+             len (- len i))))
+    (nreverse dest)))
+
+
+;;; @ word
+;;;
+
+(defun eword-encode-charset-words-to-words (charset-words)
+  (let (dest)
+    (while charset-words
+      (let* ((charset-word (car charset-words))
+            (charset (car charset-word))
+            )
+       (if charset
+           (let ((charsets (list charset))
+                 (str (cdr charset-word))
+                 )
+             (catch 'tag
+               (while (setq charset-words (cdr charset-words))
+                 (setq charset-word (car charset-words)
+                       charset (car charset-word))
+                 (if (null charset)
+                     (throw 'tag nil)
+                   )
+                 (or (memq charset charsets)
+                     (setq charsets (cons charset charsets))
+                     )
+                 (setq str (concat str (cdr charset-word)))
+                 ))
+             (setq dest (cons (cons charsets str) dest))
+             )
+         (setq dest (cons charset-word dest)
+               charset-words (cdr charset-words)
+               ))))
+    (nreverse dest)
+    ))
+
+
+;;; @ rule
+;;;
+
+(defmacro make-ew-rword (text charset encoding type)
+  (` (list (, text)(, charset)(, encoding)(, type))))
+(defmacro ew-rword-text (rword)
+  (` (car (, rword))))
+(defmacro ew-rword-charset (rword)
+  (` (car (cdr (, rword)))))
+(defmacro ew-rword-encoding (rword)
+  (` (car (cdr (cdr (, rword))))))
+(defmacro ew-rword-type (rword)
+  (` (car (cdr (cdr (cdr (, rword)))))))
+
+(defun ew-find-charset-rule (charsets)
+  (if charsets
+      (let* ((charset (find-mime-charset-by-charsets charsets))
+            (encoding
+             (cdr (or (assq charset mime-header-charset-encoding-alist)
+                      (cons charset mime-header-default-charset-encoding)))))
+       (list charset encoding))))
+
+(defun tm-eword::words-to-ruled-words (wl &optional mode)
+  (mapcar (function
+          (lambda (word)
+            (let ((ret (ew-find-charset-rule (car word))))
+              (make-ew-rword (cdr word) (car ret)(nth 1 ret) mode)
+              )))
+         wl))
+
+(defun ew-space-process (seq)
+  (let (prev a ac b c cc)
+    (while seq
+      (setq b (car seq))
+      (setq seq (cdr seq))
+      (setq c (car seq))
+      (setq cc (ew-rword-charset c))
+      (if (and (null (ew-rword-charset b))
+              (not (eq (ew-rword-type b) 'special)))
+         (progn
+           (setq a (car prev))
+           (setq ac (ew-rword-charset a))
+           (if (and (ew-rword-encoding a)
+                    (ew-rword-encoding c))
+               (cond ((eq ac cc)
+                      (setq prev (cons
+                                  (cons (concat (car a)(car b)(car c))
+                                        (cdr a))
+                                  (cdr prev)
+                                  ))
+                      (setq seq (cdr seq))
+                      )
+                     (t
+                      (setq prev (cons
+                                  (cons (concat (car a)(car b))
+                                        (cdr a))
+                                  (cdr prev)
+                                  ))
+                      ))
+             (setq prev (cons b prev))
+             ))
+       (setq prev (cons b prev))
+       ))
+    (reverse prev)
+    ))
+
+(defun eword-encode-split-string (str &optional mode)
+  (ew-space-process
+   (tm-eword::words-to-ruled-words
+    (eword-encode-charset-words-to-words
+     (eword-encode-divide-into-charset-words str))
+    mode)))
+
+
+;;; @ length
+;;;
+
+(defun tm-eword::encoded-word-length (rword)
+  (let ((string   (ew-rword-text     rword))
+       (charset  (ew-rword-charset  rword))
+       (encoding (ew-rword-encoding rword))
+       ret)
+    (setq ret
+         (cond ((string-equal encoding "B")
+                (setq string (encode-mime-charset-string string charset))
+                (base64-encoded-length string)
+                )
+               ((string-equal encoding "Q")
+                (setq string (encode-mime-charset-string string charset))
+                (Q-encoded-text-length string (ew-rword-type rword))
+                )))
+    (if ret
+       (cons (+ 7 (length (symbol-name charset)) ret) string)
+      )))
+
+
+;;; @ encode-string
+;;;
+
+(defun ew-encode-rword-1 (column rwl &optional must-output)
+  (catch 'can-not-output
+    (let* ((rword (car rwl))
+          (ret (tm-eword::encoded-word-length rword))
+          string len)
+      (if (null ret)
+         (cond ((and (setq string (car rword))
+                     (or (<= (setq len (+ (length string) column)) 76)
+                         (<= column 1))
+                     )
+                (setq rwl (cdr rwl))
+                )
+               ((memq (aref string 0) '(?  ?\t))
+                (setq string (concat "\n" string)
+                      len (length string)
+                      rwl (cdr rwl))
+                )
+               (must-output
+                (setq string "\n "
+                      len 1)
+                )
+               (t
+                (throw 'can-not-output nil)
+                ))
+       (cond ((and (setq len (car ret))
+                   (<= (+ column len) 76)
+                   )
+              (setq string
+                    (eword-encode-text
+                     (ew-rword-charset rword)
+                     (ew-rword-encoding rword)
+                     (cdr ret)
+                     (ew-rword-type rword)
+                     ))
+              (setq len (+ (length string) column))
+              (setq rwl (cdr rwl))
+              )
+             (t
+              (setq string (car rword))
+              (let* ((p 0) np
+                     (str "") nstr)
+                (while (and (< p len)
+                            (progn
+                              (setq np (1+ p))
+                              ;;(setq np (char-next-index (sref string p) p))
+                              (setq nstr (substring string 0 np))
+                              (setq ret (tm-eword::encoded-word-length
+                                         (cons nstr (cdr rword))
+                                         ))
+                              (setq nstr (cdr ret))
+                              (setq len (+ (car ret) column))
+                              (<= len 76)
+                              ))
+                  (setq str nstr
+                        p np))
+                (if (string-equal str "")
+                    (if must-output
+                        (setq string "\n "
+                              len 1)
+                      (throw 'can-not-output nil))
+                  (setq rwl (cons (cons (substring string p) (cdr rword))
+                                  (cdr rwl)))
+                  (setq string
+                        (eword-encode-text
+                         (ew-rword-charset rword)
+                         (ew-rword-encoding rword)
+                         str
+                         (ew-rword-type rword)))
+                  (setq len (+ (length string) column))
+                  )
+                )))
+       )
+      (list string len rwl)
+      )))
+
+(defun eword-encode-rword-list (column rwl)
+  (let (ret dest str ew-f pew-f folded-points)
+    (while rwl
+      (setq ew-f (nth 2 (car rwl)))
+      (if (and pew-f ew-f)
+         (setq rwl (cons '(" ") rwl)
+               pew-f nil)
+       (setq pew-f ew-f)
+       )
+      (if (null (setq ret (ew-encode-rword-1 column rwl)))
+         (let ((i (1- (length dest)))
+               c s r-dest r-column)
+           (catch 'success
+             (while (catch 'found
+                      (while (>= i 0)
+                        (cond ((memq (setq c (aref dest i)) '(?  ?\t))
+                               (if (memq i folded-points)
+                                   (throw 'found nil)
+                                 (setq folded-points (cons i folded-points))
+                                 (throw 'found i))
+                               )
+                              ((eq c ?\n)
+                               (throw 'found nil)
+                               ))
+                        (setq i (1- i))))
+               (setq s (substring dest i)
+                     r-column (length s)
+                     r-dest (concat (substring dest 0 i) "\n" s))
+               (when (setq ret (ew-encode-rword-1 r-column rwl))
+                 (setq dest r-dest
+                       column r-column)
+                 (throw 'success t)
+                 ))
+             (setq ret (ew-encode-rword-1 column rwl 'must-output))
+             )))
+      (setq str (car ret))
+      (setq dest (concat dest str))
+      (setq column (nth 1 ret)
+           rwl (nth 2 ret))
+      )
+    (list dest column)
+    ))
+
+
+;;; @ converter
+;;;
+
+(defun eword-encode-phrase-to-rword-list (phrase)
+  (let (token type dest str)
+    (while phrase
+      (setq token (car phrase))
+      (setq type (car token))
+      (cond ((eq type 'quoted-string)
+            (setq str (concat "\"" (cdr token) "\""))
+            (setq dest
+                  (append dest
+                          (list
+                           (let ((ret (ew-find-charset-rule
+                                       (find-charset-string str))))
+                             (make-ew-rword
+                              str (car ret)(nth 1 ret) 'phrase)
+                             )
+                           )))
+            )
+           ((eq type 'comment)
+            (setq dest
+                  (append dest
+                          '(("(" nil nil special))
+                          (tm-eword::words-to-ruled-words
+                           (eword-encode-charset-words-to-words
+                            (eword-encode-divide-into-charset-words
+                             (cdr token)))
+                           'comment)
+                          '((")" nil nil special))
+                          ))
+            )
+           (t
+            (setq dest
+                  (append dest
+                          (tm-eword::words-to-ruled-words
+                           (eword-encode-charset-words-to-words
+                            (eword-encode-divide-into-charset-words
+                             (cdr token))
+                            ) 'phrase)))
+            ))
+      (setq phrase (cdr phrase))
+      )
+    (ew-space-process dest)
+    ))
+
+(defun eword-encode-addr-seq-to-rword-list (seq)
+  (let (dest pname)
+    (while seq
+      (let* ((token (car seq))
+            (name (car token))
+            )
+       (cond ((eq name 'spaces)
+              (setq dest (nconc dest (list (list (cdr token) nil nil))))
+              )
+             ((eq name 'comment)
+              (setq dest
+                    (nconc
+                     dest
+                     (list (list "(" nil nil))
+                     (eword-encode-split-string (cdr token) 'comment)
+                     (list (list ")" nil nil))
+                     ))
+              )
+             ((eq name 'quoted-string)
+              (setq dest
+                    (nconc
+                     dest
+                     (list
+                      (list (concat "\"" (cdr token) "\"") nil nil)
+                      )))
+              )
+             (t
+              (setq dest
+                    (if (or (eq pname 'spaces)
+                            (eq pname 'comment))
+                        (nconc dest (list (list (cdr token) nil nil)))
+                      (nconc (nreverse (cdr (reverse dest)))
+                             ;; (butlast dest)
+                             (list
+                              (list (concat (car (car (last dest)))
+                                            (cdr token))
+                                    nil nil)))))
+              ))
+       (setq seq (cdr seq)
+             pname name))
+      )
+    dest))
+
+(defun eword-encode-phrase-route-addr-to-rword-list (phrase-route-addr)
+  (if (eq (car phrase-route-addr) 'phrase-route-addr)
+      (let ((phrase (nth 1 phrase-route-addr))
+           (route (nth 2 phrase-route-addr))
+           dest)
+        ;; (if (eq (car (car phrase)) 'spaces)
+        ;;     (setq phrase (cdr phrase))
+        ;;   )
+       (setq dest (eword-encode-phrase-to-rword-list phrase))
+       (if dest
+           (setq dest (append dest '((" " nil nil))))
+         )
+       (append
+        dest
+        (eword-encode-addr-seq-to-rword-list
+         (append '((specials . "<"))
+                 route
+                 '((specials . ">"))))
+        ))))
+
+(defun eword-encode-addr-spec-to-rword-list (addr-spec)
+  (if (eq (car addr-spec) 'addr-spec)
+      (eword-encode-addr-seq-to-rword-list (cdr addr-spec))
+    ))
+
+(defun eword-encode-mailbox-to-rword-list (mbox)
+  (let ((addr (nth 1 mbox))
+       (comment (nth 2 mbox))
+       dest)
+    (setq dest (or (eword-encode-phrase-route-addr-to-rword-list addr)
+                  (eword-encode-addr-spec-to-rword-list addr)
+                  ))
+    (if comment
+       (setq dest
+             (append dest
+                     '((" " nil nil)
+                       ("(" nil nil))
+                     (eword-encode-split-string comment 'comment)
+                     (list '(")" nil nil))
+                     )))
+    dest))
+
+(defsubst eword-encode-mailboxes-to-rword-list (mboxes)
+  (let ((dest (eword-encode-mailbox-to-rword-list (car mboxes))))
+    (if dest
+       (while (setq mboxes (cdr mboxes))
+         (setq dest
+               (nconc dest
+                      (list '("," nil nil))
+                      (eword-encode-mailbox-to-rword-list
+                       (car mboxes))))))
+    dest))
+
+(defsubst eword-encode-address-to-rword-list (address)
+  (cond
+   ((eq (car address) 'mailbox)
+    (eword-encode-mailbox-to-rword-list address))
+   ((eq (car address) 'group)
+    (nconc
+     (eword-encode-phrase-to-rword-list (nth 1 address))
+     (list (list ":" nil nil))
+     (eword-encode-mailboxes-to-rword-list (nth 2 address))
+     (list (list ";" nil nil))))))
+
+(defsubst eword-encode-addresses-to-rword-list (addresses)
+  (let ((dest (eword-encode-address-to-rword-list (car addresses))))
+    (if dest
+       (while (setq addresses (cdr addresses))
+         (setq dest
+               (nconc dest
+                      (list '("," nil nil))
+                      ;; (list '(" " nil nil))
+                      (eword-encode-address-to-rword-list (car addresses))))))
+    dest))
+
+(defsubst eword-encode-msg-id-to-rword-list (msg-id)
+  (list
+   (list
+    (concat "<"
+           (caar (eword-encode-addr-seq-to-rword-list (cdr msg-id)))
+           ">")
+    nil nil)))
+
+(defsubst eword-encode-in-reply-to-to-rword-list (in-reply-to)
+  (let (dest)
+    (while in-reply-to
+      (setq dest
+           (append dest
+                   (let ((elt (car in-reply-to)))
+                     (if (eq (car elt) 'phrase)
+                         (eword-encode-phrase-to-rword-list (cdr elt))
+                       (eword-encode-msg-id-to-rword-list elt)
+                       ))))
+      (setq in-reply-to (cdr in-reply-to)))
+    dest))
+
+
+;;; @ application interfaces
+;;;
+
+(defvar eword-encode-default-start-column 10
+  "Default start column if it is omitted.")
+
+(defun eword-encode-string (string &optional column mode)
+  "Encode STRING as encoded-words, and return the result.
+Optional argument COLUMN is start-position of the field.
+Optional argument MODE allows `text', `comment', `phrase' or nil.
+Default value is `phrase'."
+  (car (eword-encode-rword-list
+       (or column eword-encode-default-start-column)
+       (eword-encode-split-string string mode))))
+
+(defun eword-encode-address-list (string &optional column)
+  "Encode header field STRING as list of address, and return the result.
+Optional argument COLUMN is start-position of the field."
+  (car (eword-encode-rword-list
+       (or column eword-encode-default-start-column)
+       (eword-encode-addresses-to-rword-list
+        (std11-parse-addresses-string string))
+       )))
+
+(defun eword-encode-in-reply-to (string &optional column)
+  "Encode header field STRING as In-Reply-To field, and return the result.
+Optional argument COLUMN is start-position of the field."
+  (car (eword-encode-rword-list
+       (or column 13)
+       (eword-encode-in-reply-to-to-rword-list
+        (std11-parse-msg-ids-string string)))))
+
+(defun eword-encode-structured-field-body (string &optional column)
+  "Encode header field STRING as structured field, and return the result.
+Optional argument COLUMN is start-position of the field."
+  (car (eword-encode-rword-list
+       (or column eword-encode-default-start-column)
+       (eword-encode-addr-seq-to-rword-list (std11-lexical-analyze string))
+       )))
+
+(defun eword-encode-unstructured-field-body (string &optional column)
+  "Encode header field STRING as unstructured field, and return the result.
+Optional argument COLUMN is start-position of the field."
+  (car (eword-encode-rword-list
+       (or column eword-encode-default-start-column)
+       (eword-encode-split-string string 'text))))
+
+;;;###autoload
+(defun mime-encode-field-body (field-body field-name)
+  "Encode FIELD-BODY as FIELD-NAME, and return the result.
+A lexical token includes non-ASCII character is encoded as MIME
+encoded-word.  ASCII token is not encoded."
+  (setq field-body (std11-unfold-string field-body))
+  (if (string= field-body "")
+      ""
+    (let (start)
+      (if (symbolp field-name)
+         (setq start (1+ (length (symbol-name field-name))))
+       (setq start (1+ (length field-name))
+             field-name (intern (capitalize field-name))))
+      (cond ((memq field-name
+                  '(Reply-To
+                    From Sender
+                    Resent-Reply-To Resent-From
+                    Resent-Sender To Resent-To
+                    Cc Resent-Cc Bcc Resent-Bcc
+                    Dcc))
+            (eword-encode-address-list field-body start))
+           ((eq field-name 'In-Reply-To)
+            (eword-encode-in-reply-to field-body start))
+           ((memq field-name '(Mime-Version User-Agent))
+            (eword-encode-structured-field-body field-body start))
+           (t
+            (eword-encode-unstructured-field-body field-body start))))))
+(defalias 'eword-encode-field-body 'mime-encode-field-body)
+(make-obsolete 'eword-encode-field-body 'mime-encode-field-body)
+
+(defun eword-in-subject-p ()
+  (let ((str (std11-field-body "Subject")))
+    (if (and str (string-match eword-encoded-word-regexp str))
+       str)))
+(make-obsolete 'eword-in-subject-p "Don't use it.")
+
+(defsubst eword-find-field-encoding-method (field-name)
+  (setq field-name (downcase field-name))
+  (let ((alist mime-field-encoding-method-alist))
+    (catch 'found
+      (while alist
+       (let* ((pair (car alist))
+              (str (car pair)))
+         (if (and (stringp str)
+                  (string= field-name (downcase str)))
+             (throw 'found (cdr pair))
+           ))
+       (setq alist (cdr alist)))
+      (cdr (assq t mime-field-encoding-method-alist))
+      )))
+
+;;;###autoload
+(defun mime-encode-header-in-buffer (&optional code-conversion)
+  "Encode header fields to network representation, such as MIME encoded-word.
+
+It refer variable `mime-field-encoding-method-alist'."
+  (interactive "*")
+  (save-excursion
+    (save-restriction
+      (std11-narrow-to-header mail-header-separator)
+      (goto-char (point-min))
+      (let ((default-cs (mime-charset-to-coding-system default-mime-charset))
+           bbeg end field-name)
+       (while (re-search-forward std11-field-head-regexp nil t)
+         (setq bbeg (match-end 0)
+               field-name (buffer-substring (match-beginning 0) (1- bbeg))
+               end (std11-field-end))
+         (and (delq 'ascii (find-charset-region bbeg end))
+              (let ((method (eword-find-field-encoding-method
+                             (downcase field-name))))
+                (cond ((eq method 'mime)
+                       (let ((field-body
+                              (buffer-substring-no-properties bbeg end)
+                              ))
+                         (delete-region bbeg end)
+                         (insert (mime-encode-field-body field-body
+                                                         field-name))))
+                      (code-conversion
+                       (let ((cs
+                              (or (mime-charset-to-coding-system
+                                   method)
+                                  default-cs)))
+                         (encode-coding-region bbeg end cs)
+                         )))
+                ))
+         ))
+      )))
+(defalias 'eword-encode-header 'mime-encode-header-in-buffer)
+(make-obsolete 'eword-encode-header 'mime-encode-header-in-buffer)
+
+
+;;; @ end
+;;;
+
+(provide 'eword-encode)
+
+;;; eword-encode.el ends here
diff --git a/mime/mail-mime-setup.el b/mime/mail-mime-setup.el
new file mode 100644 (file)
index 0000000..7b375b7
--- /dev/null
@@ -0,0 +1,65 @@
+;;; mail-mime-setup.el --- setup file for mail-mode.
+
+;; Copyright (C) 1994,1995,1996,1997,1998,2000 Free Software Foundation, Inc.
+
+;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
+;; Keywords: mail-mode, MIME, multimedia, multilingual, encoded-word
+
+;; This file is part of SEMI (Setting for Emacs MIME Interfaces).
+
+;; 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.
+
+;;; Code:
+
+(require 'semi-setup)
+(require 'alist)
+
+
+(autoload 'turn-on-mime-edit "mime-edit"
+  "Unconditionally turn on MIME-Edit minor mode." t)
+
+;; (autoload 'eword-decode-header "eword-decode"
+;;   "Decode MIME encoded-words in header fields." t)
+
+
+;;; @ for mail-mode, RMAIL and VM
+;;;
+
+;; (add-hook 'mail-setup-hook 'eword-decode-header)
+(add-hook 'mail-setup-hook 'turn-on-mime-edit 'append)
+(add-hook 'mail-send-hook  'mime-edit-maybe-translate)
+(set-alist 'mime-edit-split-message-sender-alist
+           'mail-mode (function
+                       (lambda ()
+                         (interactive)
+                         (funcall send-mail-function)
+                         )))
+
+
+;;; @ for signature
+;;;
+
+(if mime-setup-use-signature
+    (setq mail-signature nil)
+  )
+
+
+;;; @ end
+;;;
+
+(provide 'mail-mime-setup)
+
+;;; mail-mime-setup.el ends here
diff --git a/mime/mcharset.el b/mime/mcharset.el
new file mode 100644 (file)
index 0000000..124453d
--- /dev/null
@@ -0,0 +1,108 @@
+;;; mcharset.el --- MIME charset API
+
+;; Copyright (C) 1997,1998,1999,2000 Free Software Foundation, Inc.
+
+;; Author: MORIOKA Tomohiko <tomo@m17n.org>
+;; Keywords: emulation, compatibility, Mule
+
+;; This file is part of APEL (A Portable Emacs Library).
+
+;; 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.
+
+;;; Code:
+
+(require 'custom)
+
+(cond ((featurep 'mule)
+       (if (>= emacs-major-version 20)
+          (require 'mcs-20)
+        ;; for MULE 1.* and 2.*
+        (require 'mcs-om)))
+      ((boundp 'NEMACS)
+       ;; for Nemacs and Nepoch
+       (require 'mcs-nemacs))
+      (t
+       (require 'mcs-ltn1)))
+
+(defcustom default-mime-charset-for-write
+  (if (mime-charset-p 'utf-8)
+      'utf-8
+    'x-ctext)
+  "Default value of MIME-charset for encoding.
+It may be used when suitable MIME-charset is not found.
+It must be symbol."
+  :group 'i18n
+  :type 'mime-charset)
+
+(defcustom default-mime-charset-detect-method-for-write
+  nil
+  "Function called when suitable MIME-charset is not found to encode.
+It must be nil or function.
+If it is nil, variable `default-mime-charset-for-write' is used.
+If it is a function, interface must be (TYPE CHARSETS &rest ARGS).
+CHARSETS is list of charset.
+If TYPE is 'region, ARGS has START and END."
+  :group 'i18n
+  :type '(choice function (const nil)))
+
+(defun charsets-to-mime-charset (charsets)
+  "Return MIME charset from list of charset CHARSETS.
+Return nil if suitable mime-charset is not found."
+  (if charsets
+      (catch 'tag
+       (let ((rest charsets-mime-charset-alist)
+             cell)
+         (while (setq cell (car rest))
+           (if (catch 'not-subset
+                 (let ((set1 charsets)
+                       (set2 (car cell))
+                       obj)
+                   (while set1
+                     (setq obj (car set1))
+                     (or (memq obj set2)
+                         (throw 'not-subset nil))
+                     (setq set1 (cdr set1)))
+                   t))
+               (throw 'tag (cdr cell)))
+           (setq rest (cdr rest)))
+         ))))
+
+(defun find-mime-charset-by-charsets (charsets &optional mode &rest args)
+  "Like `charsets-to-mime-charset', but it does not return nil.
+
+When suitable mime-charset is not found and variable
+`default-mime-charset-detect-method-for-write' is not nil,
+`find-mime-charset-by-charsets' calls the variable as function and
+return the return value of the function.
+Interface of the function is (MODE CHARSETS &rest ARGS).
+
+When suitable mime-charset is not found and variable
+`default-mime-charset-detect-method-for-write' is nil,
+variable `default-mime-charset-for-write' is returned."
+  (or (charsets-to-mime-charset charsets)
+      (if default-mime-charset-detect-method-for-write
+         (apply default-mime-charset-detect-method-for-write
+                mode charsets args)
+       default-mime-charset-for-write)))
+
+
+;;; @ end
+;;;
+
+(require 'product)
+(product-provide (provide 'mcharset) (require 'apel-ver))
+
+;;; mcharset.el ends here
diff --git a/mime/mcs-20.el b/mime/mcs-20.el
new file mode 100644 (file)
index 0000000..ca9f394
--- /dev/null
@@ -0,0 +1,167 @@
+;;; mcs-20.el --- MIME charset implementation for Emacs 20 and XEmacs/mule
+
+;; Copyright (C) 1997,1998,1999,2000 Free Software Foundation, Inc.
+
+;; Author: MORIOKA Tomohiko <tomo@m17n.org>
+;; Keywords: emulation, compatibility, Mule
+
+;; This file is part of APEL (A Portable Emacs Library).
+
+;; 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:
+
+;;    This module requires Emacs 20.0.93, XEmacs 20.3-b5 (with mule)
+;;    or later.
+
+;;; Code:
+
+(require 'custom)
+(eval-when-compile (require 'wid-edit))
+
+(if (featurep 'xemacs)
+    (require 'mcs-xm)
+  (require 'mcs-e20))
+
+
+;;; @ MIME charset
+;;;
+
+(defcustom mime-charset-coding-system-alist
+  (let ((rest
+        '((us-ascii      . raw-text)
+          (gb2312        . cn-gb-2312)
+          (cn-gb         . cn-gb-2312)
+          (iso-2022-jp-2 . iso-2022-7bit-ss2)
+          (iso-2022-jp-3 . iso-2022-7bit-ss2)
+          (tis-620       . tis620)
+          (windows-874   . tis-620)
+          (cp874         . tis-620)
+          (x-ctext       . ctext)
+          (unknown       . undecided)
+          (x-unknown     . undecided)
+          ))
+       dest)
+    (while rest
+      (let ((pair (car rest)))
+       (or (find-coding-system (car pair))
+           (setq dest (cons pair dest))
+           ))
+      (setq rest (cdr rest))
+      )
+    dest)
+  "Alist MIME CHARSET vs CODING-SYSTEM.
+MIME CHARSET and CODING-SYSTEM must be symbol."
+  :group 'i18n
+  :type '(repeat (cons symbol coding-system)))
+
+(defcustom mime-charset-to-coding-system-default-method
+  nil
+  "Function called when suitable coding-system is not found from MIME-charset.
+It must be nil or function.
+If it is a function, interface must be (CHARSET LBT CODING-SYSTEM)."
+  :group 'i18n
+  :type '(choice function (const nil)))
+
+(defun mime-charset-to-coding-system (charset &optional lbt)
+  "Return coding-system corresponding with CHARSET.
+CHARSET is a symbol whose name is MIME charset.
+If optional argument LBT (`CRLF', `LF', `CR', `unix', `dos' or `mac')
+is specified, it is used as line break code type of coding-system."
+  (if (stringp charset)
+      (setq charset (intern (downcase charset)))
+    )
+  (let ((cs (assq charset mime-charset-coding-system-alist)))
+    (setq cs
+         (if cs
+             (cdr cs)
+           charset))
+    (if lbt
+       (setq cs (intern (format "%s-%s" cs
+                                (cond ((eq lbt 'CRLF) 'dos)
+                                      ((eq lbt 'LF) 'unix)
+                                      ((eq lbt 'CR) 'mac)
+                                      (t lbt)))))
+      )
+    (if (find-coding-system cs)
+       cs
+      (if mime-charset-to-coding-system-default-method
+         (funcall mime-charset-to-coding-system-default-method
+                  charset lbt cs)
+       ))))
+
+(defalias 'mime-charset-p 'mime-charset-to-coding-system)
+
+(defvar widget-mime-charset-prompt-value-history nil
+  "History of input to `widget-mime-charset-prompt-value'.")
+
+(define-widget 'mime-charset 'coding-system
+  "A mime-charset."
+  :format "%{%t%}: %v"
+  :tag "MIME-charset"
+  :prompt-history 'widget-mime-charset-prompt-value-history
+  :prompt-value 'widget-mime-charset-prompt-value
+  :action 'widget-mime-charset-action)
+
+(defun widget-mime-charset-prompt-value (widget prompt value unbound)
+  ;; Read mime-charset from minibuffer.
+  (intern
+   (completing-read (format "%s (default %s) " prompt value)
+                   (mapcar (function
+                            (lambda (sym)
+                              (list (symbol-name sym))))
+                           (mime-charset-list)))))
+
+(defun widget-mime-charset-action (widget &optional event)
+  ;; Read a mime-charset from the minibuffer.
+  (let ((answer
+        (widget-mime-charset-prompt-value
+         widget
+         (widget-apply widget :menu-tag-get)
+         (widget-value widget)
+         t)))
+    (widget-value-set widget answer)
+    (widget-apply widget :notify widget event)
+    (widget-setup)))
+
+(defcustom default-mime-charset 'x-unknown
+  "Default value of MIME-charset.
+It is used when MIME-charset is not specified.
+It must be symbol."
+  :group 'i18n
+  :type 'mime-charset)
+
+(defun detect-mime-charset-region (start end)
+  "Return MIME charset for region between START and END."
+  (find-mime-charset-by-charsets (find-charset-region start end)
+                                'region start end))
+
+(defun write-region-as-mime-charset (charset start end filename
+                                            &optional append visit lockname)
+  "Like `write-region', q.v., but encode by MIME CHARSET."
+  (let ((coding-system-for-write
+        (or (mime-charset-to-coding-system charset)
+            'binary)))
+    (write-region start end filename append visit lockname)))
+
+
+;;; @ end
+;;;
+
+(require 'product)
+(product-provide (provide 'mcs-20) (require 'apel-ver))
+
+;;; mcs-20.el ends here
diff --git a/mime/mcs-e20.el b/mime/mcs-e20.el
new file mode 100644 (file)
index 0000000..47d57c0
--- /dev/null
@@ -0,0 +1,157 @@
+;;; mcs-e20.el --- MIME charset implementation for Emacs 20.1 and 20.2
+
+;; Copyright (C) 1996,1997,1998,1999,2000 Free Software Foundation, Inc.
+
+;; Author: MORIOKA Tomohiko <tomo@m17n.org>
+;; Keywords: emulation, compatibility, Mule
+
+;; This file is part of APEL (A Portable Emacs Library).
+
+;; 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:
+
+;;    This module requires Emacs 20.1 and 20.2.
+
+;;; Code:
+
+(eval-when-compile (require 'static))
+
+(defsubst find-coding-system (obj)
+  "Return OBJ if it is a coding-system."
+  (if (coding-system-p obj)
+      obj))
+
+(defsubst encode-mime-charset-region (start end charset &optional lbt)
+  "Encode the text between START and END as MIME CHARSET."
+  (let (cs)
+    (if (and enable-multibyte-characters
+            (setq cs (mime-charset-to-coding-system charset lbt)))
+       (encode-coding-region start end cs)
+      )))
+
+(defsubst decode-mime-charset-region (start end charset &optional lbt)
+  "Decode the text between START and END as MIME CHARSET."
+  (let (cs)
+    (if (and enable-multibyte-characters
+            (setq cs (mime-charset-to-coding-system charset lbt)))
+       (decode-coding-region start end cs)
+      )))
+
+
+(defsubst encode-mime-charset-string (string charset &optional lbt)
+  "Encode the STRING as MIME CHARSET."
+  (let (cs)
+    (if (and enable-multibyte-characters
+            (setq cs (mime-charset-to-coding-system charset lbt)))
+       (encode-coding-string string cs)
+      string)))
+
+(defsubst decode-mime-charset-string (string charset &optional lbt)
+  "Decode the STRING as MIME CHARSET."
+  (let (cs)
+    (if (and enable-multibyte-characters
+            (setq cs (mime-charset-to-coding-system charset lbt)))
+       (decode-coding-string string cs)
+      string)))
+
+
+(defvar charsets-mime-charset-alist
+  '(((ascii)                                           . us-ascii)
+    ((ascii latin-iso8859-1)                           . iso-8859-1)
+    ((ascii latin-iso8859-2)                           . iso-8859-2)
+    ((ascii latin-iso8859-3)                           . iso-8859-3)
+    ((ascii latin-iso8859-4)                           . iso-8859-4)
+;;; ((ascii cyrillic-iso8859-5)                                . iso-8859-5)
+    ((ascii cyrillic-iso8859-5)                                . koi8-r)
+    ((ascii arabic-iso8859-6)                          . iso-8859-6)
+    ((ascii greek-iso8859-7)                           . iso-8859-7)
+    ((ascii hebrew-iso8859-8)                          . iso-8859-8)
+    ((ascii latin-iso8859-9)                           . iso-8859-9)
+    ((ascii latin-jisx0201
+           japanese-jisx0208-1978 japanese-jisx0208)   . iso-2022-jp)
+    ((ascii latin-jisx0201
+           katakana-jisx0201 japanese-jisx0208)        . shift_jis)
+    ((ascii korean-ksc5601)                            . euc-kr)
+    ((ascii chinese-gb2312)                            . gb2312)
+    ((ascii chinese-big5-1 chinese-big5-2)             . big5)
+    ((ascii thai-tis620 composition)                   . tis-620)
+    ((ascii latin-iso8859-1 greek-iso8859-7
+           latin-jisx0201 japanese-jisx0208-1978
+           chinese-gb2312 japanese-jisx0208
+           korean-ksc5601 japanese-jisx0212)           . iso-2022-jp-2)
+;     ((ascii latin-iso8859-1 greek-iso8859-7
+;          latin-jisx0201 japanese-jisx0208-1978
+;          chinese-gb2312 japanese-jisx0208
+;          korean-ksc5601 japanese-jisx0212
+;          chinese-cns11643-1 chinese-cns11643-2)      . iso-2022-int-1)
+;     ((ascii latin-iso8859-1 latin-iso8859-2
+;          cyrillic-iso8859-5 greek-iso8859-7
+;          latin-jisx0201 japanese-jisx0208-1978
+;          chinese-gb2312 japanese-jisx0208
+;          korean-ksc5601 japanese-jisx0212
+;          chinese-cns11643-1 chinese-cns11643-2
+;          chinese-cns11643-3 chinese-cns11643-4
+;          chinese-cns11643-5 chinese-cns11643-6
+;          chinese-cns11643-7)                         . iso-2022-int-1)
+    ))
+
+(defun coding-system-to-mime-charset (coding-system)
+  "Convert CODING-SYSTEM to a MIME-charset.
+Return nil if corresponding MIME-charset is not found."
+  (or (car (rassq coding-system mime-charset-coding-system-alist))
+      (coding-system-get coding-system 'mime-charset)
+      ))
+
+(defun mime-charset-list ()
+  "Return a list of all existing MIME-charset."
+  (let ((dest (mapcar (function car) mime-charset-coding-system-alist))
+       (rest coding-system-list)
+       cs)
+    (while rest
+      (setq cs (car rest))
+      (unless (rassq cs mime-charset-coding-system-alist)
+       (if (setq cs (coding-system-get cs 'mime-charset))
+           (or (rassq cs mime-charset-coding-system-alist)
+               (memq cs dest)  
+               (setq dest (cons cs dest))
+               )))
+      (setq rest (cdr rest)))
+    dest))
+
+(static-when (and (string= (decode-coding-string "\e.A\eN!" 'ctext) "\eN!")
+                 (or (not (find-coding-system 'x-ctext))
+                     (coding-system-get 'x-ctext 'apel)))
+  (unless (find-coding-system 'x-ctext)
+    (make-coding-system
+     'x-ctext 2 ?x
+     "Compound text based generic encoding for decoding unknown messages."
+     '((ascii t) (latin-iso8859-1 t) t t
+       nil ascii-eol ascii-cntl nil locking-shift single-shift nil nil nil
+       init-bol nil nil)
+     '((safe-charsets . t)
+       (mime-charset . x-ctext)))
+    (coding-system-put 'x-ctext 'apel t)
+    ))
+
+
+;;; @ end
+;;;
+
+(require 'product)
+(product-provide (provide 'mcs-e20) (require 'apel-ver))
+
+;;; mcs-e20.el ends here
diff --git a/mime/mel-b-ccl.el b/mime/mel-b-ccl.el
new file mode 100644 (file)
index 0000000..7e31dfa
--- /dev/null
@@ -0,0 +1,477 @@
+;;; mel-b-ccl.el --- Base64 encoder/decoder using CCL.
+
+;; Copyright (C) 1998,1999,2000 Free Software Foundation, Inc.
+
+;; Author: Tanaka Akira <akr@m17n.org>
+;; Created: 1998/9/17
+;; Keywords: MIME, Base64
+
+;; This file is part of FLIM (Faithful Library about Internet Message).
+
+;; 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 this program; see the file COPYING.  If not, write to the
+;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Code:
+
+(require 'ccl)
+(require 'pccl)
+(require 'mime-def)
+
+
+;;; @ constants
+;;;
+
+(eval-when-compile
+
+(defconst mel-ccl-4-table
+  '(  0   1   2   3))
+
+(defconst mel-ccl-16-table
+  '(  0   1   2   3   4   5   6   7   8   9  10  11  12  13  14  15))
+
+(defconst mel-ccl-64-table
+  '(  0   1   2   3   4   5   6   7   8   9  10  11  12  13  14  15
+     16  17  18  19  20  21  22  23  24  25  26  27  28  29  30  31
+     32  33  34  35  36  37  38  39  40  41  42  43  44  45  46  47
+     48  49  50  51  52  53  54  55  56  57  58  59  60  61  62  63))
+
+(defconst mel-ccl-256-table
+  '(  0   1   2   3   4   5   6   7   8   9  10  11  12  13  14  15
+     16  17  18  19  20  21  22  23  24  25  26  27  28  29  30  31
+     32  33  34  35  36  37  38  39  40  41  42  43  44  45  46  47
+     48  49  50  51  52  53  54  55  56  57  58  59  60  61  62  63
+     64  65  66  67  68  69  70  71  72  73  74  75  76  77  78  79
+     80  81  82  83  84  85  86  87  88  89  90  91  92  93  94  95
+     96  97  98  99 100 101 102 103 104 105 106 107 108 109 110 111
+    112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127
+    128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143
+    144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159
+    160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175
+    176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191
+    192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207
+    208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223
+    224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239
+    240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255))
+
+(defconst mel-ccl-256-to-64-table
+  '(nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
+    nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
+    nil nil nil nil nil nil nil nil nil nil nil  62 nil nil nil  63
+     52  53  54  55  56  57  58  59  60  61 nil nil nil   t nil nil
+    nil   0   1   2   3   4   5   6   7   8   9  10  11  12  13  14
+     15  16  17  18  19  20  21  22  23  24  25 nil nil nil nil nil
+    nil  26  27  28  29  30  31  32  33  34  35  36  37  38  39  40
+     41  42  43  44  45  46  47  48  49  50  51 nil nil nil nil nil
+    nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
+    nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
+    nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
+    nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
+    nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
+    nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
+    nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
+    nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil))
+
+(defconst mel-ccl-64-to-256-table
+  (mapcar
+   'char-int
+   "ABCDEFGHIJKLMNOPQRSTUVWXYZ\
+abcdefghijklmnopqrstuvwxyz\
+0123456789\
++/"))
+
+)
+
+
+;;; @ CCL programs
+;;;
+
+(eval-when-compile
+
+(defun mel-ccl-decode-b-bit-ex (v)
+  (logior
+   (lsh (logand v (lsh 255 16)) -16)
+   (logand v (lsh 255 8))
+   (lsh (logand v 255) 16)))
+
+)
+
+(eval-when-compile
+
+(defconst mel-ccl-decode-b-0-table
+  (vconcat
+   (mapcar
+    (lambda (v)
+      (if (integerp v)
+         (mel-ccl-decode-b-bit-ex (lsh v 18))
+       (lsh 1 24)))
+    mel-ccl-256-to-64-table)))
+
+(defconst mel-ccl-decode-b-1-table
+  (vconcat
+   (mapcar
+    (lambda (v)
+      (if (integerp v)
+         (mel-ccl-decode-b-bit-ex (lsh v 12))
+       (lsh 1 25)))
+    mel-ccl-256-to-64-table)))
+
+(defconst mel-ccl-decode-b-2-table
+  (vconcat
+   (mapcar
+    (lambda (v)
+      (if (integerp v)
+         (mel-ccl-decode-b-bit-ex (lsh v 6))
+       (lsh 1 26)))
+    mel-ccl-256-to-64-table)))
+
+(defconst mel-ccl-decode-b-3-table
+  (vconcat
+   (mapcar
+    (lambda (v)
+      (if (integerp v)
+         (mel-ccl-decode-b-bit-ex v)
+       (lsh 1 27)))
+    mel-ccl-256-to-64-table)))
+
+)
+
+(check-broken-facility ccl-cascading-read)
+
+(if-broken ccl-cascading-read
+    (define-ccl-program mel-ccl-decode-b
+      `(1
+       (loop
+        (loop
+         (read-branch
+          r1
+          ,@(mapcar
+             (lambda (v)
+               (cond
+                ((or (eq v nil) (eq v t)) '(repeat))
+                (t `((r0 = ,(lsh v 2)) (break)))))
+             mel-ccl-256-to-64-table)))
+        (loop
+         (read-branch
+          r1
+          ,@(mapcar
+             (lambda (v)
+               (cond
+                ((or (eq v nil) (eq v t)) '(repeat))
+                ((= (lsh v -4) 0) `((write r0) (r0 = ,(lsh (logand v 15) 4)) (break)))
+                (t `((r0 |= ,(lsh v -4)) (write r0) (r0 = ,(lsh (logand v 15) 4)) (break)))))
+             mel-ccl-256-to-64-table)))
+        (loop
+         (read-branch
+          r1
+          ,@(mapcar
+             (lambda (v)
+               (cond
+                ((eq v nil) '(repeat))
+                ((eq v t) '(end))
+                ((= (lsh v -2) 0) `((write r0) (r0 = ,(lsh (logand v 3) 6)) (break)))
+                (t `((r0 |= ,(lsh v -2)) (write r0) (r0 = ,(lsh (logand v 3) 6)) (break)))))
+             mel-ccl-256-to-64-table)))
+        (loop
+         (read-branch
+          r1
+          ,@(mapcar
+             (lambda (v)
+               (cond
+                ((eq v nil) '(repeat))
+                ((eq v t) '(end))
+                (t `((r0 |= ,v) (write r0) (break)))))
+             mel-ccl-256-to-64-table)))
+        (repeat))))
+  (define-ccl-program mel-ccl-decode-b
+    `(1
+      (loop
+       (read r0 r1 r2 r3)
+       (r4 = r0 ,mel-ccl-decode-b-0-table)
+       (r5 = r1 ,mel-ccl-decode-b-1-table)
+       (r4 |= r5)
+       (r5 = r2 ,mel-ccl-decode-b-2-table)
+       (r4 |= r5)
+       (r5 = r3 ,mel-ccl-decode-b-3-table)
+       (r4 |= r5)
+       (if (r4 & ,(lognot (1- (lsh 1 24))))
+          ((loop
+            (if (r4 & ,(lsh 1 24))
+                ((r0 = r1) (r1 = r2) (r2 = r3) (read r3)
+                 (r4 >>= 1) (r4 &= ,(logior (lsh 7 24)))
+                 (r5 = r3 ,mel-ccl-decode-b-3-table)
+                 (r4 |= r5)
+                 (repeat))
+              (break)))
+           (loop
+            (if (r4 & ,(lsh 1 25))
+                ((r1 = r2) (r2 = r3) (read r3)
+                 (r4 >>= 1) (r4 &= ,(logior (lsh 7 24)))
+                 (r5 = r3 ,mel-ccl-decode-b-3-table)
+                 (r4 |= r5)
+                 (repeat))
+              (break)))
+           (loop
+            (if (r2 != ?=)
+                (if (r4 & ,(lsh 1 26))
+                    ((r2 = r3) (read r3)
+                     (r4 >>= 1) (r4 &= ,(logior (lsh 7 24)))
+                     (r5 = r3 ,mel-ccl-decode-b-3-table)
+                     (r4 |= r5)
+                     (repeat))
+                  ((r6 = 0)
+                   (break)))
+              ((r6 = 1)
+               (break))))
+           (loop
+            (if (r3 != ?=)
+                (if (r4 & ,(lsh 1 27))
+                    ((read r3)
+                     (r4 = r3 ,mel-ccl-decode-b-3-table)
+                     (repeat))
+                  (break))
+              ((r6 |= 2)
+               (break))))
+           (r4 = r0 ,mel-ccl-decode-b-0-table)
+           (r5 = r1 ,mel-ccl-decode-b-1-table)
+           (r4 |= r5)
+           (branch
+            r6
+            ;; BBBB
+            ((r5 = r2 ,mel-ccl-decode-b-2-table)
+             (r4 |= r5)
+             (r5 = r3 ,mel-ccl-decode-b-3-table)
+             (r4 |= r5)
+             (r4 >8= 0)
+             (write r7)
+             (r4 >8= 0)
+             (write r7)
+             (write-repeat r4))
+            ;; error: BB=B 
+            ((write (r4 & 255))
+             (end))
+            ;; BBB=
+            ((r5 = r2 ,mel-ccl-decode-b-2-table)
+             (r4 |= r5)
+             (r4 >8= 0)
+             (write r7)
+             (write (r4 & 255))
+             (end)                     ; Excessive (end) is workaround for XEmacs 21.0.
+                                       ; Without this, "AAA=" is converted to "^@^@^@".
+             (end))
+            ;; BB==
+            ((write (r4 & 255))
+             (end))))
+        ((r4 >8= 0)
+         (write r7)
+         (r4 >8= 0)
+         (write r7)
+         (write-repeat r4))))))
+  )
+
+(eval-when-compile
+
+;; Generated CCL program works not properly on 20.2 because CCL_EOF_BLOCK
+;; is not executed.
+(defun mel-ccl-encode-base64-generic
+  (&optional quantums-per-line output-crlf terminate-with-newline)
+  `(2
+    ((r3 = 0)
+     (r2 = 0)
+     (read r1)
+     (loop
+      (branch
+       r1
+       ,@(mapcar
+          (lambda (r1)
+            `((write ,(nth (lsh r1 -2) mel-ccl-64-to-256-table))
+              (r0 = ,(logand r1 3))))
+          mel-ccl-256-table))
+      (r2 = 1)
+      (read-branch
+       r1
+       ,@(mapcar
+          (lambda (r1)
+            `((write r0 ,(vconcat
+                          (mapcar
+                           (lambda (r0)
+                             (nth (logior (lsh r0 4)
+                                          (lsh r1 -4))
+                                  mel-ccl-64-to-256-table))
+                           mel-ccl-4-table)))
+              (r0 = ,(logand r1 15))))
+          mel-ccl-256-table))
+      (r2 = 2)
+      (read-branch
+       r1
+       ,@(mapcar
+          (lambda (r1)
+            `((write r0 ,(vconcat
+                          (mapcar
+                           (lambda (r0)
+                             (nth (logior (lsh r0 2)
+                                          (lsh r1 -6))
+                                  mel-ccl-64-to-256-table))
+                           mel-ccl-16-table)))))
+          mel-ccl-256-table))
+      (r1 &= 63)
+      (write r1 ,(vconcat
+                  (mapcar
+                   (lambda (r1)
+                     (nth r1 mel-ccl-64-to-256-table))
+                   mel-ccl-64-table)))
+      (r3 += 1)
+      (r2 = 0)
+      (read r1)
+      ,@(when quantums-per-line
+         `((if (r3 == ,quantums-per-line)
+               ((write ,(if output-crlf "\r\n" "\n"))
+                (r3 = 0)))))
+      (repeat)))
+    (branch
+     r2
+     ,(if terminate-with-newline
+         `(if (r3 > 0) (write ,(if output-crlf "\r\n" "\n")))
+       `(r0 = 0))
+     ((write r0 ,(vconcat
+                  (mapcar
+                   (lambda (r0)
+                     (nth (lsh r0 4) mel-ccl-64-to-256-table))
+                   mel-ccl-4-table)))
+      (write ,(if terminate-with-newline
+                 (if output-crlf "==\r\n" "==\n")
+               "==")))
+     ((write r0 ,(vconcat
+                  (mapcar
+                   (lambda (r0)
+                     (nth (lsh r0 2) mel-ccl-64-to-256-table))
+                   mel-ccl-16-table)))
+      (write ,(if terminate-with-newline
+                 (if output-crlf "=\r\n" "=\n")
+               "="))))
+    ))
+)
+
+(define-ccl-program mel-ccl-encode-b
+  (mel-ccl-encode-base64-generic))
+
+;; 19 * 4 = 76
+(define-ccl-program mel-ccl-encode-base64-crlf-crlf
+  (mel-ccl-encode-base64-generic 19 t))
+
+(define-ccl-program mel-ccl-encode-base64-crlf-lf
+  (mel-ccl-encode-base64-generic 19 nil))
+
+
+;;; @ coding system
+;;;
+
+(make-ccl-coding-system
+ 'mel-ccl-b-rev ?B "MIME B-encoding (reversed)"
+ 'mel-ccl-encode-b 'mel-ccl-decode-b)
+
+(make-ccl-coding-system
+ 'mel-ccl-base64-crlf-rev
+ ?B "MIME Base64-encoding (reversed)"
+ 'mel-ccl-encode-base64-crlf-crlf
+ 'mel-ccl-decode-b)
+
+(make-ccl-coding-system
+ 'mel-ccl-base64-lf-rev
+ ?B "MIME Base64-encoding (LF encoding) (reversed)"
+ 'mel-ccl-encode-base64-crlf-lf
+ 'mel-ccl-decode-b)
+
+
+;;; @ B
+;;;
+
+(check-broken-facility ccl-execute-eof-block-on-decoding-some)
+
+(unless-broken ccl-execute-eof-block-on-decoding-some
+
+  (defun base64-ccl-encode-string (string &optional no-line-break)
+    "Encode STRING with base64 encoding."
+    (if no-line-break
+       (decode-coding-string string 'mel-ccl-b-rev)
+      (decode-coding-string string 'mel-ccl-base64-lf-rev)))
+  (defalias-maybe 'base64-encode-string 'base64-ccl-encode-string)
+
+  (defun base64-ccl-encode-region (start end &optional no-line-break)
+    "Encode region from START to END with base64 encoding."
+    (interactive "*r")
+    (if no-line-break
+       (decode-coding-region start end 'mel-ccl-b-rev)
+      (decode-coding-region start end 'mel-ccl-base64-lf-rev)))
+  (defalias-maybe 'base64-encode-region 'base64-ccl-encode-region)
+
+  (defun base64-ccl-insert-encoded-file (filename)
+    "Encode contents of file FILENAME to base64, and insert the result."
+    (interactive "*fInsert encoded file: ")
+    (let ((coding-system-for-read 'mel-ccl-base64-lf-rev)
+         format-alist)
+      (insert-file-contents filename)))
+
+  (mel-define-method-function (mime-encode-string string (nil "base64"))
+                             'base64-ccl-encode-string)
+  (mel-define-method-function (mime-encode-region start end (nil "base64"))
+                             'base64-ccl-encode-region)
+  (mel-define-method-function
+   (mime-insert-encoded-file filename (nil "base64"))
+   'base64-ccl-insert-encoded-file)
+
+  (mel-define-method-function (encoded-text-encode-string string (nil "B"))
+                             'base64-ccl-encode-string)
+  )
+
+(defun base64-ccl-decode-string (string)
+  "Decode base64 encoded STRING"
+  (encode-coding-string string 'mel-ccl-b-rev))
+(defalias-maybe 'base64-decode-string 'base64-ccl-decode-string)
+
+(defun base64-ccl-decode-region (start end)
+  "Decode base64 encoded the region from START to END."
+  (interactive "*r")
+  (encode-coding-region start end 'mel-ccl-b-rev))
+(defalias-maybe 'base64-decode-region 'base64-ccl-decode-region)
+
+(defun base64-ccl-write-decoded-region (start end filename)
+  "Decode the region from START to END and write out to FILENAME."
+  (interactive "*r\nFWrite decoded region to file: ")
+  (let ((coding-system-for-write 'mel-ccl-b-rev)
+       jka-compr-compression-info-list jam-zcat-filename-list)
+    (write-region start end filename)))
+
+(mel-define-method-function (mime-decode-string string (nil "base64"))
+                           'base64-ccl-decode-string)
+(mel-define-method-function (mime-decode-region start end (nil "base64"))
+                           'base64-ccl-decode-region)
+(mel-define-method-function
+ (mime-write-decoded-region start end filename (nil "base64"))
+ 'base64-ccl-write-decoded-region)
+
+(mel-define-method encoded-text-decode-string (string (nil "B"))
+  (if (string-match (eval-when-compile
+                     (concat "\\`" B-encoded-text-regexp "\\'"))
+                   string)
+      (base64-ccl-decode-string string)
+    (error "Invalid encoded-text %s" string)))
+
+
+;;; @ end
+;;;
+
+(provide 'mel-b-ccl)
+
+;;; mel-b-ccl.el ends here.
diff --git a/mime/mel-b.el b/mime/mel-b.el
new file mode 100644 (file)
index 0000000..d534039
--- /dev/null
@@ -0,0 +1,82 @@
+;;; mel-b.el --- Base64 encoder/decoder using builtin base64 handlers
+
+;; Copyright (C) 1998,1999,2000,2001 Free Software Foundation, Inc.
+
+;; Author: Tanaka Akira <akr@m17n.org>
+;; Created by modifying mel-b-ccl.el: 2001/2/6
+;; Keywords: MIME, Base64
+
+;; This file is part of FLIM (Faithful Library about Internet Message).
+
+;; 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 this program; see the file COPYING.  If not, write to the
+;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Code:
+
+(require 'mime-def)
+
+(defun base64-insert-encoded-file (filename)
+  "Encode contents of file FILENAME to base64, and insert the result."
+  (interactive "*fInsert encoded file: ")
+  (save-excursion
+    (save-restriction
+      (narrow-to-region (point) (point))
+      (let ((coding-system-for-read 'binary))
+       (insert-file-contents filename))
+      (base64-encode-region (point-min) (point-max)))))
+
+(mel-define-method-function (mime-encode-string string (nil "base64"))
+                           'base64-encode-string)
+(mel-define-method-function (mime-encode-region start end (nil "base64"))
+                           'base64-encode-region)
+(mel-define-method-function (mime-insert-encoded-file filename (nil "base64"))
+                           'base64-insert-encoded-file)
+(mel-define-method-function (encoded-text-encode-string string (nil "B"))
+                           'base64-encode-string)
+
+(defun base64-write-decoded-region (start end filename)
+  "Decode the region from START to END and write out to FILENAME."
+  (interactive "*r\nFWrite decoded region to file: ")
+  (let ((current (current-buffer))
+       (multibyte enable-multibyte-characters))
+    (with-temp-buffer
+      (set-buffer-multibyte multibyte)
+      (insert-buffer-substring current start end)
+      (base64-decode-region (point-min) (point-max))
+      (let ((coding-system-for-write 'binary))
+       (write-region (point-min) (point-max) filename)))))
+
+(mel-define-method-function (mime-decode-string string (nil "base64"))
+                           'base64-ccl-decode-string)
+(mel-define-method-function (mime-decode-region start end (nil "base64"))
+                           'base64-ccl-decode-region)
+(mel-define-method-function
+ (mime-write-decoded-region start end filename (nil "base64"))
+ 'base64-write-decoded-region)
+
+(mel-define-method encoded-text-decode-string (string (nil "B"))
+  (if (string-match (eval-when-compile
+                     (concat "\\`" B-encoded-text-regexp "\\'"))
+                   string)
+      (base64-decode-string string)
+    (error "Invalid encoded-text %s" string)))
+
+
+;;; @ end
+;;;
+
+(provide 'mel-b)
+
+;;; mel-b.el ends here.
diff --git a/mime/mel-g.el b/mime/mel-g.el
new file mode 100644 (file)
index 0000000..9f79197
--- /dev/null
@@ -0,0 +1,135 @@
+;;; mel-g.el --- Gzip64 encoder/decoder.
+
+;; Copyright (C) 1995,1996,1997,1998 MORIOKA Tomohiko
+;; Copyright (C) 1996,1997,1999 Shuhei KOBAYASHI
+
+;; Author: Shuhei KOBAYASHI <shuhei@aqua.ocn.ne.jp>
+;;         MORIOKA Tomohiko <tomo@m17n.org>
+;; Maintainer: Shuhei KOBAYASHI <shuhei@aqua.ocn.ne.jp>
+;; Created: 1995/10/25
+;; Keywords: Gzip64, base64, gzip, MIME
+
+;; This file is part of FLIM (Faithful Library about Internet Message).
+
+;; 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 this program; see the file COPYING.  If not, write to the
+;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Commentary:
+
+;;; NOTE: Gzip64 is an experimental Content-Transfer-Encoding and its
+;;; use is STRONGLY DISCOURAGED except for private communication.
+
+;;; Code:
+
+(require 'mime-def)
+(require 'path-util)
+
+
+;;; @ variables
+;;;
+
+(defvar gzip64-external-encoder
+  (let ((file (exec-installed-p "mmencode")))
+    (and file
+        (` ("sh" "-c" (, (concat "gzip -c | " file))))))
+  "*list of gzip64 encoder program name and its arguments.")
+
+(defvar gzip64-external-decoder
+  (let ((file (exec-installed-p "mmencode")))
+    (and file
+        (` ("sh" "-c" (, (concat file " -u | gzip -dc"))))))
+  "*list of gzip64 decoder program name and its arguments.")
+
+
+;;; @ encoder/decoder for region
+;;;
+
+(defun gzip64-external-encode-region (beg end)
+  (interactive "*r")
+  (save-excursion
+    (let ((coding-system-for-write 'binary))
+      (apply (function call-process-region)
+            beg end (car gzip64-external-encoder)
+            t t nil
+            (cdr gzip64-external-encoder)))
+    ;; for OS/2
+    ;;   regularize line break code
+    ;;(goto-char (point-min))
+    ;;(while (re-search-forward "\r$" nil t)
+    ;;  (replace-match ""))
+    ))
+
+(defun gzip64-external-decode-region (beg end)
+  (interactive "*r")
+  (save-excursion
+    (let ((coding-system-for-read 'binary))
+      (apply (function call-process-region)
+            beg end (car gzip64-external-decoder)
+            t t nil
+            (cdr gzip64-external-decoder)))))
+
+(mel-define-method-function (mime-encode-region start end (nil "x-gzip64"))
+                           'gzip64-external-encode-region)
+(mel-define-method-function (mime-decode-region start end (nil "x-gzip64"))
+                           'gzip64-external-decode-region)
+
+
+;;; @ encoder/decoder for string
+;;;
+
+(mel-define-method mime-encode-string (string (nil "x-gzip64"))
+  (with-temp-buffer
+    (insert string)
+    (gzip64-external-encode-region (point-min)(point-max))
+    (buffer-string)))
+
+(mel-define-method mime-decode-string (string (nil "x-gzip64"))
+  (with-temp-buffer
+    (insert string)
+    (gzip64-external-decode-region (point-min)(point-max))
+    (buffer-string)))
+
+
+;;; @ encoder/decoder for file
+;;;
+
+(mel-define-method mime-insert-encoded-file (filename (nil "x-gzip64"))
+  (interactive "*fInsert encoded file: ")
+  (apply (function call-process)
+        (car gzip64-external-encoder)
+        filename t nil
+        (cdr gzip64-external-encoder)))
+
+(mel-define-method mime-write-decoded-region (start end filename
+                                                   (nil "x-gzip64"))
+  "Decode and write current region encoded by gzip64 into FILENAME.
+START and END are buffer positions."
+  (interactive "*r\nFWrite decoded region to file: ")
+  (let ((coding-system-for-read 'binary)
+       (coding-system-for-write 'binary))
+    (apply (function call-process-region)
+          start end (car gzip64-external-decoder)
+          nil nil nil
+          (let ((args (cdr gzip64-external-decoder)))
+            (append (butlast args)
+                    (list (concat (car (last args)) ">" filename)))))))
+
+
+;;; @ end
+;;;
+
+(provide 'mel-g)
+
+;;; mel-g.el ends here.
diff --git a/mime/mel-q-ccl.el b/mime/mel-q-ccl.el
new file mode 100644 (file)
index 0000000..cb54a56
--- /dev/null
@@ -0,0 +1,996 @@
+;;; mel-q-ccl.el --- Quoted-Printable encoder/decoder using CCL.
+
+;; Copyright (C) 1998,1999 Tanaka Akira
+
+;; Author: Tanaka Akira <akr@jaist.ac.jp>
+;; Created: 1998/9/17
+;; Keywords: MIME, Quoted-Printable, Q-encoding
+
+;; This file is part of FLIM (Faithful Library about Internet Message).
+
+;; 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 this program; see the file COPYING.  If not, write to the
+;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Code:
+
+(require 'ccl)
+(require 'pccl)
+(require 'mime-def)
+
+
+;;; @ constants
+;;;
+
+(eval-when-compile
+
+(defconst mel-ccl-16-table
+  '(  0   1   2   3   4   5   6   7   8   9  10  11  12  13  14  15))
+
+(defconst mel-ccl-28-table
+  '(  0   1   2   3   4   5   6   7   8   9  10  11  12  13  14  15
+     16  17  18  19  20  21  22  23  24  25  26  27))
+
+(defconst mel-ccl-256-table
+  '(  0   1   2   3   4   5   6   7   8   9  10  11  12  13  14  15
+     16  17  18  19  20  21  22  23  24  25  26  27  28  29  30  31
+     32  33  34  35  36  37  38  39  40  41  42  43  44  45  46  47
+     48  49  50  51  52  53  54  55  56  57  58  59  60  61  62  63
+     64  65  66  67  68  69  70  71  72  73  74  75  76  77  78  79
+     80  81  82  83  84  85  86  87  88  89  90  91  92  93  94  95
+     96  97  98  99 100 101 102 103 104 105 106 107 108 109 110 111
+    112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127
+    128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143
+    144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159
+    160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175
+    176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191
+    192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207
+    208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223
+    224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239
+    240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255))
+
+(defconst mel-ccl-256-to-16-table
+  '(nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
+    nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
+    nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
+      0   1   2   3   4   5   6   7   8   9 nil nil nil nil nil nil
+    nil  10  11  12  13  14  15 nil nil nil nil nil nil nil nil nil
+    nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
+    nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
+    nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
+    nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
+    nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
+    nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
+    nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
+    nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
+    nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
+    nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
+    nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil))
+
+(defconst mel-ccl-16-to-256-table
+  (mapcar 'char-int "0123456789ABCDEF"))
+
+(defconst mel-ccl-high-table
+  (vconcat
+   (mapcar
+    (lambda (v) (nth (lsh v -4) mel-ccl-16-to-256-table))
+    mel-ccl-256-table)))
+
+(defconst mel-ccl-low-table
+  (vconcat
+   (mapcar
+    (lambda (v) (nth (logand v 15) mel-ccl-16-to-256-table))
+    mel-ccl-256-table)))
+
+(defconst mel-ccl-u-raw
+  (mapcar
+   'char-int
+   "0123456789\
+ABCDEFGHIJKLMNOPQRSTUVWXYZ\
+abcdefghijklmnopqrstuvwxyz\
+!@#$%&'()*+,-./:;<>@[\\]^`{|}~"))
+
+(defconst mel-ccl-c-raw
+  (mapcar
+   'char-int
+   "0123456789\
+ABCDEFGHIJKLMNOPQRSTUVWXYZ\
+abcdefghijklmnopqrstuvwxyz\
+!@#$%&'*+,-./:;<>@[]^`{|}~"))
+
+(defconst mel-ccl-p-raw
+  (mapcar
+   'char-int
+   "0123456789\
+ABCDEFGHIJKLMNOPQRSTUVWXYZ\
+abcdefghijklmnopqrstuvwxyz\
+!*+-/"))
+
+(defconst mel-ccl-qp-table
+  [enc enc enc enc enc enc enc enc enc wsp lf  enc enc cr  enc enc
+   enc enc enc enc enc enc enc enc enc enc enc enc enc enc enc enc
+   wsp raw raw raw raw raw raw raw raw raw raw raw raw raw raw raw
+   raw raw raw raw raw raw raw raw raw raw raw raw raw enc raw raw
+   raw raw raw raw raw raw raw raw raw raw raw raw raw raw raw raw
+   raw raw raw raw raw raw raw raw raw raw raw raw raw raw raw raw
+   raw raw raw raw raw raw raw raw raw raw raw raw raw raw raw raw
+   raw raw raw raw raw raw raw raw raw raw raw raw raw raw raw enc
+   enc enc enc enc enc enc enc enc enc enc enc enc enc enc enc enc
+   enc enc enc enc enc enc enc enc enc enc enc enc enc enc enc enc
+   enc enc enc enc enc enc enc enc enc enc enc enc enc enc enc enc
+   enc enc enc enc enc enc enc enc enc enc enc enc enc enc enc enc
+   enc enc enc enc enc enc enc enc enc enc enc enc enc enc enc enc
+   enc enc enc enc enc enc enc enc enc enc enc enc enc enc enc enc
+   enc enc enc enc enc enc enc enc enc enc enc enc enc enc enc enc
+   enc enc enc enc enc enc enc enc enc enc enc enc enc enc enc enc])
+
+)
+
+
+;;; @ CCL programs
+;;;
+
+;;; Q
+
+(define-ccl-program mel-ccl-decode-q
+  `(1
+    ((loop
+      (read-branch
+       r0
+       ,@(mapcar
+          (lambda (r0)
+            (cond
+             ((= r0 (char-int ?_))
+              `(write-repeat ? ))
+             ((= r0 (char-int ?=))
+              `((loop
+                 (read-branch
+                  r1
+                  ,@(mapcar
+                     (lambda (v)
+                       (if (integerp v)
+                           `((r0 = ,v) (break))
+                         '(repeat)))
+                     mel-ccl-256-to-16-table)))
+                (loop
+                 (read-branch
+                  r1
+                  ,@(mapcar
+                     (lambda (v)
+                       (if (integerp v)
+                           `((write r0 ,(vconcat
+                                         (mapcar
+                                          (lambda (r0)
+                                            (logior (lsh r0 4) v))
+                                          mel-ccl-16-table)))
+                             (break))
+                         '(repeat)))
+                     mel-ccl-256-to-16-table)))
+                (repeat)))
+             (t
+              `(write-repeat ,r0))))
+          mel-ccl-256-table))))))
+
+(eval-when-compile
+
+(defun mel-ccl-encode-q-generic (raw)
+  `(3
+    (loop
+     (loop
+      (read-branch
+       r0
+       ,@(mapcar
+          (lambda (r0)
+            (cond
+             ((= r0 32) `(write-repeat ?_))
+             ((member r0 raw) `(write-repeat ,r0))
+             (t '(break))))
+          mel-ccl-256-table)))
+     (write ?=)
+     (write r0 ,mel-ccl-high-table)
+     (write r0 ,mel-ccl-low-table)
+     (repeat))))
+
+;; On xemacs, generated program counts iso-8859-1 8bit character as 6bytes.
+(defun mel-ccl-count-q-length (raw)
+  `(0
+    ((r0 = 0)
+     (loop
+      (read-branch
+       r1
+       ,@(mapcar
+         (lambda (r1)
+           (if (or (= r1 32) (member r1 raw))
+               '((r0 += 1) (repeat))
+             '((r0 += 3) (repeat))))
+         mel-ccl-256-table))))))
+
+)
+
+(define-ccl-program mel-ccl-encode-uq
+  (mel-ccl-encode-q-generic mel-ccl-u-raw))
+(define-ccl-program mel-ccl-encode-cq
+  (mel-ccl-encode-q-generic mel-ccl-c-raw))
+(define-ccl-program mel-ccl-encode-pq
+  (mel-ccl-encode-q-generic mel-ccl-p-raw))
+
+(define-ccl-program mel-ccl-count-uq
+  (mel-ccl-count-q-length mel-ccl-u-raw))
+(define-ccl-program mel-ccl-count-cq
+  (mel-ccl-count-q-length mel-ccl-c-raw))
+(define-ccl-program mel-ccl-count-pq
+  (mel-ccl-count-q-length mel-ccl-p-raw))
+
+;; Quoted-Printable
+
+(eval-when-compile
+
+(defvar eof-block-branches)
+(defvar eof-block-reg)
+(defun mel-ccl-set-eof-block (branch)
+  (let ((p (assoc branch eof-block-branches)))
+    (unless p
+      (setq p (cons branch (length eof-block-branches))
+           eof-block-branches (cons p eof-block-branches)))
+    `(,eof-block-reg = ,(cdr p))))
+
+)
+
+(eval-when-compile
+
+(defun mel-ccl-try-to-read-crlf (input-crlf reg
+                                           succ
+                                           cr-eof cr-fail
+                                           lf-eof lf-fail
+                                           crlf-eof crlf-fail)
+  (if input-crlf
+      `(,(mel-ccl-set-eof-block cr-eof)
+       (read-if (,reg == ?\r)
+         (,(mel-ccl-set-eof-block lf-eof)
+          (read-if (,reg == ?\n)
+            ,succ
+            ,lf-fail))
+         ,cr-fail))
+    `(,(mel-ccl-set-eof-block crlf-eof)
+      (read-if (,reg == ?\n)
+       ,succ
+       ,crlf-fail))))
+
+)
+
+(eval-when-compile
+
+;; Generated CCL program works not properly on 20.2 because CCL_EOF_BLOCK
+;; is not executed.
+(defun mel-ccl-encode-quoted-printable-generic (input-crlf output-crlf)
+  (let ((hard (if output-crlf "\r\n" "\n"))
+       (soft (if output-crlf "=\r\n" "=\n"))
+       (eof-block-branches nil)
+       (eof-block-reg 'r4)
+       (after-wsp 'r5)
+       (column 'r6)
+       (type 'r3)
+       (current 'r0)
+       (type-raw 0)
+       (type-enc 1)
+       (type-wsp 2)
+       (type-brk 3)
+       )
+    `(4
+      ((,column = 0)
+       (,after-wsp = 0)
+       ,(mel-ccl-set-eof-block '(end))
+       (read r0)
+       (loop   ; invariant: column <= 75
+       (loop
+        (loop
+         (branch
+          r0
+          ,@(mapcar
+             (lambda (r0)
+               (let ((tmp (aref mel-ccl-qp-table r0)))
+                 (cond
+                  ((eq r0 (char-int ?F))
+                   `(if (,column == 0)
+                        (,(mel-ccl-set-eof-block '((write "F") (end)))
+                         (read-if (r0 == ?r)
+                           (,(mel-ccl-set-eof-block '((write "Fr") (end)))
+                            (read-if (r0 == ?o)
+                              (,(mel-ccl-set-eof-block '((write "Fro") (end)))
+                               (read-if (r0 == ?m)
+                                 (,(mel-ccl-set-eof-block '((write "From") (end)))
+                                  (read-if (r0 == ? )
+                                    ((,column = 7)
+                                     (,after-wsp = 1)
+                                     ,(mel-ccl-set-eof-block '((write "From=20") (end)))
+                                     (read r0)
+                                     (write-repeat "=46rom "))
+                                    ((,column = 4)
+                                     (write-repeat "From"))))
+                                 ((,column = 3)
+                                  (write-repeat "Fro"))))
+                              ((,column = 2)
+                               (write-repeat "Fr"))))
+                           ((,column = 1)
+                            (write-repeat "F"))))
+                      ((,type = ,type-raw) (break)) ; RAW
+                      ))
+                  ((eq r0 (char-int ?.))
+                   `(if (,column == 0)
+                        ,(mel-ccl-try-to-read-crlf
+                           input-crlf 'r0
+                           ;; "." CR LF (input-crlf: t)
+                           ;; "." LF (input-crlf: nil)
+                           `((write ,(concat "=2E" hard))
+                             ,(mel-ccl-set-eof-block '(end))
+                             (read r0)
+                             (repeat))
+                           ;; "." <EOF>
+                           '((write ".") (end))
+                           ;; "." noCR (input-crlf: t)
+                           `((,column = 1)
+                             (write-repeat "."))
+                           ;; "." CR <EOF> (input-crlf: t)
+                           '((write ".=0D") (end))
+                           ;; "." CR noLF (input-crlf: t)
+                           `((,column = 4)
+                             (write-repeat ".=0D"))
+                           ;; "." <EOF> (input-crlf: nil)
+                           '((write ".") (end))
+                           ;; "." noLF (input-crlf: nil)
+                           `((,column = 1)
+                             (write-repeat ".")))
+                      ((,type = ,type-raw) (break)) ; RAW
+                      ))
+                  ((eq tmp 'raw) `((,type = ,type-raw) (break)))
+                  ((eq tmp 'enc) `((,type = ,type-enc) (break)))
+                  ((eq tmp 'wsp) `((,type = ,type-wsp) (break)))
+                  ((eq tmp 'cr) `((,type = ,(if input-crlf type-brk type-enc))
+                                  (break)))
+                  ((eq tmp 'lf) `((,type = ,(if input-crlf type-enc type-brk))
+                                  (break)))
+                  )))
+             mel-ccl-256-table)))
+        ;; r0:type{raw,enc,wsp,brk}
+        (branch
+         ,type
+         ;; r0:type-raw
+         (if (,column < 75)
+             ((,column += 1)
+              (,after-wsp = 0)
+              ,(mel-ccl-set-eof-block '(end))
+              (write-read-repeat r0))
+           ((r1 = (r0 + 0))
+            (,after-wsp = 0)
+            ,@(mel-ccl-try-to-read-crlf
+               input-crlf 'r0
+               `((,column = 0)
+                 (write r1)
+                 ,(mel-ccl-set-eof-block `((write ,hard) (end)))
+                 (read r0)
+                 (write-repeat ,hard))
+               '((write r1) (end))
+               `((,column = 1)
+                 (write ,soft) (write-repeat r1))
+               `((write ,soft) (write r1) (write "=0D") (end))
+               `((,column = 4)
+                 (write ,soft) (write r1) (write-repeat "=0D"))
+               '((write r1) (end))
+               `((,column = 1)
+                 (write ,soft) (write-repeat r1)))))
+         ;; r0:type-enc
+         ((,after-wsp = 0)
+          (if (,column < 73)
+              ((,column += 3)
+               (write "=")
+               (write r0 ,mel-ccl-high-table)
+               ,(mel-ccl-set-eof-block '(end))
+               (write-read-repeat r0 ,mel-ccl-low-table))
+            (if (,column < 74)
+                ((r1 = (r0 + 0))
+                 (,after-wsp = 0)
+                 ,@(mel-ccl-try-to-read-crlf
+                    input-crlf 'r0
+                    `((,column = 0)
+                      (write "=")
+                      (write r1 ,mel-ccl-high-table)
+                      (write r1 ,mel-ccl-low-table)
+                      (write ,hard)
+                      ,(mel-ccl-set-eof-block '(end))
+                      (read r0)
+                      (repeat))
+                    `((write "=")
+                      (write r1 ,mel-ccl-high-table)
+                      (write r1 ,mel-ccl-low-table)
+                      (end))
+                    `((,column = 3)
+                      (write ,(concat soft "="))
+                      (write r1 ,mel-ccl-high-table)
+                      (write r1 ,mel-ccl-low-table)
+                      (repeat))
+                    `((write ,(concat soft "="))
+                      (write r1 ,mel-ccl-high-table)
+                      (write r1 ,mel-ccl-low-table)
+                      (write "=0D")
+                      (end))
+                    `((,column = 6)
+                      (write ,(concat soft "="))
+                      (write r1 ,mel-ccl-high-table)
+                      (write r1 ,mel-ccl-low-table)
+                      (write-repeat "=0D"))
+                    `((write "=")
+                      (write r1 ,mel-ccl-high-table)
+                      (write r1 ,mel-ccl-low-table)
+                      (end))
+                    `((,column = 3)
+                      (write ,(concat soft "="))
+                      (write r1 ,mel-ccl-high-table)
+                      (write r1 ,mel-ccl-low-table)
+                      (repeat))))
+              ((,column = 3)
+               (write ,(concat soft "="))
+               (write r0 ,mel-ccl-high-table)
+               ,(mel-ccl-set-eof-block '(end))
+               (write-read-repeat r0 ,mel-ccl-low-table)))))
+         ;; r0:type-wsp
+         (if (,column < 73)
+             ((r1 = (r0 + 0))
+              ,@(mel-ccl-try-to-read-crlf
+                 input-crlf 'r0
+                 `((,column = 0)
+                   (,after-wsp = 0)
+                   (write "=")
+                   (write r1 ,mel-ccl-high-table)
+                   (write r1 ,mel-ccl-low-table)
+                   (write ,hard)
+                   ,(mel-ccl-set-eof-block `(end))
+                   (read r0)
+                   (repeat))
+                 `((write "=")
+                   (write r1 ,mel-ccl-high-table)
+                   (write r1 ,mel-ccl-low-table)
+                   (end))
+                 `((,column += 1)
+                   (,after-wsp = 1)
+                   (write-repeat r1))
+                 `((write r1)
+                   (write "=0D")
+                   (end))
+                 `((,column += 4)
+                   (,after-wsp = 0)
+                   (write r1)
+                   (write-repeat "=0D"))
+                 `((write "=")
+                   (write r1 ,mel-ccl-high-table)
+                   (write r1 ,mel-ccl-low-table)
+                   (end))
+                 `((,column += 1)
+                   (,after-wsp = 1)
+                   (write-repeat r1))))
+           (if (,column < 74)
+               ((r1 = (r0 + 0))
+                ,@(mel-ccl-try-to-read-crlf
+                   input-crlf 'r0
+                   `((,column = 0)
+                     (,after-wsp = 0)
+                     (write "=")
+                     (write r1 ,mel-ccl-high-table)
+                     (write r1 ,mel-ccl-low-table)
+                     (write ,hard)
+                     ,(mel-ccl-set-eof-block `(end))
+                     (read r0)
+                     (repeat))
+                   `((write "=")
+                     (write r1 ,mel-ccl-high-table)
+                     (write r1 ,mel-ccl-low-table)
+                     (end))
+                   `((,column += 1)
+                     (,after-wsp = 1)
+                     (write-repeat r1))
+                   `((write r1)
+                     (write ,(concat soft "=0D"))
+                     (end))
+                   `((,column = 3)
+                     (,after-wsp = 0)
+                     (write r1)
+                     (write-repeat ,(concat soft "=0D")))
+                   `((write "=")
+                     (write r1 ,mel-ccl-high-table)
+                     (write r1 ,mel-ccl-low-table)
+                     (end))
+                   `((,column += 1)
+                     (,after-wsp = 1)
+                     (write-repeat r1))))
+             (if (,column < 75)
+                 ((,column += 1)
+                  (,after-wsp = 1)
+                  ,(mel-ccl-set-eof-block `((write ,soft) (end)))
+                  (write-read-repeat r0))
+               ((write ,soft)
+                (,column = 0)
+                (,after-wsp = 0)
+                (repeat)))))
+         ;; r0:type-brk
+         ,(if input-crlf
+              ;; r0{CR}:type-brk
+              `((if ((,column > 73) & ,after-wsp)
+                    ((,column = 0)
+                     (,after-wsp = 0)
+                     (write ,soft)))
+                ,(mel-ccl-set-eof-block `((if (,column > 73) (write ,soft))
+                                          (write "=0D") (end)))
+                (read-if (r0 == ?\n)
+                  (if ,after-wsp
+                      ((,after-wsp = 0)
+                       (,column = 0)
+                       (write ,(concat soft hard))
+                       ,(mel-ccl-set-eof-block '(end))
+                       (read r0)
+                       (repeat))
+                    ((,after-wsp = 0)
+                     (,column = 0)
+                     (write ,hard)
+                     ,(mel-ccl-set-eof-block '(end))
+                     (read r0)
+                     (repeat)))
+                  (if (,column < 73)
+                      ((,after-wsp = 0)
+                       (,column += 3)
+                       (write-repeat "=0D"))
+                    (if (,column < 74)
+                        (if (r0 == ?\r)
+                            ((,after-wsp = 0)
+                             ,(mel-ccl-set-eof-block
+                               `((write ,(concat soft "=0D=0D")) (end)))
+                             (read-if (r0 == ?\n)
+                               ((,column = 0)
+                                ,(mel-ccl-set-eof-block
+                                  `((write ,(concat "=0D" hard)) (end)))
+                                (read r0)
+                                (write-repeat ,(concat "=0D" hard)))
+                               ((,column = 6)
+                                (write-repeat ,(concat soft "=0D=0D")))))
+                          ((,after-wsp = 0)
+                           (,column = 3)
+                           (write-repeat ,(concat soft "=0D"))))
+                      ((,after-wsp = 0)
+                       (,column = 3)
+                       (write-repeat ,(concat soft "=0D")))))))
+            ;; r0{LF}:type-brk
+            `(if ,after-wsp
+                 ;; WSP ; r0{LF}:type-brk
+                 ((,after-wsp = 0)
+                  (,column = 0)
+                  (write ,(concat soft (if output-crlf "\r" "")))
+                  ,(mel-ccl-set-eof-block `(end))
+                  (write-read-repeat r0))
+               ;; noWSP ; r0{LF}:type-brk
+               ((,after-wsp = 0)
+                (,column = 0)
+                ,@(if output-crlf '((write ?\r)) '())
+                ,(mel-ccl-set-eof-block `(end))
+                (write-read-repeat r0)))
+            )))))
+      (branch
+       ,eof-block-reg
+       ,@(reverse (mapcar 'car eof-block-branches))))))
+
+(defun mel-ccl-decode-quoted-printable-generic (input-crlf output-crlf)
+  `(1
+    ((read r0)
+     (loop
+      (branch
+       r0
+       ,@(mapcar
+          (lambda (r0)
+            (let ((tmp (aref mel-ccl-qp-table r0)))
+              (cond
+               ((eq tmp 'raw) `(write-read-repeat r0))
+               ((eq tmp 'wsp) (if (eq r0 (char-int ? ))
+                                  `(r1 = 1)
+                                `(r1 = 0)))
+               ((eq tmp 'cr)
+                (if input-crlf
+                    ;; r0='\r'
+                    `((read r0)
+                      ;; '\r' r0
+                      (if (r0 == ?\n)
+                          ;; '\r' r0='\n'
+                          ;; hard line break found.
+                          ,(if output-crlf
+                               '((write ?\r)
+                                 (write-read-repeat r0))
+                             '(write-read-repeat r0))
+                        ;; '\r' r0:[^\n]
+                        ;; invalid control character (bare CR) found.
+                        ;; -> ignore it and rescan from r0.
+                        (repeat)))
+                  ;; r0='\r'
+                  ;; invalid character (bare CR) found.
+                  ;; -> ignore.
+                  `((read r0)
+                    (repeat))))
+               ((eq tmp 'lf)
+                (if input-crlf
+                    ;; r0='\n'
+                    ;; invalid character (bare LF) found.
+                    ;; -> ignore.
+                    `((read r0)
+                      (repeat))
+                  ;; r0='\r\n'
+                  ;; hard line break found.
+                  (if output-crlf
+                      '((write ?\r)
+                        (write-read-repeat r0))
+                    '(write-read-repeat r0))))
+               ((eq r0 (char-int ?=))
+                ;; r0='='
+                `((read r0)
+                  ;; '=' r0
+                  (r1 = (r0 == ?\t))
+                  (if ((r0 == ? ) | r1)
+                      ;; '=' r0:[\t ]
+                      ;; Skip transport-padding.
+                      ;; It should check CR LF after
+                      ;; transport-padding.
+                      (loop
+                       (read-if (r0 == ?\t)
+                                (repeat)
+                                (if (r0 == ? )
+                                    (repeat)
+                                  (break)))))
+                  ;; '=' [\t ]* r0:[^\t ]
+                  (branch
+                   r0
+                   ,@(mapcar
+                      (lambda (r0)
+                        (cond
+                         ((eq r0 (char-int ?\r))
+                          (if input-crlf
+                              ;; '=' [\t ]* r0='\r'
+                              `((read r0)
+                                ;; '=' [\t ]* '\r' r0
+                                (if (r0 == ?\n)
+                                    ;; '=' [\t ]* '\r' r0='\n'
+                                    ;; soft line break found.
+                                    ((read r0)
+                                     (repeat))
+                                  ;; '=' [\t ]* '\r' r0:[^\n]
+                                  ;; invalid input ->
+                                  ;; output "=" and rescan from r0.
+                                  ((write "=")
+                                   (repeat))))
+                            ;; '=' [\t ]* r0='\r'
+                            ;; invalid input (bare CR found) -> 
+                            ;; output "=" and rescan from next.
+                            `((write ?=)
+                              (read r0)
+                              (repeat))))
+                         ((eq r0 (char-int ?\n))
+                          (if input-crlf
+                              ;; '=' [\t ]* r0='\n'
+                              ;; invalid input (bare LF found) -> 
+                              ;; output "=" and rescan from next.
+                              `((write ?=)
+                                (read r0)
+                                (repeat))
+                            ;; '=' [\t ]* r0='\r\n'
+                            ;; soft line break found.
+                            `((read r0)
+                              (repeat))))
+                         ((setq tmp (nth r0 mel-ccl-256-to-16-table))
+                          ;; '=' [\t ]* r0:[0-9A-F]
+                          ;; upper nibble of hexadecimal digit found.
+                          `((r1 = (r0 + 0))
+                           (r0 = ,tmp)))
+                         (t
+                          ;; '=' [\t ]* r0:[^\r0-9A-F]
+                          ;; invalid input ->
+                          ;; output "=" and rescan from r0.
+                          `((write ?=)
+                            (repeat)))))
+                      mel-ccl-256-table))
+                  ;; '=' [\t ]* r1:r0:[0-9A-F]
+                  (read-branch
+                   r2
+                   ,@(mapcar
+                      (lambda (r2)
+                        (if (setq tmp (nth r2 mel-ccl-256-to-16-table))
+                            ;; '=' [\t ]* r1:r0:[0-9A-F] r2:[0-9A-F]
+                            `(write-read-repeat
+                              r0
+                              ,(vconcat
+                                (mapcar
+                                 (lambda (r0)
+                                   (logior (lsh r0 4) tmp))
+                                 mel-ccl-16-table)))
+                          ;; '=' [\t ]* r1:r0:[0-9A-F] r2:[^0-9A-F]
+                          ;; invalid input
+                          `(r3 = 0)    ; nop
+                          ))
+                      mel-ccl-256-table))
+                  ;; '=' [\t ]* r1:r0:[0-9A-F] r2:[^0-9A-F]
+                  ;; invalid input ->
+                  ;; output "=" with hex digit and rescan from r2.
+                  (write ?=)
+                  (r0 = (r2 + 0))
+                  (write-repeat r1)))
+               (t
+                ;; r0:[^\t\r -~]
+                ;; invalid character found.
+                ;; -> ignore.
+                `((read r0)
+                  (repeat))))))
+          mel-ccl-256-table))
+      ;; r1[0]:[\t ]
+      (loop
+       ,@(apply
+         'append
+         (mapcar
+          (lambda (regnum)
+            (let ((reg (aref [r1 r2 r3 r4 r5] regnum)))
+              (apply
+               'append
+               (mapcar
+                (lambda (bit)
+                  (if (= bit 0)
+                      (if (= regnum 0)
+                          nil
+                        `((read r0)
+                          (if (r0 == ?\t)
+                              (,reg = 0)
+                            (if (r0 == ?\ )
+                                (,reg = 1)
+                              ((r6 = ,(+ (* regnum 28) bit))
+                               (break))))))
+                    `((read r0)
+                      (if (r0 == ?\ )
+                          (,reg |= ,(lsh 1 bit))
+                        (if (r0 != ?\t)
+                            ((r6 = ,(+ (* regnum 28) bit))
+                             (break)))))))
+                mel-ccl-28-table))))
+          '(0 1 2 3 4)))
+       ;; white space buffer exhaust.
+       ;; error: line length limit (76bytes) violation.
+       ;; -> ignore these white spaces.
+       (repeat))
+      ,(if input-crlf
+           `(if (r0 == ?\r)
+                ((read r0)
+                 (if (r0 == ?\n)
+                     ;; trailing white spaces found.
+                     ;; -> ignore these white spacs.
+                     ((write ,(if output-crlf "\r\n" "\n"))
+                      (read r0)
+                      (repeat))
+                   ;; [\t ]* \r r0:[^\n]
+                   ;; error: bare CR found.
+                   ;; -> output white spaces and ignore bare CR.
+                   ))
+              ;; [\t ]* r0:[^\r]
+              ;; middle white spaces found.
+              )
+         `(if (r0 == ?\n)
+              ;; trailing white spaces found.
+              ;; -> ignore these white spacs.
+              ((write ,(if output-crlf "\r\n" "\n"))
+               (read r0)
+               (repeat))
+            ;; [\t ]* r0:[^\n]
+            ;; middle white spaces found.
+            ))
+      ,@(apply
+        'append
+        (mapcar
+         (lambda (regnum)
+           (let ((reg (aref [r1 r2 r3 r4 r5] regnum)))
+             (apply
+              'append
+              (mapcar
+               (lambda (bit)
+                 `((if (,reg & ,(lsh 1 bit))
+                       (write ?\ )
+                     (write ?\t))
+                   (if (r6 == ,(+ (* regnum 28) bit 1))
+                       (repeat))))
+               mel-ccl-28-table))))
+         '(0 1 2 3 4)))
+      (repeat)
+      ))))
+
+)
+
+(define-ccl-program mel-ccl-encode-quoted-printable-crlf-crlf
+  (mel-ccl-encode-quoted-printable-generic t t))
+
+(define-ccl-program mel-ccl-encode-quoted-printable-crlf-lf
+  (mel-ccl-encode-quoted-printable-generic t nil))
+
+(define-ccl-program mel-ccl-encode-quoted-printable-lf-crlf
+  (mel-ccl-encode-quoted-printable-generic nil t))
+
+(define-ccl-program mel-ccl-encode-quoted-printable-lf-lf
+  (mel-ccl-encode-quoted-printable-generic nil nil))
+
+(define-ccl-program mel-ccl-decode-quoted-printable-crlf-crlf
+  (mel-ccl-decode-quoted-printable-generic t t))
+
+(define-ccl-program mel-ccl-decode-quoted-printable-crlf-lf
+  (mel-ccl-decode-quoted-printable-generic t nil))
+
+(define-ccl-program mel-ccl-decode-quoted-printable-lf-crlf
+  (mel-ccl-decode-quoted-printable-generic nil t))
+
+(define-ccl-program mel-ccl-decode-quoted-printable-lf-lf
+  (mel-ccl-decode-quoted-printable-generic nil nil))
+
+
+;;; @ coding system
+;;;
+
+(make-ccl-coding-system
+ 'mel-ccl-uq-rev ?Q "MIME Q-encoding in unstructured field (reversed)"
+ 'mel-ccl-encode-uq 'mel-ccl-decode-q)
+
+(make-ccl-coding-system
+ 'mel-ccl-cq-rev ?Q "MIME Q-encoding in comment (reversed)"
+ 'mel-ccl-encode-cq 'mel-ccl-decode-q)
+
+(make-ccl-coding-system
+ 'mel-ccl-pq-rev ?Q "MIME Q-encoding in phrase (reversed)"
+ 'mel-ccl-encode-pq 'mel-ccl-decode-q)
+
+(make-ccl-coding-system
+ 'mel-ccl-quoted-printable-crlf-crlf-rev
+ ?Q "MIME Quoted-Printable-encoding (reversed)"
+ 'mel-ccl-encode-quoted-printable-crlf-crlf
+ 'mel-ccl-decode-quoted-printable-crlf-crlf)
+
+(make-ccl-coding-system
+ 'mel-ccl-quoted-printable-lf-crlf-rev
+ ?Q "MIME Quoted-Printable-encoding (LF encoding) (reversed)"
+ 'mel-ccl-encode-quoted-printable-crlf-lf
+ 'mel-ccl-decode-quoted-printable-lf-crlf)
+
+(make-ccl-coding-system
+ 'mel-ccl-quoted-printable-crlf-lf-rev
+ ?Q "MIME Quoted-Printable-encoding (LF internal) (reversed)"
+ 'mel-ccl-encode-quoted-printable-lf-crlf
+ 'mel-ccl-decode-quoted-printable-crlf-lf)
+
+(make-ccl-coding-system
+ 'mel-ccl-quoted-printable-lf-lf-rev
+ ?Q "MIME Quoted-Printable-encoding (LF encoding) (LF internal) (reversed)"
+ 'mel-ccl-encode-quoted-printable-lf-lf
+ 'mel-ccl-decode-quoted-printable-lf-lf)
+
+
+;;; @ quoted-printable
+;;;
+
+(check-broken-facility ccl-execute-eof-block-on-decoding-some)
+
+(unless-broken ccl-execute-eof-block-on-decoding-some
+
+  (defun quoted-printable-ccl-encode-string (string)
+    "Encode STRING with quoted-printable encoding."
+    (decode-coding-string
+     string
+     'mel-ccl-quoted-printable-lf-lf-rev))
+
+  (defun quoted-printable-ccl-encode-region (start end)
+    "Encode the region from START to END with quoted-printable encoding."
+    (interactive "*r")
+    (decode-coding-region start end 'mel-ccl-quoted-printable-lf-lf-rev))
+
+  (defun quoted-printable-ccl-insert-encoded-file (filename)
+    "Encode contents of the file named as FILENAME, and insert it."
+    (interactive "*fInsert encoded file: ")
+    (let ((coding-system-for-read 'mel-ccl-quoted-printable-lf-lf-rev)
+         format-alist)
+      (insert-file-contents filename)))
+
+  (mel-define-method-function
+   (mime-encode-string string (nil "quoted-printable"))
+   'quoted-printable-ccl-encode-string)
+  (mel-define-method-function
+   (mime-encode-region start end (nil "quoted-printable"))
+   'quoted-printable-ccl-encode-region)
+  (mel-define-method-function
+   (mime-insert-encoded-file filename (nil "quoted-printable"))
+   'quoted-printable-ccl-insert-encoded-file)
+  )
+
+(defun quoted-printable-ccl-decode-string (string)
+  "Decode quoted-printable encoded STRING."
+  (encode-coding-string
+   string
+   'mel-ccl-quoted-printable-lf-lf-rev))
+
+(defun quoted-printable-ccl-decode-region (start end)
+  "Decode the region from START to END with quoted-printable
+encoding."
+  (interactive "*r")
+  (encode-coding-region start end 'mel-ccl-quoted-printable-lf-lf-rev))
+
+(defun quoted-printable-ccl-write-decoded-region (start end filename)
+  "Decode quoted-printable encoded current region and write out to FILENAME."
+  (interactive "*r\nFWrite decoded region to file: ")
+  (let ((coding-system-for-write 'mel-ccl-quoted-printable-lf-lf-rev)
+       jka-compr-compression-info-list jam-zcat-filename-list)
+    (write-region start end filename)))
+
+(mel-define-method-function
+ (mime-decode-string string (nil "quoted-printable"))
+ 'quoted-printable-ccl-decode-string)
+(mel-define-method-function
+ (mime-decode-region start end (nil "quoted-printable"))
+ 'quoted-printable-ccl-decode-region)
+(mel-define-method-function
+ (mime-write-decoded-region start end filename (nil "quoted-printable"))
+ 'quoted-printable-ccl-write-decoded-region)
+
+
+;;; @ Q
+;;;
+
+(defun q-encoding-ccl-encode-string (string &optional mode)
+  "Encode STRING to Q-encoding of encoded-word, and return the result.
+MODE allows `text', `comment', `phrase' or nil.  Default value is
+`phrase'."
+  (decode-coding-string
+   string
+   (cond
+    ((eq mode 'text) 'mel-ccl-uq-rev)
+    ((eq mode 'comment) 'mel-ccl-cq-rev)
+    (t 'mel-ccl-pq-rev))))
+
+(defun q-encoding-ccl-decode-string (string)
+  "Decode Q encoded STRING and return the result."
+  (encode-coding-string
+   string
+   'mel-ccl-uq-rev))
+
+(unless (featurep 'xemacs)
+  (defun q-encoding-ccl-encoded-length (string &optional mode)
+    (let ((status [nil nil nil nil nil nil nil nil nil]))
+      (fillarray status nil)           ; XXX: Is this necessary?
+      (ccl-execute-on-string
+       (cond
+       ((eq mode 'text) 'mel-ccl-count-uq)
+       ((eq mode 'comment) 'mel-ccl-count-cq)
+       (t 'mel-ccl-count-pq))
+       status
+       string)
+      (aref status 0)))
+  )
+
+(mel-define-method-function (encoded-text-encode-string string (nil "Q"))
+                           'q-encoding-ccl-encode-string)
+
+(mel-define-method encoded-text-decode-string (string (nil "Q"))
+  (if (string-match (eval-when-compile
+                     (concat "\\`" Q-encoded-text-regexp "\\'"))
+                   string)
+      (q-encoding-ccl-decode-string string)
+    (error "Invalid encoded-text %s" string)))
+
+
+;;; @ end
+;;;
+
+(provide 'mel-q-ccl)
+
+;;; mel-q-ccl.el ends here.
diff --git a/mime/mel-u.el b/mime/mel-u.el
new file mode 100644 (file)
index 0000000..ead3efb
--- /dev/null
@@ -0,0 +1,163 @@
+;;; mel-u.el --- uuencode encoder/decoder.
+
+;; Copyright (C) 1995,1996,1997,1998,1999 Free Software Foundation, Inc.
+
+;; Author: MORIOKA Tomohiko <tomo@m17n.org>
+;; Created: 1995/10/25
+;; Keywords: uuencode
+
+;; This file is part of FLIM (Faithful Library about Internet Message).
+
+;; 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 this program; see the file COPYING.  If not, write to the
+;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Code:
+
+(require 'mime-def)
+(require 'path-util)
+
+
+(mel-define-backend "x-uue")
+
+
+;;; @ variables
+;;;
+
+(defvar uuencode-external-encoder '("uuencode" "-")
+  "*list of uuencode encoder program name and its arguments.")
+
+(defvar uuencode-external-decoder '("sh" "-c" "uudecode")
+  "*list of uuencode decoder program name and its arguments.")
+
+
+;;; @ uuencode encoder/decoder for region
+;;;
+
+(defun uuencode-external-encode-region (start end)
+  "Encode current region by unofficial uuencode format.
+This function uses external uuencode encoder which is specified by
+variable `uuencode-external-encoder'."
+  (interactive "*r")
+  (save-excursion
+    (let ((coding-system-for-read  'binary)
+         (coding-system-for-write 'binary))
+      (apply (function call-process-region)
+            start end (car uuencode-external-encoder)
+            t t nil
+            (cdr uuencode-external-encoder)))
+    ;; for OS/2
+    ;;   regularize line break code
+    (goto-char (point-min))
+    (while (re-search-forward "\r$" nil t)
+      (replace-match ""))))
+
+(defun uuencode-external-decode-region (start end)
+  "Decode current region by unofficial uuencode format.
+This function uses external uuencode decoder which is specified by
+variable `uuencode-external-decoder'."
+  (interactive "*r")
+  (save-excursion
+    (let ((filename (save-excursion
+                     (save-restriction
+                       (narrow-to-region start end)
+                       (goto-char start)
+                       (if (re-search-forward "^begin [0-9]+ " nil t)
+                           (if (looking-at ".+$")
+                               (buffer-substring (match-beginning 0)
+                                                 (match-end 0)))))))
+         (default-directory temporary-file-directory))
+      (if filename
+         (let ((coding-system-for-read  'binary)
+               (coding-system-for-write 'binary))
+           (apply (function call-process-region)
+                  start end (car uuencode-external-decoder)
+                  t nil nil
+                  (cdr uuencode-external-decoder))
+           (insert-file-contents filename)
+           ;; The previous line causes the buffer to be made read-only, I
+           ;; do not pretend to understand the control flow leading to this
+           ;; but suspect it has something to do with image-mode. -slb
+           ;;  Use `inhibit-read-only' to avoid to force
+           ;;  buffer-read-only nil. - tomo.
+           (let ((inhibit-read-only t))
+             (delete-file filename)))))))
+
+(mel-define-method-function (mime-encode-region start end (nil "x-uue"))
+                           'uuencode-external-encode-region)
+(mel-define-method-function (mime-decode-region start end (nil "x-uue"))
+                           'uuencode-external-decode-region)
+
+
+;;; @ encoder/decoder for string
+;;;
+
+(mel-define-method mime-encode-string (string (nil "x-uue"))
+  (with-temp-buffer
+    (insert string)
+    (uuencode-external-encode-region (point-min)(point-max))
+    (buffer-string)))
+
+(mel-define-method mime-decode-string (string (nil "x-uue"))
+  (with-temp-buffer
+    (insert string)
+    (uuencode-external-decode-region (point-min)(point-max))
+    (buffer-string)))
+
+
+;;; @ uuencode encoder/decoder for file
+;;;
+
+(mel-define-method mime-insert-encoded-file (filename (nil "x-uue"))
+  "Insert file encoded by unofficial uuencode format.
+This function uses external uuencode encoder which is specified by
+variable `uuencode-external-encoder'."
+  (interactive "*fInsert encoded file: ")
+  (call-process (car uuencode-external-encoder)
+               filename t nil
+               (file-name-nondirectory filename)))
+
+(mel-define-method mime-write-decoded-region (start end filename
+                                                   (nil "x-uue"))
+  "Decode and write current region encoded by uuencode into FILENAME.
+START and END are buffer positions."
+  (interactive "*r\nFWrite decoded region to file: ")
+  (save-excursion
+    (let ((file (save-excursion
+                 (save-restriction
+                   (narrow-to-region start end)
+                   (goto-char start)
+                   (if (re-search-forward "^begin [0-9]+ " nil t)
+                       (if (looking-at ".+$")
+                           (buffer-substring (match-beginning 0)
+                                             (match-end 0)))))))
+         (default-directory temporary-file-directory))
+      (if file
+         (let ((coding-system-for-read  'binary)
+               (coding-system-for-write 'binary))
+           (apply (function call-process-region)
+                  start end (car uuencode-external-decoder)
+                  nil nil nil
+                  (cdr uuencode-external-decoder))
+           (rename-file file filename 'overwrites))))))
+
+
+;;; @ end
+;;;
+
+(provide 'mel-u)
+
+(mel-define-backend "x-uuencode" ("x-uue"))
+
+;;; mel-u.el ends here.
diff --git a/mime/mel.el b/mime/mel.el
new file mode 100644 (file)
index 0000000..1a1c7d2
--- /dev/null
@@ -0,0 +1,343 @@
+;;; mel.el --- A MIME encoding/decoding library.
+
+;; Copyright (C) 1995,1996,1997,1998,1999,2000 Free Software Foundation, Inc.
+
+;; Author: MORIOKA Tomohiko <tomo@m17n.org>
+;; Created: 1995/6/25
+;; Keywords: MIME, Base64, Quoted-Printable, uuencode, gzip64
+
+;; This file is part of FLIM (Faithful Library about Internet Message).
+
+;; 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 this program; see the file COPYING.  If not, write to the
+;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Code:
+
+(require 'mime-def)
+(require 'alist)
+
+(defcustom mime-encoding-list
+  '("7bit" "8bit" "binary" "base64" "quoted-printable")
+  "List of Content-Transfer-Encoding.  Each encoding must be string."
+  :group 'mime
+  :type '(repeat string))
+
+(defun mime-encoding-list (&optional service)
+  "Return list of Content-Transfer-Encoding.
+If SERVICE is specified, it returns available list of
+Content-Transfer-Encoding for it."
+  (if service
+      (let (dest)
+       (mapatoms (lambda (sym)
+                   (or (eq sym nil)
+                       (setq dest (cons (symbol-name sym) dest)))
+                   )
+                 (symbol-value (intern (format "%s-obarray" service))))
+       (let ((rest mel-encoding-module-alist)
+             pair)
+         (while (setq pair (car rest))
+           (let ((key (car pair)))
+             (or (member key dest)
+                 (<= (length key) 1)
+                 (setq dest (cons key dest))))
+           (setq rest (cdr rest)))
+         )
+       dest)
+    mime-encoding-list))
+
+(defun mime-encoding-alist (&optional service)
+  "Return table of Content-Transfer-Encoding for completion."
+  (mapcar #'list (mime-encoding-list service)))
+
+(defsubst mel-use-module (name encodings)
+  (while encodings
+    (set-alist 'mel-encoding-module-alist
+              (car encodings)
+              (cons name (cdr (assoc (car encodings)
+                                     mel-encoding-module-alist))))
+    (setq encodings (cdr encodings))))
+
+(defsubst mel-find-function (service encoding)
+  (mel-find-function-from-obarray
+   (symbol-value (intern (format "%s-obarray" service))) encoding))
+
+
+;;; @ setting for modules
+;;;
+
+(defun 8bit-insert-encoded-file (filename)
+  "Insert file FILENAME encoded by \"7bit\" format."
+  (let ((coding-system-for-read 'raw-text)
+       format-alist)
+    ;; Returns list of absolute file name and length of data inserted.
+    (insert-file-contents filename)))
+
+(defun 8bit-write-decoded-region (start end filename)
+  "Decode and write current region encoded by \"8bit\" into FILENAME."
+  (let ((coding-system-for-write 'raw-text)
+       format-alist)
+    (write-region start end filename)))
+
+(mel-define-backend "8bit")
+(mel-define-method-function (mime-encode-string string (nil "8bit"))
+                           'identity)
+(mel-define-method-function (mime-decode-string string (nil "8bit"))
+                           'identity)
+(mel-define-method mime-encode-region (start end (nil "8bit")))
+(mel-define-method mime-decode-region (start end (nil "8bit")))
+(mel-define-method-function (mime-insert-encoded-file filename (nil "8bit"))
+                           '8bit-insert-encoded-file)
+(mel-define-method-function (mime-write-decoded-region
+                            start end filename (nil "8bit"))
+                           '8bit-write-decoded-region)
+
+
+(defalias '7bit-insert-encoded-file '8bit-insert-encoded-file)
+(defalias '7bit-write-decoded-region '8bit-write-decoded-region)
+
+(mel-define-backend "7bit" ("8bit"))
+
+
+(defun binary-write-decoded-region (start end filename)
+  "Decode and write current region encoded by \"binary\" into FILENAME."
+  (let ((coding-system-for-write 'binary)
+       jka-compr-compression-info-list jam-zcat-filename-list)
+    (write-region start end filename)))
+
+(defalias 'binary-insert-encoded-file 'insert-file-contents-literally)
+
+(defun binary-find-file-noselect (filename &optional nowarn rawfile)
+  "Like `find-file-noselect', q.v., but don't code and format conversion."
+  (let ((coding-system-for-read 'binary)
+       format-alist)
+    (find-file-noselect filename nowarn rawfile)))
+
+(defun binary-funcall (name &rest args)
+  "Like `funcall', q.v., but read and write as binary."
+  (let ((coding-system-for-read 'binary)
+       (coding-system-for-write 'binary))
+    (apply name args)))
+
+(defun binary-to-text-funcall (coding-system name &rest args)
+  "Like `funcall', q.v., but write as binary and read as text.
+Read text is decoded as CODING-SYSTEM."
+  (let ((coding-system-for-read coding-system)
+       (coding-system-for-write 'binary))
+    (apply name args)))
+
+(mel-define-backend "binary")
+(mel-define-method-function (mime-encode-string string (nil "binary"))
+                           'identity)
+(mel-define-method-function (mime-decode-string string (nil "binary"))
+                           'identity)
+(mel-define-method mime-encode-region (start end (nil "binary")))
+(mel-define-method mime-decode-region (start end (nil "binary")))
+(mel-define-method-function (mime-insert-encoded-file filename (nil "binary"))
+                           'binary-insert-encoded-file)
+(mel-define-method-function (mime-write-decoded-region
+                            start end filename (nil "binary"))
+                           'binary-write-decoded-region)
+
+(defvar mel-b-builtin
+   (and (fboundp 'base64-encode-string)
+        (subrp (symbol-function 'base64-encode-string))))
+
+(when mel-b-builtin
+  (mel-define-backend "base64")
+  (mel-define-method-function (mime-encode-string string (nil "base64"))
+                             'base64-encode-string)
+  (mel-define-method-function (mime-decode-string string (nil "base64"))
+                             'base64-decode-string)
+  (mel-define-method-function (mime-encode-region start end (nil "base64"))
+                             'base64-encode-region)
+  (mel-define-method-function (mime-decode-region start end (nil "base64"))
+                             'base64-decode-region)  
+  (mel-define-method mime-insert-encoded-file (filename (nil "base64"))
+    "Encode contents of file FILENAME to base64, and insert the result.
+It calls external base64 encoder specified by
+`base64-external-encoder'.  So you must install the program (maybe
+mmencode included in metamail or XEmacs package)."
+    (interactive "*fInsert encoded file: ")
+    (insert (base64-encode-string
+            (with-temp-buffer
+              (set-buffer-multibyte nil)
+              (binary-insert-encoded-file filename)
+              (buffer-string))))
+    (or (bolp) (insert ?\n)))
+    
+  ;; (mel-define-method-function (encoded-text-encode-string string (nil "B"))
+  ;;                             'base64-encode-string)
+  (mel-define-method encoded-text-decode-string (string (nil "B"))
+    (if (string-match (eval-when-compile
+                       (concat "\\`" B-encoded-text-regexp "\\'"))
+                     string)
+       (base64-decode-string string)
+      (error "Invalid encoded-text %s" string)))
+  )
+
+(mel-use-module 'mel-b-el '("base64" "B"))
+(mel-use-module 'mel-q '("quoted-printable" "Q"))
+(mel-use-module 'mel-g '("x-gzip64"))
+(mel-use-module 'mel-u '("x-uue" "x-uuencode"))
+
+(defvar mel-b-ccl-module
+  (and (featurep 'mule)
+       (progn
+        (require 'path-util)
+        (module-installed-p 'mel-b-ccl))))
+
+(defvar mel-b-module
+  (and (featurep 'mule)
+       (progn
+        (require 'path-util)
+        (module-installed-p 'mel-b))))
+
+(defvar mel-q-ccl-module
+  (and (featurep 'mule)
+       (progn
+        (require 'path-util)
+        (module-installed-p 'mel-q-ccl))))
+
+(when mel-b-ccl-module
+  (mel-use-module 'mel-b-ccl '("base64" "B")))
+
+(when mel-b-module
+  (mel-use-module 'mel-b '("base64" "B")))
+
+(when mel-q-ccl-module
+  (mel-use-module 'mel-q-ccl '("quoted-printable" "Q")))
+
+(when base64-dl-module
+  (mel-use-module 'mel-b-dl '("base64" "B")))
+
+
+;;; @ region
+;;;
+
+;;;###autoload
+(defun mime-encode-region (start end encoding)
+  "Encode region START to END of current buffer using ENCODING.
+ENCODING must be string."
+  (interactive
+   (list (region-beginning)(region-end)
+        (completing-read "Encoding: "
+                         (mime-encoding-alist)
+                         nil t "base64")))
+  (funcall (mel-find-function 'mime-encode-region encoding) start end))
+
+
+;;;###autoload
+(defun mime-decode-region (start end encoding)
+  "Decode region START to END of current buffer using ENCODING.
+ENCODING must be string."
+  (interactive
+   (list (region-beginning)(region-end)
+        (completing-read "Encoding: "
+                         (mime-encoding-alist 'mime-decode-region)
+                         nil t "base64")))
+  (funcall (mel-find-function 'mime-decode-region encoding)
+          start end))
+
+
+;;; @ string
+;;;
+
+;;;###autoload
+(defun mime-decode-string (string encoding)
+  "Decode STRING using ENCODING.
+ENCODING must be string.  If ENCODING is found in
+`mime-string-decoding-method-alist' as its key, this function decodes
+the STRING by its value."
+  (let ((f (mel-find-function 'mime-decode-string encoding)))
+    (if f
+       (funcall f string)
+      string)))
+
+
+(mel-define-service encoded-text-encode-string)
+(defun encoded-text-encode-string (string encoding &optional mode)
+  "Encode STRING as encoded-text using ENCODING.
+ENCODING must be string.
+Optional argument MODE allows `text', `comment', `phrase' or nil.
+Default value is `phrase'."
+  (if (string= encoding "B")
+      (base64-encode-string string 'no-line-break)
+    (let ((f (mel-find-function 'encoded-text-encode-string encoding)))
+      (if f
+         (funcall f string mode)
+       string))))
+
+(mel-define-service encoded-text-decode-string (string encoding)
+  "Decode STRING as encoded-text using ENCODING.  ENCODING must be string.")
+
+(defun base64-encoded-length (string)
+  (* (/ (+ (length string) 2) 3) 4))
+
+(defsubst Q-encoding-printable-char-p (chr mode)
+  (and (not (memq chr '(?= ?? ?_)))
+       (<= ?\  chr)(<= chr ?~)
+       (cond ((eq mode 'text) t)
+            ((eq mode 'comment)
+             (not (memq chr '(?\( ?\) ?\\))))
+            (t
+             (string-match "[A-Za-z0-9!*+/=_---]" (char-to-string chr))))))
+
+(defun Q-encoded-text-length (string &optional mode)
+  (let ((l 0)(i 0)(len (length string)) chr)
+    (while (< i len)
+      (setq chr (aref string i))
+      (if (or (Q-encoding-printable-char-p chr mode)
+             (eq chr ? ))
+         (setq l (+ l 1))
+       (setq l (+ l 3)))
+      (setq i (+ i 1)))
+    l))
+
+
+;;; @ file
+;;;
+
+;;;###autoload
+(defun mime-insert-encoded-file (filename encoding)
+  "Insert file FILENAME encoded by ENCODING format."
+  (interactive
+   (list (read-file-name "Insert encoded file: ")
+        (completing-read "Encoding: "
+                         (mime-encoding-alist)
+                         nil t "base64")))
+  (funcall (mel-find-function 'mime-insert-encoded-file encoding)
+          filename))
+
+
+;;;###autoload
+(defun mime-write-decoded-region (start end filename encoding)
+  "Decode and write current region encoded by ENCODING into FILENAME.
+START and END are buffer positions."
+  (interactive
+   (list (region-beginning)(region-end)
+        (read-file-name "Write decoded region to file: ")
+        (completing-read "Encoding: "
+                         (mime-encoding-alist 'mime-write-decoded-region)
+                         nil t "base64")))
+  (funcall (mel-find-function 'mime-write-decoded-region encoding)
+          start end filename))
+
+
+;;; @ end
+;;;
+
+(provide 'mel)
+
+;;; mel.el ends here.
diff --git a/mime/mime-bbdb.el b/mime/mime-bbdb.el
new file mode 100644 (file)
index 0000000..1b61d64
--- /dev/null
@@ -0,0 +1,303 @@
+;;; mime-bbdb.el --- SEMI shared module for BBDB
+
+;; Copyright (C) 1995,1996,1997 Shuhei KOBAYASHI
+;; Copyright (C) 1997,1998 MORIOKA Tomohiko
+
+;; Author: Shuhei KOBAYASHI <shuhei-k@jaist.ac.jp>
+;; Maintainer: Shuhei KOBAYASHI <shuhei-k@jaist.ac.jp>
+;; Keywords: BBDB, MIME, multimedia, multilingual, mail, news
+
+;; This file is part of SEMI (Suite of Emacs MIME Interfaces).
+
+;; 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.
+
+;;; Code:
+
+(require 'path-util)
+(require 'std11)
+(require 'mime-view)
+
+(if (module-installed-p 'bbdb-com)
+    (require 'bbdb-com)
+  (eval-when-compile
+    ;; imported from bbdb-1.51
+    (defmacro bbdb-pop-up-elided-display ()
+      '(if (boundp 'bbdb-pop-up-elided-display)
+          bbdb-pop-up-elided-display
+        bbdb-elided-display))
+    (defmacro bbdb-user-mail-names ()
+      "Returns a regexp matching the address of the logged-in user"
+      '(or bbdb-user-mail-names
+          (setq bbdb-user-mail-names
+                (concat "\\b" (regexp-quote (user-login-name)) "\\b"))))
+    ))
+
+
+;;; @ User Variables
+;;;
+
+(defvar mime-bbdb/use-mail-extr t
+  "*If non-nil, `mail-extract-address-components' is used.
+Otherwise `mime-bbdb/extract-address-components' overrides it.")
+
+(defvar mime-bbdb/auto-create-p nil
+  "*If t, create new BBDB records automatically.
+If function, then it is called with no arguments to decide whether an
+entry should be automatically creaded.
+
+mime-bbdb uses this variable instead of `bbdb/mail-auto-create-p' or
+`bbdb/news-auto-create-p' unless other tm-MUA overrides it.")
+
+(defvar mime-bbdb/delete-empty-window nil
+  "*If non-nil, delete empty BBDB window.
+All bbdb-MUAs but bbdb-gnus display BBDB window even if it is empty.
+If you prefer behavior of bbdb-gnus, set this variable to t.
+
+For framepop users: If empty, `framepop-banish' is used instead.")
+
+;;; @ mail-extr
+;;;
+
+(defun mime-bbdb/extract-address-components (str)
+  (let* ((ret     (std11-extract-address-components str))
+         (phrase  (car ret))
+         (address (car (cdr ret)))
+         (methods mime-bbdb/canonicalize-full-name-methods))
+    (while (and phrase methods)
+      (setq phrase  (funcall (car methods) phrase)
+            methods (cdr methods)))
+    (if (string= address "") (setq address nil))
+    (if (string= phrase "") (setq phrase nil))
+    (list phrase address)
+    ))
+
+(or mime-bbdb/use-mail-extr
+    (progn
+      (require 'mail-extr) ; for `what-domain'
+      (or (fboundp 'tm:mail-extract-address-components)
+          (fset 'tm:mail-extract-address-components
+                (symbol-function 'mail-extract-address-components)))
+      (fset 'mail-extract-address-components
+           (symbol-function 'mime-bbdb/extract-address-components))
+      ))
+
+
+;;; @ bbdb-extract-field-value
+;;;
+
+(or (fboundp 'tm:bbdb-extract-field-value)
+    (progn
+      ;; (require 'bbdb-hooks) ; not provided.
+      ;; (or (fboundp 'bbdb-extract-field-value) ; defined as autoload
+      (or (fboundp 'bbdb-header-start)
+          (load "bbdb-hooks"))
+      (fset 'tm:bbdb-extract-field-value
+            (symbol-function 'bbdb-extract-field-value))
+      (defun bbdb-extract-field-value (field)
+        (let ((value (tm:bbdb-extract-field-value field)))
+          (and value
+               (eword-decode-string value))))
+      ))
+
+
+;;; @ full-name canonicalization methods
+;;;
+
+(defun mime-bbdb/canonicalize-spaces (str)
+  (let (dest)
+    (while (string-match "\\s +" str)
+      (setq dest (cons (substring str 0 (match-beginning 0)) dest))
+      (setq str (substring str (match-end 0)))
+      )
+    (or (string= str "")
+        (setq dest (cons str dest)))
+    (setq dest (nreverse dest))
+    (mapconcat 'identity dest " ")
+    ))
+
+(defun mime-bbdb/canonicalize-dots (str)
+  (let (dest)
+    (while (string-match "\\." str)
+      (setq dest (cons (substring str 0 (match-end 0)) dest))
+      (setq str (substring str (match-end 0)))
+      )
+    (or (string= str "")
+        (setq dest (cons str dest)))
+    (setq dest (nreverse dest))
+    (mapconcat 'identity dest " ")
+    ))
+
+(defvar mime-bbdb/canonicalize-full-name-methods
+  '(eword-decode-string
+    mime-bbdb/canonicalize-dots
+    mime-bbdb/canonicalize-spaces))
+
+
+;;; @ BBDB functions for mime-view-mode
+;;;
+
+(defun mime-bbdb/update-record (&optional offer-to-create)
+  "Return the record corresponding to the current MIME previewing message.
+Creating or modifying it as necessary. A record will be created if
+mime-bbdb/auto-create-p is non-nil, or if OFFER-TO-CREATE is non-nil and
+the user confirms the creation."
+  (save-excursion
+    (if (and mime-preview-buffer
+             (get-buffer mime-preview-buffer))
+        (set-buffer mime-preview-buffer))
+    (if bbdb-use-pop-up
+        (mime-bbdb/pop-up-bbdb-buffer offer-to-create)
+      (let* ((message (get-text-property (point-min) 'mime-view-entity))
+            (from (mime-entity-fetch-field message 'From))
+            addr)
+       (if (or (null from)
+                (null (setq addr (car (mime-entity-read-field message 'From))))
+                (string-match (bbdb-user-mail-names)
+                             (std11-address-string addr)))
+            (setq from (or (mime-entity-fetch-field message 'To)
+                          from))
+         )
+        (if from
+            (bbdb-annotate-message-sender
+             (mime-decode-field-body from 'From) t
+             (or (bbdb-invoke-hook-for-value mime-bbdb/auto-create-p)
+                 offer-to-create)
+             offer-to-create))
+        ))))
+
+(defun mime-bbdb/annotate-sender (string)
+  "Add a line to the end of the Notes field of the BBDB record
+corresponding to the sender of this message."
+  (interactive
+   (list (if bbdb-readonly-p
+             (error "The Insidious Big Brother Database is read-only.")
+           (read-string "Comments: "))))
+  (bbdb-annotate-notes (mime-bbdb/update-record t) string))
+
+(defun mime-bbdb/edit-notes (&optional arg)
+  "Edit the notes field or (with a prefix arg) a user-defined field
+of the BBDB record corresponding to the sender of this message."
+  (interactive "P")
+  (let ((record (or (mime-bbdb/update-record t)
+                    (error ""))))
+    (bbdb-display-records (list record))
+    (if arg
+       (bbdb-record-edit-property record nil t)
+      (bbdb-record-edit-notes record t))))
+
+(defun mime-bbdb/show-sender ()
+  "Display the contents of the BBDB for the sender of this message.
+This buffer will be in bbdb-mode, with associated keybindings."
+  (interactive)
+  (let ((record (mime-bbdb/update-record t)))
+    (if record
+       (bbdb-display-records (list record))
+       (error "unperson"))))
+
+(defun mime-bbdb/pop-up-bbdb-buffer (&optional offer-to-create)
+  "Make the *BBDB* buffer be displayed along with the MIME preview window(s),
+displaying the record corresponding to the sender of the current message."
+  (let ((framepop (eq temp-buffer-show-function 'framepop-display-buffer)))
+    (or framepop
+        (bbdb-pop-up-bbdb-buffer
+         (function
+          (lambda (w)
+            (let ((b (current-buffer)))
+              (set-buffer (window-buffer w))
+              (prog1 (eq major-mode 'mime-view-mode)
+                (set-buffer b)))))))
+    (let ((bbdb-gag-messages t)
+          (bbdb-use-pop-up nil)
+          (bbdb-electric-p nil))
+      (let ((record (mime-bbdb/update-record offer-to-create))
+            (bbdb-elided-display (bbdb-pop-up-elided-display))
+            (b (current-buffer)))
+        (if framepop
+            (if record
+                (bbdb-display-records (list record))
+              (framepop-banish))
+          (bbdb-display-records (if record (list record) nil))
+          (if (and (null record)
+                   mime-bbdb/delete-empty-window)
+              (delete-windows-on (get-buffer "*BBDB*"))))
+        (set-buffer b)
+        record))))
+
+(defun mime-bbdb/define-keys ()
+  (let ((mime-view-mode-map (current-local-map)))
+    (define-key mime-view-mode-map ";" 'mime-bbdb/edit-notes)
+    (define-key mime-view-mode-map ":" 'mime-bbdb/show-sender)
+    ))
+
+(add-hook 'mime-view-define-keymap-hook 'mime-bbdb/define-keys)
+
+
+;;; @ for signature.el
+;;;
+
+(defun signature/get-bbdb-sigtype (addr)
+  "Extract sigtype information from BBDB."
+  (let ((record (bbdb-search-simple nil addr)))
+    (and record
+         (bbdb-record-getprop record 'sigtype))
+    ))
+
+(defun signature/set-bbdb-sigtype (sigtype addr)
+  "Add sigtype information to BBDB."
+  (let* ((bbdb-notice-hook nil)
+         (record (bbdb-annotate-message-sender
+                  addr t
+                  (bbdb-invoke-hook-for-value
+                   bbdb/mail-auto-create-p)
+                  t)))
+    (if record
+        (progn
+          (bbdb-record-putprop record 'sigtype sigtype)
+          (bbdb-change-record record nil))
+      )))
+
+(defun signature/get-sigtype-from-bbdb (&optional verbose)
+  (let* ((to (std11-field-body "To"))
+         (addr (and to
+                    (car (cdr (mail-extract-address-components to)))))
+         (sigtype (signature/get-bbdb-sigtype addr))
+         return
+         )
+    (if addr
+        (if verbose
+            (progn
+              (setq return (signature/get-sigtype-interactively sigtype))
+              (if (and (not (string-equal return sigtype))
+                       (y-or-n-p
+                        (format "Register \"%s\" for <%s>? " return addr))
+                       )
+                  (signature/set-bbdb-sigtype return addr)
+                )
+              return)
+          (or sigtype
+              (signature/get-signature-file-name))
+          ))
+    ))
+
+
+;;; @ end
+;;;
+
+(provide 'mime-bbdb)
+
+(run-hooks 'mime-bbdb-load-hook)
+
+;;; end of mime-bbdb.el
diff --git a/mime/mime-conf.el b/mime/mime-conf.el
new file mode 100644 (file)
index 0000000..84fed40
--- /dev/null
@@ -0,0 +1,277 @@
+;;; mime-conf.el --- mailcap parser and MIME playback configuration
+
+;; Copyright (C) 1997,1998,1999,2000 Free Software Foundation, Inc.
+
+;; Author: MORIOKA Tomohiko <tomo@m17n.org>
+;; Created: 1997-06-27
+;; Original: 1997-06-27 mailcap.el by MORIOKA Tomohiko
+;;     Renamed: 2000-11-24 to mime-conf.el by MORIOKA Tomohiko
+;; Keywords: mailcap, setting, configuration, MIME, multimedia
+
+;; This file is part of FLIM (Faithful Library about Internet Message).
+
+;; 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.
+
+;;; Code:
+
+(require 'mime-def)
+
+
+;;; @ comment
+;;;
+
+(defsubst mime-mailcap-skip-comment ()
+  (let ((chr (char-after (point))))
+    (when (and chr
+              (or (= chr ?\n)
+                  (= chr ?#)))
+      (forward-line)
+      t)))
+
+
+;;; @ token
+;;;
+
+(defsubst mime-mailcap-look-at-token ()
+  (if (looking-at mime-token-regexp)
+      (let ((beg (match-beginning 0))
+           (end (match-end 0)))
+       (goto-char end)
+       (buffer-substring beg end)
+       )))
+
+
+;;; @ typefield
+;;;
+
+(defsubst mime-mailcap-look-at-type-field ()
+  (let ((type (mime-mailcap-look-at-token)))
+    (if type
+       (if (eq (char-after (point)) ?/)
+           (progn
+             (forward-char)
+             (let ((subtype (mime-mailcap-look-at-token)))
+               (if subtype
+                   (cons (cons 'type (intern type))
+                         (unless (string= subtype "*")
+                           (list (cons 'subtype (intern subtype)))
+                           )))))
+         (list (cons 'type (intern type)))
+         ))))
+
+
+;;; @ field separator
+;;;
+
+(defsubst mime-mailcap-skip-field-separator ()
+  (let ((ret (looking-at "\\([ \t]\\|\\\\\n\\)*;\\([ \t]\\|\\\\\n\\)*")))
+    (when ret
+      (goto-char (match-end 0))
+      t)))
+
+
+;;; @ mtext
+;;;
+
+(defsubst mime-mailcap-look-at-schar ()
+  (let ((chr (char-after (point))))
+    (if (and chr
+            (>= chr ? )
+            (/= chr ?\;)
+            (/= chr ?\\)
+            )
+       (prog1
+           chr
+         (forward-char)))))
+
+(defsubst mime-mailcap-look-at-qchar ()
+  (when (eq (char-after (point)) ?\\)
+    (prog2
+       (forward-char)
+       (char-after (point))
+      (forward-char))))
+
+(defsubst mime-mailcap-look-at-mtext ()
+  (let ((beg (point)))
+    (while (or (mime-mailcap-look-at-qchar)
+              (mime-mailcap-look-at-schar)))
+    (buffer-substring beg (point))
+    ))
+
+
+;;; @ field
+;;;
+
+(defsubst mime-mailcap-look-at-field ()
+  (let ((token (mime-mailcap-look-at-token)))
+    (if token
+       (if (looking-at "[ \t]*=[ \t]*")
+           (let ((value (progn
+                          (goto-char (match-end 0))
+                          (mime-mailcap-look-at-mtext))))
+             (if value
+                 (cons (intern token) value)
+               ))
+         (list (intern token))
+         ))))
+
+
+;;; @ mailcap entry
+;;;
+
+(defun mime-mailcap-look-at-entry ()
+  (let ((type (mime-mailcap-look-at-type-field)))
+    (if (and type (mime-mailcap-skip-field-separator))
+       (let ((view (mime-mailcap-look-at-mtext))
+             fields field)
+         (when view
+           (while (and (mime-mailcap-skip-field-separator)
+                       (setq field (mime-mailcap-look-at-field))
+                       )
+             (setq fields (cons field fields))
+             )
+           (nconc type
+                  (list (cons 'view view))
+                  fields))))))
+
+
+;;; @ main
+;;;
+
+;;;###autoload
+(defun mime-parse-mailcap-buffer (&optional buffer order)
+  "Parse BUFFER as a mailcap, and return the result.
+If optional argument ORDER is a function, result is sorted by it.
+If optional argument ORDER is not specified, result is sorted original
+order.  Otherwise result is not sorted."
+  (save-excursion
+    (if buffer
+       (set-buffer buffer))
+    (goto-char (point-min))
+    (let (entries entry)
+      (while (progn
+              (while (mime-mailcap-skip-comment))
+              (setq entry (mime-mailcap-look-at-entry))
+              )
+       (setq entries (cons entry entries))
+       (forward-line)
+       )
+      (cond ((functionp order) (sort entries order))
+           ((null order) (nreverse entries))
+           (t entries)
+           ))))
+
+
+;;;###autoload
+(defcustom mime-mailcap-file "~/.mailcap"
+  "*File name of user's mailcap file."
+  :group 'mime
+  :type 'file)
+
+;;;###autoload
+(defun mime-parse-mailcap-file (&optional filename order)
+  "Parse FILENAME as a mailcap, and return the result.
+If optional argument ORDER is a function, result is sorted by it.
+If optional argument ORDER is not specified, result is sorted original
+order.  Otherwise result is not sorted."
+  (or filename
+      (setq filename mime-mailcap-file))
+  (with-temp-buffer
+    (insert-file-contents filename)
+    (mime-parse-mailcap-buffer (current-buffer) order)
+    ))
+
+
+;;;###autoload
+(defun mime-format-mailcap-command (mtext situation)
+  "Return formated command string from MTEXT and SITUATION.
+
+MTEXT is a command text of mailcap specification, such as
+view-command.
+
+SITUATION is an association-list about information of entity.  Its key
+may be:
+
+       'type           primary media-type
+       'subtype        media-subtype
+       'filename       filename
+       STRING          parameter of Content-Type field"
+  (let ((i 0)
+       (len (length mtext))
+       (p 0)
+       dest)
+    (while (< i len)
+      (let ((chr (aref mtext i)))
+       (cond ((eq chr ?%)
+              (setq i (1+ i)
+                    chr (aref mtext i))
+              (cond ((eq chr ?s)
+                     (let ((file (cdr (assq 'filename situation))))
+                       (if (null file)
+                           (error "'filename is not specified in situation.")
+                         (setq dest (concat dest
+                                            (substring mtext p (1- i))
+                                            file)
+                               i (1+ i)
+                               p i)
+                         )))
+                    ((eq chr ?t)
+                     (let ((type (or (mime-type/subtype-string
+                                      (cdr (assq 'type situation))
+                                      (cdr (assq 'subtype situation)))
+                                     "text/plain")))
+                       (setq dest (concat dest
+                                          (substring mtext p (1- i))
+                                          type)
+                             i (1+ i)
+                             p i)
+                       ))
+                    ((eq chr ?\{)
+                     (setq i (1+ i))
+                     (if (not (string-match "}" mtext i))
+                         (error "parse error!!!")
+                       (let* ((me (match-end 0))
+                              (attribute (substring mtext i (1- me)))
+                              (parameter (cdr (assoc attribute situation))))
+                         (if (null parameter)
+                             (error "\"%s\" is not specified in situation."
+                                    attribute)
+                           (setq dest (concat dest
+                                              (substring mtext p (- i 2))
+                                              parameter)
+                                 i me
+                                 p i)
+                           )
+                         )))
+                    (t (error "Invalid sequence `%%%c'." chr))
+                    ))
+             ((eq chr ?\\)
+              (setq dest (concat dest (substring mtext p i))
+                    p (1+ i)
+                    i (+ i 2))
+              )
+             (t (setq i (1+ i)))
+             )))
+    (concat dest (substring mtext p))
+    ))
+
+
+;;; @ end
+;;;
+
+(provide 'mime-conf)
+
+;;; mime-conf.el ends here
diff --git a/mime/mime-def.el b/mime/mime-def.el
new file mode 100644 (file)
index 0000000..5ff449e
--- /dev/null
@@ -0,0 +1,402 @@
+;;; mime-def.el --- definition module about MIME -*- coding: iso-8859-4; -*-
+
+;; Copyright (C) 1995,96,97,98,99,2000 Free Software Foundation, Inc.
+
+;; Author: MORIOKA Tomohiko <tomo@m17n.org>
+;; Keywords: definition, MIME, multimedia, mail, news
+
+;; This file is part of FLIM (Faithful Library about Internet Message).
+
+;; 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.
+
+;;; Code:
+
+(require 'custom)
+(require 'mcharset)
+(require 'alist)
+
+(eval-when-compile
+  (require 'cl)   ; list*
+  (require 'luna) ; luna-arglist-to-arguments
+  )
+
+(eval-and-compile
+  (defconst mime-library-product ["FLIM" (1 14 2) "Yagi-Nishiguchi"]
+    "Product name, version number and code name of MIME-library package."))
+
+(defmacro mime-product-name (product)
+  `(aref ,product 0))
+
+(defmacro mime-product-version (product)
+  `(aref ,product 1))
+
+(defmacro mime-product-code-name (product)
+  `(aref ,product 2))
+
+(defconst mime-library-version
+  (eval-when-compile
+    (concat (mime-product-name mime-library-product) " "
+           (mapconcat #'number-to-string
+                      (mime-product-version mime-library-product) ".")
+           " - \"" (mime-product-code-name mime-library-product) "\"")))
+
+
+;;; @ variables
+;;;
+
+(defgroup mime '((default-mime-charset custom-variable))
+  "Emacs MIME Interfaces"
+  :group 'news
+  :group 'mail)
+
+(defcustom mime-uuencode-encoding-name-list '("x-uue" "x-uuencode")
+  "*List of encoding names for uuencode format."
+  :group 'mime
+  :type '(repeat string))
+
+
+;;; @@ for encoded-word
+;;;
+
+(defgroup mime-header nil
+  "Header representation, specially encoded-word"
+  :group 'mime)
+
+;;; @@@ decoding
+;;;
+
+(defcustom mime-field-decoding-max-size 1000
+  "*Max size to decode header field."
+  :group 'mime-header
+  :type '(choice (integer :tag "Limit (bytes)")
+                (const :tag "Don't limit" nil)))
+
+;;; @@@ encoding
+;;;
+
+(defcustom mime-field-encoding-method-alist
+  '(("X-Nsubject" . iso-2022-jp-2)
+    ("Newsgroups" . nil)
+    ("Message-ID" . nil)
+    (t            . mime)
+    )
+  "*Alist to specify field encoding method.
+Its key is field-name, value is encoding method.
+
+If method is `mime', this field will be encoded into MIME format.
+
+If method is a MIME-charset, this field will be encoded as the charset
+when it must be convert into network-code.
+
+If method is `default-mime-charset', this field will be encoded as
+variable `default-mime-charset' when it must be convert into
+network-code.
+
+If method is nil, this field will not be encoded."
+  :group 'mime-header
+  :type '(repeat (cons (choice :tag "Field"
+                              (string :tag "Name")
+                              (const :tag "Default" t))
+                      (choice :tag "Method"
+                              (const :tag "MIME conversion" mime)
+                              (symbol :tag "non-MIME conversion")
+                              (const :tag "no-conversion" nil)))))
+
+
+;;; @ required functions
+;;;
+
+(defsubst regexp-* (regexp)
+  (concat regexp "*"))
+
+(defsubst regexp-or (&rest args)
+  (concat "\\(" (mapconcat (function identity) args "\\|") "\\)"))
+
+(or (fboundp 'char-int)
+    (defalias 'char-int 'identity))
+
+
+;;; @ about STD 11
+;;;
+
+(eval-and-compile
+  (defconst std11-quoted-pair-regexp "\\\\.")
+  (defconst std11-non-qtext-char-list '(?\" ?\\ ?\r ?\n))
+  (defconst std11-qtext-regexp
+    (eval-when-compile
+      (concat "[^" std11-non-qtext-char-list "]"))))
+(defconst std11-quoted-string-regexp
+  (eval-when-compile
+    (concat "\""
+           (regexp-*
+            (regexp-or std11-qtext-regexp std11-quoted-pair-regexp))
+           "\"")))
+
+
+;;; @ about MIME
+;;;
+
+(eval-and-compile
+  (defconst mime-tspecial-char-list
+    '(?\] ?\[ ?\( ?\) ?< ?> ?@ ?, ?\; ?: ?\\ ?\" ?/ ?? ?=)))
+(defconst mime-token-regexp
+  (eval-when-compile
+    (concat "[^" mime-tspecial-char-list "\000-\040]+")))
+(defconst mime-charset-regexp mime-token-regexp)
+
+(defconst mime-media-type/subtype-regexp
+  (concat mime-token-regexp "/" mime-token-regexp))
+
+
+;;; @@ base64 / B
+;;;
+
+(defconst base64-token-regexp "[A-Za-z0-9+/]")
+(defconst base64-token-padding-regexp "[A-Za-z0-9+/=]")
+
+(defconst B-encoded-text-regexp
+  (concat "\\(\\("
+         base64-token-regexp
+         base64-token-regexp
+         base64-token-regexp
+         base64-token-regexp
+         "\\)*"
+         base64-token-regexp
+         base64-token-regexp
+         base64-token-padding-regexp
+         base64-token-padding-regexp
+          "\\)"))
+
+;; (defconst eword-B-encoding-and-encoded-text-regexp
+;;   (concat "\\(B\\)\\?" eword-B-encoded-text-regexp))
+
+
+;;; @@ Quoted-Printable / Q
+;;;
+
+(defconst quoted-printable-hex-chars "0123456789ABCDEF")
+
+(defconst quoted-printable-octet-regexp
+  (concat "=[" quoted-printable-hex-chars
+         "][" quoted-printable-hex-chars "]"))
+
+(defconst Q-encoded-text-regexp
+  (concat "\\([^=?]\\|" quoted-printable-octet-regexp "\\)+"))
+
+;; (defconst eword-Q-encoding-and-encoded-text-regexp
+;;   (concat "\\(Q\\)\\?" eword-Q-encoded-text-regexp))
+
+
+;;; @ Content-Type
+;;;
+
+(defsubst make-mime-content-type (type subtype &optional parameters)
+  (list* (cons 'type type)
+        (cons 'subtype subtype)
+        (nreverse parameters))
+  )
+
+(defsubst mime-content-type-primary-type (content-type)
+  "Return primary-type of CONTENT-TYPE."
+  (cdr (car content-type)))
+
+(defsubst mime-content-type-subtype (content-type)
+  "Return subtype of CONTENT-TYPE."
+  (cdr (cadr content-type)))
+
+(defsubst mime-content-type-parameters (content-type)
+  "Return parameters of CONTENT-TYPE."
+  (cddr content-type))
+
+(defsubst mime-content-type-parameter (content-type parameter)
+  "Return PARAMETER value of CONTENT-TYPE."
+  (cdr (assoc parameter (mime-content-type-parameters content-type))))
+
+
+(defsubst mime-type/subtype-string (type &optional subtype)
+  "Return type/subtype string from TYPE and SUBTYPE."
+  (if type
+      (if subtype
+         (format "%s/%s" type subtype)
+       (format "%s" type))))
+
+
+;;; @ Content-Disposition
+;;;
+
+(defsubst mime-content-disposition-type (content-disposition)
+  "Return disposition-type of CONTENT-DISPOSITION."
+  (cdr (car content-disposition)))
+
+(defsubst mime-content-disposition-parameters (content-disposition)
+  "Return disposition-parameters of CONTENT-DISPOSITION."
+  (cdr content-disposition))
+
+(defsubst mime-content-disposition-parameter (content-disposition parameter)
+  "Return PARAMETER value of CONTENT-DISPOSITION."
+  (cdr (assoc parameter (cdr content-disposition))))
+
+(defsubst mime-content-disposition-filename (content-disposition)
+  "Return filename of CONTENT-DISPOSITION."
+  (mime-content-disposition-parameter content-disposition "filename"))
+
+
+;;; @ message structure
+;;;
+
+(defvar mime-message-structure nil
+  "Information about structure of message.
+Please use reference function `mime-entity-SLOT' to get value of SLOT.
+
+Following is a list of slots of the structure:
+
+node-id                        node-id (list of integers)
+content-type           content-type (content-type)
+content-disposition    content-disposition (content-disposition)
+encoding               Content-Transfer-Encoding (string or nil)
+children               entities included in this entity (list of entity)
+
+If an entity includes other entities in its body, such as multipart or
+message/rfc822, `mime-entity' structures of them are included in
+`children', so the `mime-entity' structure become a tree.")
+
+(make-variable-buffer-local 'mime-message-structure)
+
+(make-obsolete-variable 'mime-message-structure "should not use it.")
+
+
+;;; @ for mel-backend
+;;;
+
+(defvar mel-service-list nil)
+
+(defmacro mel-define-service (name &optional args &rest rest)
+  "Define NAME as a service for Content-Transfer-Encodings.
+If ARGS is specified, NAME is defined as a generic function for the
+service."
+  `(progn
+     (add-to-list 'mel-service-list ',name)
+     (defvar ,(intern (format "%s-obarray" name)) (make-vector 7 0))
+     ,@(if args
+          `((defun ,name ,args
+              ,@rest
+              (funcall (mel-find-function ',name ,(car (last args)))
+                       ,@(luna-arglist-to-arguments (butlast args)))
+              )))
+     ))
+
+(put 'mel-define-service 'lisp-indent-function 'defun)
+
+
+(defvar mel-encoding-module-alist nil)
+
+(defsubst mel-find-function-from-obarray (ob-array encoding)
+  (let* ((f (intern-soft encoding ob-array)))
+    (or f
+       (let ((rest (cdr (assoc encoding mel-encoding-module-alist))))
+         (while (and rest
+                     (progn
+                       (require (car rest))
+                       (null (setq f (intern-soft encoding ob-array)))
+                       ))
+           (setq rest (cdr rest))
+           )
+         f))))
+
+(defsubst mel-copy-method (service src-backend dst-backend)
+  (let* ((oa (symbol-value (intern (format "%s-obarray" service))))
+        (f (mel-find-function-from-obarray oa src-backend))
+        sym)
+    (when f
+      (setq sym (intern dst-backend oa))
+      (or (fboundp sym)
+         (fset sym (symbol-function f))
+         ))))
+       
+(defsubst mel-copy-backend (src-backend dst-backend)
+  (let ((services mel-service-list))
+    (while services
+      (mel-copy-method (car services) src-backend dst-backend)
+      (setq services (cdr services)))))
+
+(defmacro mel-define-backend (type &optional parents)
+  "Define TYPE as a mel-backend.
+If PARENTS is specified, TYPE inherits PARENTS.
+Each parent must be backend name (string)."
+  (cons 'progn
+       (mapcar (lambda (parent)
+                 `(mel-copy-backend ,parent ,type)
+                 )
+               parents)))
+
+(defmacro mel-define-method (name args &rest body)
+  "Define NAME as a method function of (nth 1 (car (last ARGS))) backend.
+ARGS is like an argument list of lambda, but (car (last ARGS)) must be
+specialized parameter.  (car (car (last ARGS))) is name of variable
+and (nth 1 (car (last ARGS))) is name of backend (encoding)."
+  (let* ((specializer (car (last args)))
+        (class (nth 1 specializer)))
+    `(progn
+       (mel-define-service ,name)
+       (fset (intern ,class ,(intern (format "%s-obarray" name)))
+            (lambda ,(butlast args)
+              ,@body)))))
+
+(put 'mel-define-method 'lisp-indent-function 'defun)
+
+(defmacro mel-define-method-function (spec function)
+  "Set SPEC's function definition to FUNCTION.
+First element of SPEC is service.
+Rest of ARGS is like an argument list of lambda, but (car (last ARGS))
+must be specialized parameter.  (car (car (last ARGS))) is name of
+variable and (nth 1 (car (last ARGS))) is name of backend (encoding)."
+  (let* ((name (car spec))
+        (args (cdr spec))
+        (specializer (car (last args)))
+        (class (nth 1 specializer)))
+    `(let (sym)
+       (mel-define-service ,name)
+       (setq sym (intern ,class ,(intern (format "%s-obarray" name))))
+       (or (fboundp sym)
+          (fset sym (symbol-function ,function))))))
+
+(defmacro mel-define-function (function spec)
+  (let* ((name (car spec))
+        (args (cdr spec))
+        (specializer (car (last args)))
+        (class (nth 1 specializer)))
+    `(progn
+       (define-function ,function
+        (intern ,class ,(intern (format "%s-obarray" name))))
+       )))
+
+(defvar base64-dl-module
+  (if (and (fboundp 'base64-encode-string)
+          (subrp (symbol-function 'base64-encode-string)))
+      nil
+    (if (fboundp 'dynamic-link)
+       (let ((path (expand-file-name "base64.so" exec-directory)))
+         (and (file-exists-p path)
+              path)
+         ))))
+
+
+;;; @ end
+;;;
+
+(provide 'mime-def)
+
+;;; mime-def.el ends here
diff --git a/mime/mime-edit.el b/mime/mime-edit.el
new file mode 100644 (file)
index 0000000..37963cb
--- /dev/null
@@ -0,0 +1,3040 @@
+;;; mime-edit.el --- Simple MIME Composer for GNU Emacs
+
+;; Copyright (C) 1993,94,95,96,97,98,99,2000 Free Software Foundation, Inc.
+
+;; Author: UMEDA Masanobu <umerin@mse.kyutech.ac.jp>
+;;     MORIOKA Tomohiko <tomo@kanji.zinbun.kyoto-u.ac.jp>
+;;     Daiki Ueno <ueno@ueda.info.waseda.ac.jp>
+;; Created: 1994/08/21 renamed from mime.el
+;;     Renamed: 1997/2/21 from tm-edit.el
+;; Keywords: MIME, multimedia, multilingual, mail, news
+
+;; This file is part of SEMI (Sophisticated Emacs MIME Interfaces).
+
+;; 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:
+
+;; This is an Emacs minor mode for editing Internet multimedia
+;; messages formatted in MIME (RFC 2045, 2046, 2047, 2048 and 2049).
+;; All messages in this mode are composed in the tagged MIME format,
+;; that are described in the following examples.  The messages
+;; composed in the tagged MIME format are automatically translated
+;; into a MIME compliant message when exiting the mode.
+
+;; Mule (multilingual feature of Emacs 20 and multilingual extension
+;; for XEmacs 20) has a capability of handling multilingual text in
+;; limited ISO-2022 manner that is based on early experiences in
+;; Japanese Internet community and resulted in RFC 1468 (ISO-2022-JP
+;; charset for MIME).  In order to enable multilingual capability in
+;; single text message in MIME, charset of multilingual text written
+;; in Mule is declared as either `ISO-2022-JP-2' [RFC 1554].  Mule is
+;; required for reading the such messages.
+
+;; This MIME composer can work with Mail mode, mh-e letter Mode, and
+;; News mode.  First of all, you need the following autoload
+;; definition to load mime-edit-mode automatically:
+;;
+;; (autoload 'turn-on-mime-edit "mime-edit"
+;;           "Minor mode for editing MIME message." t)
+;;
+;; In case of Mail mode (includes VM mode), you need the following
+;; hook definition:
+;;
+;; (add-hook 'mail-mode-hook 'turn-on-mime-edit)
+;; (add-hook 'mail-send-hook 'mime-edit-maybe-translate)
+;;
+;; In case of MH-E, you need the following hook definition:
+;;
+;; (add-hook 'mh-letter-mode-hook
+;;           (function
+;;            (lambda ()
+;;              (turn-on-mime-edit)
+;;              (make-local-variable 'mail-header-separator)
+;;              (setq mail-header-separator "--------")
+;;              ))))
+;; (add-hook 'mh-before-send-letter-hook 'mime-edit-maybe-translate)
+;;
+;; In case of News mode, you need the following hook definition:
+;;
+;; (add-hook 'news-reply-mode-hook 'turn-on-mime-edit)
+;; (add-hook 'news-inews-hook 'mime-edit-maybe-translate)
+;;
+;; In case of Emacs 19, it is possible to emphasize the message tags
+;; using font-lock mode as follows:
+;;
+;; (add-hook 'mime-edit-mode-hook
+;;           (function
+;;            (lambda ()
+;;              (font-lock-mode 1)
+;;              (setq font-lock-keywords (list mime-edit-tag-regexp))
+;;              ))))
+
+;; The message tag looks like:
+;;
+;;     --[[TYPE/SUBTYPE;PARAMETERS][ENCODING]]
+;;
+;; The tagged MIME message examples:
+;;
+;; This is a conventional plain text.  It should be translated into
+;; text/plain.
+;;
+;;--[[text/plain]]
+;; This is also a plain text.  But, it is explicitly specified as is.
+;;--[[text/plain; charset=ISO-8859-1]]
+;; This is also a plain text.  But charset is specified as iso-8859-1.
+;;
+;; Â¡Hola!  Buenos días.  Â¿Cómo está usted?
+;;--[[text/enriched]]
+;; <center>This is a richtext.</center>
+;;
+;;--[[image/gif][base64]]^M...image encoded in base64 comes here...
+;;
+;;--[[audio/basic][base64]]^M...audio encoded in base64 comes here...
+
+;;; Code:
+
+(require 'sendmail)
+(require 'mail-utils)
+(require 'mel)
+(require 'mime-view)
+(require 'signature)
+(require 'alist)
+(require 'invisible)
+(require 'pgg-def)
+(require 'pgg-parse)
+
+(autoload 'pgg-encrypt-region "pgg"
+  "PGP encryption of current region." t)
+(autoload 'pgg-sign-region "pgg"
+  "PGP signature of current region." t)
+(autoload 'pgg-insert-key "pgg"
+  "Insert PGP public key at point." t)
+(autoload 'smime-encrypt-region "smime"
+  "S/MIME encryption of current region.")
+(autoload 'smime-sign-region "smime"
+  "S/MIME signature of current region.")
+(defvar smime-output-buffer)
+(defvar smime-errors-buffer)
+
+
+;;; @ version
+;;;
+
+(eval-and-compile
+  (defconst mime-edit-version
+    (concat
+     (mime-product-name mime-user-interface-product) " "
+     (mapconcat #'number-to-string
+               (mime-product-version mime-user-interface-product) ".")
+     " - \"" (mime-product-code-name mime-user-interface-product) "\"")))
+
+
+;;; @ variables
+;;;
+
+(defgroup mime-edit nil
+  "MIME edit mode"
+  :group 'mime)
+
+(defcustom mime-ignore-preceding-spaces nil
+  "*Ignore preceding white spaces if non-nil."
+  :group 'mime-edit
+  :type 'boolean)
+
+(defcustom mime-ignore-trailing-spaces nil
+  "*Ignore trailing white spaces if non-nil."
+  :group 'mime-edit
+  :type 'boolean)
+
+(defcustom mime-ignore-same-text-tag t
+  "*Ignore preceding text content-type tag that is same with new one.
+If non-nil, the text tag is not inserted unless something different."
+  :group 'mime-edit
+  :type 'boolean)
+
+(defcustom mime-auto-hide-body t
+  "*Hide non-textual body encoded in base64 after insertion if non-nil."
+  :group 'mime-edit
+  :type 'boolean)
+
+(defcustom mime-edit-voice-recorder
+  (function mime-edit-voice-recorder-for-sun)
+  "*Function to record a voice message and encode it."
+  :group 'mime-edit
+  :type 'function)
+
+(defcustom mime-edit-mode-hook nil
+  "*Hook called when enter MIME mode."
+  :group 'mime-edit
+  :type 'hook)
+
+(defcustom mime-edit-translate-hook nil
+  "*Hook called before translating into a MIME compliant message.
+To insert a signature file automatically, call the function
+`mime-edit-insert-signature' from this hook."
+  :group 'mime-edit
+  :type 'hook)
+
+(defcustom mime-edit-exit-hook nil
+  "*Hook called when exit MIME mode."
+  :group 'mime-edit
+  :type 'hook)
+
+(defvar mime-content-types
+  '(("text"
+     ;; Charset parameter need not to be specified, since it is
+     ;; defined automatically while translation.
+     ("plain"
+      ;;("charset" "" "ISO-2022-JP" "US-ASCII" "ISO-8859-1" "ISO-8859-8")
+      )
+     ("enriched")
+     ("html")
+     ("css") ; rfc2318
+     ("xml") ; rfc2376
+     ("x-latex")
+     ;; ("x-rot13-47-48")
+     )
+    ("message"
+     ("external-body"
+      ("access-type"
+       ("anon-ftp"
+       ("site" "ftp.jaist.ac.jp" "wnoc-fuk.wide.ad.jp" "nic.karrn.ad.jp")
+       ("directory" "/pub/GNU/elisp/mime")
+       ("name")
+       ("mode" "image" "ascii" "local8"))
+       ("ftp"
+       ("site")
+       ("directory")
+       ("name")
+       ("mode" "image" "ascii" "local8"))
+       ("tftp"        ("site") ("name"))
+       ("afs"         ("site") ("name"))
+       ("local-file"  ("site") ("name"))
+       ("mail-server"
+       ("server" "ftpmail@nic.karrn.ad.jp")
+       ("subject"))
+       ("url"         ("url"))
+       ))
+     ("rfc822")
+     ("news")
+     )
+    ("application"
+     ("octet-stream" ("type" "" "tar" "shar"))
+     ("postscript")
+     ("vnd.ms-powerpoint")
+     ("x-kiss" ("x-cnf")))
+    ("image"
+     ("gif")
+     ("jpeg")
+     ("png")
+     ("tiff")
+     ("x-pic")
+     ("x-mag")
+     ("x-xwd")
+     ("x-xbm")
+     )
+    ("audio" ("basic"))
+    ("video" ("mpeg"))
+    )
+  "*Alist of content-type, subtype, parameters and its values.")
+
+(defcustom mime-file-types
+  '(
+
+    ;; Programming languages
+
+    ("\\.cc$"
+     "application" "octet-stream" (("type" . "C++"))
+     "7bit"
+     "attachment"      (("filename" . file))
+     )
+
+    ("\\.el$"
+     "application" "octet-stream" (("type" . "emacs-lisp"))
+     "7bit"
+     "attachment"      (("filename" . file))
+     )
+
+    ("\\.lsp$"
+     "application" "octet-stream" (("type" . "common-lisp"))
+     "7bit"
+     "attachment"      (("filename" . file))
+     )
+
+    ("\\.pl$"
+     "application" "octet-stream" (("type" . "perl"))
+     "7bit"
+     "attachment"      (("filename" . file))
+     )
+
+    ;; Text or translated text
+
+    ("\\.txt$"
+     "text"    "plain"         nil
+     nil
+     "inline"          (("filename" . file))
+     )
+
+     ;; .rc : procmail modules pm-xxxx.rc
+     ;; *rc : other resource files
+
+    ("\\.\\(rc\\|lst\\|log\\|sql\\|mak\\)$\\|\\..*rc$"
+     "text"    "plain"         nil
+     nil
+     "attachment"      (("filename" . file))
+     )
+
+    ("\\.html$"
+     "text"    "html"          nil
+     nil
+     nil               nil)
+
+    ("\\.diff$\\|\\.patch$"
+     "application" "octet-stream" (("type" . "patch"))
+     nil
+     "attachment"      (("filename" . file))
+     )
+
+    ("\\.signature"
+     "text"    "plain"         nil     nil     nil     nil)
+
+
+    ;;  Octect binary text
+
+    ("\\.doc$"                         ;MS Word
+     "application" "msword" nil
+     "base64"
+     "attachment" (("filename" . file))
+     )
+    ("\\.ppt$"                         ; MS Power Point
+     "application" "vnd.ms-powerpoint" nil
+     "base64"
+     "attachment" (("filename" . file))
+     )
+
+    ("\\.pln$"
+     "text"    "plain"         nil
+     nil
+     "inline"          (("filename" . file))
+     )
+    ("\\.ps$"
+     "application" "postscript"        nil
+     "quoted-printable"
+     "attachment"      (("filename" . file))
+     )
+
+    ;;  Pure binary
+
+    ("\\.jpg$"
+     "image"   "jpeg"          nil
+     "base64"
+     "inline"          (("filename" . file))
+     )
+    ("\\.gif$"
+     "image"   "gif"           nil
+     "base64"
+     "inline"          (("filename" . file))
+     )
+    ("\\.png$"
+     "image"   "png"           nil
+     "base64"
+     "inline"          (("filename" . file))
+     )
+    ("\\.tiff$"
+     "image"   "tiff"          nil
+     "base64"
+     "inline"          (("filename" . file))
+     )
+    ("\\.pic$"
+     "image"   "x-pic"         nil
+     "base64"
+     "inline"          (("filename" . file))
+     )
+    ("\\.mag$"
+     "image"   "x-mag"         nil
+     "base64"
+     "inline"          (("filename" . file))
+     )
+    ("\\.xbm$"
+     "image"   "x-xbm"         nil
+     "base64"
+     "inline"          (("filename" . file))
+     )
+    ("\\.xwd$"
+     "image"   "x-xwd"         nil
+     "base64"
+     "inline"          (("filename" . file))
+     )
+    ("\\.au$"
+     "audio"   "basic"         nil
+     "base64"
+     "attachment"              (("filename" . file))
+     )
+    ("\\.mpg$"
+     "video"   "mpeg"          nil
+     "base64"
+     "attachment"      (("filename" . file))
+     )
+    ("\\.tar\\.gz$"
+     "application" "octet-stream" (("type" . "tar+gzip"))
+     "base64"
+     "attachment"      (("filename" . file))
+     )
+    ("\\.tgz$"
+     "application" "octet-stream" (("type" . "tar+gzip"))
+     "base64"
+     "attachment"      (("filename" . file))
+     )
+    ("\\.tar\\.Z$"
+     "application" "octet-stream" (("type" . "tar+compress"))
+     "base64"
+     "attachment"      (("filename" . file))
+     )
+    ("\\.taz$"
+     "application" "octet-stream" (("type" . "tar+compress"))
+     "base64"
+     "attachment"      (("filename" . file))
+     )
+    ("\\.gz$"
+     "application" "octet-stream" (("type" . "gzip"))
+     "base64"
+     "attachment"      (("filename" . file))
+     )
+    ("\\.Z$"
+     "application" "octet-stream" (("type" . "compress"))
+     "base64"
+     "attachment"      (("filename" . file))
+     )
+    ("\\.lzh$"
+     "application" "octet-stream" (("type" . "lha"))
+     "base64"
+     "attachment"      (("filename" . file))
+     )
+    ("\\.zip$"
+     "application" "zip" nil
+     "base64"
+     "attachment"      (("filename" . file))
+     )
+
+    ;; Rest
+
+    (".*"
+     "application" "octet-stream" nil
+     nil
+     "attachment"      (("filename" . file)))
+    )
+  "*Alist of file name, types, parameters, and default encoding.
+If encoding is nil, it is determined from its contents."
+  :type `(repeat
+         (list regexp
+               ;; primary-type
+               (choice :tag "Primary-Type"
+                       ,@(nconc (mapcar (lambda (cell)
+                                          (list 'item (car cell))
+                                          )
+                                        mime-content-types)
+                                '(string)))
+               ;; subtype
+               (choice :tag "Sub-Type"
+                       ,@(nconc
+                          (apply #'nconc
+                                 (mapcar (lambda (cell)
+                                           (mapcar (lambda (cell)
+                                                     (list 'item (car cell))
+                                                     )
+                                                   (cdr cell)))
+                                         mime-content-types))
+                          '(string)))
+               ;; parameters
+               (repeat :tag "Parameters of Content-Type field"
+                       (cons string (choice string symbol)))
+               ;; content-transfer-encoding
+               (choice :tag "Encoding"
+                       ,@(cons
+                          '(const nil)
+                          (mapcar (lambda (cell)
+                                    (list 'item cell)
+                                    )
+                                  (mime-encoding-list))))
+               ;; disposition-type
+               (choice :tag "Disposition-Type"
+                       (item nil)
+                       (item "inline")
+                       (item "attachment")
+                       string)
+               ;; parameters
+               (repeat :tag "Parameters of Content-Disposition field"
+                       (cons string (choice string symbol)))
+               ))
+  :group 'mime-edit)
+
+
+;;; @@ about charset, encoding and transfer-level
+;;;
+
+(defvar mime-charset-type-list
+  '((us-ascii          7 nil)
+    (iso-8859-1                8 "quoted-printable")
+    (iso-8859-2                8 "quoted-printable")
+    (iso-8859-3                8 "quoted-printable")
+    (iso-8859-4                8 "quoted-printable")
+    (iso-8859-5                8 "quoted-printable")
+    (koi8-r            8 "quoted-printable")
+    (iso-8859-7                8 "quoted-printable")
+    (iso-8859-8                8 "quoted-printable")
+    (iso-8859-9                8 "quoted-printable")
+    (iso-2022-jp       7 "base64")
+    (iso-2022-jp-3     7 "base64")
+    (iso-2022-kr       7 "base64")
+    (euc-kr            8 "base64")
+    (cn-gb             8 "base64")
+    (gb2312            8 "base64")
+    (cn-big5           8 "base64")
+    (big5              8 "base64")
+    (shift_jis         8 "base64")
+    (tis-620           8 "base64")
+    (iso-2022-jp-2     7 "base64")
+    (iso-2022-int-1    7 "base64")
+    ))
+
+(defvar mime-transfer-level 7
+  "*A number of network transfer level.  It should be bigger than 7.")
+(make-variable-buffer-local 'mime-transfer-level)
+
+(defsubst mime-encoding-name (transfer-level &optional not-omit)
+  (cond ((> transfer-level 8) "binary")
+       ((= transfer-level 8) "8bit")
+       (not-omit "7bit")
+       ))
+
+(defvar mime-transfer-level-string
+  (mime-encoding-name mime-transfer-level 'not-omit)
+  "A string formatted version of mime-transfer-level")
+(make-variable-buffer-local 'mime-transfer-level-string)
+
+;;; @@ about content transfer encoding
+
+(defvar mime-content-transfer-encoding-priority-list
+  '(nil "8bit" "binary"))
+
+;;; @@ about message inserting
+;;;
+
+(defvar mime-edit-yank-ignored-field-list
+  '("Received" "Approved" "Path" "Replied" "Status"
+    "Xref" "X-UIDL" "X-Filter" "X-Gnus-.*" "X-VM-.*")
+  "Delete these fields from original message when it is inserted
+as message/rfc822 part.
+Each elements are regexp of field-name.")
+
+(defvar mime-edit-yank-ignored-field-regexp
+  (concat "^"
+         (apply (function regexp-or) mime-edit-yank-ignored-field-list)
+         ":"))
+
+(defvar mime-edit-message-inserter-alist nil)
+(defvar mime-edit-mail-inserter-alist nil)
+
+
+;;; @@ about message splitting
+;;;
+
+(defcustom mime-edit-split-message t
+  "*Split large message if it is non-nil."
+  :group 'mime-edit
+  :type 'boolean)
+
+(defcustom mime-edit-message-default-max-lines 1000
+  "*Default maximum lines of a message."
+  :group 'mime-edit
+  :type 'integer)
+
+(defcustom mime-edit-message-max-lines-alist
+  '((news-reply-mode . 500))
+  "Alist of major-mode vs maximum lines of a message.
+If it is not specified for a major-mode,
+`mime-edit-message-default-max-lines' is used."
+  :group 'mime-edit
+  :type 'list)
+
+(defconst mime-edit-split-ignored-field-regexp
+  "\\(^Content-\\|^Subject:\\|^Mime-Version:\\|^Message-Id:\\)")
+
+(defcustom mime-edit-split-blind-field-regexp
+  "\\(^[BDFbdf]cc:\\|^cc:[ \t]*$\\)"
+  "*Regular expression to match field-name to be ignored when split sending."
+  :group 'mime-edit
+  :type 'regexp)
+
+(defvar mime-edit-split-message-sender-alist
+  '((mail-mode . (function
+                 (lambda ()
+                   (interactive)
+                   (funcall send-mail-function)
+                   )))))
+
+(defvar mime-edit-news-reply-mode-server-running nil)
+
+
+;;; @@ about tag
+;;;
+
+(defconst mime-edit-single-part-tag-regexp
+  "--[[][[]\\([^]]*\\)]\\([[]\\([^]]*\\)]\\|\\)]"
+  "*Regexp of MIME tag in the form of [[CONTENT-TYPE][ENCODING]].")
+
+(defconst mime-edit-quoted-single-part-tag-regexp
+  (concat "- " (substring mime-edit-single-part-tag-regexp 1)))
+
+(defconst mime-edit-multipart-beginning-regexp "--<<\\([^<>]+\\)>>-{\n")
+
+(defconst mime-edit-multipart-end-regexp "--}-<<\\([^<>]+\\)>>\n")
+
+(defconst mime-edit-beginning-tag-regexp
+  (regexp-or mime-edit-single-part-tag-regexp
+            mime-edit-multipart-beginning-regexp))
+
+(defconst mime-edit-end-tag-regexp
+  (regexp-or mime-edit-single-part-tag-regexp
+            mime-edit-multipart-end-regexp))
+
+(defconst mime-edit-tag-regexp
+  (regexp-or mime-edit-single-part-tag-regexp
+            mime-edit-multipart-beginning-regexp
+            mime-edit-multipart-end-regexp))
+
+(defvar mime-tag-format "--[[%s]]"
+  "*Control-string making a MIME tag.")
+
+(defvar mime-tag-format-with-encoding "--[[%s][%s]]"
+  "*Control-string making a MIME tag with encoding.")
+
+
+;;; @@ multipart boundary
+;;;
+
+(defvar mime-multipart-boundary "Multipart"
+  "*Boundary of a multipart message.")
+
+
+;;; @@ optional header fields
+;;;
+
+(defvar mime-edit-insert-user-agent-field t
+  "*If non-nil, insert User-Agent header field.")
+
+(defvar mime-edit-user-agent-value
+  (concat (mime-product-name mime-user-interface-product)
+         "/"
+         (mapconcat #'number-to-string
+                    (mime-product-version mime-user-interface-product) ".")
+         " ("
+         (mime-product-code-name mime-user-interface-product)
+         ") "
+         (mime-product-name mime-library-product)
+         "/"
+         (mapconcat #'number-to-string
+                    (mime-product-version mime-library-product) ".")
+         " ("
+         (mime-product-code-name mime-library-product)
+         ") "
+         (if (fboundp 'apel-version)
+             (concat (apel-version) " "))
+         (if (featurep 'xemacs)
+             (concat (cond ((featurep 'utf-2000)
+                            (concat "UTF-2000-MULE/" utf-2000-version))
+                           ((featurep 'mule) "MULE"))
+                     " XEmacs"
+                     (if (string-match "^[0-9]+\\(\\.[0-9]+\\)" emacs-version)
+                         (concat
+                          "/"
+                          (substring emacs-version 0 (match-end 0))
+                          (cond ((and (boundp 'xemacs-betaname)
+                                      xemacs-betaname)
+                                 ;; It does not exist in XEmacs
+                                 ;; versions prior to 20.3.
+                                 (concat " " xemacs-betaname))
+                                ((and (boundp 'emacs-patch-level)
+                                      emacs-patch-level)
+                                 ;; It does not exist in FSF Emacs or in
+                                 ;; XEmacs versions earlier than 21.1.1.
+                                 (format " (patch %d)" emacs-patch-level))
+                                (t ""))
+                          " (" xemacs-codename ") ("
+                          system-configuration ")")
+                       " (" emacs-version ")"))
+           (let ((ver (if (string-match "\\.[0-9]+$" emacs-version)
+                          (substring emacs-version 0 (match-beginning 0))
+                        emacs-version)))
+             (if (featurep 'mule)
+                 (if (boundp 'enable-multibyte-characters)
+                     (concat "Emacs/" ver
+                             " (" system-configuration ")"
+                             (if enable-multibyte-characters
+                                 (concat " MULE/" mule-version)
+                               " (with unibyte mode)")
+                             (if (featurep 'meadow)
+                                 (let ((mver (Meadow-version)))
+                                   (if (string-match "^Meadow-" mver)
+                                       (concat " Meadow/"
+                                               (substring mver
+                                                          (match-end 0)))
+                                     ))))
+                   (concat "MULE/" mule-version
+                           " (based on Emacs " ver ")"))
+               (concat "Emacs/" ver " (" system-configuration ")")))))
+  "Body of User-Agent field.
+If variable `mime-edit-insert-user-agent-field' is not nil, it is
+inserted into message header.")
+
+\f
+;;; @ constants
+;;;
+
+(defconst mime-tspecials-regexp "[][()<>@,;:\\\"/?.= \t]"
+  "*Specify MIME tspecials.
+Tspecials means any character that matches with it in header must be quoted.")
+
+(defconst mime-edit-mime-version-value
+  (concat "1.0 (generated by " mime-edit-version ")")
+  "MIME version number.")
+
+(defconst mime-edit-mime-version-field-for-message/partial
+  (concat "MIME-Version:"
+         (mime-encode-field-body
+          (concat " 1.0 (split by " mime-edit-version ")\n")
+          "MIME-Version:"))
+  "MIME version field for message/partial.")
+
+
+;;; @ keymap and menu
+;;;
+
+(defvar mime-edit-mode-flag nil)
+(make-variable-buffer-local 'mime-edit-mode-flag)
+
+(defvar mime-edit-mode-entity-prefix "\C-c\C-x"
+  "Keymap prefix for MIME-Edit mode commands to insert entity or set status.")
+(defvar mime-edit-mode-entity-map (make-sparse-keymap)
+  "Keymap for MIME-Edit mode commands to insert entity or set status.")
+
+(define-key mime-edit-mode-entity-map "\C-t" 'mime-edit-insert-text)
+(define-key mime-edit-mode-entity-map "\C-i" 'mime-edit-insert-file)
+(define-key mime-edit-mode-entity-map "\C-e" 'mime-edit-insert-external)
+(define-key mime-edit-mode-entity-map "\C-v" 'mime-edit-insert-voice)
+(define-key mime-edit-mode-entity-map "\C-y" 'mime-edit-insert-message)
+(define-key mime-edit-mode-entity-map "\C-m" 'mime-edit-insert-mail)
+(define-key mime-edit-mode-entity-map "\C-w" 'mime-edit-insert-signature)
+(define-key mime-edit-mode-entity-map "\C-s" 'mime-edit-insert-signature)
+(define-key mime-edit-mode-entity-map "\C-k" 'mime-edit-insert-key)
+(define-key mime-edit-mode-entity-map "t"    'mime-edit-insert-tag)
+
+(define-key mime-edit-mode-entity-map "7" 'mime-edit-set-transfer-level-7bit)
+(define-key mime-edit-mode-entity-map "8" 'mime-edit-set-transfer-level-8bit)
+(define-key mime-edit-mode-entity-map "/" 'mime-edit-set-split)
+(define-key mime-edit-mode-entity-map "s" 'mime-edit-set-sign)
+(define-key mime-edit-mode-entity-map "v" 'mime-edit-set-sign)
+(define-key mime-edit-mode-entity-map "e" 'mime-edit-set-encrypt)
+(define-key mime-edit-mode-entity-map "h" 'mime-edit-set-encrypt)
+(define-key mime-edit-mode-entity-map "p" 'mime-edit-preview-message)
+(define-key mime-edit-mode-entity-map "\C-z" 'mime-edit-exit)
+(define-key mime-edit-mode-entity-map "?" 'mime-edit-help)
+
+(defvar mime-edit-mode-enclosure-prefix "\C-c\C-m"
+  "Keymap prefix for MIME-Edit mode commands about enclosure.")
+(defvar mime-edit-mode-enclosure-map (make-sparse-keymap)
+  "Keymap for MIME-Edit mode commands about enclosure.")
+
+(define-key mime-edit-mode-enclosure-map
+  "\C-a" 'mime-edit-enclose-alternative-region)
+(define-key mime-edit-mode-enclosure-map
+  "\C-p" 'mime-edit-enclose-parallel-region)
+(define-key mime-edit-mode-enclosure-map
+  "\C-m" 'mime-edit-enclose-mixed-region)
+(define-key mime-edit-mode-enclosure-map
+  "\C-d" 'mime-edit-enclose-digest-region)
+(define-key mime-edit-mode-enclosure-map
+  "\C-s" 'mime-edit-enclose-pgp-signed-region)
+(define-key mime-edit-mode-enclosure-map
+  "\C-e" 'mime-edit-enclose-pgp-encrypted-region)
+(define-key mime-edit-mode-enclosure-map
+  "\C-q" 'mime-edit-enclose-quote-region)
+
+(defvar mime-edit-mode-map (make-sparse-keymap)
+  "Keymap for MIME-Edit mode commands.")
+(define-key mime-edit-mode-map
+  mime-edit-mode-entity-prefix mime-edit-mode-entity-map)
+(define-key mime-edit-mode-map
+  mime-edit-mode-enclosure-prefix mime-edit-mode-enclosure-map)
+
+(defconst mime-edit-menu-title "MIME-Edit")
+
+(defconst mime-edit-menu-list
+  '((mime-help "Describe MIME editor mode" mime-edit-help)
+    (file      "Insert File"           mime-edit-insert-file)
+    (external  "Insert External"       mime-edit-insert-external)
+    (voice     "Insert Voice"          mime-edit-insert-voice)
+    (message   "Insert Message"        mime-edit-insert-message)
+    (mail      "Insert Mail"           mime-edit-insert-mail)
+    (signature "Insert Signature"      mime-edit-insert-signature)
+    (text      "Insert Text"           mime-edit-insert-text)
+    (tag       "Insert Tag"            mime-edit-insert-tag)
+    (alternative "Enclose as alternative"
+                mime-edit-enclose-alternative-region)
+    (parallel  "Enclose as parallel"   mime-edit-enclose-parallel-region)
+    (mixed     "Enclose as serial"     mime-edit-enclose-mixed-region)
+    (digest    "Enclose as digest"     mime-edit-enclose-digest-region)
+    (signed    "Enclose as signed"     mime-edit-enclose-pgp-signed-region)
+    (encrypted "Enclose as encrypted"  mime-edit-enclose-pgp-encrypted-region)
+    (quote     "Verbatim region"       mime-edit-enclose-quote-region)
+    (key       "Insert Public Key"     mime-edit-insert-key)
+    (split     "About split"           mime-edit-set-split)
+    (sign      "About sign"            mime-edit-set-sign)
+    (encrypt   "About encryption"      mime-edit-set-encrypt)
+    (preview   "Preview Message"       mime-edit-preview-message)
+    (level     "Toggle transfer-level" mime-edit-toggle-transfer-level)
+    )
+  "MIME-edit menubar entry.")
+
+(cond ((featurep 'xemacs)
+       ;; modified by Pekka Marjola <pema@iki.fi>
+       ;;      1995/9/5 (c.f. [tm-en:69])
+       (defun mime-edit-define-menu-for-xemacs ()
+        "Define menu for XEmacs."
+        (cond ((featurep 'menubar)
+               (make-local-variable 'current-menubar)
+               (set-buffer-menubar current-menubar)
+               (add-submenu
+                nil
+                (cons mime-edit-menu-title
+                      (mapcar (function
+                               (lambda (item)
+                                 (vector (nth 1 item)(nth 2 item)
+                                         mime-edit-mode-flag)
+                                 ))
+                              mime-edit-menu-list)))
+               )))
+
+       ;; modified by Steven L. Baur <steve@miranova.com>
+       ;;      1995/12/6 (c.f. [tm-en:209])
+       (or (boundp 'mime-edit-popup-menu-for-xemacs)
+          (setq mime-edit-popup-menu-for-xemacs
+                (append '("MIME Commands" "---")
+                        (mapcar (function (lambda (item)
+                                            (vector (nth 1 item)
+                                                    (nth 2 item)
+                                                    t)))
+                                mime-edit-menu-list)))
+          )
+       )
+      ((>= emacs-major-version 19)
+       (define-key mime-edit-mode-map [menu-bar mime-edit]
+        (cons mime-edit-menu-title
+              (make-sparse-keymap mime-edit-menu-title)))
+       (mapcar (function
+               (lambda (item)
+                 (define-key mime-edit-mode-map
+                   (vector 'menu-bar 'mime-edit (car item))
+                   (cons (nth 1 item)(nth 2 item))
+                   )
+                 ))
+              (reverse mime-edit-menu-list)
+              )
+       ))
+
+
+;;; @ functions
+;;;
+
+(defvar mime-edit-touched-flag nil)
+
+;;;###autoload
+(defun mime-edit-mode ()
+  "MIME minor mode for editing the tagged MIME message.
+
+In this mode, basically, the message is composed in the tagged MIME
+format. The message tag looks like:
+
+       --[[text/plain; charset=ISO-2022-JP][7bit]]
+
+The tag specifies the MIME content type, subtype, optional parameters
+and transfer encoding of the message following the tag.  Messages
+without any tag are treated as `text/plain' by default.  Charset and
+transfer encoding are automatically defined unless explicitly
+specified.  Binary messages such as audio and image are usually
+hidden.  The messages in the tagged MIME format are automatically
+translated into a MIME compliant message when exiting this mode.
+
+Available charsets depend on Emacs version being used.  The following
+lists the available charsets of each emacs.
+
+Without mule:  US-ASCII and ISO-8859-1 (or other charset) are available.
+With mule:     US-ASCII, ISO-8859-* (except for ISO-8859-5), KOI8-R,
+               ISO-2022-JP, ISO-2022-JP-2, EUC-KR, CN-GB-2312,
+               CN-BIG5 and ISO-2022-INT-1 are available.
+
+ISO-2022-JP-2 and ISO-2022-INT-1 charsets used in mule is expected to
+be used to represent multilingual text in intermixed manner.  Any
+languages that has no registered charset are represented as either
+ISO-2022-JP-2 or ISO-2022-INT-1 in mule.
+
+If you want to use non-ISO-8859-1 charset in Emacs 19 or XEmacs
+without mule, please set variable `default-mime-charset'.  This
+variable must be symbol of which name is a MIME charset.
+
+If you want to add more charsets in mule, please set variable
+`charsets-mime-charset-alist'.  This variable must be alist of which
+key is list of charset and value is symbol of MIME charset.  If name
+of coding-system is different as MIME charset, please set variable
+`mime-charset-coding-system-alist'.  This variable must be alist of
+which key is MIME charset and value is coding-system.
+
+Following commands are available in addition to major mode commands:
+
+\[make single part\]
+\\[mime-edit-insert-text]      insert a text message.
+\\[mime-edit-insert-file]      insert a (binary) file.
+\\[mime-edit-insert-external]  insert a reference to external body.
+\\[mime-edit-insert-voice]     insert a voice message.
+\\[mime-edit-insert-message]   insert a mail or news message.
+\\[mime-edit-insert-mail]      insert a mail message.
+\\[mime-edit-insert-signature] insert a signature file at end.
+\\[mime-edit-insert-key]       insert PGP public key.
+\\[mime-edit-insert-tag]       insert a new MIME tag.
+
+\[make enclosure (maybe multipart)\]
+\\[mime-edit-enclose-alternative-region]   enclose as multipart/alternative.
+\\[mime-edit-enclose-parallel-region]     enclose as multipart/parallel.
+\\[mime-edit-enclose-mixed-region]        enclose as multipart/mixed.
+\\[mime-edit-enclose-digest-region]       enclose as multipart/digest.
+\\[mime-edit-enclose-pgp-signed-region]           enclose as PGP signed.
+\\[mime-edit-enclose-pgp-encrypted-region] enclose as PGP encrypted.
+\\[mime-edit-enclose-quote-region]        enclose as verbose mode
+                                          (to avoid to expand tags)
+
+\[other commands\]
+\\[mime-edit-set-transfer-level-7bit]  set transfer-level as 7.
+\\[mime-edit-set-transfer-level-8bit]  set transfer-level as 8.
+\\[mime-edit-set-split]                        set message splitting mode.
+\\[mime-edit-set-sign]                 set PGP-sign mode.
+\\[mime-edit-set-encrypt]              set PGP-encryption mode.
+\\[mime-edit-preview-message]          preview editing MIME message.
+\\[mime-edit-exit]                     exit and translate into a MIME
+                                       compliant message.
+\\[mime-edit-help]                     show this help.
+\\[mime-edit-maybe-translate]          exit and translate if in MIME mode,
+                                       then split.
+
+Additional commands are available in some major modes:
+C-c C-c                exit, translate and run the original command.
+C-c C-s                exit, translate and run the original command.
+
+The following is a message example written in the tagged MIME format.
+TABs at the beginning of the line are not a part of the message:
+
+       This is a conventional plain text.  It should be translated
+       into text/plain.
+       --[[text/plain]]
+       This is also a plain text.  But, it is explicitly specified as
+       is.
+       --[[text/plain; charset=ISO-8859-1]]
+       This is also a plain text.  But charset is specified as
+       iso-8859-1.
+
+       Â¡Hola!  Buenos días.  Â¿Cómo está usted?
+       --[[text/enriched]]
+       This is a <bold>enriched text</bold>.
+       --[[image/gif][base64]]...image encoded in base64 here...
+       --[[audio/basic][base64]]...audio encoded in base64 here...
+
+User customizable variables (not documented all of them):
+ mime-edit-prefix
+    Specifies a key prefix for MIME minor mode commands.
+
+ mime-ignore-preceding-spaces
+    Preceding white spaces in a message body are ignored if non-nil.
+
+ mime-ignore-trailing-spaces
+    Trailing white spaces in a message body are ignored if non-nil.
+
+ mime-auto-hide-body
+    Hide a non-textual body message encoded in base64 after insertion
+    if non-nil.
+
+ mime-transfer-level
+    A number of network transfer level.  It should be bigger than 7.
+    If you are in 8bit-through environment, please set 8.
+
+ mime-edit-voice-recorder
+    Specifies a function to record a voice message and encode it.
+    The function `mime-edit-voice-recorder-for-sun' is for Sun
+    SparcStations.
+
+ mime-edit-mode-hook
+    Turning on MIME mode calls the value of mime-edit-mode-hook, if
+    it is non-nil.
+
+ mime-edit-translate-hook
+    The value of mime-edit-translate-hook is called just before translating
+    the tagged MIME format into a MIME compliant message if it is
+    non-nil.  If the hook call the function mime-edit-insert-signature,
+    the signature file will be inserted automatically.
+
+ mime-edit-exit-hook
+    Turning off MIME mode calls the value of mime-edit-exit-hook, if it is
+    non-nil."
+  (interactive)
+  (if mime-edit-mode-flag
+      (mime-edit-exit)
+    (if mime-edit-touched-flag
+       (mime-edit-again)
+      (make-local-variable 'mime-edit-touched-flag)
+      (setq mime-edit-touched-flag t)
+      (turn-on-mime-edit)
+      )))
+
+
+(cond ((featurep 'xemacs)
+       (add-minor-mode 'mime-edit-mode-flag
+                      '((" MIME-Edit "  mime-transfer-level-string))
+                      mime-edit-mode-map
+                      nil
+                      'mime-edit-mode)
+       )
+      (t
+       (set-alist 'minor-mode-alist
+                 'mime-edit-mode-flag
+                 '((" MIME-Edit "  mime-transfer-level-string)))
+       (set-alist 'minor-mode-map-alist
+                 'mime-edit-mode-flag
+                 mime-edit-mode-map)
+       ))
+
+
+;;;###autoload
+(defun turn-on-mime-edit ()
+  "Unconditionally turn on MIME-Edit mode."
+  (interactive)
+  (if mime-edit-mode-flag
+      (error "You are already editing a MIME message.")
+    (setq mime-edit-mode-flag t)
+
+    ;; Set transfer level into mode line
+    ;;
+    (setq mime-transfer-level-string
+         (mime-encoding-name mime-transfer-level 'not-omit))
+    (force-mode-line-update)
+
+    ;; Define menu for XEmacs.
+    (if (featurep 'xemacs)
+       (mime-edit-define-menu-for-xemacs)
+      )
+
+    (enable-invisible)
+
+    ;; I don't care about saving these.
+    (setq paragraph-start
+         (regexp-or mime-edit-single-part-tag-regexp
+                    paragraph-start))
+    (setq paragraph-separate
+         (regexp-or mime-edit-single-part-tag-regexp
+                    paragraph-separate))
+    (run-hooks 'mime-edit-mode-hook)
+    (message
+     (substitute-command-keys
+      "Type \\[mime-edit-exit] to exit MIME mode, and type \\[mime-edit-help] to get help."))
+    ))
+
+;;;###autoload
+(defalias 'edit-mime 'turn-on-mime-edit) ; for convenience
+
+
+(defun mime-edit-exit (&optional nomime no-error)
+  "Translate the tagged MIME message into a MIME compliant message.
+With no argument encode a message in the buffer into MIME, otherwise
+just return to previous mode."
+  (interactive "P")
+  (if (not mime-edit-mode-flag)
+      (if (null no-error)
+         (error "You aren't editing a MIME message.")
+       )
+    (if (not nomime)
+       (progn
+         (run-hooks 'mime-edit-translate-hook)
+         (mime-edit-translate-buffer)))
+    ;; Restore previous state.
+    (setq mime-edit-mode-flag nil)
+    (if (and (featurep 'xemacs)
+            (featurep 'menubar))
+       (delete-menu-item (list mime-edit-menu-title))
+      )
+    (end-of-invisible)
+    (set-buffer-modified-p (buffer-modified-p))
+    (run-hooks 'mime-edit-exit-hook)
+    (message "Exit MIME editor mode.")
+    ))
+
+(defun mime-edit-maybe-translate ()
+  (interactive)
+  (mime-edit-exit nil t)
+  (call-interactively 'mime-edit-maybe-split-and-send)
+  )
+
+(defun mime-edit-help ()
+  "Show help message about MIME mode."
+  (interactive)
+  (with-output-to-temp-buffer "*Help*"
+    (princ "MIME editor mode:\n")
+    (princ (documentation 'mime-edit-mode))
+    (print-help-return-message)))
+
+(defun mime-edit-insert-text (&optional subtype)
+  "Insert a text message.
+Charset is automatically obtained from the `charsets-mime-charset-alist'.
+If optional argument SUBTYPE is not nil, text/SUBTYPE tag is inserted."
+  (interactive)
+  (let ((ret (mime-edit-insert-tag "text" subtype nil)))
+    (when ret
+      (if (looking-at mime-edit-single-part-tag-regexp)
+         (progn
+           ;; Make a space between the following message.
+           (insert "\n")
+           (forward-char -1)
+           ))
+      (if (and (member (cadr ret) '("enriched"))
+              (fboundp 'enriched-mode))
+         (enriched-mode t)
+       (if (boundp 'enriched-mode)
+           (enriched-mode -1)
+         ))
+      )))
+
+(defun mime-edit-insert-file (file &optional verbose)
+  "Insert a message from a file."
+  (interactive "fInsert file as MIME message: \nP")
+  (let*  ((guess (mime-find-file-type file))
+         (type (nth 0 guess))
+         (subtype (nth 1 guess))
+         (parameters (nth 2 guess))
+         (encoding (nth 3 guess))
+         (disposition-type (nth 4 guess))
+         (disposition-params (nth 5 guess))
+         )
+    (if verbose
+       (setq type    (mime-prompt-for-type type)
+             subtype (mime-prompt-for-subtype type subtype)
+             ))
+    (if (or (interactive-p) verbose)
+       (setq encoding (mime-prompt-for-encoding encoding))
+      )
+    (if (or (consp parameters) (stringp disposition-type))
+       (let ((rest parameters) cell attribute value)
+         (setq parameters "")
+         (while rest
+           (setq cell (car rest))
+           (setq attribute (car cell))
+           (setq value (cdr cell))
+           (if (eq value 'file)
+               (setq value (std11-wrap-as-quoted-string
+                            (file-name-nondirectory file)))
+             )
+           (setq parameters (concat parameters "; " attribute "=" value))
+           (setq rest (cdr rest))
+           )
+         (if disposition-type
+             (progn
+               (setq parameters
+                     (concat parameters "\n"
+                             "Content-Disposition: " disposition-type))
+               (setq rest disposition-params)
+               (while rest
+                 (setq cell (car rest))
+                 (setq attribute (car cell))
+                 (setq value (cdr cell))
+                 (if (eq value 'file)
+                     (setq value (std11-wrap-as-quoted-string
+                                  (file-name-nondirectory file)))
+                   )
+                 (setq parameters
+                       (concat parameters "; " attribute "=" value))
+                 (setq rest (cdr rest))
+                 )
+               ))
+         ))
+    (mime-edit-insert-tag type subtype parameters)
+    (mime-edit-insert-binary-file file encoding)
+    ))
+
+(defun mime-edit-insert-external ()
+  "Insert a reference to external body."
+  (interactive)
+  (mime-edit-insert-tag "message" "external-body" nil ";\n\t")
+  ;;(forward-char -1)
+  ;;(insert "Content-Description: " (read-string "Content-Description: ") "\n")
+  ;;(forward-line 1)
+  (let* ((pritype (mime-prompt-for-type))
+        (subtype (mime-prompt-for-subtype pritype))
+        (parameters (mime-prompt-for-parameters pritype subtype ";\n\t")))
+    (and pritype
+        subtype
+        (insert "Content-Type: "
+                pritype "/" subtype (or parameters "") "\n")))
+  (if (and (not (eobp))
+          (not (looking-at mime-edit-single-part-tag-regexp)))
+      (insert (mime-make-text-tag) "\n")))
+
+(defun mime-edit-insert-voice ()
+  "Insert a voice message."
+  (interactive)
+  (let ((encoding
+        (completing-read
+         "What transfer encoding: "
+         (mime-encoding-alist) nil t nil)))
+    (mime-edit-insert-tag "audio" "basic" nil)
+    (mime-edit-define-encoding encoding)
+    (save-restriction
+      (narrow-to-region (1- (point))(point))
+      (unwind-protect
+         (funcall mime-edit-voice-recorder encoding)
+       (progn
+         (insert "\n")
+         (invisible-region (point-min)(point-max))
+         (goto-char (point-max))
+         )))))
+
+(defun mime-edit-insert-signature (&optional arg)
+  "Insert a signature file."
+  (interactive "P")
+  (let ((signature-insert-hook
+         (function
+          (lambda ()
+           (let ((items (mime-find-file-type signature-file-name)))
+             (apply (function mime-edit-insert-tag)
+                    (car items) (cadr items) (list (caddr items))))
+            )))
+        )
+    (insert-signature arg)
+    ))
+
+\f
+;; Insert a new tag around a point.
+
+(defun mime-edit-insert-tag (&optional pritype subtype parameters delimiter)
+  "Insert new MIME tag and return a list of PRITYPE, SUBTYPE, and PARAMETERS.
+If nothing is inserted, return nil."
+  (interactive)
+  (let ((p (point)))
+    (mime-edit-goto-tag)
+    (if (and (re-search-forward mime-edit-tag-regexp nil t)
+            (< (match-beginning 0) p)
+            (< p (match-end 0))
+            )
+       (goto-char (match-beginning 0))
+      (goto-char p)
+      ))
+  (let ((oldtag nil)
+       (newtag nil)
+       (current (point))
+       )
+    (setq pritype
+         (or pritype
+             (mime-prompt-for-type)))
+    (setq subtype
+         (or subtype
+             (mime-prompt-for-subtype pritype)))
+    (setq parameters
+         (or parameters
+             (mime-prompt-for-parameters pritype subtype delimiter)))
+    ;; Make a new MIME tag.
+    (setq newtag (mime-make-tag pritype subtype parameters))
+    ;; Find an current MIME tag.
+    (setq oldtag
+         (save-excursion
+           (if (mime-edit-goto-tag)
+               (buffer-substring (match-beginning 0) (match-end 0))
+             ;; Assume content type is 'text/plan'.
+             (mime-make-tag "text" "plain")
+             )))
+    ;; We are only interested in TEXT.
+    (if (and oldtag
+            (not (mime-test-content-type
+                  (mime-edit-get-contype oldtag) "text")))
+       (setq oldtag nil))
+    ;; Make a new tag.
+    (if (or (not oldtag)               ;Not text
+           (or mime-ignore-same-text-tag
+               (not (string-equal oldtag newtag))))
+       (progn
+         ;; Mark the beginning of the tag for convenience.
+         (push-mark (point) 'nomsg)
+         (insert newtag "\n")
+         (list pritype subtype parameters) ;New tag is created.
+         )
+      ;; Restore previous point.
+      (goto-char current)
+      nil                              ;Nothing is created.
+      )
+    ))
+
+(defun mime-edit-insert-binary-file (file &optional encoding)
+  "Insert binary FILE at point.
+Optional argument ENCODING specifies an encoding method such as base64."
+  (let* ((tagend (1- (point)))         ;End of the tag
+        (hide-p (and mime-auto-hide-body
+                     (stringp encoding)
+                     (not
+                      (let ((en (downcase encoding)))
+                        (or (string-equal en "7bit")
+                            (string-equal en "8bit")
+                            (string-equal en "binary")
+                            )))))
+        )
+    (save-restriction
+      (narrow-to-region tagend (point))
+      (mime-insert-encoded-file file encoding)
+      (if hide-p
+         (progn
+           (invisible-region (point-min) (point-max))
+           (goto-char (point-max))
+           )
+       (goto-char (point-max))
+       ))
+    (or hide-p
+       (looking-at mime-edit-tag-regexp)
+       (= (point)(point-max))
+       (mime-edit-insert-tag "text" "plain")
+       )
+    ;; Define encoding even if it is 7bit.
+    (if (stringp encoding)
+       (save-excursion
+         (goto-char tagend) ; Make sure which line the tag is on.
+         (mime-edit-define-encoding encoding)
+         ))
+    ))
+
+\f
+;; Commands work on a current message flagment.
+
+(defun mime-edit-goto-tag ()
+  "Search for the beginning of the tagged MIME message."
+  (let ((current (point)))
+    (if (looking-at mime-edit-tag-regexp)
+       t
+      ;; At first, go to the end.
+      (cond ((re-search-forward mime-edit-beginning-tag-regexp nil t)
+            (goto-char (1- (match-beginning 0))) ;For multiline tag
+            )
+           (t
+            (goto-char (point-max))
+            ))
+      ;; Then search for the beginning.
+      (re-search-backward mime-edit-end-tag-regexp nil t)
+      (or (looking-at mime-edit-beginning-tag-regexp)
+         ;; Restore previous point.
+         (progn
+           (goto-char current)
+           nil
+           ))
+      )))
+
+(defun mime-edit-content-beginning ()
+  "Return the point of the beginning of content."
+  (save-excursion
+    (let ((beg (save-excursion
+                (beginning-of-line) (point))))
+      (if (mime-edit-goto-tag)
+         (let ((top (point)))
+           (goto-char (match-end 0))
+           (if (and (= beg top)
+                    (= (following-char) ?\^M))
+               (point)
+             (forward-line 1)
+             (point)))
+       ;; Default text/plain tag.
+       (goto-char (point-min))
+       (re-search-forward
+        (concat "\n" (regexp-quote mail-header-separator)
+                (if mime-ignore-preceding-spaces
+                    "[ \t\n]*\n" "\n")) nil 'move)
+       (point))
+      )))
+
+(defun mime-edit-content-end ()
+  "Return the point of the end of content."
+  (save-excursion
+    (if (mime-edit-goto-tag)
+       (progn
+         (goto-char (match-end 0))
+         (if (invisible-p (point))
+             (next-visible-point (point))
+           ;; Move to the end of this text.
+           (if (re-search-forward mime-edit-tag-regexp nil 'move)
+               ;; Don't forget a multiline tag.
+               (goto-char (match-beginning 0))
+             )
+           (point)
+           ))
+      ;; Assume the message begins with text/plain.
+      (goto-char (mime-edit-content-beginning))
+      (if (re-search-forward mime-edit-tag-regexp nil 'move)
+         ;; Don't forget a multiline tag.
+         (goto-char (match-beginning 0)))
+      (point))
+    ))
+
+(defun mime-edit-define-charset (charset)
+  "Set charset of current tag to CHARSET."
+  (save-excursion
+    (if (mime-edit-goto-tag)
+       (let ((tag (buffer-substring (match-beginning 0) (match-end 0))))
+         (delete-region (match-beginning 0) (match-end 0))
+         (insert
+          (mime-create-tag
+           (mime-edit-set-parameter
+            (mime-edit-get-contype tag)
+            "charset"
+            (let ((comment (get charset 'mime-charset-comment)))
+              (if comment
+                  (concat (upcase (symbol-name charset)) " (" comment ")")
+                (upcase (symbol-name charset)))))
+           (mime-edit-get-encoding tag)))
+         ))))
+
+(defun mime-edit-define-encoding (encoding)
+  "Set encoding of current tag to ENCODING."
+  (save-excursion
+    (if (mime-edit-goto-tag)
+       (let ((tag (buffer-substring (match-beginning 0) (match-end 0))))
+         (delete-region (match-beginning 0) (match-end 0))
+         (insert (mime-create-tag (mime-edit-get-contype tag) encoding)))
+      )))
+
+(defun mime-edit-choose-charset ()
+  "Choose charset of a text following current point."
+  (detect-mime-charset-region (point) (mime-edit-content-end))
+  )
+
+(defun mime-make-text-tag (&optional subtype)
+  "Make a tag for a text after current point.
+Subtype of text type can be specified by an optional argument SUBTYPE.
+Otherwise, it is obtained from mime-content-types."
+  (let* ((pritype "text")
+        (subtype (or subtype
+                     (car (car (cdr (assoc pritype mime-content-types)))))))
+    ;; Charset should be defined later.
+    (mime-make-tag pritype subtype)))
+
+\f
+;; Tag handling functions
+
+(defun mime-make-tag (pritype subtype &optional parameters encoding)
+  "Make a tag of MIME message of PRITYPE, SUBTYPE and optional PARAMETERS."
+  (mime-create-tag (concat (or pritype "") "/" (or subtype "")
+                          (or parameters ""))
+                  encoding))
+
+(defun mime-create-tag (contype &optional encoding)
+  "Make a tag with CONTENT-TYPE and optional ENCODING."
+  (format (if encoding mime-tag-format-with-encoding mime-tag-format)
+         contype encoding))
+
+(defun mime-edit-get-contype (tag)
+  "Return Content-Type (including parameters) of TAG."
+  (and (stringp tag)
+       (or (string-match mime-edit-single-part-tag-regexp tag)
+          (string-match mime-edit-multipart-beginning-regexp tag)
+          (string-match mime-edit-multipart-end-regexp tag)
+          )
+       (substring tag (match-beginning 1) (match-end 1))
+       ))
+
+(defun mime-edit-get-encoding (tag)
+  "Return encoding of TAG."
+  (and (stringp tag)
+       (string-match mime-edit-single-part-tag-regexp tag)
+       (match-beginning 3)
+       (not (= (match-beginning 3) (match-end 3)))
+       (substring tag (match-beginning 3) (match-end 3))))
+
+(defun mime-get-parameter (contype parameter)
+  "For given CONTYPE return value for PARAMETER.
+Nil if no such parameter."
+  (if (string-match
+       (concat
+       ";[ \t\n]*"
+       (regexp-quote parameter)
+       "[ \t\n]*=[ \t\n]*\\([^\" \t\n;]*\\|\"[^\"]*\"\\)\\([ \t\n]*;\\|$\\)")
+       contype)
+      (substring contype (match-beginning 1) (match-end 1))
+    nil                                        ;No such parameter
+    ))
+
+(defun mime-edit-set-parameter (contype parameter value)
+  "For given CONTYPE set PARAMETER to VALUE."
+  (let (ctype opt-fields)
+    (if (string-match "\n[^ \t\n\r]+:" contype)
+       (setq ctype (substring contype 0 (match-beginning 0))
+             opt-fields (substring contype (match-beginning 0)))
+      (setq ctype contype)
+      )
+    (if (string-match
+        (concat
+         ";[ \t\n]*\\("
+         (regexp-quote parameter)
+         "[ \t\n]*=[ \t\n]*\\([^\" \t\n;]*\\|\"[^\"]*\"\\)\\)[ \t\n]*\\(;\\|$\\)")
+        ctype)
+       ;; Change value
+       (concat (substring ctype 0 (match-beginning 1))
+               parameter "=" value
+               (substring contype (match-end 1))
+               opt-fields)
+      (concat ctype "; " parameter "=" value opt-fields)
+      )))
+
+(defun mime-strip-parameters (contype)
+  "Return primary content-type and subtype without parameters for CONTYPE."
+  (if (string-match "^[ \t]*\\([^; \t\n]*\\)" contype)
+      (substring contype (match-beginning 1) (match-end 1)) nil))
+
+(defun mime-test-content-type (contype type &optional subtype)
+  "Test if CONTYPE is a TYPE and an optional SUBTYPE."
+  (and (stringp contype)
+       (stringp type)
+       (string-match
+       (concat "^[ \t]*" (downcase type) "/" (downcase (or subtype "")))
+       (downcase contype))))
+
+\f
+;; Basic functions
+
+(defun mime-find-file-type (file)
+  "Guess Content-Type, subtype, and parameters from FILE."
+  (let ((guess nil)
+       (guesses mime-file-types))
+    (while (and (not guess) guesses)
+      (if (string-match (car (car guesses)) file)
+         (setq guess (cdr (car guesses))))
+      (setq guesses (cdr guesses)))
+    guess
+    ))
+
+(defun mime-prompt-for-type (&optional default)
+  "Ask for Content-type."
+  (let ((type ""))
+    ;; Repeat until primary content type is specified.
+    (while (string-equal type "")
+      (setq type
+           (completing-read "What content type: "
+                            mime-content-types
+                            nil
+                            'require-match ;Type must be specified.
+                            default
+                            ))
+      (if (string-equal type "")
+         (progn
+           (message "Content type is required.")
+           (beep)
+           (sit-for 1)
+           ))
+      )
+    type))
+
+(defun mime-prompt-for-subtype (type &optional default)
+  "Ask for subtype of media-type TYPE."
+  (let ((subtypes (cdr (assoc type mime-content-types))))
+    (or (and default
+            (assoc default subtypes))
+       (setq default (car (car subtypes)))
+       ))
+  (let* ((answer
+         (completing-read
+          (if default
+              (concat
+               "What content subtype: (default " default ") ")
+            "What content subtype: ")
+          (cdr (assoc type mime-content-types))
+          nil
+          'require-match               ;Subtype must be specified.
+          nil
+          )))
+    (if (string-equal answer "") default answer)))
+
+(defun mime-prompt-for-parameters (pritype subtype &optional delimiter)
+  "Ask for Content-type parameters of Content-Type PRITYPE and SUBTYPE.
+Optional DELIMITER specifies parameter delimiter (';' by default)."
+  (let* ((delimiter (or delimiter "; "))
+        (parameters
+         (mapconcat
+          (function identity)
+          (delq nil
+                (mime-prompt-for-parameters-1
+                 (cdr (assoc subtype
+                             (cdr (assoc pritype mime-content-types))))))
+          delimiter
+          )))
+    (if (and (stringp parameters)
+            (not (string-equal parameters "")))
+       (concat delimiter parameters)
+      ""                               ;"" if no parameters
+      )))
+
+(defun mime-prompt-for-parameters-1 (optlist)
+  (apply (function append)
+        (mapcar (function mime-prompt-for-parameter) optlist)))
+
+(defun mime-prompt-for-parameter (parameter)
+  "Ask for PARAMETER.
+Parameter must be '(PROMPT CHOICE1 (CHOISE2 ...))."
+  (let* ((prompt (car parameter))
+        (choices (mapcar (function
+                          (lambda (e)
+                            (if (consp e) e (list e))))
+                         (cdr parameter)))
+        (default (car (car choices)))
+        (answer nil))
+    (if choices
+       (progn
+         (setq answer
+               (completing-read
+                (concat "What " prompt
+                        ": (default "
+                        (if (string-equal default "") "\"\"" default)
+                        ") ")
+                choices nil nil ""))
+         ;; If nothing is selected, use default.
+         (if (string-equal answer "")
+             (setq answer default)))
+      (setq answer
+           (read-string (concat "What " prompt ": "))))
+    (cons (if (and answer
+                  (not (string-equal answer "")))
+             (concat prompt "="
+                     ;; Note: control characters ignored!
+                     (if (string-match mime-tspecials-regexp answer)
+                         (concat "\"" answer "\"") answer)))
+         (mime-prompt-for-parameters-1 (cdr (assoc answer (cdr parameter)))))
+    ))
+
+(defun mime-prompt-for-encoding (default)
+  "Ask for Content-Transfer-Encoding."
+  (let (encoding)
+    (while (string=
+           (setq encoding
+                 (completing-read
+                  "What transfer encoding: "
+                  (mime-encoding-alist) nil t default)
+                 )
+           ""))
+    encoding))
+
+\f
+;;; @ Translate the tagged MIME messages into a MIME compliant message.
+;;;
+
+(defvar mime-edit-translate-buffer-hook
+  '(mime-edit-pgp-enclose-buffer
+    mime-edit-translate-body
+    mime-edit-translate-header))
+
+(defun mime-edit-translate-header ()
+  "Encode the message header into network representation."
+  (mime-encode-header-in-buffer 'code-conversion)
+  (run-hooks 'mime-edit-translate-header-hook))
+
+(defun mime-edit-translate-buffer ()
+  "Encode the tagged MIME message in current buffer in MIME compliant message."
+  (interactive)
+  (undo-boundary)
+  (if (catch 'mime-edit-error
+       (save-excursion
+         (run-hooks 'mime-edit-translate-buffer-hook)
+         ))
+      (progn
+       (undo)
+       (error "Translation error!")
+       )))
+
+(defun mime-edit-find-inmost ()
+  (goto-char (point-min))
+  (if (re-search-forward mime-edit-multipart-beginning-regexp nil t)
+      (let ((bb (match-beginning 0))
+           (be (match-end 0))
+           (type (buffer-substring (match-beginning 1)(match-end 1)))
+           end-exp eb)
+       (setq end-exp (format "--}-<<%s>>\n" type))
+       (widen)
+       (if (re-search-forward end-exp nil t)
+           (setq eb (match-beginning 0))
+         (setq eb (point-max))
+         )
+       (narrow-to-region be eb)
+       (goto-char be)
+       (if (re-search-forward mime-edit-multipart-beginning-regexp nil t)
+           (progn
+             (narrow-to-region (match-beginning 0)(point-max))
+             (mime-edit-find-inmost)
+             )
+         (widen)
+         (list type bb be eb)
+         ))))
+
+(defun mime-edit-process-multipart-1 (boundary)
+  (let ((ret (mime-edit-find-inmost)))
+    (if ret
+       (let ((type (car ret))
+             (bb (nth 1 ret))(be (nth 2 ret))
+             (eb (nth 3 ret))
+             )
+         (narrow-to-region bb eb)
+         (delete-region bb be)
+         (setq bb (point-min))
+         (setq eb (point-max))
+         (widen)
+         (goto-char eb)
+         (if (looking-at mime-edit-multipart-end-regexp)
+             (let ((beg (match-beginning 0))
+                   (end (match-end 0))
+                   )
+               (delete-region beg end)
+               (or (looking-at mime-edit-beginning-tag-regexp)
+                   (eobp)
+                   (insert (concat (mime-make-text-tag) "\n"))
+                   )))
+         (cond ((string-equal type "quote")
+                (mime-edit-enquote-region bb eb)
+                )
+               ((string-equal type "pgp-signed")
+                (mime-edit-sign-pgp-mime bb eb boundary)
+                )
+               ((string-equal type "pgp-encrypted")
+                (mime-edit-encrypt-pgp-mime bb eb boundary)
+                )
+               ((string-equal type "kazu-signed")
+                (mime-edit-sign-pgp-kazu bb eb boundary)
+                )
+               ((string-equal type "kazu-encrypted")
+                (mime-edit-encrypt-pgp-kazu bb eb boundary)
+                )
+               ((string-equal type "smime-signed")
+                (mime-edit-sign-smime bb eb boundary)
+                )
+               ((string-equal type "smime-encrypted")
+                (mime-edit-encrypt-smime bb eb boundary)
+                )
+               (t
+                (setq boundary
+                      (nth 2 (mime-edit-translate-region bb eb
+                                                           boundary t)))
+                (goto-char bb)
+                (insert
+                 (format "--[[multipart/%s;
+ boundary=\"%s\"][7bit]]\n"
+                         type boundary))
+                ))
+         boundary))))
+
+(defun mime-edit-enquote-region (beg end)
+  (save-excursion
+    (save-restriction
+      (narrow-to-region beg end)
+      (goto-char beg)
+      (while (re-search-forward mime-edit-single-part-tag-regexp nil t)
+       (let ((tag (buffer-substring (match-beginning 0)(match-end 0))))
+         (replace-match (concat "- " (substring tag 1)))
+         )))))
+
+(defun mime-edit-dequote-region (beg end)
+  (save-excursion
+    (save-restriction
+      (narrow-to-region beg end)
+      (goto-char beg)
+      (while (re-search-forward
+             mime-edit-quoted-single-part-tag-regexp nil t)
+       (let ((tag (buffer-substring (match-beginning 0)(match-end 0))))
+         (replace-match (concat "-" (substring tag 2)))
+         )))))
+
+(defvar mime-edit-pgp-user-id nil)
+
+(defun mime-edit-sign-pgp-mime (beg end boundary)
+  (save-excursion
+    (save-restriction
+      (let* ((from (std11-field-body "From" mail-header-separator))
+            (ret (progn 
+                   (narrow-to-region beg end)
+                   (mime-edit-translate-region beg end boundary)))
+            (ctype    (car ret))
+            (encoding (nth 1 ret))
+            (pgp-boundary (concat "pgp-sign-" boundary))
+            micalg)
+       (goto-char beg)
+       (insert (format "Content-Type: %s\n" ctype))
+       (if encoding
+           (insert (format "Content-Transfer-Encoding: %s\n" encoding))
+         )
+       (insert "\n")
+       (or (let ((pgg-default-user-id 
+                  (or mime-edit-pgp-user-id
+                      (if from 
+                          (nth 1 (std11-extract-address-components from))
+                        pgg-default-user-id))))
+             (pgg-sign-region (point-min)(point-max)))
+           (throw 'mime-edit-error 'pgp-error)
+           )
+       (setq micalg
+             (cdr (assq 'hash-algorithm
+                        (cdar (with-current-buffer pgg-output-buffer
+                                (pgg-parse-armor-region 
+                                 (point-min)(point-max))))))
+             micalg 
+             (if micalg
+                 (concat "; micalg=pgp-" (downcase (symbol-name micalg)))
+               ""))
+       (goto-char beg)
+       (insert (format "--[[multipart/signed;
+ boundary=\"%s\"%s;
+ protocol=\"application/pgp-signature\"][7bit]]
+--%s
+" pgp-boundary micalg pgp-boundary))
+       (goto-char (point-max))
+       (insert (format "\n--%s
+Content-Type: application/pgp-signature
+Content-Transfer-Encoding: 7bit
+
+" pgp-boundary))
+       (insert-buffer-substring pgg-output-buffer)
+       (goto-char (point-max))
+       (insert (format "\n--%s--\n" pgp-boundary))
+       ))))
+
+(defvar mime-edit-encrypt-recipient-fields-list '("To" "cc"))
+
+(defun mime-edit-make-encrypt-recipient-header ()
+  (let* ((names mime-edit-encrypt-recipient-fields-list)
+        (values
+         (std11-field-bodies (cons "From" names)
+                             nil mail-header-separator))
+        (from (prog1
+                  (car values)
+                (setq values (cdr values))))
+        (header (and (stringp from)
+                     (if (string-equal from "")
+                         ""
+                       (format "From: %s\n" from)
+                       )))
+        recipients)
+    (while (and names values)
+      (let ((name (car names))
+           (value (car values))
+           )
+       (and (stringp value)
+            (or (string-equal value "")
+                (progn
+                  (setq header (concat header name ": " value "\n")
+                        recipients (if recipients
+                                       (concat recipients " ," value)
+                                     value))
+                  ))))
+      (setq names (cdr names)
+           values (cdr values))
+      )
+    (vector from recipients header)
+    ))
+
+(defun mime-edit-encrypt-pgp-mime (beg end boundary)
+  (save-excursion
+    (save-restriction
+      (let (from recipients header)
+        (let ((ret (mime-edit-make-encrypt-recipient-header)))
+          (setq from (aref ret 0)
+                recipients (aref ret 1)
+                header (aref ret 2))
+         )
+        (narrow-to-region beg end)
+        (let* ((ret
+                (mime-edit-translate-region beg end boundary))
+               (ctype    (car ret))
+               (encoding (nth 1 ret))
+               (pgp-boundary (concat "pgp-" boundary)))
+          (goto-char beg)
+          (insert header)
+          (insert (format "Content-Type: %s\n" ctype))
+          (if encoding
+              (insert (format "Content-Transfer-Encoding: %s\n" encoding))
+            )
+          (insert "\n")
+         (mime-encode-header-in-buffer)
+         (or (let ((pgg-default-user-id 
+                    (or mime-edit-pgp-user-id
+                        (if from 
+                            (nth 1 (std11-extract-address-components from))
+                          pgg-default-user-id))))                   
+               (pgg-encrypt-region 
+                (point-min) (point-max) 
+                (mapcar (lambda (recipient)
+                          (nth 1 (std11-extract-address-components
+                                  recipient)))
+                        (split-string recipients 
+                                      "\\([ \t\n]*,[ \t\n]*\\)+")))
+               )
+             (throw 'mime-edit-error 'pgp-error)
+             )
+         (delete-region (point-min)(point-max))
+         (goto-char beg)
+         (insert (format "--[[multipart/encrypted;
+ boundary=\"%s\";
+ protocol=\"application/pgp-encrypted\"][7bit]]
+--%s
+Content-Type: application/pgp-encrypted
+
+--%s
+Content-Type: application/octet-stream
+Content-Transfer-Encoding: 7bit
+
+" pgp-boundary pgp-boundary pgp-boundary))
+         (insert-buffer-substring pgg-output-buffer)
+         (goto-char (point-max))
+         (insert (format "\n--%s--\n" pgp-boundary))
+         )))))
+
+(defun mime-edit-sign-pgp-kazu (beg end boundary)
+  (save-excursion
+    (save-restriction
+      (narrow-to-region beg end)
+      (let* ((ret
+             (mime-edit-translate-region beg end boundary))
+            (ctype    (car ret))
+            (encoding (nth 1 ret)))
+       (goto-char beg)
+       (insert (format "Content-Type: %s\n" ctype))
+       (if encoding
+           (insert (format "Content-Transfer-Encoding: %s\n" encoding))
+         )
+       (insert "\n")
+       (or (pgg-sign-region beg (point-max) 'clearsign)
+           (throw 'mime-edit-error 'pgp-error)
+           )
+       (goto-char beg)
+       (insert
+        "--[[application/pgp; format=mime][7bit]]\n")
+       ))
+    ))
+
+(defun mime-edit-encrypt-pgp-kazu (beg end boundary)
+  (save-excursion
+    (let (recipients header)
+      (let ((ret (mime-edit-make-encrypt-recipient-header)))
+       (setq recipients (aref ret 1)
+             header (aref ret 2))
+       )
+      (save-restriction
+       (narrow-to-region beg end)
+       (let* ((ret
+               (mime-edit-translate-region beg end boundary))
+              (ctype    (car ret))
+              (encoding (nth 1 ret)))
+         (goto-char beg)
+         (insert header)
+         (insert (format "Content-Type: %s\n" ctype))
+         (if encoding
+             (insert (format "Content-Transfer-Encoding: %s\n" encoding))
+           )
+         (insert "\n")
+         (or (pgg-encrypt-region beg (point-max) recipients)
+             (throw 'mime-edit-error 'pgp-error)
+             )
+         (goto-char beg)
+         (insert
+          "--[[application/pgp; format=mime][7bit]]\n")
+         ))
+      )))
+
+(defun mime-edit-sign-smime (beg end boundary)
+  (save-excursion
+    (save-restriction
+      (let* ((ret (progn 
+                   (narrow-to-region beg end)
+                   (mime-edit-translate-region beg end boundary)))
+            (ctype    (car ret))
+            (encoding (nth 1 ret))
+            (smime-boundary (concat "smime-sign-" boundary)))
+       (goto-char beg)
+       (insert (format "Content-Type: %s\n" ctype))
+       (if encoding
+           (insert (format "Content-Transfer-Encoding: %s\n" encoding))
+         )
+       (insert "\n")
+       (let (buffer-undo-list)
+         (goto-char (point-min))
+         (while (progn (end-of-line) (not (eobp)))
+           (insert "\r")
+           (forward-line 1))
+         (or (prog1 (smime-sign-region (point-min)(point-max))
+               (push nil buffer-undo-list)
+               (ignore-errors (undo)))
+             (throw 'mime-edit-error 'pgp-error)
+             ))
+       (goto-char beg)
+       (insert (format "--[[multipart/signed;
+ boundary=\"%s\"; micalg=sha1;
+ protocol=\"application/pkcs7-signature\"][7bit]]
+--%s
+" smime-boundary smime-boundary))
+       (goto-char (point-max))
+       (insert (format "\n--%s
+Content-Type: application/pkcs7-signature; name=\"smime.p7s\"
+Content-Transfer-Encoding: base64
+Content-Disposition: attachment; filename=\"smime.p7s\"
+Content-Description: S/MIME Cryptographic Signature
+
+"  smime-boundary))
+       (insert-buffer-substring smime-output-buffer)
+       (goto-char (point-max))
+       (insert (format "\n--%s--\n" smime-boundary))
+       ))))
+
+(defun mime-edit-encrypt-smime (beg end boundary)
+  (save-excursion
+    (save-restriction
+      (let* ((ret (progn 
+                   (narrow-to-region beg end)
+                   (mime-edit-translate-region beg end boundary)))
+            (ctype    (car ret))
+            (encoding (nth 1 ret)))
+       (goto-char beg)
+       (insert (format "Content-Type: %s\n" ctype))
+       (if encoding
+           (insert (format "Content-Transfer-Encoding: %s\n" encoding))
+         )
+       (insert "\n")
+       (goto-char (point-min))
+       (while (progn (end-of-line) (not (eobp)))
+         (insert "\r")
+         (forward-line 1))
+       (or (smime-encrypt-region (point-min)(point-max))
+           (throw 'mime-edit-error 'pgp-error)
+           )
+       (delete-region (point-min)(point-max))
+       (insert "--[[application/pkcs7-mime; name=\"smime.p7m\"
+Content-Disposition: attachment; filename=\"smime.p7m\"
+Content-Description: S/MIME Encrypted Message][base64]]\n")
+       (insert-buffer-substring smime-output-buffer)
+       ))))
+
+(defsubst replace-space-with-underline (str)
+  (mapconcat (function
+             (lambda (arg)
+               (char-to-string
+                (if (eq arg ?\ )
+                    ?_
+                  arg)))) str "")
+  )
+
+(defun mime-edit-make-boundary ()
+  (concat mime-multipart-boundary "_"
+         (replace-space-with-underline (current-time-string))
+         ))
+
+(defun mime-edit-translate-body ()
+  "Encode the tagged MIME body in current buffer in MIME compliant message."
+  (interactive)
+  (save-excursion
+    (let ((boundary (mime-edit-make-boundary))
+         (i 1)
+         ret)
+      (while (mime-edit-process-multipart-1
+             (format "%s-%d" boundary i))
+       (setq i (1+ i))
+       )
+      (save-restriction
+       ;; We are interested in message body.
+       (let* ((beg
+               (progn
+                 (goto-char (point-min))
+                 (re-search-forward
+                  (concat "\n" (regexp-quote mail-header-separator)
+                          (if mime-ignore-preceding-spaces
+                              "[ \t\n]*\n" "\n")) nil 'move)
+                 (point)))
+              (end
+               (progn
+                 (goto-char (point-max))
+                 (and mime-ignore-trailing-spaces
+                      (re-search-backward "[^ \t\n]\n" beg t)
+                      (forward-char 1))
+                 (point))))
+         (setq ret (mime-edit-translate-region
+                    beg end
+                    (format "%s-%d" boundary i)))
+         ))
+      (mime-edit-dequote-region (point-min)(point-max))
+      (let ((contype (car ret))                ;Content-Type
+           (encoding (nth 1 ret))      ;Content-Transfer-Encoding
+           )
+       ;; Insert User-Agent field
+       (and mime-edit-insert-user-agent-field
+            (or (mail-position-on-field "User-Agent")
+                (insert mime-edit-user-agent-value)
+                ))
+       ;; Make primary MIME headers.
+       (or (mail-position-on-field "MIME-Version")
+           (insert mime-edit-mime-version-value))
+       ;; Remove old Content-Type and other fields.
+       (save-restriction
+         (goto-char (point-min))
+         (search-forward (concat "\n" mail-header-separator "\n") nil t)
+         (narrow-to-region (point-min) (point))
+         (goto-char (point-min))
+         (mime-delete-field "Content-Type")
+         (mime-delete-field "Content-Transfer-Encoding"))
+       ;; Then, insert Content-Type and Content-Transfer-Encoding fields.
+       (mail-position-on-field "Content-Type")
+       (insert contype)
+       (if encoding
+           (progn
+             (mail-position-on-field "Content-Transfer-Encoding")
+             (insert encoding)))
+       ))))
+
+(defun mime-edit-translate-single-part-tag (boundary &optional prefix)
+  "Translate single-part-tag to MIME header."
+  (if (re-search-forward mime-edit-single-part-tag-regexp nil t)
+      (let* ((beg (match-beginning 0))
+            (end (match-end 0))
+            (tag (buffer-substring beg end)))
+       (delete-region beg end)
+       (let ((contype (mime-edit-get-contype tag))
+             (encoding (mime-edit-get-encoding tag)))
+         (insert (concat prefix "--" boundary "\n"))
+         (save-restriction
+           (narrow-to-region (point)(point))
+           (insert "Content-Type: " contype "\n")
+           (if encoding
+               (insert "Content-Transfer-Encoding: " encoding "\n"))
+           (mime-encode-header-in-buffer))
+         (cons (and contype
+                    (downcase contype))
+               (and encoding
+                    (downcase encoding))))
+       )))
+
+(defun mime-edit-translate-region (beg end &optional boundary multipart)
+  (or boundary
+      (setq boundary (mime-edit-make-boundary))
+      )
+  (save-excursion
+    (save-restriction
+      (narrow-to-region beg end)
+      (let ((tag nil)                  ;MIME tag
+           (contype nil)               ;Content-Type
+           (encoding nil)              ;Content-Transfer-Encoding
+           (nparts 0))                 ;Number of body parts
+       ;; Normalize the body part by inserting appropriate message
+       ;; tags for every message contents.
+       (mime-edit-normalize-body)
+       ;; Counting the number of Content-Type.
+       (goto-char (point-min))
+       (while (re-search-forward mime-edit-single-part-tag-regexp nil t)
+         (setq nparts (1+ nparts)))
+       ;; Begin translation.
+       (cond
+        ((and (<= nparts 1)(not multipart))
+         ;; It's a singular message.
+         (goto-char (point-min))
+         (while (re-search-forward
+                 mime-edit-single-part-tag-regexp nil t)
+           (setq tag
+                 (buffer-substring (match-beginning 0) (match-end 0)))
+           (delete-region (match-beginning 0) (1+ (match-end 0)))
+           (setq contype (mime-edit-get-contype tag))
+           (setq encoding (mime-edit-get-encoding tag))
+           ))
+        (t
+         ;; It's a multipart message.
+         (goto-char (point-min))
+         (let ((prio mime-content-transfer-encoding-priority-list)
+               part-info nprio)
+           (when (setq part-info
+                       (mime-edit-translate-single-part-tag boundary))
+             (and (setq nprio (member (cdr part-info) prio))
+                  (setq prio nprio))
+             (while (setq part-info
+                          (mime-edit-translate-single-part-tag boundary "\n"))
+               (and (setq nprio (member (cdr part-info) prio))
+                    (setq prio nprio))))
+           ;; Define Content-Type as "multipart/mixed".
+           (setq contype
+                 (concat "multipart/mixed;\n boundary=\"" boundary "\""))
+           (setq encoding (car prio))
+           ;; Insert the trailer.
+           (goto-char (point-max))
+           (insert "\n--" boundary "--\n")
+           )))
+        (list contype encoding boundary nparts)
+        ))))
+
+(defun mime-edit-normalize-body ()
+  "Normalize the body part by inserting appropriate message tags."
+  ;; Insert the first MIME tags if necessary.
+  (goto-char (point-min))
+  (if (not (looking-at mime-edit-single-part-tag-regexp))
+      (insert (mime-make-text-tag) "\n"))
+  ;; Check each tag, and add new tag or correct it if necessary.
+  (goto-char (point-min))
+  (while (re-search-forward mime-edit-single-part-tag-regexp nil t)
+    (let* ((tag (buffer-substring (match-beginning 0) (match-end 0)))
+          (contype (mime-edit-get-contype tag))
+          (charset (mime-get-parameter contype "charset"))
+          (encoding (mime-edit-get-encoding tag)))
+      ;; Remove extra whitespaces after the tag.
+      (if (looking-at "[ \t]+$")
+         (delete-region (match-beginning 0) (match-end 0)))
+      (let ((beg (point))
+           (end (mime-edit-content-end))
+           )
+       (if (= end (point-max))
+           nil
+         (goto-char end)
+         (or (looking-at mime-edit-beginning-tag-regexp)
+             (eobp)
+             (insert (mime-make-text-tag) "\n")
+             ))
+       (visible-region beg end)
+       (goto-char beg)
+       )
+      (cond
+       ((mime-test-content-type contype "message")
+       ;; Content-type "message" should be sent as is.
+       (forward-line 1)
+       )
+       ((mime-test-content-type contype "text")
+       ;; Define charset for text if necessary.
+       (setq charset (if charset
+                         (intern (downcase charset))
+                       (mime-edit-choose-charset)))
+       (mime-edit-define-charset charset)
+       (cond ((string-equal contype "text/x-rot13-47-48")
+              (save-excursion
+                (forward-line)
+                (mule-caesar-region (point) (mime-edit-content-end))
+                ))
+             ((string-equal contype "text/enriched")
+              (save-excursion
+                (let ((beg (progn
+                             (forward-line)
+                             (point)))
+                      (end (mime-edit-content-end))
+                      )
+                  ;; Patch for hard newlines
+                   ;; (save-excursion
+                   ;;   (goto-char beg)
+                   ;;   (while (search-forward "\n" end t)
+                   ;;     (put-text-property (match-beginning 0)
+                   ;;                        (point)
+                   ;;                        'hard t)))
+                  ;; End patch for hard newlines
+                  (enriched-encode beg end nil)
+                  (goto-char beg)
+                  (if (search-forward "\n\n")
+                      (delete-region beg (match-end 0))
+                    )
+                  ))))
+       ;; Point is now on current tag.
+       ;; Define encoding and encode text if necessary.
+       (or encoding    ;Encoding is not specified.
+           (let* ((encoding
+                   (let (bits conv)
+                     (let ((ret (cdr (assq charset mime-charset-type-list))))
+                       (if ret
+                           (setq bits (car ret)
+                                 conv (nth 1 ret))
+                         (setq bits 8
+                               conv "quoted-printable")))
+                     (if (<= bits mime-transfer-level)
+                         (mime-encoding-name bits)
+                       conv)))
+                  (beg (mime-edit-content-beginning)))
+             (encode-mime-charset-region beg (mime-edit-content-end)
+                                         charset)
+             ;; Protect "From " in beginning of line
+             (save-restriction
+               (narrow-to-region beg (mime-edit-content-end))
+               (goto-char beg)
+               (let (case-fold-search)
+                 (if (re-search-forward "^From " nil t)
+                     (unless encoding
+                       (if (memq charset '(iso-2022-jp
+                                           iso-2022-jp-2
+                                           iso-2022-int-1
+                                           x-ctext))
+                           (while (progn
+                                    (replace-match "\e(BFrom ")
+                                    (re-search-forward "^From " nil t)
+                                    ))
+                         (setq encoding "quoted-printable")
+                         )))))
+             ;; canonicalize line break code
+             (or (member encoding '(nil "7bit" "8bit" "quoted-printable"))
+                 (save-restriction
+                   (narrow-to-region beg (mime-edit-content-end))
+                   (goto-char beg)
+                   (while (re-search-forward "\\(\\=\\|[^\r]\\)\n" nil t)
+                     (replace-match "\\1\r\n"))))
+             (goto-char beg)
+             (mime-encode-region beg (mime-edit-content-end)
+                                 (or encoding "7bit"))
+             (mime-edit-define-encoding encoding)
+             ))
+       (goto-char (mime-edit-content-end))
+       )
+       ((null encoding)                ;Encoding is not specified.
+       ;; Application, image, audio, video, and any other
+       ;; unknown content-type without encoding should be
+       ;; encoded.
+       (let* ((encoding "base64")      ;Encode in BASE64 by default.
+              (beg (mime-edit-content-beginning))
+              (end (mime-edit-content-end)))
+         (mime-encode-region beg end encoding)
+         (mime-edit-define-encoding encoding))
+       (forward-line 1)
+       ))
+      )))
+
+(defun mime-delete-field (field)
+  "Delete header FIELD."
+  (let ((regexp (format "^%s:[ \t]*" field)))
+    (goto-char (point-min))
+    (while (re-search-forward regexp nil t)
+      (delete-region (match-beginning 0)
+                    (1+ (std11-field-end))))))
+
+\f
+;;;
+;;; Platform dependent functions
+;;;
+
+;; Sun implementations
+
+(defun mime-edit-voice-recorder-for-sun (encoding)
+  "Record voice in a buffer using Sun audio device,
+and insert data encoded as ENCODING."
+  (message "Start the recording on %s.  Type C-g to finish the recording..."
+          (system-name))
+  (mime-insert-encoded-file "/dev/audio" encoding)
+  )
+
+\f
+;;; @ Other useful commands.
+;;;
+
+;; Message forwarding commands as content-type "message/rfc822".
+
+(defun mime-edit-insert-message (&optional message)
+  (interactive)
+  (let ((inserter (cdr (assq major-mode mime-edit-message-inserter-alist))))
+    (if (and inserter (fboundp inserter))
+       (progn
+         (mime-edit-insert-tag "message" "rfc822")
+         (funcall inserter message)
+         )
+      (message "Sorry, I don't have message inserter for your MUA.")
+      )))
+
+(defun mime-edit-insert-mail (&optional message)
+  (interactive)
+  (let ((inserter (cdr (assq major-mode mime-edit-mail-inserter-alist))))
+    (if (and inserter (fboundp inserter))
+       (progn
+         (mime-edit-insert-tag "message" "rfc822")
+         (funcall inserter message)
+         )
+      (message "Sorry, I don't have mail inserter for your MUA.")
+      )))
+
+(defun mime-edit-inserted-message-filter ()
+  (save-excursion
+    (save-restriction
+      (let ((header-start (point))
+           (case-fold-search t)
+           beg end)
+       ;; for Emacs 18
+       ;; (if (re-search-forward "^$" (marker-position (mark-marker)))
+       (if (re-search-forward "^$" (mark t))
+           (narrow-to-region header-start (match-beginning 0))
+         )
+       (goto-char header-start)
+       (while (and (re-search-forward
+                    mime-edit-yank-ignored-field-regexp nil t)
+                   (setq beg (match-beginning 0))
+                   (setq end (1+ (std11-field-end)))
+                   )
+         (delete-region beg end)
+         )
+       ))))
+
+
+;;; @ multipart enclosure
+;;;
+
+(defun mime-edit-enclose-region-internal (type beg end)
+  (save-excursion
+    (goto-char beg)
+    (save-restriction
+      (narrow-to-region beg end)
+      (insert (format "--<<%s>>-{\n" type))
+      (goto-char (point-max))
+      (insert (format "--}-<<%s>>\n" type))
+      (goto-char (point-max))
+      )
+    (or (looking-at mime-edit-beginning-tag-regexp)
+       (eobp)
+       (insert (mime-make-text-tag) "\n")
+       )
+    ))
+
+(defun mime-edit-enclose-quote-region (beg end)
+  (interactive "*r")
+  (mime-edit-enclose-region-internal 'quote beg end)
+  )
+
+(defun mime-edit-enclose-mixed-region (beg end)
+  (interactive "*r")
+  (mime-edit-enclose-region-internal 'mixed beg end)
+  )
+
+(defun mime-edit-enclose-parallel-region (beg end)
+  (interactive "*r")
+  (mime-edit-enclose-region-internal 'parallel beg end)
+  )
+
+(defun mime-edit-enclose-digest-region (beg end)
+  (interactive "*r")
+  (mime-edit-enclose-region-internal 'digest beg end)
+  )
+
+(defun mime-edit-enclose-alternative-region (beg end)
+  (interactive "*r")
+  (mime-edit-enclose-region-internal 'alternative beg end)
+  )
+
+(defun mime-edit-enclose-pgp-signed-region (beg end)
+  (interactive "*r")
+  (mime-edit-enclose-region-internal 'pgp-signed beg end)
+  )
+
+(defun mime-edit-enclose-pgp-encrypted-region (beg end)
+  (interactive "*r")
+  (mime-edit-enclose-region-internal 'pgp-encrypted beg end)
+  )
+
+(defun mime-edit-enclose-kazu-signed-region (beg end)
+  (interactive "*r")
+  (mime-edit-enclose-region-internal 'kazu-signed beg end)
+  )
+
+(defun mime-edit-enclose-kazu-encrypted-region (beg end)
+  (interactive "*r")
+  (mime-edit-enclose-region-internal 'kazu-encrypted beg end)
+  )
+
+(defun mime-edit-enclose-smime-signed-region (beg end)
+  (interactive "*r")
+  (mime-edit-enclose-region-internal 'smime-signed beg end)
+  )
+
+(defun mime-edit-enclose-smime-encrypted-region (beg end)
+  (interactive "*r")
+  (mime-edit-enclose-region-internal 'smime-encrypted beg end)
+  )
+
+(defun mime-edit-insert-key (&optional arg)
+  "Insert a pgp public key."
+  (interactive "P")
+  (mime-edit-insert-tag "application" "pgp-keys")
+  (mime-edit-define-encoding "7bit")
+  (pgg-insert-key)
+  (if (and (not (eobp))
+          (not (looking-at mime-edit-single-part-tag-regexp)))
+      (insert (mime-make-text-tag) "\n")))
+
+
+;;; @ flag setting
+;;;
+
+(defun mime-edit-set-split (arg)
+  (interactive
+   (list
+    (y-or-n-p "Do you want to enable split? ")
+    ))
+  (setq mime-edit-split-message arg)
+  (if arg
+      (message "This message is enabled to split.")
+    (message "This message is not enabled to split.")
+    ))
+
+(defun mime-edit-toggle-transfer-level (&optional transfer-level)
+  "Toggle transfer-level is 7bit or 8bit through.
+
+Optional TRANSFER-LEVEL is a number of transfer-level, 7 or 8."
+  (interactive)
+  (if (numberp transfer-level)
+      (setq mime-transfer-level transfer-level)
+    (if (< mime-transfer-level 8)
+       (setq mime-transfer-level 8)
+      (setq mime-transfer-level 7)
+      ))
+  (message (format "Current transfer-level is %d bit"
+                  mime-transfer-level))
+  (setq mime-transfer-level-string
+       (mime-encoding-name mime-transfer-level 'not-omit))
+  (force-mode-line-update)
+  )
+
+(defun mime-edit-set-transfer-level-7bit ()
+  (interactive)
+  (mime-edit-toggle-transfer-level 7)
+  )
+
+(defun mime-edit-set-transfer-level-8bit ()
+  (interactive)
+  (mime-edit-toggle-transfer-level 8)
+  )
+
+
+;;; @ pgp
+;;;
+
+(defvar mime-edit-pgp-processing nil)
+(make-variable-buffer-local 'mime-edit-pgp-processing)
+
+(defun mime-edit-set-sign (arg)
+  (interactive
+   (list
+    (y-or-n-p "Do you want to sign? ")
+    ))
+  (if arg
+      (progn
+       (or (memq 'sign mime-edit-pgp-processing)
+           (setq mime-edit-pgp-processing 
+                 (nconc mime-edit-pgp-processing 
+                        (copy-sequence '(sign)))))
+       (message "This message will be signed.")
+       )
+    (setq mime-edit-pgp-processing 
+         (delq 'sign mime-edit-pgp-processing))
+    (message "This message will not be signed.")
+    ))
+
+(defun mime-edit-set-encrypt (arg)
+  (interactive
+   (list
+    (y-or-n-p "Do you want to encrypt? ")
+    ))
+  (if arg
+      (progn
+       (or (memq 'encrypt mime-edit-pgp-processing)
+           (setq mime-edit-pgp-processing 
+                 (nconc mime-edit-pgp-processing 
+                        (copy-sequence '(encrypt)))))
+       (message "This message will be encrypt.")
+       )
+    (setq mime-edit-pgp-processing
+         (delq 'encrypt mime-edit-pgp-processing))
+    (message "This message will not be encrypt.")
+    ))
+
+(defun mime-edit-pgp-enclose-buffer ()
+  (let ((beg (save-excursion
+              (goto-char (point-min))
+              (if (search-forward (concat "\n" mail-header-separator "\n"))
+                  (match-end 0)
+                )))
+       )
+    (if beg
+       (dolist (pgp-processing mime-edit-pgp-processing)
+         (case pgp-processing
+           (sign
+            (mime-edit-enclose-pgp-signed-region 
+             beg (point-max))
+            )
+           (encrypt
+            (mime-edit-enclose-pgp-encrypted-region 
+             beg (point-max))
+            )))
+      )))
+
+
+;;; @ split
+;;;
+
+(defun mime-edit-insert-partial-header (fields subject
+                                              id number total separator)
+  (insert fields)
+  (insert (format "Subject: %s (%d/%d)\n" subject number total))
+  (insert mime-edit-mime-version-field-for-message/partial)
+  (insert (format "\
+Content-Type: message/partial; id=%s; number=%d; total=%d\n%s\n"
+                 id number total separator))
+  )
+
+(defun mime-edit-split-and-send
+  (&optional cmd lines mime-edit-message-max-length)
+  (interactive)
+  (or lines
+      (setq lines
+           (count-lines (point-min) (point-max)))
+      )
+  (or mime-edit-message-max-length
+      (setq mime-edit-message-max-length
+           (or (cdr (assq major-mode mime-edit-message-max-lines-alist))
+               mime-edit-message-default-max-lines))
+      )
+  (let* ((mime-edit-draft-file-name
+         (or (buffer-file-name)
+             (make-temp-name
+              (expand-file-name "mime-draft" temporary-file-directory))))
+        (separator mail-header-separator)
+        (id (concat "\""
+                    (replace-space-with-underline (current-time-string))
+                    "@" (system-name) "\"")))
+    (run-hooks 'mime-edit-before-split-hook)
+    (let ((the-buf (current-buffer))
+         (copy-buf (get-buffer-create " *Original Message*"))
+         (header (std11-header-string-except
+                  mime-edit-split-ignored-field-regexp separator))
+         (subject (mail-fetch-field "subject"))
+         (total (+ (/ lines mime-edit-message-max-length)
+                   (if (> (mod lines mime-edit-message-max-length) 0)
+                       1)))
+         (command
+          (or cmd
+              (cdr
+               (assq major-mode
+                     mime-edit-split-message-sender-alist))
+              (function
+               (lambda ()
+                 (interactive)
+                 (error "Split sender is not specified for `%s'." major-mode)
+                 ))
+              ))
+         (mime-edit-partial-number 1)
+         data)
+      (save-excursion
+       (set-buffer copy-buf)
+       (erase-buffer)
+       (insert-buffer the-buf)
+       (save-restriction
+         (if (re-search-forward
+              (concat "^" (regexp-quote separator) "$") nil t)
+             (let ((he (match-beginning 0)))
+               (replace-match "")
+               (narrow-to-region (point-min) he)
+               ))
+         (goto-char (point-min))
+         (while (re-search-forward mime-edit-split-blind-field-regexp nil t)
+           (delete-region (match-beginning 0)
+                          (1+ (std11-field-end)))
+           )))
+      (while (< mime-edit-partial-number total)
+       (erase-buffer)
+       (save-excursion
+         (set-buffer copy-buf)
+         (setq data (buffer-substring
+                     (point-min)
+                     (progn
+                       (goto-line mime-edit-message-max-length)
+                       (point))
+                     ))
+         (delete-region (point-min)(point))
+         )
+       (mime-edit-insert-partial-header
+        header subject id mime-edit-partial-number total separator)
+       (insert data)
+       (save-excursion
+         (message (format "Sending %d/%d..."
+                          mime-edit-partial-number total))
+         (call-interactively command)
+         (message (format "Sending %d/%d... done"
+                          mime-edit-partial-number total))
+         )
+       (setq mime-edit-partial-number
+             (1+ mime-edit-partial-number))
+       )
+      (erase-buffer)
+      (save-excursion
+       (set-buffer copy-buf)
+       (setq data (buffer-string))
+       (erase-buffer)
+       )
+      (mime-edit-insert-partial-header
+       header subject id mime-edit-partial-number total separator)
+      (insert data)
+      (save-excursion
+       (message (format "Sending %d/%d..."
+                        mime-edit-partial-number total))
+       (message (format "Sending %d/%d... done"
+                        mime-edit-partial-number total))
+       )
+      )))
+
+(defun mime-edit-maybe-split-and-send (&optional cmd)
+  (interactive)
+  (run-hooks 'mime-edit-before-send-hook)
+  (let ((mime-edit-message-max-length
+        (or (cdr (assq major-mode mime-edit-message-max-lines-alist))
+            mime-edit-message-default-max-lines))
+       (lines (count-lines (point-min) (point-max)))
+       )
+    (if (and (> lines mime-edit-message-max-length)
+            mime-edit-split-message)
+       (mime-edit-split-and-send cmd lines mime-edit-message-max-length)
+      )))
+
+
+;;; @ preview message
+;;;
+
+(defvar mime-edit-buffer nil) ; buffer local variable
+
+(defun mime-edit-preview-message ()
+  "preview editing MIME message."
+  (interactive)
+  (let* ((str (buffer-string))
+        (separator mail-header-separator)
+        (the-buf (current-buffer))
+        (buf-name (buffer-name))
+        (temp-buf-name (concat "*temp-article:" buf-name "*"))
+        (buf (get-buffer temp-buf-name))
+        (pgp-processing mime-edit-pgp-processing)
+        )
+    (if buf
+       (progn
+         (switch-to-buffer buf)
+         (erase-buffer)
+         )
+      (setq buf (get-buffer-create temp-buf-name))
+      (switch-to-buffer buf)
+      )
+    (insert str)
+    (setq major-mode 'mime-temp-message-mode)
+    (make-local-variable 'mail-header-separator)
+    (setq mail-header-separator separator)
+    (make-local-variable 'mime-edit-buffer)
+    (setq mime-edit-buffer the-buf)
+    (setq mime-edit-pgp-processing pgp-processing)
+
+    (run-hooks 'mime-edit-translate-hook)
+    (mime-edit-translate-buffer)
+    (goto-char (point-min))
+    (if (re-search-forward
+        (concat "^" (regexp-quote separator) "$"))
+       (replace-match "")
+      )
+    (mime-view-buffer)
+    (make-local-variable 'mime-edit-temp-message-buffer)
+    (setq mime-edit-temp-message-buffer buf)))
+
+(defun mime-edit-quitting-method ()
+  "Quitting method for mime-view."
+  (let* ((temp mime-edit-temp-message-buffer)
+        buf)
+    (mime-preview-kill-buffer)
+    (set-buffer temp)
+    (setq buf mime-edit-buffer)
+    (kill-buffer temp)
+    (switch-to-buffer buf)))
+
+(set-alist 'mime-preview-quitting-method-alist
+          'mime-temp-message-mode
+          #'mime-edit-quitting-method)
+
+
+;;; @ edit again
+;;;
+
+(defvar mime-edit-again-ignored-field-regexp
+  (concat "^\\(" "Content-.*\\|Mime-Version"
+         (if mime-edit-insert-user-agent-field "\\|User-Agent")
+         "\\):")
+  "Regexp for deleted header fields when `mime-edit-again' is called.")
+
+(defsubst eliminate-top-spaces (string)
+  "Eliminate top sequence of space or tab in STRING."
+  (if (string-match "^[ \t]+" string)
+      (substring string (match-end 0))
+    string))
+
+(defun mime-edit-decode-multipart-in-buffer (content-type not-decode-text)
+  (let* ((subtype
+         (or
+          (cdr (assoc (mime-content-type-parameter content-type "protocol")
+                      '(("application/pgp-encrypted" . pgp-encrypted)
+                        ("application/pgp-signature" . pgp-signed))))
+          (mime-content-type-subtype content-type)))
+        (boundary (mime-content-type-parameter content-type "boundary"))
+        (boundary-pat (concat "\n--" (regexp-quote boundary) "[ \t]*\n")))
+    (re-search-forward boundary-pat nil t)
+    (let ((bb (match-beginning 0)) eb tag)
+      (setq tag (format "\n--<<%s>>-{\n" subtype))
+      (goto-char bb)
+      (insert tag)
+      (setq bb (+ bb (length tag)))
+      (re-search-forward
+       (concat "\n--" (regexp-quote boundary) "--[ \t]*\n")
+       nil t)
+      (setq eb (match-beginning 0))
+      (replace-match (format "--}-<<%s>>\n" subtype))
+      (save-restriction
+       (narrow-to-region bb eb)
+       (goto-char (point-min))
+       (while (re-search-forward boundary-pat nil t)
+         (let ((beg (match-beginning 0))
+               end)
+           (delete-region beg (match-end 0))
+           (save-excursion
+             (if (re-search-forward boundary-pat nil t)
+                 (setq end (match-beginning 0))
+               (setq end (point-max))
+               )
+             (save-restriction
+               (narrow-to-region beg end)
+               (cond
+                ((eq subtype 'pgp-encrypted)
+                 (when (and
+                        (progn
+                          (goto-char (point-min))
+                          (re-search-forward "^-+BEGIN PGP MESSAGE-+$"
+                                             nil t))
+                        (prog1 
+                            (save-window-excursion
+                              (pgg-decrypt-region (match-beginning 0)
+                                                  (point-max)))
+                          (delete-region (point-min)(point-max))))
+                   (insert-buffer-substring pgg-output-buffer)
+                   (mime-edit-decode-message-in-buffer 
+                    nil not-decode-text)
+                   (delete-region (goto-char (point-min))
+                                  (if (search-forward "\n\n" nil t)
+                                      (match-end 0)
+                                    (point-min)))
+                   (goto-char (point-max))
+                   ))
+                (t 
+                 (mime-edit-decode-message-in-buffer
+                  (if (eq subtype 'digest)
+                      (eval-when-compile
+                        (make-mime-content-type 'message 'rfc822))
+                    )
+                  not-decode-text)
+                 (goto-char (point-max))
+                 ))
+               ))))
+       ))
+    (goto-char (point-min))
+    (or (= (point-min) 1)
+       (delete-region (point-min)
+                      (if (search-forward "\n\n" nil t)
+                          (match-end 0)
+                        (point-min)
+                        )))
+    ))
+
+(defun mime-edit-decode-single-part-in-buffer
+  (content-type not-decode-text &optional content-disposition)
+  (let* ((type (mime-content-type-primary-type content-type))
+        (subtype (mime-content-type-subtype content-type))
+        (ctype (format "%s/%s" type subtype))
+        charset
+        (pstr (let ((bytes (+ 14 (length ctype))))
+                (mapconcat (function
+                            (lambda (attr)
+                              (if (string= (car attr) "charset")
+                                  (progn
+                                    (setq charset (cdr attr))
+                                    "")
+                                (let* ((str (concat (car attr)
+                                                    "=" (cdr attr)))
+                                       (bs (length str)))
+                                  (setq bytes (+ bytes bs 2))
+                                  (if (< bytes 76)
+                                      (concat "; " str)
+                                    (setq bytes (+ bs 1))
+                                    (concat ";\n " str)
+                                    )
+                                  ))))
+                           (mime-content-type-parameters content-type) "")))
+        encoding
+        encoded
+        (limit (save-excursion
+                 (if (search-forward "\n\n" nil t)
+                     (1- (point)))))
+        (disposition-type
+         (mime-content-disposition-type content-disposition))
+        (disposition-str
+         (if disposition-type
+             (let ((bytes (+ 21 (length (format "%s" disposition-type)))))
+               (mapconcat (function
+                           (lambda (attr)
+                             (let* ((str (concat
+                                          (car attr)
+                                          "="
+                                          (if (string-equal "filename"
+                                                            (car attr))
+                                              (std11-wrap-as-quoted-string
+                                               (cdr attr))
+                                            (cdr attr))))
+                                    (bs (length str)))
+                               (setq bytes (+ bytes bs 2))
+                               (if (< bytes 76)
+                                   (concat "; " str)
+                                 (setq bytes (+ bs 1))
+                                 (concat ";\n " str)
+                                 )
+                               )))
+                          (mime-content-disposition-parameters
+                           content-disposition)
+                          ""))))
+        )
+    (if disposition-type
+       (setq pstr (format "%s\nContent-Disposition: %s%s"
+                          pstr disposition-type disposition-str))
+      )
+    (save-excursion
+      (if (re-search-forward
+          "^Content-Transfer-Encoding:" limit t)
+         (let ((beg (match-beginning 0))
+               (hbeg (match-end 0))
+               (end (std11-field-end limit)))
+           (setq encoding
+                 (downcase
+                  (eliminate-top-spaces
+                   (std11-unfold-string
+                    (buffer-substring hbeg end)))))
+           (if (or charset (eq type 'text))
+               (progn
+                 (delete-region beg (1+ end))
+                 (goto-char (point-min))
+                 (if (search-forward "\n\n" nil t)
+                     (progn
+                       (mime-decode-region
+                        (match-end 0)(point-max) encoding)
+                       (setq encoded t
+                             encoding nil)
+                       )))))))
+    (if (or encoded (not not-decode-text))
+       (progn
+         (save-excursion
+           (goto-char (point-min))
+           (while (re-search-forward "\r\n" nil t)
+             (replace-match "\n")
+             ))
+         (decode-mime-charset-region (point-min)(point-max)
+                                     (or charset default-mime-charset))
+         ))
+    (let ((he (if (re-search-forward "^$" nil t)
+                 (match-end 0)
+               (point-min)
+               )))
+      (if (and (eq type 'text)
+              (eq subtype 'x-rot13-47-48))
+         (mule-caesar-region he (point-max))
+       )
+      (if (= (point-min) 1)
+         (progn
+           (goto-char he)
+           (insert
+            (concat "\n"
+                    (mime-create-tag
+                     (format "%s/%s%s" type subtype pstr)
+                     encoding)))
+           )
+       (delete-region (point-min) he)
+       (insert
+        (mime-create-tag (format "%s/%s%s" type subtype pstr)
+                         encoding))
+       ))
+    ))
+
+;;;###autoload
+(defun mime-edit-decode-message-in-buffer (&optional default-content-type
+                                                    not-decode-text)
+  (save-excursion
+    (goto-char (point-min))
+    (let ((ctl (or (mime-read-Content-Type)
+                  default-content-type)))
+      (if ctl
+         (let ((type (mime-content-type-primary-type ctl)))
+           (cond
+            ((and (eq type 'application)
+                  (eq (mime-content-type-subtype ctl) 'pgp-signature))
+             (delete-region (point-min)(point-max))
+             )
+            ((eq type 'multipart)
+             (mime-edit-decode-multipart-in-buffer ctl not-decode-text)
+             )
+            (t
+             (mime-edit-decode-single-part-in-buffer
+              ctl not-decode-text (mime-read-Content-Disposition))
+             )))
+       (or not-decode-text
+           (decode-mime-charset-region (point-min) (point-max)
+                                       default-mime-charset))
+       )
+      (if (= (point-min) 1)
+         (progn
+           (save-restriction
+             (std11-narrow-to-header)
+             (goto-char (point-min))
+             (while (re-search-forward
+                     mime-edit-again-ignored-field-regexp nil t)
+               (delete-region (match-beginning 0) (1+ (std11-field-end)))
+               ))
+           (mime-decode-header-in-buffer (not not-decode-text))
+           ))
+      )))
+
+;;;###autoload
+(defun mime-edit-again (&optional not-decode-text no-separator not-turn-on)
+  "Convert current buffer to MIME-Edit buffer and turn on MIME-Edit mode.
+Content-Type and Content-Transfer-Encoding header fields will be
+converted to MIME-Edit tags."
+  (interactive)
+  (goto-char (point-min))
+  (if (search-forward
+       (concat "\n" (regexp-quote mail-header-separator) "\n")
+       nil t)
+      (replace-match "\n\n")
+    )
+  (mime-edit-decode-message-in-buffer nil not-decode-text)
+  (goto-char (point-min))
+  (or no-separator
+      (and (re-search-forward "^$")
+          (replace-match mail-header-separator)
+          ))
+  (or not-turn-on
+      (turn-on-mime-edit)
+      ))
+
+
+;;; @ end
+;;;
+
+(provide 'mime-edit)
+
+(run-hooks 'mime-edit-load-hook)
+
+;;; mime-edit.el ends here
diff --git a/mime/mime-image.el b/mime/mime-image.el
new file mode 100644 (file)
index 0000000..76c2335
--- /dev/null
@@ -0,0 +1,206 @@
+;;; mime-image.el --- mime-view filter to display images
+
+;; Copyright (C) 1995,1996,1997,1998 MORIOKA Tomohiko
+;; Copyright (C) 1996 Dan Rich
+
+;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
+;;     Dan Rich <drich@morpheus.corp.sgi.com>
+;;     Daiki Ueno <ueno@ueda.info.waseda.ac.jp>
+;;     Katsumi Yamaoka  <yamaoka@jpl.org>
+;; Maintainer: MORIOKA Tomohiko <morioka@jaist.ac.jp>
+;; Created: 1995/12/15
+;;     Renamed: 1997/2/21 from tm-image.el
+
+;; Keywords: image, picture, X-Face, MIME, multimedia, mail, news
+
+;; This file is part of SEMI (Showy Emacs MIME Interfaces).
+
+;; 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 XEmacs; see the file COPYING.  If not, write to the
+;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Commentary:
+;;     If you use this program with MULE, please install
+;;     etl8x16-bitmap.bdf font included in tl package.
+
+;;; Code:
+
+(eval-when-compile (require 'cl))
+
+(eval-when-compile (require 'static))
+
+(require 'mime-view)
+(require 'alist)
+(require 'path-util)
+
+(defsubst mime-image-normalize-xbm-buffer (buffer)
+  (save-excursion
+    (set-buffer buffer)
+    (let ((case-fold-search t) width height xbytes right margin)
+      (goto-char (point-min))
+      (or (re-search-forward "_width[\t ]+\\([0-9]+\\)" nil t)
+         (error "!! Illegal xbm file format" (current-buffer)))
+      (setq width (string-to-int (match-string 1))
+           xbytes (/ (+ width 7) 8))
+      (goto-char (point-min))
+      (or (re-search-forward "_height[\t ]+\\([0-9]+\\)" nil t)
+         (error "!! Illegal xbm file format" (current-buffer)))
+      (setq height (string-to-int (match-string 1)))
+      (goto-char (point-min))
+      (re-search-forward "0x[0-9a-f][0-9a-f],")
+      (delete-region (point-min) (match-beginning 0))
+      (goto-char (point-min))
+      (while (re-search-forward "[\n\r\t ,;}]" nil t)
+       (replace-match ""))
+      (goto-char (point-min))
+      (while (re-search-forward "0x" nil t)
+       (replace-match "\\x" nil t))
+      (goto-char (point-min))
+      (insert "(" (number-to-string width) " "
+             (number-to-string height) " \"")
+      (goto-char (point-max))
+      (insert "\")")
+      (goto-char (point-min))
+      (read (current-buffer)))))
+
+(static-if (featurep 'xemacs)
+    (progn
+      (defun mime-image-type-available-p (type)
+       (memq type (image-instantiator-format-list)))
+
+      (defun mime-image-create (file-or-data &optional type data-p &rest props)
+       (when (and data-p (eq type 'xbm))
+         (with-temp-buffer
+           (insert file-or-data)
+           (setq file-or-data
+                 (mime-image-normalize-xbm-buffer (current-buffer)))))
+       (let ((glyph
+              (make-glyph
+               (if (and type (mime-image-type-available-p type))
+                   (vconcat
+                    (list type (if data-p :data :file) file-or-data)
+                    props)
+                 file-or-data))))
+         (if (nothing-image-instance-p (glyph-image-instance glyph)) nil
+           glyph)))
+
+      (defun mime-image-insert (image &optional string area)
+       (let ((extent (make-extent (point)
+                                  (progn (and string
+                                              (insert string))
+                                         (point)))))
+         (set-extent-property extent 'invisible t)
+         (set-extent-end-glyph extent image))))
+  (condition-case nil
+      (progn
+       (require 'image)
+       (defalias 'mime-image-type-available-p 'image-type-available-p)
+       (defun mime-image-create
+         (file-or-data &optional type data-p &rest props)
+         (if (and data-p (eq type 'xbm))
+             (with-temp-buffer
+               (insert file-or-data)
+               (setq file-or-data
+                     (mime-image-normalize-xbm-buffer (current-buffer)))
+               (apply #'create-image (nth 2 file-or-data) type data-p
+                      (nconc
+                       (list :width (car file-or-data)
+                             :height (nth 1 file-or-data))
+                       props)))
+           (apply #'create-image file-or-data type data-p props)))
+       (defalias 'mime-image-insert 'insert-image))
+    (error
+     (condition-case nil
+        (progn
+          (require (if (featurep 'mule) 'bitmap ""))
+          (defun mime-image-read-xbm-buffer (buffer)
+            (condition-case nil
+                (mapconcat #'bitmap-compose
+                           (append (bitmap-decode-xbm
+                                    (bitmap-read-xbm-buffer
+                                     (current-buffer))) nil) "\n")
+              (error nil)))
+          (defun mime-image-insert (image &optional string area)
+            (insert image)))
+       (error
+       (defalias 'mime-image-read-xbm-buffer
+         'mime-image-normalize-xbm-buffer)
+       (defun mime-image-insert (image &optional string area)
+         (save-restriction
+           (narrow-to-region (point)(point))
+           (let ((face (gensym "mii")))
+             (or (facep face) (make-face face))
+             (set-face-stipple face image)
+             (let ((row (make-string (/ (car image)  (frame-char-width)) ? ))
+                 (height (/ (nth 1 image)  (frame-char-height)))
+                 (i 0))
+               (while (< i height)
+                 (set-text-properties (point) (progn (insert row)(point))
+                                      (list 'face face))
+                 (insert "\n")
+                 (setq i (1+ i)))))))))
+
+     (defun mime-image-type-available-p (type)
+       (eq type 'xbm))
+
+     (defun mime-image-create (file-or-data &optional type data-p &rest props)
+       (when (or (null type) (eq type 'xbm))
+        (with-temp-buffer
+          (if data-p
+              (insert file-or-data)
+            (insert-file-contents file-or-data))
+          (mime-image-read-xbm-buffer (current-buffer))))))))
+
+(defvar mime-image-format-alist
+  '((image jpeg                jpeg)
+    (image gif         gif)
+    (image tiff                tiff)
+    (image x-tiff      tiff)
+    (image xbm         xbm)
+    (image x-xbm       xbm)
+    (image x-xpixmap   xpm)
+    (image png         png)))
+
+(dolist (rule mime-image-format-alist)
+  (when (mime-image-type-available-p (nth 2 rule))
+    (ctree-set-calist-strictly
+     'mime-preview-condition
+     (list (cons 'type (car rule))(cons 'subtype (nth 1 rule))
+          '(body . visible)
+          (cons 'body-presentation-method #'mime-display-image)
+          (cons 'image-format (nth 2 rule))))))
+    
+
+;;; @ content filter for images
+;;;
+;;    (for XEmacs 19.12 or later)
+
+(defun mime-display-image (entity situation)
+  (message "Decoding image...")
+  (let ((format (cdr (assq 'image-format situation)))
+       image)
+    (setq image (mime-image-create (mime-entity-content entity) format 'data))
+    (if (null image)
+       (message "Invalid glyph!")
+      (save-excursion
+       (mime-image-insert image)
+       (insert "\n")
+       (message "Decoding image... done")))))
+
+;;; @ end
+;;;
+
+(provide 'mime-image)
+
+;;; mime-image.el ends here
diff --git a/mime/mime-parse.el b/mime/mime-parse.el
new file mode 100644 (file)
index 0000000..2323fba
--- /dev/null
@@ -0,0 +1,358 @@
+;;; mime-parse.el --- MIME message parser
+
+;; Copyright (C) 1994,1995,1996,1997,1998,1999 Free Software Foundation, Inc.
+
+;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
+;; Keywords: parse, MIME, multimedia, mail, news
+
+;; This file is part of SEMI (Spadework for Emacs MIME Interfaces).
+
+;; 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.
+
+;;; Code:
+
+(require 'mime-def)
+(require 'luna)
+(require 'std11)
+
+(autoload 'mime-entity-body-buffer "mime")
+(autoload 'mime-entity-body-start-point "mime")
+(autoload 'mime-entity-body-end-point "mime")
+
+
+;;; @ lexical analyzer
+;;;
+
+(defcustom mime-lexical-analyzer
+  '(std11-analyze-quoted-string
+    std11-analyze-domain-literal
+    std11-analyze-comment
+    std11-analyze-spaces
+    mime-analyze-tspecial
+    mime-analyze-token)
+  "*List of functions to return result of lexical analyze.
+Each function must have two arguments: STRING and START.
+STRING is the target string to be analyzed.
+START is start position of STRING to analyze.
+
+Previous function is preferred to next function.  If a function
+returns nil, next function is used.  Otherwise the return value will
+be the result."
+  :group 'mime
+  :type '(repeat function))
+
+(defun mime-analyze-tspecial (string start)
+  (if (and (> (length string) start)
+          (memq (aref string start) mime-tspecial-char-list))
+      (cons (cons 'tpecials (substring string start (1+ start)))
+           (1+ start))
+    ))
+
+(defun mime-analyze-token (string start)
+  (if (and (string-match mime-token-regexp string start)
+          (= (match-beginning 0) start))
+      (let ((end (match-end 0)))
+       (cons (cons 'mime-token (substring string start end))
+             ;;(substring string end)
+             end)
+       )))
+
+
+;;; @ field parser
+;;;
+
+(defconst mime/content-parameter-value-regexp
+  (concat "\\("
+         std11-quoted-string-regexp
+         "\\|[^; \t\n]*\\)"))
+
+(defconst mime::parameter-regexp
+  (concat "^[ \t]*\;[ \t]*\\(" mime-token-regexp "\\)"
+         "[ \t]*=[ \t]*\\(" mime/content-parameter-value-regexp "\\)"))
+
+(defun mime-parse-parameter (str)
+  (if (string-match mime::parameter-regexp str)
+      (let ((e (match-end 2)))
+       (cons
+        (cons (downcase (substring str (match-beginning 1) (match-end 1)))
+              (std11-strip-quoted-string
+               (substring str (match-beginning 2) e))
+              )
+        (substring str e)
+        ))))
+
+
+;;; @ Content-Type
+;;;
+
+;;;###autoload
+(defun mime-parse-Content-Type (string)
+  "Parse STRING as field-body of Content-Type field.
+Return value is
+    (PRIMARY-TYPE SUBTYPE (NAME1 . VALUE1)(NAME2 . VALUE2) ...)
+or nil.  PRIMARY-TYPE and SUBTYPE are symbol and NAME_n and VALUE_n
+are string."
+  (setq string (std11-unfold-string string))
+  (if (string-match `,(concat "^\\(" mime-token-regexp
+                             "\\)/\\(" mime-token-regexp "\\)") string)
+      (let* ((type (downcase
+                   (substring string (match-beginning 1) (match-end 1))))
+            (subtype (downcase
+                      (substring string (match-beginning 2) (match-end 2))))
+            ret dest)
+       (setq string (substring string (match-end 0)))
+       (while (setq ret (mime-parse-parameter string))
+         (setq dest (cons (car ret) dest)
+               string (cdr ret))
+         )
+       (make-mime-content-type (intern type)(intern subtype)
+                               (nreverse dest))
+       )))
+
+;;;###autoload
+(defun mime-read-Content-Type ()
+  "Read field-body of Content-Type field from current-buffer,
+and return parsed it.  Format of return value is as same as
+`mime-parse-Content-Type'."
+  (let ((str (std11-field-body "Content-Type")))
+    (if str
+       (mime-parse-Content-Type str)
+      )))
+
+
+;;; @ Content-Disposition
+;;;
+
+(eval-and-compile
+  (defconst mime-disposition-type-regexp mime-token-regexp)
+  )
+
+;;;###autoload
+(defun mime-parse-Content-Disposition (string)
+  "Parse STRING as field-body of Content-Disposition field."
+  (setq string (std11-unfold-string string))
+  (if (string-match (eval-when-compile
+                     (concat "^" mime-disposition-type-regexp)) string)
+      (let* ((e (match-end 0))
+            (type (downcase (substring string 0 e)))
+            ret dest)
+       (setq string (substring string e))
+       (while (setq ret (mime-parse-parameter string))
+         (setq dest (cons (car ret) dest)
+               string (cdr ret))
+         )
+       (cons (cons 'type (intern type))
+             (nreverse dest))
+       )))
+
+;;;###autoload
+(defun mime-read-Content-Disposition ()
+  "Read field-body of Content-Disposition field from current-buffer,
+and return parsed it."
+  (let ((str (std11-field-body "Content-Disposition")))
+    (if str
+       (mime-parse-Content-Disposition str)
+      )))
+
+
+;;; @ Content-Transfer-Encoding
+;;;
+
+;;;###autoload
+(defun mime-parse-Content-Transfer-Encoding (string)
+  "Parse STRING as field-body of Content-Transfer-Encoding field."
+  (let ((tokens (std11-lexical-analyze string mime-lexical-analyzer))
+       token)
+    (while (and tokens
+               (setq token (car tokens))
+               (std11-ignored-token-p token))
+      (setq tokens (cdr tokens)))
+    (if token
+       (if (eq (car token) 'mime-token)
+           (downcase (cdr token))
+         ))))
+
+;;;###autoload
+(defun mime-read-Content-Transfer-Encoding (&optional default-encoding)
+  "Read field-body of Content-Transfer-Encoding field from
+current-buffer, and return it.
+If is is not found, return DEFAULT-ENCODING."
+  (let ((str (std11-field-body "Content-Transfer-Encoding")))
+    (if str
+       (mime-parse-Content-Transfer-Encoding str)
+      default-encoding)))
+
+
+;;; @ Content-Id / Message-Id
+;;;
+
+;;;###autoload
+(defun mime-parse-msg-id (tokens)
+  "Parse TOKENS as msg-id of Content-Id or Message-Id field."
+  (car (std11-parse-msg-id tokens)))
+
+;;;###autoload
+(defun mime-uri-parse-cid (string)
+  "Parse STRING as cid URI."
+  (inline
+    (mime-parse-msg-id (cons '(specials . "<")
+                            (nconc
+                             (cdr (cdr (std11-lexical-analyze string)))
+                             '((specials . ">")))))))
+
+
+;;; @ message parser
+;;;
+
+;; (defun mime-parse-multipart (entity)
+;;   (with-current-buffer (mime-entity-body-buffer entity)
+;;     (let* ((representation-type
+;;             (mime-entity-representation-type-internal entity))
+;;            (content-type (mime-entity-content-type-internal entity))
+;;            (dash-boundary
+;;             (concat "--"
+;;                     (mime-content-type-parameter content-type "boundary")))
+;;            (delimiter       (concat "\n" (regexp-quote dash-boundary)))
+;;            (close-delimiter (concat delimiter "--[ \t]*$"))
+;;            (rsep (concat delimiter "[ \t]*\n"))
+;;            (dc-ctl
+;;             (if (eq (mime-content-type-subtype content-type) 'digest)
+;;                 (make-mime-content-type 'message 'rfc822)
+;;               (make-mime-content-type 'text 'plain)
+;;               ))
+;;            (body-start (mime-entity-body-start-point entity))
+;;            (body-end (mime-entity-body-end-point entity)))
+;;       (save-restriction
+;;         (goto-char body-end)
+;;         (narrow-to-region body-start
+;;                           (if (re-search-backward close-delimiter nil t)
+;;                               (match-beginning 0)
+;;                             body-end))
+;;         (goto-char body-start)
+;;         (if (re-search-forward
+;;              (concat "^" (regexp-quote dash-boundary) "[ \t]*\n")
+;;              nil t)
+;;             (let ((cb (match-end 0))
+;;                   ce ncb ret children
+;;                   (node-id (mime-entity-node-id-internal entity))
+;;                   (i 0))
+;;               (while (re-search-forward rsep nil t)
+;;                 (setq ce (match-beginning 0))
+;;                 (setq ncb (match-end 0))
+;;                 (save-restriction
+;;                   (narrow-to-region cb ce)
+;;                   (setq ret (mime-parse-message representation-type dc-ctl
+;;                                                 entity (cons i node-id)))
+;;                   )
+;;                 (setq children (cons ret children))
+;;                 (goto-char (setq cb ncb))
+;;                 (setq i (1+ i))
+;;                 )
+;;               (setq ce (point-max))
+;;               (save-restriction
+;;                 (narrow-to-region cb ce)
+;;                 (setq ret (mime-parse-message representation-type dc-ctl
+;;                                               entity (cons i node-id)))
+;;                 )
+;;               (setq children (cons ret children))
+;;               (mime-entity-set-children-internal entity (nreverse children))
+;;               )
+;;           (mime-entity-set-content-type-internal
+;;            entity (make-mime-content-type 'message 'x-broken))
+;;           nil)
+;;         ))))
+
+;; (defun mime-parse-encapsulated (entity)
+;;   (mime-entity-set-children-internal
+;;    entity
+;;    (with-current-buffer (mime-entity-body-buffer entity)
+;;      (save-restriction
+;;        (narrow-to-region (mime-entity-body-start-point entity)
+;;                          (mime-entity-body-end-point entity))
+;;        (list (mime-parse-message
+;;               (mime-entity-representation-type-internal entity) nil
+;;               entity (cons 0 (mime-entity-node-id-internal entity))))
+;;        ))))
+
+;; (defun mime-parse-external (entity)
+;;   (require 'mmexternal)
+;;   (mime-entity-set-children-internal
+;;    entity
+;;    (with-current-buffer (mime-entity-body-buffer entity)
+;;      (save-restriction
+;;        (narrow-to-region (mime-entity-body-start-point entity)
+;;                          (mime-entity-body-end-point entity))
+;;        (list (mime-parse-message
+;;               'mime-external-entity nil
+;;               entity (cons 0 (mime-entity-node-id-internal entity))))
+;;        ;; [tomo] Should we unify with `mime-parse-encapsulated'?
+;;        ))))
+
+(defun mime-parse-message (representation-type &optional default-ctl 
+                                              parent node-id)
+  (let ((header-start (point-min))
+       header-end
+       body-start
+       (body-end (point-max))
+       content-type)
+    (goto-char header-start)
+    (if (re-search-forward "^$" nil t)
+       (setq header-end (match-end 0)
+             body-start (if (= header-end body-end)
+                            body-end
+                          (1+ header-end)))
+      (setq header-end (point-min)
+           body-start (point-min)))
+    (save-restriction
+      (narrow-to-region header-start header-end)
+      (setq content-type (or (let ((str (std11-fetch-field "Content-Type")))
+                              (if str
+                                  (mime-parse-Content-Type str)
+                                ))
+                            default-ctl))
+      )
+    (luna-make-entity representation-type
+                     :location (current-buffer)
+                     :content-type content-type
+                     :parent parent
+                     :node-id node-id
+                     :buffer (current-buffer)
+                     :header-start header-start
+                     :header-end header-end
+                     :body-start body-start
+                     :body-end body-end)
+    ))
+
+
+;;; @ for buffer
+;;;
+
+;;;###autoload
+(defun mime-parse-buffer (&optional buffer representation-type)
+  "Parse BUFFER as a MIME message.
+If buffer is omitted, it parses current-buffer."
+  (save-excursion
+    (if buffer (set-buffer buffer))
+    (mime-parse-message (or representation-type
+                           'mime-buffer-entity) nil)))
+
+
+;;; @ end
+;;;
+
+(provide 'mime-parse)
+
+;;; mime-parse.el ends here
diff --git a/mime/mime-partial.el b/mime/mime-partial.el
new file mode 100644 (file)
index 0000000..618c5a6
--- /dev/null
@@ -0,0 +1,98 @@
+;;; mime-partial.el --- Grabbing all MIME "message/partial"s.
+
+;; Copyright (C) 1995,1996,1997,1998 Free Software Foundation, Inc.
+
+;; Author: OKABE Yasuo @ Kyoto University
+;;         MORIOKA Tomohiko <morioka@jaist.ac.jp>
+;; Keywords: message/partial, MIME, multimedia, mail, news
+
+;; This file is part of SEMI (Suite of Emacs MIME Interfaces).
+
+;; 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.
+
+;;; Code:
+
+(require 'mime-view)
+(require 'mime-play)
+
+(defun mime-combine-message/partial-pieces-automatically (entity situation)
+  "Internal method for mime-view to combine message/partial messages
+automatically."
+  (interactive)
+  (let* ((id (cdr (assoc "id" situation)))
+        (target (cdr (assq 'major-mode situation)))
+        (subject-buf (eval (cdr (assq 'summary-buffer-exp situation))))
+        (mother (current-buffer))
+        subject-id
+        (root-dir (expand-file-name
+                   (concat "m-prts-" (user-login-name))
+                   temporary-file-directory))
+        (request-partial-message-method
+         (cdr (assq 'request-partial-message-method situation)))
+        full-file)
+    (setq root-dir (concat root-dir "/" (replace-as-filename id)))
+    (setq full-file (concat root-dir "/FULL"))
+    
+    (if (null target)
+       (error "%s is not supported. Sorry." target)
+      )
+    
+    ;; if you can't parse the subject line, try simple decoding method
+    (if (or (file-exists-p full-file)
+           (not (y-or-n-p "Merge partials?"))
+           )
+       (mime-store-message/partial-piece entity situation)
+      (setq subject-id (mime-entity-read-field entity 'Subject))
+      (if (string-match "[0-9\n]+" subject-id)
+         (setq subject-id (substring subject-id 0 (match-beginning 0)))
+       )
+      (save-excursion
+       (set-buffer subject-buf)
+       (while (search-backward subject-id nil t))
+       (catch 'tag
+         (while t
+           (let* ((message
+                   ;; request message at the cursor in Subject buffer.
+                   (save-window-excursion
+                     (funcall request-partial-message-method)
+                     ))
+                  (situation (mime-entity-situation message))
+                  (the-id (cdr (assoc "id" situation))))
+             (when (string= the-id id)
+               (with-current-buffer mother
+                 (mime-store-message/partial-piece message situation)
+                 )
+               (if (file-exists-p full-file)
+                   (throw 'tag nil)
+                 ))
+             (if (not (progn
+                        (end-of-line)
+                        (search-forward subject-id nil t)
+                        ))
+                 (error "not found")
+               )
+             ))
+         )))))
+
+
+;;; @ end
+;;;
+
+(provide 'mime-partial)
+
+(run-hooks 'mime-partial-load-hook)
+
+;;; mime-partial.el ends here
diff --git a/mime/mime-pgp.el b/mime/mime-pgp.el
new file mode 100644 (file)
index 0000000..718ad9e
--- /dev/null
@@ -0,0 +1,286 @@
+;;; mime-pgp.el --- mime-view internal methods for PGP.
+
+;; Copyright (C) 1995,1996,1997,1998,1999,2000 Free Software Foundation, Inc.
+
+;; Author: MORIOKA Tomohiko <tomo@m17n.org>
+;;     Daiki Ueno <ueno@ueda.info.waseda.ac.jp>
+;; Created: 1995/12/7
+;;     Renamed: 1997/2/27 from tm-pgp.el
+;; Keywords: PGP, security, MIME, multimedia, mail, news
+
+;; This file is part of SEMI (Secure Emacs MIME Interface).
+
+;; 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:
+
+;;    This module is based on
+
+;;     [security-multipart] RFC 1847: "Security Multiparts for MIME:
+;;         Multipart/Signed and Multipart/Encrypted" by
+;;          Jim Galvin <galvin@tis.com>, Sandy Murphy <sandy@tis.com>,
+;;         Steve Crocker <crocker@cybercash.com> and
+;;          Ned Freed <ned@innosoft.com> (1995/10)
+
+;;     [PGP/MIME] RFC 2015: "MIME Security with Pretty Good Privacy
+;;         (PGP)" by Michael Elkins <elkins@aero.org> (1996/6)
+
+;;     [PGP-kazu] draft-kazu-pgp-mime-00.txt: "PGP MIME Integration"
+;;         by Kazuhiko Yamamoto <kazu@is.aist-nara.ac.jp> (1995/10;
+;;         expired)
+
+;;     [OpenPGP/MIME] draft-yamamoto-openpgp-mime-00.txt: "MIME
+;;         Security with OpenPGP (OpenPGP/MIME)" by Kazuhiko YAMAMOTO
+;;         <kazu@iijlab.net> (1998/1)
+
+;;; Code:
+
+(require 'mime-play)
+(require 'pgg-def)
+
+(autoload 'pgg-decrypt-region "pgg"
+  "PGP decryption of current region." t)
+(autoload 'pgg-verify-region "pgg"
+  "PGP verification of current region." t)
+(autoload 'pgg-snarf-keys-region "pgg"
+  "Snarf PGP public keys in current region." t)
+(autoload 'smime-decrypt-region "smime"
+  "S/MIME decryption of current region.")
+(autoload 'smime-verify-region "smime"
+  "S/MIME verification of current region.")
+(defvar smime-output-buffer)
+(defvar smime-errors-buffer)
+
+
+;;; @ Internal method for multipart/signed
+;;;
+;;; It is based on RFC 1847 (security-multipart).
+
+(defun mime-verify-multipart/signed (entity situation)
+  "Internal method to verify multipart/signed."
+  (mime-play-entity
+   (nth 1 (mime-entity-children entity)) ; entity-info of signature
+   (list (assq 'mode situation)) ; play-mode
+   ))
+
+
+;;; @ internal method for application/pgp
+;;;
+;;; It is based on draft-kazu-pgp-mime-00.txt (PGP-kazu).
+
+(defun mime-view-application/pgp (entity situation)
+  (let* ((p-win (or (get-buffer-window (current-buffer))
+                   (get-largest-window)))
+        (new-name
+         (format "%s-%s" (buffer-name) (mime-entity-number entity)))
+        (mother (current-buffer))
+        (preview-buffer (concat "*Preview-" (buffer-name) "*"))
+        representation-type message-buf)
+    (set-buffer (setq message-buf (get-buffer-create new-name)))
+    (erase-buffer)
+    (mime-insert-entity entity)
+    (cond ((progn
+            (goto-char (point-min))
+            (re-search-forward "^-+BEGIN PGP SIGNED MESSAGE-+$" nil t))
+          (pgg-verify-region (match-beginning 0)(point-max) nil 'fetch)
+          (goto-char (point-min))
+          (delete-region
+           (point-min)
+           (and
+            (re-search-forward "^-+BEGIN PGP SIGNED MESSAGE-+\n\n")
+            (match-end 0)))
+          (delete-region
+           (and (re-search-forward "^-+BEGIN PGP SIGNATURE-+")
+                (match-beginning 0))
+           (point-max))
+          (goto-char (point-min))
+          (while (re-search-forward "^- -" nil t)
+            (replace-match "-"))
+          (setq representation-type (if (mime-entity-cooked-p entity)
+                                        'cooked)))
+         ((progn
+            (goto-char (point-min))
+            (re-search-forward "^-+BEGIN PGP MESSAGE-+$" nil t))
+          (pgg-decrypt-region (point-min)(point-max))
+          (delete-region (point-min)(point-max))
+          (insert-buffer pgg-output-buffer)
+          (setq representation-type 'binary)))
+    (setq major-mode 'mime-show-message-mode)
+    (save-window-excursion
+      (mime-view-buffer nil preview-buffer mother
+                       nil representation-type)
+      (make-local-variable 'mime-view-temp-message-buffer)
+      (setq mime-view-temp-message-buffer message-buf))
+    (set-window-buffer p-win preview-buffer)))
+
+
+;;; @ Internal method for application/pgp-signature
+;;;
+;;; It is based on RFC 2015 (PGP/MIME) and
+;;; draft-yamamoto-openpgp-mime-00.txt (OpenPGP/MIME).
+
+(defun mime-verify-application/pgp-signature (entity situation)
+  "Internal method to check PGP/MIME signature."
+  (let* ((entity-node-id (mime-entity-node-id entity))
+        (mother (mime-entity-parent entity))
+        (knum (car entity-node-id))
+        (onum (if (> knum 0)
+                  (1- knum)
+                (1+ knum)))
+        (orig-entity (nth onum (mime-entity-children mother)))
+        (basename (expand-file-name "tm" temporary-file-directory))
+        (sig-file (concat (make-temp-name basename) ".asc"))
+        status)
+    (save-excursion 
+      (mime-show-echo-buffer)
+      (set-buffer mime-echo-buffer-name)
+      (set-window-start 
+       (get-buffer-window mime-echo-buffer-name)
+       (point-max)))
+    (mime-write-entity-content entity sig-file)
+    (unwind-protect
+       (with-temp-buffer
+         (mime-insert-entity orig-entity)
+         (goto-char (point-min))
+         (while (progn (end-of-line) (not (eobp)))
+           (insert "\r")
+           (forward-line 1))
+         (setq status (pgg-verify-region (point-min)(point-max) 
+                                         sig-file 'fetch))
+         (save-excursion 
+           (set-buffer mime-echo-buffer-name)
+           (insert-buffer-substring (if status pgg-output-buffer
+                                      pgg-errors-buffer))))
+      (delete-file sig-file))))
+
+
+;;; @ Internal method for application/pgp-encrypted
+;;;
+;;; It is based on RFC 2015 (PGP/MIME) and
+;;; draft-yamamoto-openpgp-mime-00.txt (OpenPGP/MIME).
+
+(defun mime-decrypt-application/pgp-encrypted (entity situation)
+  (let* ((entity-node-id (mime-entity-node-id entity))
+        (mother (mime-entity-parent entity))
+        (knum (car entity-node-id))
+        (onum (if (> knum 0)
+                  (1- knum)
+                (1+ knum)))
+        (orig-entity (nth onum (mime-entity-children mother))))
+    (mime-view-application/pgp orig-entity situation)))
+
+
+;;; @ Internal method for application/pgp-keys
+;;;
+;;; It is based on RFC 2015 (PGP/MIME) and
+;;; draft-yamamoto-openpgp-mime-00.txt (OpenPGP/MIME).
+
+(defun mime-add-application/pgp-keys (entity situation)
+  (save-excursion 
+    (mime-show-echo-buffer)
+    (set-buffer mime-echo-buffer-name)
+    (set-window-start 
+     (get-buffer-window mime-echo-buffer-name)
+     (point-max)))
+  (with-temp-buffer
+    (mime-insert-entity-content entity)
+    (mime-decode-region (point-min) (point-max)
+                        (cdr (assq 'encoding situation)))
+    (let ((status (pgg-snarf-keys-region (point-min)(point-max))))
+      (save-excursion 
+       (set-buffer mime-echo-buffer-name)
+       (insert-buffer-substring (if status pgg-output-buffer
+                                  pgg-errors-buffer))))))
+
+
+;;; @ Internal method for application/pkcs7-signature
+;;;
+;;; It is based on RFC 2633 (S/MIME version 3).
+
+(defun mime-verify-application/pkcs7-signature (entity situation)
+  "Internal method to check S/MIME signature."
+  (let* ((entity-node-id (mime-entity-node-id entity))
+        (mother (mime-entity-parent entity))
+        (knum (car entity-node-id))
+        (onum (if (> knum 0)
+                  (1- knum)
+                (1+ knum)))
+        (orig-entity (nth onum (mime-entity-children mother)))
+        (basename (expand-file-name "tm" temporary-file-directory))
+        (sig-file (concat (make-temp-name basename) ".asc"))
+        status)
+    (save-excursion 
+      (mime-show-echo-buffer)
+      (set-buffer mime-echo-buffer-name)
+      (set-window-start 
+       (get-buffer-window mime-echo-buffer-name)
+       (point-max)))
+    (mime-write-entity entity sig-file)
+    (unwind-protect
+       (with-temp-buffer
+         (mime-insert-entity orig-entity)
+         (goto-char (point-min))
+         (while (progn (end-of-line) (not (eobp)))
+           (insert "\r")
+           (forward-line 1))
+         (setq status (smime-verify-region (point-min)(point-max) 
+                                           sig-file))
+         (save-excursion 
+           (set-buffer mime-echo-buffer-name)
+           (insert-buffer-substring (if status smime-output-buffer
+                                      smime-errors-buffer))))
+      (delete-file sig-file))))
+
+
+;;; @ Internal method for application/pkcs7-mime
+;;;
+;;; It is based on RFC 2633 (S/MIME version 3).
+
+(defun mime-view-application/pkcs7-mime (entity situation)
+  (let* ((p-win (or (get-buffer-window (current-buffer))
+                   (get-largest-window)))
+        (new-name
+         (format "%s-%s" (buffer-name) (mime-entity-number entity)))
+        (mother (current-buffer))
+        (preview-buffer (concat "*Preview-" (buffer-name) "*"))
+        message-buf)
+    (when (memq (or (cdr (assq 'smime-type situation)) 'enveloped-data)
+               '(enveloped-data signed-data))
+      (set-buffer (setq message-buf (get-buffer-create new-name)))
+      (let ((inhibit-read-only t)
+           buffer-read-only)
+       (erase-buffer)
+       (mime-insert-entity entity)
+       (smime-decrypt-region (point-min)(point-max))
+       (delete-region (point-min)(point-max))
+       (insert-buffer smime-output-buffer))
+      (setq major-mode 'mime-show-message-mode)
+      (save-window-excursion
+       (mime-view-buffer nil preview-buffer mother
+                         nil 'binary)
+       (make-local-variable 'mime-view-temp-message-buffer)
+       (setq mime-view-temp-message-buffer message-buf))
+      (set-window-buffer p-win preview-buffer))))
+
+
+;;; @ end
+;;;
+
+(provide 'mime-pgp)
+
+(run-hooks 'mime-pgp-load-hook)
+
+;;; mime-pgp.el ends here
diff --git a/mime/mime-play.el b/mime/mime-play.el
new file mode 100644 (file)
index 0000000..dad7904
--- /dev/null
@@ -0,0 +1,517 @@
+;;; mime-play.el --- Playback processing module for mime-view.el
+
+;; Copyright (C) 1994,95,96,97,98,99,2000 Free Software Foundation, Inc.
+
+;; Author: MORIOKA Tomohiko <tomo@m17n.org>
+;; Created: 1995/9/26 (separated from tm-view.el)
+;;     Renamed: 1997/2/21 from tm-play.el
+;; Keywords: MIME, multimedia, mail, news
+
+;; This file is part of SEMI (Secretariat of Emacs MIME Interfaces).
+
+;; 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.
+
+;;; Code:
+
+(require 'mime-view)
+(require 'alist)
+(require 'filename)
+
+(eval-when-compile
+  (condition-case nil
+      (require 'bbdb)
+    (error (defvar bbdb-buffer-name nil)))
+  )
+
+(defcustom mime-save-directory "~/"
+  "*Name of the directory where MIME entity will be saved in.
+If t, it means current directory."
+  :group 'mime-view
+  :type '(choice (const :tag "Current directory" t)
+                (directory)))
+
+(defvar mime-play-find-every-situations t
+  "*Find every available situations if non-nil.")
+
+(defvar mime-play-messages-coding-system nil
+  "Coding system to be used for external MIME playback method.")
+
+
+;;; @ content decoder
+;;;
+
+;;;###autoload
+(defun mime-preview-play-current-entity (&optional ignore-examples mode)
+  "Play current entity.
+It decodes current entity to call internal or external method.  The
+method is selected from variable `mime-acting-condition'.
+If IGNORE-EXAMPLES (C-u prefix) is specified, this function ignores
+`mime-acting-situation-example-list'.
+If MODE is specified, play as it.  Default MODE is \"play\"."
+  (interactive "P")
+  (let ((entity (get-text-property (point) 'mime-view-entity)))
+    (if entity
+       (let ((situation
+              (get-text-property (point) 'mime-view-situation)))
+         (or mode
+             (setq mode "play"))
+         (setq situation 
+               (if (assq 'mode situation)
+                   (put-alist 'mode mode (copy-alist situation))
+                 (cons (cons 'mode mode)
+                       situation)))
+         (if ignore-examples
+             (setq situation
+                   (cons (cons 'ignore-examples ignore-examples)
+                         situation)))
+         (mime-play-entity entity situation)
+         ))))
+
+;;;###autoload
+(defun mime-play-entity (entity &optional situation ignored-method)
+  "Play entity specified by ENTITY.
+It decodes the entity to call internal or external method.  The method
+is selected from variable `mime-acting-condition'.  If MODE is
+specified, play as it.  Default MODE is \"play\"."
+  (let ((ret
+        (mime-unify-situations (mime-entity-situation entity situation)
+                               mime-acting-condition
+                               mime-acting-situation-example-list
+                               'method ignored-method
+                               mime-play-find-every-situations))
+       method)
+    (setq mime-acting-situation-example-list (cdr ret)
+         ret (car ret))
+    (cond ((cdr ret)
+          (setq ret (select-menu-alist
+                     "Methods"
+                     (mapcar (function
+                              (lambda (situation)
+                                (cons
+                                 (format "%s"
+                                         (cdr (assq 'method situation)))
+                                 situation)))
+                             ret)))
+          (setq ret (mime-sort-situation ret))
+          (add-to-list 'mime-acting-situation-example-list (cons ret 0))
+          )
+         (t
+          (setq ret (car ret))
+          ))
+    (setq method (cdr (assq 'method ret)))
+    (cond ((and (symbolp method)
+               (fboundp method))
+          (funcall method entity ret)
+          )
+         ((stringp method)
+          (mime-activate-mailcap-method entity ret)
+          )
+          ;; ((and (listp method)(stringp (car method)))
+          ;;  (mime-activate-external-method entity ret)
+          ;;  )
+         (t
+          (mime-show-echo-buffer "No method are specified for %s\n"
+                                 (mime-type/subtype-string
+                                  (cdr (assq 'type situation))
+                                  (cdr (assq 'subtype situation))))
+          (if (y-or-n-p "Do you want to save current entity to disk?")
+              (mime-save-content entity situation))
+          ))
+    ))
+
+
+;;; @ external decoder
+;;;
+
+(defvar mime-mailcap-method-filename-alist nil)
+
+(defun mime-activate-mailcap-method (entity situation)
+  (let ((method (cdr (assoc 'method situation)))
+       (name (mime-entity-safe-filename entity)))
+    (setq name
+         (if (and name (not (string= name "")))
+             (expand-file-name name temporary-file-directory)
+           (make-temp-name
+            (expand-file-name "EMI" temporary-file-directory))))
+    (mime-write-entity-content entity name)
+    (message "External method is starting...")
+    (let ((process
+          (let ((command
+                 (mime-format-mailcap-command
+                  method
+                  (cons (cons 'filename name) situation))))
+            (binary-to-text-funcall
+             mime-play-messages-coding-system
+             #'start-process command mime-echo-buffer-name
+             shell-file-name shell-command-switch command))))
+      (set-alist 'mime-mailcap-method-filename-alist process name)
+      (set-process-sentinel process 'mime-mailcap-method-sentinel))))
+
+(defun mime-mailcap-method-sentinel (process event)
+  (let ((file (cdr (assq process mime-mailcap-method-filename-alist))))
+    (if (file-exists-p file)
+       (delete-file file)
+      ))
+  (remove-alist 'mime-mailcap-method-filename-alist process)
+  (message (format "%s %s" process event)))
+
+(defvar mime-echo-window-is-shared-with-bbdb
+  (module-installed-p 'bbdb)
+  "*If non-nil, mime-echo window is shared with BBDB window.")
+
+(defvar mime-echo-window-height
+  (function
+   (lambda ()
+     (/ (window-height) 5)
+     ))
+  "*Size of mime-echo window.
+It allows function or integer.  If it is function,
+`mime-show-echo-buffer' calls it to get height of mime-echo window.
+Otherwise `mime-show-echo-buffer' uses it as height of mime-echo
+window.")
+
+(defun mime-show-echo-buffer (&rest forms)
+  "Show mime-echo buffer to display MIME-playing information."
+  (get-buffer-create mime-echo-buffer-name)
+  (let ((the-win (selected-window))
+       (win (get-buffer-window mime-echo-buffer-name)))
+    (unless win
+      (unless (and mime-echo-window-is-shared-with-bbdb
+                  (condition-case nil
+                      (setq win (get-buffer-window bbdb-buffer-name))
+                    (error nil)))
+       (select-window (get-buffer-window (or mime-preview-buffer
+                                             (current-buffer))))
+       (setq win (split-window-vertically
+                  (- (window-height)
+                     (if (functionp mime-echo-window-height)
+                         (funcall mime-echo-window-height)
+                       mime-echo-window-height)
+                     )))
+       )
+      (set-window-buffer win mime-echo-buffer-name)
+      )
+    (select-window win)
+    (goto-char (point-max))
+    (if forms
+       (let ((buffer-read-only nil))
+         (insert (apply (function format) forms))
+         ))
+    (select-window the-win)
+    ))
+
+
+;;; @ file name
+;;;
+
+(defvar mime-view-file-name-char-regexp "[A-Za-z0-9+_-]")
+
+(defvar mime-view-file-name-regexp-1
+  (concat mime-view-file-name-char-regexp "+\\."
+         mime-view-file-name-char-regexp "+"))
+
+(defvar mime-view-file-name-regexp-2
+  (concat (regexp-* mime-view-file-name-char-regexp)
+         "\\(\\." mime-view-file-name-char-regexp "+\\)*"))
+
+(defun mime-entity-safe-filename (entity)
+  (let ((filename
+        (or (mime-entity-filename entity)
+            (let ((subj
+                   (or (mime-entity-read-field entity 'Content-Description)
+                       (mime-entity-read-field entity 'Subject))))
+              (if (and subj
+                       (or (string-match mime-view-file-name-regexp-1 subj)
+                           (string-match mime-view-file-name-regexp-2 subj)))
+                  (substring subj (match-beginning 0)(match-end 0))
+                )))))
+    (if filename
+       (replace-as-filename filename)
+      )))
+
+
+;;; @ file extraction
+;;;
+
+(defun mime-save-content (entity situation)
+  (let ((name (or (mime-entity-safe-filename entity)
+                 (format "%s" (mime-entity-media-type entity))))
+       (dir (if (eq t mime-save-directory)
+                default-directory
+              mime-save-directory))
+       filename)
+    (setq filename (read-file-name
+                   (concat "File name: (default "
+                           (file-name-nondirectory name) ") ")
+                   dir
+                   (concat (file-name-as-directory dir)
+                           (file-name-nondirectory name))))
+    (if (file-directory-p filename)
+       (setq filename (concat (file-name-as-directory filename)
+                              (file-name-nondirectory name))))
+    (if (file-exists-p filename)
+       (or (yes-or-no-p (format "File %s exists. Save anyway? " filename))
+           (error "")))
+    (mime-write-entity-content entity (expand-file-name filename))
+    ))
+
+
+;;; @ file detection
+;;;
+
+(defvar mime-magic-type-alist
+  '(("^\377\330\377[\340\356]..JFIF"   image jpeg)
+    ("^\211PNG"                                image png)
+    ("^GIF8[79]"                       image gif)
+    ("^II\\*\000"                      image tiff)
+    ("^MM\000\\*"                      image tiff)
+    ("^MThd"                           audio midi)
+    ("^\000\000\001\263"               video mpeg)
+    )
+  "*Alist of regexp about magic-number vs. corresponding media-types.
+Each element looks like (REGEXP TYPE SUBTYPE).
+REGEXP is a regular expression to match against the beginning of the
+content of entity.
+TYPE is symbol to indicate primary type of media-type.
+SUBTYPE is symbol to indicate subtype of media-type.")
+
+(defun mime-detect-content (entity situation)
+  (let (type subtype)
+    (let ((mdata (mime-entity-content entity))
+         (rest mime-magic-type-alist))
+      (while (not (let ((cell (car rest)))
+                   (if cell
+                       (if (string-match (car cell) mdata)
+                           (setq type (nth 1 cell)
+                                 subtype (nth 2 cell))
+                         )
+                     t)))
+       (setq rest (cdr rest))))
+    (setq situation (del-alist 'method (copy-alist situation)))
+    (mime-play-entity entity
+                     (if type
+                         (put-alist 'type type
+                                    (put-alist 'subtype subtype
+                                               situation))
+                       situation)
+                     'mime-detect-content)))
+
+
+;;; @ mail/news message
+;;;
+
+(defun mime-preview-quitting-method-for-mime-show-message-mode ()
+  "Quitting method for mime-view.
+It is registered to variable `mime-preview-quitting-method-alist'."
+  (let ((mother mime-mother-buffer)
+       (win-conf mime-preview-original-window-configuration))
+    (if (and (boundp 'mime-view-temp-message-buffer)
+            (buffer-live-p mime-view-temp-message-buffer))
+       (kill-buffer mime-view-temp-message-buffer))
+    (mime-preview-kill-buffer)
+    (set-window-configuration win-conf)
+    (pop-to-buffer mother)))
+
+(defun mime-view-message/rfc822 (entity situation)
+  (let* ((new-name
+         (format "%s-%s" (buffer-name) (mime-entity-number entity)))
+        (mother (current-buffer))
+        (children (car (mime-entity-children entity)))
+        (preview-buffer
+         (mime-display-message
+          children new-name mother nil
+          (cdr (assq 'major-mode
+                     (get-text-property (point) 'mime-view-situation))))))
+    (or (get-buffer-window preview-buffer)
+       (let ((m-win (get-buffer-window mother)))
+         (if m-win
+             (set-window-buffer m-win preview-buffer)
+           (switch-to-buffer preview-buffer)
+           )))))
+
+
+;;; @ message/partial
+;;;
+
+(defun mime-store-message/partial-piece (entity cal)
+  (let* ((root-dir
+         (expand-file-name
+          (concat "m-prts-" (user-login-name)) temporary-file-directory))
+        (id (cdr (assoc "id" cal)))
+        (number (cdr (assoc "number" cal)))
+        (total (cdr (assoc "total" cal)))
+        file
+        (mother (current-buffer)))
+    (or (file-exists-p root-dir)
+       (make-directory root-dir))
+    (setq id (replace-as-filename id))
+    (setq root-dir (concat root-dir "/" id))
+    (or (file-exists-p root-dir)
+       (make-directory root-dir))
+    (setq file (concat root-dir "/FULL"))
+    (if (file-exists-p file)
+       (let ((full-buf (get-buffer-create "FULL"))
+             (pwin (or (get-buffer-window mother)
+                       (get-largest-window)))
+             pbuf)
+         (save-window-excursion
+           (set-buffer full-buf)
+           (erase-buffer)
+           (binary-insert-encoded-file file)
+           (setq major-mode 'mime-show-message-mode)
+           (mime-view-buffer (current-buffer) nil mother)
+           (setq pbuf (current-buffer))
+           (make-local-variable 'mime-view-temp-message-buffer)
+           (setq mime-view-temp-message-buffer full-buf))
+         (set-window-buffer pwin pbuf)
+         (select-window pwin))
+      (setq file (concat root-dir "/" number))
+      (mime-write-entity-body entity file)
+      (let ((total-file (concat root-dir "/CT")))
+       (setq total
+             (if total
+                 (progn
+                   (or (file-exists-p total-file)
+                       (save-excursion
+                         (set-buffer
+                          (get-buffer-create mime-temp-buffer-name))
+                         (erase-buffer)
+                         (insert total)
+                         (write-region (point-min)(point-max) total-file)
+                         (kill-buffer (current-buffer))
+                         ))
+                   (string-to-number total)
+                   )
+               (and (file-exists-p total-file)
+                    (save-excursion
+                      (set-buffer (find-file-noselect total-file))
+                      (prog1
+                          (and (re-search-forward "[0-9]+" nil t)
+                               (string-to-number
+                                (buffer-substring (match-beginning 0)
+                                                  (match-end 0)))
+                               )
+                        (kill-buffer (current-buffer))
+                        )))
+               )))
+      (if (and total (> total 0)
+              (>= (length (directory-files root-dir nil "^[0-9]+$" t))
+                  total))
+         (catch 'tag
+           (save-excursion
+             (set-buffer (get-buffer-create mime-temp-buffer-name))
+             (let ((full-buf (current-buffer)))
+               (erase-buffer)
+               (let ((i 1))
+                 (while (<= i total)
+                   (setq file (concat root-dir "/" (int-to-string i)))
+                   (or (file-exists-p file)
+                       (throw 'tag nil)
+                       )
+                   (binary-insert-encoded-file file)
+                   (goto-char (point-max))
+                   (setq i (1+ i))))
+               (binary-write-decoded-region
+                (point-min)(point-max)
+                (expand-file-name "FULL" root-dir))
+               (let ((i 1))
+                 (while (<= i total)
+                   (let ((file (format "%s/%d" root-dir i)))
+                     (and (file-exists-p file)
+                          (delete-file file)))
+                   (setq i (1+ i))))
+               (let ((file (expand-file-name "CT" root-dir)))
+                 (and (file-exists-p file)
+                      (delete-file file)))
+               (let ((buf (current-buffer))
+                     (pwin (or (get-buffer-window mother)
+                               (get-largest-window)))
+                     (pbuf (mime-display-message
+                            (mime-open-entity 'buffer (current-buffer))
+                            nil mother nil 'mime-show-message-mode)))
+                 (with-current-buffer pbuf
+                   (make-local-variable 'mime-view-temp-message-buffer)
+                   (setq mime-view-temp-message-buffer buf))
+                 (set-window-buffer pwin pbuf)
+                 (select-window pwin)
+                 )))))
+      )))
+
+
+;;; @ message/external-body
+;;;
+
+(defvar mime-raw-dired-function
+  (if (and (>= emacs-major-version 19) window-system)
+      (function dired-other-frame)
+    (function mime-raw-dired-function-for-one-frame)
+    ))
+
+(defun mime-raw-dired-function-for-one-frame (dir)
+  (let ((win (or (get-buffer-window mime-preview-buffer)
+                (get-largest-window))))
+    (select-window win)
+    (dired dir)
+    ))
+
+(defun mime-view-message/external-anon-ftp (entity cal)
+  (let* ((site (cdr (assoc "site" cal)))
+        (directory (cdr (assoc "directory" cal)))
+        (name (cdr (assoc "name" cal)))
+        (pathname (concat "/anonymous@" site ":" directory)))
+    (message (concat "Accessing " (expand-file-name name pathname) " ..."))
+    (funcall mime-raw-dired-function pathname)
+    (goto-char (point-min))
+    (search-forward name)
+    ))
+
+(defvar mime-raw-browse-url-function mime-browse-url-function)
+
+(defun mime-view-message/external-url (entity cal)
+  (let ((url (cdr (assoc "url" cal))))
+    (message (concat "Accessing " url " ..."))
+    (funcall mime-raw-browse-url-function url)))
+
+
+;;; @ rot13-47
+;;;
+
+(defun mime-view-caesar (entity situation)
+  "Internal method for mime-view to display ROT13-47-48 message."
+  (let ((buf (get-buffer-create
+             (format "%s-%s" (buffer-name) (mime-entity-number entity)))))
+    (with-current-buffer buf
+      (setq buffer-read-only nil)
+      (erase-buffer)
+      (mime-insert-text-content entity)
+      (mule-caesar-region (point-min) (point-max))
+      (set-buffer-modified-p nil)
+      )
+    (let ((win (get-buffer-window (current-buffer))))
+      (or (eq (selected-window) win)
+         (select-window (or win (get-largest-window)))
+         ))
+    (view-buffer buf)
+    (goto-char (point-min))
+    ))
+
+
+;;; @ end
+;;;
+
+(provide 'mime-play)
+
+;;; mime-play.el ends here
diff --git a/mime/mime-setup.el b/mime/mime-setup.el
new file mode 100644 (file)
index 0000000..dae2871
--- /dev/null
@@ -0,0 +1,47 @@
+;;; mime-setup.el --- setup file for MIME viewer and composer.
+
+;; Copyright (C) 1995,1996,1997,1998 Free Software Foundation, Inc.
+
+;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
+;; Keywords: MIME, multimedia, multilingual, mail, news
+
+;; This file is part of SEMI (Setting for Emacs MIME Interfaces).
+
+;; 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.
+
+;;; Code:
+
+(load "mail-mime-setup")
+
+(condition-case nil
+    (load "gnus-mime-setup")
+  (error (message "gnus-mime-setup is not found."))
+  )
+
+(condition-case nil
+    (load "emh-setup")
+  (error (message "emh-setup is not found."))
+  )
+
+
+;;; @ end
+;;;
+
+(provide 'mime-setup)
+
+(run-hooks 'mime-setup-load-hook)
+
+;;; mime-setup.el ends here
diff --git a/mime/mime-view.el b/mime/mime-view.el
new file mode 100644 (file)
index 0000000..8cdf3e7
--- /dev/null
@@ -0,0 +1,1869 @@
+;;; mime-view.el --- interactive MIME viewer for GNU Emacs
+
+;; Copyright (C) 1995,96,97,98,99,2000 Free Software Foundation, Inc.
+
+;; Author: MORIOKA Tomohiko <tomo@m17n.org>
+;; Created: 1994/07/13
+;;     Renamed: 1994/08/31 from tm-body.el
+;;     Renamed: 1997/02/19 from tm-view.el
+;; Keywords: MIME, multimedia, mail, news
+
+;; This file is part of SEMI (Sample of Elastic MIME Interfaces).
+
+;; 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.
+
+;;; Code:
+
+(require 'mime)
+(require 'semi-def)
+(require 'calist)
+(require 'alist)
+(require 'mime-conf)
+
+(eval-when-compile (require 'static))
+
+
+;;; @ version
+;;;
+
+(defconst mime-view-version
+  (concat (mime-product-name mime-user-interface-product) " MIME-View "
+         (mapconcat #'number-to-string
+                    (mime-product-version mime-user-interface-product) ".")
+         " (" (mime-product-code-name mime-user-interface-product) ")"))
+
+
+;;; @ variables
+;;;
+
+(defgroup mime-view nil
+  "MIME view mode"
+  :group 'mime)
+
+(defcustom mime-situation-examples-file "~/.mime-example"
+  "*File name of situation-examples demonstrated by user."
+  :group 'mime-view
+  :type 'file)
+
+(defcustom mime-preview-move-scroll nil
+  "*Decides whether to scroll when moving to next entity.
+When t, scroll the buffer. Non-nil but not t means scroll when
+the next entity is within next-screen-context-lines from top or
+buttom. Nil means don't scroll at all."
+  :group 'mime-view
+  :type '(choice (const :tag "Off" nil)
+                (const :tag "On" t)
+                (sexp :tag "Situation" 1)))
+
+(defcustom mime-view-mailcap-files
+  (let ((files '("/etc/mailcap" "/usr/etc/mailcap" "~/.mailcap")))
+    (or (member mime-mailcap-file files)
+       (setq files (cons mime-mailcap-file files)))
+    files)
+  "List of mailcap files."
+  :group 'mime-view
+  :type '(repeat file))
+
+
+;;; @ in raw-buffer (representation space)
+;;;
+
+(defvar mime-preview-buffer nil
+  "MIME-preview buffer corresponding with the (raw) buffer.")
+(make-variable-buffer-local 'mime-preview-buffer)
+
+
+(defvar mime-raw-representation-type-alist
+  '((mime-show-message-mode     . binary)
+    (mime-temp-message-mode     . binary)
+    (t                          . cooked)
+    )
+  "Alist of major-mode vs. representation-type of mime-raw-buffer.
+Each element looks like (SYMBOL . REPRESENTATION-TYPE).  SYMBOL is
+major-mode or t.  t means default.  REPRESENTATION-TYPE must be
+`binary' or `cooked'.")
+
+
+;;; @ in preview-buffer (presentation space)
+;;;
+
+(defvar mime-mother-buffer nil
+  "Mother buffer corresponding with the (MIME-preview) buffer.
+If current MIME-preview buffer is generated by other buffer, such as
+message/partial, it is called `mother-buffer'.")
+(make-variable-buffer-local 'mime-mother-buffer)
+
+;; (defvar mime-raw-buffer nil
+;;   "Raw buffer corresponding with the (MIME-preview) buffer.")
+;; (make-variable-buffer-local 'mime-raw-buffer)
+
+(defvar mime-preview-original-window-configuration nil
+  "Window-configuration before mime-view-mode is called.")
+(make-variable-buffer-local 'mime-preview-original-window-configuration)
+
+(defun mime-preview-original-major-mode (&optional recursive point)
+  "Return major-mode of original buffer.
+If optional argument RECURSIVE is non-nil and current buffer has
+mime-mother-buffer, it returns original major-mode of the
+mother-buffer."
+  (if (and recursive mime-mother-buffer)
+      (save-excursion
+       (set-buffer mime-mother-buffer)
+       (mime-preview-original-major-mode recursive)
+       )
+    (cdr (assq 'major-mode
+              (get-text-property (or point
+                                     (if (> (point) (buffer-size))
+                                         (max (1- (point-max)) (point-min))
+                                       (point)))
+                                 'mime-view-situation)))))
+
+
+;;; @ entity information
+;;;
+
+(defun mime-entity-situation (entity &optional situation)
+  "Return situation of ENTITY."
+  (let (rest param name)
+    ;; Content-Type
+    (unless (assq 'type situation)
+      (setq rest (or (mime-entity-content-type entity)
+                    (make-mime-content-type 'text 'plain))
+           situation (cons (car rest) situation)
+           rest (cdr rest))
+      )
+    (unless (assq 'subtype situation)
+      (or rest
+         (setq rest (or (cdr (mime-entity-content-type entity))
+                        '((subtype . plain)))))
+      (setq situation (cons (car rest) situation)
+           rest (cdr rest))
+      )
+    (while rest
+      (setq param (car rest))
+      (or (assoc (car param) situation)
+         (setq situation (cons param situation)))
+      (setq rest (cdr rest)))
+    
+    ;; Content-Disposition
+    (setq rest nil)
+    (unless (assq 'disposition-type situation)
+      (setq rest (mime-entity-content-disposition entity))
+      (if rest
+         (setq situation (cons (cons 'disposition-type
+                                     (mime-content-disposition-type rest))
+                               situation)
+               rest (mime-content-disposition-parameters rest))
+       ))
+    (while rest
+      (setq param (car rest)
+           name (car param))
+      (if (cond ((string= name "filename")
+                (if (assq 'filename situation)
+                    nil
+                  (setq name 'filename)))
+               ((string= name "creation-date")
+                (if (assq 'creation-date situation)
+                    nil
+                  (setq name 'creation-date)))
+               ((string= name "modification-date")
+                (if (assq 'modification-date situation)
+                    nil
+                  (setq name 'modification-date)))
+               ((string= name "read-date")
+                (if (assq 'read-date situation)
+                    nil
+                  (setq name 'read-date)))
+               ((string= name "size")
+                (if (assq 'size situation)
+                    nil
+                  (setq name 'size)))
+               (t (setq name (cons 'disposition name))
+                  (if (assoc name situation)
+                      nil
+                    name)))
+         (setq situation
+               (cons (cons name (cdr param))
+                     situation)))
+      (setq rest (cdr rest)))
+    
+    ;; Content-Transfer-Encoding
+    (or (assq 'encoding situation)
+       (setq situation
+             (cons (cons 'encoding (or (mime-entity-encoding entity)
+                                       "7bit"))
+                   situation)))
+    
+    situation))
+
+(defsubst mime-delq-null-situation (situations field
+                                              &rest ignored-values)
+  (let (dest)
+    (while situations
+      (let* ((situation (car situations))
+            (cell (assq field situation)))
+       (if cell
+           (or (memq (cdr cell) ignored-values)
+               (setq dest (cons situation dest))
+               )))
+      (setq situations (cdr situations)))
+    dest))
+
+(defun mime-compare-situation-with-example (situation example)
+  (let ((example (copy-alist example))
+       (match 0))
+    (while situation
+      (let* ((cell (car situation))
+            (key (car cell))
+            (ecell (assoc key example)))
+       (when ecell
+         (if (equal cell ecell)
+             (setq match (1+ match))
+           (setq example (delq ecell example))
+           ))
+       )
+      (setq situation (cdr situation))
+      )
+    (cons match example)
+    ))
+
+(defun mime-sort-situation (situation)
+  (sort situation
+       #'(lambda (a b)
+           (let ((a-t (car a))
+                 (b-t (car b))
+                 (order '((type . 1)
+                          (subtype . 2)
+                          (mode . 3)
+                          (method . 4)
+                          (major-mode . 5)
+                          (disposition-type . 6)
+                          ))
+                 a-order b-order)
+             (if (symbolp a-t)
+                 (let ((ret (assq a-t order)))
+                   (if ret
+                       (setq a-order (cdr ret))
+                     (setq a-order 7)
+                     ))
+               (setq a-order 8)
+               )
+             (if (symbolp b-t)
+                 (let ((ret (assq b-t order)))
+                   (if ret
+                       (setq b-order (cdr ret))
+                     (setq b-order 7)
+                     ))
+               (setq b-order 8)
+               )
+             (if (= a-order b-order)
+                 (string< (format "%s" a-t)(format "%s" b-t))
+               (< a-order b-order))
+             )))
+  )
+
+(defun mime-unify-situations (entity-situation
+                             condition situation-examples
+                             &optional required-name ignored-value
+                             every-situations)
+  (let (ret)
+    (in-calist-package 'mime-view)
+    (setq ret
+         (ctree-find-calist condition entity-situation
+                            every-situations))
+    (if required-name
+       (setq ret (mime-delq-null-situation ret required-name
+                                           ignored-value t)))
+    (or (assq 'ignore-examples entity-situation)
+       (if (cdr ret)
+           (let ((rest ret)
+                 (max-score 0)
+                 (max-escore 0)
+                 max-examples
+                 max-situations)
+             (while rest
+               (let ((situation (car rest))
+                     (examples situation-examples))
+                 (while examples
+                   (let* ((ret
+                           (mime-compare-situation-with-example
+                            situation (caar examples)))
+                          (ret-score (car ret)))
+                     (cond ((> ret-score max-score)
+                            (setq max-score ret-score
+                                  max-escore (cdar examples)
+                                  max-examples (list (cdr ret))
+                                  max-situations (list situation))
+                            )
+                           ((= ret-score max-score)
+                            (cond ((> (cdar examples) max-escore)
+                                   (setq max-escore (cdar examples)
+                                         max-examples (list (cdr ret))
+                                         max-situations (list situation))
+                                   )
+                                  ((= (cdar examples) max-escore)
+                                   (setq max-examples
+                                         (cons (cdr ret) max-examples))
+                                   (or (member situation max-situations)
+                                       (setq max-situations
+                                             (cons situation max-situations)))
+                                   )))))
+                   (setq examples (cdr examples))))
+               (setq rest (cdr rest)))
+             (when max-situations
+               (setq ret max-situations)
+               (while max-examples
+                 (let* ((example (car max-examples))
+                        (cell
+                         (assoc example situation-examples)))
+                   (if cell
+                       (setcdr cell (1+ (cdr cell)))
+                     (setq situation-examples
+                           (cons (cons example 0)
+                                 situation-examples))
+                     ))
+                 (setq max-examples (cdr max-examples))
+                 )))))
+    (cons ret situation-examples)
+    ;; ret: list of situations
+    ;; situation-examples: new examples (notoce that contents of
+    ;;                     argument `situation-examples' has bees modified)
+    ))
+
+(defun mime-view-entity-title (entity)
+  (or (mime-entity-read-field entity 'Content-Description)
+      (mime-entity-read-field entity 'Subject)
+      (mime-entity-filename entity)
+      ""))
+
+(defvar mime-preview-situation-example-list nil)
+(defvar mime-preview-situation-example-list-max-size 16)
+;; (defvar mime-preview-situation-example-condition nil)
+
+(defun mime-find-entity-preview-situation (entity
+                                          &optional default-situation)
+  (or (let ((ret
+            (mime-unify-situations
+             (append (mime-entity-situation entity)
+                     default-situation)
+             mime-preview-condition
+             mime-preview-situation-example-list)))
+       (setq mime-preview-situation-example-list
+             (cdr ret))
+       (caar ret))
+      default-situation))
+
+  
+(defvar mime-acting-situation-example-list nil)
+(defvar mime-acting-situation-example-list-max-size 16)
+(defvar mime-situation-examples-file-coding-system nil)
+
+(defun mime-view-read-situation-examples-file (&optional file)
+  (or file
+      (setq file mime-situation-examples-file))
+  (if (and file
+          (file-readable-p file))
+      (with-temp-buffer
+       (insert-file-contents file)
+       (setq mime-situation-examples-file-coding-system
+              (static-cond
+              ((boundp 'buffer-file-coding-system)
+               (symbol-value 'buffer-file-coding-system))
+              ((boundp 'file-coding-system)
+               (symbol-value 'file-coding-system))
+              (t nil))
+             ;; (and (boundp 'buffer-file-coding-system)
+              ;;      buffer-file-coding-system)
+             )
+       (condition-case error
+           (eval-buffer)
+         (error (message "%s is broken: %s" file (cdr error))))
+       ;; format check
+       (condition-case nil
+           (let ((i 0))
+             (while (and (> (length mime-preview-situation-example-list)
+                            mime-preview-situation-example-list-max-size)
+                         (< i 16))
+               (setq mime-preview-situation-example-list
+                     (mime-reduce-situation-examples
+                      mime-preview-situation-example-list))
+               (setq i (1+ i))))
+         (error (setq mime-preview-situation-example-list nil)))
+       ;; (let ((rest mime-preview-situation-example-list))
+       ;;   (while rest
+       ;;     (ctree-set-calist-strictly 'mime-preview-condition
+       ;;                                (caar rest))
+       ;;     (setq rest (cdr rest))))
+       (condition-case nil
+           (let ((i 0))
+             (while (and (> (length mime-acting-situation-example-list)
+                            mime-acting-situation-example-list-max-size)
+                         (< i 16))
+               (setq mime-acting-situation-example-list
+                     (mime-reduce-situation-examples
+                      mime-acting-situation-example-list))
+               (setq i (1+ i))))
+         (error (setq mime-acting-situation-example-list nil))))))
+
+(defun mime-save-situation-examples ()
+  (if (or mime-preview-situation-example-list
+         mime-acting-situation-example-list)
+      (let ((file mime-situation-examples-file))
+       (with-temp-buffer
+         (insert ";;; " (file-name-nondirectory file) "\n")
+         (insert "\n;; This file is generated automatically by "
+                 mime-view-version "\n\n")
+         (insert ";;; Code:\n\n")
+         (if mime-preview-situation-example-list
+             (pp `(setq mime-preview-situation-example-list
+                        ',mime-preview-situation-example-list)
+                 (current-buffer)))
+         (if mime-acting-situation-example-list
+             (pp `(setq mime-acting-situation-example-list
+                        ',mime-acting-situation-example-list)
+                 (current-buffer)))
+         (insert "\n;;; "
+                 (file-name-nondirectory file)
+                 " ends here.\n")
+          (static-cond
+          ((boundp 'buffer-file-coding-system)
+           (setq buffer-file-coding-system
+                 mime-situation-examples-file-coding-system))
+          ((boundp 'file-coding-system)
+           (setq file-coding-system
+                 mime-situation-examples-file-coding-system)))
+         ;; (setq buffer-file-coding-system
+          ;;       mime-situation-examples-file-coding-system)
+         (setq buffer-file-name file)
+         (save-buffer)))))
+
+(add-hook 'kill-emacs-hook 'mime-save-situation-examples)
+
+(defun mime-reduce-situation-examples (situation-examples)
+  (let ((len (length situation-examples))
+       i ir ic j jr jc ret
+       dest d-i d-j
+       (max-sim 0) sim
+       min-det-ret det-ret
+       min-det-org det-org
+       min-freq freq)
+    (setq i 0
+         ir situation-examples)
+    (while (< i len)
+      (setq ic (car ir)
+           j 0
+           jr situation-examples)
+      (while (< j len)
+       (unless (= i j)
+         (setq jc (car jr))
+         (setq ret (mime-compare-situation-with-example (car ic)(car jc))
+               sim (car ret)
+               det-ret (+ (length (car ic))(length (car jc)))
+               det-org (length (cdr ret))
+               freq (+ (cdr ic)(cdr jc)))
+         (cond ((< max-sim sim)
+                (setq max-sim sim
+                      min-det-ret det-ret
+                      min-det-org det-org
+                      min-freq freq
+                      d-i i
+                      d-j j
+                      dest (cons (cdr ret) freq))
+                )
+               ((= max-sim sim)
+                (cond ((> min-det-ret det-ret)
+                       (setq min-det-ret det-ret
+                             min-det-org det-org
+                             min-freq freq
+                             d-i i
+                             d-j j
+                             dest (cons (cdr ret) freq))
+                       )
+                      ((= min-det-ret det-ret)
+                       (cond ((> min-det-org det-org)
+                              (setq min-det-org det-org
+                                    min-freq freq
+                                    d-i i
+                                    d-j j
+                                    dest (cons (cdr ret) freq))
+                              )
+                             ((= min-det-org det-org)
+                              (cond ((> min-freq freq)
+                                     (setq min-freq freq
+                                           d-i i
+                                           d-j j
+                                           dest (cons (cdr ret) freq))
+                                     ))
+                              ))
+                       ))
+                ))
+         )
+       (setq jr (cdr jr)
+             j (1+ j)))
+      (setq ir (cdr ir)
+           i (1+ i)))
+    (if (> d-i d-j)
+       (setq i d-i
+             d-i d-j
+             d-j i))
+    (setq jr (nthcdr (1- d-j) situation-examples))
+    (setcdr jr (cddr jr))
+    (if (= d-i 0)
+       (setq situation-examples
+             (cdr situation-examples))
+      (setq ir (nthcdr (1- d-i) situation-examples))
+      (setcdr ir (cddr ir))
+      )
+    (if (setq ir (assoc (car dest) situation-examples))
+       (progn
+         (setcdr ir (+ (cdr ir)(cdr dest)))
+         situation-examples)
+      (cons dest situation-examples)
+      ;; situation-examples may be modified.
+      )))
+
+
+;;; @ presentation of preview
+;;;
+
+;;; @@ entity-button
+;;;
+
+;;; @@@ predicate function
+;;;
+
+;; (defun mime-view-entity-button-visible-p (entity)
+;;   "Return non-nil if header of ENTITY is visible.
+;; Please redefine this function if you want to change default setting."
+;;   (let ((media-type (mime-entity-media-type entity))
+;;         (media-subtype (mime-entity-media-subtype entity)))
+;;     (or (not (eq media-type 'application))
+;;         (and (not (eq media-subtype 'x-selection))
+;;              (or (not (eq media-subtype 'octet-stream))
+;;                  (let ((mother-entity (mime-entity-parent entity)))
+;;                    (or (not (eq (mime-entity-media-type mother-entity)
+;;                                 'multipart))
+;;                        (not (eq (mime-entity-media-subtype mother-entity)
+;;                                 'encrypted)))
+;;                    )
+;;                  )))))
+
+;;; @@@ entity button generator
+;;;
+
+(defun mime-view-insert-entity-button (entity)
+  "Insert entity-button of ENTITY."
+  (let ((entity-node-id (mime-entity-node-id entity))
+       (params (mime-entity-parameters entity))
+       (subject (mime-view-entity-title entity)))
+    (mime-insert-button
+     (let ((access-type (assoc "access-type" params))
+          (num (or (cdr (assoc "x-part-number" params))
+                   (if (consp entity-node-id)
+                       (mapconcat (function
+                                   (lambda (num)
+                                     (format "%s" (1+ num))
+                                     ))
+                                  (reverse entity-node-id) ".")
+                     "0"))
+               ))
+       (cond (access-type
+             (let ((server (assoc "server" params)))
+               (setq access-type (cdr access-type))
+               (if server
+                   (format "%s %s ([%s] %s)"
+                           num subject access-type (cdr server))
+               (let ((site (cdr (assoc "site" params)))
+                     (dir (cdr (assoc "directory" params)))
+                     (url (cdr (assoc "url" params)))
+                     )
+                 (if url
+                     (format "%s %s ([%s] %s)"
+                             num subject access-type url)
+                   (format "%s %s ([%s] %s:%s)"
+                           num subject access-type site dir))
+                 )))
+           )
+          (t
+           (let ((media-type (mime-entity-media-type entity))
+                 (media-subtype (mime-entity-media-subtype entity))
+                 (charset (cdr (assoc "charset" params)))
+                 (encoding (mime-entity-encoding entity)))
+             (concat
+              num " " subject
+              (let ((rest
+                     (format " <%s/%s%s%s>"
+                             media-type media-subtype
+                             (if charset
+                                 (concat "; " charset)
+                               "")
+                             (if encoding
+                                 (concat " (" encoding ")")
+                               ""))))
+                (if (>= (+ (current-column)(length rest))(window-width))
+                    "\n\t")
+                rest)))
+           )))
+     (function mime-preview-play-current-entity))
+    ))
+
+
+;;; @@ entity-header
+;;;
+
+(defvar mime-header-presentation-method-alist nil
+  "Alist of major mode vs. corresponding header-presentation-method functions.
+Each element looks like (SYMBOL . FUNCTION).
+SYMBOL must be major mode in raw-buffer or t.  t means default.
+Interface of FUNCTION must be (ENTITY SITUATION).")
+
+(defvar mime-view-ignored-field-list
+  '(".*Received:" ".*Path:" ".*Id:" "^References:"
+    "^Replied:" "^Errors-To:"
+    "^Lines:" "^Sender:" ".*Host:" "^Xref:"
+    "^Content-Type:" "^Precedence:"
+    "^Status:" "^X-VM-.*:")
+  "All fields that match this list will be hidden in MIME preview buffer.
+Each elements are regexp of field-name.")
+
+(defvar mime-view-visible-field-list '("^Dnas.*:" "^Message-Id:")
+  "All fields that match this list will be displayed in MIME preview buffer.
+Each elements are regexp of field-name.")
+
+
+;;; @@ entity-body
+;;;
+
+;;; @@@ predicate function
+;;;
+
+(in-calist-package 'mime-view)
+
+(defun mime-calist::field-match-method-as-default-rule (calist
+                                                       field-type field-value)
+  (let ((s-field (assq field-type calist)))
+    (cond ((null s-field)
+          (cons (cons field-type field-value) calist)
+          )
+         (t calist))))
+
+(define-calist-field-match-method
+  'header #'mime-calist::field-match-method-as-default-rule)
+
+(define-calist-field-match-method
+  'body #'mime-calist::field-match-method-as-default-rule)
+
+
+(defvar mime-preview-condition nil
+  "Condition-tree about how to display entity.")
+
+(ctree-set-calist-strictly
+ 'mime-preview-condition '((type . application)(subtype . octet-stream)
+                          (encoding . nil)
+                          (body . visible)))
+(ctree-set-calist-strictly
+ 'mime-preview-condition '((type . application)(subtype . octet-stream)
+                          (encoding . "7bit")
+                          (body . visible)))
+(ctree-set-calist-strictly
+ 'mime-preview-condition '((type . application)(subtype . octet-stream)
+                          (encoding . "8bit")
+                          (body . visible)))
+
+(ctree-set-calist-strictly
+ 'mime-preview-condition '((type . application)(subtype . pgp)
+                          (body . visible)))
+
+(ctree-set-calist-strictly
+ 'mime-preview-condition '((type . application)(subtype . x-latex)
+                          (body . visible)))
+
+(ctree-set-calist-strictly
+ 'mime-preview-condition '((type . application)(subtype . x-selection)
+                          (body . visible)))
+
+(ctree-set-calist-strictly
+ 'mime-preview-condition '((type . application)(subtype . x-comment)
+                          (body . visible)))
+
+(ctree-set-calist-strictly
+ 'mime-preview-condition '((type . message)(subtype . delivery-status)
+                          (body . visible)))
+
+(ctree-set-calist-strictly
+ 'mime-preview-condition
+ '((body . visible)
+   (body-presentation-method . mime-display-text/plain)))
+
+(ctree-set-calist-strictly
+ 'mime-preview-condition
+ '((type . nil)
+   (body . visible)
+   (body-presentation-method . mime-display-text/plain)))
+
+(ctree-set-calist-strictly
+ 'mime-preview-condition
+ '((type . text)(subtype . enriched)
+   (body . visible)
+   (body-presentation-method . mime-display-text/enriched)))
+
+(ctree-set-calist-strictly
+ 'mime-preview-condition
+ '((type . text)(subtype . richtext)
+   (body . visible)
+   (body-presentation-method . mime-display-text/richtext)))
+
+(autoload 'mime-display-application/x-postpet "postpet")
+
+(ctree-set-calist-strictly
+ 'mime-preview-condition
+ '((type . application)(subtype . x-postpet)
+   (body . visible)
+   (body-presentation-method . mime-display-application/x-postpet)))
+
+(ctree-set-calist-strictly
+ 'mime-preview-condition
+ '((type . text)(subtype . t)
+   (body . visible)
+   (body-presentation-method . mime-display-text/plain)))
+
+(ctree-set-calist-strictly
+ 'mime-preview-condition
+ '((type . multipart)(subtype . alternative)
+   (body . visible)
+   (body-presentation-method . mime-display-multipart/alternative)))
+
+(ctree-set-calist-strictly
+ 'mime-preview-condition
+ '((type . multipart)(subtype . t)
+   (body . visible)
+   (body-presentation-method . mime-display-multipart/mixed)))
+
+(ctree-set-calist-strictly
+ 'mime-preview-condition
+ '((type . message)(subtype . partial)
+   (body . visible)
+   (body-presentation-method . mime-display-message/partial-button)))
+
+(ctree-set-calist-strictly
+ 'mime-preview-condition
+ '((type . message)(subtype . rfc822)
+   (body . visible)
+   (body-presentation-method . mime-display-multipart/mixed)
+   (childrens-situation (header . visible)
+                       (entity-button . invisible))))
+
+(ctree-set-calist-strictly
+ 'mime-preview-condition
+ '((type . message)(subtype . news)
+   (body . visible)
+   (body-presentation-method . mime-display-multipart/mixed)
+   (childrens-situation (header . visible)
+                       (entity-button . invisible))))
+
+
+;;; @@@ entity presentation
+;;;
+
+(defun mime-display-text/plain (entity situation)
+  (save-restriction
+    (narrow-to-region (point-max)(point-max))
+    (condition-case nil
+       (mime-insert-text-content entity)
+      (error (progn
+              (message "Can't decode current entity.")
+              (sit-for 1))))
+    (run-hooks 'mime-text-decode-hook)
+    (goto-char (point-max))
+    (if (not (eq (char-after (1- (point))) ?\n))
+       (insert "\n")
+      )
+    (mime-add-url-buttons)
+    (run-hooks 'mime-display-text/plain-hook)
+    ))
+
+(defun mime-display-text/richtext (entity situation)
+  (save-restriction
+    (narrow-to-region (point-max)(point-max))
+    (mime-insert-text-content entity)
+    (run-hooks 'mime-text-decode-hook)
+    (let ((beg (point-min)))
+      (remove-text-properties beg (point-max) '(face nil))
+      (richtext-decode beg (point-max))
+      )))
+
+(defun mime-display-text/enriched (entity situation)
+  (save-restriction
+    (narrow-to-region (point-max)(point-max))
+    (mime-insert-text-content entity)
+    (run-hooks 'mime-text-decode-hook)
+    (let ((beg (point-min)))
+      (remove-text-properties beg (point-max) '(face nil))
+      (enriched-decode beg (point-max))
+      )))
+
+
+(defvar mime-view-announcement-for-message/partial
+  (if (and (>= emacs-major-version 19) window-system)
+      "\
+\[[ This is message/partial style split message. ]]
+\[[ Please press `v' key in this buffer          ]]
+\[[ or click here by mouse button-2.             ]]"
+    "\
+\[[ This is message/partial style split message. ]]
+\[[ Please press `v' key in this buffer.         ]]"
+    ))
+
+(defun mime-display-message/partial-button (&optional entity situation)
+  (save-restriction
+    (goto-char (point-max))
+    (if (not (search-backward "\n\n" nil t))
+       (insert "\n")
+      )
+    (goto-char (point-max))
+    (narrow-to-region (point-max)(point-max))
+    (insert mime-view-announcement-for-message/partial)
+    (mime-add-button (point-min)(point-max)
+                    #'mime-preview-play-current-entity)
+    ))
+
+(defun mime-display-multipart/mixed (entity situation)
+  (let ((children (mime-entity-children entity))
+       (original-major-mode-cell (assq 'major-mode situation))
+       (default-situation
+         (cdr (assq 'childrens-situation situation))))
+    (if original-major-mode-cell
+       (setq default-situation
+             (cons original-major-mode-cell default-situation)))
+    (while children
+      (mime-display-entity (car children) nil default-situation)
+      (setq children (cdr children))
+      )))
+
+(defcustom mime-view-type-subtype-score-alist
+  '(((text . enriched) . 3)
+    ((text . richtext) . 2)
+    ((text . plain)    . 1)
+    (t . 0))
+  "Alist MEDIA-TYPE vs corresponding score.
+MEDIA-TYPE must be (TYPE . SUBTYPE), TYPE or t.  t means default."
+  :group 'mime-view
+  :type '(repeat (cons (choice :tag "Media-Type"
+                              (cons :tag "Type/Subtype"
+                                    (symbol :tag "Primary-type")
+                                    (symbol :tag "Subtype"))
+                              (symbol :tag "Type")
+                              (const :tag "Default" t))
+                      integer)))
+
+(defun mime-display-multipart/alternative (entity situation)
+  (let* ((children (mime-entity-children entity))
+        (original-major-mode-cell (assq 'major-mode situation))
+        (default-situation
+          (cdr (assq 'childrens-situation situation)))
+        (i 0)
+        (p 0)
+        (max-score 0)
+        situations)
+    (if original-major-mode-cell
+       (setq default-situation
+             (cons original-major-mode-cell default-situation)))
+    (setq situations
+         (mapcar (function
+                  (lambda (child)
+                    (let ((situation
+                           (mime-find-entity-preview-situation
+                            child default-situation)))
+                      (if (cdr (assq 'body-presentation-method situation))
+                          (let ((score
+                                 (cdr
+                                  (or (assoc
+                                       (cons
+                                        (cdr (assq 'type situation))
+                                        (cdr (assq 'subtype situation)))
+                                       mime-view-type-subtype-score-alist)
+                                      (assq
+                                       (cdr (assq 'type situation))
+                                       mime-view-type-subtype-score-alist)
+                                      (assq
+                                       t
+                                       mime-view-type-subtype-score-alist)
+                                      ))))
+                            (if (> score max-score)
+                                (setq p i
+                                      max-score score)
+                              )))
+                      (setq i (1+ i))
+                      situation)
+                    ))
+                 children))
+    (setq i 0)
+    (while children
+      (let ((child (car children))
+           (situation (car situations)))
+       (mime-display-entity child (if (= i p)
+                                      situation
+                                    (put-alist 'body 'invisible
+                                               (copy-alist situation)))))
+      (setq children (cdr children)
+           situations (cdr situations)
+           i (1+ i)))))
+
+
+;;; @ acting-condition
+;;;
+
+(defvar mime-acting-condition nil
+  "Condition-tree about how to process entity.")
+
+(defun mime-view-read-mailcap-files (&optional files)
+  (or files
+      (setq files mime-view-mailcap-files))
+  (let (entries file)
+    (while files
+      (setq file (car files))
+      (if (file-readable-p file)
+         (setq entries (append entries (mime-parse-mailcap-file file))))
+      (setq files (cdr files)))
+    (while entries
+      (let ((entry (car entries))
+           view print shared)
+       (while entry
+         (let* ((field (car entry))
+                (field-type (car field)))
+           (cond ((eq field-type 'view)  (setq view field))
+                 ((eq field-type 'print) (setq print field))
+                 ((memq field-type '(compose composetyped edit)))
+                 (t (setq shared (cons field shared))))
+           )
+         (setq entry (cdr entry)))
+       (setq shared (nreverse shared))
+       (ctree-set-calist-with-default
+        'mime-acting-condition
+        (append shared (list '(mode . "play")(cons 'method (cdr view)))))
+       (if print
+           (ctree-set-calist-with-default
+            'mime-acting-condition
+            (append shared
+                    (list '(mode . "print")(cons 'method (cdr view)))))))
+      (setq entries (cdr entries)))))
+
+(mime-view-read-mailcap-files)
+
+(ctree-set-calist-strictly
+ 'mime-acting-condition
+ '((type . application)(subtype . octet-stream)
+   (mode . "play")
+   (method . mime-detect-content)
+   ))
+
+(ctree-set-calist-with-default
+ 'mime-acting-condition
+ '((mode . "extract")
+   (method . mime-save-content)))
+
+(ctree-set-calist-strictly
+ 'mime-acting-condition
+ '((type . text)(subtype . x-rot13-47)(mode . "play")
+   (method . mime-view-caesar)
+   ))
+(ctree-set-calist-strictly
+ 'mime-acting-condition
+ '((type . text)(subtype . x-rot13-47-48)(mode . "play")
+   (method . mime-view-caesar)
+   ))
+
+(ctree-set-calist-strictly
+ 'mime-acting-condition
+ '((type . message)(subtype . rfc822)(mode . "play")
+   (method . mime-view-message/rfc822)
+   ))
+(ctree-set-calist-strictly
+ 'mime-acting-condition
+ '((type . message)(subtype . partial)(mode . "play")
+   (method . mime-store-message/partial-piece)
+   ))
+
+(ctree-set-calist-strictly
+ 'mime-acting-condition
+ '((type . message)(subtype . external-body)
+   ("access-type" . "anon-ftp")
+   (method . mime-view-message/external-anon-ftp)
+   ))
+
+(ctree-set-calist-strictly
+ 'mime-acting-condition
+ '((type . message)(subtype . external-body)
+   ("access-type" . "url")
+   (method . mime-view-message/external-url)
+   ))
+
+(ctree-set-calist-strictly
+ 'mime-acting-condition
+ '((type . application)(subtype . octet-stream)
+   (method . mime-save-content)
+   ))
+
+
+;;; @ quitting method
+;;;
+
+(defvar mime-preview-quitting-method-alist
+  '((mime-show-message-mode
+     . mime-preview-quitting-method-for-mime-show-message-mode))
+  "Alist of major-mode vs. quitting-method of mime-view.")
+
+(defvar mime-preview-over-to-previous-method-alist nil
+  "Alist of major-mode vs. over-to-previous-method of mime-view.")
+
+(defvar mime-preview-over-to-next-method-alist nil
+  "Alist of major-mode vs. over-to-next-method of mime-view.")
+
+
+;;; @ following method
+;;;
+
+(defvar mime-preview-following-method-alist nil
+  "Alist of major-mode vs. following-method of mime-view.")
+
+(defvar mime-view-following-required-fields-list
+  '("From"))
+
+
+;;; @ buffer setup
+;;;
+
+(defun mime-display-entity (entity &optional situation
+                                  default-situation preview-buffer)
+  (or preview-buffer
+      (setq preview-buffer (current-buffer)))
+  (let* (e nb ne nhb nbb)
+    (in-calist-package 'mime-view)
+    (or situation
+       (setq situation
+             (mime-find-entity-preview-situation entity default-situation)))
+    (let ((button-is-invisible
+          (eq (cdr (or (assq '*entity-button situation)
+                       (assq 'entity-button situation)))
+              'invisible))
+         (header-is-visible
+          (eq (cdr (or (assq '*header situation)
+                       (assq 'header situation)))
+              'visible))
+         (body-is-visible
+          (eq (cdr (or (assq '*body situation)
+                       (assq 'body situation)))
+              'visible))
+         (children (mime-entity-children entity)))
+      (set-buffer preview-buffer)
+      (setq nb (point))
+      (narrow-to-region nb nb)
+      (or button-is-invisible
+          ;; (if (mime-view-entity-button-visible-p entity)
+         (mime-view-insert-entity-button entity)
+          ;;   )
+         )
+      (if header-is-visible
+         (let ((header-presentation-method
+                (or (cdr (assq 'header-presentation-method situation))
+                    (cdr (assq (cdr (assq 'major-mode situation))
+                               mime-header-presentation-method-alist)))))
+           (setq nhb (point))
+           (if header-presentation-method
+               (funcall header-presentation-method entity situation)
+             (mime-insert-header entity
+                                 mime-view-ignored-field-list
+                                 mime-view-visible-field-list))
+           (run-hooks 'mime-display-header-hook)
+           (put-text-property nhb (point-max) 'mime-view-entity-header entity)
+           (goto-char (point-max))
+           (insert "\n")))
+      (setq nbb (point))
+      (unless children
+       (if body-is-visible
+           (let ((body-presentation-method
+                  (cdr (assq 'body-presentation-method situation))))
+             (if (functionp body-presentation-method)
+                 (funcall body-presentation-method entity situation)
+               (mime-display-text/plain entity situation)))
+         (when button-is-invisible
+           (goto-char (point-max))
+           (mime-view-insert-entity-button entity)
+           )
+         (unless header-is-visible
+           (goto-char (point-max))
+           (insert "\n"))
+         ))
+      (setq ne (point-max))
+      (widen)
+      (put-text-property nb ne 'mime-view-entity entity)
+      (put-text-property nb ne 'mime-view-situation situation)
+      (put-text-property nbb ne 'mime-view-entity-body entity)
+      (goto-char ne)
+      (if (and children body-is-visible)
+         (let ((body-presentation-method
+                (cdr (assq 'body-presentation-method situation))))
+           (if (functionp body-presentation-method)
+               (funcall body-presentation-method entity situation)
+             (mime-display-multipart/mixed entity situation))))
+      )))
+
+
+;;; @ MIME viewer mode
+;;;
+
+(defconst mime-view-menu-title "MIME-View")
+(defconst mime-view-menu-list
+  '((up                 "Move to upper entity"    mime-preview-move-to-upper)
+    (previous   "Move to previous entity" mime-preview-move-to-previous)
+    (next       "Move to next entity"     mime-preview-move-to-next)
+    (scroll-down "Scroll-down"             mime-preview-scroll-down-entity)
+    (scroll-up  "Scroll-up"               mime-preview-scroll-up-entity)
+    (play       "Play current entity"     mime-preview-play-current-entity)
+    (extract    "Extract current entity"  mime-preview-extract-current-entity)
+    (print      "Print current entity"    mime-preview-print-current-entity)
+    )
+  "Menu for MIME Viewer")
+
+(cond ((featurep 'xemacs)
+       (defvar mime-view-xemacs-popup-menu
+        (cons mime-view-menu-title
+              (mapcar (function
+                       (lambda (item)
+                         (vector (nth 1 item)(nth 2 item) t)
+                         ))
+                      mime-view-menu-list)))
+       (defun mime-view-xemacs-popup-menu (event)
+        "Popup the menu in the MIME Viewer buffer"
+        (interactive "e")
+        (select-window (event-window event))
+        (set-buffer (event-buffer event))
+        (popup-menu 'mime-view-xemacs-popup-menu))
+       (defvar mouse-button-2 'button2)
+       (defvar mouse-button-3 'button3)
+       )
+      (t
+       (defvar mime-view-popup-menu 
+         (let ((menu (make-sparse-keymap mime-view-menu-title)))
+           (nconc menu
+                  (mapcar (function
+                           (lambda (item)
+                             (list (intern (nth 1 item)) 'menu-item 
+                                   (nth 1 item)(nth 2 item))
+                             ))
+                          mime-view-menu-list))))
+       (defun mime-view-popup-menu (event)
+         "Popup the menu in the MIME Viewer buffer"
+         (interactive "@e")
+         (let ((menu mime-view-popup-menu) events func)
+           (setq events (x-popup-menu t menu))
+           (and events
+                (setq func (lookup-key menu (apply #'vector events)))
+                (commandp func)
+                (funcall func))))
+       (defvar mouse-button-2 [mouse-2])
+       (defvar mouse-button-3 [mouse-3])
+       ))
+
+(defun mime-view-define-keymap (&optional default)
+  (let ((mime-view-mode-map (if (keymapp default)
+                               (copy-keymap default)
+                             (make-sparse-keymap))))
+    (define-key mime-view-mode-map
+      "u"        (function mime-preview-move-to-upper))
+    (define-key mime-view-mode-map
+      "p"        (function mime-preview-move-to-previous))
+    (define-key mime-view-mode-map
+      "n"        (function mime-preview-move-to-next))
+    (define-key mime-view-mode-map
+      "\e\t"     (function mime-preview-move-to-previous))
+    (define-key mime-view-mode-map
+      "\t"       (function mime-preview-move-to-next))
+    (define-key mime-view-mode-map
+      " "        (function mime-preview-scroll-up-entity))
+    (define-key mime-view-mode-map
+      "\M- "     (function mime-preview-scroll-down-entity))
+    (define-key mime-view-mode-map
+      "\177"     (function mime-preview-scroll-down-entity))
+    (define-key mime-view-mode-map
+      "\C-m"     (function mime-preview-next-line-entity))
+    (define-key mime-view-mode-map
+      "\C-\M-m"  (function mime-preview-previous-line-entity))
+    (define-key mime-view-mode-map
+      "v"        (function mime-preview-play-current-entity))
+    (define-key mime-view-mode-map
+      "e"        (function mime-preview-extract-current-entity))
+    (define-key mime-view-mode-map
+      "\C-c\C-p" (function mime-preview-print-current-entity))
+
+    (define-key mime-view-mode-map
+      "\C-c\C-t\C-f" (function mime-preview-toggle-header))
+    (define-key mime-view-mode-map
+      "\C-c\C-th" (function mime-preview-toggle-header))
+    (define-key mime-view-mode-map
+      "\C-c\C-t\C-c" (function mime-preview-toggle-content))
+
+    (define-key mime-view-mode-map
+      "\C-c\C-v\C-f" (function mime-preview-show-header))
+    (define-key mime-view-mode-map
+      "\C-c\C-vh" (function mime-preview-show-header))
+    (define-key mime-view-mode-map
+      "\C-c\C-v\C-c" (function mime-preview-show-content))
+
+    (define-key mime-view-mode-map
+      "\C-c\C-d\C-f" (function mime-preview-hide-header))
+    (define-key mime-view-mode-map
+      "\C-c\C-dh" (function mime-preview-hide-header))
+    (define-key mime-view-mode-map
+      "\C-c\C-d\C-c" (function mime-preview-hide-content))
+
+    (define-key mime-view-mode-map
+      "a"        (function mime-preview-follow-current-entity))
+    (define-key mime-view-mode-map
+      "q"        (function mime-preview-quit))
+    (define-key mime-view-mode-map
+      "\C-c\C-x" (function mime-preview-kill-buffer))
+    ;; (define-key mime-view-mode-map
+    ;;   "<"        (function beginning-of-buffer))
+    ;; (define-key mime-view-mode-map
+    ;;   ">"        (function end-of-buffer))
+    (define-key mime-view-mode-map
+      "?"        (function describe-mode))
+    (define-key mime-view-mode-map
+      [tab] (function mime-preview-move-to-next))
+    (define-key mime-view-mode-map
+      [delete] (function mime-preview-scroll-down-entity))
+    (define-key mime-view-mode-map
+      [backspace] (function mime-preview-scroll-down-entity))
+    (if (functionp default)
+       (cond ((featurep 'xemacs)
+              (set-keymap-default-binding mime-view-mode-map default)
+              )
+             (t
+              (setq mime-view-mode-map
+                    (append mime-view-mode-map (list (cons t default))))
+              )))
+    (if mouse-button-2
+       (define-key mime-view-mode-map
+         mouse-button-2 (function mime-button-dispatcher))
+      )
+    (cond ((featurep 'xemacs)
+          (define-key mime-view-mode-map
+            mouse-button-3 (function mime-view-xemacs-popup-menu))
+          )
+         ((>= emacs-major-version 19)
+          (define-key mime-view-mode-map
+             mouse-button-3 (function mime-view-popup-menu))
+          (define-key mime-view-mode-map [menu-bar mime-view]
+            (cons mime-view-menu-title
+                  (make-sparse-keymap mime-view-menu-title)))
+          (mapcar (function
+                   (lambda (item)
+                     (define-key mime-view-mode-map
+                       (vector 'menu-bar 'mime-view (car item))
+                       (cons (nth 1 item)(nth 2 item)))
+                     ))
+                  (reverse mime-view-menu-list))
+          ))
+    ;; (run-hooks 'mime-view-define-keymap-hook)
+    mime-view-mode-map))
+
+(defvar mime-view-mode-default-map (mime-view-define-keymap))
+
+
+(defsubst mime-maybe-hide-echo-buffer ()
+  "Clear mime-echo buffer and delete window for it."
+  (let ((buf (get-buffer mime-echo-buffer-name)))
+    (if buf
+       (save-excursion
+         (set-buffer buf)
+         (erase-buffer)
+         (let ((win (get-buffer-window buf)))
+           (if win
+               (delete-window win)
+             ))
+         (bury-buffer buf)
+         ))))
+
+(defvar mime-view-redisplay nil)
+
+;;;###autoload
+(defun mime-display-message (message &optional preview-buffer
+                                    mother default-keymap-or-function
+                                    original-major-mode keymap)
+  "View MESSAGE in MIME-View mode.
+
+Optional argument PREVIEW-BUFFER specifies the buffer of the
+presentation.  It must be either nil or a name of preview buffer.
+
+Optional argument MOTHER specifies mother-buffer of the preview-buffer.
+
+Optional argument DEFAULT-KEYMAP-OR-FUNCTION is nil, keymap or
+function.  If it is a keymap, keymap of MIME-View mode will be added
+to it.  If it is a function, it will be bound as default binding of
+keymap of MIME-View mode.
+
+Optional argument ORIGINAL-MAJOR-MODE is major-mode of representation
+buffer of MESSAGE.  If it is nil, current `major-mode' is used.
+
+Optional argument KEYMAP is keymap of MIME-View mode.  If it is
+non-nil, DEFAULT-KEYMAP-OR-FUNCTION is ignored.  If it is nil,
+`mime-view-mode-default-map' is used."
+  (mime-maybe-hide-echo-buffer)
+  (let ((win-conf (current-window-configuration)))
+    (or preview-buffer
+       (setq preview-buffer
+             (concat "*Preview-" (mime-entity-name message) "*")))
+    (or original-major-mode
+       (setq original-major-mode major-mode))
+    (let ((inhibit-read-only t))
+      (set-buffer (get-buffer-create preview-buffer))
+      (widen)
+      (erase-buffer)
+      (if mother
+         (setq mime-mother-buffer mother))
+      (setq mime-preview-original-window-configuration win-conf)
+      (setq major-mode 'mime-view-mode)
+      (setq mode-name "MIME-View")
+      (mime-display-entity message nil
+                          `((entity-button . invisible)
+                            (header . visible)
+                            (major-mode . ,original-major-mode))
+                          preview-buffer)
+      (use-local-map
+       (or keymap
+          (if default-keymap-or-function
+              (mime-view-define-keymap default-keymap-or-function)
+            mime-view-mode-default-map)))
+      (let ((point
+            (next-single-property-change (point-min) 'mime-view-entity)))
+       (if point
+           (goto-char point)
+         (goto-char (point-min))
+         (search-forward "\n\n" nil t)))
+      (run-hooks 'mime-view-mode-hook)
+      (set-buffer-modified-p nil)
+      (setq buffer-read-only t)
+      preview-buffer)))
+
+;;;###autoload
+(defun mime-view-buffer (&optional raw-buffer preview-buffer mother
+                                  default-keymap-or-function
+                                  representation-type)
+  "View RAW-BUFFER in MIME-View mode.
+Optional argument PREVIEW-BUFFER is either nil or a name of preview
+buffer.
+Optional argument DEFAULT-KEYMAP-OR-FUNCTION is nil, keymap or
+function.  If it is a keymap, keymap of MIME-View mode will be added
+to it.  If it is a function, it will be bound as default binding of
+keymap of MIME-View mode.
+Optional argument REPRESENTATION-TYPE is representation-type of
+message.  It must be nil, `binary' or `cooked'.  If it is nil,
+`cooked' is used as default."
+  (interactive)
+  (or raw-buffer
+      (setq raw-buffer (current-buffer)))
+  (or representation-type
+      (setq representation-type
+           (save-excursion
+             (set-buffer raw-buffer)
+             (cdr (or (assq major-mode mime-raw-representation-type-alist)
+                      (assq t mime-raw-representation-type-alist)))
+             )))
+  (if (eq representation-type 'binary)
+      (setq representation-type 'buffer)
+    )
+  (setq preview-buffer (mime-display-message
+                       (mime-open-entity representation-type raw-buffer)
+                       preview-buffer mother default-keymap-or-function))
+  (or (get-buffer-window preview-buffer)
+      (let ((r-win (get-buffer-window raw-buffer)))
+       (if r-win
+           (set-window-buffer r-win preview-buffer)
+         (let ((m-win (and mother (get-buffer-window mother))))
+           (if m-win
+               (set-window-buffer m-win preview-buffer)
+             (switch-to-buffer preview-buffer)
+             ))))))
+
+(defun mime-view-mode (&optional mother ctl encoding
+                                raw-buffer preview-buffer
+                                default-keymap-or-function)
+  "Major mode for viewing MIME message.
+
+Here is a list of the standard keys for mime-view-mode.
+
+key            feature
+---            -------
+
+u              Move to upper content
+p or M-TAB     Move to previous content
+n or TAB       Move to next content
+SPC            Scroll up or move to next content
+M-SPC or DEL   Scroll down or move to previous content
+RET            Move to next line
+M-RET          Move to previous line
+v              Decode current content as `play mode'
+e              Decode current content as `extract mode'
+C-c C-p                Decode current content as `print mode'
+a              Followup to current content.
+q              Quit
+button-2       Move to point under the mouse cursor
+               and decode current content as `play mode'
+"
+  (interactive)
+  (unless mime-view-redisplay
+    (save-excursion
+      (if raw-buffer (set-buffer raw-buffer))
+      (let ((type
+            (cdr
+             (or (assq major-mode mime-raw-representation-type-alist)
+                 (assq t mime-raw-representation-type-alist)))))
+       (if (eq type 'binary)
+           (setq type 'buffer)
+         )
+       (setq mime-message-structure (mime-open-entity type raw-buffer))
+       (or (mime-entity-content-type mime-message-structure)
+           (mime-entity-set-content-type mime-message-structure ctl))
+       )
+      (or (mime-entity-encoding mime-message-structure)
+         (mime-entity-set-encoding mime-message-structure encoding))
+      ))
+  (mime-display-message mime-message-structure preview-buffer
+                       mother default-keymap-or-function)
+  )
+
+
+;;; @@ utility
+;;;
+
+(defun mime-preview-find-boundary-info (&optional get-mother)
+  (let (entity
+       p-beg p-end
+       entity-node-id len)
+    (while (null (setq entity
+                      (get-text-property (point) 'mime-view-entity)))
+      (backward-char))
+    (setq p-beg (previous-single-property-change (point) 'mime-view-entity))
+    (setq entity-node-id (mime-entity-node-id entity))
+    (setq len (length entity-node-id))
+    (cond ((null p-beg)
+          (setq p-beg
+                (if (eq (next-single-property-change (point-min)
+                                                     'mime-view-entity)
+                        (point))
+                    (point)
+                  (point-min)))
+          )
+         ((eq (next-single-property-change p-beg 'mime-view-entity)
+              (point))
+          (setq p-beg (point))
+          ))
+    (setq p-end (next-single-property-change p-beg 'mime-view-entity))
+    (cond ((null p-end)
+          (setq p-end (point-max))
+          )
+         ((null entity-node-id)
+          (setq p-end (point-max))
+          )
+         (get-mother
+          (save-excursion
+            (goto-char p-end)
+            (catch 'tag
+              (let (e i)
+                (while (setq e
+                             (next-single-property-change
+                              (point) 'mime-view-entity))
+                  (goto-char e)
+                  (let ((rc (mime-entity-node-id
+                             (get-text-property (1- (point))
+                                                'mime-view-entity))))
+                    (or (and (>= (setq i (- (length rc) len)) 0)
+                             (equal entity-node-id (nthcdr i rc)))
+                        (throw 'tag nil)))
+                  (setq p-end e)))
+              (setq p-end (point-max))))
+          ))
+    (vector p-beg p-end entity)))
+
+
+;;; @@ playing
+;;;
+
+(autoload 'mime-preview-play-current-entity "mime-play"
+  "Play current entity." t)
+
+(defun mime-preview-extract-current-entity (&optional ignore-examples)
+  "Extract current entity into file (maybe).
+It decodes current entity to call internal or external method as
+\"extract\" mode.  The method is selected from variable
+`mime-acting-condition'."
+  (interactive "P")
+  (mime-preview-play-current-entity ignore-examples "extract")
+  )
+
+(defun mime-preview-print-current-entity (&optional ignore-examples)
+  "Print current entity (maybe).
+It decodes current entity to call internal or external method as
+\"print\" mode.  The method is selected from variable
+`mime-acting-condition'."
+  (interactive "P")
+  (mime-preview-play-current-entity ignore-examples "print")
+  )
+
+
+;;; @@ following
+;;;
+
+(defun mime-preview-follow-current-entity ()
+  "Write follow message to current entity.
+It calls following-method selected from variable
+`mime-preview-following-method-alist'."
+  (interactive)
+  (let ((entity (mime-preview-find-boundary-info t))
+       p-beg p-end
+       pb-beg)
+    (setq p-beg (aref entity 0)
+         p-end (aref entity 1)
+         entity (aref entity 2))
+    (if (get-text-property p-beg 'mime-view-entity-body)
+       (setq pb-beg p-beg)
+      (setq pb-beg
+           (next-single-property-change
+            p-beg 'mime-view-entity-body nil
+            (or (next-single-property-change p-beg 'mime-view-entity)
+                p-end))))
+    (let* ((mode (mime-preview-original-major-mode 'recursive))
+          (entity-node-id (mime-entity-node-id entity))
+          (new-name
+           (format "%s-%s" (buffer-name) (reverse entity-node-id)))
+          new-buf
+          (the-buf (current-buffer))
+          fields)
+      (save-excursion
+       (set-buffer (setq new-buf (get-buffer-create new-name)))
+       (erase-buffer)
+       (insert ?\n)
+       (insert-buffer-substring the-buf pb-beg p-end)
+       (goto-char (point-min))
+       (let ((current-entity
+              (if (and (eq (mime-entity-media-type entity) 'message)
+                       (eq (mime-entity-media-subtype entity) 'rfc822))
+                  (car (mime-entity-children entity))
+                entity)))
+         (while (and current-entity
+                     (if (and (eq (mime-entity-media-type
+                                   current-entity) 'message)
+                              (eq (mime-entity-media-subtype
+                                   current-entity) 'rfc822))
+                         nil
+                       (mime-insert-header current-entity fields)
+                       t))
+           (setq fields (std11-collect-field-names)
+                 current-entity (mime-entity-parent current-entity))
+           ))
+       (let ((rest mime-view-following-required-fields-list)
+             field-name ret)
+         (while rest
+           (setq field-name (car rest))
+           (or (std11-field-body field-name)
+               (progn
+                 (save-excursion
+                   (set-buffer the-buf)
+                   (let ((entity (when mime-mother-buffer
+                                   (set-buffer mime-mother-buffer)
+                                   (get-text-property (point)
+                                                      'mime-view-entity))))
+                     (while (and entity
+                                 (null (setq ret (mime-entity-fetch-field
+                                                  entity field-name))))
+                       (setq entity (mime-entity-parent entity)))))
+                 (if ret
+                     (insert (concat field-name ": " ret "\n"))
+                   )))
+           (setq rest (cdr rest))
+           ))
+       )
+      (let ((f (cdr (assq mode mime-preview-following-method-alist))))
+       (if (functionp f)
+           (funcall f new-buf)
+         (message
+          (format
+           "Sorry, following method for %s is not implemented yet."
+           mode))
+         ))
+      )))
+
+
+;;; @@ moving
+;;;
+
+(defun mime-preview-move-to-upper ()
+  "Move to upper entity.
+If there is no upper entity, call function `mime-preview-quit'."
+  (interactive)
+  (let (cinfo)
+    (while (null (setq cinfo
+                      (get-text-property (point) 'mime-view-entity)))
+      (backward-char)
+      )
+    (let ((r (mime-entity-parent cinfo))
+         point)
+      (catch 'tag
+       (while (setq point (previous-single-property-change
+                           (point) 'mime-view-entity))
+         (goto-char point)
+         (when (eq r (get-text-property (point) 'mime-view-entity))
+           (if (or (eq mime-preview-move-scroll t)
+                   (and mime-preview-move-scroll
+                        (>= point
+                            (save-excursion
+                              (move-to-window-line -1)
+                              (forward-line (* -1 next-screen-context-lines))
+                              (beginning-of-line)
+                              (point)))))
+               (recenter next-screen-context-lines))
+           (throw 'tag t)
+           )
+         )
+       (mime-preview-quit)
+       ))))
+
+(defun mime-preview-move-to-previous ()
+  "Move to previous entity.
+If there is no previous entity, it calls function registered in
+variable `mime-preview-over-to-previous-method-alist'."
+  (interactive)
+  (while (and (not (bobp))
+             (null (get-text-property (point) 'mime-view-entity)))
+    (backward-char)
+    )
+  (let ((point (previous-single-property-change (point) 'mime-view-entity)))
+    (if (and point
+            (>= point (point-min)))
+       (if (get-text-property (1- point) 'mime-view-entity)
+           (progn (goto-char point)
+                  (if
+                   (or (eq mime-preview-move-scroll t)
+                       (and mime-preview-move-scroll
+                            (<= point
+                               (save-excursion
+                                 (move-to-window-line 0)
+                                 (forward-line next-screen-context-lines)
+                                 (end-of-line)
+                                 (point)))))
+                       (recenter (* -1 next-screen-context-lines))))
+         (goto-char (1- point))
+         (mime-preview-move-to-previous)
+         )
+      (let ((f (assq (mime-preview-original-major-mode)
+                    mime-preview-over-to-previous-method-alist)))
+       (if f
+           (funcall (cdr f))
+         ))
+      )))
+
+(defun mime-preview-move-to-next ()
+  "Move to next entity.
+If there is no previous entity, it calls function registered in
+variable `mime-preview-over-to-next-method-alist'."
+  (interactive)
+  (while (and (not (eobp))
+             (null (get-text-property (point) 'mime-view-entity)))
+    (forward-char)
+    )
+  (let ((point (next-single-property-change (point) 'mime-view-entity)))
+    (if (and point
+            (<= point (point-max)))
+       (progn
+         (goto-char point)
+         (if (null (get-text-property point 'mime-view-entity))
+             (mime-preview-move-to-next)
+           (and
+            (or (eq mime-preview-move-scroll t)
+                (and mime-preview-move-scroll
+                     (>= point
+                        (save-excursion
+                          (move-to-window-line -1)
+                          (forward-line
+                           (* -1 next-screen-context-lines))
+                          (beginning-of-line)
+                          (point)))))
+                (recenter next-screen-context-lines))
+           ))
+      (let ((f (assq (mime-preview-original-major-mode)
+                    mime-preview-over-to-next-method-alist)))
+       (if f
+           (funcall (cdr f))
+         ))
+      )))
+
+(defun mime-preview-scroll-up-entity (&optional h)
+  "Scroll up current entity.
+If reached to (point-max), it calls function registered in variable
+`mime-preview-over-to-next-method-alist'."
+  (interactive)
+  (if (eobp)
+      (let ((f (assq (mime-preview-original-major-mode)
+                    mime-preview-over-to-next-method-alist)))
+       (if f
+           (funcall (cdr f))
+         ))
+    (let ((point
+          (or (next-single-property-change (point) 'mime-view-entity)
+              (point-max)))
+         (bottom (window-end (selected-window))))
+      (if (and (not h)
+              (> bottom point))
+         (progn (goto-char point)
+                (recenter next-screen-context-lines))
+       (condition-case nil
+           (scroll-up h)
+         (end-of-buffer
+          (goto-char (point-max)))))
+      )))
+
+(defun mime-preview-scroll-down-entity (&optional h)
+  "Scroll down current entity.
+If reached to (point-min), it calls function registered in variable
+`mime-preview-over-to-previous-method-alist'."
+  (interactive)
+  (if (bobp)
+      (let ((f (assq (mime-preview-original-major-mode)
+                    mime-preview-over-to-previous-method-alist)))
+       (if f
+           (funcall (cdr f))
+         ))
+    (let ((point
+          (or (previous-single-property-change (point) 'mime-view-entity)
+              (point-min)))
+         (top (window-start (selected-window))))
+      (if (and (not h)
+              (< top point))
+         (progn (goto-char point)
+                (recenter (* -1 next-screen-context-lines)))
+       (condition-case nil
+           (scroll-down h)
+         (beginning-of-buffer
+          (goto-char (point-min)))))
+      )))
+
+(defun mime-preview-next-line-entity (&optional lines)
+  "Scroll up one line (or prefix LINES lines).
+If LINES is negative, scroll down LINES lines."
+  (interactive "p")
+  (mime-preview-scroll-up-entity (or lines 1))
+  )
+
+(defun mime-preview-previous-line-entity (&optional lines)
+  "Scrroll down one line (or prefix LINES lines).
+If LINES is negative, scroll up LINES lines."
+  (interactive "p")
+  (mime-preview-scroll-down-entity (or lines 1))
+  )
+
+
+;;; @@ display
+;;;
+
+(defun mime-preview-toggle-display (type &optional display)
+  (let ((situation (mime-preview-find-boundary-info))
+       (sym (intern (concat "*" (symbol-name type))))
+       entity p-beg p-end)
+    (setq p-beg (aref situation 0)
+         p-end (aref situation 1)
+         entity (aref situation 2)
+         situation (get-text-property p-beg 'mime-view-situation))
+    (cond ((eq display 'invisible)
+          (setq display nil))
+         (display)
+         (t
+          (setq display
+                (eq (cdr (or (assq sym situation)
+                             (assq type situation)))
+                    'invisible))))
+    (setq situation (put-alist sym (if display
+                                      'visible
+                                    'invisible)
+                              situation))
+    (save-excursion
+      (let ((inhibit-read-only t))
+       (delete-region p-beg p-end)
+       (mime-display-entity entity situation)))
+    (let ((ret (assoc situation mime-preview-situation-example-list)))
+      (if ret
+         (setcdr ret (1+ (cdr ret)))
+       (add-to-list 'mime-preview-situation-example-list
+                    (cons situation 0))))))
+
+(defun mime-preview-toggle-header (&optional force-visible)
+  (interactive "P")
+  (mime-preview-toggle-display 'header force-visible))
+
+(defun mime-preview-toggle-content (&optional force-visible)
+  (interactive "P")
+  (mime-preview-toggle-display 'body force-visible))
+
+(defun mime-preview-show-header ()
+  (interactive)
+  (mime-preview-toggle-display 'header 'visible))
+
+(defun mime-preview-show-content ()
+  (interactive)
+  (mime-preview-toggle-display 'body 'visible))
+
+(defun mime-preview-hide-header ()
+  (interactive)
+  (mime-preview-toggle-display 'header 'invisible))
+
+(defun mime-preview-hide-content ()
+  (interactive)
+  (mime-preview-toggle-display 'body 'invisible))
+
+    
+;;; @@ quitting
+;;;
+
+(defun mime-preview-quit ()
+  "Quit from MIME-preview buffer.
+It calls function registered in variable
+`mime-preview-quitting-method-alist'."
+  (interactive)
+  (let ((r (assq (mime-preview-original-major-mode)
+                mime-preview-quitting-method-alist)))
+    (if r
+       (funcall (cdr r))
+      )))
+
+(defun mime-preview-kill-buffer ()
+  (interactive)
+  (kill-buffer (current-buffer))
+  )
+
+
+;;; @ end
+;;;
+
+(provide 'mime-view)
+
+(eval-when-compile
+  (setq mime-situation-examples-file nil)
+  ;; to avoid to read situation-examples-file at compile time.
+  )
+
+(mime-view-read-situation-examples-file)
+
+;;; mime-view.el ends here
diff --git a/mime/mime-w3.el b/mime/mime-w3.el
new file mode 100644 (file)
index 0000000..9ba2dcb
--- /dev/null
@@ -0,0 +1,86 @@
+;;; mime-w3.el --- mime-view content filter for text
+
+;; Copyright (C) 1994,95,96,97,98,99,2000 Free Software Foundation, Inc.
+
+;; Author: MORIOKA Tomohiko <tomo@m17n.org>
+;; Keywords: HTML, MIME, multimedia, mail, news
+
+;; This file is part of SEMI (Suite of Emacs MIME Interfaces).
+
+;; 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.
+
+;;; Code:
+
+(condition-case nil
+    (require 'w3)
+  (error nil))
+(require 'mime)
+
+(defmacro mime-put-keymap-region (start end keymap)
+  `(put-text-property ,start ,end
+                     ',(if (featurep 'xemacs)
+                           'keymap
+                         'local-map)
+                     ,keymap))
+
+(defmacro mime-save-background-color (&rest body)
+  (if (featurep 'xemacs)
+      `(let ((color (color-name (face-background 'default))))
+        (prog1
+            (progn ,@body)
+          (font-set-face-background 'default color (current-buffer))
+          ))
+    (cons 'progn body)))
+
+(defvar mime-w3-message-structure nil)
+
+(defun mime-preview-text/html (entity situation)
+  (setq mime-w3-message-structure (mime-find-root-entity entity))
+  (goto-char (point-max))
+  (let ((p (point)))
+    (insert "\n")
+    (goto-char p)
+    (mime-save-background-color
+     (save-restriction
+       (narrow-to-region p p)
+       (mime-insert-text-content entity)
+       (run-hooks 'mime-text-decode-hook)
+       (condition-case err
+          (w3-region p (point-max))
+        (error (message (format "%s" err))))
+       (mime-put-keymap-region p (point-max) w3-mode-map)
+       ))))
+
+(defun url-cid (url &optional proxy-info)
+  (let ((entity
+        (mime-find-entity-from-content-id (mime-uri-parse-cid url)
+                                          mime-w3-message-structure)))
+    (when entity
+      (mime-insert-entity-content entity)
+      (setq url-current-mime-type (mime-entity-type/subtype entity))
+      )))
+
+(url-register-protocol "cid"
+                      'url-cid
+                      'url-identity-expander)
+
+
+;;; @ end
+;;;
+
+(provide 'mime-w3)
+
+;;; mime-w3.el ends here
diff --git a/mime/mime.el b/mime/mime.el
new file mode 100644 (file)
index 0000000..2160569
--- /dev/null
@@ -0,0 +1,435 @@
+;;; mime.el --- MIME library module
+
+;; Copyright (C) 1998,1999,2000 Free Software Foundation, Inc.
+
+;; Author: MORIOKA Tomohiko <tomo@m17n.org>
+;; Keywords: MIME, multimedia, mail, news
+
+;; This file is part of FLIM (Faithful Library about Internet Message).
+
+;; 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.
+
+;;; Code:
+
+(require 'alist)
+(require 'std11)
+(require 'mime-def)
+(require 'eword-decode)
+
+(eval-when-compile (require 'mmgeneric))
+
+(eval-and-compile
+
+(autoload 'mime-encode-header-in-buffer "eword-encode"
+  "Encode header fields to network representation, such as MIME encoded-word.")
+
+(autoload 'mime-parse-Content-Type "mime-parse"
+  "Parse STRING as field-body of Content-Type field.")
+(autoload 'mime-read-Content-Type "mime-parse"
+  "Read field-body of Content-Type field from current-buffer,
+and return parsed it.")
+
+(autoload 'mime-parse-Content-Disposition "mime-parse"
+  "Parse STRING as field-body of Content-Disposition field.")
+(autoload 'mime-read-Content-Disposition "mime-parse"
+  "Read field-body of Content-Disposition field from current-buffer,
+and return parsed it.")
+
+(autoload 'mime-parse-Content-Transfer-Encoding "mime-parse"
+  "Parse STRING as field-body of Content-Transfer-Encoding field.")
+(autoload 'mime-read-Content-Transfer-Encoding "mime-parse"
+  "Read field-body of Content-Transfer-Encoding field from
+current-buffer, and return it.")
+
+(autoload 'mime-parse-msg-id "mime-parse"
+  "Parse TOKENS as msg-id of Content-Id or Message-Id field.")
+
+(autoload 'mime-uri-parse-cid "mime-parse"
+  "Parse STRING as cid URI.")
+
+(autoload 'mime-parse-buffer "mime-parse"
+  "Parse BUFFER as a MIME message.")
+
+)
+
+(autoload 'mime-encode-field-body "eword-encode"
+  "Encode FIELD-BODY as FIELD-NAME, and return the result.")
+
+
+;;; @ Entity Representation and Implementation
+;;;
+
+(defmacro mime-entity-send (entity message &rest args)
+  `(luna-send ,entity ',(intern (format "mime-%s" (eval message))) ,@args))
+
+(defun mime-open-entity (type location)
+  "Open an entity and return it.
+TYPE is representation-type.
+LOCATION is location of entity.  Specification of it is depended on
+representation-type."
+  (require (intern (format "mm%s" type)))
+  (luna-make-entity (mm-expand-class-name type) :location location))
+
+(luna-define-generic mime-entity-cooked-p (entity)
+  "Return non-nil if contents of ENTITY has been already code-converted.")
+
+
+;;; @ Entity as node of message
+;;;
+
+(defun mime-entity-children (entity)
+  "Return list of entities included in the ENTITY."
+  (or (mime-entity-children-internal entity)
+      (luna-send entity 'mime-entity-children entity)))
+
+(defun mime-entity-node-id (entity)
+  "Return node-id of ENTITY."
+  (mime-entity-node-id-internal entity))
+
+(defun mime-entity-number (entity)
+  "Return entity-number of ENTITY."
+  (reverse (mime-entity-node-id-internal entity)))
+
+(defun mime-find-entity-from-number (entity-number message)
+  "Return entity from ENTITY-NUMBER in MESSAGE."
+  (let ((sn (car entity-number)))
+    (if (null sn)
+       message
+      (let ((rc (nth sn (mime-entity-children message))))
+       (if rc
+           (mime-find-entity-from-number (cdr entity-number) rc)
+         ))
+      )))
+
+(defun mime-find-entity-from-node-id (entity-node-id message)
+  "Return entity from ENTITY-NODE-ID in MESSAGE."
+  (mime-find-entity-from-number (reverse entity-node-id) message))
+
+(defun mime-find-entity-from-content-id (cid message)
+  "Return entity from CID in MESSAGE."
+  (if (equal cid (mime-entity-read-field message "Content-Id"))
+      message
+    (let ((children (mime-entity-children message))
+         ret)
+      (while (and children
+                 (null (setq ret (mime-find-entity-from-content-id
+                                  cid (car children)))))
+       (setq children (cdr children)))
+      ret)))
+
+(defun mime-entity-parent (entity &optional message)
+  "Return mother entity of ENTITY.
+If MESSAGE is specified, it is regarded as root entity."
+  (if (equal entity message)
+      nil
+    (mime-entity-parent-internal entity)))
+
+(defun mime-root-entity-p (entity &optional message)
+  "Return t if ENTITY is root-entity (message).
+If MESSAGE is specified, it is regarded as root entity."
+  (null (mime-entity-parent entity message)))
+
+(defun mime-find-root-entity (entity)
+  "Return root entity of ENTITY."
+  (let ((p (mime-entity-parent entity)))
+    (if (null p)
+       entity
+      (mime-entity-parent p))))
+
+
+;;; @ Header buffer (obsolete)
+;;;
+
+;; (luna-define-generic mime-entity-header-buffer (entity))
+
+;; (luna-define-generic mime-goto-header-start-point (entity)
+;;   "Set buffer and point to header-start-position of ENTITY.")
+
+;; (luna-define-generic mime-entity-header-start-point (entity)
+;;   "Return header-start-position of ENTITY.")
+
+;; (luna-define-generic mime-entity-header-end-point (entity)
+;;   "Return header-end-position of ENTITY.")
+
+;; (make-obsolete 'mime-entity-header-buffer "don't use it.")
+;; (make-obsolete 'mime-goto-header-start-point "don't use it.")
+;; (make-obsolete 'mime-entity-header-start-point "don't use it.")
+;; (make-obsolete 'mime-entity-header-end-point "don't use it.")
+
+
+;;; @ Body buffer (obsolete)
+;;;
+
+;; (luna-define-generic mime-entity-body-buffer (entity))
+
+;; (luna-define-generic mime-goto-body-start-point (entity)
+;;   "Set buffer and point to body-start-position of ENTITY.")
+
+;; (luna-define-generic mime-goto-body-end-point (entity)
+;;   "Set buffer and point to body-end-position of ENTITY.")
+
+;; (luna-define-generic mime-entity-body-start-point (entity)
+;;   "Return body-start-position of ENTITY.")
+
+;; (luna-define-generic mime-entity-body-end-point (entity)
+;;   "Return body-end-position of ENTITY.")
+
+;; (defalias 'mime-entity-body-start 'mime-entity-body-start-point)
+;; (defalias 'mime-entity-body-end 'mime-entity-body-end-point)
+
+;; (make-obsolete 'mime-entity-body-buffer "don't use it.")
+;; (make-obsolete 'mime-goto-body-start-point "don't use it.")
+;; (make-obsolete 'mime-goto-body-end-point "don't use it.")
+;; (make-obsolete 'mime-entity-body-start-point "don't use it.")
+;; (make-obsolete 'mime-entity-body-end-point "don't use it.")
+;; (make-obsolete 'mime-entity-body-start "don't use it.")
+;; (make-obsolete 'mime-entity-body-end "don't use it.")
+
+
+;;; @ Entity buffer (obsolete)
+;;;
+
+;; (luna-define-generic mime-entity-buffer (entity))
+;; (make-obsolete 'mime-entity-buffer "don't use it.")
+
+;; (luna-define-generic mime-entity-point-min (entity))
+;; (make-obsolete 'mime-entity-point-min "don't use it.")
+
+;; (luna-define-generic mime-entity-point-max (entity))
+;; (make-obsolete 'mime-entity-point-max "don't use it.")
+
+
+;;; @ Entity
+;;;
+
+(luna-define-generic mime-insert-entity (entity)
+  "Insert header and body of ENTITY at point.")
+
+(luna-define-generic mime-write-entity (entity filename)
+  "Write header and body of ENTITY into FILENAME.")
+
+
+;;; @ Entity Body
+;;;
+
+(luna-define-generic mime-entity-body (entity)
+  "Return network representation of ENTITY body.")
+
+(luna-define-generic mime-insert-entity-body (entity)
+  "Insert network representation of ENTITY body at point.")
+
+(luna-define-generic mime-write-entity-body (entity filename)
+  "Write body of ENTITY into FILENAME.")
+
+
+;;; @ Entity Content
+;;;
+
+(luna-define-generic mime-entity-content (entity)
+  "Return content of ENTITY as byte sequence (string).")
+
+(luna-define-generic mime-insert-entity-content (entity)
+  "Insert content of ENTITY at point.")
+
+(luna-define-generic mime-write-entity-content (entity filename)
+  "Write content of ENTITY into FILENAME.")
+
+(luna-define-generic mime-insert-text-content (entity)
+  "Insert decoded text body of ENTITY.")
+
+
+;;; @ Header fields
+;;;
+
+(luna-define-generic mime-entity-fetch-field (entity field-name)
+  "Return the value of the ENTITY's header field whose type is FIELD-NAME.")
+
+;; (defun mime-fetch-field (field-name &optional entity)
+;;   "Return the value of the ENTITY's header field whose type is FIELD-NAME."
+;;   (if (symbolp field-name)
+;;       (setq field-name (symbol-name field-name))
+;;     )
+;;   (or entity
+;;       (setq entity mime-message-structure))
+;;   (mime-entity-fetch-field entity field-name)
+;;   )
+;; (make-obsolete 'mime-fetch-field 'mime-entity-fetch-field)
+
+(defun mime-entity-content-type (entity)
+  "Return content-type of ENTITY."
+  (or (mime-entity-content-type-internal entity)
+      (let ((ret (mime-entity-fetch-field entity "Content-Type")))
+       (if ret
+           (mime-entity-set-content-type-internal
+            entity (mime-parse-Content-Type ret))
+         ))))
+
+(defun mime-entity-content-disposition (entity)
+  "Return content-disposition of ENTITY."
+  (or (mime-entity-content-disposition-internal entity)
+      (let ((ret (mime-entity-fetch-field entity "Content-Disposition")))
+       (if ret
+           (mime-entity-set-content-disposition-internal
+            entity (mime-parse-Content-Disposition ret))
+         ))))
+
+(defun mime-entity-encoding (entity &optional default-encoding)
+  "Return content-transfer-encoding of ENTITY.
+If the ENTITY does not have Content-Transfer-Encoding field, this
+function returns DEFAULT-ENCODING.  If it is nil, \"7bit\" is used as
+default value."
+  (or (mime-entity-encoding-internal entity)
+      (let ((ret (mime-entity-fetch-field entity "Content-Transfer-Encoding")))
+       (mime-entity-set-encoding-internal
+        entity
+        (or (and ret (mime-parse-Content-Transfer-Encoding ret))
+            default-encoding "7bit"))
+       )))
+
+(defvar mime-field-parser-alist
+  '((Return-Path       . std11-parse-route-addr)
+    
+    (Reply-To          . std11-parse-addresses)
+    
+    (Sender            . std11-parse-mailbox)
+    (From              . std11-parse-addresses)
+
+    (Resent-Reply-To   . std11-parse-addresses)
+    
+    (Resent-Sender     . std11-parse-mailbox)
+    (Resent-From       . std11-parse-addresses)
+
+    (To                        . std11-parse-addresses)
+    (Resent-To         . std11-parse-addresses)
+    (Cc                        . std11-parse-addresses)
+    (Resent-Cc         . std11-parse-addresses)
+    (Bcc               . std11-parse-addresses)
+    (Resent-Bcc                . std11-parse-addresses)
+    
+    (Message-Id                . mime-parse-msg-id)
+    (Recent-Message-Id . mime-parse-msg-id)
+    
+    (In-Reply-To       . std11-parse-msg-ids)
+    (References                . std11-parse-msg-ids)
+    
+    (Content-Id                . mime-parse-msg-id)
+    ))
+
+(defun mime-entity-read-field (entity field-name)
+  (let ((sym (if (symbolp field-name)
+                (prog1
+                    field-name
+                  (setq field-name (symbol-name field-name)))
+              (intern (capitalize (capitalize field-name))))))
+    (cond ((eq sym 'Content-Type)
+          (mime-entity-content-type entity)
+          )
+         ((eq sym 'Content-Disposition)
+          (mime-entity-content-disposition entity)
+          )
+         ((eq sym 'Content-Transfer-Encoding)
+          (mime-entity-encoding entity)
+          )
+         (t
+          (let* ((header (mime-entity-parsed-header-internal entity))
+                 (field (cdr (assq sym header))))
+            (or field
+                (let ((field-body (mime-entity-fetch-field entity field-name))
+                      parser)
+                  (when field-body
+                    (setq parser
+                          (cdr (assq sym mime-field-parser-alist)))
+                    (setq field
+                          (if parser
+                              (funcall parser
+                                       (eword-lexical-analyze field-body))
+                            (mime-decode-field-body field-body sym 'plain)
+                            ))
+                    (mime-entity-set-parsed-header-internal
+                     entity (put-alist sym field header))
+                    field))))))))
+
+;; (defun mime-read-field (field-name &optional entity)
+;;   (or entity
+;;       (setq entity mime-message-structure))
+;;   (mime-entity-read-field entity field-name)
+;;   )
+;; (make-obsolete 'mime-read-field 'mime-entity-read-field)
+
+(luna-define-generic mime-insert-header (entity &optional invisible-fields
+                                               visible-fields)
+  "Insert before point a decoded header of ENTITY.")
+
+
+;;; @ Entity Attributes
+;;;
+
+(luna-define-generic mime-entity-name (entity)
+  "Return name of the ENTITY.")
+
+(defun mime-entity-uu-filename (entity)
+  (if (member (mime-entity-encoding entity) mime-uuencode-encoding-name-list)
+      (with-temp-buffer
+       (mime-insert-entity-body entity)
+       (if (re-search-forward "^begin [0-9]+ " nil t)
+           (if (looking-at ".+$")
+               (buffer-substring (match-beginning 0)(match-end 0))
+             )))))
+
+(defun mime-entity-filename (entity)
+  "Return filename of ENTITY."
+  (or (mime-entity-uu-filename entity)
+      (mime-content-disposition-filename
+       (mime-entity-content-disposition entity))
+      (cdr (let ((param (mime-content-type-parameters
+                        (mime-entity-content-type entity))))
+            (or (assoc "name" param)
+                (assoc "x-name" param))
+            ))))
+
+
+(defsubst mime-entity-media-type (entity)
+  "Return primary media-type of ENTITY."
+  (mime-content-type-primary-type (mime-entity-content-type entity)))
+
+(defsubst mime-entity-media-subtype (entity)
+  "Return media-subtype of ENTITY."
+  (mime-content-type-subtype (mime-entity-content-type entity)))
+
+(defsubst mime-entity-parameters (entity)
+  "Return parameters of Content-Type of ENTITY."
+  (mime-content-type-parameters (mime-entity-content-type entity)))
+
+(defsubst mime-entity-type/subtype (entity-info)
+  "Return type/subtype of Content-Type of ENTITY."
+  (mime-type/subtype-string (mime-entity-media-type entity-info)
+                           (mime-entity-media-subtype entity-info)))
+
+(defun mime-entity-set-content-type (entity content-type)
+  "Set ENTITY's content-type to CONTENT-TYPE."
+  (mime-entity-set-content-type-internal entity content-type))
+
+(defun mime-entity-set-encoding (entity encoding)
+  "Set ENTITY's content-transfer-encoding to ENCODING."
+  (mime-entity-set-encoding-internal entity encoding))
+
+
+;;; @ end
+;;;
+
+(provide 'mime)
+
+;;; mime.el ends here
diff --git a/mime/mmbabyl.el b/mime/mmbabyl.el
new file mode 100644 (file)
index 0000000..a38d0f5
--- /dev/null
@@ -0,0 +1,178 @@
+;;; mmbabyl.el --- MIME entity module for Babyl buffer
+
+;; Copyright (C) 2000 Free Software Foundation, Inc.
+
+;; Author: MORIOKA Tomohiko <tomo@m17n.org>
+;; Keywords: Babyl, RMAIL, MIME, multimedia, mail
+
+;; This file is part of GNU Emacs.
+
+;; 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.
+
+;;; Code:
+
+(require 'mmbuffer)
+
+(eval-and-compile
+  (luna-define-class mime-babyl-entity (mime-buffer-entity)
+                    (visible-header-start
+                     visible-header-end))
+
+  (luna-define-internal-accessors 'mime-babyl-entity))
+
+(luna-define-method initialize-instance
+  :after ((entity mime-babyl-entity) &rest init-args)
+  "Initialize slots of ENTITY.
+ENTITY is an instance of `mime-babyl-entity'."
+  (or (mime-buffer-entity-buffer-internal entity)
+      (mime-buffer-entity-set-buffer-internal
+       entity (get-buffer (mime-entity-location-internal entity))))
+  (save-excursion
+    (set-buffer (mime-buffer-entity-buffer-internal entity))
+    (goto-char (point-min))
+    (let (header-start
+         header-end
+         visible-header-start
+         visible-header-end
+         body-start)
+      (forward-line 1)
+      (if (= (following-char) ?0)
+         (progn
+           (forward-line 2)
+           ;; If there's a Summary-line in the (otherwise empty)
+           ;; header, we didn't yet get past the EOOH line.
+           (if (looking-at "^\\*\\*\\* EOOH \\*\\*\\*\n")
+               (forward-line 1))
+           (setq header-start (point))
+           (search-forward "\n\n" nil t)
+           (setq header-end (1+ (match-beginning 0)))
+           (setq body-start (match-end 0))
+           (setq visible-header-start header-start
+                 visible-header-end header-end))
+       (forward-line 1)
+       (setq header-start (point))
+       (search-forward "\n*** EOOH ***\n" nil t)
+       (setq header-end (match-beginning 0))
+       (setq visible-header-start (match-end 0))
+       (search-forward "\n\n" nil t)
+       (setq visible-header-end (1+ (match-beginning 0)))
+       (setq body-start (match-end 0)))
+      (mime-buffer-entity-set-header-start-internal entity header-start)
+      (mime-buffer-entity-set-header-end-internal entity header-end)
+      (mime-buffer-entity-set-body-start-internal entity body-start)
+      (mime-buffer-entity-set-body-end-internal entity (point-max))
+      (mime-babyl-entity-set-visible-header-start-internal
+       entity visible-header-start)
+      (mime-babyl-entity-set-visible-header-end-internal
+       entity visible-header-end)
+      (or (mime-entity-content-type-internal entity)
+         (save-restriction
+           (narrow-to-region header-start header-end)
+           (mime-entity-set-content-type-internal
+            entity
+            (let ((str (std11-fetch-field "Content-Type")))
+              (if str
+                  (mime-parse-Content-Type str)
+                )))
+           ))
+      ))
+  entity)
+
+
+;;; @ entity
+;;;
+
+(luna-define-method mime-insert-entity ((entity mime-babyl-entity))
+   "Insert ENTITY into the current buffer.
+ENTITY is an instance of `mime-babyl-entity'.
+The header part and the body part of ENTITY are separated by a blank
+line."
+  (insert-buffer-substring (mime-buffer-entity-buffer-internal entity)
+                          (mime-buffer-entity-header-start-internal entity)
+                          (mime-buffer-entity-header-end-internal entity))
+  (insert "\n")
+  (insert-buffer-substring (mime-buffer-entity-buffer-internal entity)
+                          (mime-buffer-entity-body-start-internal entity)
+                          (mime-buffer-entity-body-end-internal entity))
+  )
+
+(luna-define-method mime-write-entity ((entity mime-babyl-entity)
+                                      filename)
+  "Write ENTITY into FILENAME.
+ENTITY is an instance of `mime-babyl-entity'."
+  (with-temp-buffer
+    (mime-insert-entity entity)
+    (raw-message-write-region (point-min) (point-max) filename)))
+
+
+;;; @ entity header
+;;;
+
+
+;;; @ entity body
+;;;
+
+
+;;; @ entity content
+;;;
+
+
+;;; @ header field
+;;;
+
+(luna-define-method mime-insert-header ((entity mime-babyl-entity)
+                                       &optional invisible-fields
+                                       visible-fields)
+  "Insert the header of ENTITY in the current buffer.
+ENTITY is an instance of `mime-babyl-entity'.
+The optional arguemnts are currently ignored."
+  (mime-insert-header-from-buffer
+   (mime-buffer-entity-buffer-internal entity)
+   (mime-babyl-entity-visible-header-start-internal entity)
+   (mime-babyl-entity-visible-header-end-internal entity)
+   nil nil)
+  )
+
+
+;;; @ children
+;;;
+
+;;;%%% docstring \e$B9g$C$F$k!)\e(B
+
+(luna-define-method mime-entity-children ((entity mime-babyl-entity))
+  "Return a list of ENTITY's children.
+ENTITY is an instance of `mime-babyl-entity'."
+  (let* ((content-type (mime-entity-content-type entity))
+        (primary-type (mime-content-type-primary-type content-type))
+        sub-type)
+    (cond ((eq primary-type 'multipart)
+          (mmbuffer-parse-multipart entity 'mime-buffer-entity))
+         ((eq primary-type 'message)
+          (setq sub-type (mime-content-type-subtype content-type))
+          (cond ((eq sub-type 'external-body)
+                 (mmbuffer-parse-encapsulated entity 'external
+                                              'mime-buffer-entity))
+                ((memq sub-type '(rfc822 news))
+                 (mmbuffer-parse-encapsulated entity nil
+                                              'mime-buffer-entity)))))))
+
+
+;;; @ end
+;;;
+
+(provide 'mmbabyl)
+
+;;; mmbabyl.el ends here
diff --git a/mime/mmbuffer.el b/mime/mmbuffer.el
new file mode 100644 (file)
index 0000000..1447d17
--- /dev/null
@@ -0,0 +1,360 @@
+;;; mmbuffer.el --- MIME entity module for binary buffer
+
+;; Copyright (C) 1998,1999,2000 Free Software Foundation, Inc.
+
+;; Author: MORIOKA Tomohiko <tomo@m17n.org>
+;; Keywords: MIME, multimedia, mail, news
+
+;; This file is part of FLIM (Faithful Library about Internet Message).
+
+;; 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.
+
+;;; Code:
+
+(require 'mmgeneric)
+(require 'mime)
+
+(eval-and-compile
+  (luna-define-class mime-buffer-entity (mime-entity)
+                    (buffer
+                     header-start
+                     header-end
+                     body-start
+                     body-end))
+
+  (luna-define-internal-accessors 'mime-buffer-entity)
+  )
+
+(luna-define-method initialize-instance :after ((entity mime-buffer-entity)
+                                               &rest init-args)
+  (or (mime-buffer-entity-buffer-internal entity)
+      (mime-buffer-entity-set-buffer-internal
+       entity (get-buffer (mime-entity-location-internal entity))))
+  (save-excursion
+    (set-buffer (mime-buffer-entity-buffer-internal entity))
+    (let ((header-start
+          (or (mime-buffer-entity-header-start-internal entity)
+              (mime-buffer-entity-set-header-start-internal
+               entity (point-min))))
+         (header-end (mime-buffer-entity-header-end-internal entity))
+         (body-start (mime-buffer-entity-body-start-internal entity))
+         (body-end
+          (or (mime-buffer-entity-body-end-internal entity)
+              (mime-buffer-entity-set-body-end-internal entity (point-max)))))
+      (goto-char header-start)
+      (unless (and header-end body-start)
+       (if (re-search-forward "^$" body-end t)
+           (setq header-end (match-end 0)
+                 body-start (if (= header-end body-end)
+                                body-end
+                              (1+ header-end)))
+         (setq header-end (point-min)
+               body-start (point-min)))
+       (mime-buffer-entity-set-header-end-internal entity header-end)
+       (mime-buffer-entity-set-body-start-internal entity body-start)
+       )
+      (or (mime-entity-content-type-internal entity)
+         (save-restriction
+           (narrow-to-region header-start header-end)
+           (mime-entity-set-content-type-internal
+            entity
+            (let ((str (std11-fetch-field "Content-Type")))
+              (if str
+                  (mime-parse-Content-Type str)
+                )))
+           ))
+      ))
+  entity)
+
+(luna-define-method mime-entity-name ((entity mime-buffer-entity))
+  (buffer-name (mime-buffer-entity-buffer-internal entity))
+  )
+
+
+;;; @ entity
+;;;
+
+(luna-define-method mime-insert-entity ((entity mime-buffer-entity))
+  (insert-buffer-substring (mime-buffer-entity-buffer-internal entity)
+                          (mime-buffer-entity-header-start-internal entity)
+                          (mime-buffer-entity-body-end-internal entity))
+  )
+
+(luna-define-method mime-write-entity ((entity mime-buffer-entity) filename)
+  (save-excursion
+    (set-buffer (mime-buffer-entity-buffer-internal entity))
+    (let ((coding-system-for-write 'raw-text-dos))
+      (write-region (mime-buffer-entity-header-start-internal entity)
+                   (mime-buffer-entity-body-end-internal entity)
+                   filename))))
+
+
+;;; @ entity header
+;;;
+
+
+;;; @ entity body
+;;;
+
+(luna-define-method mime-entity-body ((entity mime-buffer-entity))
+  (save-excursion
+    (set-buffer (mime-buffer-entity-buffer-internal entity))
+    (buffer-substring (mime-buffer-entity-body-start-internal entity)
+                     (mime-buffer-entity-body-end-internal entity))))
+
+(luna-define-method mime-insert-entity-body ((entity mime-buffer-entity))
+  (insert-buffer-substring (mime-buffer-entity-buffer-internal entity)
+                          (mime-buffer-entity-body-start-internal entity)
+                          (mime-buffer-entity-body-end-internal entity))
+  )
+
+(luna-define-method mime-write-entity-body ((entity mime-buffer-entity)
+                                           filename)
+  (save-excursion
+    (set-buffer (mime-buffer-entity-buffer-internal entity))
+    (binary-write-decoded-region
+     (mime-buffer-entity-body-start-internal entity)
+     (mime-buffer-entity-body-end-internal entity)
+     filename)))
+
+
+;;; @ entity content
+;;;
+
+(luna-define-method mime-entity-content ((entity mime-buffer-entity))
+  (save-excursion
+    (set-buffer (mime-buffer-entity-buffer-internal entity))
+    (mime-decode-string
+     (buffer-substring (mime-buffer-entity-body-start-internal entity)
+                      (mime-buffer-entity-body-end-internal entity))
+     (mime-entity-encoding entity))))
+
+(luna-define-method mime-insert-entity-content ((entity mime-buffer-entity))
+  (insert (with-current-buffer (mime-buffer-entity-buffer-internal entity)
+           (mime-decode-string
+            (buffer-substring (mime-buffer-entity-body-start-internal entity)
+                              (mime-buffer-entity-body-end-internal entity))
+            (mime-entity-encoding entity)))))
+
+(luna-define-method mime-write-entity-content ((entity mime-buffer-entity)
+                                              filename)
+  (save-excursion
+    (set-buffer (mime-buffer-entity-buffer-internal entity))
+    (mime-write-decoded-region (mime-buffer-entity-body-start-internal entity)
+                              (mime-buffer-entity-body-end-internal entity)
+                              filename
+                              (or (mime-entity-encoding entity) "7bit"))
+    ))
+
+
+;;; @ header field
+;;;
+
+(luna-define-method mime-entity-fetch-field :around
+  ((entity mime-buffer-entity) field-name)
+  (or (luna-call-next-method)
+      (save-excursion
+       (set-buffer (mime-buffer-entity-buffer-internal entity))
+       (save-restriction
+         (narrow-to-region (mime-buffer-entity-header-start-internal entity)
+                           (mime-buffer-entity-header-end-internal entity))
+         (let ((ret (std11-fetch-field field-name)))
+           (when ret
+             (or (symbolp field-name)
+                 (setq field-name
+                       (intern (capitalize (capitalize field-name)))))
+             (mime-entity-set-original-header-internal
+              entity
+              (put-alist field-name ret
+                         (mime-entity-original-header-internal entity)))
+             ret))))))
+
+(luna-define-method mime-insert-header ((entity mime-buffer-entity)
+                                       &optional invisible-fields
+                                       visible-fields)
+  (mime-insert-header-from-buffer
+   (mime-buffer-entity-buffer-internal entity)
+   (mime-buffer-entity-header-start-internal entity)
+   (mime-buffer-entity-header-end-internal entity)
+   invisible-fields visible-fields)
+  )
+
+
+;;; @ header buffer
+;;;
+
+;; (luna-define-method mime-entity-header-buffer ((entity mime-buffer-entity))
+;;   (mime-buffer-entity-buffer-internal entity)
+;;   )
+
+;; (luna-define-method mime-goto-header-start-point ((entity mime-buffer-entity))
+;;   (set-buffer (mime-buffer-entity-buffer-internal entity))
+;;   (goto-char (mime-buffer-entity-header-start-internal entity))
+;;   )
+
+;; (luna-define-method mime-entity-header-start-point ((entity
+;;                                                      mime-buffer-entity))
+;;   (mime-buffer-entity-header-start-internal entity)
+;;   )
+
+;; (luna-define-method mime-entity-header-end-point ((entity
+;;                                                    mime-buffer-entity))
+;;   (mime-buffer-entity-header-end-internal entity)
+;;   )
+
+
+;;; @ body buffer
+;;;
+
+;; (luna-define-method mime-entity-body-buffer ((entity mime-buffer-entity))
+;;   (mime-buffer-entity-buffer-internal entity)
+;;   )
+
+;; (luna-define-method mime-goto-body-start-point ((entity mime-buffer-entity))
+;;   (set-buffer (mime-buffer-entity-buffer-internal entity))
+;;   (goto-char (mime-buffer-entity-body-start-internal entity))
+;;   )
+
+;; (luna-define-method mime-goto-body-end-point ((entity mime-buffer-entity))
+;;   (set-buffer (mime-buffer-entity-buffer-internal entity))
+;;   (goto-char (mime-buffer-entity-body-end-internal entity))
+;;   )
+
+;; (luna-define-method mime-entity-body-start-point ((entity mime-buffer-entity))
+;;   (mime-buffer-entity-body-start-internal entity)
+;;   )
+
+;; (luna-define-method mime-entity-body-end-point ((entity mime-buffer-entity))
+;;   (mime-buffer-entity-body-end-internal entity)
+;;   )
+
+
+;;; @ buffer (obsolete)
+;;;
+
+;; (luna-define-method mime-entity-buffer ((entity mime-buffer-entity))
+;;   (mime-buffer-entity-buffer-internal entity)
+;;   )
+
+;; (luna-define-method mime-entity-point-min ((entity mime-buffer-entity))
+;;   (mime-buffer-entity-header-start-internal entity)
+;;   )
+
+;; (luna-define-method mime-entity-point-max ((entity mime-buffer-entity))
+;;   (mime-buffer-entity-body-end-internal entity)
+;;   )
+
+
+;;; @ children
+;;;
+
+(defun mmbuffer-parse-multipart (entity &optional representation-type)
+  (with-current-buffer (mime-buffer-entity-buffer-internal entity)
+    (or representation-type
+       (setq representation-type
+             (mime-entity-representation-type-internal entity)))
+    (let* ((content-type (mime-entity-content-type-internal entity))
+          (dash-boundary
+           (concat "--"
+                   (mime-content-type-parameter content-type "boundary")))
+          (delimiter       (concat "\n" (regexp-quote dash-boundary)))
+          (close-delimiter (concat delimiter "--[ \t]*$"))
+          (rsep (concat delimiter "[ \t]*\n"))
+          (dc-ctl
+           (if (eq (mime-content-type-subtype content-type) 'digest)
+               (make-mime-content-type 'message 'rfc822)
+             (make-mime-content-type 'text 'plain)
+             ))
+          (body-start (mime-buffer-entity-body-start-internal entity))
+          (body-end (mime-buffer-entity-body-end-internal entity)))
+      (save-restriction
+       (goto-char body-end)
+       (narrow-to-region body-start
+                         (if (re-search-backward close-delimiter nil t)
+                             (match-beginning 0)
+                           body-end))
+       (goto-char body-start)
+       (if (re-search-forward
+            (concat "^" (regexp-quote dash-boundary) "[ \t]*\n")
+            nil t)
+           (let ((cb (match-end 0))
+                 ce ncb ret children
+                 (node-id (mime-entity-node-id-internal entity))
+                 (i 0))
+             (while (re-search-forward rsep nil t)
+               (setq ce (match-beginning 0))
+               (setq ncb (match-end 0))
+               (save-restriction
+                 (narrow-to-region cb ce)
+                 (setq ret (mime-parse-message representation-type dc-ctl
+                                               entity (cons i node-id)))
+                 )
+               (setq children (cons ret children))
+               (goto-char (setq cb ncb))
+               (setq i (1+ i))
+               )
+             (setq ce (point-max))
+             (save-restriction
+               (narrow-to-region cb ce)
+               (setq ret (mime-parse-message representation-type dc-ctl
+                                             entity (cons i node-id)))
+               )
+             (setq children (cons ret children))
+             (mime-entity-set-children-internal entity (nreverse children))
+             )
+         (mime-entity-set-content-type-internal
+          entity (make-mime-content-type 'message 'x-broken))
+         nil)
+       ))))
+
+(defun mmbuffer-parse-encapsulated (entity &optional external
+                                          representation-type)
+  (mime-entity-set-children-internal
+   entity
+   (with-current-buffer (mime-buffer-entity-buffer-internal entity)
+     (save-restriction
+       (narrow-to-region (mime-buffer-entity-body-start-internal entity)
+                        (mime-buffer-entity-body-end-internal entity))
+       (list (mime-parse-message
+             (if external
+                 (progn
+                   (require 'mmexternal)
+                   'mime-external-entity)
+               (or representation-type
+                   (mime-entity-representation-type-internal entity)))
+             nil
+             entity (cons 0 (mime-entity-node-id-internal entity))))))))
+
+(luna-define-method mime-entity-children ((entity mime-buffer-entity))
+  (let* ((content-type (mime-entity-content-type entity))
+        (primary-type (mime-content-type-primary-type content-type))
+        sub-type)
+    (cond ((eq primary-type 'multipart)
+          (mmbuffer-parse-multipart entity))
+         ((eq primary-type 'message)
+          (setq sub-type (mime-content-type-subtype content-type))
+          (cond ((eq sub-type 'external-body)
+                 (mmbuffer-parse-encapsulated entity 'external))
+                ((memq sub-type '(rfc822 news))
+                 (mmbuffer-parse-encapsulated entity)))))))
+
+
+;;; @ end
+;;;
+
+(provide 'mmbuffer)
+
+;;; mmbuffer.el ends here
diff --git a/mime/mmcooked.el b/mime/mmcooked.el
new file mode 100644 (file)
index 0000000..f55a34a
--- /dev/null
@@ -0,0 +1,92 @@
+;;; mmcooked.el --- MIME entity implementation for binary buffer
+
+;; Copyright (C) 1998,1999 Free Software Foundation, Inc.
+
+;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
+;; Keywords: MIME, multimedia, mail, news
+
+;; This file is part of FLIM (Faithful Library about Internet Message).
+
+;; 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.
+
+;;; Code:
+
+(require 'mmbuffer)
+
+(mm-define-backend cooked (buffer))
+
+(mm-define-method entity-cooked-p ((entity cooked)) t)
+
+(mm-define-method write-entity-content ((entity cooked) filename)
+  (save-excursion
+    (set-buffer (mime-buffer-entity-buffer-internal entity))
+    (let ((encoding (or (mime-entity-encoding entity) "7bit")))
+      (if (member encoding '("7bit" "8bit" "binary"))
+         (write-region (mime-buffer-entity-body-start-internal entity)
+                       (mime-buffer-entity-body-end-internal entity) filename)
+       (mime-write-decoded-region
+        (mime-buffer-entity-body-start-internal entity)
+        (mime-buffer-entity-body-end-internal entity)
+        filename encoding)
+       ))))
+
+(mm-define-method write-entity ((entity cooked) filename)
+  (save-excursion
+    (set-buffer (mime-buffer-entity-buffer-internal entity))
+    (write-region (mime-buffer-entity-header-start-internal entity)
+                 (mime-buffer-entity-body-end-internal entity)
+                 filename)
+    ))
+
+(mm-define-method write-entity-body ((entity cooked) filename)
+  (save-excursion
+    (set-buffer (mime-buffer-entity-buffer-internal entity))
+    (write-region (mime-buffer-entity-body-start-internal entity)
+                 (mime-buffer-entity-body-end-internal entity)
+                 filename)
+    ))
+
+(luna-define-method mime-insert-header ((entity mime-cooked-entity)
+                                       &optional invisible-fields
+                                       visible-fields)
+  (let (default-mime-charset)
+    (funcall (car (luna-class-find-functions
+                  (luna-find-class 'mime-buffer-entity)
+                  'mime-insert-header))
+            entity invisible-fields visible-fields)
+    ))
+
+(mm-define-method insert-text-content ((entity cooked))
+  (let ((str (mime-entity-content entity)))
+    (insert
+     (if (member (mime-entity-encoding entity)
+                '(nil "7bit" "8bit" "binary"))
+        str
+       (decode-mime-charset-string str
+                                  (or (mime-content-type-parameter
+                                       (mime-entity-content-type entity)
+                                       "charset")
+                                      default-mime-charset)
+                                  'CRLF)
+       ))))
+
+
+;;; @ end
+;;;
+
+(provide 'mmcooked)
+
+;;; mmcooked.el ends here
diff --git a/mime/mmexternal.el b/mime/mmexternal.el
new file mode 100644 (file)
index 0000000..aafddcc
--- /dev/null
@@ -0,0 +1,187 @@
+;;; mmexternal.el --- MIME entity module for external buffer
+
+;; Copyright (C) 1998,1999,2000 Free Software Foundation, Inc.
+
+;; Author: MORIOKA Tomohiko <tomo@m17n.org>
+;; Keywords: MIME, multimedia, mail, news
+
+;; This file is part of FLIM (Faithful Library about Internet Message).
+
+;; 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.
+
+;;; Code:
+
+(require 'mmgeneric)
+(require 'mime)
+
+(eval-and-compile
+  (luna-define-class mime-external-entity (mime-entity)
+                    (body-buffer
+                     body-file))
+  (luna-define-internal-accessors 'mime-external-entity)
+
+  ;; In an external entity, information of media-type or other
+  ;; information which are represented in a header in a non-external
+  ;; entity are in the body of the parent entity.
+  )
+
+(luna-define-method mime-entity-name ((entity mime-external-entity))
+  (concat "child of "
+         (mime-entity-name
+          (mime-entity-parent-internal entity))))
+
+
+(defun mmexternal-require-file-name (entity)
+  (condition-case nil
+      (or (mime-external-entity-body-file-internal entity)
+         (let* ((ct (mime-entity-content-type
+                     (mime-entity-parent-internal entity)))
+                (access-type
+                 (mime-content-type-parameter ct "access-type")))
+           (if (and access-type
+                    (string= access-type "anon-ftp"))
+               (let ((site (mime-content-type-parameter ct "site"))
+                     (directory
+                      (mime-content-type-parameter ct "directory"))
+                     (name (mime-content-type-parameter ct "name")))
+                 (mime-external-entity-set-body-file-internal
+                  entity
+                  (expand-file-name
+                   name
+                   (concat "/anonymous@" site ":"
+                           (file-name-as-directory directory))))))))
+    (error (message "Can't make file-name of external-body."))))
+
+(defun mmexternal-require-buffer (entity)
+  (unless (and (mime-external-entity-body-buffer-internal entity)
+              (buffer-live-p
+               (mime-external-entity-body-buffer-internal entity)))
+    (condition-case nil
+       (progn
+         (mmexternal-require-file-name entity)
+         (mime-external-entity-set-body-buffer-internal
+          entity
+          (with-current-buffer (get-buffer-create
+                                (concat " *Body of "
+                                        (mime-entity-name entity)
+                                        "*"))
+            (binary-insert-encoded-file
+             (mime-external-entity-body-file-internal entity))
+            (current-buffer))))
+      (error (message "Can't get external-body.")))))
+
+
+;;; @ entity
+;;;
+
+(luna-define-method mime-insert-entity ((entity mime-external-entity))
+  (mime-insert-entity-body (mime-entity-parent-internal entity))
+  (insert "\n")
+  (mime-insert-entity-body entity))
+
+(luna-define-method mime-write-entity ((entity mime-external-entity) filename)
+  (with-temp-buffer
+    (mime-insert-entity entity)
+    (let ((coding-system-for-write 'raw-text-dos))
+      (write-region (point-min) (point-max) filename))))
+
+
+;;; @ entity header
+;;;
+
+
+;;; @ entity body
+;;;
+
+(luna-define-method mime-entity-body ((entity mime-external-entity))
+  (mmexternal-require-buffer entity)
+  (with-current-buffer (mime-external-entity-body-buffer-internal entity)
+    (buffer-string)))
+
+(luna-define-method mime-insert-entity-body ((entity mime-external-entity))
+  (mmexternal-require-buffer entity)
+  (insert-buffer-substring
+   (mime-external-entity-body-buffer-internal entity)))
+
+(luna-define-method mime-write-entity-body ((entity mime-external-entity)
+                                           filename)
+  (mmexternal-require-buffer entity)
+  (with-current-buffer (mime-external-entity-body-buffer-internal entity)
+    (binary-write-decoded-region (point-min) (point-max) filename)))
+
+
+;;; @ entity content
+;;;
+
+(luna-define-method mime-entity-content ((entity mime-external-entity))
+  (let ((ret (mime-entity-body entity)))
+    (if ret
+       (mime-decode-string ret (mime-entity-encoding entity))
+      (message "Cannot get content")
+      nil)))
+
+(luna-define-method mime-insert-entity-content ((entity mime-external-entity))
+  (insert (mime-entity-content entity)))
+
+(luna-define-method mime-write-entity-content ((entity mime-external-entity)
+                                              filename)
+  (mmexternal-require-buffer entity)
+  (with-current-buffer (mime-external-entity-body-buffer-internal entity)
+    (mime-write-decoded-region (point-min) (point-max)
+                              filename
+                              (or (mime-entity-encoding entity) "7bit"))))
+
+
+;;; @ header field
+;;;
+
+(luna-define-method mime-entity-fetch-field :around
+  ((entity mime-external-entity) field-name)
+  (or (luna-call-next-method)
+      (with-temp-buffer
+       (mime-insert-entity-body (mime-entity-parent-internal entity))
+       (let ((ret (std11-fetch-field field-name)))
+         (when ret
+           (or (symbolp field-name)
+               (setq field-name
+                     (intern (capitalize (capitalize field-name)))))
+           (mime-entity-set-original-header-internal
+            entity
+            (put-alist field-name ret
+                       (mime-entity-original-header-internal entity)))
+           ret)))))
+
+(luna-define-method mime-insert-header ((entity mime-external-entity)
+                                       &optional invisible-fields
+                                       visible-fields)
+  (let ((the-buf (current-buffer))
+       buf p-min p-max)
+    (with-temp-buffer
+      (mime-insert-entity-body (mime-entity-parent-internal entity))
+      (setq buf (current-buffer)
+           p-min (point-min)
+           p-max (point-max))
+      (set-buffer the-buf)
+      (mime-insert-header-from-buffer buf p-min p-max
+                                     invisible-fields visible-fields))))
+
+
+;;; @ end
+;;;
+
+(provide 'mmexternal)
+
+;;; mmexternal.el ends here
diff --git a/mime/mmgeneric.el b/mime/mmgeneric.el
new file mode 100644 (file)
index 0000000..532dfd9
--- /dev/null
@@ -0,0 +1,178 @@
+;;; mmgeneric.el --- MIME generic entity module
+
+;; Copyright (C) 1995,96,97,98,99,2000 Free Software Foundation, Inc.
+
+;; Author: MORIOKA Tomohiko <tomo@m17n.org>
+;; Keywords: definition, MIME, multimedia, mail, news
+
+;; This file is part of FLIM (Faithful Library about Internet Message).
+
+;; 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.
+
+;;; Code:
+
+(require 'luna)
+
+(eval-when-compile
+  (require 'eword-decode) ; mime-find-field-presentation-method
+  )
+
+
+;;; @ MIME entity
+;;;
+
+(autoload 'mime-entity-content-type "mime")
+(autoload 'mime-parse-multipart "mime-parse")
+(autoload 'mime-parse-message "mime-parse")
+;; (autoload 'mime-parse-encapsulated "mime-parse")
+;; (autoload 'mime-parse-external "mime-parse")
+(autoload 'mime-entity-content "mime")
+
+(eval-and-compile
+  (luna-define-class mime-entity ()
+                    (location
+                     content-type children parent
+                     node-id
+                     content-disposition encoding
+                     ;; for other fields
+                     original-header parsed-header))
+
+  (luna-define-internal-accessors 'mime-entity)
+  )
+
+(defalias 'mime-entity-representation-type-internal 'luna-class-name)
+(defalias 'mime-entity-set-representation-type-internal 'luna-set-class-name)
+
+(luna-define-method mime-entity-fetch-field ((entity mime-entity)
+                                            field-name)
+  (or (symbolp field-name)
+      (setq field-name (intern (capitalize (capitalize field-name)))))
+  (cdr (assq field-name
+            (mime-entity-original-header-internal entity))))
+
+(luna-define-method mime-insert-text-content ((entity mime-entity))
+  (insert
+   (decode-mime-charset-string (mime-entity-content entity)
+                              (or (mime-content-type-parameter
+                                   (mime-entity-content-type entity)
+                                   "charset")
+                                  default-mime-charset)
+                              'CRLF)
+   ))
+
+
+;;; @ for mm-backend
+;;;
+
+(defmacro mm-expand-class-name (type)
+  `(intern (format "mime-%s-entity" ,type)))
+
+(defmacro mm-define-backend (type &optional parents)
+  `(luna-define-class ,(mm-expand-class-name type)
+                     ,(nconc (mapcar (lambda (parent)
+                                       (mm-expand-class-name parent)
+                                       )
+                                     parents)
+                             '(mime-entity))))
+
+(defmacro mm-define-method (name args &rest body)
+  (or (eq name 'initialize-instance)
+      (setq name (intern (format "mime-%s" name))))
+  (let ((spec (car args)))
+    (setq args
+         (cons (list (car spec)
+                     (mm-expand-class-name (nth 1 spec)))
+               (cdr args)))
+    `(luna-define-method ,name ,args ,@body)
+    ))
+
+(put 'mm-define-method 'lisp-indent-function 'defun)
+
+(def-edebug-spec mm-define-method
+  (&define name ((arg symbolp)
+                [&rest arg]
+                [&optional ["&optional" arg &rest arg]]
+                &optional ["&rest" arg]
+                )
+          def-body))
+
+
+;;; @ header filter
+;;;
+
+;; [tomo] We should think about specification of better filtering
+;; mechanism.  Please discuss in the emacs-mime mailing lists.
+
+(defun mime-visible-field-p (field-name visible-fields invisible-fields)
+  (or (catch 'found
+       (while visible-fields
+         (let ((regexp (car visible-fields)))
+           (if (string-match regexp field-name)
+               (throw 'found t)
+             ))
+         (setq visible-fields (cdr visible-fields))
+         ))
+      (catch 'found
+       (while invisible-fields
+         (let ((regexp (car invisible-fields)))
+           (if (string-match regexp field-name)
+               (throw 'found nil)
+             ))
+         (setq invisible-fields (cdr invisible-fields))
+         )
+       t)))
+
+(defun mime-insert-header-from-buffer (buffer start end
+                                             &optional invisible-fields
+                                             visible-fields)
+  (let ((the-buf (current-buffer))
+       (mode-obj (mime-find-field-presentation-method 'wide))
+       field-decoder
+       f-b p f-e field-name len field field-body)
+    (save-excursion
+      (set-buffer buffer)
+      (save-restriction
+       (narrow-to-region start end)
+       (goto-char start)
+       (while (re-search-forward std11-field-head-regexp nil t)
+         (setq f-b (match-beginning 0)
+               p (match-end 0)
+               field-name (buffer-substring f-b p)
+               len (string-width field-name)
+               f-e (std11-field-end))
+         (when (mime-visible-field-p field-name
+                                     visible-fields invisible-fields)
+           (setq field (intern
+                        (capitalize (buffer-substring f-b (1- p))))
+                 field-body (buffer-substring p f-e)
+                 field-decoder (inline (mime-find-field-decoder-internal
+                                        field mode-obj)))
+           (with-current-buffer the-buf
+             (insert field-name)
+             (insert (if field-decoder
+                         (funcall field-decoder field-body len)
+                       ;; Don't decode
+                       field-body))
+             (insert "\n")
+             )))))))
+
+
+;;; @ end
+;;;
+
+(provide 'mmgeneric)
+
+;;; mmgeneric.el ends here
diff --git a/mime/pgg-def.el b/mime/pgg-def.el
new file mode 100644 (file)
index 0000000..7630f95
--- /dev/null
@@ -0,0 +1,78 @@
+;;; pgg-def.el --- functions/macros for defining PGG functions
+
+;; Copyright (C) 1999 Free Software Foundation, Inc.
+
+;; Author: Daiki Ueno <ueno@unixuser.org>
+;; Created: 1999/11/02
+;; Keywords: PGP, OpenPGP, GnuPG
+
+;; This file is part of SEMI (Secure Emacs MIME Interface).
+
+;; 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.
+
+;;; Code:
+
+(require 'custom)
+
+(defgroup pgg ()
+  "Glue for the various PGP implementations."
+  :group 'mime)
+
+(defcustom pgg-default-scheme 'gpg
+  "Default PGP scheme."
+  :group 'pgg
+  :type '(choice (const :tag "GnuPG" gpg)
+                (const :tag "PGP 5" pgp5)
+                (const :tag "PGP" pgp)))
+
+(defcustom pgg-default-user-id (user-login-name)
+  "User ID of your default identity."
+  :group 'pgg
+  :type 'string)
+
+(defcustom pgg-default-keyserver-address "wwwkeys.pgp.net"
+  "Host name of keyserver."
+  :group 'pgg
+  :type 'string)
+
+(defcustom pgg-encrypt-for-me nil
+  "If t, encrypt all outgoing messages with user's public key."
+  :group 'pgg
+  :type 'boolean)
+
+(defcustom pgg-cache-passphrase t
+  "If t, cache passphrase."
+  :group 'pgg
+  :type 'boolean)
+
+(defvar pgg-messages-coding-system nil
+  "Coding system used when reading from a PGP external process.")
+
+(defvar pgg-status-buffer " *PGG status*")
+(defvar pgg-errors-buffer " *PGG errors*")
+(defvar pgg-output-buffer " *PGG output*")
+
+(defvar pgg-echo-buffer "*PGG-echo*")
+
+(defvar pgg-scheme nil
+  "Current scheme of PGP implementation.")
+
+(defmacro pgg-truncate-key-identifier (key)
+  `(if (> (length ,key) 8) (substring ,key 8) ,key))
+
+(provide 'pgg-def)
+
+;;; pgg-def.el ends here
diff --git a/mime/pgg-gpg.el b/mime/pgg-gpg.el
new file mode 100644 (file)
index 0000000..dc6c5ae
--- /dev/null
@@ -0,0 +1,242 @@
+;;; pgg-gpg.el --- GnuPG support for PGG.
+
+;; Copyright (C) 1999,2000 Free Software Foundation, Inc.
+
+;; Author: Daiki Ueno <ueno@unixuser.org>
+;; Created: 1999/10/28
+;; Keywords: PGP, OpenPGP, GnuPG
+
+;; This file is part of SEMI (Secure Emacs MIME Interface).
+
+;; 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.
+
+;;; Code:
+
+(require 'mel) ; binary-to-text-funcall
+(eval-when-compile (require 'pgg))
+
+(defgroup pgg-gpg ()
+  "GnuPG interface"
+  :group 'pgg)
+
+(defcustom pgg-gpg-program "gpg" 
+  "The GnuPG executable."
+  :group 'pgg-gpg
+  :type 'string)
+
+(defcustom pgg-gpg-extra-args nil
+  "Extra arguments for every GnuPG invocation."
+  :group 'pgg-gpg
+  :type 'string)
+
+(eval-and-compile
+  (luna-define-class pgg-scheme-gpg (pgg-scheme)))
+
+(defvar pgg-gpg-user-id nil
+  "GnuPG ID of your default identity.")
+
+(defvar pgg-gpg-messages-coding-system pgg-messages-coding-system
+  "Coding system used when reading from a GnuPG external process.")
+
+(defvar pgg-scheme-gpg-instance nil)
+
+;;;###autoload
+(defun pgg-make-scheme-gpg ()
+  (or pgg-scheme-gpg-instance
+      (setq pgg-scheme-gpg-instance
+           (luna-make-entity 'pgg-scheme-gpg))))
+
+(defun pgg-gpg-process-region (start end passphrase program args)
+  (let* ((output-file-name
+         (concat temporary-file-directory (make-temp-name "pgg-output")))
+        (args
+         `("--status-fd" "2"
+           ,@(if passphrase '("--passphrase-fd" "0"))
+           "--output" ,output-file-name
+           ,@pgg-gpg-extra-args ,@args))
+        (output-buffer pgg-output-buffer)
+        (errors-buffer pgg-errors-buffer)
+        (orig-mode (default-file-modes))
+        (process-connection-type nil)
+        process status exit-status)
+    (with-current-buffer (get-buffer-create errors-buffer)
+      (buffer-disable-undo)
+      (erase-buffer))
+    (unwind-protect
+       (progn
+         (set-default-file-modes 448)
+         (setq process
+               (apply #'binary-to-text-funcall
+                      pgg-gpg-messages-coding-system
+                      #'start-process "*GnuPG*" errors-buffer
+                      program args))
+         (set-process-sentinel process #'ignore)
+         (when passphrase
+           (process-send-string process (concat passphrase "\n")))
+         (process-send-region process start end)
+         (process-send-eof process)
+         (while (eq 'run (process-status process))
+           (accept-process-output process 5))
+         (setq status (process-status process)
+               exit-status (process-exit-status process))
+         (delete-process process)
+         (with-current-buffer (get-buffer-create output-buffer)
+           (buffer-disable-undo)
+           (erase-buffer)
+           (if (file-exists-p output-file-name)
+               (let ((coding-system-for-read 'raw-text-dos))
+                 (insert-file-contents output-file-name)))
+           (set-buffer errors-buffer)
+           (if (memq status '(stop signal))
+               (error "%s exited abnormally: '%s'" program exit-status))
+           (if (= 127 exit-status)
+               (error "%s could not be found" program))))
+      (if (and process (eq 'run (process-status process)))
+         (interrupt-process process))
+      (if (file-exists-p output-file-name)
+         (delete-file output-file-name))
+      (set-default-file-modes orig-mode))))
+
+(defun pgg-gpg-possibly-cache-passphrase (passphrase)
+  (if (and pgg-cache-passphrase
+          (progn
+            (goto-char (point-min))
+            (re-search-forward "^\\[GNUPG:] GOOD_PASSPHRASE\\>" nil t)))
+      (pgg-add-passphrase-cache
+       (progn
+        (goto-char (point-min))
+        (if (re-search-forward
+             "^\\[GNUPG:] NEED_PASSPHRASE \\w+ ?\\w*" nil t)
+            (substring (match-string 0) -8)))
+       passphrase)))
+
+(luna-define-method pgg-scheme-lookup-key ((scheme pgg-scheme-gpg)
+                                          string &optional type)
+  (let ((args (list "--with-colons" "--no-greeting" "--batch"
+                   (if type "--list-secret-keys" "--list-keys")
+                   string)))
+    (with-temp-buffer
+      (apply #'call-process pgg-gpg-program nil t nil args)
+      (goto-char (point-min))
+      (if (re-search-forward "^\\(sec\\|pub\\):"  nil t)
+         (substring
+          (nth 3 (split-string
+                  (buffer-substring (match-end 0)
+                                    (progn (end-of-line)(point)))
+                  ":")) 8)))))
+
+(luna-define-method pgg-scheme-encrypt-region ((scheme pgg-scheme-gpg)
+                                              start end recipients)
+  (let* ((pgg-gpg-user-id (or pgg-gpg-user-id pgg-default-user-id))
+        (args
+         `("--batch" "--armor" "--always-trust" "--encrypt"
+           ,@(if recipients
+                 (apply #'nconc
+                        (mapcar (lambda (rcpt)
+                                  (list "--remote-user" rcpt))
+                                (append recipients
+                                        (if pgg-encrypt-for-me
+                                            (list pgg-gpg-user-id)))))))))
+    (pgg-as-lbt start end 'CRLF
+      (pgg-gpg-process-region start end nil pgg-gpg-program args))
+    (pgg-process-when-success)))
+
+(luna-define-method pgg-scheme-decrypt-region ((scheme pgg-scheme-gpg)
+                                              start end)
+  (let* ((pgg-gpg-user-id (or pgg-gpg-user-id pgg-default-user-id))
+        (passphrase
+         (pgg-read-passphrase
+          (format "GnuPG passphrase for %s: " pgg-gpg-user-id)
+          (pgg-scheme-lookup-key scheme pgg-gpg-user-id 'encrypt)))
+        (args '("--batch" "--decrypt")))
+    (pgg-gpg-process-region start end passphrase pgg-gpg-program args)
+    (with-current-buffer pgg-errors-buffer
+      (pgg-gpg-possibly-cache-passphrase passphrase)
+      (goto-char (point-min))
+      (re-search-forward "^\\[GNUPG:] DECRYPTION_OKAY\\>" nil t))))
+
+(luna-define-method pgg-scheme-sign-region ((scheme pgg-scheme-gpg)
+                                           start end &optional cleartext)
+  (let* ((pgg-gpg-user-id (or pgg-gpg-user-id pgg-default-user-id))
+        (passphrase
+         (pgg-read-passphrase
+          (format "GnuPG passphrase for %s: " pgg-gpg-user-id)
+          (pgg-scheme-lookup-key scheme pgg-gpg-user-id 'sign)))
+        (args
+         (list (if cleartext "--clearsign" "--detach-sign")
+               "--armor" "--batch" "--verbose"
+               "--local-user" pgg-gpg-user-id))
+        (inhibit-read-only t)
+        buffer-read-only)
+    (pgg-as-lbt start end 'CRLF
+      (pgg-gpg-process-region start end passphrase pgg-gpg-program args))
+    (with-current-buffer pgg-errors-buffer
+      (pgg-gpg-possibly-cache-passphrase passphrase))
+    (pgg-process-when-success)))
+
+(luna-define-method pgg-scheme-verify-region ((scheme pgg-scheme-gpg)
+                                             start end &optional signature)
+  (let ((args '("--batch" "--verify")))
+    (when (stringp signature)
+      (setq args (append args (list signature))))
+    (setq args (append args '("-")))
+    (pgg-gpg-process-region start end nil pgg-gpg-program args)
+    (with-current-buffer pgg-errors-buffer
+      (goto-char (point-min))
+      (while (re-search-forward "^gpg: " nil t)
+       (replace-match ""))
+      (goto-char (point-min))
+      (prog1 (re-search-forward "^\\[GNUPG:] GOODSIG\\>" nil t)
+       (goto-char (point-min))
+       (delete-matching-lines "^warning\\|\\[GNUPG:]")
+       (set-buffer pgg-output-buffer)
+       (insert-buffer-substring pgg-errors-buffer)))))
+
+(luna-define-method pgg-scheme-insert-key ((scheme pgg-scheme-gpg))
+  (let* ((pgg-gpg-user-id (or pgg-gpg-user-id pgg-default-user-id))
+        (args (list "--batch" "--export" "--armor"
+                    pgg-gpg-user-id)))
+    (pgg-gpg-process-region (point)(point) nil pgg-gpg-program args)
+    (insert-buffer-substring pgg-output-buffer)))
+
+(luna-define-method pgg-scheme-snarf-keys-region ((scheme pgg-scheme-gpg)
+                                                 start end)
+  (let ((args '("--import" "--batch" "-")) status)
+    (pgg-gpg-process-region start end nil pgg-gpg-program args)
+    (set-buffer pgg-errors-buffer)
+    (goto-char (point-min))
+    (when (re-search-forward "^\\[GNUPG:] IMPORT_RES\\>" nil t)
+      (setq status (buffer-substring (match-end 0)
+                                    (progn (end-of-line)(point)))
+           status (vconcat (mapcar #'string-to-int (split-string status))))
+      (erase-buffer)
+      (insert (format "Imported %d key(s).
+\tArmor contains %d key(s) [%d bad, %d old].\n"
+                     (+ (aref status 2)
+                        (aref status 10))
+                     (aref status 0)
+                     (aref status 1)
+                     (+ (aref status 4)
+                        (aref status 11)))
+             (if (zerop (aref status 9))
+                 ""
+               "\tSecret keys are imported.\n")))
+    (append-to-buffer pgg-output-buffer (point-min)(point-max))
+    (pgg-process-when-success)))
+
+(provide 'pgg-gpg)
+
+;;; pgg-gpg.el ends here
diff --git a/mime/pgg-parse.el b/mime/pgg-parse.el
new file mode 100644 (file)
index 0000000..f3aec73
--- /dev/null
@@ -0,0 +1,500 @@
+;;; pgg-parse.el --- OpenPGP packet parsing
+
+;; Copyright (C) 1999 Daiki Ueno
+
+;; Author: Daiki Ueno <ueno@ueda.info.waseda.ac.jp>
+;; Created: 1999/10/28
+;; Keywords: PGP, OpenPGP, GnuPG
+
+;; This file is part of SEMI (Secure Emacs MIME Interface).
+
+;; 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:
+
+;;    This module is based on
+
+;;     [OpenPGP] RFC 2440: "OpenPGP Message Format"
+;;         by John W. Noerenberg, II <jwn2@qualcomm.com>,
+;;          Jon Callas <jon@pgp.com>, Lutz Donnerhacke <lutz@iks-jena.de>,
+;;          Hal Finney <hal@pgp.com> and Rodney Thayer <rodney@unitran.com>
+;;         (1998/11)
+
+;;; Code:
+
+(eval-when-compile (require 'cl))
+
+(eval-when-compile (require 'static))
+
+(require 'pccl)
+(require 'custom)
+(require 'mel)
+
+(defgroup pgg-parse ()
+  "OpenPGP packet parsing"
+  :group 'pgg)
+
+(defcustom pgg-parse-public-key-algorithm-alist
+  '((1 . RSA) (2 . RSA-E) (3 . RSA-S) (16 . ELG-E) (17 . DSA) (20 . ELG))
+  "Alist of the assigned number to the public key algorithm."
+  :group 'pgg-parse
+  :type 'alist)
+
+(defcustom pgg-parse-symmetric-key-algorithm-alist
+  '((1 . IDEA) (2 . 3DES) (4 . CAST5) (5 . SAFER-SK128))
+  "Alist of the assigned number to the simmetric key algorithm."
+  :group 'pgg-parse
+  :type 'alist)
+
+(defcustom pgg-parse-hash-algorithm-alist
+  '((1 . MD5) (2 . SHA1) (3 . RIPEMD160) (5 . MD2))
+  "Alist of the assigned number to the cryptographic hash algorithm."
+  :group 'pgg-parse
+  :type 'alist)
+
+(defcustom pgg-parse-compression-algorithm-alist
+  '((0 . nil); Uncompressed
+    (1 . ZIP)
+    (2 . ZLIB))
+  "Alist of the assigned number to the compression algorithm."
+  :group 'pgg-parse
+  :type 'alist)
+
+(defcustom pgg-parse-signature-type-alist
+  '((0 . "Signature of a binary document")
+    (1 . "Signature of a canonical text document")
+    (2 . "Standalone signature")
+    (16 . "Generic certification of a User ID and Public Key packet")
+    (17 . "Persona certification of a User ID and Public Key packet")
+    (18 . "Casual certification of a User ID and Public Key packet")
+    (19 . "Positive certification of a User ID and Public Key packet")
+    (24 . "Subkey Binding Signature")
+    (31 . "Signature directly on a key")
+    (32 . "Key revocation signature")
+    (40 . "Subkey revocation signature")
+    (48 . "Certification revocation signature")
+    (64 . "Timestamp signature."))
+  "Alist of the assigned number to the signature type."
+  :group 'pgg-parse
+  :type 'alist)
+
+(defcustom pgg-ignore-packet-checksum t; XXX
+  "If non-nil checksum of each ascii armored packet will be ignored."
+  :group 'pgg-parse
+  :type 'boolean)
+
+(defvar pgg-armor-header-lines
+  '("^-----BEGIN PGP MESSAGE\\(, PART [0-9]+\\(/[0-9]+\\)?\\)?-----\r?$"
+    "^-----BEGIN PGP PUBLIC KEY BLOCK-----\r?$"
+    "^-----BEGIN PGP PRIVATE KEY BLOCK-----\r?$"
+    "^-----BEGIN PGP SIGNATURE-----\r?$")
+  "Armor headers.")
+
+(defmacro pgg-format-key-identifier (string)
+  `(mapconcat (lambda (c) (format "%02X" (char-int c)))
+             ,string "")
+  ;; `(upcase (apply #'format "%02x%02x%02x%02x%02x%02x%02x%02x"
+  ;;                 (string-to-int-list ,string)))
+  )
+
+(defmacro pgg-parse-time-field (bytes)
+  `(list (logior (lsh (car ,bytes) 8)
+                (nth 1 ,bytes))
+        (logior (lsh (nth 2 ,bytes) 8)
+                (nth 3 ,bytes))
+        0))
+
+(defmacro pgg-byte-after (&optional pos)
+  `(char-int (char-after ,(or pos `(point)))))
+
+(defmacro pgg-read-byte ()
+  `(char-int (char-after (prog1 (point) (forward-char)))))
+
+(defmacro pgg-read-bytes-string (nbytes)
+  `(buffer-substring
+    (point) (prog1 (+ ,nbytes (point))
+             (forward-char ,nbytes))))
+
+(defmacro pgg-read-bytes (nbytes)
+  `(mapcar #'char-int (pgg-read-bytes-string ,nbytes))
+  ;; `(string-to-int-list (pgg-read-bytes-string ,nbytes))
+  )
+
+(defmacro pgg-read-body-string (ptag)
+  `(if (nth 1 ,ptag)
+       (pgg-read-bytes-string (nth 1 ,ptag))
+     (pgg-read-bytes-string (- (point-max) (point)))))
+
+(defmacro pgg-read-body (ptag)
+  `(mapcar #'char-int (pgg-read-body-string ,ptag))
+  ;; `(string-to-int-list (pgg-read-body-string ,ptag))
+  )
+
+(defalias 'pgg-skip-bytes 'forward-char)
+
+(defmacro pgg-skip-header (ptag)
+  `(pgg-skip-bytes (nth 2 ,ptag)))
+
+(defmacro pgg-skip-body (ptag)
+  `(pgg-skip-bytes (nth 1 ,ptag)))
+
+(defmacro pgg-set-alist (alist key value)
+  `(setq ,alist (nconc ,alist (list (cons ,key ,value)))))
+
+(unless-broken ccl-usable
+  (define-ccl-program pgg-parse-crc24
+    '(1
+      ((loop
+       (read r0) (r1 ^= r0) (r2 ^= 0)
+       (r5 = 0)
+       (loop
+        (r1 <<= 1)
+        (r1 += ((r2 >> 15) & 1))
+        (r2 <<= 1)
+        (if (r1 & 256)
+            ((r1 ^= 390) (r2 ^= 19707)))
+        (if (r5 < 7)
+            ((r5 += 1)
+             (repeat))))
+       (repeat)))))
+
+  (defun pgg-parse-crc24-string (string)
+    (let ((h (vector nil 183 1230 nil nil nil nil nil nil)))
+      (ccl-execute-on-string pgg-parse-crc24 h string)
+      (format "%c%c%c"
+             (logand (aref h 1) 255)
+             (logand (lsh (aref h 2) -8) 255)
+             (logand (aref h 2) 255)))))
+
+(defmacro pgg-parse-length-type (c)
+  `(cond
+    ((< ,c 192) (cons ,c 1))
+    ((< ,c 224)
+     (cons (+ (lsh (- ,c 192) 8)
+             (pgg-byte-after (+ 2 (point)))
+             192)
+          2))
+    ((= ,c 255)
+     (cons (cons (logior (lsh (pgg-byte-after (+ 2 (point))) 8)
+                        (pgg-byte-after (+ 3 (point))))
+                (logior (lsh (pgg-byte-after (+ 4 (point))) 8)
+                        (pgg-byte-after (+ 5 (point)))))
+          5))
+    (t;partial body length
+     '(0 . 0))))
+
+(defun pgg-parse-packet-header ()
+  (let ((ptag (pgg-byte-after))
+       length-type content-tag packet-bytes header-bytes)
+    (if (zerop (logand 64 ptag));Old format
+       (progn
+         (setq length-type (logand ptag 3)
+               length-type (if (= 3 length-type) 0 (lsh 1 length-type))
+               content-tag (logand 15 (lsh ptag -2))
+               packet-bytes 0
+               header-bytes (1+ length-type))
+         (dotimes (i length-type)
+           (setq packet-bytes
+                 (logior (lsh packet-bytes 8)
+                         (pgg-byte-after (+ 1 i (point)))))))
+      (setq content-tag (logand 63 ptag)
+           length-type (pgg-parse-length-type
+                        (pgg-byte-after (1+ (point))))
+           packet-bytes (car length-type)
+           header-bytes (1+ (cdr length-type))))
+    (list content-tag packet-bytes header-bytes)))
+
+(defun pgg-parse-packet (ptag)
+  (case (car ptag)
+    (1 ;Public-Key Encrypted Session Key Packet
+     (pgg-parse-public-key-encrypted-session-key-packet ptag))
+    (2 ;Signature Packet
+     (pgg-parse-signature-packet ptag))
+    (3 ;Symmetric-Key Encrypted Session Key Packet
+     (pgg-parse-symmetric-key-encrypted-session-key-packet ptag))
+    ;; 4        -- One-Pass Signature Packet
+    ;; 5        -- Secret Key Packet
+    (6 ;Public Key Packet
+     (pgg-parse-public-key-packet ptag))
+    ;; 7        -- Secret Subkey Packet
+    ;; 8        -- Compressed Data Packet
+    (9 ;Symmetrically Encrypted Data Packet
+     (pgg-read-body-string ptag))
+    (10 ;Marker Packet
+     (pgg-read-body-string ptag))
+    (11 ;Literal Data Packet
+     (pgg-read-body-string ptag))
+    ;; 12       -- Trust Packet
+    (13 ;User ID Packet
+     (pgg-read-body-string ptag))
+    ;; 14       -- Public Subkey Packet
+    ;; 60 .. 63 -- Private or Experimental Values
+    ))
+
+(defun pgg-parse-packets (&optional header-parser body-parser)
+  (let ((header-parser
+        (or header-parser
+            (function pgg-parse-packet-header)))
+       (body-parser
+        (or body-parser
+            (function pgg-parse-packet)))
+       result ptag)
+    (while (> (point-max) (1+ (point)))
+      (setq ptag (funcall header-parser))
+      (pgg-skip-header ptag)
+      (push (cons (car ptag)
+                 (save-excursion
+                   (funcall body-parser ptag)))
+           result)
+      (if (zerop (nth 1 ptag))
+         (goto-char (point-max))
+       (forward-char (nth 1 ptag))))
+    result))
+
+(defun pgg-parse-signature-subpacket-header ()
+  (let ((length-type (pgg-parse-length-type (pgg-byte-after))))
+    (list (pgg-byte-after (+ (cdr length-type) (point)))
+         (1- (car length-type))
+         (1+ (cdr length-type)))))
+       
+(defun pgg-parse-signature-subpacket (ptag)
+  (case (car ptag)
+    (2 ;signature creation time
+     (cons 'creation-time
+          (let ((bytes (pgg-read-bytes 4)))
+            (pgg-parse-time-field bytes))))
+    (3 ;signature expiration time
+     (cons 'signature-expiry
+          (let ((bytes (pgg-read-bytes 4)))
+            (pgg-parse-time-field bytes))))
+    (4 ;exportable certification
+     (cons 'exportability (pgg-read-byte)))
+    (5 ;trust signature
+     (cons 'trust-level (pgg-read-byte)))
+    (6 ;regular expression
+     (cons 'regular-expression
+          (pgg-read-body-string ptag)))
+    (7 ;revocable
+     (cons 'revocability (pgg-read-byte)))
+    (9 ;key expiration time
+     (cons 'key-expiry
+          (let ((bytes (pgg-read-bytes 4)))
+            (pgg-parse-time-field bytes))))
+    ;; 10 = placeholder for backward compatibility
+    (11 ;preferred symmetric algorithms
+     (cons 'preferred-symmetric-key-algorithm
+          (cdr (assq (pgg-read-byte)
+                     pgg-parse-symmetric-key-algorithm-alist))))
+    (12 ;revocation key
+     )
+    (16 ;issuer key ID
+     (cons 'key-identifier
+          (pgg-format-key-identifier (pgg-read-body-string ptag))))
+    (20 ;notation data
+     (pgg-skip-bytes 4)
+     (cons 'notation
+          (let ((name-bytes (pgg-read-bytes 2))
+                (value-bytes (pgg-read-bytes 2)))
+            (cons (pgg-read-bytes-string
+                   (logior (lsh (car name-bytes) 8)
+                           (nth 1 name-bytes)))
+                  (pgg-read-bytes-string
+                   (logior (lsh (car value-bytes) 8)
+                           (nth 1 value-bytes)))))))
+    (21 ;preferred hash algorithms
+     (cons 'preferred-hash-algorithm
+          (cdr (assq (pgg-read-byte)
+                     pgg-parse-hash-algorithm-alist))))
+    (22 ;preferred compression algorithms
+     (cons 'preferred-compression-algorithm
+          (cdr (assq (pgg-read-byte)
+                     pgg-parse-compression-algorithm-alist))))
+    (23 ;key server preferences
+     (cons 'key-server-preferences
+          (pgg-read-body ptag)))
+    (24 ;preferred key server
+     (cons 'preferred-key-server
+          (pgg-read-body-string ptag)))
+    ;; 25 = primary user id
+    (26 ;policy URL
+     (cons 'policy-url (pgg-read-body-string ptag)))
+    ;; 27 = key flags
+    ;; 28 = signer's user id
+    ;; 29 = reason for revocation
+    ;; 100 to 110 = internal or user-defined
+    ))
+
+(defun pgg-parse-signature-packet (ptag)
+  (let* ((signature-version (pgg-byte-after))
+        (result (list (cons 'version signature-version)))
+        hashed-material field n)
+    (cond
+     ((= signature-version 3)
+      (pgg-skip-bytes 2)
+      (setq hashed-material (pgg-read-bytes 5))
+      (pgg-set-alist result
+                    'signature-type
+                    (cdr (assq (pop hashed-material)
+                               pgg-parse-signature-type-alist)))
+      (pgg-set-alist result
+                    'creation-time
+                    (pgg-parse-time-field hashed-material))
+      (pgg-set-alist result
+                    'key-identifier
+                    (pgg-format-key-identifier
+                     (pgg-read-bytes-string 8)))
+      (pgg-set-alist result
+                    'public-key-algorithm (pgg-read-byte))
+      (pgg-set-alist result
+                    'hash-algorithm (pgg-read-byte)))
+     ((= signature-version 4)
+      (pgg-skip-bytes 1)
+      (pgg-set-alist result
+                    'signature-type
+                    (cdr (assq (pgg-read-byte)
+                               pgg-parse-signature-type-alist)))
+      (pgg-set-alist result
+                    'public-key-algorithm
+                    (pgg-read-byte))
+      (pgg-set-alist result
+                    'hash-algorithm (pgg-read-byte))
+      (when (>= 10000 (setq n (pgg-read-bytes 2)
+                           n (logior (lsh (car n) 8)
+                                     (nth 1 n))))
+       (save-restriction
+         (narrow-to-region (point)(+ n (point)))
+         (nconc result
+                (mapcar (function cdr) ;remove packet types
+                        (pgg-parse-packets
+                         #'pgg-parse-signature-subpacket-header
+                         #'pgg-parse-signature-subpacket)))
+         (goto-char (point-max))))
+      (when (>= 10000 (setq n (pgg-read-bytes 2)
+                           n (logior (lsh (car n) 8)
+                                     (nth 1 n))))
+       (save-restriction
+         (narrow-to-region (point)(+ n (point)))
+         (nconc result
+                (mapcar (function cdr) ;remove packet types
+                        (pgg-parse-packets
+                         #'pgg-parse-signature-subpacket-header
+                         #'pgg-parse-signature-subpacket)))))))
+
+    (setcdr (setq field (assq 'public-key-algorithm
+                             result))
+           (cdr (assq (cdr field)
+                      pgg-parse-public-key-algorithm-alist)))
+    (setcdr (setq field (assq 'hash-algorithm
+                             result))
+           (cdr (assq (cdr field)
+                      pgg-parse-hash-algorithm-alist)))
+    result))
+
+(defun pgg-parse-public-key-encrypted-session-key-packet (ptag)
+  (let (result)
+    (pgg-set-alist result
+                  'version (pgg-read-byte))
+    (pgg-set-alist result
+                  'key-identifier
+                  (pgg-format-key-identifier
+                   (pgg-read-bytes-string 8)))
+    (pgg-set-alist result
+                  'public-key-algorithm
+                  (cdr (assq (pgg-read-byte)
+                             pgg-parse-public-key-algorithm-alist)))
+    result))
+
+(defun pgg-parse-symmetric-key-encrypted-session-key-packet (ptag)
+  (let (result)
+    (pgg-set-alist result
+                  'version
+                  (pgg-read-byte))
+    (pgg-set-alist result
+                  'symmetric-key-algorithm
+                  (cdr (assq (pgg-read-byte)
+                             pgg-parse-symmetric-key-algorithm-alist)))
+    result))
+
+(defun pgg-parse-public-key-packet (ptag)
+  (let* ((key-version (pgg-read-byte))
+        (result (list (cons 'version key-version)))
+        field)
+    (cond
+     ((= 3 key-version)
+      (pgg-set-alist result
+                    'creation-time
+                    (let ((bytes (pgg-read-bytes 4)))
+                      (pgg-parse-time-field bytes)))
+      (pgg-set-alist result
+                    'key-expiry (pgg-read-bytes 2))
+      (pgg-set-alist result
+                    'public-key-algorithm (pgg-read-byte)))
+     ((= 4 key-version)
+      (pgg-set-alist result
+                    'creation-time
+                    (let ((bytes (pgg-read-bytes 4)))
+                      (pgg-parse-time-field bytes)))
+      (pgg-set-alist result
+                    'public-key-algorithm (pgg-read-byte))))
+
+    (setcdr (setq field (assq 'public-key-algorithm
+                             result))
+           (cdr (assq (cdr field)
+                      pgg-parse-public-key-algorithm-alist)))
+    result))
+     
+(defun pgg-decode-packets ()
+  (let* ((marker
+         (set-marker (make-marker)
+                     (and (re-search-forward "^=")
+                          (match-beginning 0))))
+        (checksum (buffer-substring (point) (+ 4 (point)))))
+    (delete-region marker (point-max))
+    (mime-decode-region (point-min) marker "base64")
+    (static-when (fboundp 'pgg-parse-crc24-string )
+      (or pgg-ignore-packet-checksum
+         (string-equal
+          (funcall (mel-find-function 'mime-encode-string "base64")
+                   (pgg-parse-crc24-string
+                    (buffer-substring (point-min)(point-max))))
+          checksum)
+         (error "PGP packet checksum does not match")))))
+
+(defun pgg-decode-armor-region (start end)
+  (save-restriction
+    (narrow-to-region start end)
+    (goto-char (point-min))
+    (re-search-forward "^-+BEGIN PGP" nil t)
+    (delete-region (point-min)
+                  (and (search-forward "\n\n")
+                       (match-end 0)))
+    (pgg-decode-packets)
+    (goto-char (point-min))
+    (pgg-parse-packets)))
+
+(defun pgg-parse-armor (string)
+  (with-temp-buffer
+    (buffer-disable-undo)
+    (set-buffer-multibyte nil)
+    (insert string)
+    (pgg-decode-armor-region (point-min)(point))))
+
+(defun pgg-parse-armor-region (start end)
+  (pgg-parse-armor (string-as-unibyte (buffer-substring start end))))
+
+(provide 'pgg-parse)
+
+;;; pgg-parse.el ends here
diff --git a/mime/pgg-pgp.el b/mime/pgg-pgp.el
new file mode 100644 (file)
index 0000000..91f6134
--- /dev/null
@@ -0,0 +1,246 @@
+;;; pgg-pgp.el --- PGP 2.* and 6.* support for PGG.
+
+;; Copyright (C) 1999,2000 Daiki Ueno
+
+;; Author: Daiki Ueno <ueno@ueda.info.waseda.ac.jp>
+;; Created: 1999/11/02
+;; Keywords: PGP, OpenPGP
+
+;; This file is part of SEMI (Secure Emacs MIME Interface).
+
+;; 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.
+
+;;; Code:
+
+(require 'mel) ; binary-to-text-funcall, binary-write-decoded-region
+(eval-when-compile (require 'pgg))
+
+(defgroup pgg-pgp ()
+  "PGP 2.* and 6.* interface"
+  :group 'pgg)
+
+(defcustom pgg-pgp-program "pgp"
+  "PGP 2.* and 6.* executable."
+  :group 'pgg-pgp
+  :type 'string)
+
+(defcustom pgg-pgp-shell-file-name "/bin/sh"
+  "File name to load inferior shells from.
+Bourne shell or its equivalent \(not tcsh) is needed for \"2>\"."
+  :group 'pgg-pgp
+  :type 'string)
+
+(defcustom pgg-pgp-shell-command-switch "-c"
+  "Switch used to have the shell execute its command line argument."
+  :group 'pgg-pgp
+  :type 'string)
+
+(defcustom pgg-pgp-extra-args nil
+  "Extra arguments for every PGP invocation."
+  :group 'pgg-pgp
+  :type 'string)
+
+(eval-and-compile
+  (luna-define-class pgg-scheme-pgp (pgg-scheme)))
+
+(defvar pgg-pgp-user-id nil
+  "PGP ID of your default identity.")
+
+(defvar pgg-scheme-pgp-instance nil)
+
+;;;###autoload
+(defun pgg-make-scheme-pgp ()
+  (or pgg-scheme-pgp-instance
+      (setq pgg-scheme-pgp-instance
+           (luna-make-entity 'pgg-scheme-pgp))))
+
+(defun pgg-pgp-process-region (start end passphrase program args)
+  (let* ((errors-file-name
+         (concat temporary-file-directory
+                 (make-temp-name "pgg-errors")))
+        (args
+         (append args
+                 pgg-pgp-extra-args
+                 (list (concat "2>" errors-file-name))))
+        (shell-file-name pgg-pgp-shell-file-name)
+        (shell-command-switch pgg-pgp-shell-command-switch)
+        (process-environment process-environment)
+        (output-buffer pgg-output-buffer)
+        (errors-buffer pgg-errors-buffer)
+        (process-connection-type nil)
+        process status exit-status)
+    (with-current-buffer (get-buffer-create output-buffer)
+      (buffer-disable-undo)
+      (erase-buffer))
+    (when passphrase
+      (setenv "PGPPASSFD" "0"))
+    (unwind-protect
+       (progn
+         (setq process
+               (apply #'binary-funcall
+                      #'start-process-shell-command "*PGP*" output-buffer
+                      program args))
+         (set-process-sentinel process #'ignore)
+         (when passphrase
+           (process-send-string process (concat passphrase "\n")))
+         (process-send-region process start end)
+         (process-send-eof process)
+         (while (eq 'run (process-status process))
+           (accept-process-output process 5))
+         (setq status (process-status process)
+               exit-status (process-exit-status process))
+         (delete-process process)
+         (with-current-buffer output-buffer
+           (pgg-convert-lbt-region (point-min)(point-max) 'LF)
+
+           (if (memq status '(stop signal))
+               (error "%s exited abnormally: '%s'" program exit-status))
+           (if (= 127 exit-status)
+               (error "%s could not be found" program))
+
+           (set-buffer (get-buffer-create errors-buffer))
+           (buffer-disable-undo)
+           (erase-buffer)
+           (insert-file-contents errors-file-name)))
+      (if (and process (eq 'run (process-status process)))
+         (interrupt-process process))
+      (condition-case nil
+         (delete-file errors-file-name)
+       (file-error nil)))))
+
+(luna-define-method pgg-scheme-lookup-key ((scheme pgg-scheme-pgp)
+                                                 string &optional type)
+  (let ((args (list "+batchmode" "+language=en" "-kv" string)))
+    (with-current-buffer (get-buffer-create pgg-output-buffer)
+      (buffer-disable-undo)
+      (erase-buffer)
+      (apply #'call-process pgg-pgp-program nil t nil args)
+      (goto-char (point-min))
+      (cond
+       ((re-search-forward "^pub\\s +[0-9]+/" nil t);PGP 2.*
+       (buffer-substring (point)(+ 8 (point))))
+       ((re-search-forward "^Type" nil t);PGP 6.*
+       (beginning-of-line 2)
+       (substring
+        (nth 2 (split-string
+                (buffer-substring (point)(progn (end-of-line) (point)))))
+        2))))))
+
+(luna-define-method pgg-scheme-encrypt-region ((scheme pgg-scheme-pgp)
+                                              start end recipients)
+  (let* ((pgg-pgp-user-id (or pgg-pgp-user-id pgg-default-user-id))
+        (args
+         `("+encrypttoself=off +verbose=1" "+batchmode"
+           "+language=us" "-fate"
+           ,@(if recipients
+                 (mapcar (lambda (rcpt) (concat "\"" rcpt "\""))
+                         (append recipients
+                                 (if pgg-encrypt-for-me
+                                     (list pgg-pgp-user-id))))))))
+    (pgg-pgp-process-region start end nil pgg-pgp-program args)
+    (pgg-process-when-success nil)))
+
+(luna-define-method pgg-scheme-decrypt-region ((scheme pgg-scheme-pgp)
+                                              start end)
+  (let* ((pgg-pgp-user-id (or pgg-pgp-user-id pgg-default-user-id))
+        (passphrase
+         (pgg-read-passphrase
+          (format "PGP passphrase for %s: " pgg-pgp-user-id)
+          (pgg-scheme-lookup-key scheme pgg-pgp-user-id 'encrypt)))
+        (args
+         '("+verbose=1" "+batchmode" "+language=us" "-f")))
+    (pgg-pgp-process-region start end passphrase pgg-pgp-program args)
+    (pgg-process-when-success nil)))
+
+(luna-define-method pgg-scheme-sign-region ((scheme pgg-scheme-pgp)
+                                           start end &optional clearsign)
+  (let* ((pgg-pgp-user-id (or pgg-pgp-user-id pgg-default-user-id))
+        (passphrase
+         (pgg-read-passphrase
+          (format "PGP passphrase for %s: " pgg-pgp-user-id)
+          (pgg-scheme-lookup-key scheme pgg-pgp-user-id 'sign)))
+        (args
+         (list (if clearsign "-fast" "-fbast")
+               "+verbose=1" "+language=us" "+batchmode"
+               "-u" pgg-pgp-user-id)))
+    (pgg-pgp-process-region start end passphrase pgg-pgp-program args)
+    (pgg-process-when-success
+      (goto-char (point-min))
+      (when (re-search-forward "^-+BEGIN PGP" nil t);XXX
+       (let ((packet
+              (cdr (assq 2 (pgg-parse-armor-region
+                            (progn (beginning-of-line 2)
+                                   (point))
+                            (point-max))))))
+         (if pgg-cache-passphrase
+             (pgg-add-passphrase-cache
+              (cdr (assq 'key-identifier packet))
+              passphrase)))))))
+
+(luna-define-method pgg-scheme-verify-region ((scheme pgg-scheme-pgp)
+                                             start end &optional signature)
+  (let* ((basename (expand-file-name "pgg" temporary-file-directory))
+        (orig-file (make-temp-name basename))
+        (args '("+verbose=1" "+batchmode" "+language=us"))
+        (orig-mode (default-file-modes)))
+    (unwind-protect
+       (progn
+         (set-default-file-modes 448)
+         (binary-write-decoded-region start end orig-file))
+      (set-default-file-modes orig-mode))
+    (when (stringp signature)
+      (copy-file signature (setq signature (concat orig-file ".asc")))
+      (setq args (append args (list signature orig-file))))
+    (pgg-pgp-process-region (point)(point) nil pgg-pgp-program args)
+    (delete-file orig-file)
+    (if signature (delete-file signature))
+    (pgg-process-when-success
+      (goto-char (point-min))
+      (let ((case-fold-search t))
+       (while (re-search-forward "^warning: " nil t)
+         (delete-region (match-beginning 0)
+                        (progn (beginning-of-line 2) (point)))))
+      (goto-char (point-min))
+      (when (re-search-forward "^\\.$" nil t)
+       (delete-region (point-min)
+                      (progn (beginning-of-line 2)
+                             (point)))))))
+
+(luna-define-method pgg-scheme-insert-key ((scheme pgg-scheme-pgp))
+  (let* ((pgg-pgp-user-id (or pgg-pgp-user-id pgg-default-user-id))
+        (args
+         (list "+verbose=1" "+batchmode" "+language=us" "-kxaf"
+               (concat "\"" pgg-pgp-user-id "\""))))
+    (pgg-pgp-process-region (point)(point) nil pgg-pgp-program args)
+    (insert-buffer-substring pgg-output-buffer)))
+
+(luna-define-method pgg-scheme-snarf-keys-region ((scheme pgg-scheme-pgp)
+                                                 start end)
+  (let* ((pgg-pgp-user-id (or pgg-pgp-user-id pgg-default-user-id))
+        (basename (expand-file-name "pgg" temporary-file-directory))
+        (key-file (make-temp-name basename))
+        (args
+         (list "+verbose=1" "+batchmode" "+language=us" "-kaf"
+               key-file)))
+    (let ((coding-system-for-write 'raw-text-dos))
+      (write-region start end key-file))
+    (pgg-pgp-process-region start end nil pgg-pgp-program args)
+    (delete-file key-file)
+    (pgg-process-when-success nil)))
+
+(provide 'pgg-pgp)
+
+;;; pgg-pgp.el ends here
diff --git a/mime/pgg-pgp5.el b/mime/pgg-pgp5.el
new file mode 100644 (file)
index 0000000..58c3309
--- /dev/null
@@ -0,0 +1,255 @@
+;;; pgg-pgp5.el --- PGP 5.* support for PGG.
+
+;; Copyright (C) 1999,2000 Daiki Ueno
+
+;; Author: Daiki Ueno <ueno@ueda.info.waseda.ac.jp>
+;; Created: 1999/11/02
+;; Keywords: PGP, OpenPGP
+
+;; This file is part of SEMI (Secure Emacs MIME Interface).
+
+;; 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.
+
+;;; Code:
+
+(require 'mel) ; binary-to-text-funcall, binary-write-decoded-region
+(eval-when-compile (require 'pgg))
+
+(defgroup pgg-pgp5 ()
+  "PGP 5.* interface"
+  :group 'pgg)
+
+(defcustom pgg-pgp5-pgpe-program "pgpe"
+  "PGP 5.* 'pgpe' executable."
+  :group 'pgg-pgp5
+  :type 'string)
+
+(defcustom pgg-pgp5-pgps-program "pgps"
+  "PGP 5.* 'pgps' executable."
+  :group 'pgg-pgp5
+  :type 'string)
+
+(defcustom pgg-pgp5-pgpk-program "pgpk"
+  "PGP 5.* 'pgpk' executable."
+  :group 'pgg-pgp5
+  :type 'string)
+
+(defcustom pgg-pgp5-pgpv-program "pgpv"
+  "PGP 5.* 'pgpv' executable."
+  :group 'pgg-pgp5
+  :type 'string)
+
+(defcustom pgg-pgp5-shell-file-name "/bin/sh"
+  "File name to load inferior shells from.
+Bourne shell or its equivalent \(not tcsh) is needed for \"2>\"."
+  :group 'pgg-pgp5
+  :type 'string)
+
+(defcustom pgg-pgp5-shell-command-switch "-c"
+  "Switch used to have the shell execute its command line argument."
+  :group 'pgg-pgp5
+  :type 'string)
+
+(defcustom pgg-pgp5-extra-args nil
+  "Extra arguments for every PGP 5.* invocation."
+  :group 'pgg-pgp5
+  :type 'string)
+
+(eval-and-compile
+  (luna-define-class pgg-scheme-pgp5 (pgg-scheme)))
+
+(defvar pgg-pgp5-user-id nil
+  "PGP 5.* ID of your default identity.")
+
+(defvar pgg-scheme-pgp5-instance nil)
+
+;;;###autoload
+(defun pgg-make-scheme-pgp5 ()
+  (or pgg-scheme-pgp5-instance
+      (setq pgg-scheme-pgp5-instance
+           (luna-make-entity 'pgg-scheme-pgp5))))
+
+(defun pgg-pgp5-process-region (start end passphrase program args)
+  (let* ((errors-file-name
+         (concat temporary-file-directory
+                 (make-temp-name "pgg-errors")))
+        (args
+         (append args
+                 pgg-pgp5-extra-args
+                 (list (concat "2>" errors-file-name))))
+        (shell-file-name pgg-pgp5-shell-file-name)
+        (shell-command-switch pgg-pgp5-shell-command-switch)
+        (process-environment process-environment)
+        (output-buffer pgg-output-buffer)
+        (errors-buffer pgg-errors-buffer)
+        (process-connection-type nil)
+        process status exit-status)
+    (with-current-buffer (get-buffer-create output-buffer)
+      (buffer-disable-undo)
+      (erase-buffer))
+    (when passphrase
+      (setenv "PGPPASSFD" "0"))
+    (unwind-protect
+       (progn
+         (setq process
+               (apply #'binary-funcall
+                      #'start-process-shell-command "*PGP*" output-buffer
+                      program args))
+         (set-process-sentinel process #'ignore)
+         (when passphrase
+           (process-send-string process (concat passphrase "\n")))
+         (process-send-region process start end)
+         (process-send-eof process)
+         (while (eq 'run (process-status process))
+           (accept-process-output process 5))
+         (setq status (process-status process)
+               exit-status (process-exit-status process))
+         (delete-process process)
+         (with-current-buffer output-buffer
+           (pgg-convert-lbt-region (point-min)(point-max) 'LF)
+
+           (if (memq status '(stop signal))
+               (error "%s exited abnormally: '%s'" program exit-status))
+           (if (= 127 exit-status)
+               (error "%s could not be found" program))
+
+           (set-buffer (get-buffer-create errors-buffer))
+           (buffer-disable-undo)
+           (erase-buffer)
+           (insert-file-contents errors-file-name)))
+      (if (and process (eq 'run (process-status process)))
+         (interrupt-process process))
+      (condition-case nil
+         (delete-file errors-file-name)
+       (file-error nil)))))
+
+(luna-define-method pgg-scheme-lookup-key ((scheme pgg-scheme-pgp5)
+                                                 string &optional type)
+  (let ((args (list "+language=en" "-l" string)))
+    (with-current-buffer (get-buffer-create pgg-output-buffer)
+      (buffer-disable-undo)
+      (erase-buffer)
+      (apply #'call-process pgg-pgp5-pgpk-program nil t nil args)
+      (goto-char (point-min))
+      (when (re-search-forward "^sec" nil t)
+       (substring
+        (nth 2 (split-string
+                (buffer-substring (match-end 0)(progn (end-of-line)(point)))))
+        2)))))
+
+(luna-define-method pgg-scheme-encrypt-region ((scheme pgg-scheme-pgp5)
+                                              start end recipients)
+  (let* ((pgg-pgp5-user-id (or pgg-pgp5-user-id pgg-default-user-id))
+        (args
+         `("+NoBatchInvalidKeys=off" "-fat" "+batchmode=1"
+           ,@(if recipients
+                 (apply #'append
+                        (mapcar (lambda (rcpt)
+                                  (list "-r"
+                                        (concat "\"" rcpt "\"")))
+                                (append recipients
+                                        (if pgg-encrypt-for-me
+                                            (list pgg-pgp5-user-id)))))))))
+    (pgg-pgp5-process-region start end nil pgg-pgp5-pgpe-program args)
+    (pgg-process-when-success nil)))
+
+(luna-define-method pgg-scheme-decrypt-region ((scheme pgg-scheme-pgp5)
+                                              start end)
+  (let* ((pgg-pgp5-user-id (or pgg-pgp5-user-id pgg-default-user-id))
+        (passphrase
+         (pgg-read-passphrase
+          (format "PGP passphrase for %s: " pgg-pgp5-user-id)
+          (pgg-scheme-lookup-key scheme pgg-pgp5-user-id 'encrypt)))
+        (args
+         '("+verbose=1" "+batchmode=1" "+language=us" "-f")))
+    (pgg-pgp5-process-region start end passphrase pgg-pgp5-pgpv-program args)
+    (pgg-process-when-success nil)))
+
+(luna-define-method pgg-scheme-sign-region ((scheme pgg-scheme-pgp5)
+                                           start end &optional clearsign)
+  (let* ((pgg-pgp5-user-id (or pgg-pgp5-user-id pgg-default-user-id))
+        (passphrase
+         (pgg-read-passphrase
+          (format "PGP passphrase for %s: " pgg-pgp5-user-id)
+          (pgg-scheme-lookup-key scheme pgg-pgp5-user-id 'sign)))
+        (args
+         (list (if clearsign "-fat" "-fbat")
+               "+verbose=1" "+language=us" "+batchmode=1"
+               "-u" pgg-pgp5-user-id)))
+    (pgg-pgp5-process-region start end passphrase pgg-pgp5-pgps-program args)
+    (pgg-process-when-success
+      (when (re-search-forward "^-+BEGIN PGP SIGNATURE" nil t);XXX
+       (let ((packet
+              (cdr (assq 2 (pgg-parse-armor-region
+                            (progn (beginning-of-line 2)
+                                   (point))
+                            (point-max))))))
+         (if pgg-cache-passphrase
+             (pgg-add-passphrase-cache
+              (cdr (assq 'key-identifier packet))
+              passphrase)))))))
+
+(luna-define-method pgg-scheme-verify-region ((scheme pgg-scheme-pgp5)
+                                             start end &optional signature)
+  (let* ((basename (expand-file-name "pgg" temporary-file-directory))
+        (orig-file (make-temp-name basename))
+        (args '("+verbose=1" "+batchmode=1" "+language=us"))
+        (orig-mode (default-file-modes)))
+    (unwind-protect
+       (progn
+         (set-default-file-modes 448)
+         (binary-write-decoded-region start end orig-file))
+      (set-default-file-modes orig-mode))
+    (when (stringp signature)
+      (copy-file signature (setq signature (concat orig-file ".asc")))
+      (setq args (append args (list signature))))
+    (pgg-pgp5-process-region (point)(point) nil pgg-pgp5-pgpv-program args)
+    (delete-file orig-file)
+    (if signature (delete-file signature))
+    (with-current-buffer pgg-errors-buffer
+      (goto-char (point-min))
+      (if (re-search-forward "^Good signature" nil t)
+         (progn
+           (set-buffer pgg-output-buffer)
+           (insert-buffer-substring pgg-errors-buffer)
+           t)
+       nil))))
+
+(luna-define-method pgg-scheme-insert-key ((scheme pgg-scheme-pgp5))
+  (let* ((pgg-pgp5-user-id (or pgg-pgp5-user-id pgg-default-user-id))
+        (args
+         (list "+verbose=1" "+batchmode=1" "+language=us" "-x"
+               (concat "\"" pgg-pgp5-user-id "\""))))
+    (pgg-pgp5-process-region (point)(point) nil pgg-pgp5-pgpk-program args)
+    (insert-buffer-substring pgg-output-buffer)))
+
+(luna-define-method pgg-scheme-snarf-keys-region ((scheme pgg-scheme-pgp5)
+                                                 start end)
+  (let* ((pgg-pgp5-user-id (or pgg-pgp5-user-id pgg-default-user-id))
+        (basename (expand-file-name "pgg" temporary-file-directory))
+        (key-file (make-temp-name basename))
+        (args
+         (list "+verbose=1" "+batchmode=1" "+language=us" "-a"
+               key-file)))
+    (let ((coding-system-for-write 'raw-text-dos))
+      (write-region start end key-file))
+    (pgg-pgp5-process-region start end nil pgg-pgp5-pgpk-program args)
+    (delete-file key-file)
+    (pgg-process-when-success nil)))
+
+(provide 'pgg-pgp5)
+
+;;; pgg-pgp5.el ends here
diff --git a/mime/pgg.el b/mime/pgg.el
new file mode 100644 (file)
index 0000000..1b40d48
--- /dev/null
@@ -0,0 +1,421 @@
+;;; pgg.el --- glue for the various PGP implementations.
+
+;; Copyright (C) 1999,2000 Free Software Foundation, Inc.
+
+;; Author: Daiki Ueno <ueno@unixuser.org>
+;; Created: 1999/10/28
+;; Keywords: PGP
+
+;; This file is part of SEMI (Secure Emacs MIME Interface).
+
+;; 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:
+
+(require 'calist)
+
+(eval-and-compile (require 'luna))
+
+(require 'pgg-def)
+(require 'pgg-parse)
+
+(eval-when-compile
+  (ignore-errors
+    (require 'w3)
+    (require 'url)))
+
+(in-calist-package 'pgg)
+
+(defun pgg-field-match-method-with-containment
+  (calist field-type field-value)
+  (let ((s-field (assq field-type calist)))
+    (cond ((null s-field)
+          (cons (cons field-type field-value) calist))
+         ((memq (cdr s-field) field-value)
+          calist))))
+
+(define-calist-field-match-method 'signature-version
+  #'pgg-field-match-method-with-containment)
+
+(define-calist-field-match-method 'symmetric-key-algorithm
+  #'pgg-field-match-method-with-containment)
+
+(define-calist-field-match-method 'public-key-algorithm
+  #'pgg-field-match-method-with-containment)
+
+(define-calist-field-match-method 'hash-algorithm
+  #'pgg-field-match-method-with-containment)
+
+(defvar pgg-verify-condition nil
+  "Condition-tree about which PGP implementation is used for verifying.")
+
+(defvar pgg-decrypt-condition nil
+  "Condition-tree about which PGP implementation is used for decrypting.")
+
+(ctree-set-calist-strictly
+ 'pgg-verify-condition
+ '((signature-version 3)(public-key-algorithm RSA)(hash-algorithm MD5)
+   (scheme . pgp)))
+
+(ctree-set-calist-strictly
+ 'pgg-decrypt-condition
+ '((public-key-algorithm RSA)(symmetric-key-algorithm IDEA)
+   (scheme . pgp)))
+
+(ctree-set-calist-strictly
+ 'pgg-verify-condition
+ '((signature-version 3 4)
+   (public-key-algorithm RSA ELG DSA)
+   (hash-algorithm MD5 SHA1 RIPEMD160)
+   (scheme . pgp5)))
+
+(ctree-set-calist-strictly
+ 'pgg-decrypt-condition
+ '((public-key-algorithm RSA ELG DSA)
+   (symmetric-key-algorithm 3DES CAST5 IDEA)
+   (scheme . pgp5)))
+
+(ctree-set-calist-strictly
+ 'pgg-verify-condition
+ '((signature-version 3 4)
+   (public-key-algorithm ELG-E DSA ELG)
+   (hash-algorithm MD5 SHA1 RIPEMD160)
+   (scheme . gpg)))
+
+(ctree-set-calist-strictly
+ 'pgg-decrypt-condition
+ '((public-key-algorithm ELG-E DSA ELG)
+   (symmetric-key-algorithm 3DES CAST5 BLOWFISH TWOFISH)
+   (scheme . gpg)))
+
+;;; @ definition of the implementation scheme
+;;;
+
+(eval-and-compile
+  (luna-define-class pgg-scheme ())
+
+  (luna-define-internal-accessors 'pgg-scheme))
+
+(luna-define-generic pgg-scheme-lookup-key (scheme string &optional type)
+  "Search keys associated with STRING.")
+
+(luna-define-generic pgg-scheme-encrypt-region (scheme start end recipients)
+  "Encrypt the current region between START and END.")
+
+(luna-define-generic pgg-scheme-decrypt-region (scheme start end)
+  "Decrypt the current region between START and END.")
+
+(luna-define-generic pgg-scheme-sign-region
+  (scheme start end &optional cleartext)
+  "Make detached signature from text between START and END.")
+
+(luna-define-generic pgg-scheme-verify-region
+  (scheme start end &optional signature)
+  "Verify region between START and END as the detached signature SIGNATURE.")
+
+(luna-define-generic pgg-scheme-insert-key (scheme)
+  "Insert public key at point.")
+
+(luna-define-generic pgg-scheme-snarf-keys-region (scheme start end)
+  "Add all public keys in region between START and END to the keyring.")
+
+;;; @ utility functions
+;;;
+
+(defvar pgg-fetch-key-function (function pgg-fetch-key-with-w3))
+
+(defmacro pgg-make-scheme (scheme)
+  `(progn
+     (require (intern (format "pgg-%s" ,scheme)))
+     (funcall (intern (format "pgg-make-scheme-%s"
+                             ,scheme)))))
+
+(put 'pgg-save-coding-system 'lisp-indent-function 2)
+
+(defmacro pgg-save-coding-system (start end &rest body)
+  `(if (interactive-p)
+       (let ((buffer (current-buffer)))
+        (with-temp-buffer
+          (let (buffer-undo-list)
+            (insert-buffer-substring buffer ,start ,end)
+            (encode-coding-region (point-min)(point-max)
+                                  buffer-file-coding-system)
+            (prog1 (save-excursion ,@body)
+              (push nil buffer-undo-list)
+              (ignore-errors (undo))))))
+     (save-restriction
+       (narrow-to-region ,start ,end)
+       ,@body)))
+
+(defun pgg-temp-buffer-show-function (buffer)
+  (let ((window (split-window-vertically)))
+    (set-window-buffer window buffer)
+    (shrink-window-if-larger-than-buffer window)))
+
+(defun pgg-display-output-buffer (start end status)
+  (if status
+      (progn
+       (delete-region start end)
+       (insert-buffer-substring pgg-output-buffer)
+       (decode-coding-region start (point) buffer-file-coding-system))
+    (let ((temp-buffer-show-function
+          (function pgg-temp-buffer-show-function)))
+      (with-output-to-temp-buffer pgg-echo-buffer
+       (set-buffer standard-output)
+       (insert-buffer-substring pgg-errors-buffer)))))
+
+(defvar pgg-passphrase-cache-expiry 16)
+(defvar pgg-passphrase-cache (make-vector 7 0))
+
+(defvar pgg-read-passphrase nil)
+(defun pgg-read-passphrase (prompt &optional key)
+  (if (not pgg-read-passphrase)
+      (if (functionp 'read-passwd)
+         (setq pgg-read-passphrase 'read-passwd)
+       (if (load "passwd" t)
+           (setq pgg-read-passphrase 'read-passwd)
+         (autoload 'ange-ftp-read-passwd "ange-ftp")
+         (setq pgg-read-passphrase 'ange-ftp-read-passwd))))
+  (or (and pgg-cache-passphrase
+          key (setq key (pgg-truncate-key-identifier key))
+          (symbol-value (intern-soft key pgg-passphrase-cache)))
+      (funcall pgg-read-passphrase prompt)))
+
+(defun pgg-add-passphrase-cache (key passphrase)
+  (setq key (pgg-truncate-key-identifier key))
+  (set (intern key pgg-passphrase-cache)
+       passphrase)
+  (run-at-time pgg-passphrase-cache-expiry nil
+              #'pgg-remove-passphrase-cache
+              key))
+
+(defun pgg-remove-passphrase-cache (key)
+  (let ((passphrase (symbol-value (intern-soft key pgg-passphrase-cache))))
+    (when passphrase
+      (fillarray passphrase ?_)
+      (unintern key pgg-passphrase-cache))))
+
+(defmacro pgg-convert-lbt-region (start end lbt)
+  `(let ((pgg-conversion-end (set-marker (make-marker) ,end)))
+     (goto-char ,start)
+     (case ,lbt
+       (CRLF
+       (while (progn
+                (end-of-line)
+                (> (marker-position pgg-conversion-end) (point)))
+         (insert "\r")
+         (forward-line 1)))
+       (LF
+       (while (re-search-forward "\r$" pgg-conversion-end t)
+         (replace-match ""))))))
+
+(put 'pgg-as-lbt 'lisp-indent-function 3)
+
+(defmacro pgg-as-lbt (start end lbt &rest body)
+  `(let ((inhibit-read-only t)
+        buffer-read-only
+        buffer-undo-list)
+     (pgg-convert-lbt-region ,start ,end ,lbt)
+     (let ((,end (point)))
+       ,@body)
+     (push nil buffer-undo-list)
+     (ignore-errors (undo))))
+
+(put 'pgg-process-when-success 'lisp-indent-function 0)
+
+(defmacro pgg-process-when-success (&rest body)
+  `(with-current-buffer pgg-output-buffer
+     (if (zerop (buffer-size)) nil ,@body t)))
+
+
+;;; @ interface functions
+;;;
+
+;;;###autoload
+(defun pgg-encrypt-region (start end rcpts)
+  "Encrypt the current region between START and END for RCPTS."
+  (interactive
+   (list (region-beginning)(region-end)
+        (split-string (read-string "Recipients: ") "[ \t,]+")))
+  (let* ((entity (pgg-make-scheme pgg-default-scheme))
+        (status
+         (pgg-save-coding-system start end
+           (pgg-scheme-encrypt-region entity (point-min)(point-max) rcpts))))
+    (when (interactive-p)
+      (pgg-display-output-buffer start end status))
+    status))
+
+;;;###autoload
+(defun pgg-decrypt-region (start end)
+  "Decrypt the current region between START and END."
+  (interactive "r")
+  (let* ((packet (cdr (assq 1 (pgg-parse-armor-region start end))))
+        (scheme
+         (or pgg-scheme
+             (cdr (assq 'scheme
+                        (progn
+                          (in-calist-package 'pgg)
+                          (ctree-match-calist pgg-decrypt-condition
+                                              packet))))
+             pgg-default-scheme))
+        (entity (pgg-make-scheme scheme))
+        (status
+         (pgg-save-coding-system start end
+           (pgg-scheme-decrypt-region entity (point-min)(point-max)))))
+    (when (interactive-p)
+      (pgg-display-output-buffer start end status))
+    status))
+
+;;;###autoload
+(defun pgg-sign-region (start end &optional cleartext)
+  "Make the signature from text between START and END.
+If the optional 3rd argument CLEARTEXT is non-nil, it does not create
+a detached signature."
+  (interactive "r")
+  (let* ((entity (pgg-make-scheme pgg-default-scheme))
+        (status (pgg-save-coding-system start end
+                  (pgg-scheme-sign-region entity (point-min)(point-max)
+                                          (or (interactive-p) cleartext)))))
+    (when (interactive-p)
+      (pgg-display-output-buffer start end status))
+    status))
+
+;;;###autoload
+(defun pgg-verify-region (start end &optional signature fetch)
+  "Verify the current region between START and END.
+If the optional 3rd argument SIGNATURE is non-nil, it is treated as
+the detached signature of the current region.
+
+If the optional 4th argument FETCH is non-nil, we attempt to fetch the
+signer's public key from `pgg-default-keyserver-address'."
+  (interactive "r")
+  (let* ((packet
+         (if (null signature) nil
+           (with-temp-buffer
+             (buffer-disable-undo)
+             (set-buffer-multibyte nil)
+             (insert-file-contents signature)
+             (cdr (assq 2 (pgg-decode-armor-region
+                           (point-min)(point-max)))))))
+        (scheme
+         (or pgg-scheme
+             (cdr (assq 'scheme
+                        (progn
+                          (in-calist-package 'pgg)
+                          (ctree-match-calist pgg-verify-condition
+                                              packet))))
+             pgg-default-scheme))
+        (entity (pgg-make-scheme scheme))
+        (key (cdr (assq 'key-identifier packet)))
+        status keyserver)
+    (and (stringp key)
+        (setq key (concat "0x" (pgg-truncate-key-identifier key)))
+        (null (let ((pgg-scheme scheme))
+                (pgg-lookup-key key)))
+        (or fetch (interactive-p))
+        (y-or-n-p (format "Key %s not found; attempt to fetch? " key))
+        (setq keyserver
+              (or (cdr (assq 'preferred-key-server packet))
+                  pgg-default-keyserver-address))
+        (pgg-fetch-key keyserver key))
+    (setq status (pgg-save-coding-system start end
+                  (pgg-scheme-verify-region entity (point-min)(point-max)
+                                            signature)))
+    (when (interactive-p)
+      (let ((temp-buffer-show-function
+            (function pgg-temp-buffer-show-function)))
+       (with-output-to-temp-buffer pgg-echo-buffer
+         (set-buffer standard-output)
+         (insert-buffer-substring (if status pgg-output-buffer
+                                    pgg-errors-buffer)))))
+    status))
+
+;;;###autoload
+(defun pgg-insert-key ()
+  "Insert the ASCII armored public key."
+  (interactive)
+  (let ((entity (pgg-make-scheme (or pgg-scheme pgg-default-scheme))))
+    (pgg-scheme-insert-key entity)))
+
+;;;###autoload
+(defun pgg-snarf-keys-region (start end)
+  "Import public keys in the current region between START and END."
+  (interactive "r")
+  (let ((entity (pgg-make-scheme (or pgg-scheme pgg-default-scheme))))
+    (pgg-save-coding-system start end
+      (pgg-scheme-snarf-keys-region entity start end))))
+
+(defun pgg-lookup-key (string &optional type)
+  (let ((entity (pgg-make-scheme (or pgg-scheme pgg-default-scheme))))
+    (pgg-scheme-lookup-key entity string type)))
+
+(defvar pgg-insert-url-function  (function pgg-insert-url-with-w3))
+
+(defun pgg-insert-url-with-w3 (url)
+  (require 'w3)
+  (require 'url)
+  (let (buffer-file-name)
+    (url-insert-file-contents url)))
+
+(defvar pgg-insert-url-extra-arguments nil)
+(defvar pgg-insert-url-program nil)
+
+(defun pgg-insert-url-with-program (url)
+  (let ((args (copy-sequence pgg-insert-url-extra-arguments))
+       process)
+    (insert
+     (with-temp-buffer
+       (setq process
+            (apply #'start-process " *PGG url*" (current-buffer)
+                   pgg-insert-url-program (nconc args (list url))))
+       (set-process-sentinel process #'ignore)
+       (while (eq 'run (process-status process))
+        (accept-process-output process 5))
+       (delete-process process)
+       (if (and process (eq 'run (process-status process)))
+          (interrupt-process process))
+       (buffer-string)))))
+
+(defun pgg-fetch-key (keyserver key)
+  "Attempt to fetch a KEY from KEYSERVER for addition to PGP or GnuPG keyring."
+  (with-current-buffer (get-buffer-create pgg-output-buffer)
+    (buffer-disable-undo)
+    (erase-buffer)
+    (let ((proto (if (string-match "^[a-zA-Z\\+\\.\\\\-]+:" keyserver)
+                    (substring keyserver 0 (1- (match-end 0))))))
+      (save-excursion
+       (funcall pgg-insert-url-function
+                (if proto keyserver
+                  (format "http://%s:11371/pks/lookup?op=get&search=%s"
+                          keyserver key))))
+      (when (re-search-forward "^-+BEGIN" nil 'last)
+       (delete-region (point-min) (match-beginning 0))
+       (when (re-search-forward "^-+END" nil t)
+         (delete-region (progn (end-of-line) (point))
+                        (point-max)))
+       (insert "\n")
+       (with-temp-buffer
+         (insert-buffer-substring pgg-output-buffer)
+         (pgg-snarf-keys-region (point-min)(point-max)))))))
+
+
+(provide 'pgg)
+
+;;; pgg.el ends here
diff --git a/mime/postpet.el b/mime/postpet.el
new file mode 100644 (file)
index 0000000..4284cf6
--- /dev/null
@@ -0,0 +1,153 @@
+;;; postpet.el --- Postpet support for GNU Emacs
+
+;; Copyright (C) 1999,2000 Free Software Foundation, Inc.
+
+;; Author: Tanaka Akira  <akr@jaist.ac.jp>
+;; Keywords: Postpet, MIME, multimedia, mail, news
+
+;; This file is part of SEMI (Sample of Elastic MIME Interfaces).
+
+;; 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.
+
+;;; Code:
+
+(require 'mime)
+(require 'alist)
+
+(put 'unpack 'lisp-indent-function 1)
+(defmacro unpack (string &rest body)
+  `(let* ((*unpack*string* (string-as-unibyte ,string))
+         (*unpack*index* 0))
+     ,@body))
+
+(defun unpack-skip (len)
+  (setq *unpack*index* (+ len *unpack*index*)))
+
+(defun unpack-fixed (len)
+  (prog1
+      (substring *unpack*string* *unpack*index* (+ *unpack*index* len))
+    (unpack-skip len)))
+
+(defun unpack-byte ()
+  (char-int (aref (unpack-fixed 1) 0)))
+
+(defun unpack-short ()
+  (let* ((b0 (unpack-byte))
+        (b1 (unpack-byte)))
+    (+ (* 256 b0) b1)))
+
+(defun unpack-long ()
+  (let* ((s0 (unpack-short))
+        (s1 (unpack-short)))
+    (+ (* 65536 s0) s1)))
+
+(defun unpack-string ()
+  (let ((len (unpack-byte)))
+    (unpack-fixed len)))
+
+(defun unpack-string-sjis ()
+  (decode-mime-charset-string (unpack-string) 'shift_jis))
+
+;;;###autoload
+(defun postpet-decode (string)
+  (condition-case nil
+      (unpack string
+       (let (res)
+         (unpack-skip 4)
+         (set-alist 'res 'carryingcount (unpack-long))
+         (unpack-skip 8)
+         (set-alist 'res 'sentyear (unpack-short))
+         (set-alist 'res 'sentmonth (unpack-short))
+         (set-alist 'res 'sentday (unpack-short))
+         (unpack-skip 8)
+         (set-alist 'res 'petname (unpack-string-sjis))
+         (set-alist 'res 'owner (unpack-string-sjis))
+         (set-alist 'res 'pettype (unpack-fixed 4))
+         (set-alist 'res 'health (unpack-short))
+         (unpack-skip 2)
+         (set-alist 'res 'sex (unpack-long))
+         (unpack-skip 1)
+         (set-alist 'res 'brain (unpack-byte))
+         (unpack-skip 39)
+         (set-alist 'res 'happiness (unpack-byte))
+         (unpack-skip 14)
+         (set-alist 'res 'petbirthyear (unpack-short))
+         (set-alist 'res 'petbirthmonth (unpack-short))
+         (set-alist 'res 'petbirthday (unpack-short))
+         (unpack-skip 8)
+         (set-alist 'res 'from (unpack-string))
+         (unpack-skip 5)
+         (unpack-skip 160)
+         (unpack-skip 4)
+         (unpack-skip 8)
+         (unpack-skip 8)
+         (unpack-skip 26)
+         (set-alist 'res 'treasure (unpack-short))
+         (set-alist 'res 'money (unpack-long))
+         res))
+    (error nil)))
+
+;;;###autoload
+(defun mime-display-application/x-postpet (entity situation)
+  (save-restriction
+    (narrow-to-region (point-max)(point-max))
+    (let ((pet (postpet-decode (mime-entity-content entity))))
+      (if pet
+         (insert
+          "Petname: " (cdr (assq 'petname pet))
+          "\n"
+          "Owner: " (cdr (assq 'owner pet))
+          "\n"
+          "Pettype: " (cdr (assq 'pettype pet))
+          "\n"
+          "From: " (cdr (assq 'from pet))
+          "\n"
+          "CarryingCount: " (int-to-string (cdr (assq 'carryingcount pet)))
+          "\n"
+          "SentYear: " (int-to-string (cdr (assq 'sentyear pet)))
+          "\n"
+          "SentMonth: " (int-to-string (cdr (assq 'sentmonth pet)))
+          "\n"
+          "SentDay: " (int-to-string (cdr (assq 'sentday pet)))
+          "\n"
+          "PetbirthYear: " (int-to-string (cdr (assq 'petbirthyear pet)))
+          "\n"
+          "PetbirthMonth: " (int-to-string (cdr (assq 'petbirthmonth pet)))
+          "\n"
+          "PetbirthDay: " (int-to-string (cdr (assq 'petbirthday pet)))
+          "\n"
+          "Health: " (int-to-string (cdr (assq 'health pet)))
+          "\n"
+          "Sex: " (int-to-string (cdr (assq 'sex pet)))
+          "\n"
+          "Brain: " (int-to-string (cdr (assq 'brain pet)))
+          "\n"
+          "Happiness: " (int-to-string (cdr (assq 'happiness pet)))
+          "\n"
+          "Treasure: " (int-to-string (cdr (assq 'treasure pet)))
+          "\n"
+          "Money: " (int-to-string (cdr (assq 'money pet)))
+          "\n")
+       (insert "Invalid format\n"))
+      (run-hooks 'mime-display-application/x-postpet-hook))))
+
+
+;;; @ end
+;;;
+
+(provide 'postpet)
+
+;;; postpet.el ends here
diff --git a/mime/semi-def.el b/mime/semi-def.el
new file mode 100644 (file)
index 0000000..5e6fa0f
--- /dev/null
@@ -0,0 +1,208 @@
+;;; semi-def.el --- definition module for SEMI -*- coding: iso-8859-4; -*-
+
+;; Copyright (C) 1995,96,97,98,99,2000 Free Software Foundation, Inc.
+
+;; Author: MORIOKA Tomohiko <tomo@m17n.org>
+;; Keywords: definition, MIME, multimedia, mail, news
+
+;; This file is part of SEMI (Sample of Emacs MIME Implementation).
+
+;; 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.
+
+;;; Code:
+
+(eval-when-compile (require 'cl))
+
+(require 'custom)
+
+(defconst mime-user-interface-product ["SEMI" (1 14 3) "Ushinoya"]
+  "Product name, version number and code name of MIME-kernel package.")
+
+(autoload 'mule-caesar-region "mule-caesar"
+  "Caesar rotation of current region." t)
+
+
+;;; @ constants
+;;;
+
+(defconst mime-echo-buffer-name "*MIME-echo*"
+  "Name of buffer to display MIME-playing information.")
+
+(defconst mime-temp-buffer-name " *MIME-temp*")
+
+
+;;; @ button
+;;;
+
+(defcustom mime-button-face 'bold
+  "Face used for content-button or URL-button of MIME-Preview buffer."
+  :group 'mime
+  :type 'face)
+
+(defcustom mime-button-mouse-face 'highlight
+  "Face used for MIME-preview buffer mouse highlighting."
+  :group 'mime
+  :type 'face)
+
+(defsubst mime-add-button (from to function &optional data)
+  "Create a button between FROM and TO with callback FUNCTION and DATA."
+  (and mime-button-face
+       (put-text-property from to 'face mime-button-face))
+  (and mime-button-mouse-face
+       (put-text-property from to 'mouse-face mime-button-mouse-face))
+  (put-text-property from to 'mime-button-callback function)
+  (and data
+       (put-text-property from to 'mime-button-data data))
+  )
+
+(defsubst mime-insert-button (string function &optional data)
+  "Insert STRING as button with callback FUNCTION and DATA."
+  (save-restriction
+    (narrow-to-region (point)(point))
+    (insert (concat "[" string "]\n"))
+    (mime-add-button (point-min)(point-max) function data)
+    ))
+
+(defvar mime-button-mother-dispatcher nil)
+
+(defun mime-button-dispatcher (event)
+  "Select the button under point."
+  (interactive "e")
+  (let (buf point func data)
+    (save-window-excursion
+      (mouse-set-point event)
+      (setq buf (current-buffer)
+           point (point)
+           func (get-text-property (point) 'mime-button-callback)
+           data (get-text-property (point) 'mime-button-data)
+           ))
+    (save-excursion
+      (set-buffer buf)
+      (goto-char point)
+      (if func
+         (apply func data)
+       (if (fboundp mime-button-mother-dispatcher)
+           (funcall mime-button-mother-dispatcher event)
+         )))))
+
+
+;;; @ for URL
+;;;
+
+(defcustom mime-browse-url-regexp
+  (concat "\\(http\\|ftp\\|file\\|gopher\\|news\\|telnet\\|wais\\|mailto\\):"
+         "\\(//[-a-zA-Z0-9_.]+:[0-9]*\\)?"
+         "[-a-zA-Z0-9_=?#$@~`%&*+|\\/.,]*[-a-zA-Z0-9_=#$@~`%&*+|\\/]")
+  "*Regexp to match URL in text body."
+  :group 'mime
+  :type 'regexp)
+
+(defcustom mime-browse-url-function (function browse-url)
+  "*Function to browse URL."
+  :group 'mime
+  :type 'function)
+
+(defsubst mime-add-url-buttons ()
+  "Add URL-buttons for text body."
+  (goto-char (point-min))
+  (while (re-search-forward mime-browse-url-regexp nil t)
+    (let ((beg (match-beginning 0))
+         (end (match-end 0)))
+      (mime-add-button beg end mime-browse-url-function
+                      (list (buffer-substring beg end))))))
+
+
+;;; @ menu
+;;;
+
+(if window-system
+    (if (featurep 'xemacs)
+       (defun select-menu-alist (title menu-alist)
+         (let (ret)
+           (popup-menu
+            (list* title
+                   "---"
+                   (mapcar (function
+                            (lambda (cell)
+                              (vector (car cell)
+                                      `(progn
+                                         (setq ret ',(cdr cell))
+                                         (throw 'exit nil)
+                                         )
+                                      t)
+                              ))
+                           menu-alist)
+                   ))
+           (recursive-edit)
+           ret))
+      (defun select-menu-alist (title menu-alist)
+       (x-popup-menu
+        (list '(1 1) (selected-window))
+        (list title (cons title menu-alist))
+        ))
+      )
+  (defun select-menu-alist (title menu-alist)
+    (cdr
+     (assoc (completing-read (concat title " : ") menu-alist)
+           menu-alist)
+     ))
+  )
+
+
+;;; @ Other Utility
+;;;
+
+(defvar mime-condition-type-alist
+  '((preview . mime-preview-condition)
+    (action . mime-acting-condition)))
+
+(defvar mime-condition-mode-alist
+  '((with-default . ctree-set-calist-with-default)
+    (t . ctree-set-calist-strictly)))
+
+(defun mime-add-condition (target-type condition &optional mode file)
+  "Add CONDITION to database specified by TARGET-TYPE.
+TARGET-TYPE must be 'preview or 'action.  
+If optional argument MODE is 'strict or nil (omitted), CONDITION is
+added strictly.
+If optional argument MODE is 'with-default, CONDITION is added with
+default rule.
+If optional argument FILE is specified, it is loaded when CONDITION is
+activate."
+  (let ((sym (cdr (assq target-type mime-condition-type-alist))))
+    (if sym
+       (let ((func (cdr (or (assq mode mime-condition-mode-alist)
+                            (assq t mime-condition-mode-alist)))))
+         (if (fboundp func)
+             (progn
+               (funcall func sym condition)
+               (if file
+                   (let ((method (cdr (assq 'method condition))))
+                     (autoload method file)
+                     ))
+               )
+           (error "Function for mode `%s' is not found." mode)
+           ))
+      (error "Variable for target-type `%s' is not found." target-type)
+      )))
+
+
+;;; @ end
+;;;
+
+(provide 'semi-def)
+
+;;; semi-def.el ends here
diff --git a/mime/semi-setup.el b/mime/semi-setup.el
new file mode 100644 (file)
index 0000000..ecdf2ae
--- /dev/null
@@ -0,0 +1,208 @@
+;;; semi-setup.el --- setup file for MIME-View.
+
+;; Copyright (C) 1994,95,96,97,98,99,2000 Free Software Foundation, Inc.
+
+;; Author: MORIOKA Tomohiko <tomo@m17n.org>
+;; Keywords: mail, news, MIME, multimedia, multilingual, encoded-word
+
+;; This file is part of SEMI (Setting for Emacs MIME Interfaces).
+
+;; 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.
+
+;;; Code:
+
+(require 'semi-def)
+(require 'path-util)
+
+(defun call-after-loaded (module func &optional hook-name)
+  "If MODULE is provided, then FUNC is called.
+Otherwise func is set to MODULE-load-hook.
+If optional argument HOOK-NAME is specified,
+it is used as hook to set."
+  (if (featurep module)
+      (funcall func)
+    (or hook-name
+       (setq hook-name (intern (concat (symbol-name module) "-load-hook")))
+       )
+    (add-hook hook-name func)
+    ))
+
+
+;; for image/*
+(defvar mime-setup-enable-inline-image
+  (and window-system
+       (or (featurep 'xemacs)(featurep 'mule)))
+  "*If it is non-nil, semi-setup sets up to use mime-image.")
+
+(if mime-setup-enable-inline-image
+    (eval-after-load "mime-view"
+      '(require 'mime-image)))
+
+;; for text/html
+(defvar mime-setup-enable-inline-html
+  (module-installed-p 'w3)
+  "*If it is non-nil, semi-setup sets up to use mime-w3.")
+
+(if mime-setup-enable-inline-html
+    (eval-after-load "mime-view"
+      '(progn
+        (autoload 'mime-preview-text/html "mime-w3")
+        
+        (ctree-set-calist-strictly
+         'mime-preview-condition
+         '((type . text)(subtype . html)
+           (body . visible)
+           (body-presentation-method . mime-preview-text/html)))
+        
+        (set-alist 'mime-view-type-subtype-score-alist
+                   '(text . html) 3)
+        )))
+
+
+;; for PGP
+(defvar mime-setup-enable-pgp t
+  "*If it is non-nil, semi-setup sets uf to use mime-pgp.")
+
+(if mime-setup-enable-pgp
+    (eval-after-load "mime-view"
+      '(progn
+        (mime-add-condition
+         'preview '((type . application)(subtype . pgp)
+                    (message-button . visible)))
+        (mime-add-condition
+         'action '((type . application)(subtype . pgp)
+                   (method . mime-view-application/pgp))
+         'strict "mime-pgp")
+        (mime-add-condition
+         'action '((type . text)(subtype . x-pgp)
+                   (method . mime-view-application/pgp)))
+        
+        (mime-add-condition
+         'action '((type . multipart)(subtype . signed)
+                   (method . mime-verify-multipart/signed))
+         'strict "mime-pgp")
+        
+        (mime-add-condition
+         'action
+         '((type . application)(subtype . pgp-signature)
+           (method . mime-verify-application/pgp-signature))
+         'strict "mime-pgp")
+        
+        (mime-add-condition
+         'action
+         '((type . application)(subtype . pgp-encrypted)
+           (method . mime-decrypt-application/pgp-encrypted))
+         'strict "mime-pgp")
+        
+        (mime-add-condition
+         'action
+         '((type . application)(subtype . pgp-keys)
+           (method . mime-add-application/pgp-keys))
+         'strict "mime-pgp")
+
+        (mime-add-condition
+         'action
+         '((type . application)(subtype . pkcs7-signature)
+           (method . mime-verify-application/pkcs7-signature))
+         'strict "mime-pgp")
+
+        (mime-add-condition
+         'action
+         '((type . application)(subtype . x-pkcs7-signature)
+           (method . mime-verify-application/pkcs7-signature))
+         'strict "mime-pgp")
+        
+        (mime-add-condition
+         'action
+         '((type . application)(subtype . pkcs7-mime)
+           (method . mime-view-application/pkcs7-mime))
+         'strict "mime-pgp")
+
+        (mime-add-condition
+         'action
+         '((type . application)(subtype . x-pkcs7-mime)
+           (method . mime-view-application/pkcs7-mime))
+         'strict "mime-pgp")
+        ))
+  )
+
+
+;;; @ for mime-edit
+;;;
+
+;; (defun mime-setup-decode-message-header ()
+;;   (save-excursion
+;;     (save-restriction
+;;       (goto-char (point-min))
+;;       (narrow-to-region
+;;        (point-min)
+;;        (if (re-search-forward
+;;             (concat "^" (regexp-quote mail-header-separator) "$")
+;;             nil t)
+;;            (match-beginning 0)
+;;          (point-max)
+;;          ))
+;;       (mime-decode-header-in-buffer)
+;;       (set-buffer-modified-p nil)
+;;       )))
+
+;; (add-hook 'mime-edit-mode-hook 'mime-setup-decode-message-header)
+
+
+;;; @@ variables
+;;;
+
+(defvar mime-setup-use-signature t
+  "If it is not nil, mime-setup sets up to use signature.el.")
+
+(defvar mime-setup-default-signature-key "\C-c\C-s"
+  "*Key to insert signature.")
+
+(defvar mime-setup-signature-key-alist '((mail-mode . "\C-c\C-w"))
+  "Alist of major-mode vs. key to insert signature.")
+
+
+;;; @@ for signature
+;;;
+
+(defun mime-setup-set-signature-key ()
+  (let ((keymap (current-local-map)))
+    (if keymap
+       (let ((key
+              (or (cdr (assq major-mode mime-setup-signature-key-alist))
+                  mime-setup-default-signature-key)))
+         (define-key keymap key (function insert-signature))
+         ))))
+
+(when mime-setup-use-signature
+  (autoload 'insert-signature "signature" "Insert signature" t)
+  (add-hook 'mime-edit-mode-hook 'mime-setup-set-signature-key)
+  ;; (setq message-signature nil)
+  )
+
+
+;;; @ for mu-cite
+;;;
+
+;; (add-hook 'mu-cite/pre-cite-hook 'eword-decode-header)
+
+
+;;; @ end
+;;;
+
+(provide 'semi-setup)
+
+;;; semi-setup.el ends here
diff --git a/mime/signature.el b/mime/signature.el
new file mode 100644 (file)
index 0000000..6bd81c3
--- /dev/null
@@ -0,0 +1,158 @@
+;;; signature.el --- a signature utility for GNU Emacs
+
+;; Copyright (C) 1994,1995,1996,1997,2000 Free Software Foundation, Inc.
+
+;; Author: MORIOKA Tomohiko <tomo@m17n.org>
+;;         OKABE Yasuo <okabe@kudpc.kyoto-u.ac.jp>
+;;         Shuhei KOBAYASHI <shuhei@aqua.ocn.ne.jp>
+;; Maintainer: Shuhei KOBAYASHI <shuhei@aqua.ocn.ne.jp>
+;; Created: 1994/7/11
+;; Keywords: mail, news, signature
+
+;; This file is part of SEMI (SEMI is Emacs MIME Interfaces).
+
+;; 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 this program; see the file COPYING.  If not, write to
+;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Code:
+
+(require 'std11)
+
+
+;;; @ valiables
+;;;
+
+(defvar signature-insert-at-eof nil
+  "*If non-nil, insert signature at the end of file.")
+
+(defvar signature-delete-blank-lines-at-eof nil
+  "*If non-nil, signature-insert-at-eof deletes blank lines at the end
+of file.")
+
+(defvar signature-load-hook nil
+  "*List of functions called after signature.el is loaded.")
+
+(defvar signature-separator "-- \n"
+  "*String to separate contents and signature.
+It is inserted when signature is inserted at end of file.")
+
+(defvar signature-file-name "~/.signature"
+  "*Name of file containing the user's signature.")
+
+(defvar signature-file-alist nil
+  "*Alist of the form:
+    (((FIELD . PATTERN) . FILENAME)
+     ...)
+PATTERN is a string or list of string. If PATTERN matches the contents of
+FIELD, the contents of FILENAME is inserted.")
+
+(defvar signature-file-prefix nil
+  "*String containing optional prefix for the signature file names")
+
+(defvar signature-insert-hook nil
+  "*List of functions called before inserting a signature.")
+
+(defvar signature-use-bbdb nil
+  "*If non-nil, Register sigtype to BBDB.")
+
+(autoload 'signature/get-sigtype-from-bbdb "mime-bbdb")
+
+(defun signature/get-sigtype-interactively (&optional default)
+  (read-file-name "Insert your signature: "
+                  (or default (concat signature-file-name "-"))
+                  (or default signature-file-name)
+                  nil))
+
+(defun signature/get-signature-file-name ()
+  (save-excursion
+    (save-restriction
+      (narrow-to-region
+       (goto-char (point-min))
+       (if (re-search-forward
+            (concat "^" (regexp-quote mail-header-separator) "$")
+            nil t)
+           (match-beginning 0)
+         (point-max)
+         ))
+      (catch 'found
+        (let ((alist signature-file-alist) cell field value)
+          (while alist
+            (setq cell  (car alist)
+                  field (std11-field-body (car (car cell)))
+                  value (cdr (car cell)))
+            (cond ((functionp value)
+                  (let ((name (apply value field (cdr cell))))
+                    (if name
+                        (throw 'found
+                               (concat signature-file-prefix name))
+                      )))
+                 ((stringp field)
+                  (cond ((consp value)
+                         (while value
+                           (if (string-match (car value) field)
+                               (throw 'found
+                                      (concat
+                                       signature-file-prefix (cdr cell)))
+                             (setq value (cdr value))
+                             )))
+                        ((stringp value)
+                         (if (string-match value field)
+                             (throw 'found
+                                    (concat
+                                     signature-file-prefix (cdr cell)))
+                           )))))
+            (setq alist (cdr alist))
+            ))
+        signature-file-name))))
+
+(defun insert-signature (&optional arg)
+  "Insert the file named by signature-file-name.
+It is inserted at the end of file if signature-insert-at-eof is non-nil,
+and otherwise at the current point.  A prefix argument enables user to
+specify a file named <signature-file-name>-DISTRIBUTION interactively."
+  (interactive "P")
+  (let ((signature-file-name
+         (expand-file-name
+          (or (and signature-use-bbdb
+                   (signature/get-sigtype-from-bbdb arg))
+              (and arg
+                   (signature/get-sigtype-interactively))
+              (signature/get-signature-file-name))
+          )))
+    (or (file-readable-p signature-file-name)
+        (error "Cannot open signature file: %s" signature-file-name))
+    (if signature-insert-at-eof
+        (progn
+          (goto-char (point-max))
+          (or (bolp) (insert "\n"))
+          (if signature-delete-blank-lines-at-eof (delete-blank-lines))
+          ))
+    (run-hooks 'signature-insert-hook)
+    (if (= (point)(point-max))
+       (insert signature-separator)
+      )
+    (insert-file-contents signature-file-name)
+    (force-mode-line-update)
+    signature-file-name))
+
+
+;;; @ end
+;;;
+
+(provide 'signature)
+
+(run-hooks 'signature-load-hook)
+
+;;; signature.el ends here
diff --git a/mime/smime.el b/mime/smime.el
new file mode 100644 (file)
index 0000000..839c715
--- /dev/null
@@ -0,0 +1,322 @@
+;;; smime.el --- S/MIME interface.
+
+;; Copyright (C) 1999 Daiki Ueno
+
+;; Author: Daiki Ueno <ueno@ueda.info.waseda.ac.jp>
+;; Created: 1999/12/08
+;; Keywords: S/MIME, OpenSSL
+
+;; This file is part of SEMI (Secure Emacs MIME Interface).
+
+;; 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:
+
+;;    This module is based on
+
+;;      [SMIMEV3] RFC 2633: "S/MIME Version 3 Message Specification"
+;;          by Crocker, D., Flanigan, B., Hoffman, P., Housley, R.,
+;;          Pawling, J. and Schaad, J. (1999/06)
+
+;;      [SMIMEV2] RFC 2311: "S/MIME Version 2 Message Specification"
+;;          by Dusse, S., Hoffman, P., Ramsdell, B., Lundblade, L.
+;;          and L. Repka. (1998/03)
+
+;;; Code:
+
+(require 'path-util)
+(require 'mel)
+;; binary-funcall, binary-write-decoded-region, binary-insert-encoded-file
+(eval-when-compile (require 'static))
+
+(defgroup smime ()
+  "S/MIME interface"
+  :group 'mime)
+
+(defcustom smime-program "smime" 
+  "The S/MIME executable."
+  :group 'smime
+  :type 'string)
+
+(defcustom smime-shell-file-name "/bin/sh"
+  "File name to load inferior shells from.  Bourne shell or its equivalent
+\(not tcsh) is needed for \"2>\"."
+  :group 'smime
+  :type 'string)
+
+(defcustom smime-shell-command-switch "-c"
+  "Switch used to have the shell execute its command line argument."
+  :group 'smime
+  :type 'string)
+
+(defcustom smime-x509-program
+  (let ((file (exec-installed-p "openssl")))
+    (and file (list file "x509" "-noout")))
+  "External program for x509 parser."
+  :group 'smime
+  :type 'string)
+
+(defcustom smime-cache-passphrase t
+  "Cache passphrase."
+  :group 'smime
+  :type 'boolean)
+
+(defcustom smime-certificate-directory "~/.w3/certs"
+  "Certificate directory."
+  :group 'smime
+  :type 'directory)
+
+(defcustom smime-public-key-file nil
+  "Public key file."
+  :group 'smime
+  :type 'boolean)
+
+(defcustom smime-private-key-file nil
+  "Private key file."
+  :group 'smime
+  :type 'boolean)
+
+(defvar smime-errors-buffer " *S/MIME errors*")
+(defvar smime-output-buffer " *S/MIME output*")
+
+;;; @ utility functions
+;;;
+(put 'smime-process-when-success 'lisp-indent-function 0)
+
+(defmacro smime-process-when-success (&rest body)
+  `(with-current-buffer smime-output-buffer
+     (if (zerop (buffer-size)) nil ,@body t)))
+
+(defvar smime-passphrase-cache-expiry 16)
+(defvar smime-passphrase-cache (make-vector 7 0))
+
+(defvar smime-read-passphrase nil)
+(defun smime-read-passphrase (prompt &optional key)
+  (if (not smime-read-passphrase)
+      (if (functionp 'read-passwd)
+         (setq smime-read-passphrase 'read-passwd)
+       (if (load "passwd" t)
+           (setq smime-read-passphrase 'read-passwd)
+         (autoload 'ange-ftp-read-passwd "ange-ftp")
+         (setq smime-read-passphrase 'ange-ftp-read-passwd))))
+  (or (and smime-cache-passphrase
+          (symbol-value (intern-soft key smime-passphrase-cache)))
+      (funcall smime-read-passphrase prompt)))
+
+(defun smime-add-passphrase-cache (key passphrase)
+  (set (intern key smime-passphrase-cache)
+       passphrase)
+  (run-at-time smime-passphrase-cache-expiry nil
+              #'smime-remove-passphrase-cache
+              key))
+
+(defun smime-remove-passphrase-cache (key)
+  (let ((passphrase (symbol-value (intern-soft key smime-passphrase-cache))))
+    (when passphrase
+      (fillarray passphrase ?_)
+      (unintern key smime-passphrase-cache))))
+
+(defsubst smime-parse-attribute (string)
+  (delq nil (mapcar 
+            (lambda (attr)
+              (if (string-match "=" attr)
+                  (cons (intern (substring attr 0 (match-beginning 0)))
+                        (substring attr (match-end 0)))
+                nil))
+            (split-string string "/"))))
+
+(defsubst smime-query-signer (start end)
+  (smime-process-region start end smime-program (list "-qs"))
+  (with-current-buffer smime-output-buffer
+    (if (zerop (buffer-size)) nil
+      (goto-char (point-min))
+      (when (re-search-forward "^/" nil t)
+       (smime-parse-attribute 
+        (buffer-substring (point) (progn (end-of-line)(point)))))
+      )))
+
+(defsubst smime-x509-hash (cert-file)
+  (with-current-buffer (get-buffer-create smime-output-buffer)
+    (buffer-disable-undo)
+    (erase-buffer)
+    (apply #'call-process (car smime-x509-program) nil t nil 
+          (append (cdr smime-x509-program) 
+                  (list "-hash" "-in" cert-file)))
+    (if (zerop (buffer-size)) nil
+      (buffer-substring (point-min) (1- (point-max))))))
+
+(defsubst smime-x509-subject (cert-file)
+  (with-current-buffer (get-buffer-create smime-output-buffer)
+    (buffer-disable-undo)
+    (erase-buffer)
+    (apply #'call-process (car smime-x509-program) nil t nil 
+          (append (cdr smime-x509-program)
+                  (list "-subject" "-in" cert-file)))
+    (if (zerop (buffer-size)) nil
+      (goto-char (point-min))
+      (when (re-search-forward "^subject=" nil t)
+       (smime-parse-attribute
+        (buffer-substring (point)(progn (end-of-line)(point))))))))
+
+(defsubst smime-find-certificate (attr)
+  (let ((files
+        (and (file-directory-p smime-certificate-directory)
+             (delq nil (mapcar (lambda (file) 
+                                 (if (file-directory-p file) nil
+                                   file))
+                               (directory-files 
+                                smime-certificate-directory
+                                'full))))))
+    (catch 'found
+      (while files
+       (if (or (string-equal 
+                (cdr (assq 'CN (smime-x509-subject (car files))))
+                (cdr (assq 'CN attr)))
+               (string-equal
+                (cdr (assq 'Email (smime-x509-subject (car files))))
+                (cdr (assq 'Email attr))))
+           (throw 'found (car files)))
+       (pop files)))))
+
+(defun smime-process-region (start end program args)
+  (let* ((errors-file-name
+         (concat temporary-file-directory 
+                 (make-temp-name "smime-errors")))
+        (args (append args (list (concat "2>" errors-file-name))))
+        (shell-file-name smime-shell-file-name)
+        (shell-command-switch smime-shell-command-switch)
+        (process-connection-type nil)
+        process status exit-status)
+    (with-current-buffer (get-buffer-create smime-output-buffer)
+      (buffer-disable-undo)
+      (erase-buffer))
+    (setq process
+         (apply #'binary-funcall #'start-process-shell-command
+                "*S/MIME*" smime-output-buffer
+                program args))
+    (set-process-sentinel process 'ignore)
+    (process-send-region process start end)
+    (process-send-eof process)
+    (while (eq 'run (process-status process))
+      (accept-process-output process 5))
+    (setq status (process-status process)
+         exit-status (process-exit-status process))
+    (delete-process process)
+    (with-current-buffer smime-output-buffer
+      (goto-char (point-min))
+      (while (re-search-forward "\r$" (point-max) t)
+       (replace-match ""))
+
+      (if (memq status '(stop signal))
+         (error "%s exited abnormally: '%s'" program exit-status))
+      (if (= 127 exit-status)
+         (error "%s could not be found" program))
+
+      (set-buffer (get-buffer-create smime-errors-buffer))
+      (buffer-disable-undo)
+      (erase-buffer)
+      (insert-file-contents errors-file-name)
+      (delete-file errors-file-name)
+      
+      (if (and process (eq 'run (process-status process)))
+         (interrupt-process process))
+      )
+    ))
+
+;;; @ interface functions
+;;;
+
+;;;###autoload
+(defun smime-encrypt-region (start end)
+  "Encrypt the current region between START and END."
+  (let* ((key-file
+         (or smime-private-key-file
+             (expand-file-name (read-file-name "Public key file: "))))
+        (args (list "-e" key-file)))
+    (smime-process-region start end smime-program args)
+    (smime-process-when-success 
+      (goto-char (point-min))
+      (delete-region (point-min) (progn
+                                  (re-search-forward "^$" nil t)
+                                  (1+ (point)))))))
+
+;;;###autoload
+(defun smime-decrypt-region (start end)
+  "Decrypt the current region between START and END."
+  (let* ((key-file
+         (or smime-private-key-file
+             (expand-file-name (read-file-name "Private key file: "))))
+        (hash (smime-x509-hash key-file))
+        (passphrase (smime-read-passphrase 
+                     (format "S/MIME passphrase for %s: " hash)
+                     hash))
+        (args (list "-d" key-file passphrase)))
+    (smime-process-region start end smime-program args)
+    (smime-process-when-success 
+      (when smime-cache-passphrase
+       (smime-add-passphrase-cache hash passphrase)))))
+        
+;;;###autoload
+(defun smime-sign-region (start end &optional cleartext)
+  "Make the signature from text between START and END.
+If the optional 3rd argument CLEARTEXT is non-nil, it does not create
+a detached signature."
+  (let* ((key-file
+         (or smime-private-key-file
+             (expand-file-name (read-file-name "Private key file: "))))
+        (hash (smime-x509-hash key-file))
+        (passphrase (smime-read-passphrase 
+                     (format "S/MIME passphrase for %s: " hash)
+                     hash))
+        (args (list "-ds" key-file passphrase)))
+    (smime-process-region start end smime-program args)
+    (smime-process-when-success 
+      (goto-char (point-min))
+      (delete-region (point-min) (progn
+                                  (re-search-forward "^$" nil t)
+                                  (1+ (point))))
+      (when smime-cache-passphrase
+       (smime-add-passphrase-cache hash passphrase)))))
+
+;;;###autoload
+(defun smime-verify-region (start end signature)
+  "Verify the current region between START and END.
+If the optional 3rd argument SIGNATURE is non-nil, it is treated as
+the detached signature of the current region."
+  (let* ((basename (expand-file-name "smime" temporary-file-directory))
+        (orig-file (make-temp-name basename))
+        (orig-mode (default-file-modes)))
+    (unwind-protect
+       (progn
+         (set-default-file-modes 448)
+         (binary-write-decoded-region start end orig-file))
+      (set-default-file-modes orig-mode))
+    (with-temp-buffer
+      (binary-insert-encoded-file signature)
+      (goto-char (point-max))
+      (binary-insert-encoded-file
+       (or (smime-find-certificate 
+           (smime-query-signer (point-min)(point-max)))
+          (expand-file-name 
+           (read-file-name "Certificate file: "))))
+      (smime-process-region (point-min)(point-max) smime-program 
+                           (list "-dv" orig-file)))
+    (smime-process-when-success nil)))
+
+(provide 'smime)
+
+;;; smime.el ends here
diff --git a/mime/std11.el b/mime/std11.el
new file mode 100644 (file)
index 0000000..051d45a
--- /dev/null
@@ -0,0 +1,925 @@
+;;; std11.el --- STD 11 functions for GNU Emacs
+
+;; Copyright (C) 1995,1996,1997,1998,1999,2000 Free Software Foundation, Inc.
+
+;; Author:   MORIOKA Tomohiko <tomo@m17n.org>
+;; Keywords: mail, news, RFC 822, STD 11
+
+;; This file is part of FLIM (Faithful Library about Internet Message).
+
+;; 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.
+
+;;; Code:
+
+(require 'custom)                      ; std11-lexical-analyzer
+
+
+;;; @ fetch
+;;;
+
+(defconst std11-field-name-regexp "[!-9;-~]+")
+(defconst std11-field-head-regexp
+  (concat "^" std11-field-name-regexp ":"))
+(defconst std11-next-field-head-regexp
+  (concat "\n" std11-field-name-regexp ":"))
+
+(defun std11-field-end (&optional bound)
+  "Move to end of field and return this point.
+The optional argument BOUNDs the search; it is a buffer position."
+  (if (re-search-forward std11-next-field-head-regexp bound t)
+      (goto-char (match-beginning 0))
+    (if (re-search-forward "^$" bound t)
+       (goto-char (1- (match-beginning 0)))
+      (end-of-line)
+      ))
+  (point)
+  )
+
+;;;###autoload
+(defun std11-fetch-field (name)
+  "Return the value of the header field NAME.
+The buffer is expected to be narrowed to just the headers of the message."
+  (save-excursion
+    (goto-char (point-min))
+    (let ((case-fold-search t))
+      (if (re-search-forward (concat "^" name ":[ \t]*") nil t)
+         (buffer-substring-no-properties (match-end 0) (std11-field-end))
+       ))))
+
+;;;###autoload
+(defun std11-narrow-to-header (&optional boundary)
+  "Narrow to the message header.
+If BOUNDARY is not nil, it is used as message header separator."
+  (narrow-to-region
+   (goto-char (point-min))
+   (if (re-search-forward
+       (concat "^\\(" (regexp-quote (or boundary "")) "\\)?$")
+       nil t)
+       (match-beginning 0)
+     (point-max)
+     )))
+
+;;;###autoload
+(defun std11-field-body (name &optional boundary)
+  "Return the value of the header field NAME.
+If BOUNDARY is not nil, it is used as message header separator."
+  (save-excursion
+    (save-restriction
+      (inline (std11-narrow-to-header boundary)
+             (std11-fetch-field name))
+      )))
+
+(defun std11-find-field-body (field-names &optional boundary)
+  "Return the first found field-body specified by FIELD-NAMES
+of the message header in current buffer. If BOUNDARY is not nil, it is
+used as message header separator."
+  (save-excursion
+    (save-restriction
+      (std11-narrow-to-header boundary)
+      (let ((case-fold-search t)
+           field-name)
+       (catch 'tag
+         (while (setq field-name (car field-names))
+           (goto-char (point-min))
+           (if (re-search-forward (concat "^" field-name ":[ \t]*") nil t)
+               (throw 'tag
+                      (buffer-substring-no-properties
+                       (match-end 0) (std11-field-end)))
+             )
+           (setq field-names (cdr field-names))
+           ))))))
+
+(defun std11-field-bodies (field-names &optional default-value boundary)
+  "Return list of each field-bodies of FIELD-NAMES of the message header
+in current buffer. If BOUNDARY is not nil, it is used as message
+header separator."
+  (save-excursion
+    (save-restriction
+      (std11-narrow-to-header boundary)
+      (let* ((case-fold-search t)
+            (dest (make-list (length field-names) default-value))
+            (s-rest field-names)
+            (d-rest dest)
+            field-name)
+       (while (setq field-name (car s-rest))
+         (goto-char (point-min))
+         (if (re-search-forward (concat "^" field-name ":[ \t]*") nil t)
+             (setcar d-rest
+                     (buffer-substring-no-properties
+                      (match-end 0) (std11-field-end)))
+           )
+         (setq s-rest (cdr s-rest)
+               d-rest (cdr d-rest))
+         )
+       dest))))
+
+(defun std11-header-string (regexp &optional boundary)
+  "Return string of message header fields matched by REGEXP.
+If BOUNDARY is not nil, it is used as message header separator."
+  (let ((case-fold-search t))
+    (save-excursion
+      (save-restriction
+       (std11-narrow-to-header boundary)
+       (goto-char (point-min))
+       (let (field header)
+         (while (re-search-forward std11-field-head-regexp nil t)
+           (setq field
+                 (buffer-substring (match-beginning 0) (std11-field-end)))
+           (if (string-match regexp field)
+               (setq header (concat header field "\n"))
+             ))
+         header)
+       ))))
+
+(defun std11-header-string-except (regexp &optional boundary)
+  "Return string of message header fields not matched by REGEXP.
+If BOUNDARY is not nil, it is used as message header separator."
+  (let ((case-fold-search t))
+    (save-excursion
+      (save-restriction
+       (std11-narrow-to-header boundary)
+       (goto-char (point-min))
+       (let (field header)
+         (while (re-search-forward std11-field-head-regexp nil t)
+           (setq field
+                 (buffer-substring (match-beginning 0) (std11-field-end)))
+           (if (not (string-match regexp field))
+               (setq header (concat header field "\n"))
+             ))
+         header)
+       ))))
+
+(defun std11-collect-field-names (&optional boundary)
+  "Return list of all field-names of the message header in current buffer.
+If BOUNDARY is not nil, it is used as message header separator."
+  (save-excursion
+    (save-restriction
+      (std11-narrow-to-header boundary)
+      (goto-char (point-min))
+      (let (dest name)
+       (while (re-search-forward std11-field-head-regexp nil t)
+         (setq name (buffer-substring-no-properties
+                     (match-beginning 0)(1- (match-end 0))))
+         (or (member name dest)
+             (setq dest (cons name dest))
+             )
+         )
+       dest))))
+
+
+;;; @ unfolding
+;;;
+
+;;;###autoload
+(defun std11-unfold-string (string)
+  "Unfold STRING as message header field."
+  (let ((dest "")
+       (p 0))
+    (while (string-match "\n\\([ \t]\\)" string p)
+      (setq dest (concat dest
+                         (substring string p (match-beginning 0))
+                         (substring string
+                                   (match-beginning 1)
+                                   (setq p (match-end 0)))
+                         ))
+      )
+    (concat dest (substring string p))
+    ))
+
+
+;;; @ quoted-string
+;;;
+
+(defun std11-wrap-as-quoted-pairs (string specials)
+  (let (dest
+       (i 0)
+       (b 0)
+       (len (length string))
+       )
+    (while (< i len)
+      (let ((chr (aref string i)))
+       (if (memq chr specials)
+           (setq dest (concat dest (substring string b i) "\\")
+                 b i)
+         ))
+      (setq i (1+ i))
+      )
+    (concat dest (substring string b))
+    ))
+
+(defconst std11-non-qtext-char-list '(?\" ?\\ ?\r ?\n))
+
+(defun std11-wrap-as-quoted-string (string)
+  "Wrap STRING as RFC 822 quoted-string."
+  (concat "\""
+         (std11-wrap-as-quoted-pairs string std11-non-qtext-char-list)
+         "\""))
+
+(defun std11-strip-quoted-pair (string)
+  "Strip quoted-pairs in STRING."
+  (let (dest
+       (b 0)
+       (i 0)
+       (len (length string))
+       )
+    (while (< i len)
+      (let ((chr (aref string i)))
+       (if (eq chr ?\\)
+           (setq dest (concat dest (substring string b i))
+                 b (1+ i)
+                 i (+ i 2))
+         (setq i (1+ i))
+         )))
+    (concat dest (substring string b))
+    ))
+
+(defun std11-strip-quoted-string (string)
+  "Strip quoted-string STRING."
+  (let ((len (length string)))
+    (or (and (>= len 2)
+            (let ((max (1- len)))
+              (and (eq (aref string 0) ?\")
+                   (eq (aref string max) ?\")
+                   (std11-strip-quoted-pair (substring string 1 max))
+                   )))
+       string)))
+
+
+;;; @ lexical analyze
+;;;
+
+(defcustom std11-lexical-analyzer
+  '(std11-analyze-quoted-string
+    std11-analyze-domain-literal
+    std11-analyze-comment
+    std11-analyze-spaces
+    std11-analyze-special
+    std11-analyze-atom)
+  "*List of functions to return result of lexical analyze.
+Each function must have two arguments: STRING and START.
+STRING is the target string to be analyzed.
+START is start position of STRING to analyze.
+
+Previous function is preferred to next function.  If a function
+returns nil, next function is used.  Otherwise the return value will
+be the result."
+  :group 'news
+  :group 'mail
+  :type '(repeat function))
+
+(eval-and-compile
+  (defconst std11-space-char-list '(?  ?\t ?\n))
+  (defconst std11-special-char-list '(?\] ?\[
+                                         ?\( ?\) ?< ?> ?@
+                                         ?, ?\; ?: ?\\ ?\"
+                                         ?.))
+  )
+;; (defconst std11-spaces-regexp
+;;   (eval-when-compile (concat "[" std11-space-char-list "]+")))
+(defconst std11-atom-regexp
+  (eval-when-compile
+    (concat "[^" std11-special-char-list std11-space-char-list "]+")))
+
+(defun std11-analyze-spaces (string start)
+  (if (and (string-match (eval-when-compile
+                          (concat "[" std11-space-char-list "]+"))
+                        string start)
+          (= (match-beginning 0) start))
+      (let ((end (match-end 0)))
+       (cons (cons 'spaces (substring string start end))
+             ;;(substring string end)
+             end)
+       )))
+
+(defun std11-analyze-special (string start)
+  (if (and (> (length string) start)
+          (memq (aref string start) std11-special-char-list))
+      (cons (cons 'specials (substring string start (1+ start)))
+           ;;(substring string 1)
+           (1+ start))
+    ))
+
+(defun std11-analyze-atom (string start)
+  (if (and (string-match std11-atom-regexp string start)
+          (= (match-beginning 0) start))
+      (let ((end (match-end 0)))
+       (cons (cons 'atom (substring string start end))
+             ;;(substring string end)
+             end)
+       )))
+
+(defun std11-check-enclosure (string open close &optional recursive from)
+  (let ((len (length string))
+       (i (or from 0))
+       )
+    (if (and (> len i)
+            (eq (aref string i) open))
+       (let (p chr)
+         (setq i (1+ i))
+         (catch 'tag
+           (while (< i len)
+             (setq chr (aref string i))
+             (cond ((eq chr ?\\)
+                    (setq i (1+ i))
+                    (if (>= i len)
+                        (throw 'tag nil)
+                      )
+                    (setq i (1+ i))
+                    )
+                   ((eq chr close)
+                    (throw 'tag (1+ i))
+                    )
+                   ((eq chr open)
+                    (if (and recursive
+                             (setq p (std11-check-enclosure
+                                      string open close recursive i))
+                             )
+                        (setq i p)
+                      (throw 'tag nil)
+                      ))
+                   (t
+                    (setq i (1+ i))
+                    ))
+             ))))))
+
+(defun std11-analyze-quoted-string (string start)
+  (let ((p (std11-check-enclosure string ?\" ?\" nil start)))
+    (if p
+       (cons (cons 'quoted-string (substring string (1+ start) (1- p)))
+             ;;(substring string p))
+             p)
+      )))
+
+(defun std11-analyze-domain-literal (string start)
+  (let ((p (std11-check-enclosure string ?\[ ?\] nil start)))
+    (if p
+       (cons (cons 'domain-literal (substring string (1+ start) (1- p)))
+             ;;(substring string p))
+             p)
+      )))
+
+(defun std11-analyze-comment (string start)
+  (let ((p (std11-check-enclosure string ?\( ?\) t start)))
+    (if p
+       (cons (cons 'comment (substring string (1+ start) (1- p)))
+             ;;(substring string p))
+             p)
+      )))
+
+;;;###autoload
+(defun std11-lexical-analyze (string &optional analyzer start)
+  "Analyze STRING as lexical tokens of STD 11."
+  (or analyzer
+      (setq analyzer std11-lexical-analyzer))
+  (or start
+      (setq start 0))
+  (let ((len (length string))
+       dest ret)
+    (while (< start len)
+      (setq ret
+           (let ((rest analyzer)
+                 func r)
+             (while (and (setq func (car rest))
+                         (null (setq r (funcall func string start))))
+               (setq rest (cdr rest)))
+             (or r
+                 (list (cons 'error (substring string start)) (1+ len)))
+             ))
+      (setq dest (cons (car ret) dest)
+           start (cdr ret))
+      )
+    (nreverse dest)
+    ))
+
+
+;;; @ parser
+;;;
+
+(defun std11-ignored-token-p (token)
+  (let ((type (car token)))
+    (or (eq type 'spaces)(eq type 'comment))
+    ))
+
+(defun std11-parse-token (lal)
+  (let (token itl)
+    (while (and lal
+               (progn
+                 (setq token (car lal))
+                 (std11-ignored-token-p token)
+                 ))
+      (setq lal (cdr lal))
+      (setq itl (cons token itl))
+      )
+    (cons (nreverse (cons token itl))
+         (cdr lal))
+    ))
+
+(defun std11-parse-ascii-token (lal)
+  (let (token itl parsed token-value)
+    (while (and lal
+               (setq token (car lal))
+               (or (std11-ignored-token-p token)
+                   (if (and (setq token-value (cdr token))
+                            (delq 'ascii (find-charset-string token-value)))
+                       (setq token nil)
+                     )))
+      (setq lal (cdr lal))
+      (setq itl (cons token itl))
+      )
+    (if (and token
+            (setq parsed (nreverse (cons token itl)))
+            )
+       (cons parsed (cdr lal))
+      )))
+
+(defun std11-parse-token-or-comment (lal)
+  (let (token itl)
+    (while (and lal
+               (progn
+                 (setq token (car lal))
+                 (eq (car token) 'spaces)
+                 ))
+      (setq lal (cdr lal))
+      (setq itl (cons token itl))
+      )
+    (cons (nreverse (cons token itl))
+         (cdr lal))
+    ))
+
+(defun std11-parse-word (lal)
+  (let ((ret (std11-parse-ascii-token lal)))
+    (if ret
+       (let ((elt (car ret))
+             (rest (cdr ret))
+             )
+         (if (or (assq 'atom elt)
+                 (assq 'quoted-string elt))
+             (cons (cons 'word elt) rest)
+           )))))
+
+(defun std11-parse-word-or-comment (lal)
+  (let ((ret (std11-parse-token-or-comment lal)))
+    (if ret
+       (let ((elt (car ret))
+             (rest (cdr ret))
+             )
+         (cond ((or (assq 'atom elt)
+                    (assq 'quoted-string elt))
+                (cons (cons 'word elt) rest)
+                )
+               ((assq 'comment elt)
+                (cons (cons 'comment-word elt) rest)
+                ))
+         ))))
+
+(defun std11-parse-phrase (lal)
+  (let (ret phrase)
+    (while (setq ret (std11-parse-word-or-comment lal))
+      (setq phrase (append phrase (cdr (car ret))))
+      (setq lal (cdr ret))
+      )
+    (if phrase
+       (cons (cons 'phrase phrase) lal)
+      )))
+
+(defun std11-parse-local-part (lal)
+  (let ((ret (std11-parse-word lal)))
+    (if ret
+       (let ((local-part (cdr (car ret))) dot)
+         (setq lal (cdr ret))
+         (while (and (setq ret (std11-parse-ascii-token lal))
+                     (setq dot (car ret))
+                     (string-equal (cdr (assq 'specials dot)) ".")
+                     (setq ret (std11-parse-word (cdr ret)))
+                     (setq local-part
+                           (append local-part dot (cdr (car ret)))
+                           )
+                     (setq lal (cdr ret))
+                     ))
+         (cons (cons 'local-part local-part) lal)
+         ))))
+
+(defun std11-parse-sub-domain (lal)
+  (let ((ret (std11-parse-ascii-token lal)))
+    (if ret
+       (let ((sub-domain (car ret)))
+         (if (or (assq 'atom sub-domain)
+                 (assq 'domain-literal sub-domain)
+                 )
+             (cons (cons 'sub-domain sub-domain)
+                   (cdr ret)
+                   )
+           )))))
+
+(defun std11-parse-domain (lal)
+  (let ((ret (std11-parse-sub-domain lal)))
+    (if ret
+       (let ((domain (cdr (car ret))) dot)
+         (setq lal (cdr ret))
+         (while (and (setq ret (std11-parse-ascii-token lal))
+                     (setq dot (car ret))
+                     (string-equal (cdr (assq 'specials dot)) ".")
+                     (setq ret (std11-parse-sub-domain (cdr ret)))
+                     (setq domain
+                           (append domain dot (cdr (car ret)))
+                           )
+                     (setq lal (cdr ret))
+                     ))
+         (cons (cons 'domain domain) lal)
+         ))))
+
+(defun std11-parse-at-domain (lal)
+  (let ((ret (std11-parse-ascii-token lal)) at-sign)
+    (if (and ret
+            (setq at-sign (car ret))
+            (string-equal (cdr (assq 'specials at-sign)) "@")
+            (setq ret (std11-parse-domain (cdr ret)))
+            )
+       (cons (cons 'at-domain (append at-sign (cdr (car ret))))
+             (cdr ret))
+      )))
+
+(defun std11-parse-addr-spec (lal)
+  (let ((ret (std11-parse-local-part lal))
+       addr)
+    (if (and ret
+            (prog1
+                (setq addr (cdr (car ret)))
+              (setq lal (cdr ret))
+              (and (setq ret (std11-parse-at-domain lal))
+                   (setq addr (append addr (cdr (car ret))))
+                   (setq lal (cdr ret))
+                   )))
+       (cons (cons 'addr-spec addr) lal)
+      )))
+
+(defun std11-parse-route (lal)
+  (let ((ret (std11-parse-at-domain lal))
+       route comma colon)
+    (if (and ret
+            (progn
+              (setq route (cdr (car ret)))
+              (setq lal (cdr ret))
+              (while (and (setq ret (std11-parse-ascii-token lal))
+                          (setq comma (car ret))
+                          (string-equal (cdr (assq 'specials comma)) ",")
+                          (setq ret (std11-parse-at-domain (cdr ret)))
+                          )
+                (setq route (append route comma (cdr (car ret))))
+                (setq lal (cdr ret))
+                )
+              (and (setq ret (std11-parse-ascii-token lal))
+                   (setq colon (car ret))
+                   (string-equal (cdr (assq 'specials colon)) ":")
+                   (setq route (append route colon))
+                   )
+              ))
+       (cons (cons 'route route)
+             (cdr ret)
+             )
+      )))
+
+(defun std11-parse-route-addr (lal)
+  (let ((ret (std11-parse-ascii-token lal))
+       < route addr-spec >)
+    (if (and ret
+            (setq < (car ret))
+            (string-equal (cdr (assq 'specials <)) "<")
+            (setq lal (cdr ret))
+            (progn (and (setq ret (std11-parse-route lal))
+                        (setq route (cdr (car ret)))
+                        (setq lal (cdr ret))
+                        )
+                   (setq ret (std11-parse-addr-spec lal))
+                   )
+            (setq addr-spec (cdr (car ret)))
+            (setq lal (cdr ret))
+            (setq ret (std11-parse-ascii-token lal))
+            (setq > (car ret))
+            (string-equal (cdr (assq 'specials >)) ">")
+            )
+       (cons (cons 'route-addr (append route addr-spec))
+             (cdr ret)
+             )
+      )))
+
+(defun std11-parse-phrase-route-addr (lal)
+  (let ((ret (std11-parse-phrase lal)) phrase)
+    (if ret
+       (progn
+         (setq phrase (cdr (car ret)))
+         (setq lal (cdr ret))
+         ))
+    (if (setq ret (std11-parse-route-addr lal))
+       (cons (list 'phrase-route-addr
+                   phrase
+                   (cdr (car ret)))
+             (cdr ret))
+      )))
+
+(defun std11-parse-mailbox (lal)
+  (let ((ret (or (std11-parse-phrase-route-addr lal)
+                (std11-parse-addr-spec lal)))
+       mbox comment)
+    (if (and ret
+            (prog1
+                (setq mbox (car ret))
+              (setq lal (cdr ret))
+              (if (and (setq ret (std11-parse-token-or-comment lal))
+                       (setq comment (cdr (assq 'comment (car ret))))
+                       )
+                  (setq lal (cdr ret))
+                )))
+       (cons (list 'mailbox mbox comment)
+             lal)
+      )))
+
+(defun std11-parse-group (lal)
+  (let ((ret (std11-parse-phrase lal))
+       phrase colon comma mbox semicolon)
+    (if (and ret
+            (setq phrase (cdr (car ret)))
+            (setq lal (cdr ret))
+            (setq ret (std11-parse-ascii-token lal))
+            (setq colon (car ret))
+            (string-equal (cdr (assq 'specials colon)) ":")
+            (setq lal (cdr ret))
+            (progn
+              (and (setq ret (std11-parse-mailbox lal))
+                   (setq mbox (list (car ret)))
+                   (setq lal (cdr ret))
+                   (progn
+                     (while (and (setq ret (std11-parse-ascii-token lal))
+                                 (setq comma (car ret))
+                                 (string-equal
+                                  (cdr (assq 'specials comma)) ",")
+                                 (setq lal (cdr ret))
+                                 (setq ret (std11-parse-mailbox lal))
+                                 (setq mbox (cons (car ret) mbox))
+                                 (setq lal (cdr ret))
+                                 )
+                       )))
+              (and (setq ret (std11-parse-ascii-token lal))
+                   (setq semicolon (car ret))
+                   (string-equal (cdr (assq 'specials semicolon)) ";")
+                   )))
+       (cons (list 'group phrase (nreverse mbox))
+             (cdr ret)
+             )
+      )))
+
+(defun std11-parse-address (lal)
+  (or (std11-parse-group lal)
+      (std11-parse-mailbox lal)
+      ))
+
+(defun std11-parse-addresses (lal)
+  (let ((ret (std11-parse-address lal)))
+    (if ret
+       (let ((dest (list (car ret))))
+         (setq lal (cdr ret))
+         (while (and (setq ret (std11-parse-ascii-token lal))
+                     (string-equal (cdr (assq 'specials (car ret))) ",")
+                     (setq ret (std11-parse-address (cdr ret)))
+                     )
+           (setq dest (cons (car ret) dest))
+           (setq lal (cdr ret))
+           )
+         (nreverse dest)
+         ))))
+
+(defun std11-parse-msg-id (lal)
+  (let ((ret (std11-parse-ascii-token lal))
+       < addr-spec >)
+    (if (and ret
+            (setq < (car ret))
+            (string-equal (cdr (assq 'specials <)) "<")
+            (setq lal (cdr ret))
+            (setq ret (std11-parse-addr-spec lal))
+            (setq addr-spec (car ret))
+            (setq lal (cdr ret))
+            (setq ret (std11-parse-ascii-token lal))
+            (setq > (car ret))
+            (string-equal (cdr (assq 'specials >)) ">")
+            )
+       (cons (cons 'msg-id (cdr addr-spec))
+             (cdr ret))
+      )))
+
+(defun std11-parse-msg-ids (tokens)
+  "Parse lexical TOKENS as `*(phrase / msg-id)', and return the result."
+  (let ((ret (or (std11-parse-msg-id tokens)
+                (std11-parse-phrase tokens))))
+    (if ret
+       (let ((dest (list (car ret))))
+         (setq tokens (cdr ret))
+         (while (setq ret (or (std11-parse-msg-id tokens)
+                              (std11-parse-phrase tokens)))
+           (setq dest (cons (car ret) dest))
+           (setq tokens (cdr ret))
+           )
+         (nreverse dest)
+         ))))
+
+(defalias 'std11-parse-in-reply-to 'std11-parse-msg-ids)
+(make-obsolete 'std11-parse-in-reply-to 'std11-parse-msg-ids)
+
+
+;;; @ composer
+;;;
+
+(defun std11-addr-to-string (seq)
+  "Return string from lexical analyzed list SEQ
+represents addr-spec of RFC 822."
+  (mapconcat (function
+             (lambda (token)
+               (let ((name (car token)))
+                  (cond
+                   ((eq name 'spaces) "")
+                   ((eq name 'comment) "")
+                   ((eq name 'quoted-string)
+                    (concat "\"" (cdr token) "\""))
+                   (t (cdr token)))
+                  )))
+            seq "")
+  )
+
+;;;###autoload
+(defun std11-address-string (address)
+  "Return string of address part from parsed ADDRESS of RFC 822."
+  (cond ((eq (car address) 'group)
+        (mapconcat (function std11-address-string)
+                   (nth 2 address)
+                   ", ")
+        )
+       ((eq (car address) 'mailbox)
+        (let ((addr (nth 1 address)))
+          (std11-addr-to-string
+           (if (eq (car addr) 'phrase-route-addr)
+               (nth 2 addr)
+             (cdr addr)
+             )
+           )))))
+
+(defun std11-comment-value-to-string (value)
+  (if (stringp value)
+      (std11-strip-quoted-pair value)
+    (let ((dest ""))
+      (while value
+       (setq dest
+             (concat dest
+                     (if (stringp (car value))
+                         (car value)
+                       (concat "("
+                               (std11-comment-value-to-string
+                                (cdr (car value)))
+                               ")")
+                       ))
+             value (cdr value))
+       )
+      dest)))
+
+;;;###autoload
+(defun std11-full-name-string (address)
+  "Return string of full-name part from parsed ADDRESS of RFC 822."
+  (cond ((eq (car address) 'group)
+        (mapconcat (function
+                    (lambda (token)
+                      (cdr token)
+                      ))
+                   (nth 1 address) "")
+        )
+       ((eq (car address) 'mailbox)
+        (let ((addr (nth 1 address))
+              (comment (nth 2 address))
+              phrase)
+          (if (eq (car addr) 'phrase-route-addr)
+              (setq phrase
+                    (mapconcat
+                     (function
+                      (lambda (token)
+                        (let ((type (car token)))
+                          (cond ((eq type 'quoted-string)
+                                 (std11-strip-quoted-pair (cdr token))
+                                 )
+                                ((eq type 'comment)
+                                 (concat "("
+                                         (std11-comment-value-to-string
+                                          (cdr token))
+                                         ")")
+                                 )
+                                (t
+                                 (cdr token)
+                                 )))))
+                     (nth 1 addr) ""))
+            )
+          (cond ((> (length phrase) 0) phrase)
+                (comment (std11-comment-value-to-string comment))
+                )
+          ))))
+
+;;;###autoload
+(defun std11-msg-id-string (msg-id)
+  "Return string from parsed MSG-ID of RFC 822."
+  (concat "<" (std11-addr-to-string (cdr msg-id)) ">")
+  )
+
+;;;###autoload
+(defun std11-fill-msg-id-list-string (string &optional column)
+  "Fill list of msg-id in STRING, and return the result."
+  (or column
+      (setq column 12))
+  (let ((lal (std11-lexical-analyze string))
+       dest)
+    (let ((ret (std11-parse-msg-id lal)))
+      (if ret
+         (let* ((str (std11-msg-id-string (car ret)))
+                (len (length str)))
+           (setq lal (cdr ret))
+           (if (> (+ len column) 76)
+               (setq dest (concat dest "\n " str)
+                     column (1+ len))
+             (setq dest str
+                   column (+ column len))
+             ))
+       (setq dest (concat dest (cdr (car lal)))
+             lal (cdr lal))
+       ))
+    (while lal
+      (let ((ret (std11-parse-msg-id lal)))
+       (if ret
+           (let* ((str (std11-msg-id-string (car ret)))
+                  (len (1+ (length str))))
+             (setq lal (cdr ret))
+             (if (> (+ len column) 76)
+                 (setq dest (concat dest "\n " str)
+                       column len)
+               (setq dest (concat dest " " str)
+                     column (+ column len))
+               ))
+         (setq dest (concat dest (cdr (car lal)))
+               lal (cdr lal))
+         )))
+    dest))
+
+
+;;; @ parser with lexical analyzer
+;;;
+
+;;;###autoload
+(defun std11-parse-address-string (string)
+  "Parse STRING as mail address."
+  (std11-parse-address (std11-lexical-analyze string))
+  )
+
+;;;###autoload
+(defun std11-parse-addresses-string (string)
+  "Parse STRING as mail address list."
+  (std11-parse-addresses (std11-lexical-analyze string))
+  )
+
+;;;###autoload
+(defun std11-parse-msg-id-string (string)
+  "Parse STRING as msg-id."
+  (std11-parse-msg-id (std11-lexical-analyze string))
+  )
+
+;;;###autoload
+(defun std11-parse-msg-ids-string (string)
+  "Parse STRING as `*(phrase / msg-id)'."
+  (std11-parse-msg-ids (std11-lexical-analyze string))
+  )
+
+;;;###autoload
+(defun std11-extract-address-components (string)
+  "Extract full name and canonical address from STRING.
+Returns a list of the form (FULL-NAME CANONICAL-ADDRESS).
+If no name can be extracted, FULL-NAME will be nil."
+  (let* ((structure (car (std11-parse-address-string
+                         (std11-unfold-string string))))
+         (phrase  (std11-full-name-string structure))
+         (address (std11-address-string structure))
+         )
+    (list phrase address)
+    ))
+
+
+;;; @ end
+;;;
+
+(provide 'std11)
+
+;;; std11.el ends here
diff --git a/poe/apel-ver.el b/poe/apel-ver.el
new file mode 100644 (file)
index 0000000..93d09ca
--- /dev/null
@@ -0,0 +1,58 @@
+;;; apel-ver.el --- Declare APEL version.
+
+;; Copyright (C) 1999 Free Software Foundation, Inc.
+
+;; Author: Shuhei KOBAYASHI <shuhei@aqua.ocn.ne.jp>
+;;     Keiichi Suzuki <keiichi@nanap.org>
+;; Keywords: compatibility
+
+;; This file is part of APEL (A Portable Emacs Library).
+
+;; 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 this program; see the file COPYING.  If not, write to
+;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Commentary:
+
+;; Put the following lines to each file of APEL package.
+;;
+;; (require 'product)
+;; (product-provide (provide FEATURE) (require 'apel-ver))
+
+;;; Code:
+
+(require 'product)                     ; beware of circular dependency.
+(provide 'apel-ver)                    ; these two files depend on each other.
+
+(product-provide 'apel-ver
+  ;; (product-define "APEL" nil '(9 23))       ; comment.
+  ;; (product-define "APEL" nil '(10 0))       ; Released 24 December 1999
+  ;; (product-define "APEL" nil '(10 1))       ; Released 20 January 2000
+  (product-define "APEL" nil '(10 2))  ; Released 01 March 2000
+  ;; (product-define "APEL" nil '(10 3))
+  )
+
+(defun apel-version ()
+  "Print APEL version."
+  (interactive)
+  (let ((product-info (product-string-1 'apel-ver t)))
+    (if (interactive-p)
+       (message "%s" product-info)
+      product-info)))
+
+
+;;; @ End.
+;;;
+
+;;; apel-ver.el ends here
diff --git a/poe/inv-19.el b/poe/inv-19.el
new file mode 100644 (file)
index 0000000..287a007
--- /dev/null
@@ -0,0 +1,61 @@
+;;; inv-19.el --- invisible feature implementation for Emacs 19 or later
+
+;; Copyright (C) 1995,1996,1997,1998 Free Software Foundation, Inc.
+
+;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
+;; Keywords: invisible, text-property, region, Emacs 19
+
+;; This file is part of APEL (A Portable Emacs Library).
+
+;; 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.
+
+;;; Code:
+
+;; (require 'poe)
+
+(defun enable-invisible ())
+(defun disable-invisible ())
+(defalias 'end-of-invisible 'disable-invisible)
+(make-obsolete 'end-of-invisible 'disable-invisible)
+
+(defun invisible-region (start end)
+  (if (save-excursion
+       (goto-char (1- end))
+       (eq (following-char) ?\n))
+      (setq end (1- end)))
+  (put-text-property start end 'invisible t))
+
+(defun visible-region (start end)
+  (put-text-property start end 'invisible nil))
+
+(defun invisible-p (pos)
+  (get-text-property pos 'invisible))
+
+(defun next-visible-point (pos)
+  (save-excursion
+    (goto-char (next-single-property-change pos 'invisible))
+    (if (eq (following-char) ?\n)
+       (forward-char))
+    (point)))
+
+
+;;; @ end
+;;;
+
+(require 'product)
+(product-provide (provide 'inv-19) (require 'apel-ver))
+
+;;; inv-19.el ends here
diff --git a/poe/invisible.el b/poe/invisible.el
new file mode 100644 (file)
index 0000000..d472e15
--- /dev/null
@@ -0,0 +1,42 @@
+;;; invisible.el --- hide region
+
+;; Copyright (C) 1995,1996,1997,1998 Free Software Foundation, Inc.
+
+;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
+;; Keywords: invisible, text-property, region
+
+;; This file is part of APEL (A Portable Emacs Library).
+
+;; 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.
+
+;;; Code:
+
+(cond
+ ((featurep 'xemacs)
+  (require 'inv-xemacs))
+ ((>= emacs-major-version 19)
+  (require 'inv-19))
+ (t
+  (require 'inv-18)))
+
+
+;;; @ end
+;;;
+
+(require 'product)
+(product-provide (provide 'invisible) (require 'apel-ver))
+
+;;; invisible.el ends here
diff --git a/poe/pccl-20.el b/poe/pccl-20.el
new file mode 100644 (file)
index 0000000..b95244a
--- /dev/null
@@ -0,0 +1,155 @@
+;;; pccl-20.el --- Portable CCL utility for Emacs 20 and XEmacs-21-mule
+
+;; Copyright (C) 1998 Free Software Foundation, Inc.
+;; Copyright (C) 1998 Tanaka Akira
+
+;; Author: Tanaka Akira  <akr@jaist.ac.jp>
+;; Keywords: emulation, compatibility, Mule
+
+;; This file is part of APEL (A Portable Emacs Library).
+
+;; 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.
+
+;;; Code:
+
+(eval-when-compile (require 'ccl))
+(require 'broken)
+
+(broken-facility ccl-accept-symbol-as-program
+  "Emacs does not accept symbol as CCL program."
+  (progn
+    (define-ccl-program test-ccl-identity
+      '(1 ((read r0) (loop (write-read-repeat r0)))))
+    (condition-case nil
+        (progn
+          (funcall
+          (if (fboundp 'ccl-vector-execute-on-string)
+              'ccl-vector-execute-on-string
+            'ccl-execute-on-string)
+           'test-ccl-identity
+           (make-vector 9 nil)
+           "")
+          t)
+      (error nil)))
+  t)
+
+(eval-and-compile
+
+  (if (featurep 'xemacs)
+      (defun make-ccl-coding-system (name mnemonic docstring decoder encoder)
+       "\
+Define a new CODING-SYSTEM by CCL programs DECODER and ENCODER.
+
+CODING-SYSTEM, DECODER and ENCODER must be symbol."
+       (make-coding-system
+        name 'ccl docstring
+        (list 'mnemonic (char-to-string mnemonic)
+              'decode (symbol-value decoder)
+              'encode (symbol-value encoder))))
+    (defun make-ccl-coding-system
+      (coding-system mnemonic docstring decoder encoder)
+      "\
+Define a new CODING-SYSTEM by CCL programs DECODER and ENCODER.
+
+CODING-SYSTEM, DECODER and ENCODER must be symbol."
+      (when-broken ccl-accept-symbol-as-program
+       (setq decoder (symbol-value decoder))
+       (setq encoder (symbol-value encoder)))
+      (make-coding-system coding-system 4 mnemonic docstring
+                         (cons decoder encoder)))
+    )
+
+  (when-broken ccl-accept-symbol-as-program
+
+    (when (subrp (symbol-function 'ccl-execute))
+      (fset 'ccl-vector-program-execute
+           (symbol-function 'ccl-execute))
+      (defun ccl-execute (ccl-prog reg)
+       "\
+Execute CCL-PROG with registers initialized by REGISTERS.
+If CCL-PROG is symbol, it is dereferenced."
+       (ccl-vector-program-execute
+        (if (symbolp ccl-prog) (symbol-value ccl-prog) ccl-prog)
+        reg)))
+
+    (when (subrp (symbol-function 'ccl-execute-on-string))
+      (fset 'ccl-vector-program-execute-on-string
+           (symbol-function 'ccl-execute-on-string))
+      (defun ccl-execute-on-string (ccl-prog status string &optional contin)
+       "\
+Execute CCL-PROG with initial STATUS on STRING.
+If CCL-PROG is symbol, it is dereferenced."
+       (ccl-vector-program-execute-on-string
+        (if (symbolp ccl-prog) (symbol-value ccl-prog) ccl-prog)
+        status string contin)))
+    )
+  )
+
+(eval-when-compile
+  (define-ccl-program test-ccl-eof-block
+    '(1
+      ((read r0)
+       (write r0)
+       (read r0))
+      (write "[EOF]")))
+
+  (make-ccl-coding-system
+   'test-ccl-eof-block-cs ?T "CCL_EOF_BLOCK tester"
+   'test-ccl-eof-block 'test-ccl-eof-block)
+  )
+
+(broken-facility ccl-execute-eof-block-on-encoding-null
+  "Emacs forgets executing CCL_EOF_BLOCK with encoding on empty input. (Fixed on Emacs 20.4)"
+  (equal (encode-coding-string "" 'test-ccl-eof-block-cs) "[EOF]"))
+
+(broken-facility ccl-execute-eof-block-on-encoding-some
+  "Emacs forgets executing CCL_EOF_BLOCK with encoding on non-empty input. (Fixed on Emacs 20.3)"
+  (equal (encode-coding-string "a" 'test-ccl-eof-block-cs) "a[EOF]"))
+
+(broken-facility ccl-execute-eof-block-on-decoding-null
+  "Emacs forgets executing CCL_EOF_BLOCK with decoding on empty input. (Fixed on Emacs 20.4)"
+  (equal (decode-coding-string "" 'test-ccl-eof-block-cs) "[EOF]"))
+
+(broken-facility ccl-execute-eof-block-on-decoding-some
+  "Emacs forgets executing CCL_EOF_BLOCK with decoding on non-empty input. (Fixed on Emacs 20.4)"
+  (equal (decode-coding-string "a" 'test-ccl-eof-block-cs) "a[EOF]"))
+
+(broken-facility ccl-execute-eof-block-on-encoding
+  "Emacs may forget executing CCL_EOF_BLOCK with encoding."
+  (not (or (broken-p 'ccl-execute-eof-block-on-encoding-null)
+          (broken-p 'ccl-execute-eof-block-on-encoding-some)))
+  t)
+
+(broken-facility ccl-execute-eof-block-on-decoding
+  "Emacs may forget executing CCL_EOF_BLOCK with decoding."
+  (not (or (broken-p 'ccl-execute-eof-block-on-decoding-null)
+          (broken-p 'ccl-execute-eof-block-on-decoding-some)))
+  t)
+
+(broken-facility ccl-execute-eof-block
+  "Emacs may forget executing CCL_EOF_BLOCK."
+  (not (or (broken-p 'ccl-execute-eof-block-on-encoding)
+          (broken-p 'ccl-execute-eof-block-on-decoding)))
+  t)
+
+
+;;; @ end
+;;;
+
+(require 'product)
+(product-provide (provide 'pccl-20) (require 'apel-ver))
+
+;;; pccl-20.el ends here
diff --git a/poe/pccl.el b/poe/pccl.el
new file mode 100644 (file)
index 0000000..c696f75
--- /dev/null
@@ -0,0 +1,77 @@
+;;; pccl.el --- Portable CCL utility for Mule 2.*
+
+;; Copyright (C) 1998 Free Software Foundation, Inc.
+
+;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
+;; Keywords: emulation, compatibility, Mule
+
+;; This file is part of APEL (A Portable Emacs Library).
+
+;; 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.
+
+;;; Code:
+
+(require 'broken)
+
+(broken-facility ccl-usable
+  "Emacs has not CCL."
+  (and (featurep 'mule)
+       (if (featurep 'xemacs)
+           (>= emacs-major-version 21)
+         (>= emacs-major-version 19))))
+
+(unless-broken ccl-usable
+  (require 'ccl)
+  (require 'advice)
+
+  (if (featurep 'mule)
+      (if (featurep 'xemacs)
+          (if (>= emacs-major-version 21)
+              ;; for XEmacs 21 with mule
+              (require 'pccl-20))
+        (if (>= emacs-major-version 20)
+            ;; for Emacs 20
+            (require 'pccl-20)
+          ;; for Mule 2.*
+          (require 'pccl-om))))
+
+  (defadvice define-ccl-program
+    (before accept-long-ccl-program activate)
+    "When CCL-PROGRAM is too long, internal buffer is extended automaticaly."
+    (let ((try-ccl-compile t)
+          (prog (eval (ad-get-arg 1))))
+      (ad-set-arg 1 (` '(, prog)))
+      (while try-ccl-compile
+        (setq try-ccl-compile nil)
+        (condition-case sig
+            (ccl-compile prog)
+          (args-out-of-range
+           (if (and (eq (car (cdr sig)) ccl-program-vector)
+                    (= (car (cdr (cdr sig))) (length ccl-program-vector)))
+               (setq ccl-program-vector
+                     (make-vector (* 2 (length ccl-program-vector)) 0)
+                     try-ccl-compile t)
+             (signal (car sig) (cdr sig))))))))
+  )
+
+
+;;; @ end
+;;;
+
+(require 'product)
+(product-provide (provide 'pccl) (require 'apel-ver))
+
+;;; pccl.el ends here
diff --git a/poe/product.el b/poe/product.el
new file mode 100644 (file)
index 0000000..c9aeaab
--- /dev/null
@@ -0,0 +1,424 @@
+;;; product.el --- Functions for product version information.
+
+;; Copyright (C) 1999 Free Software Foundation, Inc.
+
+;; Author: Shuhei KOBAYASHI <shuhei@aqua.ocn.ne.jp>
+;;     Keiichi Suzuki <keiichi@nanap.org>
+;; Keywords: compatibility, User-Agent
+
+;; This file is part of APEL (A Portable Emacs Library).
+
+;; 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 this program; see the file COPYING.  If not, write to
+;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Commentary:
+
+;; This module defines some utility functions for product information,
+;; used for User-Agent header field.
+;;
+;; User-Agent header field first appeared in HTTP [RFC 1945, RFC 2616]
+;; and adopted to News Article Format draft [USEFOR].
+;;
+;; [RFC 1945] Hypertext Transfer Protocol -- HTTP/1.0.
+;;  T. Berners-Lee, R. Fielding & H. Frystyk. May 1996.
+;;
+;; [RFC 2616] Hypertext Transfer Protocol -- HTTP/1.1.
+;;  R. Fielding, J. Gettys, J. Mogul, H. Frystyk, L. Masinter, P. Leach,
+;;  T. Berners-Lee. June 1999.
+;;
+;; [USEFOR] News Article Format, <draft-ietf-usefor-article-02.txt>.
+;;  USEFOR Working Group. March 1999.
+
+;;; Code:
+
+(defvar product-obarray (make-vector 13 0))
+
+(defvar product-ignore-checkers nil)
+
+(defun product-define (name &optional family version code-name)
+  "Define a product as a set of NAME, FAMILY, VERSION, and CODE-NAME.
+NAME is a string.  Optional 2nd argument FAMILY is a string of
+family product name.  Optional 3rd argument VERSION is a list of
+numbers.  Optional 4th argument CODE-NAME is a string."
+  (and family
+       (product-add-to-family family name))
+  (set (intern name product-obarray)
+       (vector name family version code-name nil nil nil nil)))
+
+(defun product-name (product)
+  "Return the name of PRODUCT, a string."
+  (aref product 0))
+(defun product-family (product)
+  "Return the family name of PRODUCT, a string."
+  (aref product 1))
+(defun product-version (product)
+  "Return the version of PRODUCT, a list of numbers."
+  (aref product 2))
+(defun product-code-name (product)
+  "Return the code-name of PRODUCT, a string."
+  (aref product 3))
+(defun product-checkers (product)
+  "Return the checkers of PRODUCT, a list of functions."
+  (aref product 4))
+(defun product-family-products (product)
+  "Return the family products of PRODUCT, a list of strings."
+  (aref product 5))
+(defun product-features (product)
+  "Return the features of PRODUCT, a list of feature."
+  (aref product 6))
+(defun product-version-string (product)
+  "Return the version string of PRODUCT, a string."
+  (aref product 7))
+
+(defun product-set-name (product name)
+  "Set name of PRODUCT to NAME."
+  (aset product 0 name))
+(defun product-set-family (product family)
+  "Set family name of PRODUCT to FAMILY."
+  (aset product 1 family))
+(defun product-set-version (product version)
+  "Set version of PRODUCT to VERSION."
+  (aset product 2 version))
+;; Some people want to translate code-name.
+(defun product-set-code-name (product code-name)
+  "Set code-name of PRODUCT to CODE-NAME."
+  (aset product 3 code-name))
+(defun product-set-checkers (product checkers)
+  "Set ckecker functions of PRODUCT to CHECKERS."
+  (aset product 4 checkers))
+(defun product-set-family-products (product products)
+  "Set family products of PRODUCT to PRODUCTS."
+  (aset product 5 products))
+(defun product-set-features (product features)
+  "Set features of PRODUCT to FEATURES."
+  (aset product 6 features))
+(defun product-set-version-string (product version-string)
+  "Set version string of PRODUCT to VERSION-STRING."
+  (aset product 7 version-string))
+
+(defun product-add-to-family (family product-name)
+  "Add a product to a family.
+FAMILY is a product structure which returned by `product-define'.
+PRODUCT-NAME is a string of the product's name ."
+  (let ((family-product (product-find-by-name family)))
+    (if family-product
+       (let ((dest (product-family-products family-product)))
+         (or (member product-name dest)
+             (product-set-family-products
+              family-product (cons product-name dest))))
+      (error "Family product `%s' is not defined" family))))
+
+(defun product-remove-from-family (family product-name)
+  "Remove a product from a family.
+FAMILY is a product string which returned by `product-define'.
+PRODUCT-NAME is a string of the product's name."
+  (let ((family-product (product-find-by-name family)))
+    (if family-product
+       (product-set-family-products
+        family-product
+        (delete product-name (product-family-products family-product)))
+      (error "Family product `%s' is not defined" family))))
+
+(defun product-add-checkers (product &rest checkers)
+  "Add checker function(s) to a product.
+PRODUCT is a product structure which returned by `product-define'.
+The rest arguments CHECKERS should be functions.  These functions
+are regist to the product's checkers list, and will be called by
+ `product-run-checkers'.
+If a checker is `ignore' will be ignored all checkers after this."
+  (setq product (product-find product))
+  (or product-ignore-checkers
+      (let ((dest (product-checkers product))
+           checker)
+       (while checkers
+         (setq checker (car checkers)
+               checkers (cdr checkers))
+         (or (memq checker dest)
+             (setq dest (cons checker dest))))
+       (product-set-checkers product dest))))
+
+(defun product-remove-checkers (product &rest checkers)
+  "Remove checker function(s) from a product.
+PRODUCT is a product structure which returned by `product-define'.
+The rest arguments CHECKERS should be functions.  These functions removed
+from the product's checkers list."
+  (setq product (product-find product))
+  (let ((dest (product-checkers product)))
+    (while checkers
+      (setq checkers (cdr checkers)
+           dest (delq (car checkers) dest)))
+    (product-set-checkers product dest)))
+
+(defun product-add-feature (product feature)
+  "Add a feature to the features list of a product.
+PRODUCT is a product structure which returned by `product-define'.
+FEATURE is a feature in the PRODUCT's."
+  (setq product (product-find product))
+  (let ((dest (product-features product)))
+    (or (memq feature dest)
+       (product-set-features product (cons feature dest)))))
+
+(defun product-remove-feature (product feature)
+  "Remove a feature from the features list of a product.
+PRODUCT is a product structure which returned by `product-define'.
+FEATURE is a feature which registered in the products list of PRODUCT."
+  (setq product (product-find product))
+  (product-set-features product
+                       (delq feature (product-features product))))
+
+(defun product-run-checkers (product version &optional force)
+  "Run checker functions of product.
+PRODUCT is a product structure which returned by `product-define'.
+VERSION is target version.
+If optional 3rd argument FORCE is non-nil then do not ignore
+all checkers."
+  (let ((checkers (product-checkers product)))
+    (if (or force
+           (not (memq 'ignore checkers)))
+       (let ((version (or version
+                          (product-version product))))
+         (while checkers
+           (funcall (car checkers) version version)
+           (setq checkers (cdr checkers)))))))
+
+(defun product-find-by-name (name)
+  "Find product by name and return a product structure.
+NAME is a string of the product's name."
+  (symbol-value (intern-soft name product-obarray)))
+
+(defun product-find-by-feature (feature)
+  "Get a product structure of a feature's product.
+FEATURE is a symbol of the feature."
+  (get feature 'product))
+
+(defun product-find (product)
+  "Find product information.
+If PROCUCT is a product structure, then return PRODUCT itself.
+If PRODUCT is a string, then find product by name and return a
+product structure.  If PRODUCT is symbol of feature, then return
+the feature's product."
+  (cond
+   ((and (symbolp product)
+        (featurep product))
+    (product-find-by-feature product))
+   ((stringp product)
+    (product-find-by-name product))
+   ((vectorp product)
+    product)
+   (t
+    (error "Invalid product %s" product))))
+
+(put 'product-provide 'lisp-indent-function 1)
+(defmacro product-provide (feature-def product-def)
+  "Declare a feature as a part of product.
+FEATURE-DEF is a definition of the feature.
+PRODUCT-DEF is a definition of the product."
+  (let* ((feature feature-def)
+        (product (product-find (eval product-def)))
+        (product-name (product-name product))
+        (product-family (product-family product))
+        (product-version (product-version product))
+        (product-code-name (product-code-name product))
+        (product-version-string (product-version-string product)))
+    (` (progn
+        (, product-def)
+        (put (, feature) 'product
+             (let ((product (product-find-by-name (, product-name))))
+               (product-run-checkers product '(, product-version))
+               (and (, product-family)
+                    (product-add-to-family (, product-family)
+                                           (, product-name)))
+               (product-add-feature product (, feature))
+               (if (equal '(, product-version) (product-version product))
+                   product
+                 (vector (, product-name) (, product-family)
+                         '(, product-version) (, product-code-name)
+                         nil nil nil (, product-version-string)))))
+        (, feature-def)))))
+
+(defun product-string-1 (product &optional verbose)
+  "Return information of product as a string of \"NAME/VERSION\".
+PRODUCT is a product structure which returned by `product-define'.
+If optional argument VERBOSE is non-nil, then return string of
+\"NAME/VERSION (CODE-NAME)\"."
+  (setq product (product-find product))
+  (concat (product-name product)
+         (cond
+          ((product-version-string product)
+           (concat "/" (product-version-string product)))
+          ((product-version product)
+           (concat "/"
+                   (product-set-version-string
+                    product
+                    (mapconcat (function int-to-string)
+                               (product-version product)
+                               "."))))
+          (""))
+         (if (and verbose (product-code-name product))
+             (concat " (" (product-code-name product) ")")
+           "")))
+
+(defun product-for-each (product all function &rest args)
+  "Apply a function to a product and the product's family with args.
+PRODUCT is a product structure which returned by `product-define'.
+If ALL is nil, apply function to only products which provided feature.
+FUNCTION is a function.  The function called with following arguments.
+The 1st argument is a product structure.  The rest arguments are ARGS."
+  (setq product (product-find product))
+  (let ((family (product-family-products product)))
+    (and (or all (product-features product))
+        (apply function product args))
+    (while family
+      (apply 'product-for-each (car family) all function args)
+      (setq family (cdr family)))))
+
+(defun product-string (product)
+  "Return information of product as a string of \"NAME/VERSION\".
+PRODUCT is a product structure which returned by `product-define'."
+  (let (dest)
+    (product-for-each product nil
+     (function
+      (lambda (product)
+       (let ((str (product-string-1 product nil)))
+         (if str
+             (setq dest (if dest
+                            (concat dest " " str)
+                          str)))))))
+    dest))
+
+(defun product-string-verbose (product)
+  "Return information of product as a string of \"NAME/VERSION (CODE-NAME)\".
+PRODUCT is a product structure which returned by `product-define'."
+  (let (dest)
+    (product-for-each product nil
+     (function
+      (lambda (product)
+       (let ((str (product-string-1 product t)))
+         (if str
+             (setq dest (if dest
+                            (concat dest " " str)
+                          str)))))))
+    dest))
+
+(defun product-version-compare (v1 v2)
+  "Compare two versions.
+Return an integer greater than, equal to, or less than 0,
+according as the version V1 is greater than, equal to, or less
+than the version V2.
+Both V1 and V2 are a list of integer(s) respectively."
+  (while (and v1 v2 (= (car v1) (car v2)))
+    (setq v1 (cdr v1)
+         v2 (cdr v2)))
+  (if v1 (if v2 (- (car v1) (car v2)) 1) (if v2 -1 0)))
+
+(defun product-version>= (product require-version)
+  "Compare product version with required version.
+PRODUCT is a product structure which returned by `product-define'.
+REQUIRE-VERSION is a list of integer."
+  (>= (product-version-compare (product-version (product-find product))
+                              require-version)
+      0))
+
+(defun product-list-products ()
+  "List all products information."
+  (let (dest)
+    (mapatoms
+     (function
+      (lambda (sym)
+       (setq dest (cons (symbol-value sym) dest))))
+     product-obarray)
+    dest))
+
+(defun product-parse-version-string (verstr)
+  "Parse version string \".*v1.v2... (CODE-NAME)\".
+Return list of version, code-name, and version-string.
+VERSTR is a string."
+  (let (version version-string code-name)
+    (and (string-match "\\(\\([0-9.]+\\)[^ ]*\\)[^(]*\\((\\(.+\\))\\)?" verstr)
+        (let ((temp (substring verstr (match-beginning 2) (match-end 2))))
+          (setq version-string (substring verstr
+                                          (match-beginning 1)
+                                          (match-end 1))
+                code-name (and (match-beginning 4)
+                               (substring verstr
+                                          (match-beginning 4)
+                                          (match-end 4))))
+          (while (string-match "^\\([0-9]+\\)\\.?" temp)
+            (setq version (cons (string-to-number
+                                 (substring temp
+                                            (match-beginning 1)
+                                            (match-end 1)))
+                                version)
+                  temp (substring temp (match-end 0))))))
+    (list (nreverse version) code-name version-string)))
+
+
+;;; @ End.
+;;;
+
+(provide 'product)                     ; beware of circular dependency.
+(require 'apel-ver)                    ; these two files depend on each other.
+(product-provide 'product 'apel-ver)
+\f
+
+;;; @ Define emacs versions.
+;;;
+
+;; (require 'pym)
+
+;; (defconst-maybe emacs-major-version
+;;   (progn (string-match "^[0-9]+" emacs-version)
+;;          (string-to-int (substring emacs-version
+;;                                    (match-beginning 0)(match-end 0))))
+;;   "Major version number of this version of Emacs.")
+;; (defconst-maybe emacs-minor-version
+;;   (progn (string-match "^[0-9]+\\.\\([0-9]+\\)" emacs-version)
+;;          (string-to-int (substring emacs-version
+;;                                    (match-beginning 1)(match-end 1))))
+;;   "Minor version number of this version of Emacs.")
+
+;;(or (product-find "emacs")
+;;    (progn
+;;      (product-define "emacs")
+;;      (cond
+;;       ((featurep 'meadow)
+;;     (let* ((info (product-parse-version-string (Meadow-version)))
+;;            (version (nth 0 info))
+;;            (code-name (nth 1 info))
+;;            (version-string (nth 2 info)))
+;;       (product-set-version-string
+;;        (product-define "Meadow" "emacs" version code-name)
+;;        version-string)
+;;       (product-provide 'Meadow "Meadow"))
+;;     (and (featurep 'mule)
+;;          (let* ((info (product-parse-version-string mule-version))
+;;                 (version (nth 0 info))
+;;                 (code-name (nth 1 info))
+;;                 (version-string (nth 2 info)))
+;;            (product-set-version-string
+;;             (product-define "MULE" "Meadow" version code-name)
+;;             version-string)
+;;            (product-provide 'mule "MULE")))
+;;     (let* ((info (product-parse-version-string emacs-version))
+;;            (version (nth 0 info))
+;;            (code-name (nth 1 info))
+;;            (version-string (nth 2 info)))
+;;       (product-set-version-string
+;;        (product-define "Emacs" "Meadow" version code-name)
+;;        version-string)
+;;       (product-provide 'emacs "Emacs")))
+;;       )))
+
+;;; product.el ends here
diff --git a/richtext.el b/richtext.el
new file mode 100644 (file)
index 0000000..8b1718c
--- /dev/null
@@ -0,0 +1,185 @@
+;;; richtext.el -- read and save files in text/richtext format
+
+;; Copyright (C) 1995,1996,1997 Free Software Foundation, Inc.
+
+;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
+;; Created: 1995/7/15
+;; Version: $Id: richtext.el,v 1.1.2.1 2000/02/03 05:01:36 tomo Exp $
+;; Keywords: wp, faces, MIME, multimedia
+
+;; This file is not part of GNU Emacs yet.
+
+;; 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.
+
+;;; Code:
+
+(require 'enriched)
+
+
+;;; @ variables
+;;;
+
+(defconst richtext-initial-annotation
+  (lambda ()
+    (format "Content-Type: text/richtext\nText-Width: %d\n\n"
+           (enriched-text-width)))
+  "What to insert at the start of a text/richtext file.
+If this is a string, it is inserted.  If it is a list, it should be a lambda
+expression, which is evaluated to get the string to insert.")
+
+(defconst richtext-annotation-regexp
+  "[ \t\n]*\\(<\\(/\\)?\\([-A-za-z0-9]+\\)>\\)[ \t\n]*"
+  "Regular expression matching richtext annotations.")
+
+(defconst richtext-translations
+  '((face          (bold-italic "bold" "italic")
+                  (bold        "bold")
+                  (italic      "italic")
+                  (underline   "underline")
+                  (fixed       "fixed")
+                  (excerpt     "excerpt")
+                  (default     )
+                  (nil         enriched-encode-other-face))
+    (invisible     (t           "comment"))
+    (left-margin   (4           "indent"))
+    (right-margin  (4           "indentright"))
+    (justification (right       "flushright")
+                  (left        "flushleft")
+                  (full        "flushboth")
+                  (center      "center")) 
+    ;; The following are not part of the standard:
+    (FUNCTION      (enriched-decode-foreground "x-color")
+                  (enriched-decode-background "x-bg-color"))
+    (read-only     (t           "x-read-only"))
+    (unknown       (nil         format-annotate-value))
+;   (font-size     (2           "bigger")       ; unimplemented
+;                 (-2          "smaller"))
+)
+  "List of definitions of text/richtext annotations.
+See `format-annotate-region' and `format-deannotate-region' for the definition
+of this structure.")
+
+
+;;; @ encoder
+;;;
+
+;;;###autoload
+(defun richtext-encode (from to)
+  (if enriched-verbose (message "Richtext: encoding document..."))
+  (save-restriction
+    (narrow-to-region from to)
+    (delete-to-left-margin)
+    (unjustify-region)
+    (goto-char from)
+    (format-replace-strings '(("<" . "<lt>")))
+    (format-insert-annotations 
+     (format-annotate-region from (point-max) richtext-translations
+                            'enriched-make-annotation enriched-ignore))
+    (goto-char from)
+    (insert (if (stringp enriched-initial-annotation)
+               richtext-initial-annotation
+             (funcall richtext-initial-annotation)))
+    (enriched-map-property-regions 'hard
+      (lambda (v b e)
+       (goto-char b)
+       (if (eolp)
+           (while (search-forward "\n" nil t)
+             (replace-match "<nl>\n")
+             )))
+      (point) nil)
+    (if enriched-verbose (message nil))
+    ;; Return new end.
+    (point-max)))
+
+
+;;; @ decoder
+;;;
+
+(defun richtext-next-annotation ()
+  "Find and return next text/richtext annotation.
+Return value is \(begin end name positive-p), or nil if none was found."
+  (catch 'tag
+    (while (re-search-forward richtext-annotation-regexp nil t)
+      (let* ((beg0 (match-beginning 0))
+            (end0 (match-end 0))
+            (beg  (match-beginning 1))
+            (end  (match-end 1))
+            (name (downcase (buffer-substring 
+                             (match-beginning 3) (match-end 3))))
+            (pos (not (match-beginning 2)))
+            )
+       (cond ((equal name "lt")
+              (delete-region beg end)
+              (goto-char beg)
+              (insert "<")
+              )
+             ((equal name "comment")
+              (if pos
+                  (throw 'tag (list beg0 end name pos))
+                (throw 'tag (list beg end0 name pos))
+                )
+              )
+             (t
+              (throw 'tag (list beg end name pos))
+              ))
+       ))))
+
+;;;###autoload
+(defun richtext-decode (from to)
+  (if enriched-verbose (message "Richtext: decoding document..."))
+  (save-excursion
+    (save-restriction
+      (narrow-to-region from to)
+      (goto-char from)
+      (let ((file-width (enriched-get-file-width))
+           (use-hard-newlines t))
+       (enriched-remove-header)
+       
+       (goto-char from)
+       (while (re-search-forward "\n\n+" nil t)
+         (replace-match "\n")
+         )
+       
+       ;; Deal with newlines
+       (goto-char from)
+       (while (re-search-forward "[ \t\n]*<nl>[ \t\n]*" nil t)
+         (replace-match "\n")
+         (put-text-property (match-beginning 0) (point) 'hard t)
+         (put-text-property (match-beginning 0) (point) 'front-sticky nil)
+         )
+       
+       ;; Translate annotations
+       (format-deannotate-region from (point-max) richtext-translations
+                                 'richtext-next-annotation)
+
+       ;; Fill paragraphs
+       (if (and file-width             ; possible reasons not to fill:
+                (= file-width (enriched-text-width))) ; correct wd.
+           ;; Minimally, we have to insert indentation and justification.
+           (enriched-insert-indentation)
+         (if enriched-verbose (message "Filling paragraphs..."))
+         (fill-region (point-min) (point-max))))
+      (if enriched-verbose (message nil))
+      (point-max))))
+
+
+;;; @ end
+;;;
+
+(require 'product)
+(product-provide (provide 'richtext) (require 'apel-ver))
+
+;;; richtext.el ends here