--- /dev/null
+;;; 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
--- /dev/null
+;;; 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
--- /dev/null
+;;; 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
--- /dev/null
+;;; 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
--- /dev/null
+;;; 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
--- /dev/null
+;;; 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
--- /dev/null
+;;; 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
--- /dev/null
+;;; 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
;; I'm not sure smtpmail.el is careful about the following
;; return value, but it also uses it internally, so I will fear
;; no evil.
- (require 'smtpmail)
- (if (not (smtpmail-via-smtp addr-listoid prepped))
+ (require 'smtp)
+ (if (not (smtp-via-smtp user-mail-address addr-listoid prepped))
(progn
(set-buffer errors-to)
(insert "Send via smtpmail failed. Probable SMTP protocol error.\n")
(insert "Look for details below or in the *Messages* buffer.\n\n")
(let ((case-fold-search t)
;; don't be overconfident about the name of the trace buffer
- (tracer (concat "trace.*smtp.*" (regexp-quote smtpmail-smtp-server))))
+ (tracer (concat "trace.*smtp.*" (regexp-quote smtp-server))))
(mapcar
'(lambda (buffy)
(if (string-match tracer (buffer-name buffy))
--- /dev/null
+;;; 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
--- /dev/null
+;;; 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
--- /dev/null
+;;; 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
--- /dev/null
+;;; 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
--- /dev/null
+;;; 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
--- /dev/null
+;;; 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
--- /dev/null
+;;; 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
--- /dev/null
+;;; 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
--- /dev/null
+;;; 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
--- /dev/null
+;;; 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
-;;; smtpmail.el --- simple SMTP protocol (RFC 821) for sending mail
-;;; ### Hacked by Mike Taylor, 11th October 1999 to add support for
-;;; automatically appending a domain to RCPT TO: addresses.
+;;; smtpmail.el --- SMTP interface for mail-mode
-;; Copyright (C) 1995, 1996 Free Software Foundation, Inc.
+;; Copyright (C) 1995, 1996, 1998, 1999 Free Software Foundation, Inc.
;; Author: Tomoji Kagatani <kagatani@rbc.ncl.omron.co.jp>
-;; Maintainer: Brian D. Carlstrom <bdc@ai.mit.edu>
-;; ESMTP support: Simon Leinen <simon@switch.ch>
;; Keywords: mail
-;; This file is part of GNU Emacs.
+;; This file is part of FLIM (Faithful Library about Internet Message).
-;; GNU Emacs 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 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.
-;; GNU Emacs 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.
+;; 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,
+;; 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:
;; Send Mail to smtp host from smtpmail temp buffer.
-;; Please add these lines in your .emacs(_emacs) or use customize.
+;; Please add these lines in your .emacs(_emacs).
;;
-;;(setq send-mail-function 'smtpmail-send-it) ; if you use `mail'
-;;(setq message-send-mail-function 'smtpmail-send-it) ; if you use `message'
-;;(setq smtpmail-default-smtp-server "YOUR SMTP HOST")
-;;(setq smtpmail-local-domain "YOUR DOMAIN NAME")
-;;(setq smtpmail-sendto-domain "YOUR DOMAIN NAME")
-;;(setq smtpmail-debug-info t) ; only to debug problems
+;;(setq send-mail-function 'smtpmail-send-it)
+;;(setq smtp-default-server "YOUR SMTP HOST")
+;;(setq smtp-service "smtp")
+;;(setq smtp-local-domain "YOUR DOMAIN NAME")
+;;(setq smtp-debug-info t)
+;;(autoload 'smtpmail-send-it "smtpmail")
+;;(setq user-full-name "YOUR NAME HERE")
;; To queue mail, set smtpmail-queue-mail to t and use
;; smtpmail-send-queued-mail to send.
;;; Code:
+(require 'custom)
+(require 'smtp)
(require 'sendmail)
(require 'time-stamp)
+(require 'mel) ; binary-write-decoded-region, binary-find-file-noselect
-;;;
-(defgroup smtpmail nil
- "SMTP protocol for sending mail."
- :group 'mail)
-
-
-(defcustom smtpmail-default-smtp-server nil
- "*Specify default SMTP server."
- :type '(choice (const nil) string)
- :group 'smtpmail)
-
-(defcustom smtpmail-smtp-server
- (or (getenv "SMTPSERVER") smtpmail-default-smtp-server)
- "*The name of the host running SMTP server."
- :type '(choice (const nil) string)
- :group 'smtpmail)
-
-(defcustom smtpmail-smtp-service 25
- "*SMTP service port number. smtp or 25 ."
- :type 'integer
- :group 'smtpmail)
-
-(defcustom smtpmail-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 'smtpmail)
-
-(defcustom smtpmail-sendto-domain nil
- "*Local domain name without a host name.
-This is appended (with an @-sign) to any specified recipients which do
-not include an @-sign, so that each RCPT TO address is fully qualified.
-\(Some configurations of sendmail require this.)
-
-Don't bother to set this unless you have get an error like:
- Sending failed; SMTP protocol error
-when sending mail, and the *trace of SMTP session to <somewhere>*
-buffer includes an exchange like:
- RCPT TO: <someone>
- 501 <someone>: recipient address must contain a domain
-"
- :type '(choice (const nil) string)
- :group 'smtpmail)
-
-(defun maybe-append-domain (recipient)
- (if (or (not smtpmail-sendto-domain)
- (string-match "@" recipient))
- recipient
- (concat recipient "@" smtpmail-sendto-domain)))
-
-(defcustom smtpmail-debug-info nil
- "*smtpmail debug info printout. messages and process buffer."
- :type 'boolean
- :group 'smtpmail)
+(eval-when-compile (require 'static))
-(defcustom smtpmail-code-conv-from nil ;; *junet*
- "*smtpmail code convert from this code to *internal*..for tiny-mime.."
- :type 'boolean
- :group 'smtpmail)
+;; (static-when (featurep 'xemacs)
+;; (define-obsolete-variable-alias 'smtpmail-default-smtp-server
+;; 'smtp-default-server)
+;; (define-obsolete-variable-alias 'smtpmail-smtp-server 'smtp-server)
+;; (define-obsolete-variable-alias 'smtpmail-smtp-service 'smtp-service)
+;; (define-obsolete-variable-alias 'smtpmail-local-domain 'smtp-local-domain)
+;; (define-obsolete-variable-alias 'smtpmail-debug-info 'smtp-debug-info)
+;; )
+
+;;;
(defcustom smtpmail-queue-mail nil
- "*Specify if mail is queued (if t) or sent immediately (if nil).
+ "Specify if mail is queued (if t) or sent immediately (if nil).
If queued, it is stored in the directory `smtpmail-queue-dir'
and sent with `smtpmail-send-queued-mail'."
:type 'boolean
- :group 'smtpmail)
+ :group 'smtp)
(defcustom smtpmail-queue-dir "~/Mail/queued-mail/"
- "*Directory where `smtpmail.el' stores queued mail."
+ "Directory where `smtpmail.el' stores queued mail."
:type 'directory
- :group 'smtpmail)
+ :group 'smtp)
(defvar smtpmail-queue-index-file "index"
"File name of queued mail index,
This is relative to `smtpmail-queue-dir'.")
-(defvar smtpmail-address-buffer)
-(defvar smtpmail-recipient-address-list)
+(defvar smtpmail-queue-index
+ (concat (file-name-as-directory smtpmail-queue-dir)
+ smtpmail-queue-index-file))
-;; Buffer-local variable.
-(defvar smtpmail-read-point)
+(defvar smtpmail-recipient-address-list nil)
-(defvar smtpmail-queue-index (concat smtpmail-queue-dir
- smtpmail-queue-index-file))
;;;
;;;
0))
(tembuf (generate-new-buffer " smtpmail temp"))
(case-fold-search nil)
+ resend-to-addresses
delimline
- (mailbuf (current-buffer))
- (smtpmail-code-conv-from
- (if enable-multibyte-characters
- (let ((sendmail-coding-system smtpmail-code-conv-from))
- (select-message-coding-system)))))
+ (mailbuf (current-buffer)))
(unwind-protect
(save-excursion
(set-buffer tembuf)
(or (= (preceding-char) ?\n)
(insert ?\n))
;; Change header-delimiter to be what sendmail expects.
- (mail-sendmail-undelimit-header)
+ (goto-char (point-min))
+ (re-search-forward
+ (concat "^" (regexp-quote mail-header-separator) "\n"))
+ (replace-match "\n")
+ (backward-char 1)
(setq delimline (point-marker))
;; (sendmail-synch-aliases)
- (if mail-aliases
+ (if (and mail-aliases (fboundp 'expand-mail-aliases)) ; XEmacs
(expand-mail-aliases (point-min) delimline))
(goto-char (point-min))
;; ignore any blank lines in the header
(< (point) delimline))
(replace-match "\n"))
(let ((case-fold-search t))
- ;; We used to process Resent-... headers here,
- ;; but it was not done properly, and the job
- ;; is done correctly in smtpmail-deduce-address-list.
+ (goto-char (point-min))
+ (goto-char (point-min))
+ (while (re-search-forward "^Resent-to:" delimline t)
+ (setq resend-to-addresses
+ (save-restriction
+ (narrow-to-region (point)
+ (save-excursion
+ (forward-line 1)
+ (while (looking-at "^[ \t]")
+ (forward-line 1))
+ (point)))
+ (append (mail-parse-comma-list)
+ resend-to-addresses))))
+;;; Apparently this causes a duplicate Sender.
+;;; ;; If the From is different than current user, insert Sender.
+;;; (goto-char (point-min))
+;;; (and (re-search-forward "^From:" delimline t)
+;;; (progn
+;;; (require 'mail-utils)
+;;; (not (string-equal
+;;; (mail-strip-quoted-names
+;;; (save-restriction
+;;; (narrow-to-region (point-min) delimline)
+;;; (mail-fetch-field "From")))
+;;; (user-login-name))))
+;;; (progn
+;;; (forward-line 1)
+;;; (insert "Sender: " (user-login-name) "\n")))
;; Don't send out a blank subject line
(goto-char (point-min))
- (if (re-search-forward "^Subject:\\([ \t]*\n\\)+\\b" delimline t)
- (replace-match "")
- ;; This one matches a Subject just before the header delimiter.
- (if (and (re-search-forward "^Subject:\\([ \t]*\n\\)+" delimline t)
- (= (match-end 0) delimline))
- (replace-match "")))
+ (if (re-search-forward "^Subject:[ \t]*\n" delimline t)
+ (replace-match ""))
;; Put the "From:" field in unless for some odd reason
;; they put one in themselves.
(goto-char (point-min))
;;
;;
;;
- (setq smtpmail-address-buffer (generate-new-buffer "*smtp-mail*"))
(setq smtpmail-recipient-address-list
- (smtpmail-deduce-address-list tembuf (point-min) delimline))
- (kill-buffer smtpmail-address-buffer)
-
+ (or resend-to-addresses
+ (smtp-deduce-address-list tembuf (point-min) delimline)))
+
(smtpmail-do-bcc delimline)
; Send or queue
(if (not smtpmail-queue-mail)
- (if (not (null smtpmail-recipient-address-list))
- (if (not (smtpmail-via-smtp
- smtpmail-recipient-address-list tembuf))
- (error "Sending failed; SMTP protocol error"))
+ (if smtpmail-recipient-address-list
+ (smtp-send-buffer user-mail-address
+ smtpmail-recipient-address-list
+ tembuf)
(error "Sending failed; no recipients"))
- (let* ((file-data (concat
- smtpmail-queue-dir
- (concat (time-stamp-yyyy-mm-dd)
- "_" (time-stamp-hh:mm:ss))))
- (file-data (convert-standard-filename file-data))
- (file-elisp (concat file-data ".el"))
+ (let* ((file-data (convert-standard-filename
+ (concat
+ (file-name-as-directory smtpmail-queue-dir)
+ (time-stamp-yyyy-mm-dd)
+ "_" (time-stamp-hh:mm:ss))))
+ (file-elisp (concat file-data ".el"))
(buffer-data (create-file-buffer file-data))
(buffer-elisp (create-file-buffer file-elisp))
(buffer-scratch "*queue-mail*"))
(set-buffer buffer-data)
(erase-buffer)
(insert-buffer tembuf)
- (write-file file-data)
+ (or (file-directory-p smtpmail-queue-dir)
+ (make-directory smtpmail-queue-dir t))
+ (binary-write-decoded-region (point-min) (point-max) file-data)
(set-buffer buffer-elisp)
(erase-buffer)
(insert (concat
(end-of-line)
(point))))
(load file-msg)
- (setq tembuf (find-file-noselect file-msg))
- (if (not (null smtpmail-recipient-address-list))
- (if (not (smtpmail-via-smtp smtpmail-recipient-address-list
- tembuf))
- (error "Sending failed; SMTP protocol error"))
+ (setq tembuf (binary-find-file-noselect file-msg))
+ (if smtpmail-recipient-address-list
+ (smtp-send-buffer user-mail-address
+ smtpmail-recipient-address-list tembuf)
(error "Sending failed; no recipients"))
(delete-file file-msg)
(delete-file (concat file-msg ".el"))
(kill-buffer buffer-index)
)))
-;(defun smtpmail-via-smtp (host,port,sender,destination,smtpmail-text-buffer)
-
-(defun smtpmail-fqdn ()
- (if smtpmail-local-domain
- (concat (system-name) "." smtpmail-local-domain)
- (system-name)))
-
-(defun smtpmail-via-smtp (recipient smtpmail-text-buffer)
- (let ((process nil)
- (host (or smtpmail-smtp-server
- (error "`smtpmail-smtp-server' not defined")))
- (port smtpmail-smtp-service)
- response-code
- greeting
- process-buffer
- (supported-extensions '()))
- (unwind-protect
- (catch 'done
- ;; get or create the trace buffer
- (setq process-buffer
- (get-buffer-create (format "*trace of SMTP session to %s*" host)))
-
- ;; clear the trace buffer of old output
- (save-excursion
- (set-buffer process-buffer)
- (erase-buffer))
-
- ;; open the connection to the server
- (setq process (open-network-stream "SMTP" process-buffer host port))
- (and (null process) (throw 'done nil))
-
- ;; set the send-filter
- (set-process-filter process 'smtpmail-process-filter)
-
- (save-excursion
- (set-buffer process-buffer)
- (set-buffer-process-coding-system 'raw-text-unix 'raw-text-unix)
- (make-local-variable 'smtpmail-read-point)
- (setq smtpmail-read-point (point-min))
-
-
- (if (or (null (car (setq greeting (smtpmail-read-response process))))
- (not (integerp (car greeting)))
- (>= (car greeting) 400))
- (throw 'done nil)
- )
-
- ;; EHLO
- (smtpmail-send-command process (format "EHLO %s" (smtpmail-fqdn)))
-
- (if (or (null (car (setq response-code (smtpmail-read-response process))))
- (not (integerp (car response-code)))
- (>= (car response-code) 400))
- (progn
- ;; HELO
- (smtpmail-send-command process (format "HELO %s" (smtpmail-fqdn)))
-
- (if (or (null (car (setq response-code (smtpmail-read-response process))))
- (not (integerp (car response-code)))
- (>= (car response-code) 400))
- (throw 'done nil)))
- (let ((extension-lines (cdr (cdr response-code))))
- (while extension-lines
- (let ((name (intern (downcase (car (split-string (substring (car extension-lines) 4) "[ ]"))))))
- (and name
- (cond ((memq name '(verb xvrb 8bitmime onex xone
- expn size dsn etrn
- help xusr))
- (setq supported-extensions
- (cons name supported-extensions)))
- (t (message "unknown extension %s"
- name)))))
- (setq extension-lines (cdr extension-lines)))))
-
- (if (or (member 'onex supported-extensions)
- (member 'xone supported-extensions))
- (progn
- (smtpmail-send-command process (format "ONEX"))
- (if (or (null (car (setq response-code (smtpmail-read-response process))))
- (not (integerp (car response-code)))
- (>= (car response-code) 400))
- (throw 'done nil))))
-
- (if (and smtpmail-debug-info
- (or (member 'verb supported-extensions)
- (member 'xvrb supported-extensions)))
- (progn
- (smtpmail-send-command process (format "VERB"))
- (if (or (null (car (setq response-code (smtpmail-read-response process))))
- (not (integerp (car response-code)))
- (>= (car response-code) 400))
- (throw 'done nil))))
-
- (if (member 'xusr supported-extensions)
- (progn
- (smtpmail-send-command process (format "XUSR"))
- (if (or (null (car (setq response-code (smtpmail-read-response process))))
- (not (integerp (car response-code)))
- (>= (car response-code) 400))
- (throw 'done nil))))
-
- ;; MAIL FROM: <sender>
- (let ((size-part
- (if (member 'size supported-extensions)
- (format " SIZE=%d"
- (save-excursion
- (set-buffer smtpmail-text-buffer)
- ;; size estimate:
- (+ (- (point-max) (point-min))
- ;; 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)))
- ""))
- (body-part
- (if (member '8bitmime supported-extensions)
- ;; FIXME:
- ;; Code should be added here that transforms
- ;; the contents of the message buffer into
- ;; something the receiving SMTP can handle.
- ;; For a receiver that supports 8BITMIME, this
- ;; may mean converting BINARY to BASE64, or
- ;; adding Content-Transfer-Encoding and the
- ;; other MIME headers. The code should also
- ;; return an indication of what encoding the
- ;; message buffer is now, i.e. ASCII or
- ;; 8BITMIME.
- (if nil
- " BODY=8BITMIME"
- "")
- "")))
-; (smtpmail-send-command process (format "MAIL FROM:%s@%s" (user-login-name) (smtpmail-fqdn)))
- (smtpmail-send-command process (format "MAIL FROM: <%s>%s%s"
- user-mail-address
- size-part
- body-part))
-
- (if (or (null (car (setq response-code (smtpmail-read-response process))))
- (not (integerp (car response-code)))
- (>= (car response-code) 400))
- (throw 'done nil)
- ))
-
- ;; RCPT TO: <recipient>
- (let ((n 0))
- (while (not (null (nth n recipient)))
- (smtpmail-send-command process (format "RCPT TO: <%s>" (maybe-append-domain (nth n recipient))))
- (setq n (1+ n))
-
- (setq response-code (smtpmail-read-response process))
- (if (or (null (car response-code))
- (not (integerp (car response-code)))
- (>= (car response-code) 400))
- (throw 'done nil)
- )
- ))
-
- ;; DATA
- (smtpmail-send-command process "DATA")
-
- (if (or (null (car (setq response-code (smtpmail-read-response process))))
- (not (integerp (car response-code)))
- (>= (car response-code) 400))
- (throw 'done nil)
- )
-
- ;; Mail contents
- (smtpmail-send-data process smtpmail-text-buffer)
-
- ;;DATA end "."
- (smtpmail-send-command process ".")
-
- (if (or (null (car (setq response-code (smtpmail-read-response process))))
- (not (integerp (car response-code)))
- (>= (car response-code) 400))
- (throw 'done nil)
- )
-
- ;;QUIT
-; (smtpmail-send-command process "QUIT")
-; (and (null (car (smtpmail-read-response process)))
-; (throw 'done nil))
- t ))
- (if process
- (save-excursion
- (set-buffer (process-buffer process))
- (smtpmail-send-command process "QUIT")
- (smtpmail-read-response process)
-
-; (if (or (null (car (setq response-code (smtpmail-read-response process))))
-; (not (integerp (car response-code)))
-; (>= (car response-code) 400))
-; (throw 'done nil)
-; )
- (delete-process process))))))
-
-
-(defun smtpmail-process-filter (process output)
- (save-excursion
- (set-buffer (process-buffer process))
- (goto-char (point-max))
- (insert output)))
-
-(defun smtpmail-read-response (process)
- (let ((case-fold-search nil)
- (response-strings nil)
- (response-continue t)
- (return-value '(nil ()))
- match-end)
-
- (while response-continue
- (goto-char smtpmail-read-point)
- (while (not (search-forward "\r\n" nil t))
- (accept-process-output process)
- (goto-char smtpmail-read-point))
-
- (setq match-end (point))
- (setq response-strings
- (cons (buffer-substring smtpmail-read-point (- match-end 2))
- response-strings))
-
- (goto-char smtpmail-read-point)
- (if (looking-at "[0-9]+ ")
- (let ((begin (match-beginning 0))
- (end (match-end 0)))
- (if smtpmail-debug-info
- (message "%s" (car response-strings)))
-
- (setq smtpmail-read-point match-end)
-
- ;; ignore lines that start with "0"
- (if (looking-at "0[0-9]+ ")
- nil
- (setq response-continue nil)
- (setq return-value
- (cons (string-to-int
- (buffer-substring begin end))
- (nreverse response-strings)))))
-
- (if (looking-at "[0-9]+-")
- (progn (if smtpmail-debug-info
- (message "%s" (car response-strings)))
- (setq smtpmail-read-point match-end)
- (setq response-continue t))
- (progn
- (setq smtpmail-read-point match-end)
- (setq response-continue nil)
- (setq return-value
- (cons nil (nreverse response-strings)))
- )
- )))
- (setq smtpmail-read-point match-end)
- return-value))
-
-
-(defun smtpmail-send-command (process command)
- (goto-char (point-max))
- (if (= (aref command 0) ?P)
- (insert "PASS <omitted>\r\n")
- (insert command "\r\n"))
- (setq smtpmail-read-point (point))
- (process-send-string process command)
- (process-send-string process "\r\n"))
-
-(defun smtpmail-send-data-1 (process data)
- (goto-char (point-max))
-
- (if (and (multibyte-string-p data)
- smtpmail-code-conv-from)
- (setq data (string-as-multibyte
- (encode-coding-string data smtpmail-code-conv-from))))
-
- (if smtpmail-debug-info
- (insert data "\r\n"))
-
- (setq smtpmail-read-point (point))
- ;; Escape "." at start of a line
- (if (eq (string-to-char data) ?.)
- (process-send-string process "."))
- (process-send-string process data)
- (process-send-string process "\r\n")
- )
-
-(defun smtpmail-send-data (process buffer)
- (let
- ((data-continue t)
- (sending-data nil)
- this-line
- this-line-end)
-
- (save-excursion
- (set-buffer buffer)
- (goto-char (point-min)))
-
- (while data-continue
- (save-excursion
- (set-buffer buffer)
- (beginning-of-line)
- (setq this-line (point))
- (end-of-line)
- (setq this-line-end (point))
- (setq sending-data nil)
- (setq sending-data (buffer-substring this-line this-line-end))
- (if (/= (forward-line 1) 0)
- (setq data-continue nil)))
-
- (smtpmail-send-data-1 process sending-data)
- )
- )
- )
-
-
-(defun smtpmail-deduce-address-list (smtpmail-text-buffer header-start header-end)
- "Get address list suitable for smtp RCPT TO: <address>."
- (require 'mail-utils) ;; pick up mail-strip-quoted-names
-
- (unwind-protect
- (save-excursion
- (set-buffer smtpmail-address-buffer) (erase-buffer)
- (let
- ((case-fold-search t)
- (simple-address-list "")
- this-line
- this-line-end
- addr-regexp)
- (insert-buffer-substring smtpmail-text-buffer header-start header-end)
- (goto-char (point-min))
- ;; RESENT-* fields should stop processing of regular fields.
- (save-excursion
- (if (re-search-forward "^Resent-\\(to\\|cc\\|bcc\\):" header-end t)
- (setq addr-regexp "^Resent-\\(to\\|cc\\|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")
- (subst-char-in-region (point-min) (point-max) 10 ? t);; newline --> blank
- (subst-char-in-region (point-min) (point-max) ?, ? t);; comma --> blank
- (subst-char-in-region (point-min) (point-max) 9 ? t);; tab --> blank
-
- (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))
- )
- (setq smtpmail-recipient-address-list recipient-address-list))
-
- )
- )
- )
- )
-
(defun smtpmail-do-bcc (header-end)
- "Delete [Resent-]BCC: and their continuation lines from the header area.
+ "Delete BCC: and their continuation lines from the header area.
There may be multiple BCC: lines, and each may have arbitrarily
many continuation lines."
(let ((case-fold-search t))
(save-excursion
(goto-char (point-min))
;; iterate over all BCC: lines
- (while (re-search-forward "^\\(RESENT-\\)?BCC:" header-end t)
- (delete-region (match-beginning 0)
- (progn (forward-line 1) (point)))
+ (while (re-search-forward "^BCC:" header-end t)
+ (delete-region (match-beginning 0) (progn (forward-line 1) (point)))
;; get rid of any continuation lines
(while (and (looking-at "^[ \t].*\n") (< (point) header-end))
- (replace-match ""))))))
+ (replace-match ""))
+ )
+ ) ;; save-excursion
+ ) ;; let
+ )
+
+;;;
(provide 'smtpmail)
--- /dev/null
+;;; 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
--- /dev/null
+;;; 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
--- /dev/null
+;;; 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
--- /dev/null
+;;; 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
--- /dev/null
+;;; 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
--- /dev/null
+;;; 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
--- /dev/null
+;;; 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
--- /dev/null
+;;; 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
--- /dev/null
+;;; 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
--- /dev/null
+;;; 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
--- /dev/null
+;;; 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
--- /dev/null
+;;; 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.
--- /dev/null
+;;; 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.
--- /dev/null
+;;; 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.
--- /dev/null
+;;; 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.
--- /dev/null
+;;; 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-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-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.
--- /dev/null
+;;; 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
--- /dev/null
+;;; 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
--- /dev/null
+;;; 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
--- /dev/null
+;;; 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
--- /dev/null
+;;; 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
--- /dev/null
+;;; 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
--- /dev/null
+;;; 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
--- /dev/null
+;;; 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
--- /dev/null
+;;; 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
--- /dev/null
+;;; 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
--- /dev/null
+;;; 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
--- /dev/null
+;;; 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
--- /dev/null
+;;; 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
--- /dev/null
+;;; 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
--- /dev/null
+;;; 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
--- /dev/null
+;;; 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
--- /dev/null
+;;; 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
--- /dev/null
+;;; 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
--- /dev/null
+;;; 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
--- /dev/null
+;;; 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
--- /dev/null
+;;; 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
--- /dev/null
+;;; 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
--- /dev/null
+;;; 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
--- /dev/null
+;;; 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
--- /dev/null
+;;; 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
--- /dev/null
+;;; 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
--- /dev/null
+;;; 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
--- /dev/null
+;;; 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
--- /dev/null
+;;; 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
--- /dev/null
+;;; 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
--- /dev/null
+;;; 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
--- /dev/null
+;;; 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
--- /dev/null
+;;; 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
--- /dev/null
+;;; 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
--- /dev/null
+;;; 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
--- /dev/null
+;;; 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
--- /dev/null
+;;; 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
projects / elisp / lemi.git / commitdiff