+++ /dev/null
-#
-# $Id: Makefile,v 0.1 1997-03-14 07:44:00 morioka Exp $
-#
-
-VERSION = 0.70
-
-SHELL = /bin/sh
-MAKE = make
-CC = gcc
-CFLAGS = -O2
-RM = /bin/rm -f
-CP = /bin/cp -p
-EMACS = emacs
-
-GOMI = *.elc
-FLAGS = -batch -q -no-site-file
-
-PREFIX = NONE
-EXEC_PREFIX =
-
-SEMI_FILES = semi/Makefile semi/SEMI-MK semi/SEMI-CFG semi/SEMI-ELS \
- semi/*.el semi/ChangeLog
-
-MEL_FILES = mel/Makefile mel/MEL-MK mel/MEL-CFG mel/MEL-ELS \
- mel/*.el mel/ChangeLog
-
-MU_FILES = mu/Makefile mu/MU-MK mu/MU-CFG mu/MU-ELS \
- mu/*.el mu/ChangeLog
-
-APEL_FILES = apel/Makefile apel/APEL-MK apel/APEL-CFG apel/APEL-ELS \
- apel/*.el apel/ChangeLog
-
-BITMAP_FILES = bitmap-mule/Makefile bitmap-mule/BITMAP-MK \
- bitmap-mule/BITMAP-CFG bitmap-mule/BITMAP-ELS \
- bitmap-mule/*.el bitmap-mule/*.bdf \
- bitmap-mule/README.* bitmap-mule/ChangeLog
-
-EMU_FILES = emu/Makefile emu/EMU-MK emu/EMU-CFG emu/EMU-ELS \
- emu/*.el emu/ChangeLog
-
-SINFO_FILES = sinfo/Makefile sinfo/SINFO-MK \
- sinfo/SINFO-CFG sinfo/SINFO-ELS \
- sinfo/*.dtd sinfo/*.el sinfo/*-mapping sinfo/ChangeLog
-
-FILES = $(SEMI_FILES) $(MEL_FILES) $(MU_FILES) \
- $(APEL_FILES) $(BITMAP_FILES) $(EMU_FILES) $(SINFO_FILES)
-
-elc:
- $(EMACS) $(FLAGS) -l SEMI-MK -f compile-semi $(PREFIX) $(EXEC_PREFIX)
-
-install-elc: elc
- $(EMACS) $(FLAGS) -l SEMI-MK -f install-semi $(PREFIX) $(EXEC_PREFIX)
-
-
-all: $(UTILS) $(DVI) elc
-
-tex: ol2
- cd doc; $(MAKE) tex
-
-dvi: ol2
- cd doc; $(MAKE) dvi
-
-ps: ol2
- cd doc; $(MAKE) ps
-
-
-install: install-elc install-execs
-
-execs: $(UTILS)
-
-install-execs:
- $(EMACS) $(FLAGS) -l SEMI-MK -f install-execs $(PREFIX) $(EXEC_PREFIX)
-
-
-update-xemacs:
- $(EMACS) $(FLAGS) -l SEMI-MK -f update-xemacs-source
-
-
-clean:
- -$(RM) $(GOMI)
- -cd doc && $(MAKE) clean
- -cd gnus && $(MAKE) clean
- -cd mh-e && $(MAKE) clean
- cd ../mel && $(MAKE) clean
-
-
-tar:
- cd ..; gtar cvf semi-$(VERSION).tar $(FILES)
- -cd ..; mkdir semi-$(VERSION)
- cp ../semi-kernel/README.?? ../semi-$(VERSION)
- cp ../semi-kernel/Makefile ../semi-$(VERSION)
- cd ../semi-$(VERSION); gtar xvf ../semi-$(VERSION).tar
- cd ..; gtar cvzf semi-$(VERSION).tar.gz semi-$(VERSION)
- cd ..; $(RM) -r semi-$(VERSION); rm semi-$(VERSION).tar
+++ /dev/null
-;;; -*-Emacs-Lisp-*-
-;;;
-;;; $Id: SEMI-CFG,v 0.5 1997-03-12 07:49:41 morioka Exp $
-;;;
-
-(defvar default-load-path load-path)
-(setq load-path (append
- (mapcar (function
- (lambda (path)
- (expand-file-name path default-directory)
- ))
- '("." "../emu" "../apel" "../bitmap-mule"
- "../mu" "../mel")
- )
- load-path))
-
-(require 'install)
-(require 'cl)
-
-
-;;; @ Please specify optional package directory if you use them.
-;;;
-
-;; It is only necessary to use `add-path' if these packages are not
-;; already on the standard load-path of Emacs.
-
-;; Function `get-latest-path' detect latest version of such package
-;; under load-path directories. If you want to use a version of a
-;; package instead of latest version, please specify by argument of
-;; function `add-path'.
-
-;; Function `add-path' finds path under load-path directories. If a
-;; package does not exist in load-path, please specify by absolutely
-;; (`~/' is available), for example
-;; (add-path "~/lib/elisp/mailcrypt-3.4")
-;; or
-;; (add-path "/opt/share/xmule/site-lisp/mailcrypt-3.4")
-
-
-;;; @@ Please specify Mailcrypt path.
-;;;
-
-;; Use latest version installed in load-path.
-
-(let ((path (get-latest-path "mailcrypt" 'all-paths)))
- (if path
- (add-path path)
- ))
-
-;; Or please specify path.
-;; (add-path "mailcrypt-3.4" 'all-paths)
-
-
-;;; @@ Please specify BBDB path.
-;;;
-
-(let ((path (get-latest-path "bbdb" 'all-paths)))
- (if path
- (add-path path)
- ))
-
-;; Or please specify path.
-;; (add-path "bbdb-1.50" 'all-paths)
-
-
-;;; @ shell
-;;;
-
-;; Please specify shell command path.
-(setq SHELL
- (find-if (function file-exists-p)
- '("/bin/sh" "/usr/bin/sh")
- ))
-
-;; Please specify shell command option.
-(setq SHELLOPTION "-c")
-
-
-;;; @ Please specify prefix of install directory.
-;;;
-
-;; Please specify install path prefix.
-;; If it is omitted, shared directory (maybe /usr/local is used).
-(defvar PREFIX install-prefix)
-;;(setq PREFIX "~/")
-
-;; Please specify install path prefix for binaries.
-(defvar EXEC_PREFIX
- (if (or running-emacs-18 running-xemacs)
- (expand-file-name "../../.." exec-directory)
- (expand-file-name "../../../.." exec-directory)
- ))
-
-;; Please specify emu prefix [optional]
-(setq EMU_PREFIX
- (if (string-match "XEmacs" emacs-version)
- "emu"
- ""))
-
-;; Please specify SEMI prefix [optional]
-(setq SEMI_PREFIX "semi")
-
-
-;;; @ executables
-;;;
-
-;; Please specify binary path.
-(defvar BIN_DIR (expand-file-name "bin" EXEC_PREFIX))
-
-;; Please specify binary path. (for external method scripts)
-(setq METHOD_DIR (expand-file-name "share/semi" PREFIX))
-
-
-\f
-
-;;; @ optional settings
-;;;
-
-;; It is generated by automatically. Please set variable `PREFIX'.
-;; If you don't like default directory tree, please set it.
-(defvar LISPDIR (install-detect-elisp-directory PREFIX))
-;; (setq install-default-elisp-directory "~/lib/emacs/lisp")
-
-(setq SEMI_KERNEL_DIR (expand-file-name SEMI_PREFIX LISPDIR))
-(setq SETUP_FILE_DIR SEMI_KERNEL_DIR)
-
-(setq METHOD_SRC_DIR "methods")
-(setq METHODS
- '("tm-au" "tm-file" "tm-html" "tm-image" "tm-mpeg"
- "tm-plain" "tm-ps"
- "tmdecode"))
-
-;;; SEMI-CFG ends here
+++ /dev/null
-;;; -*-Emacs-Lisp-*-
-;;;
-;;; $Id: SEMI-ELS,v 0.5 1997-03-10 13:45:35 morioka Exp $
-;;;
-
-(setq semi-modules-to-compile
- '(signature
- mime-def
- eword-decode eword-encode
- mime-parse mime-view mime-text mime-play mime-partial
- mime-tar mime-file
- mime-edit
- semi-setup))
-
-(setq semi-modules-not-to-compile nil)
-
-(mapcar (function
- (lambda (cell)
- (let ((c-module (car cell))
- (i-modules (cdr cell))
- )
- (if (module-installed-p c-module)
- (setq semi-modules-to-compile
- (nconc semi-modules-to-compile i-modules))
- (setq semi-modules-not-to-compile
- (nconc semi-modules-not-to-compile i-modules))
- )
- )))
- '((mailcrypt mime-pgp mime-mc)
- (bbdb mime-bbdb)
- ))
-
-(if (or (string-match "XEmacs" emacs-version)
- (featurep 'mule))
- (setq semi-modules-to-compile
- (nconc semi-modules-to-compile '(mime-image)))
- )
-
-(setq semi-modules (append semi-modules-to-compile
- semi-modules-not-to-compile))
-
-;;; SEMI-ELS ends here
+++ /dev/null
-;;; -*-Emacs-Lisp-*-
-;;;
-;;; $Id: SEMI-MK,v 0.3 1997-03-14 07:42:44 morioka Exp $
-;;;
-
-(defun config-semi ()
- (let (prefix exec-prefix)
- (setq prefix (car command-line-args-left))
- (and prefix
- (not (string-equal "NONE" prefix))
- (progn
- (defvar PREFIX prefix)
- (setq command-line-args-left (cdr command-line-args-left))
- )
- (setq exec-prefix (car command-line-args-left))
- (progn
- (defvar EXEC_PREFIX exec-prefix)
- ;;(setq command-line-args-left (cdr command-line-args-left))
- )))
- (load-file "SEMI-CFG")
- (load-file "SEMI-ELS")
- (princ (format "PREFIX=%s\tEXEC_PREFIX=%s\n" PREFIX EXEC_PREFIX))
- )
-
-(defun directory= (dir1 dir2)
- (string= (file-name-as-directory dir1)(file-name-as-directory dir2))
- )
-
-(defun compile-semi ()
- (config-semi)
- (print load-path)
- (compile-elisp-modules semi-modules-to-compile ".")
- (compile-elisp-module 'mime-setup ".")
- )
-
-(defun install-semi ()
- (config-semi)
- (princ (format "%s\n" emacs-version))
- (install-elisp-modules semi-modules "." SEMI_KERNEL_DIR)
- (install-elisp-modules '(mime-setup) "." SETUP_FILE_DIR)
- )
-
-(defun install-execs ()
- (config-semi)
- (install-files METHODS METHOD_SRC_DIR METHOD_DIR nil t)
- )
-
-;;; SEMI-MK ends here
+++ /dev/null
-;;; eword-decode.el --- RFC 2047 based encoded-word decoder for GNU Emacs
-
-;; Copyright (C) 1995,1996,1997 Free Software Foundation, Inc.
-
-;; Author: ENAMI Tsugutomo <enami@sys.ptg.sony.co.jp>
-;; MORIOKA Tomohiko <morioka@jaist.ac.jp>
-;; Maintainer: MORIOKA Tomohiko <morioka@jaist.ac.jp>
-;; Created: 1995/10/03
-;; Original: 1992/07/20 ENAMI Tsugutomo's `mime.el'.
-;; Renamed: 1993/06/03 to tiny-mime.el
-;; Renamed: 1995/10/03 from tiny-mime.el (split off encoder)
-;; Renamed: 1997/02/22 from tm-ew-d.el
-;; Version: $Revision: 0.14 $
-;; Keywords: encoded-word, MIME, multilingual, header, mail, news
-
-;; 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 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 'std11)
-(require 'mel)
-(require 'mime-def)
-
-
-;;; @ version
-;;;
-
-(defconst eword-decode-RCS-ID
- "$Id: eword-decode.el,v 0.14 1997-02-27 08:56:45 tmorioka Exp $")
-(defconst eword-decode-version (get-version-string eword-decode-RCS-ID))
-
-
-;;; @ MIME encoded-word definition
-;;;
-
-(defconst eword-encoded-text-regexp "[!->@-~]+")
-(defconst eword-encoded-word-regexp
- (concat (regexp-quote "=?")
- "\\("
- mime-charset-regexp
- "\\)"
- (regexp-quote "?")
- "\\(B\\|Q\\)"
- (regexp-quote "?")
- "\\("
- eword-encoded-text-regexp
- "\\)"
- (regexp-quote "?=")))
-
-
-;;; @@ Base64
-;;;
-
-(defconst base64-token-regexp "[A-Za-z0-9+/]")
-(defconst base64-token-padding-regexp "[A-Za-z0-9+/=]")
-
-(defconst eword-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
-;;;
-
-(defconst quoted-printable-hex-chars "0123456789ABCDEF")
-(defconst quoted-printable-octet-regexp
- (concat "=[" quoted-printable-hex-chars
- "][" quoted-printable-hex-chars "]"))
-
-(defconst eword-Q-encoded-text-regexp
- (concat "\\([^=?]\\|" quoted-printable-octet-regexp "\\)+"))
-;; (defconst eword-Q-encoding-and-encoded-text-regexp
-;; (concat "\\(Q\\)\\?" eword-Q-encoded-text-regexp))
-
-
-;;; @ 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)
- ))
-
-
-;;; @ 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))
- )
- )))
-
-
-;;; @ for message header
-;;;
-
-(defun eword-decode-header (&optional separator)
- "Decode MIME encoded-words in header fields.
-If SEPARATOR is not nil, it is used as header separator."
- (interactive "*")
- (save-excursion
- (save-restriction
- (std11-narrow-to-header separator)
- (eword-decode-region (point-min) (point-max) t)
- )))
-
-(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))
- ))
- )))
-
-
-;;; @ encoded-word decoder
-;;;
-
-(defvar eword-warning-face nil "Face used for invalid encoded-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
- (and
- (add-text-properties 0 (length word)
- (and eword-warning-face
- (list 'face eword-warning-face))
- word)
- word)))
- ))
- 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
- (cond
- ((string-equal "B" encoding)
- (if (and (string-match eword-B-encoded-text-regexp string)
- (string-equal string (match-string 0 string)))
- (base64-decode-string string)
- (error "Invalid encoded-text %s" string)))
- ((string-equal "Q" encoding)
- (if (and (string-match eword-Q-encoded-text-regexp string)
- (string-equal string (match-string 0 string)))
- (q-encoding-decode-string string)
- (error "Invalid encoded-text %s" string)))
- (t
- (error "Invalid encoding %s" encoding)
- )))
- )
- (if dest
- (progn
- (setq dest (decode-coding-string dest cs))
- (if must-unfold
- (mapconcat (function
- (lambda (chr)
- (cond
- ((eq chr ?\n) "")
- ((eq chr ?\t) " ")
- (t (char-to-string chr)))
- ))
- (std11-unfold-string dest)
- "")
- dest)
- ))))))
-
-
-;;; @ 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 Free Software Foundation, Inc.
-
-;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
-;; Version: $Revision: 0.14 $
-;; Keywords: encoded-word, MIME, multilingual, header, mail, news
-
-;; 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 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 'emu)
-(require 'mel)
-(require 'std11)
-(require 'mime-def)
-(require 'cl)
-
-
-;;; @ version
-;;;
-
-(defconst eword-encode-RCS-ID
- "$Id: eword-encode.el,v 0.14 1997-03-06 21:23:52 morioka Exp $")
-(defconst eword-encode-version (get-version-string eword-encode-RCS-ID))
-
-
-;;; @ variables
-;;;
-
-(defvar eword-field-encoding-method-alist
- '(("X-Nsubject" . iso-2022-jp-2)
- ("Newsgroups" . 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.")
-
-(defvar eword-generate-X-Nsubject nil
- "*If it is not nil, X-Nsubject field is generated
-when Subject field is encoded by `eword-encode-header'.")
-
-(defvar eword-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-kr . "B")
- (gb2312 . "B")
- (cn-gb . "B")
- (cn-gb-2312 . "B")
- (euc-kr . "B")
- (iso-2022-jp-2 . "B")
- (iso-2022-int-1 . "B")
- ))
-
-
-;;; @ encoded-text encoder
-;;;
-
-(defun tm-eword::encode-encoded-text (charset encoding string &optional mode)
- (let ((text
- (cond ((string= encoding "B")
- (base64-encode-string string))
- ((string= encoding "Q")
- (q-encoding-encode-string string mode))
- )
- ))
- (if text
- (concat "=?" (upcase (symbol-name charset)) "?"
- encoding "?" text "?=")
- )))
-
-
-;;; @ leading char
-;;;
-
-(defun tm-eword::char-type (chr)
- (if (or (= chr 32)(= chr ?\t))
- nil
- (char-charset chr)
- ))
-
-(defun tm-eword::parse-lc-word (str)
- (let* ((chr (sref str 0))
- (lc (tm-eword::char-type chr))
- (i (char-bytes chr))
- (len (length str))
- )
- (while (and (< i len)
- (setq chr (sref str i))
- (eq lc (tm-eword::char-type chr))
- )
- (setq i (+ i (char-bytes chr)))
- )
- (cons (cons lc (substring str 0 i)) (substring str i))
- ))
-
-(defun tm-eword::split-to-lc-words (str)
- (let (ret dest)
- (while (and (not (string= str ""))
- (setq ret (tm-eword::parse-lc-word str))
- )
- (setq dest (cons (car ret) dest))
- (setq str (cdr ret))
- )
- (reverse dest)
- ))
-
-
-;;; @ word
-;;;
-
-(defun tm-eword::parse-word (lcwl)
- (let* ((lcw (car lcwl))
- (lc (car lcw))
- )
- (if (null lc)
- lcwl
- (let ((lcl (list lc))
- (str (cdr lcw))
- )
- (catch 'tag
- (while (setq lcwl (cdr lcwl))
- (setq lcw (car lcwl))
- (setq lc (car lcw))
- (if (null lc)
- (throw 'tag nil)
- )
- (if (not (memq lc lcl))
- (setq lcl (cons lc lcl))
- )
- (setq str (concat str (cdr lcw)))
- ))
- (cons (cons lcl str) lcwl)
- ))))
-
-(defun tm-eword::lc-words-to-words (lcwl)
- (let (ret dest)
- (while (setq ret (tm-eword::parse-word lcwl))
- (setq dest (cons (car ret) dest))
- (setq lcwl (cdr ret))
- )
- (reverse dest)
- ))
-
-
-;;; @ rule
-;;;
-
-(defmacro tm-eword::make-rword (text charset encoding type)
- (` (list (, text)(, charset)(, encoding)(, type))))
-(defmacro tm-eword::rword-text (rword)
- (` (car (, rword))))
-(defmacro tm-eword::rword-charset (rword)
- (` (car (cdr (, rword)))))
-(defmacro tm-eword::rword-encoding (rword)
- (` (car (cdr (cdr (, rword))))))
-(defmacro tm-eword::rword-type (rword)
- (` (car (cdr (cdr (cdr (, rword)))))))
-
-(defun tm-eword::find-charset-rule (charsets)
- (if charsets
- (let* ((charset (charsets-to-mime-charset charsets))
- (encoding (cdr (assq charset eword-charset-encoding-alist)))
- )
- (list charset encoding)
- )))
-
-(defun tm-eword::words-to-ruled-words (wl &optional mode)
- (mapcar (function
- (lambda (word)
- (let ((ret (tm-eword::find-charset-rule (car word))))
- (tm-eword::make-rword (cdr word) (car ret)(nth 1 ret) mode)
- )))
- wl))
-
-(defun tm-eword::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 (tm-eword::rword-charset c))
- (if (null (tm-eword::rword-charset b))
- (progn
- (setq a (car prev))
- (setq ac (tm-eword::rword-charset a))
- (if (and (tm-eword::rword-encoding a)
- (tm-eword::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 tm-eword::split-string (str &optional mode)
- (tm-eword::space-process
- (tm-eword::words-to-ruled-words (tm-eword::lc-words-to-words
- (tm-eword::split-to-lc-words str))
- mode)))
-
-
-;;; @ length
-;;;
-
-(defun tm-eword::encoded-word-length (rword)
- (let ((string (tm-eword::rword-text rword))
- (charset (tm-eword::rword-charset rword))
- (encoding (tm-eword::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-encoding-encoded-length string
- (tm-eword::rword-type rword))
- )))
- (if ret
- (cons (+ 7 (length (symbol-name charset)) ret) string)
- )))
-
-
-;;; @ encode-string
-;;;
-
-(defun tm-eword::encode-string-1 (column rwl)
- (let* ((rword (car rwl))
- (ret (tm-eword::encoded-word-length rword))
- string len)
- (if (null ret)
- (cond ((and (setq string (car rword))
- (<= (setq len (+ (length string) column)) 76)
- )
- (setq rwl (cdr rwl))
- )
- (t
- (setq string "\n ")
- (setq len 1)
- ))
- (cond ((and (setq len (car ret))
- (<= (+ column len) 76)
- )
- (setq string
- (tm-eword::encode-encoded-text
- (tm-eword::rword-charset rword)
- (tm-eword::rword-encoding rword)
- (cdr ret)
- (tm-eword::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 (+ p (char-bytes (sref string 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 "")
- (setq string "\n "
- len 1)
- (setq rwl (cons (cons (substring string p) (cdr rword))
- (cdr rwl)))
- (setq string
- (tm-eword::encode-encoded-text
- (tm-eword::rword-charset rword)
- (tm-eword::rword-encoding rword)
- str
- (tm-eword::rword-type rword)))
- (setq len (+ (length string) column))
- )
- )))
- )
- (list string len rwl)
- ))
-
-(defun tm-eword::encode-rwl (column rwl)
- (let (ret dest ps special str ew-f pew-f)
- (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)
- )
- (setq ret (tm-eword::encode-string-1 column rwl))
- (setq str (car ret))
- (if (eq (elt str 0) ?\n)
- (if (eq special ?\()
- (progn
- (setq dest (concat dest "\n ("))
- (setq ret (tm-eword::encode-string-1 2 rwl))
- (setq str (car ret))
- ))
- (cond ((eq special 32)
- (if (string= str "(")
- (setq ps t)
- (setq dest (concat dest " "))
- (setq ps nil)
- ))
- ((eq special ?\()
- (if ps
- (progn
- (setq dest (concat dest " ("))
- (setq ps nil)
- )
- (setq dest (concat dest "("))
- )
- )))
- (cond ((string= str " ")
- (setq special 32)
- )
- ((string= str "(")
- (setq special ?\()
- )
- (t
- (setq special nil)
- (setq dest (concat dest str))
- ))
- (setq column (nth 1 ret)
- rwl (nth 2 ret))
- )
- (list dest column)
- ))
-
-(defun tm-eword::encode-string (column str &optional mode)
- (tm-eword::encode-rwl column (tm-eword::split-string str mode))
- )
-
-
-;;; @ converter
-;;;
-
-(defun tm-eword::phrase-to-rwl (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 (tm-eword::find-charset-rule
- (find-non-ascii-charset-string str))))
- (tm-eword::make-rword
- str (car ret)(nth 1 ret) 'phrase)
- )
- )))
- )
- ((eq type 'comment)
- (setq dest
- (append dest
- '(("(" nil nil))
- (tm-eword::words-to-ruled-words
- (tm-eword::lc-words-to-words
- (tm-eword::split-to-lc-words (cdr token)))
- 'comment)
- '((")" nil nil))
- ))
- )
- (t
- (setq dest (append dest
- (tm-eword::words-to-ruled-words
- (tm-eword::lc-words-to-words
- (tm-eword::split-to-lc-words (cdr token))
- ) 'phrase)))
- ))
- (setq phrase (cdr phrase))
- )
- (tm-eword::space-process dest)
- ))
-
-(defun tm-eword::phrase-route-addr-to-rwl (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 (tm-eword::phrase-to-rwl phrase))
- (if dest
- (setq dest (append dest '((" " nil nil))))
- )
- (append
- dest
- (list (list (concat "<" (std11-addr-to-string route) ">") nil nil))
- ))))
-
-(defun tm-eword::addr-spec-to-rwl (addr-spec)
- (if (eq (car addr-spec) 'addr-spec)
- (list (list (std11-addr-to-string (cdr addr-spec)) nil nil))
- ))
-
-(defun tm-eword::mailbox-to-rwl (mbox)
- (let ((addr (nth 1 mbox))
- (comment (nth 2 mbox))
- dest)
- (setq dest (or (tm-eword::phrase-route-addr-to-rwl addr)
- (tm-eword::addr-spec-to-rwl addr)
- ))
- (if comment
- (setq dest
- (append dest
- '((" " nil nil)
- ("(" nil nil))
- (tm-eword::split-string comment 'comment)
- '((")" nil nil))
- )))
- dest))
-
-(defun tm-eword::addresses-to-rwl (addresses)
- (let ((dest (tm-eword::mailbox-to-rwl (car addresses))))
- (if dest
- (while (setq addresses (cdr addresses))
- (setq dest (append dest
- '(("," nil nil))
- '((" " nil nil))
- (tm-eword::mailbox-to-rwl (car addresses))
- ))
- ))
- dest))
-
-(defun tm-eword::encode-address-list (column str)
- (tm-eword::encode-rwl
- column
- (tm-eword::addresses-to-rwl (std11-parse-addresses-string str))
- ))
-
-
-;;; @ application interfaces
-;;;
-
-(defun eword-encode-field (str)
- (setq str (std11-unfold-string str))
- (let ((ret (string-match std11-field-head-regexp str)))
- (or (if ret
- (let ((field-name (substring str 0 (1- (match-end 0))))
- (field-body (eliminate-top-spaces
- (substring str (match-end 0))))
- fname)
- (if (setq ret
- (cond ((string-equal field-body "") "")
- ((member (setq fname (downcase field-name))
- '("reply-to" "from" "sender"
- "resent-reply-to" "resent-from"
- "resent-sender" "to" "resent-to"
- "cc" "resent-cc"
- "bcc" "resent-bcc" "dcc")
- )
- (car (tm-eword::encode-address-list
- (+ (length field-name) 2) field-body))
- )
- (t
- (car (tm-eword::encode-string
- (+ (length field-name) 1)
- field-body 'text))
- ))
- )
- (concat field-name ": " ret)
- )))
- (car (tm-eword::encode-string 0 str))
- )))
-
-(defun eword-in-subject-p ()
- (let ((str (std11-field-body "Subject")))
- (if (and str (string-match eword-encoded-word-regexp str))
- str)))
-
-(defun eword-encode-header (&optional code-conversion)
- "Encode header fields to network representation, such as MIME encoded-word.
-
-It refer variable `eword-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))
- beg end field-name)
- (while (re-search-forward std11-field-head-regexp nil t)
- (setq beg (match-beginning 0))
- (setq field-name (buffer-substring beg (1- (match-end 0))))
- (setq end (std11-field-end))
- (and (find-non-ascii-charset-region beg end)
- (let ((ret (or (let ((fname (downcase field-name)))
- (assoc-if
- (function
- (lambda (str)
- (and (stringp str)
- (string= fname (downcase str))
- )))
- eword-field-encoding-method-alist))
- (assq t eword-field-encoding-method-alist)
- )))
- (if ret
- (let ((method (cdr ret)))
- (cond ((eq method 'mime)
- (let ((field
- (buffer-substring-no-properties beg end)
- ))
- (delete-region beg end)
- (insert (eword-encode-field field))
- ))
- (code-conversion
- (let ((cs
- (or (mime-charset-to-coding-system
- method)
- default-cs)))
- (encode-coding-region beg end cs)
- )))
- ))
- ))
- ))
- (and eword-generate-X-Nsubject
- (or (std11-field-body "X-Nsubject")
- (let ((str (eword-in-subject-p)))
- (if str
- (progn
- (setq str
- (eword-decode-string
- (std11-unfold-string str)))
- (if code-conversion
- (setq str
- (encode-mime-charset-string
- str
- (or (cdr (assoc-if
- (function
- (lambda (str)
- (and (stringp str)
- (string= "x-nsubject"
- (downcase str))
- )))
- eword-field-encoding-method-alist))
- 'iso-2022-jp-2)))
- )
- (insert (concat "\nX-Nsubject: " str))
- )))))
- )))
-
-(defun eword-encode-string (str &optional column mode)
- (car (tm-eword::encode-rwl (or column 0) (tm-eword::split-string str mode)))
- )
-
-
-;;; @ end
-;;;
-
-(provide 'eword-encode)
-
-;;; eword-encode.el ends here
+++ /dev/null
-;;; mime-bbdb.el --- SEMI shared module for BBDB
-
-;; Copyright (C) 1995,1996 Shuhei KOBAYASHI
-;; Copyright (C) 1996 Artur Pioro
-;; Copyright (C) 1997 MORIOKA Tomohiko
-
-;; Author: Shuhei KOBAYASHI <shuhei-k@jaist.ac.jp>
-;; Artur Pioro <artur@flugor.if.uj.edu.pl>
-;; Maintainer: Shuhei KOBAYASHI <shuhei-k@jaist.ac.jp>
-;; Version: $Id: mime-bbdb.el,v 0.2 1997-03-03 19:02:54 morioka Exp $
-;; Keywords: BBDB, MIME, multimedia, multilingual, mail, news
-
-;; 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 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 'file-detect)
-(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::article/preview-buffer
- (get-buffer mime::article/preview-buffer))
- (set-buffer mime::article/preview-buffer))
- (if bbdb-use-pop-up
- (mime-bbdb/pop-up-bbdb-buffer offer-to-create)
- (let* ((from (std11-field-body "From"))
- (addr (if from
- (car (cdr (mail-extract-address-components from))))))
- (if (or (null from)
- (null addr)
- (string-match (bbdb-user-mail-names) addr))
- (setq from (or (std11-field-body "To") from))
- )
- (if from
- (bbdb-annotate-message-sender
- 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-def.el --- definition module for SEMI
-
-;; Copyright (C) 1995,1996,1997 Free Software Foundation, Inc.
-
-;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
-;; Version: $Id: mime-def.el,v 0.43 1997-03-10 15:16:26 morioka Exp $
-;; Keywords: definition, MIME, multimedia, mail, news
-
-;; 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 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 'cl)
-(require 'emu)
-
-
-;;; @ variables
-;;;
-
-(defvar mime/use-multi-frame
- (and (>= emacs-major-version 19) window-system))
-
-(defvar mime/find-file-function
- (if mime/use-multi-frame
- (function find-file-other-frame)
- (function find-file)
- ))
-
-(defvar mime/output-buffer-window-is-shared-with-bbdb t
- "*If t, mime/output-buffer window is shared with BBDB window.")
-
-
-;;; @ constants
-;;;
-
-(defconst mime/output-buffer-name "*MIME-out*")
-(defconst mime/temp-buffer-name " *MIME-temp*")
-
-
-;;; @ definitions about MIME
-;;;
-
-(defconst mime/tspecials "][\000-\040()<>@,\;:\\\"/?.=")
-(defconst mime/token-regexp (concat "[^" mime/tspecials "]+"))
-(defconst mime-charset-regexp mime/token-regexp)
-
-(defconst mime/content-type-subtype-regexp
- (concat mime/token-regexp "/" mime/token-regexp))
-
-(defconst mime/disposition-type-regexp mime/token-regexp)
-
-
-;;; @ button
-;;;
-
-(if running-xemacs
- (require 'overlay)
- )
-
-(defvar mime-button-face 'bold
- "Face used for content-button or URL-button of MIME-Preview buffer.")
-
-(defvar mime-button-mouse-face 'highlight
- "Face used for MIME-preview buffer mouse highlighting.")
-
-(defun mime-add-button (from to func &optional data)
- "Create a button between FROM and TO with callback FUNC and data DATA."
- (and mime-button-face
- (overlay-put (make-overlay from to) 'face mime-button-face))
- (add-text-properties from to
- (nconc
- (and mime-button-mouse-face
- (list 'mouse-face mime-button-mouse-face))
- (list 'mime-button-callback func)
- (and data (list 'mime-button-data 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)
- )
- ))))
-
-
-;;; @ PGP
-;;;
-
-(defvar pgp-function-alist
- '(
- ;; for mime-pgp
- (verify mc-verify "mc-toplev")
- (decrypt mc-decrypt "mc-toplev")
- (fetch-key mc-pgp-fetch-key "mc-pgp")
- (snarf-keys mc-snarf-keys "mc-toplev")
- ;; for mime-edit
- (mime-sign mime-mc-pgp-sign-region "mime-mc")
- (traditional-sign mc-pgp-sign-region "mc-pgp")
- (encrypt mime-mc-pgp-encrypt-region "mime-mc")
- (insert-key mc-insert-public-key "mc-toplev")
- )
- "Alist of service names vs. corresponding functions and its filenames.
-Each element looks like (SERVICE FUNCTION FILE).
-
-SERVICE is a symbol of PGP processing. It allows `verify', `decrypt',
-`fetch-key', `snarf-keys', `mime-sign', `traditional-sign', `encrypt'
-or `insert-key'.
-
-Function is a symbol of function to do specified SERVICE.
-
-FILE is string of filename which has definition of corresponding
-FUNCTION.")
-
-(defmacro pgp-function (method)
- "Return function to do service METHOD."
- (` (car (cdr (assq (, method) (symbol-value 'pgp-function-alist)))))
- )
-
-(mapcar (function
- (lambda (method)
- (autoload (second method)(third method))
- ))
- pgp-function-alist)
-
-
-;;; @ method selector kernel
-;;;
-
-(require 'atype)
-
-;;; @@ field unifier
-;;;
-
-(defun field-unifier-for-mode (a b)
- (let ((va (cdr a)))
- (if (if (consp va)
- (member (cdr b) va)
- (equal va (cdr b))
- )
- (list nil b nil)
- )))
-
-
-;;; @ rot13-47
-;;;
-;; caesar-region written by phr@prep.ai.mit.edu Nov 86
-;; modified by tower@prep Nov 86
-;; gnus-caesar-region
-;; Modified by umerin@flab.flab.Fujitsu.JUNET for ROT47.
-(defun tm:caesar-region (&optional n)
- "Caesar rotation of region by N, default 13, for decrypting netnews.
-ROT47 will be performed for Japanese text in any case."
- (interactive (if current-prefix-arg ; Was there a prefix arg?
- (list (prefix-numeric-value current-prefix-arg))
- (list nil)))
- (cond ((not (numberp n)) (setq n 13))
- (t (setq n (mod n 26)))) ;canonicalize N
- (if (not (zerop n)) ; no action needed for a rot of 0
- (progn
- (if (or (not (boundp 'caesar-translate-table))
- (/= (aref caesar-translate-table ?a) (+ ?a n)))
- (let ((i 0) (lower "abcdefghijklmnopqrstuvwxyz") upper)
- (message "Building caesar-translate-table...")
- (setq caesar-translate-table (make-vector 256 0))
- (while (< i 256)
- (aset caesar-translate-table i i)
- (setq i (1+ i)))
- (setq lower (concat lower lower) upper (upcase lower) i 0)
- (while (< i 26)
- (aset caesar-translate-table (+ ?a i) (aref lower (+ i n)))
- (aset caesar-translate-table (+ ?A i) (aref upper (+ i n)))
- (setq i (1+ i)))
- ;; ROT47 for Japanese text.
- ;; Thanks to ichikawa@flab.fujitsu.junet.
- (setq i 161)
- (let ((t1 (logior ?O 128))
- (t2 (logior ?! 128))
- (t3 (logior ?~ 128)))
- (while (< i 256)
- (aset caesar-translate-table i
- (let ((v (aref caesar-translate-table i)))
- (if (<= v t1) (if (< v t2) v (+ v 47))
- (if (<= v t3) (- v 47) v))))
- (setq i (1+ i))))
- (message "Building caesar-translate-table...done")))
- (let ((from (region-beginning))
- (to (region-end))
- (i 0) str len)
- (setq str (buffer-substring from to))
- (setq len (length str))
- (while (< i len)
- (aset str i (aref caesar-translate-table (aref str i)))
- (setq i (1+ i)))
- (goto-char from)
- (delete-region from to)
- (insert str)))))
-
-
-;;; @ field
-;;;
-
-(defsubst regexp-or (&rest args)
- (concat "\\(" (mapconcat (function identity) args "\\|") "\\)"))
-
-(defun tm:set-fields (sym field-list &optional regexp-sym)
- (or regexp-sym
- (setq regexp-sym
- (let ((name (symbol-name sym)))
- (intern
- (concat (if (string-match "\\(.*\\)-list" name)
- (substring name 0 (match-end 1))
- name)
- "-regexp")
- )))
- )
- (set sym field-list)
- (set regexp-sym
- (concat "^" (apply (function regexp-or) field-list) ":"))
- )
-
-(defun tm:add-fields (sym field-list &optional regexp-sym)
- (or regexp-sym
- (setq regexp-sym
- (let ((name (symbol-name sym)))
- (intern
- (concat (if (string-match "\\(.*\\)-list" name)
- (substring name 0 (match-end 1))
- name)
- "-regexp")
- )))
- )
- (let ((fields (eval sym)))
- (mapcar (function
- (lambda (field)
- (or (member field fields)
- (setq fields (cons field fields))
- )
- ))
- (reverse field-list)
- )
- (set regexp-sym
- (concat "^" (apply (function regexp-or) fields) ":"))
- (set sym fields)
- ))
-
-(defun tm:delete-fields (sym field-list &optional regexp-sym)
- (or regexp-sym
- (setq regexp-sym
- (let ((name (symbol-name sym)))
- (intern
- (concat (if (string-match "\\(.*\\)-list" name)
- (substring name 0 (match-end 1))
- name)
- "-regexp")
- )))
- )
- (let ((fields (eval sym)))
- (mapcar (function
- (lambda (field)
- (setq fields (delete field fields))
- ))
- field-list)
- (set regexp-sym
- (concat "^" (apply (function regexp-or) fields) ":"))
- (set sym fields)
- ))
-
-
-;;; @ RCS version
-;;;
-
-(defsubst get-version-string (id)
- "Return a version-string from RCS ID."
- (and (string-match ",v \\([0-9][0-9.][0-9.]+\\)" id)
- (substring id (match-beginning 1)(match-end 1))
- ))
-
-
-;;; @ Other Utility
-;;;
-
-(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 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)
- ))
-
-
-;;; @ end
-;;;
-
-(provide 'mime-def)
-
-;;; mime-def.el ends here
+++ /dev/null
-;;; mime-edit.el --- Simple MIME Composer for GNU Emacs
-
-;; Copyright (C) 1993,1994,1995,1996,1997 Free Software Foundation, Inc.
-
-;; Author: UMEDA Masanobu <umerin@mse.kyutech.ac.jp>
-;; MORIOKA Tomohiko <morioka@jaist.ac.jp>
-;; Maintainer: MORIOKA Tomohiko <morioka@jaist.ac.jp>
-;; Created: 1994/08/21 renamed from mime.el
-;; Renamed: 1997/2/21 from tm-edit.el
-;; Version: $Revision: 0.72 $
-;; Keywords: MIME, multimedia, multilingual, mail, news
-
-;; 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 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 'emu)
-(require 'sendmail)
-(require 'mail-utils)
-(require 'mel)
-(require 'mime-view)
-(require 'eword-encode)
-(require 'signature)
-(require 'alist)
-
-
-;;; @ version
-;;;
-
-(defconst mime-edit-RCS-ID
- "$Id: mime-edit.el,v 0.72 1997-03-14 06:09:23 morioka Exp $")
-
-(defconst mime-edit-version (get-version-string mime-edit-RCS-ID))
-
-(defconst mime-edit-version-name
- (concat "SEMI MIME-Edit " mime-edit-version))
-
-
-;;; @ variables
-;;;
-
-(defvar mime-ignore-preceding-spaces nil
- "*Ignore preceding white spaces if non-nil.")
-
-(defvar mime-ignore-trailing-spaces nil
- "*Ignore trailing white spaces if non-nil.")
-
-(defvar 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.")
-
-(defvar mime-auto-hide-body t
- "*Hide non-textual body encoded in base64 after insertion if non-nil.")
-
-(defvar mime-edit-voice-recorder
- (function mime-edit-voice-recorder-for-sun)
- "*Function to record a voice message and encode it. [mime-edit.el]")
-
-(defvar mime-edit-mode-hook nil
- "*Hook called when enter MIME mode.")
-
-(defvar 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.")
-
-(defvar mime-edit-exit-hook nil
- "*Hook called when exit MIME mode.")
-
-(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")
- )
- ("richtext"
- ;;("charset" "" "ISO-2022-JP" "US-ASCII" "ISO-8859-1" "ISO-8859-8")
- )
- ("enriched"
- ;;("charset" "" "ISO-2022-JP" "US-ASCII" "ISO-8859-1" "ISO-8859-8")
- )
- ("x-latex"
- ;;("charset" "" "ISO-2022-JP" "US-ASCII" "ISO-8859-1" "ISO-8859-8")
- )
- ("html"
- ;;("charset" "" "ISO-2022-JP" "US-ASCII" "ISO-8859-1" "ISO-8859-8")
- )
- ("x-rot13-47")
- )
- ("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"))
- ))
- ("rfc822")
- )
- ("application"
- ("octet-stream" ("type" "" "tar" "shar"))
- ("postscript")
- ("x-kiss" ("x-cnf")))
- ("image"
- ("gif")
- ("jpeg")
- ("tiff")
- ("x-pic")
- ("x-mag")
- ("x-xwd")
- ("x-xbm")
- )
- ("audio" ("basic"))
- ("video" ("mpeg"))
- )
- "*Alist of content-type, subtype, parameters and its values.")
-
-(defvar mime-file-types
- '(("\\.rtf$"
- "text" "richtext" nil
- nil
- nil nil)
- ("\\.html$"
- "text" "html" nil
- nil
- nil nil)
- ("\\.ps$"
- "application" "postscript" nil
- "quoted-printable"
- "attachment" (("filename" . file))
- )
- ("\\.jpg$"
- "image" "jpeg" nil
- "base64"
- "inline" (("filename" . file))
- )
- ("\\.gif$"
- "image" "gif" 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))
- )
- ("\\.el$"
- "application" "octet-stream" (("type" . "emacs-lisp"))
- "7bit"
- "attachment" (("filename" . file))
- )
- ("\\.lsp$"
- "application" "octet-stream" (("type" . "common-lisp"))
- "7bit"
- "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))
- )
- ("\\.diff$"
- "application" "octet-stream" (("type" . "patch"))
- nil
- "attachment" (("filename" . file))
- )
- ("\\.patch$"
- "application" "octet-stream" (("type" . "patch"))
- nil
- "attachment" (("filename" . file))
- )
- ("\\.signature"
- "text" "plain" nil nil)
- (".*"
- "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.")
-
-
-;;; @@ 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-kr 7 "base64")
- (euc-kr 8 "base64")
- (cn-gb2312 8 "quoted-printable")
- (cn-big5 8 "base64")
- (gb2312 8 "quoted-printable")
- (big5 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)
-
-(defun mime-make-charset-default-encoding-alist (transfer-level)
- (mapcar (function
- (lambda (charset-type)
- (let ((charset (car charset-type))
- (type (nth 1 charset-type))
- (encoding (nth 2 charset-type))
- )
- (if (<= type transfer-level)
- (cons charset (mime-encoding-name type))
- (cons charset encoding)
- ))))
- mime-charset-type-list))
-
-(defvar mime-edit-charset-default-encoding-alist
- (mime-make-charset-default-encoding-alist mime-transfer-level))
-(make-variable-buffer-local 'mime-edit-charset-default-encoding-alist)
-
-
-;;; @@ 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. [mime-edit.el]")
-
-(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
-;;;
-
-(defvar mime-edit-split-message t
- "*Split large message if it is non-nil. [mime-edit.el]")
-
-(defvar mime-edit-message-default-max-lines 1000
- "*Default maximum lines of a message. [mime-edit.el]")
-
-(defvar 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. [mime-edit.el]")
-
-(defconst mime-edit-split-ignored-field-regexp
- "\\(^Content-\\|^Subject:\\|^Mime-Version:\\)")
-
-(defvar mime-edit-split-blind-field-regexp
- "\\(^[BDFbdf]cc:\\|^cc:[ \t]*$\\)")
-
-(defvar mime-edit-split-message-sender-alist nil)
-
-(defvar mime-edit-news-reply-mode-server-running nil)
-
-
-;;; @@ about PGP
-;;;
-
-(defvar mime-edit-signing-type 'pgp-elkins
- "*PGP signing type (pgp-elkins, pgp-kazu or nil). [mime-edit.el]")
-
-(defvar mime-edit-encrypting-type 'pgp-elkins
- "*PGP encrypting type (pgp-elkins, pgp-kazu or nil). [mime-edit.el]")
-
-
-;;; @@ 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-x-emacs-field t
- "*If non-nil, insert X-Emacs header field.")
-
-(defvar mime-edit-x-emacs-value
- (if running-xemacs
- (concat emacs-version
- (if (featurep 'mule)
- " with mule"
- " without mule"))
- (let ((ver (if (string-match "\\.[0-9]+$" emacs-version)
- (substring emacs-version 0 (match-beginning 0))
- emacs-version)))
- (if (featurep 'mule)
- (concat "Emacs " ver ", MULE " mule-version)
- ver))))
-
-\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-name ")")
- "MIME version number.")
-
-
-;;; @ keymap and menu
-;;;
-
-(defvar mime-edit-mode-flag nil)
-(make-variable-buffer-local 'mime-edit-mode-flag)
-
-(defvar mime-edit-mode-map (make-sparse-keymap)
- "Keymap for MIME-Edit mode commands.")
-
-(define-key mime-edit-mode-map
- "\C-c\C-x\C-t" 'mime-edit-insert-text)
-(define-key mime-edit-mode-map
- "\C-c\C-x\C-i" 'mime-edit-insert-file)
-(define-key mime-edit-mode-map
- "\C-c\C-x\C-e" 'mime-edit-insert-external)
-(define-key mime-edit-mode-map
- "\C-c\C-x\C-v" 'mime-edit-insert-voice)
-(define-key mime-edit-mode-map
- "\C-c\C-x\C-y" 'mime-edit-insert-message)
-(define-key mime-edit-mode-map
- "\C-c\C-x\C-m" 'mime-edit-insert-mail)
-(define-key mime-edit-mode-map
- "\C-c\C-x\C-w" 'mime-edit-insert-signature)
-(define-key mime-edit-mode-map
- "\C-c\C-x\C-s" 'mime-edit-insert-signature)
-(define-key mime-edit-mode-map
- "\C-c\C-x\C-k" 'mime-edit-insert-key)
-(define-key mime-edit-mode-map
- "\C-c\C-xt" 'mime-edit-insert-tag)
-
-(define-key mime-edit-mode-map
- "\C-c\C-m\C-a" 'mime-edit-enclose-alternative-region)
-(define-key mime-edit-mode-map
- "\C-c\C-m\C-p" 'mime-edit-enclose-parallel-region)
-(define-key mime-edit-mode-map
- "\C-c\C-m\C-m" 'mime-edit-enclose-mixed-region)
-(define-key mime-edit-mode-map
- "\C-c\C-m\C-d" 'mime-edit-enclose-digest-region)
-(define-key mime-edit-mode-map
- "\C-c\C-m\C-s" 'mime-edit-enclose-signed-region)
-(define-key mime-edit-mode-map
- "\C-c\C-m\C-e" 'mime-edit-enclose-encrypted-region)
-(define-key mime-edit-mode-map
- "\C-c\C-m\C-q" 'mime-edit-enclose-quote-region)
-
-(define-key mime-edit-mode-map
- "\C-c\C-x7" 'mime-edit-set-transfer-level-7bit)
-(define-key mime-edit-mode-map
- "\C-c\C-x8" 'mime-edit-set-transfer-level-8bit)
-(define-key mime-edit-mode-map
- "\C-c\C-x/" 'mime-edit-set-split)
-(define-key mime-edit-mode-map
- "\C-c\C-xs" 'mime-edit-set-sign)
-(define-key mime-edit-mode-map
- "\C-c\C-xv" 'mime-edit-set-sign)
-(define-key mime-edit-mode-map
- "\C-c\C-xe" 'mime-edit-set-encrypt)
-(define-key mime-edit-mode-map
- "\C-c\C-xh" 'mime-edit-set-encrypt)
-(define-key mime-edit-mode-map
- "\C-c\C-x\C-p" 'mime-edit-preview-message)
-(define-key mime-edit-mode-map
- "\C-c\C-x\C-z" 'mime-edit-exit)
-(define-key mime-edit-mode-map
- "\C-c\C-x?" 'mime-edit-help)
-
-(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-signed-region)
- (encrypted "Enclose as encrypted" mime-edit-enclose-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 (running-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 Emacs 19."
- (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
-;;;
-
-;;;###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-signed-region] enclose as PGP signed.
-\\[mime-edit-enclose-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 (and (boundp 'mime-edit-touched-flag)
- 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 (running-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 running-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 running-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 ()
- "Insert a text message.
-Charset is automatically obtained from the `charsets-mime-charset-alist'."
- (interactive)
- (let ((ret (mime-edit-insert-tag "text" nil nil)))
- (if ret
- (progn
- (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 (second ret) '("enriched" "richtext"))
- (fboundp 'enriched-mode)
- )
- (enriched-mode t)
- (if (boundp 'enriched-mode)
- (enriched-mode nil)
- ))))))
-
-(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-file-encoding-method-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 ()
- (apply (function mime-edit-insert-tag)
- (mime-find-file-type signature-file-name))
- )))
- )
- (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)) multipart)
- (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
- (let ((beg (point)))
- (if (mime-edit-goto-tag)
- (let ((top (point)))
- (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" (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. [mime-edit.el]"
- (let (encoding)
- (while (string=
- (setq encoding
- (completing-read
- "What transfer encoding: "
- mime-file-encoding-method-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."
- (eword-encode-header '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)
- (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 ee)
- (setq end-exp (format "--}-<<%s>>\n" type))
- (widen)
- (if (re-search-forward end-exp nil t)
- (progn
- (setq eb (match-beginning 0))
- (setq ee (match-end 0))
- )
- (setq eb (point-max))
- (setq ee (point-max))
- )
- (narrow-to-region be eb)
- (goto-char be)
- (if (re-search-forward mime-edit-multipart-beginning-regexp nil t)
- (let (ret)
- (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 "signed")
- (cond ((eq mime-edit-signing-type 'pgp-elkins)
- (mime-edit-sign-pgp-elkins bb eb boundary)
- )
- ((eq mime-edit-signing-type 'pgp-kazu)
- (mime-edit-sign-pgp-kazu bb eb boundary)
- ))
- )
- ((string-equal type "encrypted")
- (cond ((eq mime-edit-encrypting-type 'pgp-elkins)
- (mime-edit-encrypt-pgp-elkins bb eb boundary)
- )
- ((eq mime-edit-encrypting-type 'pgp-kazu)
- (mime-edit-encrypt-pgp-kazu 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)))
- )))))
-
-(defun mime-edit-sign-pgp-elkins (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))
- (parts (nth 3 ret))
- (pgp-boundary (concat "pgp-sign-" boundary))
- )
- (goto-char beg)
- (insert (format "Content-Type: %s\n" ctype))
- (if encoding
- (insert (format "Content-Transfer-Encoding: %s\n" encoding))
- )
- (insert "\n")
- (or (funcall (pgp-function 'mime-sign)
- (point-min)(point-max) nil nil pgp-boundary)
- (throw 'mime-edit-error 'pgp-error)
- )
- ))))
-
-(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-elkins (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))
- (parts (nth 3 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")
- (or (funcall (pgp-function 'encrypt)
- recipients (point-min) (point-max) from)
- (throw 'mime-edit-error 'pgp-error)
- )
- (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))
- (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))
- (parts (nth 3 ret))
- )
- (goto-char beg)
- (insert (format "Content-Type: %s\n" ctype))
- (if encoding
- (insert (format "Content-Transfer-Encoding: %s\n" encoding))
- )
- (insert "\n")
- (or (as-binary-process
- (funcall (pgp-function 'traditional-sign)
- beg (point-max)))
- (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 (from recipients header)
- (let ((ret (mime-edit-make-encrypt-recipient-header)))
- (setq from (aref ret 0)
- 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))
- (parts (nth 3 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 (as-binary-process
- (funcall (pgp-function 'encrypt)
- recipients beg (point-max) nil 'maybe)
- )
- (throw 'mime-edit-error 'pgp-error)
- )
- (goto-char beg)
- (insert
- "--[[application/pgp; format=mime][7bit]]\n")
- ))
- )))
-
-(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 X-Emacs field
- (and mime-edit-insert-x-emacs-field
- (or (mail-position-on-field "X-Emacs")
- (insert mime-edit-x-emacs-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 (&optional prefix)
- (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)
- (setq contype (mime-edit-get-contype tag))
- (setq 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"))
- (eword-encode-header)
- )
- t)))
-
-(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))
- (and (mime-edit-translate-single-part-tag)
- (while (mime-edit-translate-single-part-tag "\n"))
- )
- ;; Define Content-Type as "multipart/mixed".
- (setq contype
- (concat "multipart/mixed;\n boundary=\"" boundary "\""))
- ;; Content-Transfer-Encoding must be "7bit".
- ;; The following encoding can be `nil', but is
- ;; specified as is since there is no way that a user
- ;; specifies it.
- (setq encoding "7bit")
- ;; 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")
- (save-excursion
- (forward-line)
- (set-mark (point))
- (goto-char (mime-edit-content-end))
- (tm:caesar-region)
- ))
- ((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)
- (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
- (cdr
- (assq charset
- mime-edit-charset-default-encoding-alist)
- ))
- (beg (mime-edit-content-beginning))
- )
- (encode-mime-charset-region beg (mime-edit-content-end)
- charset)
- (mime-encode-region beg (mime-edit-content-end) encoding)
- (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))
- (body (buffer-substring beg 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)
- (progn (forward-line 1) (point)))
- )))
-
-\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. [mime-edit.el]"
- (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 (type beg end)
- (save-excursion
- (goto-char beg)
- (let ((current (point)))
- (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 "quote" beg end)
- )
-
-(defun mime-edit-enclose-mixed-region (beg end)
- (interactive "*r")
- (mime-edit-enclose-region "mixed" beg end)
- )
-
-(defun mime-edit-enclose-parallel-region (beg end)
- (interactive "*r")
- (mime-edit-enclose-region "parallel" beg end)
- )
-
-(defun mime-edit-enclose-digest-region (beg end)
- (interactive "*r")
- (mime-edit-enclose-region "digest" beg end)
- )
-
-(defun mime-edit-enclose-alternative-region (beg end)
- (interactive "*r")
- (mime-edit-enclose-region "alternative" beg end)
- )
-
-(defun mime-edit-enclose-signed-region (beg end)
- (interactive "*r")
- (if mime-edit-signing-type
- (mime-edit-enclose-region "signed" beg end)
- (message "Please specify signing type.")
- ))
-
-(defun mime-edit-enclose-encrypted-region (beg end)
- (interactive "*r")
- (if mime-edit-signing-type
- (mime-edit-enclose-region "encrypted" beg end)
- (message "Please specify encrypting type.")
- ))
-
-(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")
- (funcall (pgp-function 'insert-key))
- )
-
-
-;;; @ 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)
- ))
- (setq mime-edit-charset-default-encoding-alist
- (mime-make-charset-default-encoding-alist mime-transfer-level))
- (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
-;;;
-
-(defun mime-edit-set-sign (arg)
- (interactive
- (list
- (y-or-n-p "Do you want to sign?")
- ))
- (if arg
- (if mime-edit-signing-type
- (progn
- (setq mime-edit-pgp-processing 'sign)
- (message "This message will be signed.")
- )
- (message "Please specify signing type.")
- )
- (if (eq mime-edit-pgp-processing 'sign)
- (setq mime-edit-pgp-processing nil)
- )
- (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
- (if mime-edit-encrypting-type
- (progn
- (setq mime-edit-pgp-processing 'encrypt)
- (message "This message will be encrypt.")
- )
- (message "Please specify encrypting type.")
- )
- (if (eq mime-edit-pgp-processing 'encrypt)
- (setq mime-edit-pgp-processing nil)
- )
- (message "This message will not be encrypt.")
- ))
-
-(defvar mime-edit-pgp-processing nil)
-(make-variable-buffer-local 'mime-edit-pgp-processing)
-
-(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)
- )))
- (end (point-max))
- )
- (if beg
- (cond ((eq mime-edit-pgp-processing 'sign)
- (mime-edit-enclose-signed-region beg end)
- )
- ((eq mime-edit-pgp-processing 'encrypt)
- (mime-edit-enclose-encrypted-region beg end)
- ))
- )))
-
-
-;;; @ 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 (format "Mime-Version: 1.0 (split by %s)\n"
- mime-edit-version-name))
- (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" mime-temp-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. [mime-edit.el]"
- (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))
- )
- (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)
-
- (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-mode)
- ))
-
-(defun mime-edit-quitting-method ()
- (let ((temp mime::preview/article-buffer)
- buf)
- (mime-view-kill-buffer)
- (set-buffer temp)
- (setq buf mime-edit-buffer)
- (kill-buffer temp)
- (switch-to-buffer buf)
- ))
-
-(set-alist 'mime-view-quitting-method-alist
- 'mime-temp-message-mode
- (function mime-edit-quitting-method)
- )
-
-
-;;; @ edit again
-;;;
-
-(defvar mime-edit-again-ignored-field-regexp
- (concat "^\\(" "Content-.*\\|Mime-Version"
- (if mime-edit-insert-x-emacs-field "\\|X-Emacs")
- "\\):")
- "Regexp for deleted header fields when `mime-edit-again' is called.")
-
-(defun mime-edit-decode-buffer (not-decode-text)
- (save-excursion
- (goto-char (point-min))
- (let ((ctl (mime/Content-Type)))
- (if ctl
- (let ((ctype (car ctl))
- (params (cdr ctl))
- type stype)
- (if (string-match "/" ctype)
- (progn
- (setq type (substring ctype 0 (match-beginning 0)))
- (setq stype (substring ctype (match-end 0)))
- )
- (setq type ctype)
- )
- (cond
- ((string= ctype "application/pgp-signature")
- (delete-region (point-min)(point-max))
- )
- ((string= type "multipart")
- (let* ((boundary (cdr (assoc "boundary" params)))
- (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" stype))
- (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" stype))
- (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)
- (mime-edit-decode-buffer 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)
- )))
- ))
- (t
- (let* (charset
- (pstr
- (let ((bytes (+ 14 (length ctype))))
- (mapconcat (function
- (lambda (attr)
- (if (string-equal (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)
- )
- ))))
- params "")))
- encoding
- encoded)
- (save-excursion
- (if (re-search-forward
- "Content-Transfer-Encoding:" nil t)
- (let ((beg (match-beginning 0))
- (hbeg (match-end 0))
- (end (std11-field-end)))
- (setq encoding
- (eliminate-top-spaces
- (std11-unfold-string
- (buffer-substring hbeg end))))
- (if (or charset (string-equal 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))
- (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 (= (point-min) 1)
- (progn
- (goto-char he)
- (insert
- (concat "\n"
- (mime-create-tag
- (concat type "/" stype pstr) encoding)))
- )
- (delete-region (point-min) he)
- (insert
- (mime-create-tag
- (concat type "/" stype pstr) encoding))
- ))
- ))))
- (or not-decode-text
- (decode-mime-charset-region (point-min) (point-max)
- default-mime-charset)
- )
- ))))
-
-(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-buffer not-decode-text)
- (goto-char (point-min))
- (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)))
- ))
- (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-file.el --- mime-view internal method for file extraction
-
-;; Copyright (C) 1995,1996,1997 Free Software Foundation, Inc.
-
-;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
-;; modified by Shuhei KOBAYASHI <shuhei-k@jaist.ac.jp>
-;; Version: $Id: mime-file.el,v 0.0 1997-02-27 05:44:03 tmorioka Exp $
-;; Keywords: file, extract, MIME, multimedia, mail, news
-
-;; 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 GNU Emacs; see the file COPYING. If not, write to the
-;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
-;; Boston, MA 02111-1307, USA.
-
-;;; Code:
-
-(require 'mime-view)
-
-(defun mime-article/extract-file (beg end cal)
- (goto-char beg)
- (let* ((name
- (save-restriction
- (narrow-to-region beg end)
- (mime-article/get-filename cal)
- ))
- (encoding (cdr (assq 'encoding cal)))
- (filename
- (if (and name (not (string-equal name "")))
- (expand-file-name name
- (call-interactively
- (function
- (lambda (dir)
- (interactive "DDirectory: ")
- dir))))
- (call-interactively
- (function
- (lambda (file)
- (interactive "FFilename: ")
- (expand-file-name file))))))
- (the-buf (current-buffer))
- (tmp-buf (generate-new-buffer (file-name-nondirectory filename)))
- )
- (if (file-exists-p filename)
- (or (yes-or-no-p (format "File %s exists. Save anyway? " filename))
- (error "")))
- (re-search-forward "\n\n")
- (append-to-buffer tmp-buf (match-end 0) end)
- (save-excursion
- (set-buffer tmp-buf)
- (mime-decode-region (point-min)(point-max) encoding)
- (let ((coding-system-for-write 'no-conversion)
- jka-compr-compression-info-list ; for jka-compr
- jam-zcat-filename-list ; for jam-zcat
- require-final-newline)
- (write-file filename)
- )
- (kill-buffer tmp-buf)
- )))
-
-
-;;; @ setup
-;;;
-
-(set-atype 'mime/content-decoding-condition
- '((type . "application/octet-stream")
- (method . mime-article/extract-file)
- )
- 'ignore '(method)
- 'replacement)
-
-(set-atype 'mime/content-decoding-condition
- '((mode . "extract")
- (method . mime-article/extract-file)
- )
- 'remove
- '((method "mime-file" nil 'file 'type 'encoding 'mode 'name)
- (mode . "extract"))
- 'replacement)
-
-
-;;; @ end
-;;;
-
-(provide 'mime-file)
-
-;;; end of mime-file.el
+++ /dev/null
-;;; mime-image.el --- mime-view filter to display images
-
-;; Copyright (C) 1995,1996,1997 MORIOKA Tomohiko
-;; Copyright (C) 1996 Dan Rich
-
-;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
-;; Dan Rich <drich@morpheus.corp.sgi.com>
-;; Maintainer: MORIOKA Tomohiko <morioka@jaist.ac.jp>
-;; Created: 1995/12/15
-;; Renamed: 1997/2/21 from tm-image.el
-;; Version:
-;; $Id: mime-image.el,v 0.5 1997-03-14 05:59:31 morioka Exp $
-
-;; Keywords: image, picture, X-Face, MIME, multimedia, mail, news
-
-;; This file is part of XEmacs.
-
-;; 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:
-
-(require 'mime-view)
-(require 'alist)
-
-(cond (running-xemacs
- (require 'images)
-
- (defun-maybe image-inline-p (format)
- (or (memq format image-native-formats)
- (find-if (function
- (lambda (native)
- (image-converter-chain format native)
- ))
- image-native-formats)
- ))
-
- (image-register-netpbm-utilities)
- (image-register-converter 'pic 'ppm "pictoppm")
- (image-register-converter 'mag 'ppm "magtoppm")
-
- (defun bitmap-insert-xbm-file (file)
- (let ((gl (make-glyph (list (cons 'x file))))
- (e (make-extent (point) (point)))
- )
- (set-extent-end-glyph e gl)
- ))
-
- ;;
- ;; X-Face
- ;;
- (autoload 'highlight-headers "highlight-headers")
-
- (defun mime-preview/x-face-function-use-highlight-headers ()
- (highlight-headers (point-min) (re-search-forward "^$" nil t) t)
- )
-
- (add-hook 'mime-view-content-header-filter-hook
- 'mime-preview/x-face-function-use-highlight-headers)
-
- )
- ((featurep 'mule)
- ;; for MULE 2.* or mule merged EMACS
- (require 'x-face-mule)
-
- (defvar image-native-formats '(xbm))
-
- (defun-maybe image-inline-p (format)
- (memq format image-native-formats)
- )
-
- (defun-maybe image-normalize (format data)
- (and (eq format 'xbm)
- (vector 'xbm ':data data)
- ))
-
- ;;
- ;; X-Face
- ;;
- (if (file-installed-p uncompface-program exec-path)
- (add-hook 'mime-view-content-header-filter-hook
- 'x-face-decode-message-header)
- )
- ))
-
-(or (fboundp 'image-invalid-glyph-p)
- (defsubst image-invalid-glyph-p (glyph)
- (or (null (aref glyph 0))
- (null (aref glyph 2))
- (equal (aref glyph 2) "")
- ))
- )
-
-(defvar mime-view-image-converter-alist nil)
-
-(mapcar (function
- (lambda (rule)
- (let ((ctype (car rule))
- (format (cdr rule))
- )
- (if (image-inline-p format)
- (progn
- (set-alist 'mime-view-content-filter-alist
- ctype
- (function mime-preview/filter-for-image))
- (set-alist 'mime-view-image-converter-alist
- ctype format)
- (add-to-list
- 'mime-view-default-showing-Content-Type-list
- ctype)
- )
- ))))
- '(("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/x-pic" . pic)
- ("image/x-mag" . mag)
- ))
-
-(defvar mime-view-ps-to-gif-command "pstogif")
-
-
-;;; @ content filter for images
-;;;
-;; (for XEmacs 19.12 or later)
-
-(defun mime-preview/filter-for-image (ctype params encoding)
- (let* ((mode mime::preview/original-major-mode)
- (charset (assoc "charset" params))
- (beg (point-min)) (end (point-max))
- )
- (remove-text-properties beg end '(face nil))
- (message "Decoding image...")
- (mime-decode-region beg end encoding)
- (let* ((minor (cdr (assoc ctype mime-view-image-converter-alist)))
- (gl (image-normalize minor (buffer-string)))
- e)
- (delete-region (point-min)(point-max))
- (cond ((image-invalid-glyph-p gl)
- (setq gl nil)
- (message "Invalid glyph!")
- )
- ((eq (aref gl 0) 'xbm)
- (let ((xbm-file
- (make-temp-name
- (expand-file-name "tm" mime-temp-directory))))
- (insert (aref gl 2))
- (write-region (point-min)(point-max) xbm-file)
- (message "Decoding image...")
- (delete-region (point-min)(point-max))
- (bitmap-insert-xbm-file xbm-file)
- (delete-file xbm-file)
- )
- (message "Decoding image... done")
- )
- (t
- (setq gl (make-glyph gl))
- (setq e (make-extent (point) (point)))
- (set-extent-end-glyph e gl)
- (message "Decoding image... done")
- ))
- )
- (insert "\n")
- ))
-
-
-;;; @ content filter for Postscript
-;;;
-;; (for XEmacs 19.14 or later)
-
-(defun mime-preview/filter-for-application/postscript (ctype params encoding)
- (let* ((mode mime::preview/original-major-mode)
- (m (assq mode mime-view-code-converter-alist))
- (beg (point-min)) (end (point-max))
- (file-base
- (make-temp-name (expand-file-name "tm" mime-temp-directory)))
- (ps-file (concat file-base ".ps"))
- (gif-file (concat file-base ".gif"))
- )
- (remove-text-properties beg end '(face nil))
- (message "Decoding Postscript...")
- (mime-decode-region beg end encoding)
- (write-region (point-min)(point-max) ps-file)
- (message "Decoding Postscript...")
- (delete-region (point-min)(point-max))
- (call-process mime-view-ps-to-gif-command nil nil nil ps-file)
- (set-extent-end-glyph (make-extent (point) (point))
- (make-glyph (vector 'gif :file gif-file)))
- (message "Decoding Postscript... done")
- (delete-file ps-file)
- (delete-file gif-file)
- ))
-
-(set-alist 'mime-view-content-filter-alist
- "application/postscript"
- (function mime-preview/filter-for-application/postscript))
-
-(if (featurep 'gif)
- (add-to-list 'mime-view-default-showing-Content-Type-list
- "application/postscript")
- )
-
-
-;;; @ end
-;;;
-
-(provide 'mime-image)
-
-;;; mime-image.el ends here
+++ /dev/null
-;;; mime-mc.el --- Mailcrypt interface for SEMI
-
-;; Copyright (C) 1996,1997 MORIOKA Tomohiko
-
-;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
-;; Version: $Id: mime-mc.el,v 0.0 1997-02-27 08:03:48 tmorioka Exp $
-;; Keywords: PGP, security, MIME, multimedia, mail, news
-
-;; 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 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 'mailcrypt)
-(load "mc-pgp")
-
-(defun mime-mc-pgp-generic-parser (result)
- (let ((ret (mc-pgp-generic-parser result)))
- (if (consp ret)
- (vector (car ret)(cdr ret))
- )))
-
-(defun mime-mc-process-region
- (beg end passwd program args parser &optional buffer boundary)
- (let ((obuf (current-buffer))
- (process-connection-type nil)
- mybuf result rgn proc)
- (unwind-protect
- (progn
- (setq mybuf (or buffer (generate-new-buffer " *mailcrypt temp")))
- (set-buffer mybuf)
- (erase-buffer)
- (set-buffer obuf)
- (buffer-disable-undo mybuf)
- (setq proc
- (apply 'start-process "*PGP*" mybuf program args))
- (if passwd
- (progn
- (process-send-string proc (concat passwd "\n"))
- (or mc-passwd-timeout (mc-deactivate-passwd t))))
- (process-send-region proc beg end)
- (process-send-eof proc)
- (while (eq 'run (process-status proc))
- (accept-process-output proc 5))
- (setq result (process-exit-status proc))
- ;; Hack to force a status_notify() in Emacs 19.29
- (delete-process proc)
- (set-buffer mybuf)
- (goto-char (point-max))
- (if (re-search-backward "\nProcess \\*PGP.*\n\\'" nil t)
- (delete-region (match-beginning 0) (match-end 0)))
- (goto-char (point-min))
- ;; CRNL -> NL
- (while (search-forward "\r\n" nil t)
- (replace-match "\n"))
- ;; Hurm. FIXME; must get better result codes.
- (if (stringp result)
- (error "%s exited abnormally: '%s'" program result)
- (setq rgn (funcall parser result))
- ;; If the parser found something, migrate it
- (if (consp rgn)
- (progn
- (set-buffer obuf)
- (if boundary
- (save-restriction
- (narrow-to-region beg end)
- (goto-char beg)
- (insert (format "--%s\n" boundary))
- (goto-char (point-max))
- (insert (format "\n--%s
-Content-Type: application/pgp-signature
-Content-Transfer-Encoding: 7bit
-
-" boundary))
- (insert-buffer-substring mybuf (car rgn) (cdr rgn))
- (goto-char (point-max))
- (insert (format "\n--%s--\n" boundary))
- )
- (delete-region beg end)
- (goto-char beg)
- (insert-buffer-substring mybuf (car rgn) (cdr rgn))
- )
- (set-buffer mybuf)
- (delete-region (car rgn) (cdr rgn)))))
- ;; Return nil on failure and exit code on success
- (if rgn result))
- ;; Cleanup even on nonlocal exit
- (if (and proc (eq 'run (process-status proc)))
- (interrupt-process proc))
- (set-buffer obuf)
- (or buffer (null mybuf) (kill-buffer mybuf)))))
-
-(defun mime-mc-pgp-sign-region (start end &optional id unclear boundary)
- ;; (if (not (boundp 'mc-pgp-user-id))
- ;; (load "mc-pgp")
- ;; )
- (let ((process-environment process-environment)
- (buffer (get-buffer-create mc-buffer-name))
- passwd args key
- (parser (function mc-pgp-generic-parser))
- (pgp-path mc-pgp-path)
- )
- (setq key (mc-pgp-lookup-key (or id mc-pgp-user-id)))
- (setq passwd
- (mc-activate-passwd
- (cdr key)
- (format "PGP passphrase for %s (%s): " (car key) (cdr key))))
- (setenv "PGPPASSFD" "0")
- (setq args
- (cons
- (if boundary
- "-fbast"
- "-fast")
- (list "+verbose=1" "+language=en"
- (format "+clearsig=%s" (if unclear "off" "on"))
- "+batchmode" "-u" (cdr key))))
- (if mc-pgp-comment
- (setq args (cons (format "+comment=%s" mc-pgp-comment) args))
- )
- (message "Signing as %s ..." (car key))
- (if (mime-mc-process-region
- start end passwd pgp-path args parser buffer boundary)
- (progn
- (if boundary
- (progn
- (goto-char (point-min))
- (insert
- (format "\
---[[multipart/signed; protocol=\"application/pgp-signature\";
- boundary=\"%s\"; micalg=pgp-md5][7bit]]\n" boundary))
- ))
- (message "Signing as %s ... Done." (car key))
- t)
- nil)))
-
-(defun mime-mc-pgp-encrypt-region (recipients start end &optional id sign)
- (let ((mc-pgp-always-sign (if (eq sign 'maybe)
- mc-pgp-always-sign
- 'never)))
- (mc-pgp-encrypt-region
- (mc-split "\\([ \t\n]*,[ \t\n]*\\)+" recipients)
- start end id nil)
- ))
-
-
-;;; @ end
-;;;
-
-(provide 'mime-mc)
-
-;;; mime-mc.el ends here
+++ /dev/null
-;;; mime-parse.el --- MIME message parser
-
-;; Copyright (C) 1994,1995,1996,1997 Free Software Foundation, Inc.
-
-;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
-;; Version: $Id: mime-parse.el,v 0.7 1997-03-03 17:40:55 morioka Exp $
-;; Keywords: parse, MIME, multimedia, mail, news
-
-;; 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 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 'emu)
-(require 'std11)
-(require 'mime-def)
-
-(defsubst symbol-concat (&rest args)
- "Return a symbol whose name is concatenation of arguments ARGS
-which are string or symbol."
- (intern (apply (function concat)
- (mapcar (function
- (lambda (s)
- (cond ((symbolp s) (symbol-name s))
- ((stringp s) s)
- )))
- args))))
-
-(defmacro define-structure (name &rest slots)
- (let ((pred (symbol-concat name '-p)))
- (cons 'progn
- (nconc
- (list
- (` (defun (, pred) (obj)
- (and (vectorp obj)
- (eq (elt obj 0) '(, name))
- ))
- )
- (` (defun (, (symbol-concat name '/create)) (, slots)
- (, (cons 'vector (cons (list 'quote name) slots)))
- )
- ))
- (let ((i 1))
- (mapcar (function
- (lambda (slot)
- (prog1
- (` (defun (, (symbol-concat name '/ slot)) (obj)
- (if ((, pred) obj)
- (elt obj (, i))
- ))
- )
- (setq i (+ i 1))
- )
- )) slots)
- )
- (list (list 'quote name))
- ))))
-
-
-;;; @ field parser
-;;;
-
-(defsubst regexp-* (regexp)
- (concat regexp "*"))
-
-(defconst rfc822/quoted-pair-regexp "\\\\.")
-(defconst rfc822/qtext-regexp
- (concat "[^" (char-list-to-string std11-non-qtext-char-list) "]"))
-(defconst rfc822/quoted-string-regexp
- (concat "\""
- (regexp-*
- (regexp-or rfc822/qtext-regexp rfc822/quoted-pair-regexp)
- )
- "\""))
-
-(defconst mime/content-parameter-value-regexp
- (concat "\\("
- rfc822/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)
- ))))
-
-(defconst mime::ctype-regexp (concat "^" mime/content-type-subtype-regexp))
-
-(defun mime-parse-Content-Type (string)
- "Parse STRING as field-body of Content-Type field. [mime-parse.el]"
- (setq string (std11-unfold-string string))
- (if (string-match mime::ctype-regexp string)
- (let* ((e (match-end 0))
- (ctype (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 ctype (nreverse dest))
- )))
-
-(defconst mime::dtype-regexp (concat "^" mime/disposition-type-regexp))
-
-(defun mime-parse-Content-Disposition (string)
- "Parse STRING as field-body of Content-Disposition field. [mime-parse.el]"
- (setq string (std11-unfold-string string))
- (if (string-match mime::dtype-regexp string)
- (let* ((e (match-end 0))
- (ctype (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 ctype (nreverse dest))
- )))
-
-
-;;; @ field reader
-;;;
-
-(defun mime/Content-Type ()
- "Read field-body of Content-Type field from current-buffer,
-and return parsed it. [mime-parse.el]"
- (let ((str (std11-field-body "Content-Type")))
- (if str
- (mime-parse-Content-Type str)
- )))
-
-(defun mime/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. [mime-parse.el]"
- (let ((str (std11-field-body "Content-Transfer-Encoding")))
- (if str
- (progn
- (if (string-match "[ \t\n\r]+$" str)
- (setq str (substring str 0 (match-beginning 0)))
- )
- (downcase str)
- )
- default-encoding)
- ))
-
-(defun mime/Content-Disposition ()
- "Read field-body of Content-Disposition field from current-buffer,
-and return parsed it. [mime-parse.el]"
- (let ((str (std11-field-body "Content-Disposition")))
- (if str
- (mime-parse-Content-Disposition str)
- )))
-
-
-;;; @ message parser
-;;;
-
-(define-structure mime::content-info
- rcnum point-min point-max type parameters encoding children)
-
-
-(defun mime-parse-multipart (boundary ctype params encoding rcnum)
- (goto-char (point-min))
- (let* ((dash-boundary (concat "--" boundary))
- (delimiter (concat "\n" (regexp-quote dash-boundary)))
- (close-delimiter (concat delimiter "--[ \t]*$"))
- (beg (point-min))
- (end (progn
- (goto-char (point-max))
- (if (re-search-backward close-delimiter nil t)
- (match-beginning 0)
- (point-max)
- )))
- (rsep (concat delimiter "[ \t]*\n"))
- (dc-ctl
- (if (string-equal ctype "multipart/digest")
- '("message/rfc822")
- '("text/plain")
- ))
- cb ce ct ret ncb children (i 0))
- (save-restriction
- (narrow-to-region beg end)
- (goto-char beg)
- (re-search-forward rsep nil t)
- (setq cb (match-end 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 dc-ctl "7bit" (cons i rcnum)))
- )
- (setq children (cons ret children))
- (goto-char (mime::content-info/point-max ret))
- (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 dc-ctl "7bit" (cons i rcnum)))
- )
- (setq children (cons ret children))
- )
- (mime::content-info/create rcnum beg (point-max)
- ctype params encoding
- (nreverse children))
- ))
-
-(defun mime-parse-message (&optional ctl encoding rcnum)
- "Parse current-buffer as a MIME message. [mime-parse.el]"
- (setq ctl (or (mime/Content-Type) ctl))
- (setq encoding (or (mime/Content-Transfer-Encoding) encoding))
- (let ((ctype (car ctl))
- (params (cdr ctl))
- )
- (let ((boundary (assoc "boundary" params)))
- (cond (boundary
- (setq boundary (std11-strip-quoted-string (cdr boundary)))
- (mime-parse-multipart boundary ctype params encoding rcnum)
- )
- ((or (string-equal ctype "message/rfc822")
- (string-equal ctype "message/news")
- )
- (goto-char (point-min))
- (mime::content-info/create rcnum
- (point-min) (point-max)
- ctype params encoding
- (save-restriction
- (narrow-to-region
- (if (re-search-forward "^$" nil t)
- (1+ (match-end 0))
- (point-min)
- )
- (point-max))
- (list (mime-parse-message
- nil nil (cons 0 rcnum)))
- )
- )
- )
- (t
- (mime::content-info/create rcnum (point-min) (point-max)
- ctype params encoding 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 Free Software Foundation, Inc.
-
-;; Author: OKABE Yasuo @ Kyoto University
-;; MORIOKA Tomohiko <morioka@jaist.ac.jp>
-;; Version:
-;; $Id: mime-partial.el,v 0.3 1997-03-07 16:40:29 morioka Exp $
-;; Keywords: message/partial, MIME, multimedia, mail, news
-
-;; 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 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)
-
-(defvar mime-partial/preview-article-method-alist nil)
-
-;; display Article at the cursor in Subject buffer.
-(defun mime-partial/preview-article (target)
- (save-window-excursion
- (let ((f (assq target mime-partial/preview-article-method-alist)))
- (if f
- (funcall (cdr f))
- (error "Fatal. Unsupported mode")
- ))))
-
-(defun mime-article/grab-message/partials (beg end cal)
- (interactive)
- (let* ((id (cdr (assoc "id" cal)))
- (mother mime::article/preview-buffer)
- (target (cdr (assq 'major-mode cal)))
- (article-buffer (buffer-name (current-buffer)))
- (subject-buf (eval (cdr (assq 'summary-buffer-exp cal))))
- subject-id
- (root-dir (expand-file-name
- (concat "m-prts-" (user-login-name)) mime-temp-directory))
- 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-article/decode-message/partial beg end cal)
- (let (cinfo the-id parameters)
- (setq subject-id (std11-field-body "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
- (mime-partial/preview-article target)
- (set-buffer article-buffer)
- (set-buffer mime::article/preview-buffer)
- (setq cinfo
- (mime::preview-content-info/content-info
- (car mime::preview/content-list)))
- (setq parameters (mime::content-info/parameters cinfo))
- (setq the-id (cdr (assoc "id" parameters)))
- (if (equal the-id id)
- (progn
- (set-buffer article-buffer)
- (mime-article/decode-message/partial
- (point-min)(point-max) parameters)
- (if (file-exists-p full-file)
- (throw 'tag nil)
- )
- ))
- (if (not (progn
- (set-buffer subject-buf)
- (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 MORIOKA Tomohiko
-
-;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
-;; Created: 1995/12/7
-;; Renamed: 1997/2/27 from tm-pgp.el
-;; Version: $Id: mime-pgp.el,v 0.2 1997-03-04 13:07:54 morioka Exp $
-;; Keywords: mail, news, MIME, multimedia, PGP, security
-
-;; 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 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 2 drafts about PGP MIME integration:
-
-;; - RFC 2015: "MIME Security with Pretty Good Privacy (PGP)"
-;; by Michael Elkins <elkins@aero.org> (1996/6)
-;;
-;; - draft-kazu-pgp-mime-00.txt: "PGP MIME Integration"
-;; by Kazuhiko Yamamoto <kazu@is.aist-nara.ac.jp>
-;; (1995/10; expired)
-;;
-;; These drafts may be contrary to each other. You should decide
-;; which you support. (Maybe you should use PGP/MIME)
-
-;;; Code:
-
-(require 'mime-play)
-
-
-;;; @ internal method for application/pgp
-;;;
-;;; It is based on draft-kazu-pgp-mime-00.txt
-
-(defun mime-article/view-application/pgp (beg end cal)
- (let* ((cnum (mime-article/point-content-number beg))
- (cur-buf (current-buffer))
- (p-win (or (get-buffer-window mime::article/preview-buffer)
- (get-largest-window)))
- (new-name (format "%s-%s" (buffer-name) cnum))
- (mother mime::article/preview-buffer)
- (mode major-mode)
- code-converter
- (str (buffer-substring beg end))
- )
- (set-buffer (get-buffer-create new-name))
- (erase-buffer)
- (insert str)
- (cond ((progn
- (goto-char (point-min))
- (re-search-forward "^-+BEGIN PGP SIGNED MESSAGE-+$" nil t)
- )
- (funcall (pgp-function 'verify))
- (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 code-converter
- (or
- (cdr (assq mode mime-viewer/code-converter-alist))
- (function mime-viewer/default-code-convert-region)))
- )
- ((progn
- (goto-char (point-min))
- (re-search-forward "^-+BEGIN PGP MESSAGE-+$" nil t)
- )
- (as-binary-process (funcall (pgp-function 'decrypt)))
- (goto-char (point-min))
- (delete-region (point-min)
- (and
- (search-forward "\n\n")
- (match-end 0)))
- (setq code-converter (function mime-charset/decode-buffer))
- ))
- (setq major-mode 'mime/show-message-mode)
- (setq mime::article/code-converter code-converter)
- (save-window-excursion (mime/viewer-mode mother))
- (set-window-buffer p-win mime::article/preview-buffer)
- ))
-
-(set-atype 'mime/content-decoding-condition
- '((type . "application/pgp")
- (method . mime-article/view-application/pgp)
- ))
-
-(set-atype 'mime/content-decoding-condition
- '((type . "text/x-pgp")
- (method . mime-article/view-application/pgp)
- ))
-
-
-;;; @ Internal method for application/pgp-signature
-;;;
-;;; It is based on RFC 2015.
-
-(defvar mime-pgp-default-language 'en
- "*Symbol of language for pgp.
-It should be ISO 639 2 letter language code such as en, ja, ...")
-
-(defvar mime-pgp-good-signature-regexp-alist
- '((en . "Good signature from user.*$"))
- "Alist of language vs regexp to detect ``Good signature''.")
-
-(defvar mime-pgp-key-expected-regexp-alist
- '((en . "Key matching expected Key ID \\(\\S +\\) not found"))
- "Alist of language vs regexp to detect ``Key expected''.")
-
-(defun mime::article/call-pgp-to-check-signature (output-buffer orig-file)
- (save-excursion
- (set-buffer output-buffer)
- (erase-buffer)
- )
- (let* ((lang (or mime-pgp-default-language 'en))
- (status
- (call-process-region (point-min)(point-max)
- "pgp" nil output-buffer nil orig-file
- (format "+language=%s" lang)
- ))
- (regexp (cdr (assq lang mime-pgp-good-signature-regexp-alist)))
- )
- (if (= status 0)
- (save-excursion
- (set-buffer output-buffer)
- (goto-char (point-min))
- (message
- (cond ((not (stringp regexp))
- "Please specify right regexp for specified language")
- ((re-search-forward regexp nil t)
- (buffer-substring (match-beginning 0) (match-end 0))
- )
- (t
- "Bad signature"
- )))
- ))))
-
-(defun mime-article/check-pgp-signature (beg end cal)
- (let* ((encoding (cdr (assq 'encoding cal)))
- (cnum (mime-article/point-content-number beg))
- (rcnum (reverse cnum))
- (rmcnum (cdr rcnum))
- (knum (car rcnum))
- (onum (if (> knum 0)
- (1- knum)
- (1+ knum)))
- (oinfo (mime-article/rcnum-to-cinfo (cons onum rmcnum)
- mime::article/content-info))
- status str kbuf
- (basename (expand-file-name "tm" mime-temp-directory))
- (orig-file (make-temp-name basename))
- (sig-file (concat orig-file ".sig"))
- )
- (save-excursion
- (setq str (buffer-substring
- (mime::content-info/point-min oinfo)
- (mime::content-info/point-max oinfo)
- ))
- (set-buffer (get-buffer-create mime/temp-buffer-name))
- (insert str)
- (goto-char (point-min))
- (while (re-search-forward "\n" nil t)
- (replace-match "\r\n")
- )
- (as-binary-output-file (write-file orig-file))
- (kill-buffer (current-buffer))
- )
- (save-excursion
- (mime-article/show-output-buffer)
- )
- (save-excursion
- (setq str (buffer-substring
- (save-excursion
- (goto-char beg)
- (and (search-forward "\n\n")
- (match-end 0)))
- end))
- (set-buffer (setq kbuf (get-buffer-create mime/temp-buffer-name)))
- (insert str)
- (mime-decode-region (point-min)(point-max) encoding)
- (as-binary-output-file (write-file sig-file))
- (or (mime::article/call-pgp-to-check-signature
- mime/output-buffer-name orig-file)
- (let (pgp-id)
- (save-excursion
- (set-buffer mime/output-buffer-name)
- (goto-char (point-min))
- (let ((regexp (cdr (assq (or mime-pgp-default-language 'en)
- mime-pgp-key-expected-regexp-alist))))
- (cond ((not (stringp regexp))
- (message
- "Please specify right regexp for specified language")
- )
- ((re-search-forward regexp nil t)
- (setq pgp-id
- (concat "0x" (buffer-substring-no-properties
- (match-beginning 1)
- (match-end 1))))
- ))))
- (if (and pgp-id
- (y-or-n-p
- (format "Key %s not found; attempt to fetch? " pgp-id))
- )
- (progn
- (funcall (pgp-function 'fetch-key) (cons nil pgp-id))
- (mime::article/call-pgp-to-check-signature
- mime/output-buffer-name orig-file)
- ))
- ))
- (let ((other-window-scroll-buffer mime/output-buffer-name))
- (scroll-other-window 8)
- )
- (kill-buffer kbuf)
- (delete-file orig-file)
- (delete-file sig-file)
- )))
-
-(set-atype 'mime/content-decoding-condition
- '((type . "application/pgp-signature")
- (method . mime-article/check-pgp-signature)
- ))
-
-
-;;; @ Internal method for application/pgp-encrypted
-;;;
-;;; It is based on RFC 2015.
-
-(defun mime-article/decrypt-pgp (beg end cal)
- (let* ((cnum (mime-article/point-content-number beg))
- (rcnum (reverse cnum))
- (rmcnum (cdr rcnum))
- (knum (car rcnum))
- (onum (if (> knum 0)
- (1- knum)
- (1+ knum)))
- (oinfo (mime-article/rcnum-to-cinfo (cons onum rmcnum)
- mime::article/content-info))
- (obeg (mime::content-info/point-min oinfo))
- (oend (mime::content-info/point-max oinfo))
- )
- (mime-article/view-application/pgp obeg oend cal)
- ))
-
-(set-atype 'mime/content-decoding-condition
- '((type . "application/pgp-encrypted")
- (method . mime-article/decrypt-pgp)
- ))
-
-
-;;; @ Internal method for application/pgp-keys
-;;;
-;;; It is based on RFC 2015.
-
-(defun mime-article/add-pgp-keys (beg end cal)
- (let* ((cnum (mime-article/point-content-number beg))
- (cur-buf (current-buffer))
- (new-name (format "%s-%s" (buffer-name) cnum))
- (mother mime::article/preview-buffer)
- (charset (cdr (assoc "charset" cal)))
- (encoding (cdr (assq 'encoding cal)))
- (mode major-mode)
- str)
- (setq str (buffer-substring beg end))
- (switch-to-buffer new-name)
- (setq buffer-read-only nil)
- (erase-buffer)
- (insert str)
- (goto-char (point-min))
- (if (re-search-forward "^\n" nil t)
- (delete-region (point-min) (match-end 0))
- )
- (mime-decode-region (point-min)(point-max) encoding)
- (funcall (pgp-function 'snarf-keys))
- (kill-buffer (current-buffer))
- ))
-
-(set-atype 'mime/content-decoding-condition
- '((type . "application/pgp-keys")
- (method . mime-article/add-pgp-keys)
- ))
-
-
-;;; @ end
-;;;
-
-(provide 'mime-pgp)
-
-(run-hooks 'mime-pgp-load-hook)
-
-;;; mime-pgp.el ends here
+++ /dev/null
-;;; mime-play.el --- decoder for mime-view.el
-
-;; Copyright (C) 1994,1995,1996,1997 Free Software Foundation, Inc.
-
-;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
-;; Created: 1995/9/26 (separated from tm-view.el)
-;; Renamed: 1997/2/21 from tm-play.el
-;; Version: $Id: mime-play.el,v 0.13 1997-03-10 13:39:57 morioka Exp $
-;; Keywords: MIME, multimedia, mail, news
-
-;; 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 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)
-
-
-;;; @ content decoder
-;;;
-
-(defvar mime-preview/after-decoded-position nil)
-
-(defun mime-preview/decode-content ()
- (interactive)
- (let ((pc (mime-preview/point-pcinfo (point))))
- (if pc
- (let ((the-buf (current-buffer)))
- (setq mime-preview/after-decoded-position (point))
- (set-buffer (mime::preview-content-info/buffer pc))
- (mime-article/decode-content
- (mime::preview-content-info/content-info pc))
- (if (eq (current-buffer)
- (mime::preview-content-info/buffer pc))
- (progn
- (set-buffer the-buf)
- (goto-char mime-preview/after-decoded-position)
- ))
- ))))
-
-(defun mime-article/decode-content (cinfo)
- (let ((beg (mime::content-info/point-min cinfo))
- (end (mime::content-info/point-max cinfo))
- (ctype (or (mime::content-info/type cinfo) "text/plain"))
- (params (mime::content-info/parameters cinfo))
- (encoding (mime::content-info/encoding cinfo))
- )
- ;; Check for VM
- (if (< beg (point-min))
- (setq beg (point-min))
- )
- (if (< (point-max) end)
- (setq end (point-max))
- )
- (let (method cal ret)
- (setq cal (list* (cons 'type ctype)
- (cons 'encoding encoding)
- (cons 'major-mode major-mode)
- params))
- (if mime-view-decoding-mode
- (setq cal (cons
- (cons 'mode mime-view-decoding-mode)
- cal))
- )
- (setq ret (mime/get-content-decoding-alist cal))
- (setq method (cdr (assq 'method ret)))
- (cond ((and (symbolp method)
- (fboundp method))
- (funcall method beg end ret)
- )
- ((and (listp method)(stringp (car method)))
- (mime-article/start-external-method-region beg end ret)
- )
- (t
- (mime-article/show-output-buffer
- "No method are specified for %s\n" ctype)
- ))
- )
- ))
-
-
-;;; @ method selector
-;;;
-
-(defun mime/get-content-decoding-alist (al)
- (get-unified-alist mime/content-decoding-condition al)
- )
-
-
-;;; @ external decoder
-;;;
-
-(defun mime-article/start-external-method-region (beg end cal)
- (save-excursion
- (save-restriction
- (narrow-to-region beg end)
- (goto-char beg)
- (let ((method (cdr (assoc 'method cal)))
- (name (mime-article/get-filename cal))
- )
- (if method
- (let ((file (make-temp-name
- (expand-file-name "TM" mime-temp-directory)))
- b args)
- (if (nth 1 method)
- (setq b beg)
- (setq b
- (if (re-search-forward "^$" nil t)
- (1+ (match-end 0))
- (point-min)
- ))
- )
- (goto-char b)
- (write-region b end file)
- (message "External method is starting...")
- (setq cal (put-alist
- 'name (replace-as-filename name) cal))
- (setq cal (put-alist 'file file cal))
- (setq args (nconc
- (list (car method)
- mime/output-buffer-name (car method)
- )
- (mime-article/make-method-args cal
- (cdr (cdr method)))
- ))
- (apply (function start-process) args)
- (mime-article/show-output-buffer)
- ))
- ))))
-
-(defun mime-article/make-method-args (cal format)
- (mapcar (function
- (lambda (arg)
- (if (stringp arg)
- arg
- (let* ((item (eval arg))
- (ret (cdr (assoc item cal)))
- )
- (if ret
- ret
- (if (eq item 'encoding)
- "7bit"
- ""))
- ))
- ))
- format))
-
-(defun mime-article/show-output-buffer (&rest forms)
- (get-buffer-create mime/output-buffer-name)
- (let ((the-win (selected-window))
- (win (get-buffer-window mime/output-buffer-name))
- )
- (or win
- (if (and mime/output-buffer-window-is-shared-with-bbdb
- (boundp 'bbdb-buffer-name)
- (setq win (get-buffer-window bbdb-buffer-name))
- )
- (set-window-buffer win mime/output-buffer-name)
- (select-window (get-buffer-window mime::article/preview-buffer))
- (setq win (split-window-vertically (/ (* (window-height) 3) 4)))
- (set-window-buffer win mime/output-buffer-name)
- ))
- (select-window win)
- (goto-char (point-max))
- (if forms
- (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-article/get-original-filename (param &optional encoding)
- (or (mime-article/get-uu-filename param encoding)
- (let (ret)
- (or (if (or (and (setq ret (mime/Content-Disposition))
- (setq ret (assoc "filename" (cdr ret)))
- )
- (setq ret (assoc "name" param))
- (setq ret (assoc "x-name" param))
- )
- (std11-strip-quoted-string (cdr ret))
- )
- (if (setq ret
- (std11-find-field-body '("Content-Description"
- "Subject")))
- (if (or (string-match mime-view-file-name-regexp-1 ret)
- (string-match mime-view-file-name-regexp-2 ret))
- (substring ret (match-beginning 0)(match-end 0))
- ))
- ))
- ))
-
-(defun mime-article/get-filename (param)
- (replace-as-filename (mime-article/get-original-filename param))
- )
-
-
-;;; @ mail/news message
-;;;
-
-(defun mime-view-quitting-method-for-mime/show-message-mode ()
- (let ((mother mime::preview/mother-buffer)
- (win-conf mime::preview/original-window-configuration)
- )
- (kill-buffer
- (mime::preview-content-info/buffer (car mime::preview/content-list)))
- (mime-view-kill-buffer)
- (set-window-configuration win-conf)
- (pop-to-buffer mother)
- ;;(goto-char (point-min))
- ;;(mime-view-up-content)
- ))
-
-(defun mime-article/view-message/rfc822 (beg end cal)
- (let* ((cnum (mime-article/point-content-number beg))
- (cur-buf (current-buffer))
- (new-name (format "%s-%s" (buffer-name) cnum))
- (mother mime::article/preview-buffer)
- (code-converter
- (or (cdr (assq major-mode mime-text-decoder-alist))
- 'mime-view-default-code-convert-region))
- str)
- (setq str (buffer-substring beg end))
- (switch-to-buffer new-name)
- (erase-buffer)
- (insert str)
- (goto-char (point-min))
- (if (re-search-forward "^\n" nil t)
- (delete-region (point-min) (match-end 0))
- )
- (setq major-mode 'mime/show-message-mode)
- (setq mime::article/code-converter code-converter)
- (mime-view-mode mother)
- ))
-
-
-;;; @ message/partial
-;;;
-
-(defvar mime-article/coding-system-alist
- (list '(mh-show-mode . no-conversion)
- (cons t (mime-charset-to-coding-system default-mime-charset))
- ))
-
-(defun mime-article::write-region (start end file)
- (let ((coding-system-for-write
- (cdr
- (or (assq major-mode mime-article/coding-system-alist)
- (assq t mime-article/coding-system-alist)
- ))))
- (write-region start end file)
- ))
-
-(defun mime-article/decode-message/partial (beg end cal)
- (goto-char beg)
- (let* ((root-dir
- (expand-file-name
- (concat "m-prts-" (user-login-name)) mime-temp-directory))
- (id (cdr (assoc "id" cal)))
- (number (cdr (assoc "number" cal)))
- (total (cdr (assoc "total" cal)))
- file
- (mother mime::article/preview-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)))
- )
- (save-window-excursion
- (set-buffer full-buf)
- (erase-buffer)
- (as-binary-input-file (insert-file-contents file))
- (setq major-mode 'mime/show-message-mode)
- (mime-view-mode mother)
- )
- (set-window-buffer pwin
- (save-excursion
- (set-buffer full-buf)
- mime::article/preview-buffer))
- (select-window pwin)
- )
- (re-search-forward "^$")
- (goto-char (1+ (match-end 0)))
- (setq file (concat root-dir "/" number))
- (mime-article::write-region (point) (point-max) 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-file 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))
- (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)
- )
- (as-binary-input-file (insert-file-contents file))
- (goto-char (point-max))
- (setq i (1+ i))
- ))
- (as-binary-output-file (write-file (concat root-dir "/FULL")))
- (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)
- ))
- (save-window-excursion
- (setq major-mode 'mime/show-message-mode)
- (mime-view-mode mother)
- )
- (let ((pwin (or (get-buffer-window mother)
- (get-largest-window)
- ))
- (pbuf (save-excursion
- (set-buffer full-buf)
- mime::article/preview-buffer)))
- (set-window-buffer pwin pbuf)
- (select-window pwin)
- )))))
- )))
-
-
-;;; @ message/external-body
-;;;
-
-(defvar mime-article/dired-function
- (if mime/use-multi-frame
- (function dired-other-frame)
- (function mime-article/dired-function-for-one-frame)
- ))
-
-(defun mime-article/dired-function-for-one-frame (dir)
- (let ((win (or (get-buffer-window mime::article/preview-buffer)
- (get-largest-window))))
- (select-window win)
- (dired dir)
- ))
-
-(defun mime-article/decode-message/external-ftp (beg end cal)
- (let* ((access-type (cdr (assoc "access-type" cal)))
- (site (cdr (assoc "site" cal)))
- (directory (cdr (assoc "directory" cal)))
- (name (cdr (assoc "name" cal)))
- (mode (cdr (assoc "mode" cal)))
- (pathname (concat "/anonymous@" site ":" directory))
- )
- (message (concat "Accessing " (expand-file-name name pathname) "..."))
- (funcall mime-article/dired-function pathname)
- (goto-char (point-min))
- (search-forward name)
- ))
-
-
-;;; @ rot13-47
-;;;
-
-(require 'view)
-
-(defconst mime-view-text/plain-mode-map (copy-keymap view-mode-map))
-(define-key mime-view-text/plain-mode-map
- "q" (function mime-view-text/plain-exit))
-
-(defun mime-view-text/plain-mode ()
- "\\{mime-view-text/plain-mode-map}"
- (setq buffer-read-only t)
- (setq major-mode 'mime-view-text/plain-mode)
- (setq mode-name "MIME-View text/plain")
- (use-local-map mime-view-text/plain-mode-map)
- )
-
-(defun mime-view-text/plain-exit ()
- (interactive)
- (kill-buffer (current-buffer))
- )
-
-(defun mime-article/decode-caesar (beg end cal)
- (let* ((cnum (mime-article/point-content-number beg))
- (cur-buf (current-buffer))
- (new-name (format "%s-%s" (buffer-name) cnum))
- (mother mime::article/preview-buffer)
- (charset (cdr (assoc "charset" cal)))
- (encoding (cdr (assq 'encoding cal)))
- (mode major-mode)
- str)
- (setq str (buffer-substring beg end))
- (let ((pwin (or (get-buffer-window mother)
- (get-largest-window)))
- (buf (get-buffer-create new-name))
- )
- (set-window-buffer pwin buf)
- (set-buffer buf)
- (select-window pwin)
- )
- (setq buffer-read-only nil)
- (erase-buffer)
- (insert str)
- (goto-char (point-min))
- (if (re-search-forward "^\n" nil t)
- (delete-region (point-min) (match-end 0))
- )
- (let ((m (cdr (or (assq mode mime-text-decoder-alist)
- (assq t mime-text-decoder-alist)))))
- (and (functionp m)
- (funcall m charset encoding)
- ))
- (save-excursion
- (set-mark (point-min))
- (goto-char (point-max))
- (tm:caesar-region)
- )
- (set-buffer-modified-p nil)
- (mime-view-text/plain-mode)
- ))
-
-
-;;; @ 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 Free Software Foundation, Inc.
-
-;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
-;; Version:
-;; $Id: mime-setup.el,v 0.11 1997-03-14 08:46:50 morioka Exp $
-;; Keywords: MIME, multimedia, multilingual, mail, news
-
-;; 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 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 err
- (load "gnus-mime-setup")
- (error (message "gnus-mime-setup is not found."))
- )
-
-(condition-case err
- (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-tar.el --- mime-view internal method for tar or tar+gzip format
-
-;; Copyright (C) 1995,1996,1997 Free Software Foundation, Inc.
-
-;; Author: Hiroshi Ueno <zodiac@ibm.net>
-;; modified by MORIOKA Tomohiko <morioka@jaist.ac.jp>
-;; Renamed: 1997/2/26 from tm-tar.el
-;; Version: $Id: mime-tar.el,v 0.3 1997-03-04 13:11:02 morioka Exp $
-;; Keywords: tar, tar+gzip, MIME, multimedia, mail, news
-
-;; 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 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:
-
-;; Internal viewer for
-;; - application/x-tar
-;; - application/x-gzip, type="tar"
-;; - aplication/octet-stream, type="tar"
-;; - aplication/octet-stream, type="tar+gzip"
-
-;;; Code:
-
-(require 'mime-view)
-
-
-;;; @ constants
-;;;
-
-(defconst mime-tar-list-buffer "*mime-tar-List*")
-(defconst mime-tar-view-buffer "*mime-tar-View*")
-(defconst mime-tar-file-search-regexp "[0-9]+\:[0-9\:]+[ ]+[0-9]+[ ]+")
-(defconst mime-tar-popup-menu-title "Action Menu")
-
-
-;;; @ variables
-;;;
-
-(defvar mime-tar-program "gtar")
-(defvar mime-tar-decompress-arg '("-z"))
-(defvar mime-tar-gzip-program "gzip")
-(defvar mime-tar-mmencode-program "mmencode")
-(defvar mime-tar-uudecode-program "uudecode")
-
-(defvar mime-tar-popup-menu-items
- '(("View File" . mime-tar-view-file)
- ("Key Help" . mime-tar-helpful-message)
- ("Quit mime-tar Mode" . exit-recursive-edit)
- ))
-
-(cond ((string-match "XEmacs\\|Lucid" emacs-version)
- (defvar mime-tar-popup-menu
- (cons mime-tar-popup-menu-title
- (mapcar (function
- (lambda (item)
- (vector (car item)(cdr item) t)
- ))
- mime-tar-popup-menu-items)))
-
- (defun mime-tar-mouse-button-2 (event)
- (popup-menu mime-tar-popup-menu)
- )
- )
- ((>= emacs-major-version 19)
- (defun mime-tar-mouse-button-2 (event)
- (let ((menu
- (cons mime-tar-popup-menu-title
- (list (cons "Menu Items" mime-tar-popup-menu-items))
- )))
- (let ((func (x-popup-menu event menu)))
- (if func
- (funcall func)
- ))
- ))
- ))
-
-(defvar mime-tar-mode-map nil)
-(if mime-tar-mode-map
- nil
- (setq mime-tar-mode-map (make-keymap))
- (suppress-keymap mime-tar-mode-map)
- (define-key mime-tar-mode-map "\C-c" 'exit-recursive-edit)
- (define-key mime-tar-mode-map "q" 'exit-recursive-edit)
- (define-key mime-tar-mode-map "n" 'mime-tar-next-line)
- (define-key mime-tar-mode-map " " 'mime-tar-next-line)
- (define-key mime-tar-mode-map "\C-m" 'mime-tar-next-line)
- (define-key mime-tar-mode-map "p" 'mime-tar-previous-line)
- (define-key mime-tar-mode-map "\177" 'mime-tar-previous-line)
- (define-key mime-tar-mode-map "\C-\M-m" 'mime-tar-previous-line)
- (define-key mime-tar-mode-map "v" 'mime-tar-view-file)
- (define-key mime-tar-mode-map "\C-h" 'Helper-help)
- (define-key mime-tar-mode-map "?" 'mime-tar-helpful-message)
- (if mouse-button-2
- (define-key mime-tar-mode-map
- mouse-button-2 'mime-button-dispatcher))
- )
-
-
-;;; @@ mime-tar mode functions
-;;;
-
-(defun mime-tar-mode (&optional prev-buf)
- "Major mode for listing the contents of a tar archive file."
- (unwind-protect
- (let ((buffer-read-only t)
- (mode-name "mime-tar")
- (mode-line-buffer-identification '("%17b"))
- )
- (goto-char (point-min))
- (mime-tar-move-to-filename)
- (catch 'mime-tar-mode (mime-tar-command-loop))
- )
- (if prev-buf
- (switch-to-buffer prev-buf)
- )
- ))
-
-(defun mime-tar-command-loop ()
- (let ((old-local-map (current-local-map)))
- (unwind-protect
- (progn
- (use-local-map mime-tar-mode-map)
- (mime-tar-helpful-message)
- (recursive-edit)
- )
- (save-excursion
- (use-local-map old-local-map)
- ))
- ))
-
-(defun mime-tar-next-line ()
- (interactive)
- (next-line 1)
- (mime-tar-move-to-filename)
- )
-
-(defun mime-tar-previous-line ()
- (interactive)
- (previous-line 1)
- (mime-tar-move-to-filename)
- )
-
-(defun mime-tar-view-file ()
- (interactive)
- (let ((name (mime-tar-get-filename))
- )
- (save-excursion
- (switch-to-buffer mime-tar-view-buffer)
- (setq buffer-read-only nil)
- (erase-buffer)
- (message "Reading a file from an archive. Please wait...")
- (apply 'call-process mime-tar-program
- nil t nil (append mime-tar-view-args (list name)))
- (goto-char (point-min))
- )
- (view-buffer mime-tar-view-buffer)
- ))
-
-(defun mime-tar-get-filename ()
- (let (eol)
- (save-excursion
- (end-of-line)
- (setq eol (point))
- (beginning-of-line)
- (save-excursion
- (if (re-search-forward "^d" eol t)
- (error "Cannot view a directory"))
- )
- (if (re-search-forward mime-tar-file-search-regexp eol t)
- (let ((beg (point)))
- (skip-chars-forward "^ \n")
- (buffer-substring beg (point))
- )
- (error "No file on this line")
- ))
- ))
-
-(defun mime-tar-move-to-filename ()
- (let ((eol (progn (end-of-line) (point))))
- (beginning-of-line)
- (re-search-forward mime-tar-file-search-regexp eol t)
- ))
-
-(defun mime-tar-set-properties ()
- (if mouse-button-2
- (let ((beg (point-min))
- (end (point-max))
- )
- (goto-char beg)
- (save-excursion
- (while (re-search-forward mime-tar-file-search-regexp end t)
- (mime-add-button (point)
- (progn
- (end-of-line)
- (point))
- 'mime-tar-view-file)
- ))
- )))
-
-(defun mime-tar-helpful-message ()
- (interactive)
- (message "Type %s, %s, %s, %s, %s, %s."
- (substitute-command-keys "\\[Helper-help] for help")
- (substitute-command-keys "\\[mime-tar-helpful-message] for keys")
- (substitute-command-keys "\\[mime-tar-next-line] to next")
- (substitute-command-keys "\\[mime-tar-previous-line] to prev")
- (substitute-command-keys "\\[mime-tar-view-file] to view")
- (substitute-command-keys "\\[exit-recursive-edit] to quit")
- ))
-
-(defun mime-tar-y-or-n-p (prompt)
- (prog1
- (y-or-n-p prompt)
- (message "")
- ))
-
-;;; @@ tar message decoder
-;;
-
-(defun mime-decode-message/tar (beg end cal)
- (if (mime-tar-y-or-n-p "Do you want to enter mime-tar mode? ")
- (let ((coding (cdr (assoc 'encoding cal)))
- (cur-buf (current-buffer))
- (mime-tar-file-name
- (expand-file-name
- (concat (make-temp-name
- (expand-file-name "tm" mime-temp-directory)) ".tar")))
- (mime-tar-tmp-file-name
- (expand-file-name
- (make-temp-name (expand-file-name "tm" mime-temp-directory))))
- new-buf)
- (find-file mime-tar-tmp-file-name)
- (setq new-buf (current-buffer))
- (setq buffer-read-only nil)
- (erase-buffer)
- (save-excursion
- (set-buffer cur-buf)
- (goto-char beg)
- (re-search-forward "^$")
- (append-to-buffer new-buf (+ (match-end 0) 1) end)
- )
- (if (member coding mime-viewer/uuencode-encoding-name-list)
- (progn
- (goto-char (point-min))
- (if (re-search-forward "^begin [0-9]+ " nil t)
- (progn
- (kill-line)
- (insert mime-tar-file-name)
- )
- (progn
- (set-buffer-modified-p nil)
- (kill-buffer new-buf)
- (error "uuencode file signature was not found")
- ))))
- (save-buffer)
- (kill-buffer new-buf)
- (message "Listing the contents of an archive. Please wait...")
- (cond ((string-equal coding "base64")
- (call-process mime-tar-mmencode-program nil nil nil "-u"
- "-o" mime-tar-file-name mime-tar-tmp-file-name)
- )
- ((string-equal coding "quoted-printable")
- (call-process mime-tar-mmencode-program nil nil nil "-u" "-q"
- "-o" mime-tar-file-name mime-tar-tmp-file-name)
- )
- ((member coding mime-viewer/uuencode-encoding-name-list)
- (call-process mime-tar-uudecode-program nil nil nil
- mime-tar-tmp-file-name)
- )
- (t
- (copy-file mime-tar-tmp-file-name mime-tar-file-name t)
- ))
- (delete-file mime-tar-tmp-file-name)
- (setq mime-tar-list-args (list "-tvf" mime-tar-file-name))
- (setq mime-tar-view-args (list "-xOf" mime-tar-file-name))
- (if (eq 0 (call-process mime-tar-gzip-program
- nil nil nil "-t" mime-tar-file-name))
- (progn
- (setq mime-tar-list-args
- (append mime-tar-decompress-arg mime-tar-list-args))
- (setq mime-tar-view-args
- (append mime-tar-decompress-arg mime-tar-view-args))
- ))
- (switch-to-buffer mime-tar-view-buffer)
- (switch-to-buffer mime-tar-list-buffer)
- (setq buffer-read-only nil)
- (erase-buffer)
- (apply 'call-process mime-tar-program
- nil t nil mime-tar-list-args)
- (if mouse-button-2
- (progn
- (make-local-variable 'mime-button-mother-dispatcher)
- (setq mime-button-mother-dispatcher 'mime-tar-mouse-button-2)
- ))
- (mime-tar-set-properties)
- (mime-tar-mode mime::article/preview-buffer)
- (kill-buffer mime-tar-view-buffer)
- (kill-buffer mime-tar-list-buffer)
- (delete-file mime-tar-file-name)
- )
- ))
-
-;;; @@ program/buffer coding system
-;;;
-
-(cond ((boundp 'MULE)
- (define-program-coding-system mime-tar-view-buffer nil *autoconv*)
- )
- ((boundp 'NEMACS)
- (define-program-kanji-code mime-tar-view-buffer nil 1)
- ))
-
-;;; @@ message types to use mime-tar
-;;;
-
-(set-atype 'mime/content-decoding-condition
- '((type . "application/octet-stream")
- (method . mime-decode-message/tar)
- (mode . "play") ("type" . "tar")
- ))
-
-(set-atype 'mime/content-decoding-condition
- '((type . "application/octet-stream")
- (method . mime-decode-message/tar)
- (mode . "play") ("type" . "tar+gzip")
- ))
-
-(set-atype 'mime/content-decoding-condition
- '((type . "application/x-gzip")
- (method . mime-decode-message/tar)
- (mode . "play") ("type" . "tar")
- ))
-
-(set-atype 'mime/content-decoding-condition
- '((type . "application/x-tar")
- (method . mime-decode-message/tar)
- (mode . "play")
- ))
-
-;;; @ end
-;;;
-
-(provide 'mime-tar)
-
-;;; mime-tar.el ends here
+++ /dev/null
-;;; mime-text.el --- mime-view content filter for text
-
-;; Copyright (C) 1994,1995,1996,1997 Free Software Foundation, Inc.
-
-;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
-;; Version:
-;; $Id: mime-text.el,v 0.11 1997-03-04 12:39:25 morioka Exp $
-;; Keywords: text, MIME, multimedia, mail, news
-
-;; 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 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:
-
-;;; @ code conversion
-;;;
-
-(defvar mime-text-decoder-alist
- '((mime/show-message-mode . mime-charset/decode-buffer)
- (mime-temp-message-mode . mime-charset/decode-buffer)
- (t . mime-charset/maybe-decode-buffer)
- ))
-
-(defun mime-charset/decode-buffer (charset &optional encoding)
- (decode-mime-charset-region (point-min)(point-max)
- (or charset default-mime-charset))
- )
-
-(defun mime-charset/maybe-decode-buffer (charset &optional encoding)
- (or (member encoding '(nil "7bit" "8bit" "binary"))
- (mime-charset/decode-buffer charset)
- ))
-
-(defun mime-preview/decode-text-buffer (charset encoding)
- (mime-decode-region (point-min) (point-max) encoding)
- (let* ((mode mime::preview/original-major-mode)
- (m (or (save-excursion
- (set-buffer mime::preview/article-buffer)
- mime::article/code-converter)
- (cdr (or (assq mode mime-text-decoder-alist)
- (assq t mime-text-decoder-alist)))
- ))
- )
- (and (functionp m)
- (funcall m charset encoding)
- )))
-
-
-;;; @ for URL
-;;;
-
-(require 'browse-url)
-
-(defvar mime-text-url-regexp
- "\\(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/plain body.")
-
-(defun mime-text-browse-url (&optional url)
- (if (fboundp browse-url-browser-function)
- (if url
- (funcall browse-url-browser-function url)
- (call-interactively browse-url-browser-function))
- (if (fboundp mime-button-mother-dispatcher)
- (call-interactively mime-button-mother-dispatcher)
- )
- ))
-
-
-;;; @ content filters for mime-text
-;;;
-
-(defun mime-preview/filter-for-text/plain (ctype params encoding)
- (mime-preview/decode-text-buffer (cdr (assoc "charset" params)) encoding)
- (goto-char (point-max))
- (if (not (eq (char-after (1- (point))) ?\n))
- (insert "\n")
- )
- (if browse-url-browser-function
- (progn
- (goto-char (point-min))
- (while (re-search-forward mime-text-url-regexp nil t)
- (let ((beg (match-beginning 0))
- (end (match-end 0)))
- (mime-add-button beg end
- (function mime-text-browse-url)
- (list (buffer-substring beg end))))
- )))
- (run-hooks 'mime-view-plain-text-preview-hook)
- )
-
-(defun mime-preview/filter-for-text/richtext (ctype params encoding)
- (let* ((mode mime::preview/original-major-mode)
- (m (assq mode mime-text-decoder-alist))
- (charset (cdr (assoc "charset" params)))
- (beg (point-min))
- )
- (remove-text-properties beg (point-max) '(face nil))
- (mime-preview/decode-text-buffer charset encoding)
- (richtext-decode beg (point-max))
- ))
-
-(defun mime-preview/filter-for-text/enriched (ctype params encoding)
- (let* ((mode mime::preview/original-major-mode)
- (m (assq mode mime-text-decoder-alist))
- (charset (cdr (assoc "charset" params)))
- (beg (point-min))
- )
- (remove-text-properties beg (point-max) '(face nil))
- (mime-preview/decode-text-buffer charset encoding)
- (enriched-decode beg (point-max))
- ))
-
-
-;;; @ end
-;;;
-
-(provide 'mime-text)
-
-;;; mime-text.el ends here
+++ /dev/null
-;;; mime-view.el --- interactive MIME viewer for GNU Emacs
-
-;; Copyright (C) 1995,1996,1997 Free Software Foundation, Inc.
-
-;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
-;; Created: 1994/7/13
-;; Renamed: 1994/8/31 from tm-body.el
-;; Renamed: 1997/02/19 from tm-view.el
-;; Version: $Revision: 0.22 $
-;; Keywords: MIME, multimedia, mail, news
-
-;; 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 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 'cl)
-(require 'std11)
-(require 'mel)
-(require 'eword-decode)
-(require 'mime-parse)
-(require 'mime-text)
-
-
-;;; @ version
-;;;
-
-(defconst mime-view-RCS-ID
- "$Id: mime-view.el,v 0.22 1997-03-10 13:44:24 morioka Exp $")
-
-(defconst mime-view-version (get-version-string mime-view-RCS-ID))
-
-
-;;; @ variables
-;;;
-
-(defvar mime/content-decoding-condition
- '(((type . "text/plain")
- (method "tm-plain" nil 'file 'type 'encoding 'mode 'name)
- (mode "play" "print")
- )
- ((type . "text/html")
- (method "tm-html" nil 'file 'type 'encoding 'mode 'name)
- (mode . "play")
- )
- ((type . "text/x-rot13-47")
- (method . mime-article/decode-caesar)
- (mode . "play")
- )
- ((type . "audio/basic")
- (method "tm-au" nil 'file 'type 'encoding 'mode 'name)
- (mode . "play")
- )
-
- ((type . "image/jpeg")
- (method "tm-image" nil 'file 'type 'encoding 'mode 'name)
- (mode "play" "print")
- )
- ((type . "image/gif")
- (method "tm-image" nil 'file 'type 'encoding 'mode 'name)
- (mode "play" "print")
- )
- ((type . "image/tiff")
- (method "tm-image" nil 'file 'type 'encoding 'mode 'name)
- (mode "play" "print")
- )
- ((type . "image/x-tiff")
- (method "tm-image" nil 'file 'type 'encoding 'mode 'name)
- (mode "play" "print")
- )
- ((type . "image/x-xbm")
- (method "tm-image" nil 'file 'type 'encoding 'mode 'name)
- (mode "play" "print")
- )
- ((type . "image/x-pic")
- (method "tm-image" nil 'file 'type 'encoding 'mode 'name)
- (mode "play" "print")
- )
- ((type . "image/x-mag")
- (method "tm-image" nil 'file 'type 'encoding 'mode 'name)
- (mode "play" "print")
- )
-
- ((type . "video/mpeg")
- (method "tm-mpeg" nil 'file 'type 'encoding 'mode 'name)
- (mode . "play")
- )
-
- ((type . "application/postscript")
- (method "tm-ps" nil 'file 'type 'encoding 'mode 'name)
- (mode "play" "print")
- )
- ((type . "application/octet-stream")
- (method "tm-file" nil 'file 'type 'encoding 'mode 'name)
- (mode "play" "print")
- )
-
- ;;((type . "message/external-body")
- ;; (method "xterm" nil
- ;; "-e" "showexternal"
- ;; 'file '"access-type" '"name" '"site" '"directory"))
- ((type . "message/rfc822")
- (method . mime-article/view-message/rfc822)
- (mode . "play")
- )
- ((type . "message/partial")
- (method . mime-article/decode-message/partial)
- (mode . "play")
- )
- ((type . "message/external-body")
- ("access-type" . "anon-ftp")
- (method . mime-article/decode-message/external-ftp)
- )
-
- ((method "metamail" t "-m" "tm" "-x" "-d" "-z" "-e" 'file)
- (mode . "play")
- )
- ((method "tm-file" nil 'file 'type 'encoding 'mode 'name)
- (mode . "extract")
- )
- ))
-
-(defvar mime-view-childrens-header-showing-Content-Type-list
- '("message/rfc822" "message/news"))
-
-(defvar mime-view-default-showing-Content-Type-list
- '("text/plain" nil "text/richtext" "text/enriched"
- "text/x-latex" "application/x-latex"
- "message/delivery-status"
- "application/pgp" "text/x-pgp"
- "application/octet-stream"
- "application/x-selection" "application/x-comment"))
-
-(defvar mime-view-content-button-ignored-ctype-list
- '("application/x-selection"))
-
-(defvar mime-view-content-button-visible-ctype-list
- '("application/pgp"))
-
-(defvar mime-view-uuencode-encoding-name-list '("x-uue" "x-uuencode"))
-
-(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. [mime-view.el]")
-
-(defvar mime-view-ignored-field-regexp
- (concat "^"
- (apply (function regexp-or) mime-view-ignored-field-list)
- ":"))
-
-(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. [mime-view.el]")
-
-(defvar mime-view-visible-field-regexp
- (concat "^"
- (apply (function regexp-or) mime-view-visible-field-list)
- ":"))
-
-(defvar mime-view-redisplay nil)
-
-(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. ]]"
- ))
-
-
-;;; @@ predicate functions
-;;;
-
-(defun mime-view-header-visible-p (rcnum cinfo &optional ctype)
- (or (null rcnum)
- (progn
- (setq ctype
- (mime::content-info/type
- (mime-article/rcnum-to-cinfo (cdr rcnum) cinfo)
- ))
- (member ctype mime-view-childrens-header-showing-Content-Type-list)
- )))
-
-(defun mime-view-body-visible-p (rcnum cinfo &optional ctype)
- (let (ccinfo)
- (or ctype
- (setq ctype
- (mime::content-info/type
- (setq ccinfo (mime-article/rcnum-to-cinfo rcnum cinfo))
- ))
- )
- (and (member ctype mime-view-default-showing-Content-Type-list)
- (if (string-equal ctype "application/octet-stream")
- (progn
- (or ccinfo
- (setq ccinfo (mime-article/rcnum-to-cinfo rcnum cinfo))
- )
- (member (mime::content-info/encoding ccinfo)
- '(nil "7bit" "8bit"))
- )
- t))
- ))
-
-
-;;; @@ content button
-;;;
-
-(defun mime-preview/insert-content-button
- (rcnum cinfo ctype params subj encoding)
- (save-restriction
- (narrow-to-region (point)(point))
- (let ((access-type (assoc "access-type" params))
- (charset (assoc "charset" params))
- (num (or (cdr (assoc "x-part-number" params))
- (if (consp rcnum)
- (mapconcat (function
- (lambda (num)
- (format "%s" (1+ num))
- ))
- (reverse rcnum) ".")
- "0"))
- ))
- (cond (access-type
- (let ((server (assoc "server" params)))
- (setq access-type (cdr access-type))
- (if server
- (insert (format "[%s %s ([%s] %s)]\n" num subj
- access-type (cdr server)))
- (let ((site (cdr (assoc "site" params)))
- (dir (cdr (assoc "directory" params)))
- )
- (insert (format "[%s %s ([%s] %s:%s)]\n" num subj
- access-type site dir))
- )))
- )
- (t
- (insert (concat "[" num " " subj))
- (let ((rest
- (if (setq charset (cdr charset))
- (if encoding
- (format " <%s; %s (%s)>]\n"
- ctype charset encoding)
- (format " <%s; %s>]\n" ctype charset)
- )
- (format " <%s>]\n" ctype)
- )))
- (if (>= (+ (current-column)(length rest))(window-width))
- (setq rest (concat "\n\t" rest))
- )
- (insert rest)
- ))))
- (mime-add-button (point-min)(1- (point-max))
- (function mime-view-play-content))
- ))
-
-(defun mime-preview/default-content-button-function
- (rcnum cinfo ctype params subj encoding)
- (if (and (consp rcnum)
- (not (member
- ctype
- mime-view-content-button-ignored-ctype-list)))
- (mime-preview/insert-content-button
- rcnum cinfo ctype params subj encoding)
- ))
-
-(defvar mime-preview/content-button-function
- (function mime-preview/default-content-button-function))
-
-
-;;; @@ content header filter
-;;;
-
-(defun mime-preview/cut-header ()
- (goto-char (point-min))
- (while (and
- (re-search-forward mime-view-ignored-field-regexp nil t)
- (let* ((beg (match-beginning 0))
- (end (match-end 0))
- (name (buffer-substring beg end))
- )
- (if (not (string-match mime-view-visible-field-regexp name))
- (delete-region
- beg
- (save-excursion
- (and
- (re-search-forward "^\\([^ \t]\\|$\\)" nil t)
- (match-beginning 0)
- )))
- )
- t)))
- )
-
-(defun mime-view-default-content-header-filter ()
- (mime-preview/cut-header)
- (eword-decode-header)
- )
-
-(defvar mime-view-content-header-filter-alist nil)
-
-
-;;; @@ content filter
-;;;
-
-(defvar mime-view-content-filter-alist
- '(("text/enriched" . mime-preview/filter-for-text/enriched)
- ("text/richtext" . mime-preview/filter-for-text/richtext)
- (t . mime-preview/filter-for-text/plain)
- ))
-
-
-;;; @@ content separator
-;;;
-
-(defun mime-preview/default-content-separator (rcnum cinfo ctype params subj)
- (if (and (not (mime-view-header-visible-p rcnum cinfo ctype))
- (not (mime-view-body-visible-p rcnum cinfo ctype))
- )
- (progn
- (goto-char (point-max))
- (insert "\n")
- )))
-
-
-;;; @@ buffer local variables
-;;;
-
-;; for XEmacs
-(defvar mime::article/preview-buffer nil)
-(defvar mime::article/code-converter nil)
-(defvar mime::preview/article-buffer nil)
-
-(make-variable-buffer-local 'mime::article/content-info)
-(make-variable-buffer-local 'mime::article/preview-buffer)
-(make-variable-buffer-local 'mime::article/code-converter)
-
-(make-variable-buffer-local 'mime::preview/mother-buffer)
-(make-variable-buffer-local 'mime::preview/content-list)
-(make-variable-buffer-local 'mime::preview/article-buffer)
-(make-variable-buffer-local 'mime::preview/original-major-mode)
-(make-variable-buffer-local 'mime::preview/original-window-configuration)
-
-
-;;; @@ quitting method
-;;;
-
-(defvar mime-view-quitting-method-alist
- '((mime/show-message-mode
- . mime-view-quitting-method-for-mime/show-message-mode)))
-
-(defvar mime-view-over-to-previous-method-alist nil)
-(defvar mime-view-over-to-next-method-alist nil)
-
-(defvar mime-view-show-summary-method nil)
-
-
-;;; @@ following method
-;;;
-
-(defvar mime-view-following-method-alist nil)
-
-(defvar mime-view-following-required-fields-list
- '("From"))
-
-
-;;; @@ X-Face
-;;;
-
-;; hack from Gnus 5.0.4.
-
-(defvar mime-view-x-face-to-pbm-command
- "{ echo '/* Width=48, Height=48 */'; uncompface; } | icontopbm")
-
-(defvar mime-view-x-face-command
- (concat mime-view-x-face-to-pbm-command
- " | xv -quit -")
- "String to be executed to display an X-Face field.
-The command will be executed in a sub-shell asynchronously.
-The compressed face will be piped to this command.")
-
-(defun mime-view-x-face-function ()
- "Function to display X-Face field. You can redefine to customize."
- ;; 1995/10/12 (c.f. tm-eng:130)
- ;; fixed by Eric Ding <ericding@San-Jose.ate.slb.com>
- (save-restriction
- (narrow-to-region (point-min) (re-search-forward "^$" nil t))
- ;; end
- (goto-char (point-min))
- (if (re-search-forward "^X-Face:[ \t]*" nil t)
- (let ((beg (match-end 0))
- (end (std11-field-end))
- )
- (call-process-region beg end "sh" nil 0 nil
- "-c" mime-view-x-face-command)
- ))))
-
-
-;;; @@ utility
-;;;
-
-(defun mime-preview/get-original-major-mode ()
- (if mime::preview/mother-buffer
- (save-excursion
- (set-buffer mime::preview/mother-buffer)
- (mime-preview/get-original-major-mode)
- )
- mime::preview/original-major-mode))
-
-
-;;; @ data structures
-;;;
-
-;;; @@ preview-content-info
-;;;
-
-(define-structure mime::preview-content-info
- point-min point-max buffer content-info)
-
-
-;;; @ buffer setup
-;;;
-
-(defun mime-view-setup-buffer (&optional ctl encoding ibuf obuf)
- (if ibuf
- (progn
- (get-buffer ibuf)
- (set-buffer ibuf)
- ))
- (or mime-view-redisplay
- (setq mime::article/content-info (mime-parse-message ctl encoding))
- )
- (let ((ret (mime-view-make-preview-buffer obuf)))
- (setq mime::article/preview-buffer (car ret))
- ret))
-
-(defun mime-view-make-preview-buffer (&optional obuf)
- (let* ((cinfo mime::article/content-info)
- (pcl (mime/flatten-content-info cinfo))
- (dest (make-list (length pcl) nil))
- (the-buf (current-buffer))
- (mode major-mode)
- )
- (or obuf
- (setq obuf (concat "*Preview-" (buffer-name the-buf) "*")))
- (set-buffer (get-buffer-create obuf))
- (setq buffer-read-only nil)
- (widen)
- (erase-buffer)
- (setq mime::preview/article-buffer the-buf)
- (setq mime::preview/original-major-mode mode)
- (setq major-mode 'mime-view-mode)
- (setq mode-name "MIME-View")
- (let ((drest dest))
- (while pcl
- (setcar drest
- (mime-preview/display-content (car pcl) cinfo the-buf obuf))
- (setq pcl (cdr pcl)
- drest (cdr drest))
- ))
- (set-buffer-modified-p nil)
- (setq buffer-read-only t)
- (set-buffer the-buf)
- (list obuf dest)
- ))
-
-(defun mime-preview/display-content (content cinfo ibuf obuf)
- (let* ((beg (mime::content-info/point-min content))
- (end (mime::content-info/point-max content))
- (ctype (mime::content-info/type content))
- (params (mime::content-info/parameters content))
- (encoding (mime::content-info/encoding content))
- (rcnum (mime::content-info/rcnum content))
- he e nb ne subj)
- (set-buffer ibuf)
- (goto-char beg)
- (setq he (if (re-search-forward "^$" nil t)
- (1+ (match-end 0))
- end))
- (if (> he end)
- (setq he end)
- )
- (save-restriction
- (narrow-to-region beg end)
- (setq subj
- (eword-decode-string
- (mime-article/get-subject params encoding)))
- )
- (set-buffer obuf)
- (setq nb (point))
- (narrow-to-region nb nb)
- (funcall mime-preview/content-button-function
- rcnum cinfo ctype params subj encoding)
- (if (mime-view-header-visible-p rcnum cinfo ctype)
- (mime-preview/display-header beg he)
- )
- (if (and (null rcnum)
- (member
- ctype mime-view-content-button-visible-ctype-list))
- (save-excursion
- (goto-char (point-max))
- (mime-preview/insert-content-button
- rcnum cinfo ctype params subj encoding)
- ))
- (cond ((mime-view-body-visible-p rcnum cinfo ctype)
- (mime-preview/display-body he end
- rcnum cinfo ctype params subj encoding)
- )
- ((equal ctype "message/partial")
- (mime-preview/display-message/partial)
- )
- ((and (null rcnum)
- (null (mime::content-info/children cinfo))
- )
- (goto-char (point-max))
- (mime-preview/insert-content-button
- rcnum cinfo ctype params subj encoding)
- ))
- (mime-preview/default-content-separator rcnum cinfo ctype params subj)
- (prog1
- (progn
- (setq ne (point-max))
- (widen)
- (mime::preview-content-info/create nb (1- ne) ibuf content)
- )
- (goto-char ne)
- )))
-
-(defun mime-preview/display-header (beg end)
- (save-restriction
- (narrow-to-region (point)(point))
- (insert-buffer-substring mime::preview/article-buffer beg end)
- (let ((f (cdr (assq mime::preview/original-major-mode
- mime-view-content-header-filter-alist))))
- (if (functionp f)
- (funcall f)
- (mime-view-default-content-header-filter)
- ))
- (run-hooks 'mime-view-content-header-filter-hook)
- ))
-
-(defun mime-preview/display-body (beg end
- rcnum cinfo ctype params subj encoding)
- (save-restriction
- (narrow-to-region (point-max)(point-max))
- (insert-buffer-substring mime::preview/article-buffer beg end)
- (let ((f (cdr (or (assoc ctype mime-view-content-filter-alist)
- (assq t mime-view-content-filter-alist)))))
- (and (functionp f)
- (funcall f ctype params encoding)
- )
- )))
-
-(defun mime-preview/display-message/partial ()
- (save-restriction
- (goto-char (point-max))
- (if (not (search-backward "\n\n" nil t))
- (insert "\n")
- )
- (let ((be (point-max)))
- (narrow-to-region be be)
- (insert mime-view-announcement-for-message/partial)
- (mime-add-button (point-min)(point-max)
- (function mime-view-play-content))
- )))
-
-(defun mime-article/get-uu-filename (param &optional encoding)
- (if (member (or encoding
- (cdr (assq 'encoding param))
- )
- mime-view-uuencode-encoding-name-list)
- (save-excursion
- (or (if (re-search-forward "^begin [0-9]+ " nil t)
- (if (looking-at ".+$")
- (buffer-substring (match-beginning 0)(match-end 0))
- ))
- ""))
- ))
-
-(defun mime-article/get-subject (param &optional encoding)
- (or (std11-find-field-body '("Content-Description" "Subject"))
- (let (ret)
- (if (or (and (setq ret (mime/Content-Disposition))
- (setq ret (assoc "filename" (cdr ret)))
- )
- (setq ret (assoc "name" param))
- (setq ret (assoc "x-name" param))
- )
- (std11-strip-quoted-string (cdr ret))
- ))
- (mime-article/get-uu-filename param encoding)
- ""))
-
-
-;;; @ content information
-;;;
-
-(defun mime-article/point-content-number (p &optional cinfo)
- (or cinfo
- (setq cinfo mime::article/content-info)
- )
- (let ((b (mime::content-info/point-min cinfo))
- (e (mime::content-info/point-max cinfo))
- (c (mime::content-info/children cinfo))
- )
- (if (and (<= b p)(<= p e))
- (or (let (co ret (sn 0))
- (catch 'tag
- (while c
- (setq co (car c))
- (setq ret (mime-article/point-content-number p co))
- (cond ((eq ret t) (throw 'tag (list sn)))
- (ret (throw 'tag (cons sn ret)))
- )
- (setq c (cdr c))
- (setq sn (1+ sn))
- )))
- t))))
-
-(defun mime-article/rcnum-to-cinfo (rcnum &optional cinfo)
- (or cinfo
- (setq cinfo mime::article/content-info)
- )
- (find-if (function
- (lambda (ci)
- (equal (mime::content-info/rcnum ci) rcnum)
- ))
- (mime/flatten-content-info cinfo)
- ))
-
-(defun mime-article/cnum-to-cinfo (cn &optional cinfo)
- (or cinfo
- (setq cinfo mime::article/content-info)
- )
- (if (eq cn t)
- cinfo
- (let ((sn (car cn)))
- (if (null sn)
- cinfo
- (let ((rc (nth sn (mime::content-info/children cinfo))))
- (if rc
- (mime-article/cnum-to-cinfo (cdr cn) rc)
- ))
- ))))
-
-(defun mime/flatten-content-info (&optional cinfo)
- (or cinfo
- (setq cinfo mime::article/content-info)
- )
- (let ((dest (list cinfo))
- (rcl (mime::content-info/children cinfo))
- )
- (while rcl
- (setq dest (nconc dest (mime/flatten-content-info (car rcl))))
- (setq rcl (cdr rcl))
- )
- dest))
-
-(defun mime-preview/point-pcinfo (p &optional pcl)
- (or pcl
- (setq pcl mime::preview/content-list)
- )
- (catch 'tag
- (let ((r pcl) cell)
- (while r
- (setq cell (car r))
- (if (and (<= (mime::preview-content-info/point-min cell) p)
- (<= p (mime::preview-content-info/point-max cell))
- )
- (throw 'tag cell)
- )
- (setq r (cdr r))
- ))
- (car (last pcl))
- ))
-
-
-;;; @ MIME viewer mode
-;;;
-
-(defconst mime-view-menu-title "MIME-View")
-(defconst mime-view-menu-list
- '((up "Move to upper content" mime-view-up-content)
- (previous "Move to previous content" mime-view-previous-content)
- (next "Move to next content" mime-view-next-content)
- (scroll-down "Scroll to previous content" mime-view-scroll-down-content)
- (scroll-up "Scroll to next content" mime-view-scroll-up-content)
- (play "Play Content" mime-view-play-content)
- (extract "Extract Content" mime-view-extract-content)
- (print "Print" mime-view-print-content)
- (x-face "Show X Face" mime-view-display-x-face)
- )
- "Menu for MIME Viewer")
-
-(cond (running-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)
- )
- (t
- (defvar mouse-button-2 [mouse-2])
- ))
-
-(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-view-up-content))
- (define-key mime-view-mode-map
- "p" (function mime-view-previous-content))
- (define-key mime-view-mode-map
- "n" (function mime-view-next-content))
- (define-key mime-view-mode-map
- "\e\t" (function mime-view-previous-content))
- (define-key mime-view-mode-map
- "\t" (function mime-view-next-content))
- (define-key mime-view-mode-map
- " " (function mime-view-scroll-up-content))
- (define-key mime-view-mode-map
- "\M- " (function mime-view-scroll-down-content))
- (define-key mime-view-mode-map
- "\177" (function mime-view-scroll-down-content))
- (define-key mime-view-mode-map
- "\C-m" (function mime-view-next-line-content))
- (define-key mime-view-mode-map
- "\C-\M-m" (function mime-view-previous-line-content))
- (define-key mime-view-mode-map
- "v" (function mime-view-play-content))
- (define-key mime-view-mode-map
- "e" (function mime-view-extract-content))
- (define-key mime-view-mode-map
- "\C-c\C-p" (function mime-view-print-content))
- (define-key mime-view-mode-map
- "a" (function mime-view-follow-content))
- (define-key mime-view-mode-map
- "q" (function mime-view-quit))
- (define-key mime-view-mode-map
- "h" (function mime-view-show-summary))
- (define-key mime-view-mode-map
- "\C-c\C-x" (function mime-view-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))
- (if (functionp default)
- (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 (running-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 [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)
- )
- ))
- (use-local-map mime-view-mode-map)
- (run-hooks 'mime-view-define-keymap-hook)
- ))
-
-(defun mime-view-mode (&optional mother ctl encoding ibuf obuf
- 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.
-x Display X-Face
-q Quit
-button-2 Move to point under the mouse cursor
- and decode current content as `play mode'
-"
- (interactive)
- (let ((buf (get-buffer mime/output-buffer-name)))
- (if buf
- (save-excursion
- (set-buffer buf)
- (erase-buffer)
- )))
- (let ((ret (mime-view-setup-buffer ctl encoding ibuf obuf))
- (win-conf (current-window-configuration))
- )
- (prog1
- (switch-to-buffer (car ret))
- (setq mime::preview/original-window-configuration win-conf)
- (if mother
- (progn
- (setq mime::preview/mother-buffer mother)
- ))
- (mime-view-define-keymap default-keymap-or-function)
- (setq mime::preview/content-list (nth 1 ret))
- (goto-char
- (let ((ce (mime::preview-content-info/point-max
- (car mime::preview/content-list)
- ))
- e)
- (goto-char (point-min))
- (search-forward "\n\n" nil t)
- (setq e (match-end 0))
- (if (<= e ce)
- e
- ce)))
- (run-hooks 'mime-view-mode-hook)
- )))
-
-(defun mime-preview/point-content-number (point)
- (save-window-excursion
- (let ((pc (mime-preview/point-pcinfo (point)))
- cinfo)
- (switch-to-buffer (mime::preview-content-info/buffer pc))
- (setq cinfo (mime::preview-content-info/content-info pc))
- (mime-article/point-content-number (mime::content-info/point-min cinfo))
- )))
-
-(defun mime-preview/cinfo-to-pcinfo (cinfo)
- (let ((rpcl mime::preview/content-list) cell)
- (catch 'tag
- (while rpcl
- (setq cell (car rpcl))
- (if (eq cinfo (mime::preview-content-info/content-info cell))
- (throw 'tag cell)
- )
- (setq rpcl (cdr rpcl))
- ))))
-
-(autoload 'mime-preview/decode-content "mime-play")
-
-(defvar mime-view-decoding-mode "play" "MIME body decoding mode")
-
-(defun mime-view-play-content ()
- (interactive)
- (let ((mime-view-decoding-mode "play"))
- (mime-preview/decode-content)
- ))
-
-(defun mime-view-extract-content ()
- (interactive)
- (let ((mime-view-decoding-mode "extract"))
- (mime-preview/decode-content)
- ))
-
-(defun mime-view-print-content ()
- (interactive)
- (let ((mime-view-decoding-mode "print"))
- (mime-preview/decode-content)
- ))
-
-(defun mime-view-follow-content ()
- (interactive)
- (let ((root-cinfo
- (mime::preview-content-info/content-info
- (car mime::preview/content-list)))
- pc p-beg p-end cinfo rcnum)
- (let ((rest mime::preview/content-list)
- b e cell len rc)
- (if (catch 'tag
- (while (setq cell (car rest))
- (setq b (mime::preview-content-info/point-min cell)
- e (mime::preview-content-info/point-max cell))
- (setq rest (cdr rest))
- (if (and (<= b (point))(<= (point) e))
- (throw 'tag cell)
- )
- ))
- (progn
- (setq pc cell
- cinfo (mime::preview-content-info/content-info pc)
- rcnum (mime::content-info/rcnum cinfo))
- (setq len (length rcnum))
- (setq p-beg (mime::preview-content-info/point-min pc)
- p-end (mime::preview-content-info/point-max pc))
- (while (and (setq cell (car rest))
- (progn
- (setq rc
- (mime::content-info/rcnum
- (mime::preview-content-info/content-info
- cell)))
- (equal rcnum
- (nthcdr (- (length rc) len) rc))
- ))
- (setq p-end (mime::preview-content-info/point-max cell))
- (setq rest (cdr rest))
- ))))
- (if pc
- (let* ((mode (mime-preview/get-original-major-mode))
- (new-name (format "%s-%s" (buffer-name) (reverse rcnum)))
- new-buf
- (the-buf (current-buffer))
- (a-buf mime::preview/article-buffer)
- (hb (mime::content-info/point-min cinfo))
- (he (mime::content-info/point-max cinfo))
- fields from to cc reply-to subj mid f)
- (save-excursion
- (set-buffer (setq new-buf (get-buffer-create new-name)))
- (erase-buffer)
- (insert-buffer-substring the-buf p-beg p-end)
- (goto-char (point-min))
- (if (mime-view-header-visible-p rcnum root-cinfo)
- (delete-region (goto-char (point-min))
- (if (re-search-forward "^$" nil t)
- (match-end 0)
- (point-min)))
- )
- (goto-char (point-min))
- (insert "\n")
- (goto-char (point-min))
- (let ((rcnum (mime::content-info/rcnum cinfo)) ci str)
- (while (progn
- (setq str
- (save-excursion
- (set-buffer a-buf)
- (setq ci (mime-article/rcnum-to-cinfo rcnum))
- (save-restriction
- (narrow-to-region
- (mime::content-info/point-min ci)
- (mime::content-info/point-max ci)
- )
- (std11-header-string-except
- (concat "^"
- (apply (function regexp-or) fields)
- ":") ""))))
- (if (string-equal (mime::content-info/type ci)
- "message/rfc822")
- nil
- (if str
- (insert str)
- )
- rcnum))
- (setq fields (std11-collect-field-names)
- rcnum (cdr rcnum))
- )
- )
- (let ((rest mime-view-following-required-fields-list))
- (while rest
- (let ((field-name (car rest)))
- (or (std11-field-body field-name)
- (insert
- (format
- (concat field-name
- ": "
- (save-excursion
- (set-buffer the-buf)
- (set-buffer mime::preview/mother-buffer)
- (set-buffer mime::preview/article-buffer)
- (std11-field-body field-name)
- )
- "\n")))
- ))
- (setq rest (cdr rest))
- ))
- (eword-decode-header)
- )
- (let ((f (cdr (assq mode mime-view-following-method-alist))))
- (if (functionp f)
- (funcall f new-buf)
- (message
- (format
- "Sorry, following method for %s is not implemented yet."
- mode))
- ))
- ))))
-
-(defun mime-view-display-x-face ()
- (interactive)
- (save-window-excursion
- (set-buffer mime::preview/article-buffer)
- (mime-view-x-face-function)
- ))
-
-(defun mime-view-up-content ()
- (interactive)
- (let* ((pc (mime-preview/point-pcinfo (point)))
- (cinfo (mime::preview-content-info/content-info pc))
- (rcnum (mime::content-info/rcnum cinfo))
- )
- (if rcnum
- (let ((r (save-excursion
- (set-buffer (mime::preview-content-info/buffer pc))
- (mime-article/rcnum-to-cinfo (cdr rcnum))
- ))
- (rpcl mime::preview/content-list)
- cell)
- (while (and
- (setq cell (car rpcl))
- (not (eq r (mime::preview-content-info/content-info cell)))
- )
- (setq rpcl (cdr rpcl))
- )
- (goto-char (mime::preview-content-info/point-min cell))
- )
- (mime-view-quit)
- )))
-
-(defun mime-view-previous-content ()
- (interactive)
- (let* ((pcl mime::preview/content-list)
- (p (point))
- (i (- (length pcl) 1))
- beg)
- (catch 'tag
- (while (> i 0)
- (setq beg (mime::preview-content-info/point-min (nth i pcl)))
- (if (> p beg)
- (throw 'tag (goto-char beg))
- )
- (setq i (- i 1))
- )
- (let ((f (assq mime::preview/original-major-mode
- mime-view-over-to-previous-method-alist)))
- (if f
- (funcall (cdr f))
- ))
- )
- ))
-
-(defun mime-view-next-content ()
- (interactive)
- (let ((pcl mime::preview/content-list)
- (p (point))
- beg)
- (catch 'tag
- (while pcl
- (setq beg (mime::preview-content-info/point-min (car pcl)))
- (if (< p beg)
- (throw 'tag (goto-char beg))
- )
- (setq pcl (cdr pcl))
- )
- (let ((f (assq mime::preview/original-major-mode
- mime-view-over-to-next-method-alist)))
- (if f
- (funcall (cdr f))
- ))
- )
- ))
-
-(defun mime-view-scroll-up-content (&optional h)
- (interactive)
- (or h
- (setq h (- (window-height) 1))
- )
- (if (= (point) (point-max))
- (let ((f (assq mime::preview/original-major-mode
- mime-view-over-to-next-method-alist)))
- (if f
- (funcall (cdr f))
- ))
- (let ((pcl mime::preview/content-list)
- (p (point))
- np beg)
- (setq np
- (or (catch 'tag
- (while pcl
- (setq beg (mime::preview-content-info/point-min (car pcl)))
- (if (< p beg)
- (throw 'tag beg)
- )
- (setq pcl (cdr pcl))
- ))
- (point-max)))
- (forward-line h)
- (if (> (point) np)
- (goto-char np)
- )
- ;;(show-subtree)
- ))
- )
-
-(defun mime-view-scroll-down-content (&optional h)
- (interactive)
- (or h
- (setq h (- (window-height) 1))
- )
- (if (= (point) (point-min))
- (let ((f (assq mime::preview/original-major-mode
- mime-view-over-to-previous-method-alist)))
- (if f
- (funcall (cdr f))
- ))
- (let ((pcl mime::preview/content-list)
- (p (point))
- pp beg)
- (setq pp
- (or (let ((i (- (length pcl) 1)))
- (catch 'tag
- (while (> i 0)
- (setq beg (mime::preview-content-info/point-min
- (nth i pcl)))
- (if (> p beg)
- (throw 'tag beg)
- )
- (setq i (- i 1))
- )))
- (point-min)))
- (forward-line (- h))
- (if (< (point) pp)
- (goto-char pp)
- )))
- )
-
-(defun mime-view-next-line-content ()
- (interactive)
- (mime-view-scroll-up-content 1)
- )
-
-(defun mime-view-previous-line-content ()
- (interactive)
- (mime-view-scroll-down-content 1)
- )
-
-(defun mime-view-quit ()
- (interactive)
- (let ((r (save-excursion
- (set-buffer (mime::preview-content-info/buffer
- (mime-preview/point-pcinfo (point))))
- (assq major-mode mime-view-quitting-method-alist)
- )))
- (if r
- (funcall (cdr r))
- )))
-
-(defun mime-view-show-summary ()
- (interactive)
- (let ((r (save-excursion
- (set-buffer
- (mime::preview-content-info/buffer
- (mime-preview/point-pcinfo (point)))
- )
- (assq major-mode mime-view-show-summary-method)
- )))
- (if r
- (funcall (cdr r))
- )))
-
-(defun mime-view-kill-buffer ()
- (interactive)
- (kill-buffer (current-buffer))
- )
-
-
-;;; @ end
-;;;
-
-(provide 'mime-view)
-
-(run-hooks 'mime-view-load-hook)
-
-;;; mime-view.el ends here
+++ /dev/null
-;;; semi-setup.el --- setup file for MIME-View.
-
-;; Copyright (C) 1994,1995,1996,1997 Free Software Foundation, Inc.
-
-;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
-;; Version: $Id: semi-setup.el,v 0.15 1997-03-14 08:46:14 morioka Exp $
-;; Keywords: mail, news, MIME, multimedia, multilingual, encoded-word
-
-;; 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 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 'file-detect)
-
-
-;;; @ for mime-view
-;;;
-
-(call-after-loaded
- 'mime-view
- (function
- (lambda ()
- ;; for message/partial
- (require 'mime-partial)
- )))
-
-
-;; for image/* and X-Face
-(defvar mime-setup-enable-inline-image
- (and window-system
- (or running-xemacs
- (and (featurep 'mule)(module-installed-p 'bitmap))
- ))
- "*If it is non-nil, semi-setup sets up to use mime-image.")
-
-(if mime-setup-enable-inline-image
- (call-after-loaded 'mime-view
- (function
- (lambda ()
- (require 'mime-image)
- )))
- )
-
-
-(defvar mime-setup-enable-pgp
- (module-installed-p 'mailcrypt)
- "*If it is non-nil, semi-setup sets uf to use mime-pgp.")
-
-;; for PGP
-(if mime-setup-enable-pgp
- (call-after-loaded 'mime-view
- (function
- (lambda ()
- (require '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)
- ))
- (eword-decode-header)
- (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 ((key (or (cdr (assq major-mode mime-setup-signature-key-alist))
- mime-setup-default-signature-key)))
- (define-key (current-local-map) key (function insert-signature))
- ))
-
-(if mime-setup-use-signature
- (progn
- (autoload 'insert-signature "signature" "Insert signature" t)
- (add-hook 'mime-edit-mode-hook 'mime-setup-set-signature-key)
- (setq gnus-signature-file nil)
- (setq mail-signature nil)
- (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
projects / elisp / semi.git / commitdiff