From: tomo Date: Thu, 12 Mar 1998 19:50:54 +0000 (+0000) Subject: This commit was manufactured by cvs2svn to create branch 'unlabeled-1.99.4'. X-Git-Url: http://git.chise.org/gitweb/?a=commitdiff_plain;h=99a10e6069ff95dcbf1caa33a59d885860e2b4fb;p=elisp%2Fsemi.git This commit was manufactured by cvs2svn to create branch 'unlabeled-1.99.4'. --- diff --git a/Makefile b/Makefile deleted file mode 100644 index 70037bd..0000000 --- a/Makefile +++ /dev/null @@ -1,68 +0,0 @@ -# -# $Id: Makefile,v 1.4 1998-02-28 07:18:46 morioka Exp $ -# - -VERSION = 1.0.1 - -SHELL = /bin/sh -MAKE = make -CC = gcc -CFLAGS = -O2 -TAR = tar -RM = /bin/rm -f -CP = /bin/cp -p -EMACS = emacs - -GOMI = *.elc -FLAGS = -batch -q -no-site-file - -PREFIX = NONE -EXEC_PREFIX = NONE -LISPDIR = NONE - -elc: - $(EMACS) $(FLAGS) -l SEMI-MK -f compile-semi \ - $(PREFIX) $(EXEC_PREFIX) $(LISPDIR) - -install-elc: elc - $(EMACS) $(FLAGS) -l SEMI-MK -f install-semi \ - $(PREFIX) $(EXEC_PREFIX) $(LISPDIR) - - -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 - -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: - cvs commit - sh -c 'cvs tag -RF semi-`echo $(VERSION) \ - | sed s/\\\\./_/ | sed s/\\\\./_/`; \ - cd /tmp; cvs -d $(HOME)/master export -d semi-$(VERSION) \ - -r semi-`echo $(VERSION) \ - | sed s/\\\\./_/ | sed s/\\\\./_/` SEMI/semi' - $(RM) /tmp/semi-$(VERSION)/ftp.in - cd /tmp; $(TAR) cvzf semi-$(VERSION).tar.gz semi-$(VERSION) - cd /tmp; $(RM) -r semi-$(VERSION) - sed "s/VERSION/$(VERSION)/" < ftp.in > ftp diff --git a/README.en b/README.en deleted file mode 100644 index 2c6b236..0000000 --- a/README.en +++ /dev/null @@ -1,162 +0,0 @@ -[README for SEMI kernel package (English Version)] -by MORIOKA Tomohiko -$Id: README.en,v 1.6 1998-03-12 17:14:31 morioka Exp $ - -What's SEMI? ------------- - - SEMI is a library to provide MIME feature for GNU Emacs. MIME is a - proposed internet standard for including content and headers other - than (ASCII) plain text in messages. - - RFC 2045 : Internet Message Bodies - RFC 2046 : Media Types - RFC 2047 : Message Header Extensions - RFC 2048 : MIME Registration Procedures - RFC 2049 : MIME Conformance - - SEMI has the following features: - - - MIME style multilingual header (RFC 2047) - - MIME message viewer (mime-view-mode) (RFC 2045 .. 2049) - - MIME message composer (mime-edit-mode) (RFC 2045 .. 2049) - - MIME message viewer and composer also support following features: - - - filename handling by Content-Disposition field (RFC 1806) - - PGP/MIME security Multiparts (RFC 2015) - - application/pgp (draft-kazu-pgp-mime-00.txt; obsolete) - - text/richtext (RFC 1521; obsolete; preview only) - - text/enriched (RFC 1896) - - Notice that this package does not contain MIME extender for any - MUAs and external methods. They are released as separated packages. - - -Required environment --------------------- - - SEMI supports XEmacs 20.2 or later with mule, and Emacs 20. - - SEMI does not support anything older than Emacs 19.28 or XEmacs - 19.14. SEMI also does not support Emacs 19.29 to 19.34, XEmacs - 19.15 or XEmacs 20.2 without mule, but SEMI may work with them. - - If you use Emacs 20, don't set `enable-multibyte-characters' to - nil. (Maybe non mule setting requires to modify emu. In addition, - it is better to use terminal-coding-system feature) - - SEMI requires APEL and MEL package. Please install them before - installing it. APEL package - is available at: - - ftp://ftp.jaist.ac.jp/pub/GNU/elisp/apel/ - - and MEL package is available at: - - ftp://ftp.jaist.ac.jp/pub/GNU/elisp/mime/libs/ - - Notice that latest version of XEmacs may have latest version of APEL - and MEL, so you should not install them. - - PGP/MIME and application/pgp require mailcrypt or tiny-pgp package. - - The package enriched.el is required to compose text/enriched, so if - you use Emacs anything 19.28 or older (including official version of - MULE 2.3), WYSIWYG composing for text/enriched is not available. - - -Installation ------------- - - % make install - - You can specify the emacs command name, for example - - % make install EMACS=xemacs - - If `EMACS=...' is omitted, EMACS=emacs is used. - - You can specify the prefix of the directory tree for Emacs Lisp - programs and shell scripts, for example: - - % make install PREFIX=~/ - - If `PREFIX=...' is omitted, the prefix of the directory tree of the - specified emacs command is used (perhaps /usr/local). - - For example, if PREFIX=/usr/local and EMACS 19.34 is specified, it - will create the following directory tree: - - /usr/local/share/emacs/19.34/site-lisp/ --- emu - /usr/local/share/emacs/site-lisp/apel/ --- APEL - /usr/local/share/emacs/site-lisp/bitmap/ --- BITMAP-MULE - /usr/local/share/emacs/site-lisp/mu/ --- MU - /usr/local/share/emacs/site-lisp/mel/ --- MEL - /usr/local/share/emacs/site-lisp/semi/ --- SEMI - - You can specify site-lisp directory, for example - - % make install LISPDIR=~/share/emacs/lisp - - If `LISPDIR=...' is omitted, site-lisp directory of the specified - emacs command is used (perhaps /usr/local/share/emacs/site-lisp or - /usr/local/lib/xemacs/site-lisp). - - You can specify other optional settings by editing the file - semi/SEMI-CFG. Please read semi/README.en and comments in - semi/SEMI-CFG. - - -Initialization --------------- - -(a) load-path - - If you are using Emacs or Mule, please add directory of emu, apel, - bitmap, mu, mel and semi to load-path. If you install by default - setting, you can write subdirs.el for example: - - -------------------------------------------------------------------- - (normal-top-level-add-to-load-path - '("apel" "bitmap" "mu" "mel" "semi")) - -------------------------------------------------------------------- - - If you are using XEmacs, there are no need of setting about - load-path. - -(b) mime-setup - - Please insert the following into your ~/.emacs: - - (load "mime-setup") - - -Documentation -------------- - - To get started, please read semi/README.en. - - RFC's 822, 1806, 1847, 1896, 2015, 2045, 2046, 2047, 2048 and 2049 - are available via anonymous ftp: - ftp://ds.internic.net/rfc/ - - -Bug reports ------------ - - If you write bug-reports and/or suggestions for improvement, please - send them to the tm Mailing List: - - bug-tm-en@chamonix.jaist.ac.jp (English) - bug-tm-ja@chamonix.jaist.ac.jp (Japanese) - - Via the tm ML, you can report SEMI bugs, obtain the latest release - of SEMI, and discuss future enhancements to SEMI. To join the tm - ML, send e-mail to - - tm-ja-admin@chamonix.jaist.ac.jp (Japanese) - tm-en-admin@chamonix.jaist.ac.jp (English) - - Since the user registration is done manually, please write the mail - body in human-recognizable language (^_^). diff --git a/SEMI-CFG b/SEMI-CFG deleted file mode 100644 index 61a3adb..0000000 --- a/SEMI-CFG +++ /dev/null @@ -1,140 +0,0 @@ -;;; -*-Emacs-Lisp-*- -;;; -;;; $Id: SEMI-CFG,v 1.1 1998-03-12 19:00:46 morioka Exp $ -;;; - -(defvar default-load-path load-path) - -(add-to-list 'load-path - (expand-file-name "../../site-lisp/apel" data-directory)) -(add-to-list 'load-path - (expand-file-name "." data-directory)) - -(when (boundp 'LISPDIR) - (add-to-list 'default-load-path LISPDIR) - (add-to-list 'load-path LISPDIR) - (add-to-list 'load-path (expand-file-name "apel" LISPDIR)) - ) - -(require 'install) -(require 'cl) - -(add-path "bitmap-mule") -(add-path "mel") - -(add-to-list 'load-path (expand-file-name ".")) - - -;;; @ 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)) - - - - -;;; @ 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 diff --git a/SEMI-ELS b/SEMI-ELS deleted file mode 100644 index 4bb4f87..0000000 --- a/SEMI-ELS +++ /dev/null @@ -1,41 +0,0 @@ -;;; -*-Emacs-Lisp-*- -;;; -;;; $Id: SEMI-ELS,v 1.2 1998-03-12 12:40:37 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-edit - semi-setup mail-mime-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 diff --git a/SEMI-MK b/SEMI-MK deleted file mode 100644 index 0467074..0000000 --- a/SEMI-MK +++ /dev/null @@ -1,54 +0,0 @@ -;;; -*-Emacs-Lisp-*- -;;; -;;; $Id: SEMI-MK,v 1.1 1998-03-12 19:06:44 morioka Exp $ -;;; -;;; Code: - -(defun config-semi () - (let (prefix exec-prefix lisp-dir) - (and (setq prefix (car command-line-args-left)) - (or (string-equal "NONE" prefix) - (defvar PREFIX prefix) - )) - (setq command-line-args-left (cdr command-line-args-left)) - (and (setq exec-prefix (car command-line-args-left)) - (or (string-equal "NONE" exec-prefix) - (defvar EXEC_PREFIX exec-prefix) - )) - (setq command-line-args-left (cdr command-line-args-left)) - (and (setq lisp-dir (car command-line-args-left)) - (or (string-equal "NONE" lisp-dir) - (defvar LISPDIR lisp-dir) - )) - (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 -LISPDIR=%s\n" PREFIX EXEC_PREFIX LISPDIR)) - ) - -(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 diff --git a/eword-decode.el b/eword-decode.el deleted file mode 100644 index aa638db..0000000 --- a/eword-decode.el +++ /dev/null @@ -1,622 +0,0 @@ -;;; eword-decode.el --- RFC 2047 based encoded-word decoder for GNU Emacs - -;; Copyright (C) 1995,1996,1997,1998 Free Software Foundation, Inc. - -;; Author: ENAMI Tsugutomo -;; MORIOKA Tomohiko -;; Maintainer: MORIOKA Tomohiko -;; 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 -;; Keywords: encoded-word, MIME, multilingual, header, mail, news - -;; This file is part of SEMI (Spadework for Emacs MIME Interfaces). - -;; This program is free software; you can redistribute it and/or -;; modify it under the terms of the GNU General Public License as -;; published by the Free Software Foundation; either version 2, or (at -;; your option) any later version. - -;; This program is distributed in the hope that it will be useful, but -;; WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Code: - -(require 'std11-parse) -(require 'mel) -(require 'mime-def) - -(defgroup eword-decode nil - "Encoded-word decoding" - :group 'mime) - -(defconst eword-decode-version - `,(mapconcat #'number-to-string (cdr semi-version) ".")) - - -;;; @ 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 -;;; - -(defcustom eword-decode-ignored-field-list - '(newsgroups path lines nntp-posting-host message-id date) - "*List of field-names to be ignored when decoding. -Each field name must be symbol." - :group 'eword-decode - :type '(repeat symbol)) - -(defcustom eword-decode-structured-field-list - '(reply-to resent-reply-to from resent-from sender resent-sender - to resent-to cc resent-cc bcc resent-bcc dcc - mime-version content-type content-transfer-encoding - content-disposition) - "*List of field-names to decode as structured field. -Each field name must be symbol." - :group 'eword-decode - :type '(repeat symbol)) - -(defun eword-decode-header (&optional code-conversion separator) - "Decode MIME encoded-words in header fields. -If CODE-CONVERSION is nil, it decodes only encoded-words. If it is -mime-charset, it decodes non-ASCII bit patterns as the mime-charset. -Otherwise it decodes non-ASCII bit patterns as the -default-mime-charset. -If SEPARATOR is not nil, it is used as header separator." - (interactive "*") - (save-excursion - (save-restriction - (std11-narrow-to-header separator) - (let ((default-charset - (if code-conversion - (if (mime-charset-to-coding-system code-conversion) - code-conversion - default-mime-charset)))) - (if default-charset - (let (beg p end field-name len) - (goto-char (point-min)) - (while (re-search-forward std11-field-head-regexp nil t) - (setq beg (match-beginning 0) - p (match-end 0) - field-name (buffer-substring beg (1- p)) - len (string-width field-name) - field-name (intern (downcase field-name)) - end (std11-field-end)) - (cond ((memq field-name eword-decode-ignored-field-list) - ;; Don't decode - ) - ((memq field-name eword-decode-structured-field-list) - ;; Decode as structured field - (let ((body (buffer-substring p end)) - (default-mime-charset default-charset)) - (delete-region p end) - (insert (eword-decode-and-fold-structured-field - body (1+ len))) - )) - (t - ;; Decode as unstructured field - (save-restriction - (narrow-to-region beg (1+ end)) - (decode-mime-charset-region p end default-charset) - (goto-char p) - (if (re-search-forward eword-encoded-word-regexp - nil t) - (eword-decode-region beg (point-max) 'unfold)) - ))))) - (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) - )))))) - - -;;; @ lexical analyze -;;; - -(defvar eword-lexical-analyze-cache nil) -(defvar eword-lexical-analyze-cache-max 299 - "*Max position of eword-lexical-analyze-cache. -It is max size of eword-lexical-analyze-cache - 1.") - -(defcustom eword-lexical-analyzers - '(eword-analyze-quoted-string - eword-analyze-domain-literal - eword-analyze-comment - eword-analyze-spaces - eword-analyze-special - eword-analyze-encoded-word - eword-analyze-atom) - "*List of functions to return result of lexical analyze. -Each function must have two arguments: STRING and MUST-UNFOLD. -STRING is the target string to be analyzed. -If MUST-UNFOLD is not nil, each function must unfold and eliminate -bare-CR and bare-LF from the result even if they are included in -content of the encoded-word. -Each function must return nil if it can not analyze STRING as its -format. - -Previous function is preferred to next function. If a function -returns nil, next function is used. Otherwise the return value will -be the result." - :group 'eword-decode - :type '(repeat function)) - -(defun eword-analyze-quoted-string (string &optional must-unfold) - (let ((p (std11-check-enclosure string ?\" ?\"))) - (if p - (cons (cons 'quoted-string - (decode-mime-charset-string - (std11-strip-quoted-pair (substring string 1 (1- p))) - default-mime-charset)) - (substring string p)) - ))) - -(defun eword-analyze-domain-literal (string &optional must-unfold) - (std11-analyze-domain-literal string)) - -(defun eword-analyze-comment (string &optional must-unfold) - (let ((p (std11-check-enclosure string ?\( ?\) t))) - (if p - (cons (cons 'comment - (eword-decode-string - (decode-mime-charset-string - (std11-strip-quoted-pair (substring string 1 (1- p))) - default-mime-charset) - must-unfold)) - (substring string p)) - ))) - -(defun eword-analyze-spaces (string &optional must-unfold) - (std11-analyze-spaces string)) - -(defun eword-analyze-special (string &optional must-unfold) - (std11-analyze-special string)) - -(defun eword-analyze-encoded-word (string &optional must-unfold) - (if (eq (string-match eword-encoded-word-regexp string) 0) - (let ((end (match-end 0)) - (dest (eword-decode-encoded-word (match-string 0 string) - must-unfold)) - ) - (setq string (substring string end)) - (while (eq (string-match `,(concat "[ \t\n]*\\(" - eword-encoded-word-regexp - "\\)") - string) - 0) - (setq end (match-end 0)) - (setq dest - (concat dest - (eword-decode-encoded-word (match-string 1 string) - must-unfold)) - string (substring string end)) - ) - (cons (cons 'atom dest) string) - ))) - -(defun eword-analyze-atom (string &optional must-unfold) - (if (string-match std11-atom-regexp string) - (let ((end (match-end 0))) - (cons (cons 'atom (decode-mime-charset-string - (substring string 0 end) - default-mime-charset)) - (substring string end) - )))) - -(defun eword-lexical-analyze-internal (string must-unfold) - (let (dest ret) - (while (not (string-equal string "")) - (setq ret - (let ((rest eword-lexical-analyzers) - func r) - (while (and (setq func (car rest)) - (null (setq r (funcall func string must-unfold))) - ) - (setq rest (cdr rest))) - (or r '((error) . "")) - )) - (setq dest (cons (car ret) dest)) - (setq string (cdr ret)) - ) - (nreverse dest) - )) - -(defun eword-lexical-analyze (string &optional must-unfold) - "Return lexical analyzed list corresponding STRING. -It is like std11-lexical-analyze, but it decodes non us-ascii -characters encoded as encoded-words or invalid \"raw\" format. -\"Raw\" non us-ascii characters are regarded as variable -`default-mime-charset'." - (let ((key (copy-sequence string)) - ret) - (set-text-properties 0 (length key) nil key) - (if (setq ret (assoc key eword-lexical-analyze-cache)) - (cdr ret) - (setq ret (eword-lexical-analyze-internal key must-unfold)) - (setq eword-lexical-analyze-cache - (cons (cons key ret) - (last eword-lexical-analyze-cache - eword-lexical-analyze-cache-max))) - ret))) - -(defun eword-decode-token (token) - (let ((type (car token)) - (value (cdr token))) - (cond ((eq type 'quoted-string) - (std11-wrap-as-quoted-string value)) - ((eq type 'comment) - (concat "(" (std11-wrap-as-quoted-pairs value '(?( ?))) ")")) - (t value)))) - -(defun eword-decode-and-fold-structured-field - (string start-column &optional max-column must-unfold) - "Decode and fold (fill) STRING as structured field body. -It decodes non us-ascii characters in FULL-NAME encoded as -encoded-words or invalid \"raw\" string. \"Raw\" non us-ascii -characters are regarded as variable `default-mime-charset'. - -If an encoded-word is broken or your emacs implementation can not -decode the charset included in it, it is not decoded. - -If MAX-COLUMN is omitted, `fill-column' is used. - -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)." - (or max-column - (setq max-column fill-column)) - (let ((c start-column) - (tokens (eword-lexical-analyze string must-unfold)) - (result "") - token) - (while (and (setq token (car tokens)) - (setq tokens (cdr tokens))) - (let* ((type (car token))) - (if (eq type 'spaces) - (let* ((next-token (car tokens)) - (next-str (eword-decode-token next-token)) - (next-len (string-width next-str)) - (next-c (+ c next-len 1))) - (if (< next-c max-column) - (setq result (concat result " " next-str) - c next-c) - (setq result (concat result "\n " next-str) - c (1+ next-len))) - (setq tokens (cdr tokens)) - ) - (let* ((str (eword-decode-token token))) - (setq result (concat result str) - c (+ c (string-width str))) - )))) - (if token - (concat result (eword-decode-token token)) - result))) - -(defun eword-decode-and-unfold-structured-field (string) - "Decode and unfold STRING as structured field body. -It decodes non us-ascii characters in FULL-NAME encoded as -encoded-words or invalid \"raw\" string. \"Raw\" non us-ascii -characters are regarded as variable `default-mime-charset'. - -If an encoded-word is broken or your emacs implementation can not -decode the charset included in it, it is not decoded." - (let ((tokens (eword-lexical-analyze string 'must-unfold)) - (result "")) - (while tokens - (let* ((token (car tokens)) - (type (car token))) - (setq tokens (cdr tokens)) - (setq result - (if (eq type 'spaces) - (concat result " ") - (concat result (eword-decode-token token)) - )))) - result)) - -(defun eword-decode-structured-field-body (string &optional must-unfold - start-column max-column) - "Decode non us-ascii characters in STRING as structured field body. -STRING is unfolded before decoding. - -It decodes non us-ascii characters in FULL-NAME encoded as -encoded-words or invalid \"raw\" string. \"Raw\" non us-ascii -characters are regarded as variable `default-mime-charset'. - -If an encoded-word is broken or your emacs implementation can not -decode the charset included in it, it is not decoded. - -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)." - (if start-column - ;; fold with max-column - (eword-decode-and-fold-structured-field - string start-column max-column must-unfold) - ;; Don't fold - (mapconcat (function eword-decode-token) - (eword-lexical-analyze string must-unfold) - "") - )) - -(defun eword-decode-unstructured-field-body (string &optional must-unfold) - "Decode non us-ascii characters in STRING as unstructured field body. -STRING is unfolded before decoding. - -It decodes non us-ascii characters in FULL-NAME encoded as -encoded-words or invalid \"raw\" string. \"Raw\" non us-ascii -characters are regarded as variable `default-mime-charset'. - -If an encoded-word is broken or your emacs implementation can not -decode the charset included in it, it is not decoded. - -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)." - (eword-decode-string - (decode-mime-charset-string string default-mime-charset) - must-unfold)) - -(defun eword-extract-address-components (string) - "Extract full name and canonical address from STRING. -Returns a list of the form (FULL-NAME CANONICAL-ADDRESS). -If no name can be extracted, FULL-NAME will be nil. -It decodes non us-ascii characters in FULL-NAME encoded as -encoded-words or invalid \"raw\" string. \"Raw\" non us-ascii -characters are regarded as variable `default-mime-charset'." - (let* ((structure (car (std11-parse-address - (eword-lexical-analyze - (std11-unfold-string string) 'must-unfold)))) - (phrase (std11-full-name-string structure)) - (address (std11-address-string structure)) - ) - (list phrase address) - )) - - -;;; @ end -;;; - -(provide 'eword-decode) - -;;; eword-decode.el ends here diff --git a/eword-encode.el b/eword-encode.el deleted file mode 100644 index 6dbbea3..0000000 --- a/eword-encode.el +++ /dev/null @@ -1,644 +0,0 @@ -;;; eword-encode.el --- RFC 2047 based encoded-word encoder for GNU Emacs - -;; Copyright (C) 1995,1996,1997,1998 Free Software Foundation, Inc. - -;; Author: MORIOKA Tomohiko -;; Keywords: encoded-word, MIME, multilingual, header, mail, news - -;; This file is part of SEMI (Spadework for Emacs MIME Interfaces). - -;; This program is free software; you can redistribute it and/or -;; modify it under the terms of the GNU General Public License as -;; published by the Free Software Foundation; either version 2, or (at -;; your option) any later version. - -;; This program is distributed in the hope that it will be useful, but -;; WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Code: - -(require 'emu) -(require 'mel) -(require 'std11) -(require 'mime-def) -(require 'eword-decode) - - -;;; @ version -;;; - -(defconst eword-encode-RCS-ID - "$Id: eword-encode.el,v 1.1 1998-03-12 19:10:12 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) - ("Message-ID" . nil) - (t . mime) - ) - "*Alist to specify field encoding method. -Its key is field-name, value is encoding method. - -If method is `mime', this field will be encoded into MIME format. - -If method is a MIME-charset, this field will be encoded as the charset -when it must be convert into network-code. - -If method is `default-mime-charset', this field will be encoded as -variable `default-mime-charset' when it must be convert into -network-code. - -If method is nil, this field will not be encoded.") - -(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 eword-encode-text (charset encoding string &optional mode) - "Encode STRING as an encoded-word, and return the result. -CHARSET is a symbol to indicate MIME charset of the encoded-word. -ENCODING allows \"B\" or \"Q\". -MODE is allows `text', `comment', `phrase' or nil. Default value is -`phrase'." - (let ((text - (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 "?=") - ))) - - -;;; @ charset word -;;; - -(defsubst eword-encode-char-type (character) - (if (or (eq character ? )(eq character ?\t)) - nil - (char-charset character) - )) - -(defun eword-encode-divide-into-charset-words (string) - (let ((len (length string)) - dest) - (while (> len 0) - (let* ((chr (sref string 0)) - (charset (eword-encode-char-type chr)) - (i (char-bytes chr)) - ) - (while (and (< i len) - (setq chr (sref string i)) - (eq charset (eword-encode-char-type chr)) - ) - (setq i (+ i (char-bytes chr))) - ) - (setq dest (cons (cons charset (substring string 0 i)) dest) - string (substring string i) - len (- len i) - ))) - (nreverse dest) - )) - - -;;; @ word -;;; - -(defun eword-encode-charset-words-to-words (charset-words) - (let (dest) - (while charset-words - (let* ((charset-word (car charset-words)) - (charset (car charset-word)) - ) - (if charset - (let ((charsets (list charset)) - (str (cdr charset-word)) - ) - (catch 'tag - (while (setq charset-words (cdr charset-words)) - (setq charset-word (car charset-words) - charset (car charset-word)) - (if (null charset) - (throw 'tag nil) - ) - (or (memq charset charsets) - (setq charsets (cons charset charsets)) - ) - (setq str (concat str (cdr charset-word))) - )) - (setq dest (cons (cons charsets str) dest)) - ) - (setq dest (cons charset-word dest) - charset-words (cdr charset-words) - )))) - (nreverse dest) - )) - - -;;; @ rule -;;; - -(defmacro 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 - (eword-encode-charset-words-to-words - (eword-encode-divide-into-charset-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)) - (or (<= (setq len (+ (length string) column)) 76) - (<= column 1)) - ) - (setq rwl (cdr rwl)) - ) - (t - (setq string "\n ") - (setq len 1) - )) - (cond ((and (setq len (car ret)) - (<= (+ column len) 76) - ) - (setq string - (eword-encode-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 - (eword-encode-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 ? ) - (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 ? ) - ) - ((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 - (eword-encode-charset-words-to-words - (eword-encode-divide-into-charset-words - (cdr token))) - 'comment) - '((")" nil nil)) - )) - ) - (t - (setq dest - (append dest - (tm-eword::words-to-ruled-words - (eword-encode-charset-words-to-words - (eword-encode-divide-into-charset-words - (cdr token)) - ) 'phrase))) - )) - (setq phrase (cdr phrase)) - ) - (tm-eword::space-process dest) - )) - -(defun eword-addr-seq-to-rwl (seq) - (let (dest pname) - (while seq - (let* ((token (car seq)) - (name (car token)) - ) - (cond ((eq name 'spaces) - (setq dest (nconc dest (list (list (cdr token) nil nil)))) - ) - ((eq name 'comment) - (setq dest - (nconc - dest - (list (list "(" nil nil)) - (tm-eword::split-string (cdr token) 'comment) - (list (list ")" nil nil)) - )) - ) - ((eq name 'quoted-string) - (setq dest - (nconc - dest - (list - (list (concat "\"" (cdr token) "\"") nil nil) - ))) - ) - (t - (setq dest - (if (or (eq pname 'spaces) - (eq pname 'comment)) - (nconc dest (list (list (cdr token) nil nil))) - (nconc (butlast dest) - (list - (list (concat (car (car (last dest))) - (cdr token)) - nil nil))))) - )) - (setq seq (cdr seq) - pname name)) - ) - dest)) - -(defun 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 - (eword-addr-seq-to-rwl - (append '((specials . "<")) - route - '((specials . ">")))) - )))) - -(defun eword-addr-spec-to-rwl (addr-spec) - (if (eq (car addr-spec) 'addr-spec) - (eword-addr-seq-to-rwl (cdr addr-spec)) - )) - -(defun tm-eword::mailbox-to-rwl (mbox) - (let ((addr (nth 1 mbox)) - (comment (nth 2 mbox)) - dest) - (setq dest (or (eword-phrase-route-addr-to-rwl addr) - (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 (string) - "Encode header field STRING, and return the result. -A lexical token includes non-ASCII character is encoded as MIME -encoded-word. ASCII token is not encoded." - (setq string (std11-unfold-string string)) - (let ((ret (string-match std11-field-head-regexp string))) - (or (if ret - (let ((field-name (substring string 0 (1- (match-end 0)))) - (field-body (eliminate-top-spaces - (substring string (match-end 0)))) - ) - (if (setq ret - (cond ((string-equal field-body "") "") - ((memq (intern (downcase field-name)) - '(reply-to - from sender - resent-reply-to resent-from - resent-sender to resent-to - cc resent-cc - bcc resent-bcc dcc - mime-version) - ) - (car (tm-eword::encode-address-list - (+ (length field-name) 2) field-body)) - ) - (t - (car (tm-eword::encode-string - (1+ (length field-name)) - field-body 'text)) - )) - ) - (concat field-name ": " ret) - ))) - (car (tm-eword::encode-string 0 string)) - ))) - -(defun eword-in-subject-p () - (let ((str (std11-field-body "Subject"))) - (if (and str (string-match eword-encoded-word-regexp str)) - str))) - -(defsubst eword-find-field-encoding-method (field-name) - (setq field-name (downcase field-name)) - (let ((alist eword-field-encoding-method-alist)) - (catch 'found - (while alist - (let* ((pair (car alist)) - (str (car pair))) - (if (and (stringp str) - (string= field-name (downcase str))) - (throw 'found (cdr pair)) - )) - (setq alist (cdr alist))) - (cdr (assq t eword-field-encoding-method-alist)) - ))) - -(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 ((method (eword-find-field-encoding-method - (downcase field-name)))) - (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) - ))) - )) - )) - ))) - -(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 diff --git a/ftp.in b/ftp.in deleted file mode 100644 index 6f2c482..0000000 --- a/ftp.in +++ /dev/null @@ -1,24 +0,0 @@ ---<>-{ - - It is available from - - ftp://ftp.jaist.ac.jp/pub/GNU/elisp/semi/ (Japan) - -or its mirrors - - ftp://ftp.nis.co.jp/pub/gnu/emacs-lisp/tm/alpha/ (Japan) - ftp://ftp.nisiq.net/pub/gnu/emacs-lisp/tm/alpha/ (US) - ftp://ftp.miranova.com/pub/mime/jaist.ac.jp/alpha/ (US) - ftp://ftp.unicamp.br/pub/mail/mime/tm/alpha/ (Brazil) - ---[[message/external-body; - access-type=anon-ftp; - site="ftp.jaist.ac.jp"; - directory="/pub/GNU/elisp/semi"; - name="semi-VERSION.tar.gz"; - mode=image]] -Content-Type: application/octet-stream; - name="semi-VERSION.tar.gz"; - type=tar; - conversions=gzip ---}-<> diff --git a/mail-mime-setup.el b/mail-mime-setup.el deleted file mode 100644 index d11ef6d..0000000 --- a/mail-mime-setup.el +++ /dev/null @@ -1,56 +0,0 @@ -;;; mail-mime-setup.el --- setup file for mail-mode. - -;; Copyright (C) 1994,1995,1996,1997,1998 Free Software Foundation, Inc. - -;; Author: MORIOKA Tomohiko -;; Keywords: mail-mode, MIME, multimedia, multilingual, encoded-word - -;; This file is part of SEMI (Setting for Emacs MIME Interfaces). - -;; This program is free software; you can redistribute it and/or -;; modify it under the terms of the GNU General Public License as -;; published by the Free Software Foundation; either version 2, or (at -;; your option) any later version. - -;; This program is distributed in the hope that it will be useful, but -;; WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Code: - -(require 'semi-setup) - - -(autoload 'turn-on-mime-edit "mime-edit" - "Unconditionally turn on MIME-Edit minor mode." t) - -(autoload 'eword-decode-header "eword-decode" - "Decode MIME encoded-words in header fields." t) - - -;;; @ for mail-mode, RMAIL and VM -;;; - -(add-hook 'mail-setup-hook 'eword-decode-header) -(add-hook 'mail-setup-hook 'turn-on-mime-edit 'append) -(add-hook 'mail-send-hook 'mime-edit-maybe-translate) -(set-alist 'mime-edit-split-message-sender-alist - 'mail-mode (function - (lambda () - (interactive) - (funcall send-mail-function) - ))) - - -;;; @ end -;;; - -(provide 'mail-mime-setup) - -;;; mail-mime-setup.el ends here diff --git a/mailcap.el b/mailcap.el deleted file mode 100644 index f3b82ce..0000000 --- a/mailcap.el +++ /dev/null @@ -1,190 +0,0 @@ -;;; mailcap.el --- mailcap parser - -;; Copyright (C) 1997,1998 Free Software Foundation, Inc. - -;; Author: MORIOKA Tomohiko -;; Created: 1997/6/27 -;; Keywords: mailcap, setting, configuration, MIME, multimedia - -;; This file is part of SEMI (Spadework for Emacs MIME Interfaces). - -;; This program is free software; you can redistribute it and/or -;; modify it under the terms of the GNU General Public License as -;; published by the Free Software Foundation; either version 2, or (at -;; your option) any later version. - -;; This program is distributed in the hope that it will be useful, but -;; WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Code: - -;;; @ comment -;;; - -(defsubst mailcap-skip-comment () - (let ((chr (char-after (point)))) - (when (and chr - (or (= chr ?\n) - (= chr ?#))) - (forward-line) - t))) - - -;;; @ token -;;; - -(defsubst mailcap-look-at-token () - (if (looking-at mime-token-regexp) - (let ((beg (match-beginning 0)) - (end (match-end 0))) - (goto-char end) - (buffer-substring beg end) - ))) - - -;;; @ typefield -;;; - -(defsubst mailcap-look-at-type-field () - (let ((type (mailcap-look-at-token))) - (if (and type - (eq (char-after (point)) ?/) - ) - (progn - (forward-char) - (let ((subtype (mailcap-look-at-token))) - (if subtype - (cons (cons 'type (intern type)) - (unless (string= subtype "*") - (list (cons 'subtype (intern subtype))) - )))))))) - - -;;; @ field separator -;;; - -(defsubst mailcap-skip-field-separator () - (let ((ret (looking-at "\\([ \t]\\|\\\\\n\\)*;\\([ \t]\\|\\\\\n\\)*"))) - (when ret - (goto-char (match-end 0)) - t))) - - -;;; @ mtext -;;; - -(defsubst mailcap-look-at-schar () - (let ((chr (char-after (point)))) - (if (and (>= chr ? ) - (/= chr ?\;) - (/= chr ?\\) - ) - (prog1 - chr - (forward-char))))) - -(defsubst mailcap-look-at-qchar () - (let ((chr (char-after (point)))) - (when (eq chr ?\\) - (forward-char 2) - (char-before (point)) - ))) - -(defsubst mailcap-look-at-mtext () - (let ((beg (point))) - (while (or (mailcap-look-at-schar) - (mailcap-look-at-schar))) - (buffer-substring beg (point)) - )) - - -;;; @ field -;;; - -(defsubst mailcap-look-at-field () - (let ((token (mailcap-look-at-token))) - (if token - (if (eq (char-after (point)) ?=) - (let ((value (progn - (forward-char) - (mailcap-look-at-mtext)))) - (if value - (cons token value) - )) - (list token) - )))) - - -;;; @ mailcap entry -;;; - -(defun mailcap-look-at-entry () - (let ((type (mailcap-look-at-type-field))) - (if (and type (mailcap-skip-field-separator)) - (let ((view (mailcap-look-at-mtext)) - fields field) - (when view - (while (and (mailcap-skip-field-separator) - (setq field (mailcap-look-at-field)) - ) - (setq fields (cons field fields)) - ) - (nconc type - (list (cons 'view view)) - fields)))))) - - -;;; @ main -;;; - -(defun mailcap-parse-buffer (&optional buffer order) - "Parse BUFFER as a mailcap, and return the result. -If optional argument ORDER is a function, result is sorted by it. -If optional argument ORDER is not specified, result is sorted original -order. Otherwise result is not sorted." - (save-excursion - (if buffer - (set-buffer buffer)) - (goto-char (point-min)) - (let (entries entry) - (while (progn - (while (mailcap-skip-comment)) - (setq entry (mailcap-look-at-entry)) - ) - (setq entries (cons entry entries)) - (forward-line) - ) - (cond ((functionp order) (sort entries order)) - ((null order) (nreverse entries)) - (t entries) - )))) - -(defvar mailcap-file "~/.mailcap" - "*File name of user's mailcap file.") - -(defun mailcap-parse-file (&optional filename order) - "Parse FILENAME as a mailcap, and return the result. -If optional argument ORDER is a function, result is sorted by it. -If optional argument ORDER is not specified, result is sorted original -order. Otherwise result is not sorted." - (or filename - (setq filename mailcap-file)) - (with-temp-buffer - (insert-file-contents filename) - (mailcap-parse-buffer (current-buffer) order) - )) - - -;;; @ end -;;; - -(provide 'mailcap) - -;;; mailcap.el ends here diff --git a/mime-bbdb.el b/mime-bbdb.el deleted file mode 100644 index 6ee0feb..0000000 --- a/mime-bbdb.el +++ /dev/null @@ -1,301 +0,0 @@ -;;; mime-bbdb.el --- SEMI shared module for BBDB - -;; Copyright (C) 1995,1996,1997 Shuhei KOBAYASHI -;; Copyright (C) 1997,1998 MORIOKA Tomohiko - -;; Author: Shuhei KOBAYASHI -;; Maintainer: Shuhei KOBAYASHI -;; Keywords: BBDB, MIME, multimedia, multilingual, mail, news - -;; This file is part of SEMI (Suite of Emacs MIME Interfaces). - -;; This program is free software; you can redistribute it and/or -;; modify it under the terms of the GNU General Public License as -;; published by the Free Software Foundation; either version 2, or (at -;; your option) any later version. - -;; This program is distributed in the hope that it will be useful, but -;; WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Code: - -(require 'path-util) -(require 'std11) -(require 'mime-view) - -(if (module-installed-p 'bbdb-com) - (require 'bbdb-com) - (eval-when-compile - ;; imported from bbdb-1.51 - (defmacro bbdb-pop-up-elided-display () - '(if (boundp 'bbdb-pop-up-elided-display) - bbdb-pop-up-elided-display - bbdb-elided-display)) - (defmacro bbdb-user-mail-names () - "Returns a regexp matching the address of the logged-in user" - '(or bbdb-user-mail-names - (setq bbdb-user-mail-names - (concat "\\b" (regexp-quote (user-login-name)) "\\b")))) - )) - - -;;; @ User Variables -;;; - -(defvar mime-bbdb/use-mail-extr t - "*If non-nil, `mail-extract-address-components' is used. -Otherwise `mime-bbdb/extract-address-components' overrides it.") - -(defvar mime-bbdb/auto-create-p nil - "*If t, create new BBDB records automatically. -If function, then it is called with no arguments to decide whether an -entry should be automatically creaded. - -mime-bbdb uses this variable instead of `bbdb/mail-auto-create-p' or -`bbdb/news-auto-create-p' unless other tm-MUA overrides it.") - -(defvar mime-bbdb/delete-empty-window nil - "*If non-nil, delete empty BBDB window. -All bbdb-MUAs but bbdb-gnus display BBDB window even if it is empty. -If you prefer behavior of bbdb-gnus, set this variable to t. - -For framepop users: If empty, `framepop-banish' is used instead.") - -;;; @ mail-extr -;;; - -(defun mime-bbdb/extract-address-components (str) - (let* ((ret (std11-extract-address-components str)) - (phrase (car ret)) - (address (car (cdr ret))) - (methods mime-bbdb/canonicalize-full-name-methods)) - (while (and phrase methods) - (setq phrase (funcall (car methods) phrase) - methods (cdr methods))) - (if (string= address "") (setq address nil)) - (if (string= phrase "") (setq phrase nil)) - (list phrase address) - )) - -(or mime-bbdb/use-mail-extr - (progn - (require 'mail-extr) ; for `what-domain' - (or (fboundp 'tm:mail-extract-address-components) - (fset 'tm:mail-extract-address-components - (symbol-function 'mail-extract-address-components))) - (fset 'mail-extract-address-components - (symbol-function 'mime-bbdb/extract-address-components)) - )) - - -;;; @ bbdb-extract-field-value -;;; - -(or (fboundp 'tm:bbdb-extract-field-value) - (progn - ;; (require 'bbdb-hooks) ; not provided. - ;; (or (fboundp 'bbdb-extract-field-value) ; defined as autoload - (or (fboundp 'bbdb-header-start) - (load "bbdb-hooks")) - (fset 'tm:bbdb-extract-field-value - (symbol-function 'bbdb-extract-field-value)) - (defun bbdb-extract-field-value (field) - (let ((value (tm:bbdb-extract-field-value field))) - (and value - (eword-decode-string value)))) - )) - - -;;; @ full-name canonicalization methods -;;; - -(defun mime-bbdb/canonicalize-spaces (str) - (let (dest) - (while (string-match "\\s +" str) - (setq dest (cons (substring str 0 (match-beginning 0)) dest)) - (setq str (substring str (match-end 0))) - ) - (or (string= str "") - (setq dest (cons str dest))) - (setq dest (nreverse dest)) - (mapconcat 'identity dest " ") - )) - -(defun mime-bbdb/canonicalize-dots (str) - (let (dest) - (while (string-match "\\." str) - (setq dest (cons (substring str 0 (match-end 0)) dest)) - (setq str (substring str (match-end 0))) - ) - (or (string= str "") - (setq dest (cons str dest))) - (setq dest (nreverse dest)) - (mapconcat 'identity dest " ") - )) - -(defvar mime-bbdb/canonicalize-full-name-methods - '(eword-decode-string - mime-bbdb/canonicalize-dots - mime-bbdb/canonicalize-spaces)) - - -;;; @ BBDB functions for mime-view-mode -;;; - -(defun mime-bbdb/update-record (&optional offer-to-create) - "Return the record corresponding to the current MIME previewing message. -Creating or modifying it as necessary. A record will be created if -mime-bbdb/auto-create-p is non-nil, or if OFFER-TO-CREATE is non-nil and -the user confirms the creation." - (save-excursion - (if (and mime-view-buffer - (get-buffer mime-view-buffer)) - (set-buffer mime-view-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 diff --git a/mime-def.el b/mime-def.el deleted file mode 100644 index 08f71d8..0000000 --- a/mime-def.el +++ /dev/null @@ -1,326 +0,0 @@ -;;; mime-def.el --- definition module for SEMI - -;; Copyright (C) 1995,1996,1997,1998 Free Software Foundation, Inc. - -;; Author: MORIOKA Tomohiko -;; Keywords: definition, MIME, multimedia, mail, news - -;; This file is part of SEMI (Spadework for Emacs MIME Interfaces). - -;; This program is free software; you can redistribute it and/or -;; modify it under the terms of the GNU General Public License as -;; published by the Free Software Foundation; either version 2, or (at -;; your option) any later version. - -;; This program is distributed in the hope that it will be useful, but -;; WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Code: - -(require 'emu) -(require 'custom) - -(defgroup mime nil - "Emacs MIME Interfaces" - :group 'news - :group 'mail) - -(custom-handle-keyword 'default-mime-charset :group 'mime - 'custom-variable) - -(unless (fboundp 'butlast) - (defun butlast (x &optional n) - "Returns a copy of LIST with the last N elements removed." - (if (and n (<= n 0)) x - (nbutlast (copy-sequence x) n))) - - (defun nbutlast (x &optional n) - "Modifies LIST to remove the last N elements." - (let ((m (length x))) - (or n (setq n 1)) - (and (< n m) - (progn - (if (> n 0) (setcdr (nthcdr (- (1- m) n) x) nil)) - x)))) - ) - -(defconst semi-version '("Nonoichi-K,Dr(Bdaimae" 1 0 2) - "Version name and numbers of SEMI-kernel package.") - -(autoload 'mule-caesar-region "mule-caesar" - "Caesar rotation of current region." t) - - -;;; @ 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) - )) - - -;;; @ constants -;;; - -(defconst mime-echo-buffer-name "*MIME-echo*" - "Name of buffer to display MIME-playing information.") - -(defconst mime-temp-buffer-name " *MIME-temp*") - - -;;; @ definitions about MIME -;;; - -(defconst mime-tspecials "][()<>@,\;:\\\"/?=") -(defconst mime-token-regexp (concat "[^" mime-tspecials "\000-\040]+")) -(defconst mime-charset-regexp mime-token-regexp) - -(defconst mime-media-type/subtype-regexp - (concat mime-token-regexp "/" mime-token-regexp)) - - -;;; @ button -;;; - -(defcustom mime-button-face 'bold - "Face used for content-button or URL-button of MIME-Preview buffer." - :group 'mime - :type 'face) - -(defcustom mime-button-mouse-face 'highlight - "Face used for MIME-preview buffer mouse highlighting." - :group 'mime - :type 'face) - -(defsubst mime-add-button (from to function &optional data) - "Create a button between FROM and TO with callback FUNCTION and DATA." - (let ((overlay (make-overlay from to))) - (and mime-button-face - (overlay-put overlay 'face mime-button-face)) - (and mime-button-mouse-face - (overlay-put overlay 'mouse-face mime-button-mouse-face)) - (add-text-properties from to (list 'mime-button-callback function)) - (and data - (add-text-properties from to (list 'mime-button-data data))) - ;;(add-text-properties from to (list 'keymap widget-keymap)) - )) - -(defsubst mime-insert-button (string function &optional data) - "Insert STRING as button with callback FUNCTION and DATA." - (save-restriction - (narrow-to-region (point)(point)) - (insert (concat "[" string "]")) - ;; (widget-push-button-value-create - ;; (widget-convert 'push-button - ;; :notify (lambda (&rest ignore) - ;; (mime-view-play-current-entity) - ;; ) - ;; string)) - (insert "\n") - (mime-add-button (point-min)(point-max) function data) - )) - -(defvar mime-button-mother-dispatcher nil) - -(defun mime-button-dispatcher (event) - "Select the button under point." - (interactive "e") - (let (buf point func data) - (save-window-excursion - (mouse-set-point event) - (setq buf (current-buffer) - point (point) - func (get-text-property (point) 'mime-button-callback) - data (get-text-property (point) 'mime-button-data) - ) - ) - (save-excursion - (set-buffer buf) - (goto-char point) - (if func - (apply func data) - (if (fboundp mime-button-mother-dispatcher) - (funcall mime-button-mother-dispatcher event) - ) - )))) - - -;;; @ 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." - `(cadr (assq ,method (symbol-value 'pgp-function-alist))) - ) - -(mapcar (function - (lambda (method) - (autoload (cadr method)(nth 2 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) - ))) - - -;;; @ 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 diff --git a/mime-edit.el b/mime-edit.el deleted file mode 100644 index c95f8eb..0000000 --- a/mime-edit.el +++ /dev/null @@ -1,2728 +0,0 @@ -;;; mime-edit.el --- Simple MIME Composer for GNU Emacs - -;; Copyright (C) 1993,1994,1995,1996,1997,1998 Free Software Foundation, Inc. - -;; Author: UMEDA Masanobu -;; MORIOKA Tomohiko -;; Maintainer: MORIOKA Tomohiko -;; Created: 1994/08/21 renamed from mime.el -;; Renamed: 1997/2/21 from tm-edit.el -;; Keywords: MIME, multimedia, multilingual, mail, news - -;; This file is part of SEMI (Sophisticated Emacs MIME Interfaces). - -;; This program is free software; you can redistribute it and/or -;; modify it under the terms of the GNU General Public License as -;; published by the Free Software Foundation; either version 2, or (at -;; your option) any later version. - -;; This program is distributed in the hope that it will be useful, but -;; WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: - -;; This is an Emacs minor mode for editing Internet multimedia -;; messages formatted in MIME (RFC 2045, 2046, 2047, 2048 and 2049). -;; All messages in this mode are composed in the tagged MIME format, -;; that are described in the following examples. The messages -;; composed in the tagged MIME format are automatically translated -;; into a MIME compliant message when exiting the mode. - -;; Mule (multilingual feature of Emacs 20 and multilingual extension -;; for XEmacs 20) has a capability of handling multilingual text in -;; limited ISO-2022 manner that is based on early experiences in -;; Japanese Internet community and resulted in RFC 1468 (ISO-2022-JP -;; charset for MIME). In order to enable multilingual capability in -;; single text message in MIME, charset of multilingual text written -;; in Mule is declared as either `ISO-2022-JP-2' [RFC 1554]. Mule is -;; required for reading the such messages. - -;; This MIME composer can work with Mail mode, mh-e letter Mode, and -;; News mode. First of all, you need the following autoload -;; definition to load mime-edit-mode automatically: -;; -;; (autoload 'turn-on-mime-edit "mime-edit" -;; "Minor mode for editing MIME message." t) -;; -;; In case of Mail mode (includes VM mode), you need the following -;; hook definition: -;; -;; (add-hook 'mail-mode-hook 'turn-on-mime-edit) -;; (add-hook 'mail-send-hook 'mime-edit-maybe-translate) -;; -;; In case of MH-E, you need the following hook definition: -;; -;; (add-hook 'mh-letter-mode-hook -;; (function -;; (lambda () -;; (turn-on-mime-edit) -;; (make-local-variable 'mail-header-separator) -;; (setq mail-header-separator "--------") -;; )))) -;; (add-hook 'mh-before-send-letter-hook 'mime-edit-maybe-translate) -;; -;; In case of News mode, you need the following hook definition: -;; -;; (add-hook 'news-reply-mode-hook 'turn-on-mime-edit) -;; (add-hook 'news-inews-hook 'mime-edit-maybe-translate) -;; -;; In case of Emacs 19, it is possible to emphasize the message tags -;; using font-lock mode as follows: -;; -;; (add-hook 'mime-edit-mode-hook -;; (function -;; (lambda () -;; (font-lock-mode 1) -;; (setq font-lock-keywords (list mime-edit-tag-regexp)) -;; )))) - -;; The message tag looks like: -;; -;; --[[TYPE/SUBTYPE;PARAMETERS][ENCODING]] -;; -;; The tagged MIME message examples: -;; -;; This is a conventional plain text. It should be translated into -;; text/plain. -;; -;;--[[text/plain]] -;; This is also a plain text. But, it is explicitly specified as is. -;;--[[text/plain; charset=ISO-8859-1]] -;; This is also a plain text. But charset is specified as iso-8859-1. -;; -;; ¡Hola! Buenos días. ¿Cómo está usted? -;;--[[text/enriched]] -;;
This is a richtext.
-;; -;;--[[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-version-string - `,(concat "SEMI " - (mapconcat #'number-to-string (cdr semi-version) ".") - " - \"" (car semi-version) "\"")) - - -;;; @ variables -;;; - -(defgroup mime-edit nil - "MIME edit mode" - :group 'mime) - -(defcustom mime-ignore-preceding-spaces nil - "*Ignore preceding white spaces if non-nil." - :group 'mime-edit - :type 'boolean) - -(defcustom mime-ignore-trailing-spaces nil - "*Ignore trailing white spaces if non-nil." - :group 'mime-edit - :type 'boolean) - -(defcustom mime-ignore-same-text-tag t - "*Ignore preceding text content-type tag that is same with new one. -If non-nil, the text tag is not inserted unless something different." - :group 'mime-edit - :type 'boolean) - -(defcustom mime-auto-hide-body t - "*Hide non-textual body encoded in base64 after insertion if non-nil." - :group 'mime-edit - :type 'boolean) - -(defcustom mime-edit-voice-recorder - (function mime-edit-voice-recorder-for-sun) - "*Function to record a voice message and encode it." - :group 'mime-edit - :type 'function) - -(defcustom mime-edit-mode-hook nil - "*Hook called when enter MIME mode." - :group 'mime-edit - :type 'hook) - -(defcustom mime-edit-translate-hook nil - "*Hook called before translating into a MIME compliant message. -To insert a signature file automatically, call the function -`mime-edit-insert-signature' from this hook." - :group 'mime-edit - :type 'hook) - -(defcustom mime-edit-exit-hook nil - "*Hook called when exit MIME mode." - :group 'mime-edit - :type 'hook) - -(defvar mime-content-types - '(("text" - ;; Charset parameter need not to be specified, since it is - ;; defined automatically while translation. - ("plain" - ;;("charset" "" "ISO-2022-JP" "US-ASCII" "ISO-8859-1" "ISO-8859-8") - ) - ("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-48") - ) - ("message" - ("external-body" - ("access-type" - ("anon-ftp" - ("site" "ftp.jaist.ac.jp" "wnoc-fuk.wide.ad.jp" "nic.karrn.ad.jp") - ("directory" "/pub/GNU/elisp/mime") - ("name") - ("mode" "image" "ascii" "local8")) - ("ftp" - ("site") - ("directory") - ("name") - ("mode" "image" "ascii" "local8")) - ("tftp" ("site") ("name")) - ("afs" ("site") ("name")) - ("local-file" ("site") ("name")) - ("mail-server" ("server" "ftpmail@nic.karrn.ad.jp")) - )) - ("rfc822") - ) - ("application" - ("octet-stream" ("type" "" "tar" "shar")) - ("postscript") - ("x-kiss" ("x-cnf"))) - ("image" - ("gif") - ("jpeg") - ("png") - ("tiff") - ("x-pic") - ("x-mag") - ("x-xwd") - ("x-xbm") - ) - ("audio" ("basic")) - ("video" ("mpeg")) - ) - "*Alist of content-type, subtype, parameters and its values.") - -(defcustom mime-file-types - '(("\\.txt$" - "text" "plain" nil - nil - "inline" (("filename" . file)) - ) - ("\\.pln$" - "text" "plain" nil - nil - "inline" (("filename" . file)) - ) - ("\\.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)) - ) - ("\\.png$" - "image" "png" nil - "base64" - "inline" (("filename" . file)) - ) - ("\\.tiff$" - "image" "tiff" nil - "base64" - "inline" (("filename" . file)) - ) - ("\\.pic$" - "image" "x-pic" nil - "base64" - "inline" (("filename" . file)) - ) - ("\\.mag$" - "image" "x-mag" nil - "base64" - "inline" (("filename" . file)) - ) - ("\\.xbm$" - "image" "x-xbm" nil - "base64" - "inline" (("filename" . file)) - ) - ("\\.xwd$" - "image" "x-xwd" nil - "base64" - "inline" (("filename" . file)) - ) - ("\\.au$" - "audio" "basic" nil - "base64" - "attachment" (("filename" . file)) - ) - ("\\.mpg$" - "video" "mpeg" nil - "base64" - "attachment" (("filename" . file)) - ) - ("\\.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 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." - :type `(repeat - (list regexp - ;; primary-type - (choice :tag "Primary-Type" - ,@(nconc (mapcar (lambda (cell) - (list 'item (car cell)) - ) - mime-content-types) - '(string))) - ;; subtype - (choice :tag "Sub-Type" - ,@(nconc - (apply #'nconc - (mapcar (lambda (cell) - (mapcar (lambda (cell) - (list 'item (car cell)) - ) - (cdr cell))) - mime-content-types)) - '(string))) - ;; parameters - (repeat :tag "Parameters of Content-Type field" - (cons string (choice string symbol))) - ;; content-transfer-encoding - (choice :tag "Encoding" - ,@(cons - '(const nil) - (mapcar (lambda (cell) - (list 'item (car cell)) - ) - mime-file-encoding-method-alist))) - ;; disposition-type - (choice :tag "Disposition-Type" - (item nil) - (item "inline") - (item "attachment") - string) - ;; parameters - (repeat :tag "Parameters of Content-Disposition field" - (cons string (choice string symbol))) - )) - :group 'mime-edit) - - -;;; @@ about charset, encoding and transfer-level -;;; - -(defvar mime-charset-type-list - '((us-ascii 7 nil) - (iso-8859-1 8 "quoted-printable") - (iso-8859-2 8 "quoted-printable") - (iso-8859-3 8 "quoted-printable") - (iso-8859-4 8 "quoted-printable") - (iso-8859-5 8 "quoted-printable") - (koi8-r 8 "quoted-printable") - (iso-8859-7 8 "quoted-printable") - (iso-8859-8 8 "quoted-printable") - (iso-8859-9 8 "quoted-printable") - (iso-2022-jp 7 "base64") - (iso-2022-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.") - -(defvar mime-edit-yank-ignored-field-regexp - (concat "^" - (apply (function regexp-or) mime-edit-yank-ignored-field-list) - ":")) - -(defvar mime-edit-message-inserter-alist nil) -(defvar mime-edit-mail-inserter-alist nil) - - -;;; @@ about message splitting -;;; - -(defcustom mime-edit-split-message t - "*Split large message if it is non-nil." - :group 'mime-edit - :type 'boolean) - -(defcustom mime-edit-message-default-max-lines 1000 - "*Default maximum lines of a message." - :group 'mime-edit - :type 'integer) - -(defcustom mime-edit-message-max-lines-alist - '((news-reply-mode . 500)) - "Alist of major-mode vs maximum lines of a message. -If it is not specified for a major-mode, -`mime-edit-message-default-max-lines' is used." - :group 'mime-edit - :type 'list) - -(defconst mime-edit-split-ignored-field-regexp - "\\(^Content-\\|^Subject:\\|^Mime-Version:\\)") - -(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).") - -(defvar mime-edit-encrypting-type 'pgp-elkins - "*PGP encrypting type (pgp-elkins, pgp-kazu or nil).") - - -;;; @@ about tag -;;; - -(defconst mime-edit-single-part-tag-regexp - "--[[][[]\\([^]]*\\)]\\([[]\\([^]]*\\)]\\|\\)]" - "*Regexp of MIME tag in the form of [[CONTENT-TYPE][ENCODING]].") - -(defconst mime-edit-quoted-single-part-tag-regexp - (concat "- " (substring mime-edit-single-part-tag-regexp 1))) - -(defconst mime-edit-multipart-beginning-regexp "--<<\\([^<>]+\\)>>-{\n") - -(defconst mime-edit-multipart-end-regexp "--}-<<\\([^<>]+\\)>>\n") - -(defconst mime-edit-beginning-tag-regexp - (regexp-or mime-edit-single-part-tag-regexp - mime-edit-multipart-beginning-regexp)) - -(defconst mime-edit-end-tag-regexp - (regexp-or mime-edit-single-part-tag-regexp - mime-edit-multipart-end-regexp)) - -(defconst mime-edit-tag-regexp - (regexp-or mime-edit-single-part-tag-regexp - mime-edit-multipart-beginning-regexp - mime-edit-multipart-end-regexp)) - -(defvar mime-tag-format "--[[%s]]" - "*Control-string making a MIME tag.") - -(defvar mime-tag-format-with-encoding "--[[%s][%s]]" - "*Control-string making a MIME tag with encoding.") - - -;;; @@ multipart boundary -;;; - -(defvar mime-multipart-boundary "Multipart" - "*Boundary of a multipart message.") - - -;;; @@ optional header fields -;;; - -(defvar mime-edit-insert-x-emacs-field t - "*If non-nil, insert X-Emacs header field.") - -(defvar mime-edit-x-emacs-value - (if (featurep '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 - (if enable-multibyte-characters - (concat ", MULE " mule-version) - " (with raw setting)") - (if (featurep 'meadow) - (concat ", " (Meadow-version)) - )) - ver))) - "Body of X-Emacs field. -If variable `mime-edit-insert-x-emacs-field' is not nil, it is -inserted into message header.") - - -;;; @ 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-string ")") - "MIME version number.") - -(defconst mime-edit-mime-version-field-for-message/partial - (concat "MIME-Version: 1.0 (split by " mime-edit-version-string ")\n") - "MIME version field for message/partial.") - - -;;; @ keymap and menu -;;; - -(defvar mime-edit-mode-flag nil) -(make-variable-buffer-local 'mime-edit-mode-flag) - -(defvar mime-edit-mode-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 - ;; 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 - ;; 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 enriched text. - --[[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 (&optional subtype) - "Insert a text message. -Charset is automatically obtained from the `charsets-mime-charset-alist'. -If optional argument SUBTYPE is not nil, text/SUBTYPE tag is inserted." - (interactive) - (let ((ret (mime-edit-insert-tag "text" subtype nil))) - (when ret - (if (looking-at mime-edit-single-part-tag-regexp) - (progn - ;; Make a space between the following message. - (insert "\n") - (forward-char -1) - )) - (if (and (member (cadr ret) '("enriched" "richtext")) - (fboundp 'enriched-mode) - ) - (enriched-mode t) - (if (boundp 'enriched-mode) - (enriched-mode -1) - )) - ))) - -(defun mime-edit-insert-file (file &optional verbose) - "Insert a message from a file." - (interactive "fInsert file as MIME message: \nP") - (let* ((guess (mime-find-file-type file)) - (type (nth 0 guess)) - (subtype (nth 1 guess)) - (parameters (nth 2 guess)) - (encoding (nth 3 guess)) - (disposition-type (nth 4 guess)) - (disposition-params (nth 5 guess)) - ) - (if verbose - (setq type (mime-prompt-for-type type) - subtype (mime-prompt-for-subtype type subtype) - )) - (if (or (interactive-p) verbose) - (setq encoding (mime-prompt-for-encoding encoding)) - ) - (if (or (consp parameters) (stringp disposition-type)) - (let ((rest parameters) cell attribute value) - (setq parameters "") - (while rest - (setq cell (car rest)) - (setq attribute (car cell)) - (setq value (cdr cell)) - (if (eq value 'file) - (setq value (std11-wrap-as-quoted-string - (file-name-nondirectory file))) - ) - (setq parameters (concat parameters "; " attribute "=" value)) - (setq rest (cdr rest)) - ) - (if disposition-type - (progn - (setq parameters - (concat parameters "\n" - "Content-Disposition: " disposition-type)) - (setq rest disposition-params) - (while rest - (setq cell (car rest)) - (setq attribute (car cell)) - (setq value (cdr cell)) - (if (eq value 'file) - (setq value (std11-wrap-as-quoted-string - (file-name-nondirectory file))) - ) - (setq parameters - (concat parameters "; " attribute "=" value)) - (setq rest (cdr rest)) - ) - )) - )) - (mime-edit-insert-tag type subtype parameters) - (mime-edit-insert-binary-file file encoding) - )) - -(defun mime-edit-insert-external () - "Insert a reference to external body." - (interactive) - (mime-edit-insert-tag "message" "external-body" nil ";\n\t") - ;;(forward-char -1) - ;;(insert "Content-Description: " (read-string "Content-Description: ") "\n") - ;;(forward-line 1) - (let* ((pritype (mime-prompt-for-type)) - (subtype (mime-prompt-for-subtype pritype)) - (parameters (mime-prompt-for-parameters pritype subtype ";\n\t"))) - (and pritype - subtype - (insert "Content-Type: " - pritype "/" subtype (or parameters "") "\n"))) - (if (and (not (eobp)) - (not (looking-at mime-edit-single-part-tag-regexp))) - (insert (mime-make-text-tag) "\n"))) - -(defun mime-edit-insert-voice () - "Insert a voice message." - (interactive) - (let ((encoding - (completing-read - "What transfer encoding: " - mime-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 () - (let ((items (mime-find-file-type signature-file-name))) - (apply (function mime-edit-insert-tag) - (car items) (cadr items) (list (caddr items)))) - ))) - ) - (insert-signature arg) - )) - - -;; 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) - )) - )) - - -;; Commands work on a current message flagment. - -(defun mime-edit-goto-tag () - "Search for the beginning of the tagged MIME message." - (let ((current (point))) - (if (looking-at mime-edit-tag-regexp) - t - ;; At first, go to the end. - (cond ((re-search-forward mime-edit-beginning-tag-regexp nil t) - (goto-char (1- (match-beginning 0))) ;For multiline tag - ) - (t - (goto-char (point-max)) - )) - ;; Then search for the beginning. - (re-search-backward mime-edit-end-tag-regexp nil t) - (or (looking-at mime-edit-beginning-tag-regexp) - ;; Restore previous point. - (progn - (goto-char current) - nil - )) - ))) - -(defun mime-edit-content-beginning () - "Return the point of the beginning of content." - (save-excursion - (let ((beg (save-excursion - (beginning-of-line) (point)))) - (if (mime-edit-goto-tag) - (let ((top (point))) - (goto-char (match-end 0)) - (if (and (= beg top) - (= (following-char) ?\^M)) - (point) - (forward-line 1) - (point))) - ;; Default text/plain tag. - (goto-char (point-min)) - (re-search-forward - (concat "\n" (regexp-quote mail-header-separator) - (if mime-ignore-preceding-spaces - "[ \t\n]*\n" "\n")) nil 'move) - (point)) - ))) - -(defun mime-edit-content-end () - "Return the point of the end of content." - (save-excursion - (if (mime-edit-goto-tag) - (progn - (goto-char (match-end 0)) - (if (invisible-p (point)) - (next-visible-point (point)) - ;; Move to the end of this text. - (if (re-search-forward mime-edit-tag-regexp nil 'move) - ;; Don't forget a multiline tag. - (goto-char (match-beginning 0)) - ) - (point) - )) - ;; Assume the message begins with text/plain. - (goto-char (mime-edit-content-beginning)) - (if (re-search-forward mime-edit-tag-regexp nil 'move) - ;; Don't forget a multiline tag. - (goto-char (match-beginning 0))) - (point)) - )) - -(defun mime-edit-define-charset (charset) - "Set charset of current tag to CHARSET." - (save-excursion - (if (mime-edit-goto-tag) - (let ((tag (buffer-substring (match-beginning 0) (match-end 0)))) - (delete-region (match-beginning 0) (match-end 0)) - (insert - (mime-create-tag - (mime-edit-set-parameter - (mime-edit-get-contype tag) - "charset" (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))) - - -;; 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)))) - - -;; Basic functions - -(defun mime-find-file-type (file) - "Guess Content-Type, subtype, and parameters from FILE." - (let ((guess nil) - (guesses mime-file-types)) - (while (and (not guess) guesses) - (if (string-match (car (car guesses)) file) - (setq guess (cdr (car guesses)))) - (setq guesses (cdr guesses))) - guess - )) - -(defun mime-prompt-for-type (&optional default) - "Ask for Content-type." - (let ((type "")) - ;; Repeat until primary content type is specified. - (while (string-equal type "") - (setq type - (completing-read "What content type: " - mime-content-types - nil - 'require-match ;Type must be specified. - default - )) - (if (string-equal type "") - (progn - (message "Content type is required.") - (beep) - (sit-for 1) - )) - ) - type)) - -(defun mime-prompt-for-subtype (type &optional default) - "Ask for subtype of media-type TYPE." - (let ((subtypes (cdr (assoc type mime-content-types)))) - (or (and default - (assoc default subtypes)) - (setq default (car (car subtypes))) - )) - (let* ((answer - (completing-read - (if default - (concat - "What content subtype: (default " default ") ") - "What content subtype: ") - (cdr (assoc type mime-content-types)) - nil - 'require-match ;Subtype must be specified. - nil - ))) - (if (string-equal answer "") default answer))) - -(defun mime-prompt-for-parameters (pritype subtype &optional delimiter) - "Ask for Content-type parameters of Content-Type PRITYPE and SUBTYPE. -Optional DELIMITER specifies parameter delimiter (';' by default)." - (let* ((delimiter (or delimiter "; ")) - (parameters - (mapconcat - (function identity) - (delq nil - (mime-prompt-for-parameters-1 - (cdr (assoc subtype - (cdr (assoc pritype mime-content-types)))))) - delimiter - ))) - (if (and (stringp parameters) - (not (string-equal parameters ""))) - (concat delimiter parameters) - "" ;"" if no parameters - ))) - -(defun mime-prompt-for-parameters-1 (optlist) - (apply (function append) - (mapcar (function mime-prompt-for-parameter) optlist))) - -(defun mime-prompt-for-parameter (parameter) - "Ask for PARAMETER. -Parameter must be '(PROMPT CHOICE1 (CHOISE2 ...))." - (let* ((prompt (car parameter)) - (choices (mapcar (function - (lambda (e) - (if (consp e) e (list e)))) - (cdr parameter))) - (default (car (car choices))) - (answer nil)) - (if choices - (progn - (setq answer - (completing-read - (concat "What " prompt - ": (default " - (if (string-equal default "") "\"\"" default) - ") ") - choices nil nil "")) - ;; If nothing is selected, use default. - (if (string-equal answer "") - (setq answer default))) - (setq answer - (read-string (concat "What " prompt ": ")))) - (cons (if (and answer - (not (string-equal answer ""))) - (concat prompt "=" - ;; Note: control characters ignored! - (if (string-match mime-tspecials-regexp answer) - (concat "\"" answer "\"") answer))) - (mime-prompt-for-parameters-1 (cdr (assoc answer (cdr parameter))))) - )) - -(defun mime-prompt-for-encoding (default) - "Ask for Content-Transfer-Encoding." - (let (encoding) - (while (string= - (setq encoding - (completing-read - "What transfer encoding: " - mime-file-encoding-method-alist nil t default) - ) - "")) - encoding)) - - -;;; @ 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 (as-binary-process - (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) - "Translate single-part-tag to MIME header." - (if (re-search-forward mime-edit-single-part-tag-regexp nil t) - (let* ((beg (match-beginning 0)) - (end (match-end 0)) - (tag (buffer-substring beg end)) - ) - (delete-region beg end) - (let ((contype (mime-edit-get-contype tag)) - (encoding (mime-edit-get-encoding tag)) - ) - (insert (concat prefix "--" boundary "\n")) - (save-restriction - (narrow-to-region (point)(point)) - (insert "Content-Type: " contype "\n") - (if encoding - (insert "Content-Transfer-Encoding: " encoding "\n")) - (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-48") - (save-excursion - (forward-line) - (mule-caesar-region (point) (mime-edit-content-end)) - )) - ((string-equal contype "text/enriched") - (save-excursion - (let ((beg (progn - (forward-line) - (point))) - (end (mime-edit-content-end)) - ) - ;; Patch for hard newlines - ;; (save-excursion - ;; (goto-char beg) - ;; (while (search-forward "\n" end t) - ;; (put-text-property (match-beginning 0) - ;; (point) - ;; 'hard t))) - ;; End patch for hard newlines - (enriched-encode beg end) - (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) - ;; Protect "From " in beginning of line - (save-restriction - (narrow-to-region beg (mime-edit-content-end)) - (goto-char beg) - (let (case-fold-search) - (if (re-search-forward "^From " nil t) - (unless encoding - (if (memq charset '(iso-2022-jp - iso-2022-jp-2 - iso-2022-int-1 - x-ctext)) - (while (progn - (replace-match "\e(BFrom ") - (re-search-forward "^From " nil t) - )) - (setq encoding "quoted-printable") - ))))) - ;; canonicalize line break code - (or (member encoding '(nil "7bit" "8bit" "quoted-printable")) - (save-restriction - (narrow-to-region beg (mime-edit-content-end)) - (goto-char beg) - (while (re-search-forward "\\([^\r]\\)\n" nil t) - (replace-match - (concat (buffer-substring (match-beginning 0) - (match-end 1)) "\r\n")) - ))) - (goto-char beg) - (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))) - ))) - - -;;; -;;; Platform dependent functions -;;; - -;; Sun implementations - -(defun mime-edit-voice-recorder-for-sun (encoding) - "Record voice in a buffer using Sun audio device, -and insert data encoded as ENCODING." - (message "Start the recording on %s. Type C-g to finish the recording..." - (system-name)) - (mime-insert-encoded-file "/dev/audio" encoding) - ) - - -;;; @ Other useful commands. -;;; - -;; Message forwarding commands as content-type "message/rfc822". - -(defun mime-edit-insert-message (&optional message) - (interactive) - (let ((inserter (cdr (assq major-mode mime-edit-message-inserter-alist)))) - (if (and inserter (fboundp inserter)) - (progn - (mime-edit-insert-tag "message" "rfc822") - (funcall inserter message) - ) - (message "Sorry, I don't have message inserter for your MUA.") - ))) - -(defun mime-edit-insert-mail (&optional message) - (interactive) - (let ((inserter (cdr (assq major-mode mime-edit-mail-inserter-alist)))) - (if (and inserter (fboundp inserter)) - (progn - (mime-edit-insert-tag "message" "rfc822") - (funcall inserter message) - ) - (message "Sorry, I don't have mail inserter for your MUA.") - ))) - -(defun mime-edit-inserted-message-filter () - (save-excursion - (save-restriction - (let ((header-start (point)) - (case-fold-search t) - beg end) - ;; for Emacs 18 - ;; (if (re-search-forward "^$" (marker-position (mark-marker))) - (if (re-search-forward "^$" (mark t)) - (narrow-to-region header-start (match-beginning 0)) - ) - (goto-char header-start) - (while (and (re-search-forward - mime-edit-yank-ignored-field-regexp nil t) - (setq beg (match-beginning 0)) - (setq end (1+ (std11-field-end))) - ) - (delete-region beg end) - ) - )))) - - -;;; @ multipart enclosure -;;; - -(defun mime-edit-enclose-region-internal (type beg end) - (save-excursion - (goto-char beg) - (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-internal 'quote beg end) - ) - -(defun mime-edit-enclose-mixed-region (beg end) - (interactive "*r") - (mime-edit-enclose-region-internal 'mixed beg end) - ) - -(defun mime-edit-enclose-parallel-region (beg end) - (interactive "*r") - (mime-edit-enclose-region-internal 'parallel beg end) - ) - -(defun mime-edit-enclose-digest-region (beg end) - (interactive "*r") - (mime-edit-enclose-region-internal 'digest beg end) - ) - -(defun mime-edit-enclose-alternative-region (beg end) - (interactive "*r") - (mime-edit-enclose-region-internal 'alternative beg end) - ) - -(defun mime-edit-enclose-signed-region (beg end) - (interactive "*r") - (if mime-edit-signing-type - (mime-edit-enclose-region-internal '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-internal '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 mime-edit-mime-version-field-for-message/partial) - (insert (format "\ -Content-Type: message/partial; id=%s; number=%d; total=%d\n%s\n" - id number total separator)) - ) - -(defun mime-edit-split-and-send - (&optional cmd lines mime-edit-message-max-length) - (interactive) - (or lines - (setq lines - (count-lines (point-min) (point-max))) - ) - (or mime-edit-message-max-length - (setq mime-edit-message-max-length - (or (cdr (assq major-mode mime-edit-message-max-lines-alist)) - mime-edit-message-default-max-lines)) - ) - (let* ((mime-edit-draft-file-name - (or (buffer-file-name) - (make-temp-name - (expand-file-name "mime-draft" 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." - (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 () - "Quitting method for mime-view." - (let ((temp mime-raw-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-read-Content-Type))) - (if ctl - (let ((type (car ctl)) - (stype (car (cdr ctl))) - (params (cdr (cdr ctl))) - ) - (cond - ((and (eq type 'application)(eq stype 'pgp-signature)) - (delete-region (point-min)(point-max)) - ) - ((eq 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* ((ctype (format "%s/%s" type stype)) - charset - (pstr - (let ((bytes (+ 14 (length ctype)))) - (mapconcat (function - (lambda (attr) - (if (string= (car attr) "charset") - (progn - (setq charset (cdr attr)) - "") - (let* ((str - (concat (car attr) - "=" (cdr attr)) - ) - (bs (length str)) - ) - (setq bytes (+ bytes bs 2)) - (if (< bytes 76) - (concat "; " str) - (setq bytes (+ bs 1)) - (concat ";\n " str) - ) - )))) - 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 (eq type 'text)) - (progn - (delete-region beg (1+ end)) - (goto-char (point-min)) - (if (search-forward "\n\n" nil t) - (progn - (mime-decode-region - (match-end 0)(point-max) encoding) - (setq encoded t - encoding nil) - ))))))) - (if (or encoded (not not-decode-text)) - (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 - (format "%s/%s%s" type stype pstr) - encoding))) - ) - (delete-region (point-min) he) - (insert - (mime-create-tag - (format "%s/%s%s" 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 diff --git a/mime-image.el b/mime-image.el deleted file mode 100644 index d24963a..0000000 --- a/mime-image.el +++ /dev/null @@ -1,227 +0,0 @@ -;;; mime-image.el --- mime-view filter to display images - -;; Copyright (C) 1995,1996,1997,1998 MORIOKA Tomohiko -;; Copyright (C) 1996 Dan Rich - -;; Author: MORIOKA Tomohiko -;; Dan Rich -;; Maintainer: MORIOKA Tomohiko -;; Created: 1995/12/15 -;; Renamed: 1997/2/21 from tm-image.el - -;; Keywords: image, picture, X-Face, MIME, multimedia, mail, news - -;; This file is part of SEMI (Suite of Emacs MIME Interfaces). - -;; This program is free software; you can redistribute it and/or -;; modify it under the terms of the GNU General Public License as -;; published by the Free Software Foundation; either version 2, or (at -;; your option) any later version. - -;; This program is distributed in the hope that it will be useful, but -;; WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU 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 ((featurep '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 (exec-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-view-filter-for-image)) - (set-alist 'mime-view-image-converter-alist - ctype format) - (add-to-list - 'mime-view-visible-media-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) - ("image/png" . png) - )) - -(defvar mime-view-ps-to-gif-command "pstogif") - - -;;; @ content filter for images -;;; -;; (for XEmacs 19.12 or later) - -(defun mime-view-filter-for-image (ctype params encoding) - (let ((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-view-filter-for-application/postscript (ctype params encoding) - (let* ((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) - )) - -;; If you would like to display inline Postscript image, please -;; activate following: - -;; (set-alist 'mime-view-content-filter-alist -;; "application/postscript" -;; (function mime-view-filter-for-application/postscript)) - -;; (if (featurep 'gif) -;; (add-to-list -;; 'mime-view-visible-media-type-list "application/postscript") -;; ) - - -;;; @ end -;;; - -(provide 'mime-image) - -;;; mime-image.el ends here diff --git a/mime-mc.el b/mime-mc.el deleted file mode 100644 index 78dfdae..0000000 --- a/mime-mc.el +++ /dev/null @@ -1,164 +0,0 @@ -;;; mime-mc.el --- Mailcrypt interface for SEMI - -;; Copyright (C) 1996,1997,1998 MORIOKA Tomohiko - -;; Author: MORIOKA Tomohiko -;; Keywords: PGP, security, MIME, multimedia, mail, news - -;; This file is part of SEMI (Secure Emacs MIME Interface). - -;; This program is free software; you can redistribute it and/or -;; modify it under the terms of the GNU General Public License as -;; published by the Free Software Foundation; either version 2, or (at -;; your option) any later version. - -;; This program is distributed in the hope that it will be useful, but -;; WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; 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 diff --git a/mime-parse.el b/mime-parse.el deleted file mode 100644 index 9f6a9ae..0000000 --- a/mime-parse.el +++ /dev/null @@ -1,279 +0,0 @@ -;;; mime-parse.el --- MIME message parser - -;; Copyright (C) 1994,1995,1996,1997,1998 Free Software Foundation, Inc. - -;; Author: MORIOKA Tomohiko -;; Keywords: parse, MIME, multimedia, mail, news - -;; This file is part of SEMI (Spadework for Emacs MIME Interfaces). - -;; This program is free software; you can redistribute it and/or -;; modify it under the terms of the GNU General Public License as -;; published by the Free Software Foundation; either version 2, or (at -;; your option) any later version. - -;; This program is distributed in the hope that it will be useful, but -;; WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Code: - -(require '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 (mapconcat (function - (lambda (s) - (cond ((symbolp s) (symbol-name s)) - ((stringp s) s) - ))) - args ""))) - - -;;; @ 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) - )))) - -(defun mime-parse-Content-Type (string) - "Parse STRING as field-body of Content-Type field. -Return value is - (PRIMARY-TYPE SUBTYPE (NAME1 . VALUE1)(NAME2 . VALUE2) ...) -or nil. PRIMARY-TYPE and SUBTYPE are symbol and NAME_n and VALUE_n -are string." - (setq string (std11-unfold-string string)) - (if (string-match `,(concat "^\\(" mime-token-regexp - "\\)/\\(" mime-token-regexp "\\)") string) - (let* ((type (downcase - (substring string (match-beginning 1) (match-end 1)))) - (subtype (downcase - (substring string (match-beginning 2) (match-end 2)))) - ret dest) - (setq string (substring string (match-end 0))) - (while (setq ret (mime-parse-parameter string)) - (setq dest (cons (car ret) dest) - string (cdr ret)) - ) - (cons (intern type) (cons (intern subtype) (nreverse dest))) - ))) - - -(defconst mime-disposition-type-regexp mime-token-regexp) - -(defun mime-parse-Content-Disposition (string) - "Parse STRING as field-body of Content-Disposition field." - (setq string (std11-unfold-string string)) - (if (string-match `,(concat "^" mime-disposition-type-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-read-Content-Type () - "Read field-body of Content-Type field from current-buffer, -and return parsed it. Format of return value is as same as -`mime-parse-Content-Type'." - (let ((str (std11-field-body "Content-Type"))) - (if str - (mime-parse-Content-Type str) - ))) - -(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 -;;; - -(defsubst make-mime-entity-info (rcnum - point-min point-max - media-type media-subtype parameters - encoding children) - (vector rcnum point-min point-max - media-type media-subtype parameters encoding children)) - -(defsubst mime-entity-info-rnum (entity-info) (aref entity-info 0)) -(defsubst mime-entity-info-point-min (entity-info) (aref entity-info 1)) -(defsubst mime-entity-info-point-max (entity-info) (aref entity-info 2)) -(defsubst mime-entity-info-media-type (entity-info) (aref entity-info 3)) -(defsubst mime-entity-info-media-subtype (entity-info) (aref entity-info 4)) -(defsubst mime-entity-info-parameters (entity-info) (aref entity-info 5)) -(defsubst mime-entity-info-encoding (entity-info) (aref entity-info 6)) -(defsubst mime-entity-info-children (entity-info) (aref entity-info 7)) - -(defsubst mime-entity-info-type/subtype (entity-info) - (let ((type (mime-entity-info-media-type entity-info))) - (if type - (let ((subtype (mime-entity-info-media-subtype entity-info))) - (if subtype - (format "%s/%s" type subtype) - (symbol-name type)))))) - -(defun mime-parse-multipart (boundary primtype subtype 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 (eq subtype 'digest) - '(message rfc822) - '(text plain) - )) - cb ce 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-entity-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)) - ) - (make-mime-entity-info rcnum beg (point-max) - primtype subtype params encoding - (nreverse children)) - )) - -(defun mime-parse-message (&optional default-ctl default-encoding rcnum) - "Parse current-buffer as a MIME message. -DEFAULT-CTL is used when an entity does not have valid Content-Type -field. Its format must be as same as return value of -mime-{parse|read}-Content-Type." - (setq default-ctl (or (mime-read-Content-Type) default-ctl)) - (let ((primtype (car default-ctl)) - (subtype (car (cdr default-ctl))) - (params (cdr (cdr default-ctl))) - (encoding (or (mime/Content-Transfer-Encoding) default-encoding)) - ) - (let ((boundary (assoc "boundary" params))) - (cond (boundary - (setq boundary (std11-strip-quoted-string (cdr boundary))) - (mime-parse-multipart - boundary - primtype subtype params encoding rcnum) - ) - ((and (eq primtype 'message) - (memq subtype '(rfc822 news)) - ) - (goto-char (point-min)) - (make-mime-entity-info rcnum - (point-min) (point-max) - primtype subtype 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 - (make-mime-entity-info rcnum (point-min) (point-max) - primtype subtype params encoding - nil) - )) - ))) - - -;;; @ end -;;; - -(provide 'mime-parse) - -;;; mime-parse.el ends here diff --git a/mime-partial.el b/mime-partial.el deleted file mode 100644 index 4cef03a..0000000 --- a/mime-partial.el +++ /dev/null @@ -1,110 +0,0 @@ -;;; mime-partial.el --- Grabbing all MIME "message/partial"s. - -;; Copyright (C) 1995,1996,1997,1998 Free Software Foundation, Inc. - -;; Author: OKABE Yasuo @ Kyoto University -;; MORIOKA Tomohiko -;; Keywords: message/partial, MIME, multimedia, mail, news - -;; This file is part of SEMI (Suite of Emacs MIME Interfaces). - -;; This program is free software; you can redistribute it and/or -;; modify it under the terms of the GNU General Public License as -;; published by the Free Software Foundation; either version 2, or (at -;; your option) any later version. - -;; This program is distributed in the hope that it will be useful, but -;; WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Code: - -(require 'mime-view) -(require 'mime-play) - -(defvar mime-view-partial-message-method-alist nil - "Alist major-mode vs. function to view partial message for mime-partial.") - -;; display Article at the cursor in Subject buffer. -(defsubst mime-view-partial-message (target) - (save-window-excursion - (let ((f (assq target mime-view-partial-message-method-alist))) - (if f - (funcall (cdr f)) - (error "Fatal. Unsupported mode") - )))) - -(defun mime-combine-message/partials-automatically (beg end cal) - "Internal method for mime-view to combine message/partial messages -automatically. This function refers variable -`mime-view-partial-message-method-alist' to select function to display -partial messages using mime-view." - (interactive) - (let* ((id (cdr (assoc "id" cal))) - (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-method-to-store-message/partial beg end cal) - (let (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-view-partial-message target) - (set-buffer article-buffer) - (setq parameters - (mime-entity-info-parameters mime-raw-content-info)) - (setq the-id (cdr (assoc "id" parameters))) - (if (string= the-id id) - (progn - (mime-method-to-store-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 diff --git a/mime-pgp.el b/mime-pgp.el deleted file mode 100644 index 146ac5c..0000000 --- a/mime-pgp.el +++ /dev/null @@ -1,321 +0,0 @@ -;;; mime-pgp.el --- mime-view internal methods for PGP. - -;; Copyright (C) 1995,1996,1997,1998 MORIOKA Tomohiko - -;; Author: MORIOKA Tomohiko -;; Created: 1995/12/7 -;; Renamed: 1997/2/27 from tm-pgp.el -;; Keywords: PGP, security, MIME, multimedia, mail, news - -;; This file is part of SEMI (Secure Emacs MIME Interface). - -;; This program is free software; you can redistribute it and/or -;; modify it under the terms of the GNU General Public License as -;; published by the Free Software Foundation; either version 2, or (at -;; your option) any later version. - -;; This program is distributed in the hope that it will be useful, but -;; WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: - -;; This module is based on 2 drafts about PGP MIME integration: - -;; - RFC 2015: "MIME Security with Pretty Good Privacy (PGP)" -;; by Michael Elkins (1996/6) -;; -;; - draft-kazu-pgp-mime-00.txt: "PGP MIME Integration" -;; by Kazuhiko Yamamoto -;; (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-method-for-application/pgp (beg end cal) - (let* ((cnum (mime-article/point-content-number beg)) - (p-win (or (get-buffer-window mime-view-buffer) - (get-largest-window))) - (new-name (format "%s-%s" (buffer-name) cnum)) - (the-buf (current-buffer)) - (mother mime-view-buffer) - (mode major-mode) - text-decoder) - (set-buffer (get-buffer-create new-name)) - (erase-buffer) - (insert-buffer-substring the-buf beg end) - (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 text-decoder - (cdr (or (assq mode mime-text-decoder-alist) - (assq t mime-text-decoder-alist)))) - ) - ((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 text-decoder (function mime-text-decode-buffer)) - )) - (setq major-mode 'mime-show-message-mode) - (setq mime-text-decoder text-decoder) - (save-window-excursion (mime-view-mode mother)) - (set-window-buffer p-win mime-view-buffer) - )) - -(set-atype 'mime-acting-condition - '((type . "application/pgp") - (method . mime-method-for-application/pgp) - )) - -(set-atype 'mime-acting-condition - '((type . "text/x-pgp") - (method . mime-method-for-application/pgp) - )) - - -;;; @ Internal method for multipart/signed -;;; - -(defun mime-method-to-verify-multipart/signed (beg end cal) - "Internal method to check multipart/signed." - (let* ((rcnum (reverse (mime-article/point-content-number beg))) - (oinfo (mime-article/rcnum-to-cinfo (cons '1 rcnum) - mime-raw-content-info)) - ) - (mime-playback-entity oinfo (cdr (assq 'mode cal))) - )) - -(set-atype 'mime-acting-condition - '((type . "multipart/signed") - (method . mime-method-to-verify-multipart/signed) - )) - - -;;; @ Internal method for application/pgp-signature -;;; -;;; It is based on RFC 2015. - -(defvar mime-pgp-command "pgp" - "*Name of the PGP command.") - -(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-pgp-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) - mime-pgp-command - 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-method-to-verify-application/pgp-signature (beg end cal) - "Internal method to check PGP/MIME signature." - (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))) - (raw-buf (current-buffer)) - (oinfo (mime-article/rcnum-to-cinfo (cons onum rmcnum) - mime-raw-content-info)) - kbuf - (basename (expand-file-name "tm" mime-temp-directory)) - (orig-file (make-temp-name basename)) - (sig-file (concat orig-file ".sig")) - ) - (save-excursion - (let ((p-min (mime-entity-info-point-min oinfo)) - (p-max (mime-entity-info-point-max oinfo)) - ) - (set-buffer (get-buffer-create mime-temp-buffer-name)) - (insert-buffer-substring raw-buf p-min p-max) - ) - (goto-char (point-min)) - (while (re-search-forward "\n" nil t) - (replace-match "\r\n") - ) - (as-binary-output-file (write-region (point-min)(point-max) orig-file)) - (kill-buffer (current-buffer)) - ) - (save-excursion (mime-show-echo-buffer)) - (save-excursion - (let ((p-min (save-excursion - (goto-char beg) - (and (search-forward "\n\n") - (match-end 0)) - ))) - (set-buffer (setq kbuf (get-buffer-create mime-temp-buffer-name))) - (insert-buffer-substring raw-buf p-min end) - ) - (mime-decode-region (point-min)(point-max) encoding) - (as-binary-output-file (write-region (point-min)(point-max) sig-file)) - (or (mime-pgp-check-signature mime-echo-buffer-name orig-file) - (let (pgp-id) - (save-excursion - (set-buffer mime-echo-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-pgp-check-signature mime-echo-buffer-name orig-file) - )) - )) - (let ((other-window-scroll-buffer mime-echo-buffer-name)) - (scroll-other-window 8) - ) - (kill-buffer kbuf) - (delete-file orig-file) - (delete-file sig-file) - ))) - -(set-atype 'mime-acting-condition - '((type . "application/pgp-signature") - (method . mime-method-to-verify-application/pgp-signature) - )) - - -;;; @ Internal method for application/pgp-encrypted -;;; -;;; It is based on RFC 2015. - -(defun mime-method-to-decrypt-application/pgp-encrypted (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-raw-content-info)) - (obeg (mime-entity-info-point-min oinfo)) - (oend (mime-entity-info-point-max oinfo)) - ) - (mime-method-for-application/pgp obeg oend cal) - )) - -(set-atype 'mime-acting-condition - '((type . "application/pgp-encrypted") - (method . mime-method-to-decrypt-application/pgp-encrypted) - )) - - -;;; @ Internal method for application/pgp-keys -;;; -;;; It is based on RFC 2015. - -(defun mime-method-to-add-application/pgp-keys (beg end cal) - (let* ((cnum (mime-article/point-content-number beg)) - (new-name (format "%s-%s" (buffer-name) cnum)) - (encoding (cdr (assq 'encoding cal))) - 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-acting-condition - '((type . "application/pgp-keys") - (method . mime-method-to-add-application/pgp-keys) - )) - - -;;; @ end -;;; - -(provide 'mime-pgp) - -(run-hooks 'mime-pgp-load-hook) - -;;; mime-pgp.el ends here diff --git a/mime-play.el b/mime-play.el deleted file mode 100644 index 65b9fcf..0000000 --- a/mime-play.el +++ /dev/null @@ -1,529 +0,0 @@ -;;; mime-play.el --- Playback processing module for mime-view.el - -;; Copyright (C) 1994,1995,1996,1997,1998 Free Software Foundation, Inc. - -;; Author: MORIOKA Tomohiko -;; Created: 1995/9/26 (separated from tm-view.el) -;; Renamed: 1997/2/21 from tm-play.el -;; Keywords: MIME, multimedia, mail, news - -;; This file is part of SEMI (Secretariat of Emacs MIME Interfaces). - -;; This program is free software; you can redistribute it and/or -;; modify it under the terms of the GNU General Public License as -;; published by the Free Software Foundation; either version 2, or (at -;; your option) any later version. - -;; This program is distributed in the hope that it will be useful, but -;; WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Code: - -(require 'mime-view) -(require 'alist) -(require 'filename) - - -;;; @ content decoder -;;; - -(defvar mime-preview/after-decoded-position nil) - -(defun mime-view-play-current-entity (&optional mode) - "Play current entity. -It decodes current entity to call internal or external method. The -method is selected from variable `mime-acting-condition'. -If MODE is specified, play as it. Default MODE is \"play\"." - (interactive) - (or mode - (setq mode "play") - ) - (let ((cinfo (get-text-property (point) 'mime-view-cinfo))) - (if cinfo - (let ((the-buf (current-buffer)) - (raw-buffer (get-text-property (point) 'mime-view-raw-buffer)) - ) - (setq mime-preview/after-decoded-position (point)) - (set-buffer raw-buffer) - (mime-playback-entity cinfo mode) - (if (eq (current-buffer) raw-buffer) - (progn - (set-buffer the-buf) - (goto-char mime-preview/after-decoded-position) - )) - )))) - -(defun mime-playback-entity (cinfo &optional mode) - (let ((beg (mime-entity-info-point-min cinfo)) - (end (mime-entity-info-point-max cinfo)) - (ctype (or (mime-entity-info-type/subtype cinfo) "text/plain")) - (params (mime-entity-info-parameters cinfo)) - (encoding (mime-entity-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 mode - (setq cal (cons (cons 'mode 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-activate-external-method beg end ret) - ) - (t - (mime-show-echo-buffer - "No method are specified for %s\n" ctype) - )) - ) - )) - - -;;; @ method selector -;;; - -(defun mime/get-content-decoding-alist (al) - (get-unified-alist mime-acting-condition al) - ) - - -;;; @ external decoder -;;; - -(defun mime-activate-external-method (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-echo-buffer-name (car method) - ) - (mime-make-external-method-args - cal (cdr (cdr method))) - )) - (apply (function start-process) args) - (mime-show-echo-buffer) - )) - )))) - -(defun mime-make-external-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)) - -(defvar mime-echo-window-is-shared-with-bbdb t - "*If non-nil, mime-echo window is shared with BBDB window.") - -(defvar mime-echo-window-height - (function - (lambda () - (/ (window-height) 5) - )) - "*Size of mime-echo window. -It allows function or integer. If it is function, -`mime-show-echo-buffer' calls it to get height of mime-echo window. -Otherwise `mime-show-echo-buffer' uses it as height of mime-echo -window.") - -(defun mime-show-echo-buffer (&rest forms) - "Show mime-echo buffer to display MIME-playing information." - (get-buffer-create mime-echo-buffer-name) - (let ((the-win (selected-window)) - (win (get-buffer-window mime-echo-buffer-name)) - ) - (or win - (if (and mime-echo-window-is-shared-with-bbdb - (boundp 'bbdb-buffer-name) - (setq win (get-buffer-window bbdb-buffer-name)) - ) - (set-window-buffer win mime-echo-buffer-name) - (select-window (get-buffer-window mime-view-buffer)) - (setq win (split-window-vertically - (- (window-height) - (if (functionp mime-echo-window-height) - (funcall mime-echo-window-height) - mime-echo-window-height) - ))) - (set-window-buffer win mime-echo-buffer-name) - )) - (select-window win) - (goto-char (point-max)) - (if forms - (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)) - ) - - -;;; @ file extraction -;;; - -(defun mime-method-to-save (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)))))) - ) - (if (file-exists-p filename) - (or (yes-or-no-p (format "File %s exists. Save anyway? " filename)) - (error ""))) - (re-search-forward "\n\n") - (mime-write-decoded-region (match-end 0)(point-max) filename encoding) - )) - - -;;; @ mail/news message -;;; - -(defun mime-view-quitting-method-for-mime-show-message-mode () - "Quitting method for mime-view. -It is registered to variable `mime-view-quitting-method-alist'." - (let ((mother mime-mother-buffer) - (win-conf mime::preview/original-window-configuration) - ) - (kill-buffer mime-raw-buffer) - (mime-view-kill-buffer) - (set-window-configuration win-conf) - (pop-to-buffer mother) - )) - -(defun mime-method-to-display-message/rfc822 (beg end cal) - (let* ((cnum (mime-article/point-content-number beg)) - (new-name (format "%s-%s" (buffer-name) cnum)) - (mother mime-view-buffer) - (text-decoder - (cdr (or (assq major-mode mime-text-decoder-alist) - (assq t mime-text-decoder-alist)))) - 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-text-decoder text-decoder) - (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-method-to-store-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-view-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-view-buffer)) - (select-window pwin) - ) - (re-search-forward "^$") - (goto-char (1+ (match-end 0))) - (setq file (concat root-dir "/" number)) - (mime-article::write-region (point) end file) - (let ((total-file (concat root-dir "/CT"))) - (setq total - (if total - (progn - (or (file-exists-p total-file) - (save-excursion - (set-buffer - (get-buffer-create mime-temp-buffer-name)) - (erase-buffer) - (insert total) - (write-region (point-min)(point-max) total-file) - (kill-buffer (current-buffer)) - )) - (string-to-number total) - ) - (and (file-exists-p total-file) - (save-excursion - (set-buffer (find-file-noselect total-file)) - (prog1 - (and (re-search-forward "[0-9]+" nil t) - (string-to-number - (buffer-substring (match-beginning 0) - (match-end 0))) - ) - (kill-buffer (current-buffer)) - ))) - ))) - (if (and total (> total 0)) - (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-region (point-min)(point-max) - (expand-file-name "FULL" root-dir))) - (let ((i 1)) - (while (<= i total) - (let ((file (format "%s/%d" root-dir i))) - (and (file-exists-p file) - (delete-file file) - )) - (setq i (1+ i)) - )) - (let ((file (expand-file-name "CT" root-dir))) - (and (file-exists-p file) - (delete-file file) - )) - (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-view-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-view-buffer) - (get-largest-window)))) - (select-window win) - (dired dir) - )) - -(defun mime-method-to-display-message/external-ftp (beg end cal) - (let* ((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 -;;; - -(defun mime-method-to-display-caesar (start end cal) - "Internal method for mime-view to display ROT13-47-48 message." - (let* ((cnum (mime-article/point-content-number start)) - (new-name (format "%s-%s" (buffer-name) cnum)) - (the-buf (current-buffer)) - (mother mime-view-buffer) - (charset (cdr (assoc "charset" cal))) - (encoding (cdr (assq 'encoding cal))) - (mode major-mode) - ) - (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-buffer-substring the-buf start end) - (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) - )) - (mule-caesar-region (point-min) (point-max)) - (set-buffer-modified-p nil) - (set-buffer mother) - (view-buffer new-name) - )) - - -;;; @ end -;;; - -(provide 'mime-play) - -;;; mime-play.el ends here diff --git a/mime-setup.el b/mime-setup.el deleted file mode 100644 index cee4616..0000000 --- a/mime-setup.el +++ /dev/null @@ -1,47 +0,0 @@ -;;; mime-setup.el --- setup file for MIME viewer and composer. - -;; Copyright (C) 1995,1996,1997,1998 Free Software Foundation, Inc. - -;; Author: MORIOKA Tomohiko -;; Keywords: MIME, multimedia, multilingual, mail, news - -;; This file is part of SEMI (Setting for Emacs MIME Interfaces). - -;; This program is free software; you can redistribute it and/or -;; modify it under the terms of the GNU General Public License as -;; published by the Free Software Foundation; either version 2, or (at -;; your option) any later version. - -;; This program is distributed in the hope that it will be useful, but -;; WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Code: - -(load "mail-mime-setup") - -(condition-case 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 diff --git a/mime-tar.el b/mime-tar.el deleted file mode 100644 index 129820c..0000000 --- a/mime-tar.el +++ /dev/null @@ -1,359 +0,0 @@ -;;; 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 -;; modified by MORIOKA Tomohiko -;; Renamed: 1997/2/26 from tm-tar.el -;; Version: $Id: mime-tar.el,v 0.7 1997-05-12 12:30:42 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-view-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-view-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-view-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-acting-condition - '((type . "application/octet-stream") - (method . mime-decode-message/tar) - (mode . "play") ("type" . "tar") - )) - -(set-atype 'mime-acting-condition - '((type . "application/octet-stream") - (method . mime-decode-message/tar) - (mode . "play") ("type" . "tar+gzip") - )) - -(set-atype 'mime-acting-condition - '((type . "application/x-gzip") - (method . mime-decode-message/tar) - (mode . "play") ("type" . "tar") - )) - -(set-atype 'mime-acting-condition - '((type . "application/x-tar") - (method . mime-decode-message/tar) - (mode . "play") - )) - -;;; @ end -;;; - -(provide 'mime-tar) - -;;; mime-tar.el ends here diff --git a/mime-text.el b/mime-text.el deleted file mode 100644 index 7b63a9d..0000000 --- a/mime-text.el +++ /dev/null @@ -1,169 +0,0 @@ -;;; mime-text.el --- mime-view content filter for text - -;; Copyright (C) 1994,1995,1996,1997,1998 Free Software Foundation, Inc. - -;; Author: MORIOKA Tomohiko -;; Keywords: text, MIME, multimedia, mail, news - -;; This file is part of SEMI (Suite of Emacs MIME Interfaces). - -;; This program is free software; you can redistribute it and/or -;; modify it under the terms of the GNU General Public License as -;; published by the Free Software Foundation; either version 2, or (at -;; your option) any later version. - -;; This program is distributed in the hope that it will be useful, but -;; WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Code: - -;;; @ buffer local variables in raw-buffer -;;; - -(defvar mime-text-decoder nil - "Function to decode text in current buffer. -Interface of the function is (CHARSET &optional ENCODING). -CHARSET is symbol of MIME charset and ENCODING is value of -Content-Transfer-Encoding. - -Notice that this variable is usually used as buffer local variable in -raw-buffer.") - -(make-variable-buffer-local 'mime-text-decoder) - - -;;; @ code conversion -;;; - -(defvar mime-text-decoder-alist - '((mime-show-message-mode . mime-text-decode-buffer) - (mime-temp-message-mode . mime-text-decode-buffer) - (t . mime-text-decode-buffer-maybe) - ) - "Alist of major-mode vs. mime-text-decoder. -Each element looks like (SYMBOL . FUNCTION). SYMBOL is major-mode or -t. t means default. - -Specification of FUNCTION is described in DOC-string of variable -`mime-text-decoder'. - -This value is overridden by buffer local variable `mime-text-decoder' -if it is not nil.") - -(defun mime-text-decode-buffer (charset &optional encoding) - "Decode text of current buffer as CHARSET. -It code-converts current buffer from network representation specified -by MIME CHARSET to internal code. CHARSET is symbol of MIME charset. -See also variable `mime-charset-coding-system-alist'." - (decode-mime-charset-region (point-min)(point-max) - (or charset default-mime-charset)) - ) - -(defun mime-text-decode-buffer-maybe (charset &optional encoding) - "Decode text of current buffer as CHARSET if ENCODING is actual encoding. -It code-converts current buffer from network representation specified -by MIME CHARSET to internal code if ENCODING is not nil, \"7bit\", -\"8bit\" or \"binary\". CHARSET is symbol of MIME charset. -See also variable `mime-charset-coding-system-alist'." - (or (member encoding '(nil "7bit" "8bit" "binary")) - (mime-text-decode-buffer charset) - )) - -(defun mime-decode-text-body (charset encoding) - "Decode current buffer as text body. -It decodes MIME-encoding as ENCODING then code-converts as MIME -CHARSET. CHARSET is SYMBOL and ENCODING is nil or STRING. - -It calls text decoder for MIME charset specified by buffer local -variable `mime-text-decoder' and variable `mime-text-decoder-alist'." - (mime-decode-region (point-min) (point-max) encoding) - (goto-char (point-min)) - (while (search-forward "\r\n" nil t) - (replace-match "\n") - ) - (let ((text-decoder - (save-excursion - (set-buffer mime-raw-buffer) - (or mime-text-decoder - (cdr (or (assq major-mode mime-text-decoder-alist) - (assq t mime-text-decoder-alist))) - )))) - (and (functionp text-decoder) - (funcall text-decoder 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-view-filter-for-text/plain (ctype params encoding) - (mime-decode-text-body (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-view-filter-for-text/richtext (ctype params encoding) - (let* ((charset (cdr (assoc "charset" params))) - (beg (point-min)) - ) - (remove-text-properties beg (point-max) '(face nil)) - (mime-decode-text-body charset encoding) - (richtext-decode beg (point-max)) - )) - -(defun mime-view-filter-for-text/enriched (ctype params encoding) - (let* ((charset (cdr (assoc "charset" params))) - (beg (point-min)) - ) - (remove-text-properties beg (point-max) '(face nil)) - (mime-decode-text-body charset encoding) - (enriched-decode beg (point-max)) - )) - - -;;; @ end -;;; - -(provide 'mime-text) - -;;; mime-text.el ends here diff --git a/mime-view.el b/mime-view.el deleted file mode 100644 index f365499..0000000 --- a/mime-view.el +++ /dev/null @@ -1,1216 +0,0 @@ -;;; mime-view.el --- interactive MIME viewer for GNU Emacs - -;; Copyright (C) 1995,1996,1997,1998 Free Software Foundation, Inc. - -;; Author: MORIOKA Tomohiko -;; Created: 1994/7/13 -;; Renamed: 1994/8/31 from tm-body.el -;; Renamed: 1997/02/19 from tm-view.el -;; Keywords: MIME, multimedia, mail, news - -;; This file is part of SEMI (Sophisticated Emacs MIME Interfaces). - -;; This program is free software; you can redistribute it and/or -;; modify it under the terms of the GNU General Public License as -;; published by the Free Software Foundation; either version 2, or (at -;; your option) any later version. - -;; This program is distributed in the hope that it will be useful, but -;; WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Code: - -(require 'std11) -(require 'mel) -(require 'eword-decode) -(require 'mime-parse) -(require 'mime-text) - - -;;; @ version -;;; - -(defconst mime-view-version-string - `,(concat "SEMI MIME-View " - (mapconcat #'number-to-string (cdr semi-version) ".") - " (" (car semi-version) ")")) - - -;;; @ variables -;;; - -(defvar mime-acting-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-method-to-display-caesar) - (mode . "play") - ) - ((type . "text/x-rot13-47-48") - (method . mime-method-to-display-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/png") - (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 . mime-method-to-save)(mode "play" "print") - ) - - ((type . "message/external-body") - ("access-type" . "anon-ftp") - (method . mime-method-to-display-message/external-ftp) - ) - ((type . "message/rfc822") - (method . mime-method-to-display-message/rfc822) - (mode . "play") - ) - ((type . "message/partial") - (method . mime-method-to-store-message/partial) - (mode . "play") - ) - - ((method "metamail" t "-m" "tm" "-x" "-d" "-z" "-e" 'file) - (mode . "play") - ) - ((method . mime-method-to-save)(mode . "extract")) - )) - -(defvar mime-view-childrens-header-showing-Content-Type-list - '("message/rfc822" "message/news")) - -(defvar mime-view-visible-media-type-list - '("text/plain" nil "text/richtext" "text/enriched" - "text/rfc822-headers" - "text/x-latex" "application/x-latex" - "message/delivery-status" - "application/pgp" "text/x-pgp" - "application/octet-stream" - "application/x-selection" "application/x-comment") - "*List of media-types to be able to display in MIME-View buffer. -Each elements are string of TYPE/SUBTYPE, e.g. \"text/plain\".") - -(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.") - -(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. ]]" - )) - - -;;; @@ entity button -;;; - -(defun mime-view-insert-entity-button (rcnum cinfo - media-type media-subtype params - subj encoding) - "Insert entity-button." - (mime-insert-button - (let ((access-type (assoc "access-type" 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 - (format "%s %s ([%s] %s)" - num subj access-type (cdr server)) - (let ((site (cdr (assoc "site" params))) - (dir (cdr (assoc "directory" params))) - ) - (format "%s %s ([%s] %s:%s)" - num subj access-type site dir) - ))) - ) - (t - (let ((charset (cdr (assoc "charset" params)))) - (concat - num " " subj - (let ((rest - (format " <%s/%s%s%s>" - media-type media-subtype - (if charset - (concat "; " charset) - "") - (if encoding - (concat " (" encoding ")") - "")))) - (if (>= (+ (current-column)(length rest))(window-width)) - "\n\t") - rest))) - ))) - (function mime-view-play-current-entity)) - ) - -(defun mime-view-entity-button-function (rcnum cinfo - media-type media-subtype - params subj encoding) - "Insert entity button conditionally. -Please redefine this function if you want to change default setting." - (or (null rcnum) - (and (eq media-type 'application) - (or (eq media-subtype 'x-selection) - (and (eq media-subtype 'octet-stream) - (let ((entity-info - (mime-article/rcnum-to-cinfo (cdr rcnum) cinfo))) - (and (eq (mime-entity-info-media-type entity-info) - 'multipart) - (eq (mime-entity-info-media-subtype entity-info) - 'encrypted) - ))))) - (mime-view-insert-entity-button - rcnum cinfo media-type media-subtype params subj encoding) - )) - - -;;; @@ content header filter -;;; - -(defun mime-view-cut-header () - (goto-char (point-min)) - (while (re-search-forward mime-view-ignored-field-regexp nil t) - (let* ((beg (match-beginning 0)) - (end (match-end 0)) - (name (buffer-substring beg end)) - ) - (catch 'visible - (let ((rest mime-view-visible-field-list)) - (while rest - (if (string-match (car rest) name) - (throw 'visible nil) - ) - (setq rest (cdr rest)))) - (delete-region beg - (save-excursion - (if (re-search-forward "^\\([^ \t]\\|$\\)" nil t) - (match-beginning 0) - (point-max)))) - )))) - -(defun mime-view-default-content-header-filter () - (mime-view-cut-header) - (eword-decode-header) - ) - -(defvar mime-view-content-header-filter-alist nil) - - -;;; @@ content filter -;;; - -(defvar mime-view-content-filter-alist - '(("text/enriched" . mime-view-filter-for-text/enriched) - ("text/richtext" . mime-view-filter-for-text/richtext) - (t . mime-view-filter-for-text/plain) - ) - "Alist of media-types vs. corresponding MIME-View filter functions. -Each element looks like (TYPE/SUBTYPE . FUNCTION) or (t . FUNCTION). -TYPE/SUBTYPE is a string of media-type and FUNCTION is a filter -function. t means default media-type.") - - -;;; @@ entity separator -;;; - -(defun mime-view-entity-separator-function (rcnum cinfo - media-type media-subtype - params subj) - "Insert entity separator conditionally. -Please redefine this function if you want to change default setting." - (or (mime-view-header-visible-p rcnum cinfo) - (mime-view-body-visible-p rcnum cinfo media-type media-subtype) - (progn - (goto-char (point-max)) - (insert "\n") - ))) - - -;;; @@ buffer local variables -;;; - -;;; @@@ in raw buffer -;;; - -(defvar mime-raw-content-info - "Information about structure of message. -Please use reference function `mime::content-info/SLOT-NAME' to -reference slot of content-info. Their argument is only content-info. - -Following is a list of slots of the structure: - -rcnum reversed content-number (list) -point-min beginning point of region in raw-buffer -point-max end point of region in raw-buffer -type media-type/subtype (string or nil) -parameters parameter of Content-Type field (association list) -encoding Content-Transfer-Encoding (string or nil) -children entities included in this entity (list of content-infos) - -If a entity includes other entities in its body, such as multipart or -message/rfc822, content-infos of other entities are included in -`children', so content-info become a tree.") -(make-variable-buffer-local 'mime-raw-content-info) - -(defvar mime-view-buffer nil - "MIME View buffer corresponding with the (raw) buffer.") -(make-variable-buffer-local 'mime-view-buffer) - - -;;; @@@ in view buffer -;;; - -(defvar mime-mother-buffer nil - "Mother buffer corresponding with the (MIME-View) buffer. -If current MIME-View buffer is generated by other buffer, such as -message/partial, it is called `mother-buffer'.") -(make-variable-buffer-local 'mime-mother-buffer) - -(defvar mime-raw-buffer nil - "Raw buffer corresponding with the (MIME-View) buffer.") -(make-variable-buffer-local 'mime-raw-buffer) - -(defvar mime-view-original-major-mode nil - "Major-mode in mime-raw-buffer.") -(make-variable-buffer-local 'mime-view-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)) - "Alist of major-mode vs. quitting-method of mime-view.") - -(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 - "Alist of major-mode vs. show-summary-method.") - - -;;; @@ following method -;;; - -(defvar mime-view-following-method-alist nil - "Alist of major-mode vs. following-method of mime-view.") - -(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 - (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) - )))) - - -;;; @ buffer setup -;;; - -(defun mime-view-setup-buffers (&optional ctl encoding ibuf obuf) - (if ibuf - (progn - (get-buffer ibuf) - (set-buffer ibuf) - )) - (or mime-view-redisplay - (setq mime-raw-content-info (mime-parse-message ctl encoding)) - ) - (let* ((cinfo mime-raw-content-info) - (pcl (mime/flatten-content-info cinfo)) - (the-buf (current-buffer)) - (mode major-mode) - ) - (or obuf - (setq obuf (concat "*Preview-" (buffer-name the-buf) "*"))) - (set-buffer (get-buffer-create obuf)) - (let ((inhibit-read-only t)) - ;;(setq buffer-read-only nil) - (widen) - (erase-buffer) - (setq mime-raw-buffer the-buf) - (setq mime-view-original-major-mode mode) - (setq major-mode 'mime-view-mode) - (setq mode-name "MIME-View") - (while pcl - (mime-view-display-entity (car pcl) cinfo the-buf obuf) - (setq pcl (cdr pcl)) - ) - (set-buffer-modified-p nil) - ) - (setq buffer-read-only t) - (set-buffer the-buf) - ) - (setq mime-view-buffer obuf) - ) - -(defun mime-view-display-entity (content cinfo ibuf obuf) - "Display entity from content-info CONTENT." - (let* ((beg (mime-entity-info-point-min content)) - (end (mime-entity-info-point-max content)) - (media-type (mime-entity-info-media-type content)) - (media-subtype (mime-entity-info-media-subtype content)) - (ctype (if media-type - (if media-subtype - (format "%s/%s" media-type media-subtype) - (symbol-name media-type) - ))) - (params (mime-entity-info-parameters content)) - (encoding (mime-entity-info-encoding content)) - (rcnum (mime-entity-info-rnum 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) - (mime-view-entity-button-function - rcnum cinfo media-type media-subtype params subj encoding) - (if (mime-view-header-visible-p rcnum cinfo) - (mime-view-display-header beg he) - ) - (if (and (null rcnum) - (member - ctype mime-view-content-button-visible-ctype-list)) - (save-excursion - (goto-char (point-max)) - (mime-view-insert-entity-button - rcnum cinfo media-type media-subtype params subj encoding) - )) - (cond ((mime-view-body-visible-p rcnum cinfo media-type media-subtype) - (mime-view-display-body he end - rcnum cinfo ctype params subj encoding) - ) - ((and (eq media-type 'message)(eq media-subtype 'partial)) - (mime-view-insert-message/partial-button) - ) - ((and (null rcnum) - (null (mime-entity-info-children cinfo)) - ) - (goto-char (point-max)) - (mime-view-insert-entity-button - rcnum cinfo media-type media-subtype params subj encoding) - )) - (mime-view-entity-separator-function - rcnum cinfo media-type media-subtype params subj) - (setq ne (point-max)) - (widen) - (put-text-property nb ne 'mime-view-raw-buffer ibuf) - (put-text-property nb ne 'mime-view-cinfo content) - (goto-char ne) - )) - -(defun mime-view-display-header (beg end) - (save-restriction - (narrow-to-region (point)(point)) - (insert-buffer-substring mime-raw-buffer beg end) - (let ((f (cdr (assq mime-view-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-view-display-body (beg end rcnum cinfo ctype params subj encoding) - (save-restriction - (narrow-to-region (point-max)(point-max)) - (insert-buffer-substring mime-raw-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-view-insert-message/partial-button () - (save-restriction - (goto-char (point-max)) - (if (not (search-backward "\n\n" nil t)) - (insert "\n") - ) - (goto-char (point-max)) - (narrow-to-region (point-max)(point-max)) - (insert mime-view-announcement-for-message/partial) - (mime-add-button (point-min)(point-max) - (function mime-view-play-current-entity)) - )) - -(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) - "")) - - -;;; @ entity information -;;; - -(defun mime-article/point-content-number (p &optional cinfo) - (or cinfo - (setq cinfo mime-raw-content-info) - ) - (let ((b (mime-entity-info-point-min cinfo)) - (e (mime-entity-info-point-max cinfo)) - (c (mime-entity-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)))) - -(defsubst mime-article/rcnum-to-cinfo (rnum &optional cinfo) - (mime-article/cnum-to-cinfo (reverse rnum) cinfo) - ) - -(defun mime-article/cnum-to-cinfo (cn &optional cinfo) - (or cinfo - (setq cinfo mime-raw-content-info) - ) - (if (eq cn t) - cinfo - (let ((sn (car cn))) - (if (null sn) - cinfo - (let ((rc (nth sn (mime-entity-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-raw-content-info) - ) - (let ((dest (list cinfo)) - (rcl (mime-entity-info-children cinfo)) - ) - (while rcl - (setq dest (nconc dest (mime/flatten-content-info (car rcl)))) - (setq rcl (cdr rcl)) - ) - dest)) - - -;;; @@ predicate functions -;;; - -(defun mime-view-header-visible-p (rcnum cinfo) - "Return non-nil if header of current entity is visible." - (or (null rcnum) - (member (mime-entity-info-type/subtype - (mime-article/rcnum-to-cinfo (cdr rcnum) cinfo)) - mime-view-childrens-header-showing-Content-Type-list) - )) - -(defun mime-view-body-visible-p (rcnum cinfo media-type media-subtype) - (let ((ctype (if media-type - (if media-subtype - (format "%s/%s" media-type media-subtype) - (symbol-name media-type) - )))) - (and (member ctype mime-view-visible-media-type-list) - (if (and (eq media-type 'application) - (eq media-subtype 'octet-stream)) - (let ((ccinfo (mime-article/rcnum-to-cinfo rcnum cinfo))) - (member (mime-entity-info-encoding ccinfo) - '(nil "7bit" "8bit")) - ) - t)) - )) - - -;;; @ MIME viewer mode -;;; - -(defconst mime-view-menu-title "MIME-View") -(defconst mime-view-menu-list - '((up "Move to upper content" mime-view-move-to-upper) - (previous "Move to previous content" mime-view-move-to-previous) - (next "Move to next content" mime-view-move-to-next) - (scroll-down "Scroll to previous content" mime-view-scroll-down-entity) - (scroll-up "Scroll to next content" mime-view-scroll-up-entity) - (play "Play Content" mime-view-play-current-entity) - (extract "Extract Content" mime-view-extract-current-entity) - (print "Print" mime-view-print-current-entity) - (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-move-to-upper)) - (define-key mime-view-mode-map - "p" (function mime-view-move-to-previous)) - (define-key mime-view-mode-map - "n" (function mime-view-move-to-next)) - (define-key mime-view-mode-map - "\e\t" (function mime-view-move-to-previous)) - (define-key mime-view-mode-map - "\t" (function mime-view-move-to-next)) - (define-key mime-view-mode-map - " " (function mime-view-scroll-up-entity)) - (define-key mime-view-mode-map - "\M- " (function mime-view-scroll-down-entity)) - (define-key mime-view-mode-map - "\177" (function mime-view-scroll-down-entity)) - (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-current-entity)) - (define-key mime-view-mode-map - "e" (function mime-view-extract-current-entity)) - (define-key mime-view-mode-map - "\C-c\C-p" (function mime-view-print-current-entity)) - (define-key mime-view-mode-map - "a" (function mime-view-follow-current-entity)) - (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)) - (define-key mime-view-mode-map - [tab] (function mime-view-move-to-next)) - (define-key mime-view-mode-map - [delete] (function mime-view-scroll-down-entity)) - (define-key mime-view-mode-map - [backspace] (function mime-view-scroll-down-entity)) - (if (functionp default) - (cond (running-xemacs - (set-keymap-default-binding mime-view-mode-map default) - ) - (t - (setq mime-view-mode-map - (append mime-view-mode-map (list (cons t default)))) - ))) - (if mouse-button-2 - (define-key mime-view-mode-map - mouse-button-2 (function mime-button-dispatcher)) - ) - (cond (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) - )) - -(defsubst mime-maybe-hide-echo-buffer () - "Clear mime-echo buffer and delete window for it." - (let ((buf (get-buffer mime-echo-buffer-name))) - (if buf - (save-excursion - (set-buffer buf) - (erase-buffer) - (let ((win (get-buffer-window buf))) - (if win - (delete-window win) - )) - (bury-buffer buf) - )))) - -(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) - (mime-maybe-hide-echo-buffer) - (let ((ret (mime-view-setup-buffers ctl encoding ibuf obuf)) - (win-conf (current-window-configuration)) - ) - (prog1 - (switch-to-buffer ret) - (setq mime::preview/original-window-configuration win-conf) - (if mother - (progn - (setq mime-mother-buffer mother) - )) - (mime-view-define-keymap default-keymap-or-function) - (let ((point (next-single-property-change (point-min) 'mime-view-cinfo))) - (if point - (goto-char point) - (goto-char (point-min)) - (search-forward "\n\n" nil t) - )) - (run-hooks 'mime-view-mode-hook) - ))) - - -;;; @@ playing -;;; - -(autoload 'mime-view-play-current-entity "mime-play" "Play current entity." t) - -(defun mime-view-extract-current-entity () - "Extract current entity into file (maybe). -It decodes current entity to call internal or external method as -\"extract\" mode. The method is selected from variable -`mime-acting-condition'." - (interactive) - (mime-view-play-current-entity "extract") - ) - -(defun mime-view-print-current-entity () - "Print current entity (maybe). -It decodes current entity to call internal or external method as -\"print\" mode. The method is selected from variable -`mime-acting-condition'." - (interactive) - (mime-view-play-current-entity "print") - ) - - -;;; @@ following -;;; - -(defun mime-view-get-original-major-mode () - "Return major-mode of original buffer. -If a current buffer has mime-mother-buffer, return original major-mode -of the mother-buffer." - (if mime-mother-buffer - (save-excursion - (set-buffer mime-mother-buffer) - (mime-view-get-original-major-mode) - ) - mime-view-original-major-mode)) - -(defun mime-view-follow-current-entity () - "Write follow message to current entity. -It calls following-method selected from variable -`mime-view-following-method-alist'." - (interactive) - (let ((root-cinfo (get-text-property (point-min) 'mime-view-cinfo)) - cinfo) - (while (null (setq cinfo (get-text-property (point) 'mime-view-cinfo))) - (backward-char) - ) - (let* ((p-beg (previous-single-property-change (point) 'mime-view-cinfo)) - p-end - (rcnum (mime-entity-info-rnum cinfo)) - (len (length rcnum)) - ) - (cond ((null p-beg) - (setq p-beg - (if (eq (next-single-property-change (point-min) - 'mime-view-cinfo) - (point)) - (point) - (point-min))) - ) - ((eq (next-single-property-change p-beg 'mime-view-cinfo) - (point)) - (setq p-beg (point)) - )) - (setq p-end (next-single-property-change p-beg 'mime-view-cinfo)) - (cond ((null p-end) - (setq p-end (point-max)) - ) - ((null rcnum) - (setq p-end (point-max)) - ) - (t - (save-excursion - (goto-char p-end) - (catch 'tag - (let (e) - (while (setq e - (next-single-property-change - (point) 'mime-view-cinfo)) - (goto-char e) - (let ((rc (mime-entity-info-rnum - (get-text-property (point) - 'mime-view-cinfo)))) - (or (equal rcnum (nthcdr (- (length rc) len) rc)) - (throw 'tag nil) - )) - (setq p-end e) - )) - (setq p-end (point-max)) - )) - )) - (let* ((mode (mime-view-get-original-major-mode)) - (new-name (format "%s-%s" (buffer-name) (reverse rcnum))) - new-buf - (the-buf (current-buffer)) - (a-buf mime-raw-buffer) - fields) - (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-entity-info-rnum 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-entity-info-point-min ci) - (mime-entity-info-point-max ci) - ) - (std11-header-string-except - (concat "^" - (apply (function regexp-or) fields) - ":") "")))) - (if (and - (eq (mime-entity-info-media-type ci) 'message) - (eq (mime-entity-info-media-subtype ci) '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-mother-buffer) - (set-buffer mime-raw-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)) - )) - )))) - - -;;; @@ X-Face -;;; - -(defun mime-view-display-x-face () - (interactive) - (save-window-excursion - (set-buffer mime-raw-buffer) - (mime-view-x-face-function) - )) - - -;;; @@ moving -;;; - -(defun mime-view-move-to-upper () - "Move to upper entity. -If there is no upper entity, call function `mime-view-quit'." - (interactive) - (let (cinfo) - (while (null (setq cinfo (get-text-property (point) 'mime-view-cinfo))) - (backward-char) - ) - (let ((r (mime-article/rcnum-to-cinfo - (cdr (mime-entity-info-rnum cinfo)) - (get-text-property 1 'mime-view-cinfo))) - point) - (catch 'tag - (while (setq point (previous-single-property-change - (point) 'mime-view-cinfo)) - (goto-char point) - (if (eq r (get-text-property (point) 'mime-view-cinfo)) - (throw 'tag t) - ) - ) - (mime-view-quit) - )))) - -(defun mime-view-move-to-previous () - "Move to previous entity. -If there is no previous entity, it calls function registered in -variable `mime-view-over-to-previous-method-alist'." - (interactive) - (while (null (get-text-property (point) 'mime-view-cinfo)) - (backward-char) - ) - (let ((point (previous-single-property-change (point) 'mime-view-cinfo))) - (if point - (goto-char point) - (let ((f (assq mime-view-original-major-mode - mime-view-over-to-previous-method-alist))) - (if f - (funcall (cdr f)) - )) - ))) - -(defun mime-view-move-to-next () - "Move to next entity. -If there is no previous entity, it calls function registered in -variable `mime-view-over-to-next-method-alist'." - (interactive) - (let ((point (next-single-property-change (point) 'mime-view-cinfo))) - (if point - (goto-char point) - (let ((f (assq mime-view-original-major-mode - mime-view-over-to-next-method-alist))) - (if f - (funcall (cdr f)) - )) - ))) - -(defun mime-view-scroll-up-entity (&optional h) - "Scroll up current entity. -If reached to (point-max), it calls function registered in variable -`mime-view-over-to-next-method-alist'." - (interactive) - (or h - (setq h (1- (window-height))) - ) - (if (= (point) (point-max)) - (let ((f (assq mime-view-original-major-mode - mime-view-over-to-next-method-alist))) - (if f - (funcall (cdr f)) - )) - (let ((point - (or (next-single-property-change (point) 'mime-view-cinfo) - (point-max)))) - (forward-line h) - (if (> (point) point) - (goto-char point) - ) - ))) - -(defun mime-view-scroll-down-entity (&optional h) - "Scroll down current entity. -If reached to (point-min), it calls function registered in variable -`mime-view-over-to-previous-method-alist'." - (interactive) - (or h - (setq h (1- (window-height))) - ) - (if (= (point) (point-min)) - (let ((f (assq mime-view-original-major-mode - mime-view-over-to-previous-method-alist))) - (if f - (funcall (cdr f)) - )) - (let (point) - (save-excursion - (catch 'tag - (while (> (point) 1) - (if (setq point - (previous-single-property-change (point) - 'mime-view-cinfo)) - (throw 'tag t) - ) - (backward-char) - ) - (setq point (point-min)) - )) - (forward-line (- h)) - (if (< (point) point) - (goto-char point) - )))) - -(defun mime-view-next-line-content () - (interactive) - (mime-view-scroll-up-entity 1) - ) - -(defun mime-view-previous-line-content () - (interactive) - (mime-view-scroll-down-entity 1) - ) - - -;;; @@ quitting -;;; - -(defun mime-view-quit () - "Quit from MIME-View buffer. -It calls function registered in variable -`mime-view-quitting-method-alist'." - (interactive) - (let ((r (assq mime-view-original-major-mode - mime-view-quitting-method-alist))) - (if r - (funcall (cdr r)) - ))) - -(defun mime-view-show-summary () - "Show summary. -It calls function registered in variable -`mime-view-show-summary-method'." - (interactive) - (let ((r (assq mime-view-original-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 diff --git a/semi-setup.el b/semi-setup.el deleted file mode 100644 index f095424..0000000 --- a/semi-setup.el +++ /dev/null @@ -1,130 +0,0 @@ -;;; semi-setup.el --- setup file for MIME-View. - -;; Copyright (C) 1994,1995,1996,1997,1998 Free Software Foundation, Inc. - -;; Author: MORIOKA Tomohiko -;; Keywords: mail, news, MIME, multimedia, multilingual, encoded-word - -;; This file is part of SEMI (Setting for Emacs MIME Interfaces). - -;; This program is free software; you can redistribute it and/or -;; modify it under the terms of the GNU General Public License as -;; published by the Free Software Foundation; either version 2, or (at -;; your option) any later version. - -;; This program is distributed in the hope that it will be useful, but -;; WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Code: - -(require 'mime-def) -(require 'path-util) - - -;; 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 ((keymap (current-local-map))) - (if keymap - (let ((key - (or (cdr (assq major-mode mime-setup-signature-key-alist)) - mime-setup-default-signature-key))) - (define-key keymap key (function insert-signature)) - )))) - -(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 diff --git a/signature.el b/signature.el deleted file mode 100644 index f06f53c..0000000 --- a/signature.el +++ /dev/null @@ -1,159 +0,0 @@ -;;; signature.el --- a signature utility for GNU Emacs - -;; Copyright (C) 1994,1995,1996,1997 Free Software Foundation, Inc. - -;; Author: MORIOKA Tomohiko -;; OKABE Yasuo -;; Shuhei KOBAYASHI -;; Maintainer: Shuhei KOBAYASHI -;; Created: 1994/7/11 -;; Version: $Id: signature.el,v 7.16 1997/09/24 23:17:38 shuhei-k Exp $ -;; Keywords: mail, news, signature - -;; This file is part of SEMI (SEMI is Emacs MIME Interfaces). - -;; This program is free software; you can redistribute it and/or -;; modify it under the terms of the GNU General Public License as -;; published by the Free Software Foundation; either version 2, or (at -;; your option) any later version. - -;; This program is distributed in the hope that it will be useful, but -;; WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with this program; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Code: - -(require 'std11) - - -;;; @ valiables -;;; - -(defvar signature-insert-at-eof nil - "*If non-nil, insert signature at the end of file.") - -(defvar signature-delete-blank-lines-at-eof nil - "*If non-nil, signature-insert-at-eof deletes blank lines at the end -of file.") - -(defvar signature-load-hook nil - "*List of functions called after signature.el is loaded.") - -(defvar signature-separator "-- \n" - "*String to separate contents and signature. -It is inserted when signature is inserted at end of file.") - -(defvar signature-file-name "~/.signature" - "*Name of file containing the user's signature.") - -(defvar signature-file-alist nil - "*Alist of the form: - (((FIELD . PATTERN) . FILENAME) - ...) -PATTERN is a string or list of string. If PATTERN matches the contents of -FIELD, the contents of FILENAME is inserted.") - -(defvar signature-file-prefix nil - "*String containing optional prefix for the signature file names") - -(defvar signature-insert-hook nil - "*List of functions called before inserting a signature.") - -(defvar signature-use-bbdb nil - "*If non-nil, Register sigtype to BBDB.") - -(autoload 'signature/get-sigtype-from-bbdb "mime-bbdb") - -(defun signature/get-sigtype-interactively (&optional default) - (read-file-name "Insert your signature: " - (or default (concat signature-file-name "-")) - (or default signature-file-name) - nil)) - -(defun signature/get-signature-file-name () - (save-excursion - (save-restriction - (narrow-to-region - (goto-char (point-min)) - (if (re-search-forward - (concat "^" (regexp-quote mail-header-separator) "$") - nil t) - (match-beginning 0) - (point-max) - )) - (catch 'found - (let ((alist signature-file-alist) cell field value) - (while alist - (setq cell (car alist) - field (std11-field-body (car (car cell))) - value (cdr (car cell))) - (cond ((functionp value) - (let ((name (apply value field (cdr cell)))) - (if name - (throw 'found - (concat signature-file-prefix name)) - ))) - ((stringp field) - (cond ((consp value) - (while value - (if (string-match (car value) field) - (throw 'found - (concat - signature-file-prefix (cdr cell))) - (setq value (cdr value)) - ))) - ((stringp value) - (if (string-match value field) - (throw 'found - (concat - signature-file-prefix (cdr cell))) - ))))) - (setq alist (cdr alist)) - )) - signature-file-name)))) - -(defun insert-signature (&optional arg) - "Insert the file named by signature-file-name. -It is inserted at the end of file if signature-insert-at-eof is non-nil, -and otherwise at the current point. A prefix argument enables user to -specify a file named -DISTRIBUTION interactively." - (interactive "P") - (let ((signature-file-name - (expand-file-name - (or (and signature-use-bbdb - (signature/get-sigtype-from-bbdb arg)) - (and arg - (signature/get-sigtype-interactively)) - (signature/get-signature-file-name)) - ))) - (or (file-readable-p signature-file-name) - (error "Cannot open signature file: %s" signature-file-name)) - (if signature-insert-at-eof - (progn - (goto-char (point-max)) - (or (bolp) (insert "\n")) - (if signature-delete-blank-lines-at-eof (delete-blank-lines)) - )) - (run-hooks 'signature-insert-hook) - (if (= (point)(point-max)) - (insert signature-separator) - ) - (insert-file-contents signature-file-name) - (force-mode-line-update) - signature-file-name)) - - -;;; @ end -;;; - -(provide 'signature) - -(run-hooks 'signature-load-hook) - -;;; signature.el ends here