From: tomo Date: Fri, 14 Mar 1997 08:46:51 +0000 (+0000) Subject: This commit was manufactured by cvs2svn to create branch 'unlabeled-0.11.2'. X-Git-Url: http://git.chise.org/cgi-bin/gitweb.cgi?a=commitdiff_plain;h=ff8cf5491823d57a0e5a5226080e97961fee5c87;p=elisp%2Fsemi.git This commit was manufactured by cvs2svn to create branch 'unlabeled-0.11.2'. --- diff --git a/Makefile b/Makefile deleted file mode 100644 index b792b23..0000000 --- a/Makefile +++ /dev/null @@ -1,94 +0,0 @@ -# -# $Id: Makefile,v 0.1 1997-03-14 07:44:00 morioka Exp $ -# - -VERSION = 0.70 - -SHELL = /bin/sh -MAKE = make -CC = gcc -CFLAGS = -O2 -RM = /bin/rm -f -CP = /bin/cp -p -EMACS = emacs - -GOMI = *.elc -FLAGS = -batch -q -no-site-file - -PREFIX = NONE -EXEC_PREFIX = - -SEMI_FILES = semi/Makefile semi/SEMI-MK semi/SEMI-CFG semi/SEMI-ELS \ - semi/*.el semi/ChangeLog - -MEL_FILES = mel/Makefile mel/MEL-MK mel/MEL-CFG mel/MEL-ELS \ - mel/*.el mel/ChangeLog - -MU_FILES = mu/Makefile mu/MU-MK mu/MU-CFG mu/MU-ELS \ - mu/*.el mu/ChangeLog - -APEL_FILES = apel/Makefile apel/APEL-MK apel/APEL-CFG apel/APEL-ELS \ - apel/*.el apel/ChangeLog - -BITMAP_FILES = bitmap-mule/Makefile bitmap-mule/BITMAP-MK \ - bitmap-mule/BITMAP-CFG bitmap-mule/BITMAP-ELS \ - bitmap-mule/*.el bitmap-mule/*.bdf \ - bitmap-mule/README.* bitmap-mule/ChangeLog - -EMU_FILES = emu/Makefile emu/EMU-MK emu/EMU-CFG emu/EMU-ELS \ - emu/*.el emu/ChangeLog - -SINFO_FILES = sinfo/Makefile sinfo/SINFO-MK \ - sinfo/SINFO-CFG sinfo/SINFO-ELS \ - sinfo/*.dtd sinfo/*.el sinfo/*-mapping sinfo/ChangeLog - -FILES = $(SEMI_FILES) $(MEL_FILES) $(MU_FILES) \ - $(APEL_FILES) $(BITMAP_FILES) $(EMU_FILES) $(SINFO_FILES) - -elc: - $(EMACS) $(FLAGS) -l SEMI-MK -f compile-semi $(PREFIX) $(EXEC_PREFIX) - -install-elc: elc - $(EMACS) $(FLAGS) -l SEMI-MK -f install-semi $(PREFIX) $(EXEC_PREFIX) - - -all: $(UTILS) $(DVI) elc - -tex: ol2 - cd doc; $(MAKE) tex - -dvi: ol2 - cd doc; $(MAKE) dvi - -ps: ol2 - cd doc; $(MAKE) ps - - -install: install-elc install-execs - -execs: $(UTILS) - -install-execs: - $(EMACS) $(FLAGS) -l SEMI-MK -f install-execs $(PREFIX) $(EXEC_PREFIX) - - -update-xemacs: - $(EMACS) $(FLAGS) -l SEMI-MK -f update-xemacs-source - - -clean: - -$(RM) $(GOMI) - -cd doc && $(MAKE) clean - -cd gnus && $(MAKE) clean - -cd mh-e && $(MAKE) clean - cd ../mel && $(MAKE) clean - - -tar: - cd ..; gtar cvf semi-$(VERSION).tar $(FILES) - -cd ..; mkdir semi-$(VERSION) - cp ../semi-kernel/README.?? ../semi-$(VERSION) - cp ../semi-kernel/Makefile ../semi-$(VERSION) - cd ../semi-$(VERSION); gtar xvf ../semi-$(VERSION).tar - cd ..; gtar cvzf semi-$(VERSION).tar.gz semi-$(VERSION) - cd ..; $(RM) -r semi-$(VERSION); rm semi-$(VERSION).tar diff --git a/SEMI-CFG b/SEMI-CFG deleted file mode 100644 index 1209df2..0000000 --- a/SEMI-CFG +++ /dev/null @@ -1,133 +0,0 @@ -;;; -*-Emacs-Lisp-*- -;;; -;;; $Id: SEMI-CFG,v 0.5 1997-03-12 07:49:41 morioka Exp $ -;;; - -(defvar default-load-path load-path) -(setq load-path (append - (mapcar (function - (lambda (path) - (expand-file-name path default-directory) - )) - '("." "../emu" "../apel" "../bitmap-mule" - "../mu" "../mel") - ) - load-path)) - -(require 'install) -(require 'cl) - - -;;; @ Please specify optional package directory if you use them. -;;; - -;; It is only necessary to use `add-path' if these packages are not -;; already on the standard load-path of Emacs. - -;; Function `get-latest-path' detect latest version of such package -;; under load-path directories. If you want to use a version of a -;; package instead of latest version, please specify by argument of -;; function `add-path'. - -;; Function `add-path' finds path under load-path directories. If a -;; package does not exist in load-path, please specify by absolutely -;; (`~/' is available), for example -;; (add-path "~/lib/elisp/mailcrypt-3.4") -;; or -;; (add-path "/opt/share/xmule/site-lisp/mailcrypt-3.4") - - -;;; @@ Please specify Mailcrypt path. -;;; - -;; Use latest version installed in load-path. - -(let ((path (get-latest-path "mailcrypt" 'all-paths))) - (if path - (add-path path) - )) - -;; Or please specify path. -;; (add-path "mailcrypt-3.4" 'all-paths) - - -;;; @@ Please specify BBDB path. -;;; - -(let ((path (get-latest-path "bbdb" 'all-paths))) - (if path - (add-path path) - )) - -;; Or please specify path. -;; (add-path "bbdb-1.50" 'all-paths) - - -;;; @ shell -;;; - -;; Please specify shell command path. -(setq SHELL - (find-if (function file-exists-p) - '("/bin/sh" "/usr/bin/sh") - )) - -;; Please specify shell command option. -(setq SHELLOPTION "-c") - - -;;; @ Please specify prefix of install directory. -;;; - -;; Please specify install path prefix. -;; If it is omitted, shared directory (maybe /usr/local is used). -(defvar PREFIX install-prefix) -;;(setq PREFIX "~/") - -;; Please specify install path prefix for binaries. -(defvar EXEC_PREFIX - (if (or running-emacs-18 running-xemacs) - (expand-file-name "../../.." exec-directory) - (expand-file-name "../../../.." exec-directory) - )) - -;; Please specify emu prefix [optional] -(setq EMU_PREFIX - (if (string-match "XEmacs" emacs-version) - "emu" - "")) - -;; Please specify SEMI prefix [optional] -(setq SEMI_PREFIX "semi") - - -;;; @ executables -;;; - -;; Please specify binary path. -(defvar BIN_DIR (expand-file-name "bin" EXEC_PREFIX)) - -;; Please specify binary path. (for external method scripts) -(setq METHOD_DIR (expand-file-name "share/semi" PREFIX)) - - - - -;;; @ 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 bfd030a..0000000 --- a/SEMI-ELS +++ /dev/null @@ -1,42 +0,0 @@ -;;; -*-Emacs-Lisp-*- -;;; -;;; $Id: SEMI-ELS,v 0.5 1997-03-10 13:45:35 morioka Exp $ -;;; - -(setq semi-modules-to-compile - '(signature - mime-def - eword-decode eword-encode - mime-parse mime-view mime-text mime-play mime-partial - mime-tar mime-file - mime-edit - semi-setup)) - -(setq semi-modules-not-to-compile nil) - -(mapcar (function - (lambda (cell) - (let ((c-module (car cell)) - (i-modules (cdr cell)) - ) - (if (module-installed-p c-module) - (setq semi-modules-to-compile - (nconc semi-modules-to-compile i-modules)) - (setq semi-modules-not-to-compile - (nconc semi-modules-not-to-compile i-modules)) - ) - ))) - '((mailcrypt mime-pgp mime-mc) - (bbdb mime-bbdb) - )) - -(if (or (string-match "XEmacs" emacs-version) - (featurep 'mule)) - (setq semi-modules-to-compile - (nconc semi-modules-to-compile '(mime-image))) - ) - -(setq semi-modules (append semi-modules-to-compile - semi-modules-not-to-compile)) - -;;; SEMI-ELS ends here diff --git a/SEMI-MK b/SEMI-MK deleted file mode 100644 index 2b490df..0000000 --- a/SEMI-MK +++ /dev/null @@ -1,48 +0,0 @@ -;;; -*-Emacs-Lisp-*- -;;; -;;; $Id: SEMI-MK,v 0.3 1997-03-14 07:42:44 morioka Exp $ -;;; - -(defun config-semi () - (let (prefix exec-prefix) - (setq prefix (car command-line-args-left)) - (and prefix - (not (string-equal "NONE" prefix)) - (progn - (defvar PREFIX prefix) - (setq command-line-args-left (cdr command-line-args-left)) - ) - (setq exec-prefix (car command-line-args-left)) - (progn - (defvar EXEC_PREFIX exec-prefix) - ;;(setq command-line-args-left (cdr command-line-args-left)) - ))) - (load-file "SEMI-CFG") - (load-file "SEMI-ELS") - (princ (format "PREFIX=%s\tEXEC_PREFIX=%s\n" PREFIX EXEC_PREFIX)) - ) - -(defun directory= (dir1 dir2) - (string= (file-name-as-directory dir1)(file-name-as-directory dir2)) - ) - -(defun compile-semi () - (config-semi) - (print load-path) - (compile-elisp-modules semi-modules-to-compile ".") - (compile-elisp-module 'mime-setup ".") - ) - -(defun install-semi () - (config-semi) - (princ (format "%s\n" emacs-version)) - (install-elisp-modules semi-modules "." SEMI_KERNEL_DIR) - (install-elisp-modules '(mime-setup) "." SETUP_FILE_DIR) - ) - -(defun install-execs () - (config-semi) - (install-files METHODS METHOD_SRC_DIR METHOD_DIR nil t) - ) - -;;; SEMI-MK ends here diff --git a/eword-decode.el b/eword-decode.el deleted file mode 100644 index 3fca9ed..0000000 --- a/eword-decode.el +++ /dev/null @@ -1,304 +0,0 @@ -;;; eword-decode.el --- RFC 2047 based encoded-word decoder for GNU Emacs - -;; Copyright (C) 1995,1996,1997 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 -;; Version: $Revision: 0.14 $ -;; Keywords: encoded-word, MIME, multilingual, header, mail, news - -;; This file is part of SEMI (SEMI is Emacs MIME Interfaces). - -;; This program is free software; you can redistribute it and/or -;; modify it under the terms of the GNU General Public License as -;; published by the Free Software Foundation; either version 2, or (at -;; your option) any later version. - -;; This program is distributed in the hope that it will be useful, but -;; WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Code: - -(require 'std11) -(require 'mel) -(require 'mime-def) - - -;;; @ version -;;; - -(defconst eword-decode-RCS-ID - "$Id: eword-decode.el,v 0.14 1997-02-27 08:56:45 tmorioka Exp $") -(defconst eword-decode-version (get-version-string eword-decode-RCS-ID)) - - -;;; @ MIME encoded-word definition -;;; - -(defconst eword-encoded-text-regexp "[!->@-~]+") -(defconst eword-encoded-word-regexp - (concat (regexp-quote "=?") - "\\(" - mime-charset-regexp - "\\)" - (regexp-quote "?") - "\\(B\\|Q\\)" - (regexp-quote "?") - "\\(" - eword-encoded-text-regexp - "\\)" - (regexp-quote "?="))) - - -;;; @@ Base64 -;;; - -(defconst base64-token-regexp "[A-Za-z0-9+/]") -(defconst base64-token-padding-regexp "[A-Za-z0-9+/=]") - -(defconst eword-B-encoded-text-regexp - (concat "\\(\\(" - base64-token-regexp - base64-token-regexp - base64-token-regexp - base64-token-regexp - "\\)*" - base64-token-regexp - base64-token-regexp - base64-token-padding-regexp - base64-token-padding-regexp - "\\)")) - -;; (defconst eword-B-encoding-and-encoded-text-regexp -;; (concat "\\(B\\)\\?" eword-B-encoded-text-regexp)) - - -;;; @@ Quoted-Printable -;;; - -(defconst quoted-printable-hex-chars "0123456789ABCDEF") -(defconst quoted-printable-octet-regexp - (concat "=[" quoted-printable-hex-chars - "][" quoted-printable-hex-chars "]")) - -(defconst eword-Q-encoded-text-regexp - (concat "\\([^=?]\\|" quoted-printable-octet-regexp "\\)+")) -;; (defconst eword-Q-encoding-and-encoded-text-regexp -;; (concat "\\(Q\\)\\?" eword-Q-encoded-text-regexp)) - - -;;; @ for string -;;; - -(defun eword-decode-string (string &optional must-unfold) - "Decode MIME encoded-words in STRING. - -STRING is unfolded before decoding. - -If an encoded-word is broken or your emacs implementation can not -decode the charset included in it, it is not decoded. - -If MUST-UNFOLD is non-nil, it unfolds and eliminates line-breaks even -if there are in decoded encoded-words (generated by bad manner MUA -such as a version of Net$cape)." - (setq string (std11-unfold-string string)) - (let ((dest "")(ew nil) - beg end) - (while (and (string-match eword-encoded-word-regexp string) - (setq beg (match-beginning 0) - end (match-end 0)) - ) - (if (> beg 0) - (if (not - (and (eq ew t) - (string-match "^[ \t]+$" (substring string 0 beg)) - )) - (setq dest (concat dest (substring string 0 beg))) - ) - ) - (setq dest - (concat dest - (eword-decode-encoded-word - (substring string beg end) must-unfold) - )) - (setq string (substring string end)) - (setq ew t) - ) - (concat dest string) - )) - - -;;; @ for region -;;; - -(defun eword-decode-region (start end &optional unfolding must-unfold) - "Decode MIME encoded-words in region between START and END. - -If UNFOLDING is not nil, it unfolds before decoding. - -If MUST-UNFOLD is non-nil, it unfolds and eliminates line-breaks even -if there are in decoded encoded-words (generated by bad manner MUA -such as a version of Net$cape)." - (interactive "*r") - (save-excursion - (save-restriction - (narrow-to-region start end) - (if unfolding - (eword-decode-unfold) - ) - (goto-char (point-min)) - (while (re-search-forward (concat "\\(" eword-encoded-word-regexp "\\)" - "\\(\n?[ \t]\\)+" - "\\(" eword-encoded-word-regexp "\\)") - nil t) - (replace-match "\\1\\6") - (goto-char (point-min)) - ) - (while (re-search-forward eword-encoded-word-regexp nil t) - (insert (eword-decode-encoded-word - (prog1 - (buffer-substring (match-beginning 0) (match-end 0)) - (delete-region (match-beginning 0) (match-end 0)) - ) must-unfold)) - ) - ))) - - -;;; @ for message header -;;; - -(defun eword-decode-header (&optional separator) - "Decode MIME encoded-words in header fields. -If SEPARATOR is not nil, it is used as header separator." - (interactive "*") - (save-excursion - (save-restriction - (std11-narrow-to-header separator) - (eword-decode-region (point-min) (point-max) t) - ))) - -(defun eword-decode-unfold () - (goto-char (point-min)) - (let (field beg end) - (while (re-search-forward std11-field-head-regexp nil t) - (setq beg (match-beginning 0) - end (std11-field-end)) - (setq field (buffer-substring beg end)) - (if (string-match eword-encoded-word-regexp field) - (save-restriction - (narrow-to-region (goto-char beg) end) - (while (re-search-forward "\n\\([ \t]\\)" nil t) - (replace-match (match-string 1)) - ) - (goto-char (point-max)) - )) - ))) - - -;;; @ encoded-word decoder -;;; - -(defvar eword-warning-face nil "Face used for invalid encoded-word.") - -(defun eword-decode-encoded-word (word &optional must-unfold) - "Decode WORD if it is an encoded-word. - -If your emacs implementation can not decode the charset of WORD, it -returns WORD. Similarly the encoded-word is broken, it returns WORD. - -If MUST-UNFOLD is non-nil, it unfolds and eliminates line-breaks even -if there are in decoded encoded-word (generated by bad manner MUA such -as a version of Net$cape)." - (or (if (string-match eword-encoded-word-regexp word) - (let ((charset - (substring word (match-beginning 1) (match-end 1)) - ) - (encoding - (upcase - (substring word (match-beginning 2) (match-end 2)) - )) - (text - (substring word (match-beginning 3) (match-end 3)) - )) - (condition-case err - (eword-decode-encoded-text charset encoding text must-unfold) - (error - (and - (add-text-properties 0 (length word) - (and eword-warning-face - (list 'face eword-warning-face)) - word) - word))) - )) - word)) - - -;;; @ encoded-text decoder -;;; - -(defun eword-decode-encoded-text (charset encoding string - &optional must-unfold) - "Decode STRING as an encoded-text. - -If your emacs implementation can not decode CHARSET, it returns nil. - -If ENCODING is not \"B\" or \"Q\", it occurs error. -So you should write error-handling code if you don't want break by errors. - -If MUST-UNFOLD is non-nil, it unfolds and eliminates line-breaks even -if there are in decoded encoded-text (generated by bad manner MUA such -as a version of Net$cape)." - (let ((cs (mime-charset-to-coding-system charset))) - (if cs - (let ((dest - (cond - ((string-equal "B" encoding) - (if (and (string-match eword-B-encoded-text-regexp string) - (string-equal string (match-string 0 string))) - (base64-decode-string string) - (error "Invalid encoded-text %s" string))) - ((string-equal "Q" encoding) - (if (and (string-match eword-Q-encoded-text-regexp string) - (string-equal string (match-string 0 string))) - (q-encoding-decode-string string) - (error "Invalid encoded-text %s" string))) - (t - (error "Invalid encoding %s" encoding) - ))) - ) - (if dest - (progn - (setq dest (decode-coding-string dest cs)) - (if must-unfold - (mapconcat (function - (lambda (chr) - (cond - ((eq chr ?\n) "") - ((eq chr ?\t) " ") - (t (char-to-string chr))) - )) - (std11-unfold-string dest) - "") - dest) - )))))) - - -;;; @ end -;;; - -(provide 'eword-decode) - -;;; eword-decode.el ends here diff --git a/eword-encode.el b/eword-encode.el deleted file mode 100644 index 6449ba7..0000000 --- a/eword-encode.el +++ /dev/null @@ -1,616 +0,0 @@ -;;; eword-encode.el --- RFC 2047 based encoded-word encoder for GNU Emacs - -;; Copyright (C) 1995,1996,1997 Free Software Foundation, Inc. - -;; Author: MORIOKA Tomohiko -;; Version: $Revision: 0.14 $ -;; Keywords: encoded-word, MIME, multilingual, header, mail, news - -;; This file is part of SEMI (SEMI is Emacs MIME Interfaces). - -;; This program is free software; you can redistribute it and/or -;; modify it under the terms of the GNU General Public License as -;; published by the Free Software Foundation; either version 2, or (at -;; your option) any later version. - -;; This program is distributed in the hope that it will be useful, but -;; WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Code: - -(require 'emu) -(require 'mel) -(require 'std11) -(require 'mime-def) -(require 'cl) - - -;;; @ version -;;; - -(defconst eword-encode-RCS-ID - "$Id: eword-encode.el,v 0.14 1997-03-06 21:23:52 morioka Exp $") -(defconst eword-encode-version (get-version-string eword-encode-RCS-ID)) - - -;;; @ variables -;;; - -(defvar eword-field-encoding-method-alist - '(("X-Nsubject" . iso-2022-jp-2) - ("Newsgroups" . nil) - (t . mime) - ) - "*Alist to specify field encoding method. -Its key is field-name, value is encoding method. - -If method is `mime', this field will be encoded into MIME format. - -If method is a MIME-charset, this field will be encoded as the charset -when it must be convert into network-code. - -If method is `default-mime-charset', this field will be encoded as -variable `default-mime-charset' when it must be convert into -network-code. - -If method is nil, this field will not be encoded.") - -(defvar eword-generate-X-Nsubject nil - "*If it is not nil, X-Nsubject field is generated -when Subject field is encoded by `eword-encode-header'.") - -(defvar eword-charset-encoding-alist - '((us-ascii . nil) - (iso-8859-1 . "Q") - (iso-8859-2 . "Q") - (iso-8859-3 . "Q") - (iso-8859-4 . "Q") - (iso-8859-5 . "Q") - (koi8-r . "Q") - (iso-8859-7 . "Q") - (iso-8859-8 . "Q") - (iso-8859-9 . "Q") - (iso-2022-jp . "B") - (iso-2022-kr . "B") - (gb2312 . "B") - (cn-gb . "B") - (cn-gb-2312 . "B") - (euc-kr . "B") - (iso-2022-jp-2 . "B") - (iso-2022-int-1 . "B") - )) - - -;;; @ encoded-text encoder -;;; - -(defun tm-eword::encode-encoded-text (charset encoding string &optional mode) - (let ((text - (cond ((string= encoding "B") - (base64-encode-string string)) - ((string= encoding "Q") - (q-encoding-encode-string string mode)) - ) - )) - (if text - (concat "=?" (upcase (symbol-name charset)) "?" - encoding "?" text "?=") - ))) - - -;;; @ leading char -;;; - -(defun tm-eword::char-type (chr) - (if (or (= chr 32)(= chr ?\t)) - nil - (char-charset chr) - )) - -(defun tm-eword::parse-lc-word (str) - (let* ((chr (sref str 0)) - (lc (tm-eword::char-type chr)) - (i (char-bytes chr)) - (len (length str)) - ) - (while (and (< i len) - (setq chr (sref str i)) - (eq lc (tm-eword::char-type chr)) - ) - (setq i (+ i (char-bytes chr))) - ) - (cons (cons lc (substring str 0 i)) (substring str i)) - )) - -(defun tm-eword::split-to-lc-words (str) - (let (ret dest) - (while (and (not (string= str "")) - (setq ret (tm-eword::parse-lc-word str)) - ) - (setq dest (cons (car ret) dest)) - (setq str (cdr ret)) - ) - (reverse dest) - )) - - -;;; @ word -;;; - -(defun tm-eword::parse-word (lcwl) - (let* ((lcw (car lcwl)) - (lc (car lcw)) - ) - (if (null lc) - lcwl - (let ((lcl (list lc)) - (str (cdr lcw)) - ) - (catch 'tag - (while (setq lcwl (cdr lcwl)) - (setq lcw (car lcwl)) - (setq lc (car lcw)) - (if (null lc) - (throw 'tag nil) - ) - (if (not (memq lc lcl)) - (setq lcl (cons lc lcl)) - ) - (setq str (concat str (cdr lcw))) - )) - (cons (cons lcl str) lcwl) - )))) - -(defun tm-eword::lc-words-to-words (lcwl) - (let (ret dest) - (while (setq ret (tm-eword::parse-word lcwl)) - (setq dest (cons (car ret) dest)) - (setq lcwl (cdr ret)) - ) - (reverse dest) - )) - - -;;; @ rule -;;; - -(defmacro tm-eword::make-rword (text charset encoding type) - (` (list (, text)(, charset)(, encoding)(, type)))) -(defmacro tm-eword::rword-text (rword) - (` (car (, rword)))) -(defmacro tm-eword::rword-charset (rword) - (` (car (cdr (, rword))))) -(defmacro tm-eword::rword-encoding (rword) - (` (car (cdr (cdr (, rword)))))) -(defmacro tm-eword::rword-type (rword) - (` (car (cdr (cdr (cdr (, rword))))))) - -(defun tm-eword::find-charset-rule (charsets) - (if charsets - (let* ((charset (charsets-to-mime-charset charsets)) - (encoding (cdr (assq charset eword-charset-encoding-alist))) - ) - (list charset encoding) - ))) - -(defun tm-eword::words-to-ruled-words (wl &optional mode) - (mapcar (function - (lambda (word) - (let ((ret (tm-eword::find-charset-rule (car word)))) - (tm-eword::make-rword (cdr word) (car ret)(nth 1 ret) mode) - ))) - wl)) - -(defun tm-eword::space-process (seq) - (let (prev a ac b c cc) - (while seq - (setq b (car seq)) - (setq seq (cdr seq)) - (setq c (car seq)) - (setq cc (tm-eword::rword-charset c)) - (if (null (tm-eword::rword-charset b)) - (progn - (setq a (car prev)) - (setq ac (tm-eword::rword-charset a)) - (if (and (tm-eword::rword-encoding a) - (tm-eword::rword-encoding c)) - (cond ((eq ac cc) - (setq prev (cons - (cons (concat (car a)(car b)(car c)) - (cdr a)) - (cdr prev) - )) - (setq seq (cdr seq)) - ) - (t - (setq prev (cons - (cons (concat (car a)(car b)) - (cdr a)) - (cdr prev) - )) - )) - (setq prev (cons b prev)) - )) - (setq prev (cons b prev)) - )) - (reverse prev) - )) - -(defun tm-eword::split-string (str &optional mode) - (tm-eword::space-process - (tm-eword::words-to-ruled-words (tm-eword::lc-words-to-words - (tm-eword::split-to-lc-words str)) - mode))) - - -;;; @ length -;;; - -(defun tm-eword::encoded-word-length (rword) - (let ((string (tm-eword::rword-text rword)) - (charset (tm-eword::rword-charset rword)) - (encoding (tm-eword::rword-encoding rword)) - ret) - (setq ret - (cond ((string-equal encoding "B") - (setq string (encode-mime-charset-string string charset)) - (base64-encoded-length string) - ) - ((string-equal encoding "Q") - (setq string (encode-mime-charset-string string charset)) - (q-encoding-encoded-length string - (tm-eword::rword-type rword)) - ))) - (if ret - (cons (+ 7 (length (symbol-name charset)) ret) string) - ))) - - -;;; @ encode-string -;;; - -(defun tm-eword::encode-string-1 (column rwl) - (let* ((rword (car rwl)) - (ret (tm-eword::encoded-word-length rword)) - string len) - (if (null ret) - (cond ((and (setq string (car rword)) - (<= (setq len (+ (length string) column)) 76) - ) - (setq rwl (cdr rwl)) - ) - (t - (setq string "\n ") - (setq len 1) - )) - (cond ((and (setq len (car ret)) - (<= (+ column len) 76) - ) - (setq string - (tm-eword::encode-encoded-text - (tm-eword::rword-charset rword) - (tm-eword::rword-encoding rword) - (cdr ret) - (tm-eword::rword-type rword) - )) - (setq len (+ (length string) column)) - (setq rwl (cdr rwl)) - ) - (t - (setq string (car rword)) - (let* ((p 0) np - (str "") nstr) - (while (and (< p len) - (progn - (setq np (+ p (char-bytes (sref string p)))) - (setq nstr (substring string 0 np)) - (setq ret (tm-eword::encoded-word-length - (cons nstr (cdr rword)) - )) - (setq nstr (cdr ret)) - (setq len (+ (car ret) column)) - (<= len 76) - )) - (setq str nstr - p np)) - (if (string-equal str "") - (setq string "\n " - len 1) - (setq rwl (cons (cons (substring string p) (cdr rword)) - (cdr rwl))) - (setq string - (tm-eword::encode-encoded-text - (tm-eword::rword-charset rword) - (tm-eword::rword-encoding rword) - str - (tm-eword::rword-type rword))) - (setq len (+ (length string) column)) - ) - ))) - ) - (list string len rwl) - )) - -(defun tm-eword::encode-rwl (column rwl) - (let (ret dest ps special str ew-f pew-f) - (while rwl - (setq ew-f (nth 2 (car rwl))) - (if (and pew-f ew-f) - (setq rwl (cons '(" ") rwl) - pew-f nil) - (setq pew-f ew-f) - ) - (setq ret (tm-eword::encode-string-1 column rwl)) - (setq str (car ret)) - (if (eq (elt str 0) ?\n) - (if (eq special ?\() - (progn - (setq dest (concat dest "\n (")) - (setq ret (tm-eword::encode-string-1 2 rwl)) - (setq str (car ret)) - )) - (cond ((eq special 32) - (if (string= str "(") - (setq ps t) - (setq dest (concat dest " ")) - (setq ps nil) - )) - ((eq special ?\() - (if ps - (progn - (setq dest (concat dest " (")) - (setq ps nil) - ) - (setq dest (concat dest "(")) - ) - ))) - (cond ((string= str " ") - (setq special 32) - ) - ((string= str "(") - (setq special ?\() - ) - (t - (setq special nil) - (setq dest (concat dest str)) - )) - (setq column (nth 1 ret) - rwl (nth 2 ret)) - ) - (list dest column) - )) - -(defun tm-eword::encode-string (column str &optional mode) - (tm-eword::encode-rwl column (tm-eword::split-string str mode)) - ) - - -;;; @ converter -;;; - -(defun tm-eword::phrase-to-rwl (phrase) - (let (token type dest str) - (while phrase - (setq token (car phrase)) - (setq type (car token)) - (cond ((eq type 'quoted-string) - (setq str (concat "\"" (cdr token) "\"")) - (setq dest - (append dest - (list - (let ((ret (tm-eword::find-charset-rule - (find-non-ascii-charset-string str)))) - (tm-eword::make-rword - str (car ret)(nth 1 ret) 'phrase) - ) - ))) - ) - ((eq type 'comment) - (setq dest - (append dest - '(("(" nil nil)) - (tm-eword::words-to-ruled-words - (tm-eword::lc-words-to-words - (tm-eword::split-to-lc-words (cdr token))) - 'comment) - '((")" nil nil)) - )) - ) - (t - (setq dest (append dest - (tm-eword::words-to-ruled-words - (tm-eword::lc-words-to-words - (tm-eword::split-to-lc-words (cdr token)) - ) 'phrase))) - )) - (setq phrase (cdr phrase)) - ) - (tm-eword::space-process dest) - )) - -(defun tm-eword::phrase-route-addr-to-rwl (phrase-route-addr) - (if (eq (car phrase-route-addr) 'phrase-route-addr) - (let ((phrase (nth 1 phrase-route-addr)) - (route (nth 2 phrase-route-addr)) - dest) - (if (eq (car (car phrase)) 'spaces) - (setq phrase (cdr phrase)) - ) - (setq dest (tm-eword::phrase-to-rwl phrase)) - (if dest - (setq dest (append dest '((" " nil nil)))) - ) - (append - dest - (list (list (concat "<" (std11-addr-to-string route) ">") nil nil)) - )))) - -(defun tm-eword::addr-spec-to-rwl (addr-spec) - (if (eq (car addr-spec) 'addr-spec) - (list (list (std11-addr-to-string (cdr addr-spec)) nil nil)) - )) - -(defun tm-eword::mailbox-to-rwl (mbox) - (let ((addr (nth 1 mbox)) - (comment (nth 2 mbox)) - dest) - (setq dest (or (tm-eword::phrase-route-addr-to-rwl addr) - (tm-eword::addr-spec-to-rwl addr) - )) - (if comment - (setq dest - (append dest - '((" " nil nil) - ("(" nil nil)) - (tm-eword::split-string comment 'comment) - '((")" nil nil)) - ))) - dest)) - -(defun tm-eword::addresses-to-rwl (addresses) - (let ((dest (tm-eword::mailbox-to-rwl (car addresses)))) - (if dest - (while (setq addresses (cdr addresses)) - (setq dest (append dest - '(("," nil nil)) - '((" " nil nil)) - (tm-eword::mailbox-to-rwl (car addresses)) - )) - )) - dest)) - -(defun tm-eword::encode-address-list (column str) - (tm-eword::encode-rwl - column - (tm-eword::addresses-to-rwl (std11-parse-addresses-string str)) - )) - - -;;; @ application interfaces -;;; - -(defun eword-encode-field (str) - (setq str (std11-unfold-string str)) - (let ((ret (string-match std11-field-head-regexp str))) - (or (if ret - (let ((field-name (substring str 0 (1- (match-end 0)))) - (field-body (eliminate-top-spaces - (substring str (match-end 0)))) - fname) - (if (setq ret - (cond ((string-equal field-body "") "") - ((member (setq fname (downcase field-name)) - '("reply-to" "from" "sender" - "resent-reply-to" "resent-from" - "resent-sender" "to" "resent-to" - "cc" "resent-cc" - "bcc" "resent-bcc" "dcc") - ) - (car (tm-eword::encode-address-list - (+ (length field-name) 2) field-body)) - ) - (t - (car (tm-eword::encode-string - (+ (length field-name) 1) - field-body 'text)) - )) - ) - (concat field-name ": " ret) - ))) - (car (tm-eword::encode-string 0 str)) - ))) - -(defun eword-in-subject-p () - (let ((str (std11-field-body "Subject"))) - (if (and str (string-match eword-encoded-word-regexp str)) - str))) - -(defun eword-encode-header (&optional code-conversion) - "Encode header fields to network representation, such as MIME encoded-word. - -It refer variable `eword-field-encoding-method-alist'." - (interactive "*") - (save-excursion - (save-restriction - (std11-narrow-to-header mail-header-separator) - (goto-char (point-min)) - (let ((default-cs (mime-charset-to-coding-system default-mime-charset)) - beg end field-name) - (while (re-search-forward std11-field-head-regexp nil t) - (setq beg (match-beginning 0)) - (setq field-name (buffer-substring beg (1- (match-end 0)))) - (setq end (std11-field-end)) - (and (find-non-ascii-charset-region beg end) - (let ((ret (or (let ((fname (downcase field-name))) - (assoc-if - (function - (lambda (str) - (and (stringp str) - (string= fname (downcase str)) - ))) - eword-field-encoding-method-alist)) - (assq t eword-field-encoding-method-alist) - ))) - (if ret - (let ((method (cdr ret))) - (cond ((eq method 'mime) - (let ((field - (buffer-substring-no-properties beg end) - )) - (delete-region beg end) - (insert (eword-encode-field field)) - )) - (code-conversion - (let ((cs - (or (mime-charset-to-coding-system - method) - default-cs))) - (encode-coding-region beg end cs) - ))) - )) - )) - )) - (and eword-generate-X-Nsubject - (or (std11-field-body "X-Nsubject") - (let ((str (eword-in-subject-p))) - (if str - (progn - (setq str - (eword-decode-string - (std11-unfold-string str))) - (if code-conversion - (setq str - (encode-mime-charset-string - str - (or (cdr (assoc-if - (function - (lambda (str) - (and (stringp str) - (string= "x-nsubject" - (downcase str)) - ))) - eword-field-encoding-method-alist)) - 'iso-2022-jp-2))) - ) - (insert (concat "\nX-Nsubject: " str)) - ))))) - ))) - -(defun eword-encode-string (str &optional column mode) - (car (tm-eword::encode-rwl (or column 0) (tm-eword::split-string str mode))) - ) - - -;;; @ end -;;; - -(provide 'eword-encode) - -;;; eword-encode.el ends here diff --git a/mime-bbdb.el b/mime-bbdb.el deleted file mode 100644 index 46b9b19..0000000 --- a/mime-bbdb.el +++ /dev/null @@ -1,304 +0,0 @@ -;;; mime-bbdb.el --- SEMI shared module for BBDB - -;; Copyright (C) 1995,1996 Shuhei KOBAYASHI -;; Copyright (C) 1996 Artur Pioro -;; Copyright (C) 1997 MORIOKA Tomohiko - -;; Author: Shuhei KOBAYASHI -;; Artur Pioro -;; Maintainer: Shuhei KOBAYASHI -;; Version: $Id: mime-bbdb.el,v 0.2 1997-03-03 19:02:54 morioka Exp $ -;; Keywords: BBDB, MIME, multimedia, multilingual, mail, news - -;; This file is part of SEMI (SEMI is Emacs MIME Interfaces). - -;; This program is free software; you can redistribute it and/or -;; modify it under the terms of the GNU General Public License as -;; published by the Free Software Foundation; either version 2, or (at -;; your option) any later version. - -;; This program is distributed in the hope that it will be useful, but -;; WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Code: - -(require 'file-detect) -(require 'std11) -(require 'mime-view) - -(if (module-installed-p 'bbdb-com) - (require 'bbdb-com) - (eval-when-compile - ;; imported from bbdb-1.51 - (defmacro bbdb-pop-up-elided-display () - '(if (boundp 'bbdb-pop-up-elided-display) - bbdb-pop-up-elided-display - bbdb-elided-display)) - (defmacro bbdb-user-mail-names () - "Returns a regexp matching the address of the logged-in user" - '(or bbdb-user-mail-names - (setq bbdb-user-mail-names - (concat "\\b" (regexp-quote (user-login-name)) "\\b")))) - )) - - -;;; @ User Variables -;;; - -(defvar mime-bbdb/use-mail-extr t - "*If non-nil, `mail-extract-address-components' is used. -Otherwise `mime-bbdb/extract-address-components' overrides it.") - -(defvar mime-bbdb/auto-create-p nil - "*If t, create new BBDB records automatically. -If function, then it is called with no arguments to decide whether an -entry should be automatically creaded. - -mime-bbdb uses this variable instead of `bbdb/mail-auto-create-p' or -`bbdb/news-auto-create-p' unless other tm-MUA overrides it.") - -(defvar mime-bbdb/delete-empty-window nil - "*If non-nil, delete empty BBDB window. -All bbdb-MUAs but bbdb-gnus display BBDB window even if it is empty. -If you prefer behavior of bbdb-gnus, set this variable to t. - -For framepop users: If empty, `framepop-banish' is used instead.") - -;;; @ mail-extr -;;; - -(defun mime-bbdb/extract-address-components (str) - (let* ((ret (std11-extract-address-components str)) - (phrase (car ret)) - (address (car (cdr ret))) - (methods mime-bbdb/canonicalize-full-name-methods)) - (while (and phrase methods) - (setq phrase (funcall (car methods) phrase) - methods (cdr methods))) - (if (string= address "") (setq address nil)) - (if (string= phrase "") (setq phrase nil)) - (list phrase address) - )) - -(or mime-bbdb/use-mail-extr - (progn - (require 'mail-extr) ; for `what-domain' - (or (fboundp 'tm:mail-extract-address-components) - (fset 'tm:mail-extract-address-components - (symbol-function 'mail-extract-address-components))) - (fset 'mail-extract-address-components - (symbol-function 'mime-bbdb/extract-address-components)) - )) - - -;;; @ bbdb-extract-field-value -;;; - -(or (fboundp 'tm:bbdb-extract-field-value) - (progn - ;; (require 'bbdb-hooks) ; not provided. - ;; (or (fboundp 'bbdb-extract-field-value) ; defined as autoload - (or (fboundp 'bbdb-header-start) - (load "bbdb-hooks")) - (fset 'tm:bbdb-extract-field-value - (symbol-function 'bbdb-extract-field-value)) - (defun bbdb-extract-field-value (field) - (let ((value (tm:bbdb-extract-field-value field))) - (and value - (eword-decode-string value)))) - )) - - -;;; @ full-name canonicalization methods -;;; - -(defun mime-bbdb/canonicalize-spaces (str) - (let (dest) - (while (string-match "\\s +" str) - (setq dest (cons (substring str 0 (match-beginning 0)) dest)) - (setq str (substring str (match-end 0))) - ) - (or (string= str "") - (setq dest (cons str dest))) - (setq dest (nreverse dest)) - (mapconcat 'identity dest " ") - )) - -(defun mime-bbdb/canonicalize-dots (str) - (let (dest) - (while (string-match "\\." str) - (setq dest (cons (substring str 0 (match-end 0)) dest)) - (setq str (substring str (match-end 0))) - ) - (or (string= str "") - (setq dest (cons str dest))) - (setq dest (nreverse dest)) - (mapconcat 'identity dest " ") - )) - -(defvar mime-bbdb/canonicalize-full-name-methods - '(eword-decode-string - mime-bbdb/canonicalize-dots - mime-bbdb/canonicalize-spaces)) - - -;;; @ BBDB functions for mime-view-mode -;;; - -(defun mime-bbdb/update-record (&optional offer-to-create) - "Return the record corresponding to the current MIME previewing message. -Creating or modifying it as necessary. A record will be created if -mime-bbdb/auto-create-p is non-nil, or if OFFER-TO-CREATE is non-nil and -the user confirms the creation." - (save-excursion - (if (and mime::article/preview-buffer - (get-buffer mime::article/preview-buffer)) - (set-buffer mime::article/preview-buffer)) - (if bbdb-use-pop-up - (mime-bbdb/pop-up-bbdb-buffer offer-to-create) - (let* ((from (std11-field-body "From")) - (addr (if from - (car (cdr (mail-extract-address-components from)))))) - (if (or (null from) - (null addr) - (string-match (bbdb-user-mail-names) addr)) - (setq from (or (std11-field-body "To") from)) - ) - (if from - (bbdb-annotate-message-sender - from t - (or (bbdb-invoke-hook-for-value mime-bbdb/auto-create-p) - offer-to-create) - offer-to-create)) - )))) - -(defun mime-bbdb/annotate-sender (string) - "Add a line to the end of the Notes field of the BBDB record -corresponding to the sender of this message." - (interactive - (list (if bbdb-readonly-p - (error "The Insidious Big Brother Database is read-only.") - (read-string "Comments: ")))) - (bbdb-annotate-notes (mime-bbdb/update-record t) string)) - -(defun mime-bbdb/edit-notes (&optional arg) - "Edit the notes field or (with a prefix arg) a user-defined field -of the BBDB record corresponding to the sender of this message." - (interactive "P") - (let ((record (or (mime-bbdb/update-record t) - (error "")))) - (bbdb-display-records (list record)) - (if arg - (bbdb-record-edit-property record nil t) - (bbdb-record-edit-notes record t)))) - -(defun mime-bbdb/show-sender () - "Display the contents of the BBDB for the sender of this message. -This buffer will be in bbdb-mode, with associated keybindings." - (interactive) - (let ((record (mime-bbdb/update-record t))) - (if record - (bbdb-display-records (list record)) - (error "unperson")))) - -(defun mime-bbdb/pop-up-bbdb-buffer (&optional offer-to-create) - "Make the *BBDB* buffer be displayed along with the MIME preview window(s), -displaying the record corresponding to the sender of the current message." - (let ((framepop (eq temp-buffer-show-function 'framepop-display-buffer))) - (or framepop - (bbdb-pop-up-bbdb-buffer - (function - (lambda (w) - (let ((b (current-buffer))) - (set-buffer (window-buffer w)) - (prog1 (eq major-mode 'mime-view-mode) - (set-buffer b))))))) - (let ((bbdb-gag-messages t) - (bbdb-use-pop-up nil) - (bbdb-electric-p nil)) - (let ((record (mime-bbdb/update-record offer-to-create)) - (bbdb-elided-display (bbdb-pop-up-elided-display)) - (b (current-buffer))) - (if framepop - (if record - (bbdb-display-records (list record)) - (framepop-banish)) - (bbdb-display-records (if record (list record) nil)) - (if (and (null record) - mime-bbdb/delete-empty-window) - (delete-windows-on (get-buffer "*BBDB*")))) - (set-buffer b) - record)))) - -(defun mime-bbdb/define-keys () - (let ((mime-view-mode-map (current-local-map))) - (define-key mime-view-mode-map ";" 'mime-bbdb/edit-notes) - (define-key mime-view-mode-map ":" 'mime-bbdb/show-sender) - )) - -(add-hook 'mime-view-define-keymap-hook 'mime-bbdb/define-keys) - - -;;; @ for signature.el -;;; - -(defun signature/get-bbdb-sigtype (addr) - "Extract sigtype information from BBDB." - (let ((record (bbdb-search-simple nil addr))) - (and record - (bbdb-record-getprop record 'sigtype)) - )) - -(defun signature/set-bbdb-sigtype (sigtype addr) - "Add sigtype information to BBDB." - (let* ((bbdb-notice-hook nil) - (record (bbdb-annotate-message-sender - addr t - (bbdb-invoke-hook-for-value - bbdb/mail-auto-create-p) - t))) - (if record - (progn - (bbdb-record-putprop record 'sigtype sigtype) - (bbdb-change-record record nil)) - ))) - -(defun signature/get-sigtype-from-bbdb (&optional verbose) - (let* ((to (std11-field-body "To")) - (addr (and to - (car (cdr (mail-extract-address-components to))))) - (sigtype (signature/get-bbdb-sigtype addr)) - return - ) - (if addr - (if verbose - (progn - (setq return (signature/get-sigtype-interactively sigtype)) - (if (and (not (string-equal return sigtype)) - (y-or-n-p - (format "Register \"%s\" for <%s>? " return addr)) - ) - (signature/set-bbdb-sigtype return addr) - ) - return) - (or sigtype - (signature/get-signature-file-name)) - )) - )) - - -;;; @ end -;;; - -(provide 'mime-bbdb) - -(run-hooks 'mime-bbdb-load-hook) - -;;; end of mime-bbdb.el diff --git a/mime-def.el b/mime-def.el deleted file mode 100644 index 2e4a702..0000000 --- a/mime-def.el +++ /dev/null @@ -1,340 +0,0 @@ -;;; mime-def.el --- definition module for SEMI - -;; Copyright (C) 1995,1996,1997 Free Software Foundation, Inc. - -;; Author: MORIOKA Tomohiko -;; Version: $Id: mime-def.el,v 0.43 1997-03-10 15:16:26 morioka Exp $ -;; Keywords: definition, MIME, multimedia, mail, news - -;; This file is part of SEMI (SEMI is Emacs MIME Interfaces). - -;; This program is free software; you can redistribute it and/or -;; modify it under the terms of the GNU General Public License as -;; published by the Free Software Foundation; either version 2, or (at -;; your option) any later version. - -;; This program is distributed in the hope that it will be useful, but -;; WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Code: - -(require 'cl) -(require 'emu) - - -;;; @ variables -;;; - -(defvar mime/use-multi-frame - (and (>= emacs-major-version 19) window-system)) - -(defvar mime/find-file-function - (if mime/use-multi-frame - (function find-file-other-frame) - (function find-file) - )) - -(defvar mime/output-buffer-window-is-shared-with-bbdb t - "*If t, mime/output-buffer window is shared with BBDB window.") - - -;;; @ constants -;;; - -(defconst mime/output-buffer-name "*MIME-out*") -(defconst mime/temp-buffer-name " *MIME-temp*") - - -;;; @ definitions about MIME -;;; - -(defconst mime/tspecials "][\000-\040()<>@,\;:\\\"/?.=") -(defconst mime/token-regexp (concat "[^" mime/tspecials "]+")) -(defconst mime-charset-regexp mime/token-regexp) - -(defconst mime/content-type-subtype-regexp - (concat mime/token-regexp "/" mime/token-regexp)) - -(defconst mime/disposition-type-regexp mime/token-regexp) - - -;;; @ button -;;; - -(if running-xemacs - (require 'overlay) - ) - -(defvar mime-button-face 'bold - "Face used for content-button or URL-button of MIME-Preview buffer.") - -(defvar mime-button-mouse-face 'highlight - "Face used for MIME-preview buffer mouse highlighting.") - -(defun mime-add-button (from to func &optional data) - "Create a button between FROM and TO with callback FUNC and data DATA." - (and mime-button-face - (overlay-put (make-overlay from to) 'face mime-button-face)) - (add-text-properties from to - (nconc - (and mime-button-mouse-face - (list 'mouse-face mime-button-mouse-face)) - (list 'mime-button-callback func) - (and data (list 'mime-button-data data)) - )) - ) - -(defvar mime-button-mother-dispatcher nil) - -(defun mime-button-dispatcher (event) - "Select the button under point." - (interactive "e") - (let (buf point func data) - (save-window-excursion - (mouse-set-point event) - (setq buf (current-buffer) - point (point) - func (get-text-property (point) 'mime-button-callback) - data (get-text-property (point) 'mime-button-data) - ) - ) - (save-excursion - (set-buffer buf) - (goto-char point) - (if func - (apply func data) - (if (fboundp mime-button-mother-dispatcher) - (funcall mime-button-mother-dispatcher event) - ) - )))) - - -;;; @ PGP -;;; - -(defvar pgp-function-alist - '( - ;; for mime-pgp - (verify mc-verify "mc-toplev") - (decrypt mc-decrypt "mc-toplev") - (fetch-key mc-pgp-fetch-key "mc-pgp") - (snarf-keys mc-snarf-keys "mc-toplev") - ;; for mime-edit - (mime-sign mime-mc-pgp-sign-region "mime-mc") - (traditional-sign mc-pgp-sign-region "mc-pgp") - (encrypt mime-mc-pgp-encrypt-region "mime-mc") - (insert-key mc-insert-public-key "mc-toplev") - ) - "Alist of service names vs. corresponding functions and its filenames. -Each element looks like (SERVICE FUNCTION FILE). - -SERVICE is a symbol of PGP processing. It allows `verify', `decrypt', -`fetch-key', `snarf-keys', `mime-sign', `traditional-sign', `encrypt' -or `insert-key'. - -Function is a symbol of function to do specified SERVICE. - -FILE is string of filename which has definition of corresponding -FUNCTION.") - -(defmacro pgp-function (method) - "Return function to do service METHOD." - (` (car (cdr (assq (, method) (symbol-value 'pgp-function-alist))))) - ) - -(mapcar (function - (lambda (method) - (autoload (second method)(third method)) - )) - pgp-function-alist) - - -;;; @ method selector kernel -;;; - -(require 'atype) - -;;; @@ field unifier -;;; - -(defun field-unifier-for-mode (a b) - (let ((va (cdr a))) - (if (if (consp va) - (member (cdr b) va) - (equal va (cdr b)) - ) - (list nil b nil) - ))) - - -;;; @ rot13-47 -;;; -;; caesar-region written by phr@prep.ai.mit.edu Nov 86 -;; modified by tower@prep Nov 86 -;; gnus-caesar-region -;; Modified by umerin@flab.flab.Fujitsu.JUNET for ROT47. -(defun tm:caesar-region (&optional n) - "Caesar rotation of region by N, default 13, for decrypting netnews. -ROT47 will be performed for Japanese text in any case." - (interactive (if current-prefix-arg ; Was there a prefix arg? - (list (prefix-numeric-value current-prefix-arg)) - (list nil))) - (cond ((not (numberp n)) (setq n 13)) - (t (setq n (mod n 26)))) ;canonicalize N - (if (not (zerop n)) ; no action needed for a rot of 0 - (progn - (if (or (not (boundp 'caesar-translate-table)) - (/= (aref caesar-translate-table ?a) (+ ?a n))) - (let ((i 0) (lower "abcdefghijklmnopqrstuvwxyz") upper) - (message "Building caesar-translate-table...") - (setq caesar-translate-table (make-vector 256 0)) - (while (< i 256) - (aset caesar-translate-table i i) - (setq i (1+ i))) - (setq lower (concat lower lower) upper (upcase lower) i 0) - (while (< i 26) - (aset caesar-translate-table (+ ?a i) (aref lower (+ i n))) - (aset caesar-translate-table (+ ?A i) (aref upper (+ i n))) - (setq i (1+ i))) - ;; ROT47 for Japanese text. - ;; Thanks to ichikawa@flab.fujitsu.junet. - (setq i 161) - (let ((t1 (logior ?O 128)) - (t2 (logior ?! 128)) - (t3 (logior ?~ 128))) - (while (< i 256) - (aset caesar-translate-table i - (let ((v (aref caesar-translate-table i))) - (if (<= v t1) (if (< v t2) v (+ v 47)) - (if (<= v t3) (- v 47) v)))) - (setq i (1+ i)))) - (message "Building caesar-translate-table...done"))) - (let ((from (region-beginning)) - (to (region-end)) - (i 0) str len) - (setq str (buffer-substring from to)) - (setq len (length str)) - (while (< i len) - (aset str i (aref caesar-translate-table (aref str i))) - (setq i (1+ i))) - (goto-char from) - (delete-region from to) - (insert str))))) - - -;;; @ field -;;; - -(defsubst regexp-or (&rest args) - (concat "\\(" (mapconcat (function identity) args "\\|") "\\)")) - -(defun tm:set-fields (sym field-list &optional regexp-sym) - (or regexp-sym - (setq regexp-sym - (let ((name (symbol-name sym))) - (intern - (concat (if (string-match "\\(.*\\)-list" name) - (substring name 0 (match-end 1)) - name) - "-regexp") - ))) - ) - (set sym field-list) - (set regexp-sym - (concat "^" (apply (function regexp-or) field-list) ":")) - ) - -(defun tm:add-fields (sym field-list &optional regexp-sym) - (or regexp-sym - (setq regexp-sym - (let ((name (symbol-name sym))) - (intern - (concat (if (string-match "\\(.*\\)-list" name) - (substring name 0 (match-end 1)) - name) - "-regexp") - ))) - ) - (let ((fields (eval sym))) - (mapcar (function - (lambda (field) - (or (member field fields) - (setq fields (cons field fields)) - ) - )) - (reverse field-list) - ) - (set regexp-sym - (concat "^" (apply (function regexp-or) fields) ":")) - (set sym fields) - )) - -(defun tm:delete-fields (sym field-list &optional regexp-sym) - (or regexp-sym - (setq regexp-sym - (let ((name (symbol-name sym))) - (intern - (concat (if (string-match "\\(.*\\)-list" name) - (substring name 0 (match-end 1)) - name) - "-regexp") - ))) - ) - (let ((fields (eval sym))) - (mapcar (function - (lambda (field) - (setq fields (delete field fields)) - )) - field-list) - (set regexp-sym - (concat "^" (apply (function regexp-or) fields) ":")) - (set sym fields) - )) - - -;;; @ RCS version -;;; - -(defsubst get-version-string (id) - "Return a version-string from RCS ID." - (and (string-match ",v \\([0-9][0-9.][0-9.]+\\)" id) - (substring id (match-beginning 1)(match-end 1)) - )) - - -;;; @ Other Utility -;;; - -(defsubst eliminate-top-spaces (string) - "Eliminate top sequence of space or tab in STRING." - (if (string-match "^[ \t]+" string) - (substring string (match-end 0)) - string)) - -(defun call-after-loaded (module func &optional hook-name) - "If MODULE is provided, then FUNC is called. -Otherwise func is set to MODULE-load-hook. -If optional argument HOOK-NAME is specified, -it is used as hook to set." - (if (featurep module) - (funcall func) - (or hook-name - (setq hook-name (intern (concat (symbol-name module) "-load-hook"))) - ) - (add-hook hook-name func) - )) - - -;;; @ end -;;; - -(provide 'mime-def) - -;;; mime-def.el ends here diff --git a/mime-edit.el b/mime-edit.el deleted file mode 100644 index 3d1d164..0000000 --- a/mime-edit.el +++ /dev/null @@ -1,2610 +0,0 @@ -;;; mime-edit.el --- Simple MIME Composer for GNU Emacs - -;; Copyright (C) 1993,1994,1995,1996,1997 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 -;; Version: $Revision: 0.72 $ -;; Keywords: MIME, multimedia, multilingual, mail, news - -;; This file is part of SEMI (SEMI is Emacs MIME Interfaces). - -;; This program is free software; you can redistribute it and/or -;; modify it under the terms of the GNU General Public License as -;; published by the Free Software Foundation; either version 2, or (at -;; your option) any later version. - -;; This program is distributed in the hope that it will be useful, but -;; WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: - -;; This is an Emacs minor mode for editing Internet multimedia -;; messages formatted in MIME (RFC 2045, 2046, 2047, 2048 and 2049). -;; All messages in this mode are composed in the tagged MIME format, -;; that are described in the following examples. The messages -;; composed in the tagged MIME format are automatically translated -;; into a MIME compliant message when exiting the mode. - -;; Mule (multilingual feature of Emacs 20 and multilingual extension -;; for XEmacs 20) has a capability of handling multilingual text in -;; limited ISO-2022 manner that is based on early experiences in -;; Japanese Internet community and resulted in RFC 1468 (ISO-2022-JP -;; charset for MIME). In order to enable multilingual capability in -;; single text message in MIME, charset of multilingual text written -;; in Mule is declared as either `ISO-2022-JP-2' [RFC 1554]. Mule is -;; required for reading the such messages. - -;; This MIME composer can work with Mail mode, mh-e letter Mode, and -;; News mode. First of all, you need the following autoload -;; definition to load mime-edit-mode automatically: -;; -;; (autoload 'turn-on-mime-edit "mime-edit" -;; "Minor mode for editing MIME message." t) -;; -;; In case of Mail mode (includes VM mode), you need the following -;; hook definition: -;; -;; (add-hook 'mail-mode-hook 'turn-on-mime-edit) -;; (add-hook 'mail-send-hook 'mime-edit-maybe-translate) -;; -;; In case of MH-E, you need the following hook definition: -;; -;; (add-hook 'mh-letter-mode-hook -;; (function -;; (lambda () -;; (turn-on-mime-edit) -;; (make-local-variable 'mail-header-separator) -;; (setq mail-header-separator "--------") -;; )))) -;; (add-hook 'mh-before-send-letter-hook 'mime-edit-maybe-translate) -;; -;; In case of News mode, you need the following hook definition: -;; -;; (add-hook 'news-reply-mode-hook 'turn-on-mime-edit) -;; (add-hook 'news-inews-hook 'mime-edit-maybe-translate) -;; -;; In case of Emacs 19, it is possible to emphasize the message tags -;; using font-lock mode as follows: -;; -;; (add-hook 'mime-edit-mode-hook -;; (function -;; (lambda () -;; (font-lock-mode 1) -;; (setq font-lock-keywords (list mime-edit-tag-regexp)) -;; )))) - -;; The message tag looks like: -;; -;; --[[TYPE/SUBTYPE;PARAMETERS][ENCODING]] -;; -;; The tagged MIME message examples: -;; -;; This is a conventional plain text. It should be translated into -;; text/plain. -;; -;;--[[text/plain]] -;; This is also a plain text. But, it is explicitly specified as is. -;;--[[text/plain; charset=ISO-8859-1]] -;; This is also a plain text. But charset is specified as iso-8859-1. -;; -;; ¡Hola! Buenos días. ¿Cómo está usted? -;;--[[text/enriched]] -;;
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-RCS-ID - "$Id: mime-edit.el,v 0.72 1997-03-14 06:09:23 morioka Exp $") - -(defconst mime-edit-version (get-version-string mime-edit-RCS-ID)) - -(defconst mime-edit-version-name - (concat "SEMI MIME-Edit " mime-edit-version)) - - -;;; @ variables -;;; - -(defvar mime-ignore-preceding-spaces nil - "*Ignore preceding white spaces if non-nil.") - -(defvar mime-ignore-trailing-spaces nil - "*Ignore trailing white spaces if non-nil.") - -(defvar mime-ignore-same-text-tag t - "*Ignore preceding text content-type tag that is same with new one. -If non-nil, the text tag is not inserted unless something different.") - -(defvar mime-auto-hide-body t - "*Hide non-textual body encoded in base64 after insertion if non-nil.") - -(defvar mime-edit-voice-recorder - (function mime-edit-voice-recorder-for-sun) - "*Function to record a voice message and encode it. [mime-edit.el]") - -(defvar mime-edit-mode-hook nil - "*Hook called when enter MIME mode.") - -(defvar mime-edit-translate-hook nil - "*Hook called before translating into a MIME compliant message. -To insert a signature file automatically, call the function -`mime-edit-insert-signature' from this hook.") - -(defvar mime-edit-exit-hook nil - "*Hook called when exit MIME mode.") - -(defvar mime-content-types - '(("text" - ;; Charset parameter need not to be specified, since it is - ;; defined automatically while translation. - ("plain" - ;;("charset" "" "ISO-2022-JP" "US-ASCII" "ISO-8859-1" "ISO-8859-8") - ) - ("richtext" - ;;("charset" "" "ISO-2022-JP" "US-ASCII" "ISO-8859-1" "ISO-8859-8") - ) - ("enriched" - ;;("charset" "" "ISO-2022-JP" "US-ASCII" "ISO-8859-1" "ISO-8859-8") - ) - ("x-latex" - ;;("charset" "" "ISO-2022-JP" "US-ASCII" "ISO-8859-1" "ISO-8859-8") - ) - ("html" - ;;("charset" "" "ISO-2022-JP" "US-ASCII" "ISO-8859-1" "ISO-8859-8") - ) - ("x-rot13-47") - ) - ("message" - ("external-body" - ("access-type" - ("anon-ftp" - ("site" "ftp.jaist.ac.jp" "wnoc-fuk.wide.ad.jp" "nic.karrn.ad.jp") - ("directory" "/pub/GNU/elisp/mime") - ("name") - ("mode" "image" "ascii" "local8")) - ("ftp" - ("site") - ("directory") - ("name") - ("mode" "image" "ascii" "local8")) - ("tftp" ("site") ("name")) - ("afs" ("site") ("name")) - ("local-file" ("site") ("name")) - ("mail-server" ("server" "ftpmail@nic.karrn.ad.jp")) - )) - ("rfc822") - ) - ("application" - ("octet-stream" ("type" "" "tar" "shar")) - ("postscript") - ("x-kiss" ("x-cnf"))) - ("image" - ("gif") - ("jpeg") - ("tiff") - ("x-pic") - ("x-mag") - ("x-xwd") - ("x-xbm") - ) - ("audio" ("basic")) - ("video" ("mpeg")) - ) - "*Alist of content-type, subtype, parameters and its values.") - -(defvar mime-file-types - '(("\\.rtf$" - "text" "richtext" nil - nil - nil nil) - ("\\.html$" - "text" "html" nil - nil - nil nil) - ("\\.ps$" - "application" "postscript" nil - "quoted-printable" - "attachment" (("filename" . file)) - ) - ("\\.jpg$" - "image" "jpeg" nil - "base64" - "inline" (("filename" . file)) - ) - ("\\.gif$" - "image" "gif" nil - "base64" - "inline" (("filename" . file)) - ) - ("\\.tiff$" - "image" "tiff" nil - "base64" - "inline" (("filename" . file)) - ) - ("\\.pic$" - "image" "x-pic" nil - "base64" - "inline" (("filename" . file)) - ) - ("\\.mag$" - "image" "x-mag" nil - "base64" - "inline" (("filename" . file)) - ) - ("\\.xbm$" - "image" "x-xbm" nil - "base64" - "inline" (("filename" . file)) - ) - ("\\.xwd$" - "image" "x-xwd" nil - "base64" - "inline" (("filename" . file)) - ) - ("\\.au$" - "audio" "basic" nil - "base64" - "attachment" (("filename" . file)) - ) - ("\\.mpg$" - "video" "mpeg" nil - "base64" - "attachment" (("filename" . file)) - ) - ("\\.el$" - "application" "octet-stream" (("type" . "emacs-lisp")) - "7bit" - "attachment" (("filename" . file)) - ) - ("\\.lsp$" - "application" "octet-stream" (("type" . "common-lisp")) - "7bit" - "attachment" (("filename" . file)) - ) - ("\\.tar\\.gz$" - "application" "octet-stream" (("type" . "tar+gzip")) - "base64" - "attachment" (("filename" . file)) - ) - ("\\.tgz$" - "application" "octet-stream" (("type" . "tar+gzip")) - "base64" - "attachment" (("filename" . file)) - ) - ("\\.tar\\.Z$" - "application" "octet-stream" (("type" . "tar+compress")) - "base64" - "attachment" (("filename" . file)) - ) - ("\\.taz$" - "application" "octet-stream" (("type" . "tar+compress")) - "base64" - "attachment" (("filename" . file)) - ) - ("\\.gz$" - "application" "octet-stream" (("type" . "gzip")) - "base64" - "attachment" (("filename" . file)) - ) - ("\\.Z$" - "application" "octet-stream" (("type" . "compress")) - "base64" - "attachment" (("filename" . file)) - ) - ("\\.lzh$" - "application" "octet-stream" (("type" . "lha")) - "base64" - "attachment" (("filename" . file)) - ) - ("\\.zip$" - "application" "zip" nil - "base64" - "attachment" (("filename" . file)) - ) - ("\\.diff$" - "application" "octet-stream" (("type" . "patch")) - nil - "attachment" (("filename" . file)) - ) - ("\\.patch$" - "application" "octet-stream" (("type" . "patch")) - nil - "attachment" (("filename" . file)) - ) - ("\\.signature" - "text" "plain" nil nil) - (".*" - "application" "octet-stream" nil - nil - "attachment" (("filename" . file)) - ) - ) - "*Alist of file name, types, parameters, and default encoding. -If encoding is nil, it is determined from its contents.") - - -;;; @@ about charset, encoding and transfer-level -;;; - -(defvar mime-charset-type-list - '((us-ascii 7 nil) - (iso-8859-1 8 "quoted-printable") - (iso-8859-2 8 "quoted-printable") - (iso-8859-3 8 "quoted-printable") - (iso-8859-4 8 "quoted-printable") - (iso-8859-5 8 "quoted-printable") - (koi8-r 8 "quoted-printable") - (iso-8859-7 8 "quoted-printable") - (iso-8859-8 8 "quoted-printable") - (iso-8859-9 8 "quoted-printable") - (iso-2022-jp 7 "base64") - (iso-2022-kr 7 "base64") - (euc-kr 8 "base64") - (cn-gb2312 8 "quoted-printable") - (cn-big5 8 "base64") - (gb2312 8 "quoted-printable") - (big5 8 "base64") - (iso-2022-jp-2 7 "base64") - (iso-2022-int-1 7 "base64") - )) - -(defvar mime-transfer-level 7 - "*A number of network transfer level. It should be bigger than 7.") -(make-variable-buffer-local 'mime-transfer-level) - -(defsubst mime-encoding-name (transfer-level &optional not-omit) - (cond ((> transfer-level 8) "binary") - ((= transfer-level 8) "8bit") - (not-omit "7bit") - )) - -(defvar mime-transfer-level-string - (mime-encoding-name mime-transfer-level 'not-omit) - "A string formatted version of mime-transfer-level") -(make-variable-buffer-local 'mime-transfer-level-string) - -(defun mime-make-charset-default-encoding-alist (transfer-level) - (mapcar (function - (lambda (charset-type) - (let ((charset (car charset-type)) - (type (nth 1 charset-type)) - (encoding (nth 2 charset-type)) - ) - (if (<= type transfer-level) - (cons charset (mime-encoding-name type)) - (cons charset encoding) - )))) - mime-charset-type-list)) - -(defvar mime-edit-charset-default-encoding-alist - (mime-make-charset-default-encoding-alist mime-transfer-level)) -(make-variable-buffer-local 'mime-edit-charset-default-encoding-alist) - - -;;; @@ about message inserting -;;; - -(defvar mime-edit-yank-ignored-field-list - '("Received" "Approved" "Path" "Replied" "Status" - "Xref" "X-UIDL" "X-Filter" "X-Gnus-.*" "X-VM-.*") - "Delete these fields from original message when it is inserted -as message/rfc822 part. -Each elements are regexp of field-name. [mime-edit.el]") - -(defvar mime-edit-yank-ignored-field-regexp - (concat "^" - (apply (function regexp-or) mime-edit-yank-ignored-field-list) - ":")) - -(defvar mime-edit-message-inserter-alist nil) -(defvar mime-edit-mail-inserter-alist nil) - - -;;; @@ about message splitting -;;; - -(defvar mime-edit-split-message t - "*Split large message if it is non-nil. [mime-edit.el]") - -(defvar mime-edit-message-default-max-lines 1000 - "*Default maximum lines of a message. [mime-edit.el]") - -(defvar mime-edit-message-max-lines-alist - '((news-reply-mode . 500)) - "Alist of major-mode vs maximum lines of a message. -If it is not specified for a major-mode, -`mime-edit-message-default-max-lines' is used. [mime-edit.el]") - -(defconst mime-edit-split-ignored-field-regexp - "\\(^Content-\\|^Subject:\\|^Mime-Version:\\)") - -(defvar mime-edit-split-blind-field-regexp - "\\(^[BDFbdf]cc:\\|^cc:[ \t]*$\\)") - -(defvar mime-edit-split-message-sender-alist nil) - -(defvar mime-edit-news-reply-mode-server-running nil) - - -;;; @@ about PGP -;;; - -(defvar mime-edit-signing-type 'pgp-elkins - "*PGP signing type (pgp-elkins, pgp-kazu or nil). [mime-edit.el]") - -(defvar mime-edit-encrypting-type 'pgp-elkins - "*PGP encrypting type (pgp-elkins, pgp-kazu or nil). [mime-edit.el]") - - -;;; @@ about tag -;;; - -(defconst mime-edit-single-part-tag-regexp - "--[[][[]\\([^]]*\\)]\\([[]\\([^]]*\\)]\\|\\)]" - "*Regexp of MIME tag in the form of [[CONTENT-TYPE][ENCODING]].") - -(defconst mime-edit-quoted-single-part-tag-regexp - (concat "- " (substring mime-edit-single-part-tag-regexp 1))) - -(defconst mime-edit-multipart-beginning-regexp "--<<\\([^<>]+\\)>>-{\n") - -(defconst mime-edit-multipart-end-regexp "--}-<<\\([^<>]+\\)>>\n") - -(defconst mime-edit-beginning-tag-regexp - (regexp-or mime-edit-single-part-tag-regexp - mime-edit-multipart-beginning-regexp)) - -(defconst mime-edit-end-tag-regexp - (regexp-or mime-edit-single-part-tag-regexp - mime-edit-multipart-end-regexp)) - -(defconst mime-edit-tag-regexp - (regexp-or mime-edit-single-part-tag-regexp - mime-edit-multipart-beginning-regexp - mime-edit-multipart-end-regexp)) - -(defvar mime-tag-format "--[[%s]]" - "*Control-string making a MIME tag.") - -(defvar mime-tag-format-with-encoding "--[[%s][%s]]" - "*Control-string making a MIME tag with encoding.") - - -;;; @@ multipart boundary -;;; - -(defvar mime-multipart-boundary "Multipart" - "*Boundary of a multipart message.") - - -;;; @@ optional header fields -;;; - -(defvar mime-edit-insert-x-emacs-field t - "*If non-nil, insert X-Emacs header field.") - -(defvar mime-edit-x-emacs-value - (if running-xemacs - (concat emacs-version - (if (featurep 'mule) - " with mule" - " without mule")) - (let ((ver (if (string-match "\\.[0-9]+$" emacs-version) - (substring emacs-version 0 (match-beginning 0)) - emacs-version))) - (if (featurep 'mule) - (concat "Emacs " ver ", MULE " mule-version) - ver)))) - - -;;; @ constants -;;; - -(defconst mime-tspecials-regexp "[][()<>@,;:\\\"/?.= \t]" - "*Specify MIME tspecials. -Tspecials means any character that matches with it in header must be quoted.") - -(defconst mime-edit-mime-version-value - (concat "1.0 (generated by " mime-edit-version-name ")") - "MIME version number.") - - -;;; @ keymap and menu -;;; - -(defvar mime-edit-mode-flag nil) -(make-variable-buffer-local 'mime-edit-mode-flag) - -(defvar mime-edit-mode-map (make-sparse-keymap) - "Keymap for MIME-Edit mode commands.") - -(define-key mime-edit-mode-map - "\C-c\C-x\C-t" 'mime-edit-insert-text) -(define-key mime-edit-mode-map - "\C-c\C-x\C-i" 'mime-edit-insert-file) -(define-key mime-edit-mode-map - "\C-c\C-x\C-e" 'mime-edit-insert-external) -(define-key mime-edit-mode-map - "\C-c\C-x\C-v" 'mime-edit-insert-voice) -(define-key mime-edit-mode-map - "\C-c\C-x\C-y" 'mime-edit-insert-message) -(define-key mime-edit-mode-map - "\C-c\C-x\C-m" 'mime-edit-insert-mail) -(define-key mime-edit-mode-map - "\C-c\C-x\C-w" 'mime-edit-insert-signature) -(define-key mime-edit-mode-map - "\C-c\C-x\C-s" 'mime-edit-insert-signature) -(define-key mime-edit-mode-map - "\C-c\C-x\C-k" 'mime-edit-insert-key) -(define-key mime-edit-mode-map - "\C-c\C-xt" 'mime-edit-insert-tag) - -(define-key mime-edit-mode-map - "\C-c\C-m\C-a" 'mime-edit-enclose-alternative-region) -(define-key mime-edit-mode-map - "\C-c\C-m\C-p" 'mime-edit-enclose-parallel-region) -(define-key mime-edit-mode-map - "\C-c\C-m\C-m" 'mime-edit-enclose-mixed-region) -(define-key mime-edit-mode-map - "\C-c\C-m\C-d" 'mime-edit-enclose-digest-region) -(define-key mime-edit-mode-map - "\C-c\C-m\C-s" 'mime-edit-enclose-signed-region) -(define-key mime-edit-mode-map - "\C-c\C-m\C-e" 'mime-edit-enclose-encrypted-region) -(define-key mime-edit-mode-map - "\C-c\C-m\C-q" 'mime-edit-enclose-quote-region) - -(define-key mime-edit-mode-map - "\C-c\C-x7" 'mime-edit-set-transfer-level-7bit) -(define-key mime-edit-mode-map - "\C-c\C-x8" 'mime-edit-set-transfer-level-8bit) -(define-key mime-edit-mode-map - "\C-c\C-x/" 'mime-edit-set-split) -(define-key mime-edit-mode-map - "\C-c\C-xs" 'mime-edit-set-sign) -(define-key mime-edit-mode-map - "\C-c\C-xv" 'mime-edit-set-sign) -(define-key mime-edit-mode-map - "\C-c\C-xe" 'mime-edit-set-encrypt) -(define-key mime-edit-mode-map - "\C-c\C-xh" 'mime-edit-set-encrypt) -(define-key mime-edit-mode-map - "\C-c\C-x\C-p" 'mime-edit-preview-message) -(define-key mime-edit-mode-map - "\C-c\C-x\C-z" 'mime-edit-exit) -(define-key mime-edit-mode-map - "\C-c\C-x?" 'mime-edit-help) - -(defconst mime-edit-menu-title "MIME-Edit") - -(defconst mime-edit-menu-list - '((mime-help "Describe MIME editor mode" mime-edit-help) - (file "Insert File" mime-edit-insert-file) - (external "Insert External" mime-edit-insert-external) - (voice "Insert Voice" mime-edit-insert-voice) - (message "Insert Message" mime-edit-insert-message) - (mail "Insert Mail" mime-edit-insert-mail) - (signature "Insert Signature" mime-edit-insert-signature) - (text "Insert Text" mime-edit-insert-text) - (tag "Insert Tag" mime-edit-insert-tag) - (alternative "Enclose as alternative" - mime-edit-enclose-alternative-region) - (parallel "Enclose as parallel" mime-edit-enclose-parallel-region) - (mixed "Enclose as serial" mime-edit-enclose-mixed-region) - (digest "Enclose as digest" mime-edit-enclose-digest-region) - (signed "Enclose as signed" mime-edit-enclose-signed-region) - (encrypted "Enclose as encrypted" mime-edit-enclose-encrypted-region) - (quote "Verbatim region" mime-edit-enclose-quote-region) - (key "Insert Public Key" mime-edit-insert-key) - (split "About split" mime-edit-set-split) - (sign "About sign" mime-edit-set-sign) - (encrypt "About encryption" mime-edit-set-encrypt) - (preview "Preview Message" mime-edit-preview-message) - (level "Toggle transfer-level" mime-edit-toggle-transfer-level) - ) - "MIME-edit menubar entry.") - -(cond (running-xemacs - ;; modified by Pekka Marjola - ;; 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 () - "Insert a text message. -Charset is automatically obtained from the `charsets-mime-charset-alist'." - (interactive) - (let ((ret (mime-edit-insert-tag "text" nil nil))) - (if ret - (progn - (if (looking-at mime-edit-single-part-tag-regexp) - (progn - ;; Make a space between the following message. - (insert "\n") - (forward-char -1) - )) - (if (and (member (second ret) '("enriched" "richtext")) - (fboundp 'enriched-mode) - ) - (enriched-mode t) - (if (boundp 'enriched-mode) - (enriched-mode nil) - )))))) - -(defun mime-edit-insert-file (file &optional verbose) - "Insert a message from a file." - (interactive "fInsert file as MIME message: \nP") - (let* ((guess (mime-find-file-type file)) - (type (nth 0 guess)) - (subtype (nth 1 guess)) - (parameters (nth 2 guess)) - (encoding (nth 3 guess)) - (disposition-type (nth 4 guess)) - (disposition-params (nth 5 guess)) - ) - (if verbose - (setq type (mime-prompt-for-type type) - subtype (mime-prompt-for-subtype type subtype) - )) - (if (or (interactive-p) verbose) - (setq encoding (mime-prompt-for-encoding encoding)) - ) - (if (or (consp parameters) (stringp disposition-type)) - (let ((rest parameters) cell attribute value) - (setq parameters "") - (while rest - (setq cell (car rest)) - (setq attribute (car cell)) - (setq value (cdr cell)) - (if (eq value 'file) - (setq value (std11-wrap-as-quoted-string - (file-name-nondirectory file))) - ) - (setq parameters (concat parameters "; " attribute "=" value)) - (setq rest (cdr rest)) - ) - (if disposition-type - (progn - (setq parameters - (concat parameters "\n" - "Content-Disposition: " disposition-type)) - (setq rest disposition-params) - (while rest - (setq cell (car rest)) - (setq attribute (car cell)) - (setq value (cdr cell)) - (if (eq value 'file) - (setq value (std11-wrap-as-quoted-string - (file-name-nondirectory file))) - ) - (setq parameters - (concat parameters "; " attribute "=" value)) - (setq rest (cdr rest)) - ) - )) - )) - (mime-edit-insert-tag type subtype parameters) - (mime-edit-insert-binary-file file encoding) - )) - -(defun mime-edit-insert-external () - "Insert a reference to external body." - (interactive) - (mime-edit-insert-tag "message" "external-body" nil ";\n\t") - ;;(forward-char -1) - ;;(insert "Content-Description: " (read-string "Content-Description: ") "\n") - ;;(forward-line 1) - (let* ((pritype (mime-prompt-for-type)) - (subtype (mime-prompt-for-subtype pritype)) - (parameters (mime-prompt-for-parameters pritype subtype ";\n\t"))) - (and pritype - subtype - (insert "Content-Type: " - pritype "/" subtype (or parameters "") "\n"))) - (if (and (not (eobp)) - (not (looking-at mime-edit-single-part-tag-regexp))) - (insert (mime-make-text-tag) "\n"))) - -(defun mime-edit-insert-voice () - "Insert a voice message." - (interactive) - (let ((encoding - (completing-read - "What transfer encoding: " - mime-file-encoding-method-alist nil t nil))) - (mime-edit-insert-tag "audio" "basic" nil) - (mime-edit-define-encoding encoding) - (save-restriction - (narrow-to-region (1- (point))(point)) - (unwind-protect - (funcall mime-edit-voice-recorder encoding) - (progn - (insert "\n") - (invisible-region (point-min)(point-max)) - (goto-char (point-max)) - ))))) - -(defun mime-edit-insert-signature (&optional arg) - "Insert a signature file." - (interactive "P") - (let ((signature-insert-hook - (function - (lambda () - (apply (function mime-edit-insert-tag) - (mime-find-file-type signature-file-name)) - ))) - ) - (insert-signature arg) - )) - - -;; 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)) multipart) - (if (looking-at mime-edit-tag-regexp) - t - ;; At first, go to the end. - (cond ((re-search-forward mime-edit-beginning-tag-regexp nil t) - (goto-char (1- (match-beginning 0))) ;For multiline tag - ) - (t - (goto-char (point-max)) - )) - ;; Then search for the beginning. - (re-search-backward mime-edit-end-tag-regexp nil t) - (or (looking-at mime-edit-beginning-tag-regexp) - ;; Restore previous point. - (progn - (goto-char current) - nil - )) - ))) - -(defun mime-edit-content-beginning () - "Return the point of the beginning of content." - (save-excursion - (let ((beg (save-excursion - (beginning-of-line) (point)))) - (if (mime-edit-goto-tag) - (let ((top (point))) - (goto-char (match-end 0)) - (if (and (= beg top) - (= (following-char) ?\^M)) - (point) - (forward-line 1) - (point))) - ;; Default text/plain tag. - (goto-char (point-min)) - (re-search-forward - (concat "\n" (regexp-quote mail-header-separator) - (if mime-ignore-preceding-spaces - "[ \t\n]*\n" "\n")) nil 'move) - (point)) - ))) - -(defun mime-edit-content-end () - "Return the point of the end of content." - (save-excursion - (let ((beg (point))) - (if (mime-edit-goto-tag) - (let ((top (point))) - (goto-char (match-end 0)) - (if (invisible-p (point)) - (next-visible-point (point)) - ;; Move to the end of this text. - (if (re-search-forward mime-edit-tag-regexp nil 'move) - ;; Don't forget a multiline tag. - (goto-char (match-beginning 0)) - ) - (point) - )) - ;; Assume the message begins with text/plain. - (goto-char (mime-edit-content-beginning)) - (if (re-search-forward mime-edit-tag-regexp nil 'move) - ;; Don't forget a multiline tag. - (goto-char (match-beginning 0))) - (point)) - ))) - -(defun mime-edit-define-charset (charset) - "Set charset of current tag to CHARSET." - (save-excursion - (if (mime-edit-goto-tag) - (let ((tag (buffer-substring (match-beginning 0) (match-end 0)))) - (delete-region (match-beginning 0) (match-end 0)) - (insert - (mime-create-tag - (mime-edit-set-parameter - (mime-edit-get-contype tag) - "charset" (upcase (symbol-name charset))) - (mime-edit-get-encoding tag))) - )))) - -(defun mime-edit-define-encoding (encoding) - "Set encoding of current tag to ENCODING." - (save-excursion - (if (mime-edit-goto-tag) - (let ((tag (buffer-substring (match-beginning 0) (match-end 0)))) - (delete-region (match-beginning 0) (match-end 0)) - (insert (mime-create-tag (mime-edit-get-contype tag) encoding))) - ))) - -(defun mime-edit-choose-charset () - "Choose charset of a text following current point." - (detect-mime-charset-region (point) (mime-edit-content-end)) - ) - -(defun mime-make-text-tag (&optional subtype) - "Make a tag for a text after current point. -Subtype of text type can be specified by an optional argument SUBTYPE. -Otherwise, it is obtained from mime-content-types." - (let* ((pritype "text") - (subtype (or subtype - (car (car (cdr (assoc pritype mime-content-types))))))) - ;; Charset should be defined later. - (mime-make-tag pritype subtype))) - - -;; 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. [mime-edit.el]" - (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 (funcall (pgp-function 'mime-sign) - (point-min)(point-max) nil nil pgp-boundary) - (throw 'mime-edit-error 'pgp-error) - ) - )))) - -(defvar mime-edit-encrypt-recipient-fields-list '("To" "cc")) - -(defun mime-edit-make-encrypt-recipient-header () - (let* ((names mime-edit-encrypt-recipient-fields-list) - (values - (std11-field-bodies (cons "From" names) - nil mail-header-separator)) - (from (prog1 - (car values) - (setq values (cdr values)))) - (header (and (stringp from) - (if (string-equal from "") - "" - (format "From: %s\n" from) - ))) - recipients) - (while (and names values) - (let ((name (car names)) - (value (car values)) - ) - (and (stringp value) - (or (string-equal value "") - (progn - (setq header (concat header name ": " value "\n") - recipients (if recipients - (concat recipients " ," value) - value)) - )))) - (setq names (cdr names) - values (cdr values)) - ) - (vector from recipients header) - )) - -(defun mime-edit-encrypt-pgp-elkins (beg end boundary) - (save-excursion - (save-restriction - (let (from recipients header) - (let ((ret (mime-edit-make-encrypt-recipient-header))) - (setq from (aref ret 0) - recipients (aref ret 1) - header (aref ret 2)) - ) - (narrow-to-region beg end) - (let* ((ret - (mime-edit-translate-region beg end boundary)) - (ctype (car ret)) - (encoding (nth 1 ret)) - (parts (nth 3 ret)) - (pgp-boundary (concat "pgp-" boundary)) - ) - (goto-char beg) - (insert header) - (insert (format "Content-Type: %s\n" ctype)) - (if encoding - (insert (format "Content-Transfer-Encoding: %s\n" encoding)) - ) - (insert "\n") - (or (funcall (pgp-function 'encrypt) - recipients (point-min) (point-max) from) - (throw 'mime-edit-error 'pgp-error) - ) - (goto-char beg) - (insert (format "--[[multipart/encrypted; - boundary=\"%s\"; - protocol=\"application/pgp-encrypted\"][7bit]] ---%s -Content-Type: application/pgp-encrypted - ---%s -Content-Type: application/octet-stream -Content-Transfer-Encoding: 7bit - -" pgp-boundary pgp-boundary pgp-boundary)) - (goto-char (point-max)) - (insert (format "\n--%s--\n" pgp-boundary)) - ))))) - -(defun mime-edit-sign-pgp-kazu (beg end boundary) - (save-excursion - (save-restriction - (narrow-to-region beg end) - (let* ((ret - (mime-edit-translate-region beg end boundary)) - (ctype (car ret)) - (encoding (nth 1 ret)) - (parts (nth 3 ret)) - ) - (goto-char beg) - (insert (format "Content-Type: %s\n" ctype)) - (if encoding - (insert (format "Content-Transfer-Encoding: %s\n" encoding)) - ) - (insert "\n") - (or (as-binary-process - (funcall (pgp-function 'traditional-sign) - beg (point-max))) - (throw 'mime-edit-error 'pgp-error) - ) - (goto-char beg) - (insert - "--[[application/pgp; format=mime][7bit]]\n") - )) - )) - -(defun mime-edit-encrypt-pgp-kazu (beg end boundary) - (save-excursion - (let (from recipients header) - (let ((ret (mime-edit-make-encrypt-recipient-header))) - (setq from (aref ret 0) - recipients (aref ret 1) - header (aref ret 2)) - ) - (save-restriction - (narrow-to-region beg end) - (let* ((ret - (mime-edit-translate-region beg end boundary)) - (ctype (car ret)) - (encoding (nth 1 ret)) - (parts (nth 3 ret)) - ) - (goto-char beg) - (insert header) - (insert (format "Content-Type: %s\n" ctype)) - (if encoding - (insert (format "Content-Transfer-Encoding: %s\n" encoding)) - ) - (insert "\n") - (or (as-binary-process - (funcall (pgp-function 'encrypt) - recipients beg (point-max) nil 'maybe) - ) - (throw 'mime-edit-error 'pgp-error) - ) - (goto-char beg) - (insert - "--[[application/pgp; format=mime][7bit]]\n") - )) - ))) - -(defsubst replace-space-with-underline (str) - (mapconcat (function - (lambda (arg) - (char-to-string - (if (eq arg ?\ ) - ?_ - arg)))) str "") - ) - -(defun mime-edit-make-boundary () - (concat mime-multipart-boundary "_" - (replace-space-with-underline (current-time-string)) - )) - -(defun mime-edit-translate-body () - "Encode the tagged MIME body in current buffer in MIME compliant message." - (interactive) - (save-excursion - (let ((boundary (mime-edit-make-boundary)) - (i 1) - ret) - (while (mime-edit-process-multipart-1 - (format "%s-%d" boundary i)) - (setq i (1+ i)) - ) - (save-restriction - ;; We are interested in message body. - (let* ((beg - (progn - (goto-char (point-min)) - (re-search-forward - (concat "\n" (regexp-quote mail-header-separator) - (if mime-ignore-preceding-spaces - "[ \t\n]*\n" "\n")) nil 'move) - (point))) - (end - (progn - (goto-char (point-max)) - (and mime-ignore-trailing-spaces - (re-search-backward "[^ \t\n]\n" beg t) - (forward-char 1)) - (point)))) - (setq ret (mime-edit-translate-region - beg end - (format "%s-%d" boundary i))) - )) - (mime-edit-dequote-region (point-min)(point-max)) - (let ((contype (car ret)) ;Content-Type - (encoding (nth 1 ret)) ;Content-Transfer-Encoding - ) - ;; Insert X-Emacs field - (and mime-edit-insert-x-emacs-field - (or (mail-position-on-field "X-Emacs") - (insert mime-edit-x-emacs-value) - )) - ;; Make primary MIME headers. - (or (mail-position-on-field "Mime-Version") - (insert mime-edit-mime-version-value)) - ;; Remove old Content-Type and other fields. - (save-restriction - (goto-char (point-min)) - (search-forward (concat "\n" mail-header-separator "\n") nil t) - (narrow-to-region (point-min) (point)) - (goto-char (point-min)) - (mime-delete-field "Content-Type") - (mime-delete-field "Content-Transfer-Encoding")) - ;; Then, insert Content-Type and Content-Transfer-Encoding fields. - (mail-position-on-field "Content-Type") - (insert contype) - (if encoding - (progn - (mail-position-on-field "Content-Transfer-Encoding") - (insert encoding))) - )))) - -(defun mime-edit-translate-single-part-tag (&optional prefix) - (if (re-search-forward mime-edit-single-part-tag-regexp nil t) - (let* ((beg (match-beginning 0)) - (end (match-end 0)) - (tag (buffer-substring beg end)) - ) - (delete-region beg end) - (setq contype (mime-edit-get-contype tag)) - (setq encoding (mime-edit-get-encoding tag)) - (insert (concat prefix "--" boundary "\n")) - (save-restriction - (narrow-to-region (point)(point)) - (insert "Content-Type: " contype "\n") - (if encoding - (insert "Content-Transfer-Encoding: " encoding "\n")) - (eword-encode-header) - ) - t))) - -(defun mime-edit-translate-region (beg end &optional boundary multipart) - (or boundary - (setq boundary (mime-edit-make-boundary)) - ) - (save-excursion - (save-restriction - (narrow-to-region beg end) - (let ((tag nil) ;MIME tag - (contype nil) ;Content-Type - (encoding nil) ;Content-Transfer-Encoding - (nparts 0)) ;Number of body parts - ;; Normalize the body part by inserting appropriate message - ;; tags for every message contents. - (mime-edit-normalize-body) - ;; Counting the number of Content-Type. - (goto-char (point-min)) - (while (re-search-forward mime-edit-single-part-tag-regexp nil t) - (setq nparts (1+ nparts))) - ;; Begin translation. - (cond - ((and (<= nparts 1)(not multipart)) - ;; It's a singular message. - (goto-char (point-min)) - (while (re-search-forward - mime-edit-single-part-tag-regexp nil t) - (setq tag - (buffer-substring (match-beginning 0) (match-end 0))) - (delete-region (match-beginning 0) (1+ (match-end 0))) - (setq contype (mime-edit-get-contype tag)) - (setq encoding (mime-edit-get-encoding tag)) - )) - (t - ;; It's a multipart message. - (goto-char (point-min)) - (and (mime-edit-translate-single-part-tag) - (while (mime-edit-translate-single-part-tag "\n")) - ) - ;; Define Content-Type as "multipart/mixed". - (setq contype - (concat "multipart/mixed;\n boundary=\"" boundary "\"")) - ;; Content-Transfer-Encoding must be "7bit". - ;; The following encoding can be `nil', but is - ;; specified as is since there is no way that a user - ;; specifies it. - (setq encoding "7bit") - ;; Insert the trailer. - (goto-char (point-max)) - (insert "\n--" boundary "--\n") - )) - (list contype encoding boundary nparts) - )))) - -(defun mime-edit-normalize-body () - "Normalize the body part by inserting appropriate message tags." - ;; Insert the first MIME tags if necessary. - (goto-char (point-min)) - (if (not (looking-at mime-edit-single-part-tag-regexp)) - (insert (mime-make-text-tag) "\n")) - ;; Check each tag, and add new tag or correct it if necessary. - (goto-char (point-min)) - (while (re-search-forward mime-edit-single-part-tag-regexp nil t) - (let* ((tag (buffer-substring (match-beginning 0) (match-end 0))) - (contype (mime-edit-get-contype tag)) - (charset (mime-get-parameter contype "charset")) - (encoding (mime-edit-get-encoding tag))) - ;; Remove extra whitespaces after the tag. - (if (looking-at "[ \t]+$") - (delete-region (match-beginning 0) (match-end 0))) - (let ((beg (point)) - (end (mime-edit-content-end)) - ) - (if (= end (point-max)) - nil - (goto-char end) - (or (looking-at mime-edit-beginning-tag-regexp) - (eobp) - (insert (mime-make-text-tag) "\n") - )) - (visible-region beg end) - (goto-char beg) - ) - (cond - ((mime-test-content-type contype "message") - ;; Content-type "message" should be sent as is. - (forward-line 1) - ) - ((mime-test-content-type contype "text") - ;; Define charset for text if necessary. - (setq charset (if charset - (intern (downcase charset)) - (mime-edit-choose-charset))) - (mime-edit-define-charset charset) - (cond ((string-equal contype "text/x-rot13-47") - (save-excursion - (forward-line) - (set-mark (point)) - (goto-char (mime-edit-content-end)) - (tm:caesar-region) - )) - ((string-equal contype "text/enriched") - (save-excursion - (let ((beg (progn - (forward-line) - (point))) - (end (mime-edit-content-end)) - ) - ;; Patch for hard newlines - ;; (save-excursion - ;; (goto-char beg) - ;; (while (search-forward "\n" end t) - ;; (put-text-property (match-beginning 0) - ;; (point) - ;; 'hard t))) - ;; End patch for hard newlines - (enriched-encode beg end) - (goto-char beg) - (if (search-forward "\n\n") - (delete-region beg (match-end 0)) - ) - )))) - ;; Point is now on current tag. - ;; Define encoding and encode text if necessary. - (or encoding ;Encoding is not specified. - (let* ((encoding - (cdr - (assq charset - mime-edit-charset-default-encoding-alist) - )) - (beg (mime-edit-content-beginning)) - ) - (encode-mime-charset-region beg (mime-edit-content-end) - charset) - (mime-encode-region beg (mime-edit-content-end) encoding) - (mime-edit-define-encoding encoding) - )) - (goto-char (mime-edit-content-end)) - ) - ((null encoding) ;Encoding is not specified. - ;; Application, image, audio, video, and any other - ;; unknown content-type without encoding should be - ;; encoded. - (let* ((encoding "base64") ;Encode in BASE64 by default. - (beg (mime-edit-content-beginning)) - (end (mime-edit-content-end)) - (body (buffer-substring beg end)) - ) - (mime-encode-region beg end encoding) - (mime-edit-define-encoding encoding)) - (forward-line 1) - )) - ))) - -(defun mime-delete-field (field) - "Delete header FIELD." - (let ((regexp (format "^%s:[ \t]*" field))) - (goto-char (point-min)) - (while (re-search-forward regexp nil t) - (delete-region (match-beginning 0) - (progn (forward-line 1) (point))) - ))) - - -;;; -;;; Platform dependent functions -;;; - -;; Sun implementations - -(defun mime-edit-voice-recorder-for-sun (encoding) - "Record voice in a buffer using Sun audio device, -and insert data encoded as ENCODING. [mime-edit.el]" - (message "Start the recording on %s. Type C-g to finish the recording..." - (system-name)) - (mime-insert-encoded-file "/dev/audio" encoding) - ) - - -;;; @ Other useful commands. -;;; - -;; Message forwarding commands as content-type "message/rfc822". - -(defun mime-edit-insert-message (&optional message) - (interactive) - (let ((inserter (cdr (assq major-mode mime-edit-message-inserter-alist)))) - (if (and inserter (fboundp inserter)) - (progn - (mime-edit-insert-tag "message" "rfc822") - (funcall inserter message) - ) - (message "Sorry, I don't have message inserter for your MUA.") - ))) - -(defun mime-edit-insert-mail (&optional message) - (interactive) - (let ((inserter (cdr (assq major-mode mime-edit-mail-inserter-alist)))) - (if (and inserter (fboundp inserter)) - (progn - (mime-edit-insert-tag "message" "rfc822") - (funcall inserter message) - ) - (message "Sorry, I don't have mail inserter for your MUA.") - ))) - -(defun mime-edit-inserted-message-filter () - (save-excursion - (save-restriction - (let ((header-start (point)) - (case-fold-search t) - beg end) - ;; for Emacs 18 - ;; (if (re-search-forward "^$" (marker-position (mark-marker))) - (if (re-search-forward "^$" (mark t)) - (narrow-to-region header-start (match-beginning 0)) - ) - (goto-char header-start) - (while (and (re-search-forward - mime-edit-yank-ignored-field-regexp nil t) - (setq beg (match-beginning 0)) - (setq end (1+ (std11-field-end))) - ) - (delete-region beg end) - ) - )))) - - -;;; @ multipart enclosure -;;; - -(defun mime-edit-enclose-region (type beg end) - (save-excursion - (goto-char beg) - (let ((current (point))) - (save-restriction - (narrow-to-region beg end) - (insert (format "--<<%s>>-{\n" type)) - (goto-char (point-max)) - (insert (format "--}-<<%s>>\n" type)) - (goto-char (point-max)) - ) - (or (looking-at mime-edit-beginning-tag-regexp) - (eobp) - (insert (mime-make-text-tag) "\n") - ) - ))) - -(defun mime-edit-enclose-quote-region (beg end) - (interactive "*r") - (mime-edit-enclose-region "quote" beg end) - ) - -(defun mime-edit-enclose-mixed-region (beg end) - (interactive "*r") - (mime-edit-enclose-region "mixed" beg end) - ) - -(defun mime-edit-enclose-parallel-region (beg end) - (interactive "*r") - (mime-edit-enclose-region "parallel" beg end) - ) - -(defun mime-edit-enclose-digest-region (beg end) - (interactive "*r") - (mime-edit-enclose-region "digest" beg end) - ) - -(defun mime-edit-enclose-alternative-region (beg end) - (interactive "*r") - (mime-edit-enclose-region "alternative" beg end) - ) - -(defun mime-edit-enclose-signed-region (beg end) - (interactive "*r") - (if mime-edit-signing-type - (mime-edit-enclose-region "signed" beg end) - (message "Please specify signing type.") - )) - -(defun mime-edit-enclose-encrypted-region (beg end) - (interactive "*r") - (if mime-edit-signing-type - (mime-edit-enclose-region "encrypted" beg end) - (message "Please specify encrypting type.") - )) - -(defun mime-edit-insert-key (&optional arg) - "Insert a pgp public key." - (interactive "P") - (mime-edit-insert-tag "application" "pgp-keys") - (mime-edit-define-encoding "7bit") - (funcall (pgp-function 'insert-key)) - ) - - -;;; @ flag setting -;;; - -(defun mime-edit-set-split (arg) - (interactive - (list - (y-or-n-p "Do you want to enable split?") - )) - (setq mime-edit-split-message arg) - (if arg - (message "This message is enabled to split.") - (message "This message is not enabled to split.") - )) - -(defun mime-edit-toggle-transfer-level (&optional transfer-level) - "Toggle transfer-level is 7bit or 8bit through. - -Optional TRANSFER-LEVEL is a number of transfer-level, 7 or 8." - (interactive) - (if (numberp transfer-level) - (setq mime-transfer-level transfer-level) - (if (< mime-transfer-level 8) - (setq mime-transfer-level 8) - (setq mime-transfer-level 7) - )) - (setq mime-edit-charset-default-encoding-alist - (mime-make-charset-default-encoding-alist mime-transfer-level)) - (message (format "Current transfer-level is %d bit" - mime-transfer-level)) - (setq mime-transfer-level-string - (mime-encoding-name mime-transfer-level 'not-omit)) - (force-mode-line-update) - ) - -(defun mime-edit-set-transfer-level-7bit () - (interactive) - (mime-edit-toggle-transfer-level 7) - ) - -(defun mime-edit-set-transfer-level-8bit () - (interactive) - (mime-edit-toggle-transfer-level 8) - ) - - -;;; @ pgp -;;; - -(defun mime-edit-set-sign (arg) - (interactive - (list - (y-or-n-p "Do you want to sign?") - )) - (if arg - (if mime-edit-signing-type - (progn - (setq mime-edit-pgp-processing 'sign) - (message "This message will be signed.") - ) - (message "Please specify signing type.") - ) - (if (eq mime-edit-pgp-processing 'sign) - (setq mime-edit-pgp-processing nil) - ) - (message "This message will not be signed.") - )) - -(defun mime-edit-set-encrypt (arg) - (interactive - (list - (y-or-n-p "Do you want to encrypt?") - )) - (if arg - (if mime-edit-encrypting-type - (progn - (setq mime-edit-pgp-processing 'encrypt) - (message "This message will be encrypt.") - ) - (message "Please specify encrypting type.") - ) - (if (eq mime-edit-pgp-processing 'encrypt) - (setq mime-edit-pgp-processing nil) - ) - (message "This message will not be encrypt.") - )) - -(defvar mime-edit-pgp-processing nil) -(make-variable-buffer-local 'mime-edit-pgp-processing) - -(defun mime-edit-pgp-enclose-buffer () - (let ((beg (save-excursion - (goto-char (point-min)) - (if (search-forward (concat "\n" mail-header-separator "\n")) - (match-end 0) - ))) - (end (point-max)) - ) - (if beg - (cond ((eq mime-edit-pgp-processing 'sign) - (mime-edit-enclose-signed-region beg end) - ) - ((eq mime-edit-pgp-processing 'encrypt) - (mime-edit-enclose-encrypted-region beg end) - )) - ))) - - -;;; @ split -;;; - -(defun mime-edit-insert-partial-header - (fields subject id number total separator) - (insert fields) - (insert (format "Subject: %s (%d/%d)\n" subject number total)) - (insert (format "Mime-Version: 1.0 (split by %s)\n" - mime-edit-version-name)) - (insert (format "\ -Content-Type: message/partial; id=%s; number=%d; total=%d\n%s\n" - id number total separator)) - ) - -(defun mime-edit-split-and-send - (&optional cmd lines mime-edit-message-max-length) - (interactive) - (or lines - (setq lines - (count-lines (point-min) (point-max))) - ) - (or mime-edit-message-max-length - (setq mime-edit-message-max-length - (or (cdr (assq major-mode mime-edit-message-max-lines-alist)) - mime-edit-message-default-max-lines)) - ) - (let* ((mime-edit-draft-file-name - (or (buffer-file-name) - (make-temp-name - (expand-file-name "mime-draft" mime-temp-directory)))) - (separator mail-header-separator) - (id (concat "\"" - (replace-space-with-underline (current-time-string)) - "@" (system-name) "\""))) - (run-hooks 'mime-edit-before-split-hook) - (let ((the-buf (current-buffer)) - (copy-buf (get-buffer-create " *Original Message*")) - (header (std11-header-string-except - mime-edit-split-ignored-field-regexp separator)) - (subject (mail-fetch-field "subject")) - (total (+ (/ lines mime-edit-message-max-length) - (if (> (mod lines mime-edit-message-max-length) 0) - 1))) - (command - (or cmd - (cdr - (assq major-mode - mime-edit-split-message-sender-alist)) - (function - (lambda () - (interactive) - (error "Split sender is not specified for `%s'." major-mode) - )) - )) - (mime-edit-partial-number 1) - data) - (save-excursion - (set-buffer copy-buf) - (erase-buffer) - (insert-buffer the-buf) - (save-restriction - (if (re-search-forward - (concat "^" (regexp-quote separator) "$") nil t) - (let ((he (match-beginning 0))) - (replace-match "") - (narrow-to-region (point-min) he) - )) - (goto-char (point-min)) - (while (re-search-forward mime-edit-split-blind-field-regexp nil t) - (delete-region (match-beginning 0) - (1+ (std11-field-end))) - ))) - (while (< mime-edit-partial-number total) - (erase-buffer) - (save-excursion - (set-buffer copy-buf) - (setq data (buffer-substring - (point-min) - (progn - (goto-line mime-edit-message-max-length) - (point)) - )) - (delete-region (point-min)(point)) - ) - (mime-edit-insert-partial-header - header subject id mime-edit-partial-number total separator) - (insert data) - (save-excursion - (message (format "Sending %d/%d..." - mime-edit-partial-number total)) - (call-interactively command) - (message (format "Sending %d/%d... done" - mime-edit-partial-number total)) - ) - (setq mime-edit-partial-number - (1+ mime-edit-partial-number)) - ) - (erase-buffer) - (save-excursion - (set-buffer copy-buf) - (setq data (buffer-string)) - (erase-buffer) - ) - (mime-edit-insert-partial-header - header subject id mime-edit-partial-number total separator) - (insert data) - (save-excursion - (message (format "Sending %d/%d..." - mime-edit-partial-number total)) - (message (format "Sending %d/%d... done" - mime-edit-partial-number total)) - ) - ))) - -(defun mime-edit-maybe-split-and-send (&optional cmd) - (interactive) - (run-hooks 'mime-edit-before-send-hook) - (let ((mime-edit-message-max-length - (or (cdr (assq major-mode mime-edit-message-max-lines-alist)) - mime-edit-message-default-max-lines)) - (lines (count-lines (point-min) (point-max))) - ) - (if (and (> lines mime-edit-message-max-length) - mime-edit-split-message) - (mime-edit-split-and-send cmd lines mime-edit-message-max-length) - ))) - - -;;; @ preview message -;;; - -(defvar mime-edit-buffer nil) ; buffer local variable - -(defun mime-edit-preview-message () - "preview editing MIME message. [mime-edit.el]" - (interactive) - (let* ((str (buffer-string)) - (separator mail-header-separator) - (the-buf (current-buffer)) - (buf-name (buffer-name)) - (temp-buf-name (concat "*temp-article:" buf-name "*")) - (buf (get-buffer temp-buf-name)) - ) - (if buf - (progn - (switch-to-buffer buf) - (erase-buffer) - ) - (setq buf (get-buffer-create temp-buf-name)) - (switch-to-buffer buf) - ) - (insert str) - (setq major-mode 'mime-temp-message-mode) - (make-local-variable 'mail-header-separator) - (setq mail-header-separator separator) - (make-local-variable 'mime-edit-buffer) - (setq mime-edit-buffer the-buf) - - (run-hooks 'mime-edit-translate-hook) - (mime-edit-translate-buffer) - (goto-char (point-min)) - (if (re-search-forward - (concat "^" (regexp-quote separator) "$")) - (replace-match "") - ) - (mime-view-mode) - )) - -(defun mime-edit-quitting-method () - (let ((temp mime::preview/article-buffer) - buf) - (mime-view-kill-buffer) - (set-buffer temp) - (setq buf mime-edit-buffer) - (kill-buffer temp) - (switch-to-buffer buf) - )) - -(set-alist 'mime-view-quitting-method-alist - 'mime-temp-message-mode - (function mime-edit-quitting-method) - ) - - -;;; @ edit again -;;; - -(defvar mime-edit-again-ignored-field-regexp - (concat "^\\(" "Content-.*\\|Mime-Version" - (if mime-edit-insert-x-emacs-field "\\|X-Emacs") - "\\):") - "Regexp for deleted header fields when `mime-edit-again' is called.") - -(defun mime-edit-decode-buffer (not-decode-text) - (save-excursion - (goto-char (point-min)) - (let ((ctl (mime/Content-Type))) - (if ctl - (let ((ctype (car ctl)) - (params (cdr ctl)) - type stype) - (if (string-match "/" ctype) - (progn - (setq type (substring ctype 0 (match-beginning 0))) - (setq stype (substring ctype (match-end 0))) - ) - (setq type ctype) - ) - (cond - ((string= ctype "application/pgp-signature") - (delete-region (point-min)(point-max)) - ) - ((string= type "multipart") - (let* ((boundary (cdr (assoc "boundary" params))) - (boundary-pat - (concat "\n--" (regexp-quote boundary) "[ \t]*\n")) - ) - (re-search-forward boundary-pat nil t) - (let ((bb (match-beginning 0)) eb tag) - (setq tag (format "\n--<<%s>>-{\n" stype)) - (goto-char bb) - (insert tag) - (setq bb (+ bb (length tag))) - (re-search-forward - (concat "\n--" (regexp-quote boundary) "--[ \t]*\n") - nil t) - (setq eb (match-beginning 0)) - (replace-match (format "--}-<<%s>>\n" stype)) - (save-restriction - (narrow-to-region bb eb) - (goto-char (point-min)) - (while (re-search-forward boundary-pat nil t) - (let ((beg (match-beginning 0)) - end) - (delete-region beg (match-end 0)) - (save-excursion - (if (re-search-forward boundary-pat nil t) - (setq end (match-beginning 0)) - (setq end (point-max)) - ) - (save-restriction - (narrow-to-region beg end) - (mime-edit-decode-buffer not-decode-text) - (goto-char (point-max)) - )))) - )) - (goto-char (point-min)) - (or (= (point-min) 1) - (delete-region (point-min) - (if (search-forward "\n\n" nil t) - (match-end 0) - (point-min) - ))) - )) - (t - (let* (charset - (pstr - (let ((bytes (+ 14 (length ctype)))) - (mapconcat (function - (lambda (attr) - (if (string-equal (car attr) "charset") - (progn - (setq charset (cdr attr)) - "") - (let* ((str - (concat (car attr) - "=" (cdr attr)) - ) - (bs (length str)) - ) - (setq bytes (+ bytes bs 2)) - (if (< bytes 76) - (concat "; " str) - (setq bytes (+ bs 1)) - (concat ";\n " str) - ) - )))) - params ""))) - encoding - encoded) - (save-excursion - (if (re-search-forward - "Content-Transfer-Encoding:" nil t) - (let ((beg (match-beginning 0)) - (hbeg (match-end 0)) - (end (std11-field-end))) - (setq encoding - (eliminate-top-spaces - (std11-unfold-string - (buffer-substring hbeg end)))) - (if (or charset (string-equal type "text")) - (progn - (delete-region beg (1+ end)) - (goto-char (point-min)) - (if (search-forward "\n\n" nil t) - (progn - (mime-decode-region - (match-end 0)(point-max) encoding) - (setq encoded t - encoding nil) - ))))))) - (if (or encoded (not not-decode-text)) - (decode-mime-charset-region - (point-min)(point-max) - (or charset default-mime-charset)) - ) - (let ((he - (if (re-search-forward "^$" nil t) - (match-end 0) - (point-min) - ))) - (if (= (point-min) 1) - (progn - (goto-char he) - (insert - (concat "\n" - (mime-create-tag - (concat type "/" stype pstr) encoding))) - ) - (delete-region (point-min) he) - (insert - (mime-create-tag - (concat type "/" stype pstr) encoding)) - )) - )))) - (or not-decode-text - (decode-mime-charset-region (point-min) (point-max) - default-mime-charset) - ) - )))) - -(defun mime-edit-again (&optional not-decode-text no-separator not-turn-on) - "Convert current buffer to MIME-Edit buffer and turn on MIME-Edit mode. -Content-Type and Content-Transfer-Encoding header fields will be -converted to MIME-Edit tags." - (interactive) - (goto-char (point-min)) - (if (search-forward - (concat "\n" (regexp-quote mail-header-separator) "\n") - nil t) - (replace-match "\n\n") - ) - (mime-edit-decode-buffer not-decode-text) - (goto-char (point-min)) - (save-restriction - (std11-narrow-to-header) - (goto-char (point-min)) - (while (re-search-forward mime-edit-again-ignored-field-regexp nil t) - (delete-region (match-beginning 0) (1+ (std11-field-end))) - )) - (or no-separator - (and (re-search-forward "^$") - (replace-match mail-header-separator) - )) - (or not-turn-on - (turn-on-mime-edit) - )) - - -;;; @ end -;;; - -(provide 'mime-edit) - -(run-hooks 'mime-edit-load-hook) - -;;; mime-edit.el ends here diff --git a/mime-file.el b/mime-file.el deleted file mode 100644 index fac91e9..0000000 --- a/mime-file.el +++ /dev/null @@ -1,98 +0,0 @@ -;;; mime-file.el --- mime-view internal method for file extraction - -;; Copyright (C) 1995,1996,1997 Free Software Foundation, Inc. - -;; Author: MORIOKA Tomohiko -;; modified by Shuhei KOBAYASHI -;; Version: $Id: mime-file.el,v 0.0 1997-02-27 05:44:03 tmorioka Exp $ -;; Keywords: file, extract, MIME, multimedia, mail, news - -;; This file is part of SEMI (SEMI is Emacs MIME Interfaces). - -;; This program is free software; you can redistribute it and/or -;; modify it under the terms of the GNU General Public License as -;; published by the Free Software Foundation; either version 2, or (at -;; your option) any later version. - -;; This program is distributed in the hope that it will be useful, but -;; WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Code: - -(require 'mime-view) - -(defun mime-article/extract-file (beg end cal) - (goto-char beg) - (let* ((name - (save-restriction - (narrow-to-region beg end) - (mime-article/get-filename cal) - )) - (encoding (cdr (assq 'encoding cal))) - (filename - (if (and name (not (string-equal name ""))) - (expand-file-name name - (call-interactively - (function - (lambda (dir) - (interactive "DDirectory: ") - dir)))) - (call-interactively - (function - (lambda (file) - (interactive "FFilename: ") - (expand-file-name file)))))) - (the-buf (current-buffer)) - (tmp-buf (generate-new-buffer (file-name-nondirectory filename))) - ) - (if (file-exists-p filename) - (or (yes-or-no-p (format "File %s exists. Save anyway? " filename)) - (error ""))) - (re-search-forward "\n\n") - (append-to-buffer tmp-buf (match-end 0) end) - (save-excursion - (set-buffer tmp-buf) - (mime-decode-region (point-min)(point-max) encoding) - (let ((coding-system-for-write 'no-conversion) - jka-compr-compression-info-list ; for jka-compr - jam-zcat-filename-list ; for jam-zcat - require-final-newline) - (write-file filename) - ) - (kill-buffer tmp-buf) - ))) - - -;;; @ setup -;;; - -(set-atype 'mime/content-decoding-condition - '((type . "application/octet-stream") - (method . mime-article/extract-file) - ) - 'ignore '(method) - 'replacement) - -(set-atype 'mime/content-decoding-condition - '((mode . "extract") - (method . mime-article/extract-file) - ) - 'remove - '((method "mime-file" nil 'file 'type 'encoding 'mode 'name) - (mode . "extract")) - 'replacement) - - -;;; @ end -;;; - -(provide 'mime-file) - -;;; end of mime-file.el diff --git a/mime-image.el b/mime-image.el deleted file mode 100644 index 431633d..0000000 --- a/mime-image.el +++ /dev/null @@ -1,229 +0,0 @@ -;;; mime-image.el --- mime-view filter to display images - -;; Copyright (C) 1995,1996,1997 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 -;; Version: -;; $Id: mime-image.el,v 0.5 1997-03-14 05:59:31 morioka Exp $ - -;; Keywords: image, picture, X-Face, MIME, multimedia, mail, news - -;; This file is part of XEmacs. - -;; This program is free software; you can redistribute it and/or -;; modify it under the terms of the GNU General Public License as -;; published by the Free Software Foundation; either version 2, or (at -;; your option) any later version. - -;; This program is distributed in the hope that it will be useful, but -;; WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU XEmacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: -;; If you use this program with MULE, please install -;; etl8x16-bitmap.bdf font included in tl package. - -;;; Code: - -(require 'mime-view) -(require 'alist) - -(cond (running-xemacs - (require 'images) - - (defun-maybe image-inline-p (format) - (or (memq format image-native-formats) - (find-if (function - (lambda (native) - (image-converter-chain format native) - )) - image-native-formats) - )) - - (image-register-netpbm-utilities) - (image-register-converter 'pic 'ppm "pictoppm") - (image-register-converter 'mag 'ppm "magtoppm") - - (defun bitmap-insert-xbm-file (file) - (let ((gl (make-glyph (list (cons 'x file)))) - (e (make-extent (point) (point))) - ) - (set-extent-end-glyph e gl) - )) - - ;; - ;; X-Face - ;; - (autoload 'highlight-headers "highlight-headers") - - (defun mime-preview/x-face-function-use-highlight-headers () - (highlight-headers (point-min) (re-search-forward "^$" nil t) t) - ) - - (add-hook 'mime-view-content-header-filter-hook - 'mime-preview/x-face-function-use-highlight-headers) - - ) - ((featurep 'mule) - ;; for MULE 2.* or mule merged EMACS - (require 'x-face-mule) - - (defvar image-native-formats '(xbm)) - - (defun-maybe image-inline-p (format) - (memq format image-native-formats) - ) - - (defun-maybe image-normalize (format data) - (and (eq format 'xbm) - (vector 'xbm ':data data) - )) - - ;; - ;; X-Face - ;; - (if (file-installed-p uncompface-program exec-path) - (add-hook 'mime-view-content-header-filter-hook - 'x-face-decode-message-header) - ) - )) - -(or (fboundp 'image-invalid-glyph-p) - (defsubst image-invalid-glyph-p (glyph) - (or (null (aref glyph 0)) - (null (aref glyph 2)) - (equal (aref glyph 2) "") - )) - ) - -(defvar mime-view-image-converter-alist nil) - -(mapcar (function - (lambda (rule) - (let ((ctype (car rule)) - (format (cdr rule)) - ) - (if (image-inline-p format) - (progn - (set-alist 'mime-view-content-filter-alist - ctype - (function mime-preview/filter-for-image)) - (set-alist 'mime-view-image-converter-alist - ctype format) - (add-to-list - 'mime-view-default-showing-Content-Type-list - ctype) - ) - )))) - '(("image/jpeg" . jpeg) - ("image/gif" . gif) - ("image/tiff" . tiff) - ("image/x-tiff" . tiff) - ("image/xbm" . xbm) - ("image/x-xbm" . xbm) - ("image/x-xpixmap" . xpm) - ("image/x-pic" . pic) - ("image/x-mag" . mag) - )) - -(defvar mime-view-ps-to-gif-command "pstogif") - - -;;; @ content filter for images -;;; -;; (for XEmacs 19.12 or later) - -(defun mime-preview/filter-for-image (ctype params encoding) - (let* ((mode mime::preview/original-major-mode) - (charset (assoc "charset" params)) - (beg (point-min)) (end (point-max)) - ) - (remove-text-properties beg end '(face nil)) - (message "Decoding image...") - (mime-decode-region beg end encoding) - (let* ((minor (cdr (assoc ctype mime-view-image-converter-alist))) - (gl (image-normalize minor (buffer-string))) - e) - (delete-region (point-min)(point-max)) - (cond ((image-invalid-glyph-p gl) - (setq gl nil) - (message "Invalid glyph!") - ) - ((eq (aref gl 0) 'xbm) - (let ((xbm-file - (make-temp-name - (expand-file-name "tm" mime-temp-directory)))) - (insert (aref gl 2)) - (write-region (point-min)(point-max) xbm-file) - (message "Decoding image...") - (delete-region (point-min)(point-max)) - (bitmap-insert-xbm-file xbm-file) - (delete-file xbm-file) - ) - (message "Decoding image... done") - ) - (t - (setq gl (make-glyph gl)) - (setq e (make-extent (point) (point))) - (set-extent-end-glyph e gl) - (message "Decoding image... done") - )) - ) - (insert "\n") - )) - - -;;; @ content filter for Postscript -;;; -;; (for XEmacs 19.14 or later) - -(defun mime-preview/filter-for-application/postscript (ctype params encoding) - (let* ((mode mime::preview/original-major-mode) - (m (assq mode mime-view-code-converter-alist)) - (beg (point-min)) (end (point-max)) - (file-base - (make-temp-name (expand-file-name "tm" mime-temp-directory))) - (ps-file (concat file-base ".ps")) - (gif-file (concat file-base ".gif")) - ) - (remove-text-properties beg end '(face nil)) - (message "Decoding Postscript...") - (mime-decode-region beg end encoding) - (write-region (point-min)(point-max) ps-file) - (message "Decoding Postscript...") - (delete-region (point-min)(point-max)) - (call-process mime-view-ps-to-gif-command nil nil nil ps-file) - (set-extent-end-glyph (make-extent (point) (point)) - (make-glyph (vector 'gif :file gif-file))) - (message "Decoding Postscript... done") - (delete-file ps-file) - (delete-file gif-file) - )) - -(set-alist 'mime-view-content-filter-alist - "application/postscript" - (function mime-preview/filter-for-application/postscript)) - -(if (featurep 'gif) - (add-to-list 'mime-view-default-showing-Content-Type-list - "application/postscript") - ) - - -;;; @ end -;;; - -(provide 'mime-image) - -;;; mime-image.el ends here diff --git a/mime-mc.el b/mime-mc.el deleted file mode 100644 index 75ba129..0000000 --- a/mime-mc.el +++ /dev/null @@ -1,165 +0,0 @@ -;;; mime-mc.el --- Mailcrypt interface for SEMI - -;; Copyright (C) 1996,1997 MORIOKA Tomohiko - -;; Author: MORIOKA Tomohiko -;; Version: $Id: mime-mc.el,v 0.0 1997-02-27 08:03:48 tmorioka Exp $ -;; Keywords: PGP, security, MIME, multimedia, mail, news - -;; This file is part of SEMI (SEMI is Emacs MIME Interfaces). - -;; This program is free software; you can redistribute it and/or -;; modify it under the terms of the GNU General Public License as -;; published by the Free Software Foundation; either version 2, or (at -;; your option) any later version. - -;; This program is distributed in the hope that it will be useful, but -;; WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Code: - -(require 'mailcrypt) -(load "mc-pgp") - -(defun mime-mc-pgp-generic-parser (result) - (let ((ret (mc-pgp-generic-parser result))) - (if (consp ret) - (vector (car ret)(cdr ret)) - ))) - -(defun mime-mc-process-region - (beg end passwd program args parser &optional buffer boundary) - (let ((obuf (current-buffer)) - (process-connection-type nil) - mybuf result rgn proc) - (unwind-protect - (progn - (setq mybuf (or buffer (generate-new-buffer " *mailcrypt temp"))) - (set-buffer mybuf) - (erase-buffer) - (set-buffer obuf) - (buffer-disable-undo mybuf) - (setq proc - (apply 'start-process "*PGP*" mybuf program args)) - (if passwd - (progn - (process-send-string proc (concat passwd "\n")) - (or mc-passwd-timeout (mc-deactivate-passwd t)))) - (process-send-region proc beg end) - (process-send-eof proc) - (while (eq 'run (process-status proc)) - (accept-process-output proc 5)) - (setq result (process-exit-status proc)) - ;; Hack to force a status_notify() in Emacs 19.29 - (delete-process proc) - (set-buffer mybuf) - (goto-char (point-max)) - (if (re-search-backward "\nProcess \\*PGP.*\n\\'" nil t) - (delete-region (match-beginning 0) (match-end 0))) - (goto-char (point-min)) - ;; CRNL -> NL - (while (search-forward "\r\n" nil t) - (replace-match "\n")) - ;; Hurm. FIXME; must get better result codes. - (if (stringp result) - (error "%s exited abnormally: '%s'" program result) - (setq rgn (funcall parser result)) - ;; If the parser found something, migrate it - (if (consp rgn) - (progn - (set-buffer obuf) - (if boundary - (save-restriction - (narrow-to-region beg end) - (goto-char beg) - (insert (format "--%s\n" boundary)) - (goto-char (point-max)) - (insert (format "\n--%s -Content-Type: application/pgp-signature -Content-Transfer-Encoding: 7bit - -" boundary)) - (insert-buffer-substring mybuf (car rgn) (cdr rgn)) - (goto-char (point-max)) - (insert (format "\n--%s--\n" boundary)) - ) - (delete-region beg end) - (goto-char beg) - (insert-buffer-substring mybuf (car rgn) (cdr rgn)) - ) - (set-buffer mybuf) - (delete-region (car rgn) (cdr rgn))))) - ;; Return nil on failure and exit code on success - (if rgn result)) - ;; Cleanup even on nonlocal exit - (if (and proc (eq 'run (process-status proc))) - (interrupt-process proc)) - (set-buffer obuf) - (or buffer (null mybuf) (kill-buffer mybuf))))) - -(defun mime-mc-pgp-sign-region (start end &optional id unclear boundary) - ;; (if (not (boundp 'mc-pgp-user-id)) - ;; (load "mc-pgp") - ;; ) - (let ((process-environment process-environment) - (buffer (get-buffer-create mc-buffer-name)) - passwd args key - (parser (function mc-pgp-generic-parser)) - (pgp-path mc-pgp-path) - ) - (setq key (mc-pgp-lookup-key (or id mc-pgp-user-id))) - (setq passwd - (mc-activate-passwd - (cdr key) - (format "PGP passphrase for %s (%s): " (car key) (cdr key)))) - (setenv "PGPPASSFD" "0") - (setq args - (cons - (if boundary - "-fbast" - "-fast") - (list "+verbose=1" "+language=en" - (format "+clearsig=%s" (if unclear "off" "on")) - "+batchmode" "-u" (cdr key)))) - (if mc-pgp-comment - (setq args (cons (format "+comment=%s" mc-pgp-comment) args)) - ) - (message "Signing as %s ..." (car key)) - (if (mime-mc-process-region - start end passwd pgp-path args parser buffer boundary) - (progn - (if boundary - (progn - (goto-char (point-min)) - (insert - (format "\ ---[[multipart/signed; protocol=\"application/pgp-signature\"; - boundary=\"%s\"; micalg=pgp-md5][7bit]]\n" boundary)) - )) - (message "Signing as %s ... Done." (car key)) - t) - nil))) - -(defun mime-mc-pgp-encrypt-region (recipients start end &optional id sign) - (let ((mc-pgp-always-sign (if (eq sign 'maybe) - mc-pgp-always-sign - 'never))) - (mc-pgp-encrypt-region - (mc-split "\\([ \t\n]*,[ \t\n]*\\)+" recipients) - start end id nil) - )) - - -;;; @ end -;;; - -(provide 'mime-mc) - -;;; mime-mc.el ends here diff --git a/mime-parse.el b/mime-parse.el deleted file mode 100644 index 2dc255e..0000000 --- a/mime-parse.el +++ /dev/null @@ -1,278 +0,0 @@ -;;; mime-parse.el --- MIME message parser - -;; Copyright (C) 1994,1995,1996,1997 Free Software Foundation, Inc. - -;; Author: MORIOKA Tomohiko -;; Version: $Id: mime-parse.el,v 0.7 1997-03-03 17:40:55 morioka Exp $ -;; Keywords: parse, MIME, multimedia, mail, news - -;; This file is part of SEMI (SEMI is Emacs MIME Interfaces). - -;; This program is free software; you can redistribute it and/or -;; modify it under the terms of the GNU General Public License as -;; published by the Free Software Foundation; either version 2, or (at -;; your option) any later version. - -;; This program is distributed in the hope that it will be useful, but -;; WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Code: - -(require 'emu) -(require 'std11) -(require 'mime-def) - -(defsubst symbol-concat (&rest args) - "Return a symbol whose name is concatenation of arguments ARGS -which are string or symbol." - (intern (apply (function concat) - (mapcar (function - (lambda (s) - (cond ((symbolp s) (symbol-name s)) - ((stringp s) s) - ))) - args)))) - -(defmacro define-structure (name &rest slots) - (let ((pred (symbol-concat name '-p))) - (cons 'progn - (nconc - (list - (` (defun (, pred) (obj) - (and (vectorp obj) - (eq (elt obj 0) '(, name)) - )) - ) - (` (defun (, (symbol-concat name '/create)) (, slots) - (, (cons 'vector (cons (list 'quote name) slots))) - ) - )) - (let ((i 1)) - (mapcar (function - (lambda (slot) - (prog1 - (` (defun (, (symbol-concat name '/ slot)) (obj) - (if ((, pred) obj) - (elt obj (, i)) - )) - ) - (setq i (+ i 1)) - ) - )) slots) - ) - (list (list 'quote name)) - )))) - - -;;; @ field parser -;;; - -(defsubst regexp-* (regexp) - (concat regexp "*")) - -(defconst rfc822/quoted-pair-regexp "\\\\.") -(defconst rfc822/qtext-regexp - (concat "[^" (char-list-to-string std11-non-qtext-char-list) "]")) -(defconst rfc822/quoted-string-regexp - (concat "\"" - (regexp-* - (regexp-or rfc822/qtext-regexp rfc822/quoted-pair-regexp) - ) - "\"")) - -(defconst mime/content-parameter-value-regexp - (concat "\\(" - rfc822/quoted-string-regexp - "\\|[^; \t\n]*\\)")) - -(defconst mime::parameter-regexp - (concat "^[ \t]*\;[ \t]*\\(" mime/token-regexp "\\)" - "[ \t]*=[ \t]*\\(" mime/content-parameter-value-regexp "\\)")) - -(defun mime-parse-parameter (str) - (if (string-match mime::parameter-regexp str) - (let ((e (match-end 2))) - (cons - (cons (downcase (substring str (match-beginning 1) (match-end 1))) - (std11-strip-quoted-string - (substring str (match-beginning 2) e)) - ) - (substring str e) - )))) - -(defconst mime::ctype-regexp (concat "^" mime/content-type-subtype-regexp)) - -(defun mime-parse-Content-Type (string) - "Parse STRING as field-body of Content-Type field. [mime-parse.el]" - (setq string (std11-unfold-string string)) - (if (string-match mime::ctype-regexp string) - (let* ((e (match-end 0)) - (ctype (downcase (substring string 0 e))) - ret dest) - (setq string (substring string e)) - (while (setq ret (mime-parse-parameter string)) - (setq dest (cons (car ret) dest) - string (cdr ret)) - ) - (cons ctype (nreverse dest)) - ))) - -(defconst mime::dtype-regexp (concat "^" mime/disposition-type-regexp)) - -(defun mime-parse-Content-Disposition (string) - "Parse STRING as field-body of Content-Disposition field. [mime-parse.el]" - (setq string (std11-unfold-string string)) - (if (string-match mime::dtype-regexp string) - (let* ((e (match-end 0)) - (ctype (downcase (substring string 0 e))) - ret dest) - (setq string (substring string e)) - (while (setq ret (mime-parse-parameter string)) - (setq dest (cons (car ret) dest) - string (cdr ret)) - ) - (cons ctype (nreverse dest)) - ))) - - -;;; @ field reader -;;; - -(defun mime/Content-Type () - "Read field-body of Content-Type field from current-buffer, -and return parsed it. [mime-parse.el]" - (let ((str (std11-field-body "Content-Type"))) - (if str - (mime-parse-Content-Type str) - ))) - -(defun mime/Content-Transfer-Encoding (&optional default-encoding) - "Read field-body of Content-Transfer-Encoding field from -current-buffer, and return it. -If is is not found, return DEFAULT-ENCODING. [mime-parse.el]" - (let ((str (std11-field-body "Content-Transfer-Encoding"))) - (if str - (progn - (if (string-match "[ \t\n\r]+$" str) - (setq str (substring str 0 (match-beginning 0))) - ) - (downcase str) - ) - default-encoding) - )) - -(defun mime/Content-Disposition () - "Read field-body of Content-Disposition field from current-buffer, -and return parsed it. [mime-parse.el]" - (let ((str (std11-field-body "Content-Disposition"))) - (if str - (mime-parse-Content-Disposition str) - ))) - - -;;; @ message parser -;;; - -(define-structure mime::content-info - rcnum point-min point-max type parameters encoding children) - - -(defun mime-parse-multipart (boundary ctype params encoding rcnum) - (goto-char (point-min)) - (let* ((dash-boundary (concat "--" boundary)) - (delimiter (concat "\n" (regexp-quote dash-boundary))) - (close-delimiter (concat delimiter "--[ \t]*$")) - (beg (point-min)) - (end (progn - (goto-char (point-max)) - (if (re-search-backward close-delimiter nil t) - (match-beginning 0) - (point-max) - ))) - (rsep (concat delimiter "[ \t]*\n")) - (dc-ctl - (if (string-equal ctype "multipart/digest") - '("message/rfc822") - '("text/plain") - )) - cb ce ct ret ncb children (i 0)) - (save-restriction - (narrow-to-region beg end) - (goto-char beg) - (re-search-forward rsep nil t) - (setq cb (match-end 0)) - (while (re-search-forward rsep nil t) - (setq ce (match-beginning 0)) - (setq ncb (match-end 0)) - (save-restriction - (narrow-to-region cb ce) - (setq ret (mime-parse-message dc-ctl "7bit" (cons i rcnum))) - ) - (setq children (cons ret children)) - (goto-char (mime::content-info/point-max ret)) - (goto-char (setq cb ncb)) - (setq i (1+ i)) - ) - (setq ce (point-max)) - (save-restriction - (narrow-to-region cb ce) - (setq ret (mime-parse-message dc-ctl "7bit" (cons i rcnum))) - ) - (setq children (cons ret children)) - ) - (mime::content-info/create rcnum beg (point-max) - ctype params encoding - (nreverse children)) - )) - -(defun mime-parse-message (&optional ctl encoding rcnum) - "Parse current-buffer as a MIME message. [mime-parse.el]" - (setq ctl (or (mime/Content-Type) ctl)) - (setq encoding (or (mime/Content-Transfer-Encoding) encoding)) - (let ((ctype (car ctl)) - (params (cdr ctl)) - ) - (let ((boundary (assoc "boundary" params))) - (cond (boundary - (setq boundary (std11-strip-quoted-string (cdr boundary))) - (mime-parse-multipart boundary ctype params encoding rcnum) - ) - ((or (string-equal ctype "message/rfc822") - (string-equal ctype "message/news") - ) - (goto-char (point-min)) - (mime::content-info/create rcnum - (point-min) (point-max) - ctype params encoding - (save-restriction - (narrow-to-region - (if (re-search-forward "^$" nil t) - (1+ (match-end 0)) - (point-min) - ) - (point-max)) - (list (mime-parse-message - nil nil (cons 0 rcnum))) - ) - ) - ) - (t - (mime::content-info/create rcnum (point-min) (point-max) - ctype params encoding nil) - )) - ))) - - -;;; @ end -;;; - -(provide 'mime-parse) - -;;; mime-parse.el ends here diff --git a/mime-partial.el b/mime-partial.el deleted file mode 100644 index 6c3dbcb..0000000 --- a/mime-partial.el +++ /dev/null @@ -1,112 +0,0 @@ -;;; mime-partial.el --- Grabbing all MIME "message/partial"s. - -;; Copyright (C) 1995,1996,1997 Free Software Foundation, Inc. - -;; Author: OKABE Yasuo @ Kyoto University -;; MORIOKA Tomohiko -;; Version: -;; $Id: mime-partial.el,v 0.3 1997-03-07 16:40:29 morioka Exp $ -;; Keywords: message/partial, MIME, multimedia, mail, news - -;; This file is part of SEMI (SEMI is Emacs MIME Interfaces). - -;; This program is free software; you can redistribute it and/or -;; modify it under the terms of the GNU General Public License as -;; published by the Free Software Foundation; either version 2, or (at -;; your option) any later version. - -;; This program is distributed in the hope that it will be useful, but -;; WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Code: - -(require 'mime-view) -(require 'mime-play) - -(defvar mime-partial/preview-article-method-alist nil) - -;; display Article at the cursor in Subject buffer. -(defun mime-partial/preview-article (target) - (save-window-excursion - (let ((f (assq target mime-partial/preview-article-method-alist))) - (if f - (funcall (cdr f)) - (error "Fatal. Unsupported mode") - )))) - -(defun mime-article/grab-message/partials (beg end cal) - (interactive) - (let* ((id (cdr (assoc "id" cal))) - (mother mime::article/preview-buffer) - (target (cdr (assq 'major-mode cal))) - (article-buffer (buffer-name (current-buffer))) - (subject-buf (eval (cdr (assq 'summary-buffer-exp cal)))) - subject-id - (root-dir (expand-file-name - (concat "m-prts-" (user-login-name)) mime-temp-directory)) - full-file) - (setq root-dir (concat root-dir "/" (replace-as-filename id))) - (setq full-file (concat root-dir "/FULL")) - - (if (null target) - (error "%s is not supported. Sorry." target) - ) - - ;; if you can't parse the subject line, try simple decoding method - (if (or (file-exists-p full-file) - (not (y-or-n-p "Merge partials?")) - ) - (mime-article/decode-message/partial beg end cal) - (let (cinfo the-id parameters) - (setq subject-id (std11-field-body "Subject")) - (if (string-match "[0-9\n]+" subject-id) - (setq subject-id (substring subject-id 0 (match-beginning 0))) - ) - (save-excursion - (set-buffer subject-buf) - (while (search-backward subject-id nil t)) - (catch 'tag - (while t - (mime-partial/preview-article target) - (set-buffer article-buffer) - (set-buffer mime::article/preview-buffer) - (setq cinfo - (mime::preview-content-info/content-info - (car mime::preview/content-list))) - (setq parameters (mime::content-info/parameters cinfo)) - (setq the-id (cdr (assoc "id" parameters))) - (if (equal the-id id) - (progn - (set-buffer article-buffer) - (mime-article/decode-message/partial - (point-min)(point-max) parameters) - (if (file-exists-p full-file) - (throw 'tag nil) - ) - )) - (if (not (progn - (set-buffer subject-buf) - (end-of-line) - (search-forward subject-id nil t) - )) - (error "not found") - ) - ) - )))))) - - -;;; @ end -;;; - -(provide 'mime-partial) - -(run-hooks 'mime-partial-load-hook) - -;;; mime-partial.el ends here diff --git a/mime-pgp.el b/mime-pgp.el deleted file mode 100644 index 523fc83..0000000 --- a/mime-pgp.el +++ /dev/null @@ -1,316 +0,0 @@ -;;; mime-pgp.el --- mime-view internal methods for PGP. - -;; Copyright (C) 1995,1996,1997 MORIOKA Tomohiko - -;; Author: MORIOKA Tomohiko -;; Created: 1995/12/7 -;; Renamed: 1997/2/27 from tm-pgp.el -;; Version: $Id: mime-pgp.el,v 0.2 1997-03-04 13:07:54 morioka Exp $ -;; Keywords: mail, news, MIME, multimedia, PGP, security - -;; This file is part of SEMI (SEMI is Emacs MIME Interfaces). - -;; This program is free software; you can redistribute it and/or -;; modify it under the terms of the GNU General Public License as -;; published by the Free Software Foundation; either version 2, or (at -;; your option) any later version. - -;; This program is distributed in the hope that it will be useful, but -;; WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: - -;; This module is based on 2 drafts about PGP MIME integration: - -;; - RFC 2015: "MIME Security with Pretty Good Privacy (PGP)" -;; by Michael Elkins (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-article/view-application/pgp (beg end cal) - (let* ((cnum (mime-article/point-content-number beg)) - (cur-buf (current-buffer)) - (p-win (or (get-buffer-window mime::article/preview-buffer) - (get-largest-window))) - (new-name (format "%s-%s" (buffer-name) cnum)) - (mother mime::article/preview-buffer) - (mode major-mode) - code-converter - (str (buffer-substring beg end)) - ) - (set-buffer (get-buffer-create new-name)) - (erase-buffer) - (insert str) - (cond ((progn - (goto-char (point-min)) - (re-search-forward "^-+BEGIN PGP SIGNED MESSAGE-+$" nil t) - ) - (funcall (pgp-function 'verify)) - (goto-char (point-min)) - (delete-region - (point-min) - (and - (re-search-forward "^-+BEGIN PGP SIGNED MESSAGE-+\n\n") - (match-end 0)) - ) - (delete-region - (and (re-search-forward "^-+BEGIN PGP SIGNATURE-+") - (match-beginning 0)) - (point-max) - ) - (goto-char (point-min)) - (while (re-search-forward "^- -" nil t) - (replace-match "-") - ) - (setq code-converter - (or - (cdr (assq mode mime-viewer/code-converter-alist)) - (function mime-viewer/default-code-convert-region))) - ) - ((progn - (goto-char (point-min)) - (re-search-forward "^-+BEGIN PGP MESSAGE-+$" nil t) - ) - (as-binary-process (funcall (pgp-function 'decrypt))) - (goto-char (point-min)) - (delete-region (point-min) - (and - (search-forward "\n\n") - (match-end 0))) - (setq code-converter (function mime-charset/decode-buffer)) - )) - (setq major-mode 'mime/show-message-mode) - (setq mime::article/code-converter code-converter) - (save-window-excursion (mime/viewer-mode mother)) - (set-window-buffer p-win mime::article/preview-buffer) - )) - -(set-atype 'mime/content-decoding-condition - '((type . "application/pgp") - (method . mime-article/view-application/pgp) - )) - -(set-atype 'mime/content-decoding-condition - '((type . "text/x-pgp") - (method . mime-article/view-application/pgp) - )) - - -;;; @ Internal method for application/pgp-signature -;;; -;;; It is based on RFC 2015. - -(defvar mime-pgp-default-language 'en - "*Symbol of language for pgp. -It should be ISO 639 2 letter language code such as en, ja, ...") - -(defvar mime-pgp-good-signature-regexp-alist - '((en . "Good signature from user.*$")) - "Alist of language vs regexp to detect ``Good signature''.") - -(defvar mime-pgp-key-expected-regexp-alist - '((en . "Key matching expected Key ID \\(\\S +\\) not found")) - "Alist of language vs regexp to detect ``Key expected''.") - -(defun mime::article/call-pgp-to-check-signature (output-buffer orig-file) - (save-excursion - (set-buffer output-buffer) - (erase-buffer) - ) - (let* ((lang (or mime-pgp-default-language 'en)) - (status - (call-process-region (point-min)(point-max) - "pgp" nil output-buffer nil orig-file - (format "+language=%s" lang) - )) - (regexp (cdr (assq lang mime-pgp-good-signature-regexp-alist))) - ) - (if (= status 0) - (save-excursion - (set-buffer output-buffer) - (goto-char (point-min)) - (message - (cond ((not (stringp regexp)) - "Please specify right regexp for specified language") - ((re-search-forward regexp nil t) - (buffer-substring (match-beginning 0) (match-end 0)) - ) - (t - "Bad signature" - ))) - )))) - -(defun mime-article/check-pgp-signature (beg end cal) - (let* ((encoding (cdr (assq 'encoding cal))) - (cnum (mime-article/point-content-number beg)) - (rcnum (reverse cnum)) - (rmcnum (cdr rcnum)) - (knum (car rcnum)) - (onum (if (> knum 0) - (1- knum) - (1+ knum))) - (oinfo (mime-article/rcnum-to-cinfo (cons onum rmcnum) - mime::article/content-info)) - status str kbuf - (basename (expand-file-name "tm" mime-temp-directory)) - (orig-file (make-temp-name basename)) - (sig-file (concat orig-file ".sig")) - ) - (save-excursion - (setq str (buffer-substring - (mime::content-info/point-min oinfo) - (mime::content-info/point-max oinfo) - )) - (set-buffer (get-buffer-create mime/temp-buffer-name)) - (insert str) - (goto-char (point-min)) - (while (re-search-forward "\n" nil t) - (replace-match "\r\n") - ) - (as-binary-output-file (write-file orig-file)) - (kill-buffer (current-buffer)) - ) - (save-excursion - (mime-article/show-output-buffer) - ) - (save-excursion - (setq str (buffer-substring - (save-excursion - (goto-char beg) - (and (search-forward "\n\n") - (match-end 0))) - end)) - (set-buffer (setq kbuf (get-buffer-create mime/temp-buffer-name))) - (insert str) - (mime-decode-region (point-min)(point-max) encoding) - (as-binary-output-file (write-file sig-file)) - (or (mime::article/call-pgp-to-check-signature - mime/output-buffer-name orig-file) - (let (pgp-id) - (save-excursion - (set-buffer mime/output-buffer-name) - (goto-char (point-min)) - (let ((regexp (cdr (assq (or mime-pgp-default-language 'en) - mime-pgp-key-expected-regexp-alist)))) - (cond ((not (stringp regexp)) - (message - "Please specify right regexp for specified language") - ) - ((re-search-forward regexp nil t) - (setq pgp-id - (concat "0x" (buffer-substring-no-properties - (match-beginning 1) - (match-end 1)))) - )))) - (if (and pgp-id - (y-or-n-p - (format "Key %s not found; attempt to fetch? " pgp-id)) - ) - (progn - (funcall (pgp-function 'fetch-key) (cons nil pgp-id)) - (mime::article/call-pgp-to-check-signature - mime/output-buffer-name orig-file) - )) - )) - (let ((other-window-scroll-buffer mime/output-buffer-name)) - (scroll-other-window 8) - ) - (kill-buffer kbuf) - (delete-file orig-file) - (delete-file sig-file) - ))) - -(set-atype 'mime/content-decoding-condition - '((type . "application/pgp-signature") - (method . mime-article/check-pgp-signature) - )) - - -;;; @ Internal method for application/pgp-encrypted -;;; -;;; It is based on RFC 2015. - -(defun mime-article/decrypt-pgp (beg end cal) - (let* ((cnum (mime-article/point-content-number beg)) - (rcnum (reverse cnum)) - (rmcnum (cdr rcnum)) - (knum (car rcnum)) - (onum (if (> knum 0) - (1- knum) - (1+ knum))) - (oinfo (mime-article/rcnum-to-cinfo (cons onum rmcnum) - mime::article/content-info)) - (obeg (mime::content-info/point-min oinfo)) - (oend (mime::content-info/point-max oinfo)) - ) - (mime-article/view-application/pgp obeg oend cal) - )) - -(set-atype 'mime/content-decoding-condition - '((type . "application/pgp-encrypted") - (method . mime-article/decrypt-pgp) - )) - - -;;; @ Internal method for application/pgp-keys -;;; -;;; It is based on RFC 2015. - -(defun mime-article/add-pgp-keys (beg end cal) - (let* ((cnum (mime-article/point-content-number beg)) - (cur-buf (current-buffer)) - (new-name (format "%s-%s" (buffer-name) cnum)) - (mother mime::article/preview-buffer) - (charset (cdr (assoc "charset" cal))) - (encoding (cdr (assq 'encoding cal))) - (mode major-mode) - str) - (setq str (buffer-substring beg end)) - (switch-to-buffer new-name) - (setq buffer-read-only nil) - (erase-buffer) - (insert str) - (goto-char (point-min)) - (if (re-search-forward "^\n" nil t) - (delete-region (point-min) (match-end 0)) - ) - (mime-decode-region (point-min)(point-max) encoding) - (funcall (pgp-function 'snarf-keys)) - (kill-buffer (current-buffer)) - )) - -(set-atype 'mime/content-decoding-condition - '((type . "application/pgp-keys") - (method . mime-article/add-pgp-keys) - )) - - -;;; @ end -;;; - -(provide 'mime-pgp) - -(run-hooks 'mime-pgp-load-hook) - -;;; mime-pgp.el ends here diff --git a/mime-play.el b/mime-play.el deleted file mode 100644 index cfe59ad..0000000 --- a/mime-play.el +++ /dev/null @@ -1,495 +0,0 @@ -;;; mime-play.el --- decoder for mime-view.el - -;; Copyright (C) 1994,1995,1996,1997 Free Software Foundation, Inc. - -;; Author: MORIOKA Tomohiko -;; Created: 1995/9/26 (separated from tm-view.el) -;; Renamed: 1997/2/21 from tm-play.el -;; Version: $Id: mime-play.el,v 0.13 1997-03-10 13:39:57 morioka Exp $ -;; Keywords: MIME, multimedia, mail, news - -;; This file is part of SEMI (SEMI is Emacs MIME Interfaces). - -;; This program is free software; you can redistribute it and/or -;; modify it under the terms of the GNU General Public License as -;; published by the Free Software Foundation; either version 2, or (at -;; your option) any later version. - -;; This program is distributed in the hope that it will be useful, but -;; WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Code: - -(require 'mime-view) -(require 'alist) -(require 'filename) - - -;;; @ content decoder -;;; - -(defvar mime-preview/after-decoded-position nil) - -(defun mime-preview/decode-content () - (interactive) - (let ((pc (mime-preview/point-pcinfo (point)))) - (if pc - (let ((the-buf (current-buffer))) - (setq mime-preview/after-decoded-position (point)) - (set-buffer (mime::preview-content-info/buffer pc)) - (mime-article/decode-content - (mime::preview-content-info/content-info pc)) - (if (eq (current-buffer) - (mime::preview-content-info/buffer pc)) - (progn - (set-buffer the-buf) - (goto-char mime-preview/after-decoded-position) - )) - )))) - -(defun mime-article/decode-content (cinfo) - (let ((beg (mime::content-info/point-min cinfo)) - (end (mime::content-info/point-max cinfo)) - (ctype (or (mime::content-info/type cinfo) "text/plain")) - (params (mime::content-info/parameters cinfo)) - (encoding (mime::content-info/encoding cinfo)) - ) - ;; Check for VM - (if (< beg (point-min)) - (setq beg (point-min)) - ) - (if (< (point-max) end) - (setq end (point-max)) - ) - (let (method cal ret) - (setq cal (list* (cons 'type ctype) - (cons 'encoding encoding) - (cons 'major-mode major-mode) - params)) - (if mime-view-decoding-mode - (setq cal (cons - (cons 'mode mime-view-decoding-mode) - cal)) - ) - (setq ret (mime/get-content-decoding-alist cal)) - (setq method (cdr (assq 'method ret))) - (cond ((and (symbolp method) - (fboundp method)) - (funcall method beg end ret) - ) - ((and (listp method)(stringp (car method))) - (mime-article/start-external-method-region beg end ret) - ) - (t - (mime-article/show-output-buffer - "No method are specified for %s\n" ctype) - )) - ) - )) - - -;;; @ method selector -;;; - -(defun mime/get-content-decoding-alist (al) - (get-unified-alist mime/content-decoding-condition al) - ) - - -;;; @ external decoder -;;; - -(defun mime-article/start-external-method-region (beg end cal) - (save-excursion - (save-restriction - (narrow-to-region beg end) - (goto-char beg) - (let ((method (cdr (assoc 'method cal))) - (name (mime-article/get-filename cal)) - ) - (if method - (let ((file (make-temp-name - (expand-file-name "TM" mime-temp-directory))) - b args) - (if (nth 1 method) - (setq b beg) - (setq b - (if (re-search-forward "^$" nil t) - (1+ (match-end 0)) - (point-min) - )) - ) - (goto-char b) - (write-region b end file) - (message "External method is starting...") - (setq cal (put-alist - 'name (replace-as-filename name) cal)) - (setq cal (put-alist 'file file cal)) - (setq args (nconc - (list (car method) - mime/output-buffer-name (car method) - ) - (mime-article/make-method-args cal - (cdr (cdr method))) - )) - (apply (function start-process) args) - (mime-article/show-output-buffer) - )) - )))) - -(defun mime-article/make-method-args (cal format) - (mapcar (function - (lambda (arg) - (if (stringp arg) - arg - (let* ((item (eval arg)) - (ret (cdr (assoc item cal))) - ) - (if ret - ret - (if (eq item 'encoding) - "7bit" - "")) - )) - )) - format)) - -(defun mime-article/show-output-buffer (&rest forms) - (get-buffer-create mime/output-buffer-name) - (let ((the-win (selected-window)) - (win (get-buffer-window mime/output-buffer-name)) - ) - (or win - (if (and mime/output-buffer-window-is-shared-with-bbdb - (boundp 'bbdb-buffer-name) - (setq win (get-buffer-window bbdb-buffer-name)) - ) - (set-window-buffer win mime/output-buffer-name) - (select-window (get-buffer-window mime::article/preview-buffer)) - (setq win (split-window-vertically (/ (* (window-height) 3) 4))) - (set-window-buffer win mime/output-buffer-name) - )) - (select-window win) - (goto-char (point-max)) - (if forms - (insert (apply (function format) forms)) - ) - (select-window the-win) - )) - - -;;; @ file name -;;; - -(defvar mime-view-file-name-char-regexp "[A-Za-z0-9+_-]") - -(defvar mime-view-file-name-regexp-1 - (concat mime-view-file-name-char-regexp "+\\." - mime-view-file-name-char-regexp "+")) - -(defvar mime-view-file-name-regexp-2 - (concat (regexp-* mime-view-file-name-char-regexp) - "\\(\\." mime-view-file-name-char-regexp "+\\)*")) - -(defun mime-article/get-original-filename (param &optional encoding) - (or (mime-article/get-uu-filename param encoding) - (let (ret) - (or (if (or (and (setq ret (mime/Content-Disposition)) - (setq ret (assoc "filename" (cdr ret))) - ) - (setq ret (assoc "name" param)) - (setq ret (assoc "x-name" param)) - ) - (std11-strip-quoted-string (cdr ret)) - ) - (if (setq ret - (std11-find-field-body '("Content-Description" - "Subject"))) - (if (or (string-match mime-view-file-name-regexp-1 ret) - (string-match mime-view-file-name-regexp-2 ret)) - (substring ret (match-beginning 0)(match-end 0)) - )) - )) - )) - -(defun mime-article/get-filename (param) - (replace-as-filename (mime-article/get-original-filename param)) - ) - - -;;; @ mail/news message -;;; - -(defun mime-view-quitting-method-for-mime/show-message-mode () - (let ((mother mime::preview/mother-buffer) - (win-conf mime::preview/original-window-configuration) - ) - (kill-buffer - (mime::preview-content-info/buffer (car mime::preview/content-list))) - (mime-view-kill-buffer) - (set-window-configuration win-conf) - (pop-to-buffer mother) - ;;(goto-char (point-min)) - ;;(mime-view-up-content) - )) - -(defun mime-article/view-message/rfc822 (beg end cal) - (let* ((cnum (mime-article/point-content-number beg)) - (cur-buf (current-buffer)) - (new-name (format "%s-%s" (buffer-name) cnum)) - (mother mime::article/preview-buffer) - (code-converter - (or (cdr (assq major-mode mime-text-decoder-alist)) - 'mime-view-default-code-convert-region)) - str) - (setq str (buffer-substring beg end)) - (switch-to-buffer new-name) - (erase-buffer) - (insert str) - (goto-char (point-min)) - (if (re-search-forward "^\n" nil t) - (delete-region (point-min) (match-end 0)) - ) - (setq major-mode 'mime/show-message-mode) - (setq mime::article/code-converter code-converter) - (mime-view-mode mother) - )) - - -;;; @ message/partial -;;; - -(defvar mime-article/coding-system-alist - (list '(mh-show-mode . no-conversion) - (cons t (mime-charset-to-coding-system default-mime-charset)) - )) - -(defun mime-article::write-region (start end file) - (let ((coding-system-for-write - (cdr - (or (assq major-mode mime-article/coding-system-alist) - (assq t mime-article/coding-system-alist) - )))) - (write-region start end file) - )) - -(defun mime-article/decode-message/partial (beg end cal) - (goto-char beg) - (let* ((root-dir - (expand-file-name - (concat "m-prts-" (user-login-name)) mime-temp-directory)) - (id (cdr (assoc "id" cal))) - (number (cdr (assoc "number" cal))) - (total (cdr (assoc "total" cal))) - file - (mother mime::article/preview-buffer) - ) - (or (file-exists-p root-dir) - (make-directory root-dir) - ) - (setq id (replace-as-filename id)) - (setq root-dir (concat root-dir "/" id)) - (or (file-exists-p root-dir) - (make-directory root-dir) - ) - (setq file (concat root-dir "/FULL")) - (if (file-exists-p file) - (let ((full-buf (get-buffer-create "FULL")) - (pwin (or (get-buffer-window mother) - (get-largest-window))) - ) - (save-window-excursion - (set-buffer full-buf) - (erase-buffer) - (as-binary-input-file (insert-file-contents file)) - (setq major-mode 'mime/show-message-mode) - (mime-view-mode mother) - ) - (set-window-buffer pwin - (save-excursion - (set-buffer full-buf) - mime::article/preview-buffer)) - (select-window pwin) - ) - (re-search-forward "^$") - (goto-char (1+ (match-end 0))) - (setq file (concat root-dir "/" number)) - (mime-article::write-region (point) (point-max) file) - (let ((total-file (concat root-dir "/CT"))) - (setq total - (if total - (progn - (or (file-exists-p total-file) - (save-excursion - (set-buffer - (get-buffer-create mime/temp-buffer-name)) - (erase-buffer) - (insert total) - (write-file total-file) - (kill-buffer (current-buffer)) - )) - (string-to-number total) - ) - (and (file-exists-p total-file) - (save-excursion - (set-buffer (find-file-noselect total-file)) - (prog1 - (and (re-search-forward "[0-9]+" nil t) - (string-to-number - (buffer-substring (match-beginning 0) - (match-end 0))) - ) - (kill-buffer (current-buffer)) - ))) - ))) - (if (and total (> total 0)) - (catch 'tag - (save-excursion - (set-buffer (get-buffer-create mime/temp-buffer-name)) - (let ((full-buf (current-buffer))) - (erase-buffer) - (let ((i 1)) - (while (<= i total) - (setq file (concat root-dir "/" (int-to-string i))) - (or (file-exists-p file) - (throw 'tag nil) - ) - (as-binary-input-file (insert-file-contents file)) - (goto-char (point-max)) - (setq i (1+ i)) - )) - (as-binary-output-file (write-file (concat root-dir "/FULL"))) - (let ((i 1)) - (while (<= i total) - (let ((file (format "%s/%d" root-dir i))) - (and (file-exists-p file) - (delete-file file) - )) - (setq i (1+ i)) - )) - (let ((file (expand-file-name "CT" root-dir))) - (and (file-exists-p file) - (delete-file file) - )) - (save-window-excursion - (setq major-mode 'mime/show-message-mode) - (mime-view-mode mother) - ) - (let ((pwin (or (get-buffer-window mother) - (get-largest-window) - )) - (pbuf (save-excursion - (set-buffer full-buf) - mime::article/preview-buffer))) - (set-window-buffer pwin pbuf) - (select-window pwin) - ))))) - ))) - - -;;; @ message/external-body -;;; - -(defvar mime-article/dired-function - (if mime/use-multi-frame - (function dired-other-frame) - (function mime-article/dired-function-for-one-frame) - )) - -(defun mime-article/dired-function-for-one-frame (dir) - (let ((win (or (get-buffer-window mime::article/preview-buffer) - (get-largest-window)))) - (select-window win) - (dired dir) - )) - -(defun mime-article/decode-message/external-ftp (beg end cal) - (let* ((access-type (cdr (assoc "access-type" cal))) - (site (cdr (assoc "site" cal))) - (directory (cdr (assoc "directory" cal))) - (name (cdr (assoc "name" cal))) - (mode (cdr (assoc "mode" cal))) - (pathname (concat "/anonymous@" site ":" directory)) - ) - (message (concat "Accessing " (expand-file-name name pathname) "...")) - (funcall mime-article/dired-function pathname) - (goto-char (point-min)) - (search-forward name) - )) - - -;;; @ rot13-47 -;;; - -(require 'view) - -(defconst mime-view-text/plain-mode-map (copy-keymap view-mode-map)) -(define-key mime-view-text/plain-mode-map - "q" (function mime-view-text/plain-exit)) - -(defun mime-view-text/plain-mode () - "\\{mime-view-text/plain-mode-map}" - (setq buffer-read-only t) - (setq major-mode 'mime-view-text/plain-mode) - (setq mode-name "MIME-View text/plain") - (use-local-map mime-view-text/plain-mode-map) - ) - -(defun mime-view-text/plain-exit () - (interactive) - (kill-buffer (current-buffer)) - ) - -(defun mime-article/decode-caesar (beg end cal) - (let* ((cnum (mime-article/point-content-number beg)) - (cur-buf (current-buffer)) - (new-name (format "%s-%s" (buffer-name) cnum)) - (mother mime::article/preview-buffer) - (charset (cdr (assoc "charset" cal))) - (encoding (cdr (assq 'encoding cal))) - (mode major-mode) - str) - (setq str (buffer-substring beg end)) - (let ((pwin (or (get-buffer-window mother) - (get-largest-window))) - (buf (get-buffer-create new-name)) - ) - (set-window-buffer pwin buf) - (set-buffer buf) - (select-window pwin) - ) - (setq buffer-read-only nil) - (erase-buffer) - (insert str) - (goto-char (point-min)) - (if (re-search-forward "^\n" nil t) - (delete-region (point-min) (match-end 0)) - ) - (let ((m (cdr (or (assq mode mime-text-decoder-alist) - (assq t mime-text-decoder-alist))))) - (and (functionp m) - (funcall m charset encoding) - )) - (save-excursion - (set-mark (point-min)) - (goto-char (point-max)) - (tm:caesar-region) - ) - (set-buffer-modified-p nil) - (mime-view-text/plain-mode) - )) - - -;;; @ end -;;; - -(provide 'mime-play) - -;;; mime-play.el ends here diff --git a/mime-tar.el b/mime-tar.el deleted file mode 100644 index 4c8f8e9..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.3 1997-03-04 13:11:02 morioka Exp $ -;; Keywords: tar, tar+gzip, MIME, multimedia, mail, news - -;; This file is part of SEMI (SEMI is Emacs MIME Interfaces). - -;; This program is free software; you can redistribute it and/or -;; modify it under the terms of the GNU General Public License as -;; published by the Free Software Foundation; either version 2, or (at -;; your option) any later version. - -;; This program is distributed in the hope that it will be useful, but -;; WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: - -;; Internal viewer for -;; - application/x-tar -;; - application/x-gzip, type="tar" -;; - aplication/octet-stream, type="tar" -;; - aplication/octet-stream, type="tar+gzip" - -;;; Code: - -(require 'mime-view) - - -;;; @ constants -;;; - -(defconst mime-tar-list-buffer "*mime-tar-List*") -(defconst mime-tar-view-buffer "*mime-tar-View*") -(defconst mime-tar-file-search-regexp "[0-9]+\:[0-9\:]+[ ]+[0-9]+[ ]+") -(defconst mime-tar-popup-menu-title "Action Menu") - - -;;; @ variables -;;; - -(defvar mime-tar-program "gtar") -(defvar mime-tar-decompress-arg '("-z")) -(defvar mime-tar-gzip-program "gzip") -(defvar mime-tar-mmencode-program "mmencode") -(defvar mime-tar-uudecode-program "uudecode") - -(defvar mime-tar-popup-menu-items - '(("View File" . mime-tar-view-file) - ("Key Help" . mime-tar-helpful-message) - ("Quit mime-tar Mode" . exit-recursive-edit) - )) - -(cond ((string-match "XEmacs\\|Lucid" emacs-version) - (defvar mime-tar-popup-menu - (cons mime-tar-popup-menu-title - (mapcar (function - (lambda (item) - (vector (car item)(cdr item) t) - )) - mime-tar-popup-menu-items))) - - (defun mime-tar-mouse-button-2 (event) - (popup-menu mime-tar-popup-menu) - ) - ) - ((>= emacs-major-version 19) - (defun mime-tar-mouse-button-2 (event) - (let ((menu - (cons mime-tar-popup-menu-title - (list (cons "Menu Items" mime-tar-popup-menu-items)) - ))) - (let ((func (x-popup-menu event menu))) - (if func - (funcall func) - )) - )) - )) - -(defvar mime-tar-mode-map nil) -(if mime-tar-mode-map - nil - (setq mime-tar-mode-map (make-keymap)) - (suppress-keymap mime-tar-mode-map) - (define-key mime-tar-mode-map "\C-c" 'exit-recursive-edit) - (define-key mime-tar-mode-map "q" 'exit-recursive-edit) - (define-key mime-tar-mode-map "n" 'mime-tar-next-line) - (define-key mime-tar-mode-map " " 'mime-tar-next-line) - (define-key mime-tar-mode-map "\C-m" 'mime-tar-next-line) - (define-key mime-tar-mode-map "p" 'mime-tar-previous-line) - (define-key mime-tar-mode-map "\177" 'mime-tar-previous-line) - (define-key mime-tar-mode-map "\C-\M-m" 'mime-tar-previous-line) - (define-key mime-tar-mode-map "v" 'mime-tar-view-file) - (define-key mime-tar-mode-map "\C-h" 'Helper-help) - (define-key mime-tar-mode-map "?" 'mime-tar-helpful-message) - (if mouse-button-2 - (define-key mime-tar-mode-map - mouse-button-2 'mime-button-dispatcher)) - ) - - -;;; @@ mime-tar mode functions -;;; - -(defun mime-tar-mode (&optional prev-buf) - "Major mode for listing the contents of a tar archive file." - (unwind-protect - (let ((buffer-read-only t) - (mode-name "mime-tar") - (mode-line-buffer-identification '("%17b")) - ) - (goto-char (point-min)) - (mime-tar-move-to-filename) - (catch 'mime-tar-mode (mime-tar-command-loop)) - ) - (if prev-buf - (switch-to-buffer prev-buf) - ) - )) - -(defun mime-tar-command-loop () - (let ((old-local-map (current-local-map))) - (unwind-protect - (progn - (use-local-map mime-tar-mode-map) - (mime-tar-helpful-message) - (recursive-edit) - ) - (save-excursion - (use-local-map old-local-map) - )) - )) - -(defun mime-tar-next-line () - (interactive) - (next-line 1) - (mime-tar-move-to-filename) - ) - -(defun mime-tar-previous-line () - (interactive) - (previous-line 1) - (mime-tar-move-to-filename) - ) - -(defun mime-tar-view-file () - (interactive) - (let ((name (mime-tar-get-filename)) - ) - (save-excursion - (switch-to-buffer mime-tar-view-buffer) - (setq buffer-read-only nil) - (erase-buffer) - (message "Reading a file from an archive. Please wait...") - (apply 'call-process mime-tar-program - nil t nil (append mime-tar-view-args (list name))) - (goto-char (point-min)) - ) - (view-buffer mime-tar-view-buffer) - )) - -(defun mime-tar-get-filename () - (let (eol) - (save-excursion - (end-of-line) - (setq eol (point)) - (beginning-of-line) - (save-excursion - (if (re-search-forward "^d" eol t) - (error "Cannot view a directory")) - ) - (if (re-search-forward mime-tar-file-search-regexp eol t) - (let ((beg (point))) - (skip-chars-forward "^ \n") - (buffer-substring beg (point)) - ) - (error "No file on this line") - )) - )) - -(defun mime-tar-move-to-filename () - (let ((eol (progn (end-of-line) (point)))) - (beginning-of-line) - (re-search-forward mime-tar-file-search-regexp eol t) - )) - -(defun mime-tar-set-properties () - (if mouse-button-2 - (let ((beg (point-min)) - (end (point-max)) - ) - (goto-char beg) - (save-excursion - (while (re-search-forward mime-tar-file-search-regexp end t) - (mime-add-button (point) - (progn - (end-of-line) - (point)) - 'mime-tar-view-file) - )) - ))) - -(defun mime-tar-helpful-message () - (interactive) - (message "Type %s, %s, %s, %s, %s, %s." - (substitute-command-keys "\\[Helper-help] for help") - (substitute-command-keys "\\[mime-tar-helpful-message] for keys") - (substitute-command-keys "\\[mime-tar-next-line] to next") - (substitute-command-keys "\\[mime-tar-previous-line] to prev") - (substitute-command-keys "\\[mime-tar-view-file] to view") - (substitute-command-keys "\\[exit-recursive-edit] to quit") - )) - -(defun mime-tar-y-or-n-p (prompt) - (prog1 - (y-or-n-p prompt) - (message "") - )) - -;;; @@ tar message decoder -;; - -(defun mime-decode-message/tar (beg end cal) - (if (mime-tar-y-or-n-p "Do you want to enter mime-tar mode? ") - (let ((coding (cdr (assoc 'encoding cal))) - (cur-buf (current-buffer)) - (mime-tar-file-name - (expand-file-name - (concat (make-temp-name - (expand-file-name "tm" mime-temp-directory)) ".tar"))) - (mime-tar-tmp-file-name - (expand-file-name - (make-temp-name (expand-file-name "tm" mime-temp-directory)))) - new-buf) - (find-file mime-tar-tmp-file-name) - (setq new-buf (current-buffer)) - (setq buffer-read-only nil) - (erase-buffer) - (save-excursion - (set-buffer cur-buf) - (goto-char beg) - (re-search-forward "^$") - (append-to-buffer new-buf (+ (match-end 0) 1) end) - ) - (if (member coding mime-viewer/uuencode-encoding-name-list) - (progn - (goto-char (point-min)) - (if (re-search-forward "^begin [0-9]+ " nil t) - (progn - (kill-line) - (insert mime-tar-file-name) - ) - (progn - (set-buffer-modified-p nil) - (kill-buffer new-buf) - (error "uuencode file signature was not found") - )))) - (save-buffer) - (kill-buffer new-buf) - (message "Listing the contents of an archive. Please wait...") - (cond ((string-equal coding "base64") - (call-process mime-tar-mmencode-program nil nil nil "-u" - "-o" mime-tar-file-name mime-tar-tmp-file-name) - ) - ((string-equal coding "quoted-printable") - (call-process mime-tar-mmencode-program nil nil nil "-u" "-q" - "-o" mime-tar-file-name mime-tar-tmp-file-name) - ) - ((member coding mime-viewer/uuencode-encoding-name-list) - (call-process mime-tar-uudecode-program nil nil nil - mime-tar-tmp-file-name) - ) - (t - (copy-file mime-tar-tmp-file-name mime-tar-file-name t) - )) - (delete-file mime-tar-tmp-file-name) - (setq mime-tar-list-args (list "-tvf" mime-tar-file-name)) - (setq mime-tar-view-args (list "-xOf" mime-tar-file-name)) - (if (eq 0 (call-process mime-tar-gzip-program - nil nil nil "-t" mime-tar-file-name)) - (progn - (setq mime-tar-list-args - (append mime-tar-decompress-arg mime-tar-list-args)) - (setq mime-tar-view-args - (append mime-tar-decompress-arg mime-tar-view-args)) - )) - (switch-to-buffer mime-tar-view-buffer) - (switch-to-buffer mime-tar-list-buffer) - (setq buffer-read-only nil) - (erase-buffer) - (apply 'call-process mime-tar-program - nil t nil mime-tar-list-args) - (if mouse-button-2 - (progn - (make-local-variable 'mime-button-mother-dispatcher) - (setq mime-button-mother-dispatcher 'mime-tar-mouse-button-2) - )) - (mime-tar-set-properties) - (mime-tar-mode mime::article/preview-buffer) - (kill-buffer mime-tar-view-buffer) - (kill-buffer mime-tar-list-buffer) - (delete-file mime-tar-file-name) - ) - )) - -;;; @@ program/buffer coding system -;;; - -(cond ((boundp 'MULE) - (define-program-coding-system mime-tar-view-buffer nil *autoconv*) - ) - ((boundp 'NEMACS) - (define-program-kanji-code mime-tar-view-buffer nil 1) - )) - -;;; @@ message types to use mime-tar -;;; - -(set-atype 'mime/content-decoding-condition - '((type . "application/octet-stream") - (method . mime-decode-message/tar) - (mode . "play") ("type" . "tar") - )) - -(set-atype 'mime/content-decoding-condition - '((type . "application/octet-stream") - (method . mime-decode-message/tar) - (mode . "play") ("type" . "tar+gzip") - )) - -(set-atype 'mime/content-decoding-condition - '((type . "application/x-gzip") - (method . mime-decode-message/tar) - (mode . "play") ("type" . "tar") - )) - -(set-atype 'mime/content-decoding-condition - '((type . "application/x-tar") - (method . mime-decode-message/tar) - (mode . "play") - )) - -;;; @ end -;;; - -(provide 'mime-tar) - -;;; mime-tar.el ends here diff --git a/mime-text.el b/mime-text.el deleted file mode 100644 index 63b4955..0000000 --- a/mime-text.el +++ /dev/null @@ -1,133 +0,0 @@ -;;; mime-text.el --- mime-view content filter for text - -;; Copyright (C) 1994,1995,1996,1997 Free Software Foundation, Inc. - -;; Author: MORIOKA Tomohiko -;; Version: -;; $Id: mime-text.el,v 0.11 1997-03-04 12:39:25 morioka Exp $ -;; Keywords: text, MIME, multimedia, mail, news - -;; This file is part of SEMI (SEMI is Emacs MIME Interfaces). - -;; This program is free software; you can redistribute it and/or -;; modify it under the terms of the GNU General Public License as -;; published by the Free Software Foundation; either version 2, or (at -;; your option) any later version. - -;; This program is distributed in the hope that it will be useful, but -;; WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Code: - -;;; @ code conversion -;;; - -(defvar mime-text-decoder-alist - '((mime/show-message-mode . mime-charset/decode-buffer) - (mime-temp-message-mode . mime-charset/decode-buffer) - (t . mime-charset/maybe-decode-buffer) - )) - -(defun mime-charset/decode-buffer (charset &optional encoding) - (decode-mime-charset-region (point-min)(point-max) - (or charset default-mime-charset)) - ) - -(defun mime-charset/maybe-decode-buffer (charset &optional encoding) - (or (member encoding '(nil "7bit" "8bit" "binary")) - (mime-charset/decode-buffer charset) - )) - -(defun mime-preview/decode-text-buffer (charset encoding) - (mime-decode-region (point-min) (point-max) encoding) - (let* ((mode mime::preview/original-major-mode) - (m (or (save-excursion - (set-buffer mime::preview/article-buffer) - mime::article/code-converter) - (cdr (or (assq mode mime-text-decoder-alist) - (assq t mime-text-decoder-alist))) - )) - ) - (and (functionp m) - (funcall m charset encoding) - ))) - - -;;; @ for URL -;;; - -(require 'browse-url) - -(defvar mime-text-url-regexp - "\\(http\\|ftp\\|file\\|gopher\\|news\\|telnet\\|wais\\|mailto\\):\\(//[-a-zA-Z0-9_.]+:[0-9]*\\)?[-a-zA-Z0-9_=?#$@~`%&*+|\\/.,]*[-a-zA-Z0-9_=#$@~`%&*+|\\/]" - "*Regexp to match URL in text/plain body.") - -(defun mime-text-browse-url (&optional url) - (if (fboundp browse-url-browser-function) - (if url - (funcall browse-url-browser-function url) - (call-interactively browse-url-browser-function)) - (if (fboundp mime-button-mother-dispatcher) - (call-interactively mime-button-mother-dispatcher) - ) - )) - - -;;; @ content filters for mime-text -;;; - -(defun mime-preview/filter-for-text/plain (ctype params encoding) - (mime-preview/decode-text-buffer (cdr (assoc "charset" params)) encoding) - (goto-char (point-max)) - (if (not (eq (char-after (1- (point))) ?\n)) - (insert "\n") - ) - (if browse-url-browser-function - (progn - (goto-char (point-min)) - (while (re-search-forward mime-text-url-regexp nil t) - (let ((beg (match-beginning 0)) - (end (match-end 0))) - (mime-add-button beg end - (function mime-text-browse-url) - (list (buffer-substring beg end)))) - ))) - (run-hooks 'mime-view-plain-text-preview-hook) - ) - -(defun mime-preview/filter-for-text/richtext (ctype params encoding) - (let* ((mode mime::preview/original-major-mode) - (m (assq mode mime-text-decoder-alist)) - (charset (cdr (assoc "charset" params))) - (beg (point-min)) - ) - (remove-text-properties beg (point-max) '(face nil)) - (mime-preview/decode-text-buffer charset encoding) - (richtext-decode beg (point-max)) - )) - -(defun mime-preview/filter-for-text/enriched (ctype params encoding) - (let* ((mode mime::preview/original-major-mode) - (m (assq mode mime-text-decoder-alist)) - (charset (cdr (assoc "charset" params))) - (beg (point-min)) - ) - (remove-text-properties beg (point-max) '(face nil)) - (mime-preview/decode-text-buffer charset encoding) - (enriched-decode beg (point-max)) - )) - - -;;; @ end -;;; - -(provide 'mime-text) - -;;; mime-text.el ends here diff --git a/mime-view.el b/mime-view.el deleted file mode 100644 index b7422ab..0000000 --- a/mime-view.el +++ /dev/null @@ -1,1211 +0,0 @@ -;;; mime-view.el --- interactive MIME viewer for GNU Emacs - -;; Copyright (C) 1995,1996,1997 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 -;; Version: $Revision: 0.22 $ -;; Keywords: MIME, multimedia, mail, news - -;; This file is part of SEMI (SEMI is Emacs MIME Interfaces). - -;; This program is free software; you can redistribute it and/or -;; modify it under the terms of the GNU General Public License as -;; published by the Free Software Foundation; either version 2, or (at -;; your option) any later version. - -;; This program is distributed in the hope that it will be useful, but -;; WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Code: - -(require 'cl) -(require 'std11) -(require 'mel) -(require 'eword-decode) -(require 'mime-parse) -(require 'mime-text) - - -;;; @ version -;;; - -(defconst mime-view-RCS-ID - "$Id: mime-view.el,v 0.22 1997-03-10 13:44:24 morioka Exp $") - -(defconst mime-view-version (get-version-string mime-view-RCS-ID)) - - -;;; @ variables -;;; - -(defvar mime/content-decoding-condition - '(((type . "text/plain") - (method "tm-plain" nil 'file 'type 'encoding 'mode 'name) - (mode "play" "print") - ) - ((type . "text/html") - (method "tm-html" nil 'file 'type 'encoding 'mode 'name) - (mode . "play") - ) - ((type . "text/x-rot13-47") - (method . mime-article/decode-caesar) - (mode . "play") - ) - ((type . "audio/basic") - (method "tm-au" nil 'file 'type 'encoding 'mode 'name) - (mode . "play") - ) - - ((type . "image/jpeg") - (method "tm-image" nil 'file 'type 'encoding 'mode 'name) - (mode "play" "print") - ) - ((type . "image/gif") - (method "tm-image" nil 'file 'type 'encoding 'mode 'name) - (mode "play" "print") - ) - ((type . "image/tiff") - (method "tm-image" nil 'file 'type 'encoding 'mode 'name) - (mode "play" "print") - ) - ((type . "image/x-tiff") - (method "tm-image" nil 'file 'type 'encoding 'mode 'name) - (mode "play" "print") - ) - ((type . "image/x-xbm") - (method "tm-image" nil 'file 'type 'encoding 'mode 'name) - (mode "play" "print") - ) - ((type . "image/x-pic") - (method "tm-image" nil 'file 'type 'encoding 'mode 'name) - (mode "play" "print") - ) - ((type . "image/x-mag") - (method "tm-image" nil 'file 'type 'encoding 'mode 'name) - (mode "play" "print") - ) - - ((type . "video/mpeg") - (method "tm-mpeg" nil 'file 'type 'encoding 'mode 'name) - (mode . "play") - ) - - ((type . "application/postscript") - (method "tm-ps" nil 'file 'type 'encoding 'mode 'name) - (mode "play" "print") - ) - ((type . "application/octet-stream") - (method "tm-file" nil 'file 'type 'encoding 'mode 'name) - (mode "play" "print") - ) - - ;;((type . "message/external-body") - ;; (method "xterm" nil - ;; "-e" "showexternal" - ;; 'file '"access-type" '"name" '"site" '"directory")) - ((type . "message/rfc822") - (method . mime-article/view-message/rfc822) - (mode . "play") - ) - ((type . "message/partial") - (method . mime-article/decode-message/partial) - (mode . "play") - ) - ((type . "message/external-body") - ("access-type" . "anon-ftp") - (method . mime-article/decode-message/external-ftp) - ) - - ((method "metamail" t "-m" "tm" "-x" "-d" "-z" "-e" 'file) - (mode . "play") - ) - ((method "tm-file" nil 'file 'type 'encoding 'mode 'name) - (mode . "extract") - ) - )) - -(defvar mime-view-childrens-header-showing-Content-Type-list - '("message/rfc822" "message/news")) - -(defvar mime-view-default-showing-Content-Type-list - '("text/plain" nil "text/richtext" "text/enriched" - "text/x-latex" "application/x-latex" - "message/delivery-status" - "application/pgp" "text/x-pgp" - "application/octet-stream" - "application/x-selection" "application/x-comment")) - -(defvar mime-view-content-button-ignored-ctype-list - '("application/x-selection")) - -(defvar mime-view-content-button-visible-ctype-list - '("application/pgp")) - -(defvar mime-view-uuencode-encoding-name-list '("x-uue" "x-uuencode")) - -(defvar mime-view-ignored-field-list - '(".*Received" ".*Path" ".*Id" "References" - "Replied" "Errors-To" - "Lines" "Sender" ".*Host" "Xref" - "Content-Type" "Precedence" - "Status" "X-VM-.*") - "All fields that match this list will be hidden in MIME preview buffer. -Each elements are regexp of field-name. [mime-view.el]") - -(defvar mime-view-ignored-field-regexp - (concat "^" - (apply (function regexp-or) mime-view-ignored-field-list) - ":")) - -(defvar mime-view-visible-field-list - '("Dnas.*" "Message-Id") - "All fields that match this list will be displayed in MIME preview buffer. -Each elements are regexp of field-name. [mime-view.el]") - -(defvar mime-view-visible-field-regexp - (concat "^" - (apply (function regexp-or) mime-view-visible-field-list) - ":")) - -(defvar mime-view-redisplay nil) - -(defvar mime-view-announcement-for-message/partial - (if (and (>= emacs-major-version 19) window-system) - "\ -\[[ This is message/partial style split message. ]] -\[[ Please press `v' key in this buffer ]] -\[[ or click here by mouse button-2. ]]" - "\ -\[[ This is message/partial style split message. ]] -\[[ Please press `v' key in this buffer. ]]" - )) - - -;;; @@ predicate functions -;;; - -(defun mime-view-header-visible-p (rcnum cinfo &optional ctype) - (or (null rcnum) - (progn - (setq ctype - (mime::content-info/type - (mime-article/rcnum-to-cinfo (cdr rcnum) cinfo) - )) - (member ctype mime-view-childrens-header-showing-Content-Type-list) - ))) - -(defun mime-view-body-visible-p (rcnum cinfo &optional ctype) - (let (ccinfo) - (or ctype - (setq ctype - (mime::content-info/type - (setq ccinfo (mime-article/rcnum-to-cinfo rcnum cinfo)) - )) - ) - (and (member ctype mime-view-default-showing-Content-Type-list) - (if (string-equal ctype "application/octet-stream") - (progn - (or ccinfo - (setq ccinfo (mime-article/rcnum-to-cinfo rcnum cinfo)) - ) - (member (mime::content-info/encoding ccinfo) - '(nil "7bit" "8bit")) - ) - t)) - )) - - -;;; @@ content button -;;; - -(defun mime-preview/insert-content-button - (rcnum cinfo ctype params subj encoding) - (save-restriction - (narrow-to-region (point)(point)) - (let ((access-type (assoc "access-type" params)) - (charset (assoc "charset" params)) - (num (or (cdr (assoc "x-part-number" params)) - (if (consp rcnum) - (mapconcat (function - (lambda (num) - (format "%s" (1+ num)) - )) - (reverse rcnum) ".") - "0")) - )) - (cond (access-type - (let ((server (assoc "server" params))) - (setq access-type (cdr access-type)) - (if server - (insert (format "[%s %s ([%s] %s)]\n" num subj - access-type (cdr server))) - (let ((site (cdr (assoc "site" params))) - (dir (cdr (assoc "directory" params))) - ) - (insert (format "[%s %s ([%s] %s:%s)]\n" num subj - access-type site dir)) - ))) - ) - (t - (insert (concat "[" num " " subj)) - (let ((rest - (if (setq charset (cdr charset)) - (if encoding - (format " <%s; %s (%s)>]\n" - ctype charset encoding) - (format " <%s; %s>]\n" ctype charset) - ) - (format " <%s>]\n" ctype) - ))) - (if (>= (+ (current-column)(length rest))(window-width)) - (setq rest (concat "\n\t" rest)) - ) - (insert rest) - )))) - (mime-add-button (point-min)(1- (point-max)) - (function mime-view-play-content)) - )) - -(defun mime-preview/default-content-button-function - (rcnum cinfo ctype params subj encoding) - (if (and (consp rcnum) - (not (member - ctype - mime-view-content-button-ignored-ctype-list))) - (mime-preview/insert-content-button - rcnum cinfo ctype params subj encoding) - )) - -(defvar mime-preview/content-button-function - (function mime-preview/default-content-button-function)) - - -;;; @@ content header filter -;;; - -(defun mime-preview/cut-header () - (goto-char (point-min)) - (while (and - (re-search-forward mime-view-ignored-field-regexp nil t) - (let* ((beg (match-beginning 0)) - (end (match-end 0)) - (name (buffer-substring beg end)) - ) - (if (not (string-match mime-view-visible-field-regexp name)) - (delete-region - beg - (save-excursion - (and - (re-search-forward "^\\([^ \t]\\|$\\)" nil t) - (match-beginning 0) - ))) - ) - t))) - ) - -(defun mime-view-default-content-header-filter () - (mime-preview/cut-header) - (eword-decode-header) - ) - -(defvar mime-view-content-header-filter-alist nil) - - -;;; @@ content filter -;;; - -(defvar mime-view-content-filter-alist - '(("text/enriched" . mime-preview/filter-for-text/enriched) - ("text/richtext" . mime-preview/filter-for-text/richtext) - (t . mime-preview/filter-for-text/plain) - )) - - -;;; @@ content separator -;;; - -(defun mime-preview/default-content-separator (rcnum cinfo ctype params subj) - (if (and (not (mime-view-header-visible-p rcnum cinfo ctype)) - (not (mime-view-body-visible-p rcnum cinfo ctype)) - ) - (progn - (goto-char (point-max)) - (insert "\n") - ))) - - -;;; @@ buffer local variables -;;; - -;; for XEmacs -(defvar mime::article/preview-buffer nil) -(defvar mime::article/code-converter nil) -(defvar mime::preview/article-buffer nil) - -(make-variable-buffer-local 'mime::article/content-info) -(make-variable-buffer-local 'mime::article/preview-buffer) -(make-variable-buffer-local 'mime::article/code-converter) - -(make-variable-buffer-local 'mime::preview/mother-buffer) -(make-variable-buffer-local 'mime::preview/content-list) -(make-variable-buffer-local 'mime::preview/article-buffer) -(make-variable-buffer-local 'mime::preview/original-major-mode) -(make-variable-buffer-local 'mime::preview/original-window-configuration) - - -;;; @@ quitting method -;;; - -(defvar mime-view-quitting-method-alist - '((mime/show-message-mode - . mime-view-quitting-method-for-mime/show-message-mode))) - -(defvar mime-view-over-to-previous-method-alist nil) -(defvar mime-view-over-to-next-method-alist nil) - -(defvar mime-view-show-summary-method nil) - - -;;; @@ following method -;;; - -(defvar mime-view-following-method-alist nil) - -(defvar mime-view-following-required-fields-list - '("From")) - - -;;; @@ X-Face -;;; - -;; hack from Gnus 5.0.4. - -(defvar mime-view-x-face-to-pbm-command - "{ echo '/* Width=48, Height=48 */'; uncompface; } | icontopbm") - -(defvar mime-view-x-face-command - (concat mime-view-x-face-to-pbm-command - " | xv -quit -") - "String to be executed to display an X-Face field. -The command will be executed in a sub-shell asynchronously. -The compressed face will be piped to this command.") - -(defun mime-view-x-face-function () - "Function to display X-Face field. You can redefine to customize." - ;; 1995/10/12 (c.f. tm-eng:130) - ;; fixed by Eric Ding - (save-restriction - (narrow-to-region (point-min) (re-search-forward "^$" nil t)) - ;; end - (goto-char (point-min)) - (if (re-search-forward "^X-Face:[ \t]*" nil t) - (let ((beg (match-end 0)) - (end (std11-field-end)) - ) - (call-process-region beg end "sh" nil 0 nil - "-c" mime-view-x-face-command) - )))) - - -;;; @@ utility -;;; - -(defun mime-preview/get-original-major-mode () - (if mime::preview/mother-buffer - (save-excursion - (set-buffer mime::preview/mother-buffer) - (mime-preview/get-original-major-mode) - ) - mime::preview/original-major-mode)) - - -;;; @ data structures -;;; - -;;; @@ preview-content-info -;;; - -(define-structure mime::preview-content-info - point-min point-max buffer content-info) - - -;;; @ buffer setup -;;; - -(defun mime-view-setup-buffer (&optional ctl encoding ibuf obuf) - (if ibuf - (progn - (get-buffer ibuf) - (set-buffer ibuf) - )) - (or mime-view-redisplay - (setq mime::article/content-info (mime-parse-message ctl encoding)) - ) - (let ((ret (mime-view-make-preview-buffer obuf))) - (setq mime::article/preview-buffer (car ret)) - ret)) - -(defun mime-view-make-preview-buffer (&optional obuf) - (let* ((cinfo mime::article/content-info) - (pcl (mime/flatten-content-info cinfo)) - (dest (make-list (length pcl) nil)) - (the-buf (current-buffer)) - (mode major-mode) - ) - (or obuf - (setq obuf (concat "*Preview-" (buffer-name the-buf) "*"))) - (set-buffer (get-buffer-create obuf)) - (setq buffer-read-only nil) - (widen) - (erase-buffer) - (setq mime::preview/article-buffer the-buf) - (setq mime::preview/original-major-mode mode) - (setq major-mode 'mime-view-mode) - (setq mode-name "MIME-View") - (let ((drest dest)) - (while pcl - (setcar drest - (mime-preview/display-content (car pcl) cinfo the-buf obuf)) - (setq pcl (cdr pcl) - drest (cdr drest)) - )) - (set-buffer-modified-p nil) - (setq buffer-read-only t) - (set-buffer the-buf) - (list obuf dest) - )) - -(defun mime-preview/display-content (content cinfo ibuf obuf) - (let* ((beg (mime::content-info/point-min content)) - (end (mime::content-info/point-max content)) - (ctype (mime::content-info/type content)) - (params (mime::content-info/parameters content)) - (encoding (mime::content-info/encoding content)) - (rcnum (mime::content-info/rcnum content)) - he e nb ne subj) - (set-buffer ibuf) - (goto-char beg) - (setq he (if (re-search-forward "^$" nil t) - (1+ (match-end 0)) - end)) - (if (> he end) - (setq he end) - ) - (save-restriction - (narrow-to-region beg end) - (setq subj - (eword-decode-string - (mime-article/get-subject params encoding))) - ) - (set-buffer obuf) - (setq nb (point)) - (narrow-to-region nb nb) - (funcall mime-preview/content-button-function - rcnum cinfo ctype params subj encoding) - (if (mime-view-header-visible-p rcnum cinfo ctype) - (mime-preview/display-header beg he) - ) - (if (and (null rcnum) - (member - ctype mime-view-content-button-visible-ctype-list)) - (save-excursion - (goto-char (point-max)) - (mime-preview/insert-content-button - rcnum cinfo ctype params subj encoding) - )) - (cond ((mime-view-body-visible-p rcnum cinfo ctype) - (mime-preview/display-body he end - rcnum cinfo ctype params subj encoding) - ) - ((equal ctype "message/partial") - (mime-preview/display-message/partial) - ) - ((and (null rcnum) - (null (mime::content-info/children cinfo)) - ) - (goto-char (point-max)) - (mime-preview/insert-content-button - rcnum cinfo ctype params subj encoding) - )) - (mime-preview/default-content-separator rcnum cinfo ctype params subj) - (prog1 - (progn - (setq ne (point-max)) - (widen) - (mime::preview-content-info/create nb (1- ne) ibuf content) - ) - (goto-char ne) - ))) - -(defun mime-preview/display-header (beg end) - (save-restriction - (narrow-to-region (point)(point)) - (insert-buffer-substring mime::preview/article-buffer beg end) - (let ((f (cdr (assq mime::preview/original-major-mode - mime-view-content-header-filter-alist)))) - (if (functionp f) - (funcall f) - (mime-view-default-content-header-filter) - )) - (run-hooks 'mime-view-content-header-filter-hook) - )) - -(defun mime-preview/display-body (beg end - rcnum cinfo ctype params subj encoding) - (save-restriction - (narrow-to-region (point-max)(point-max)) - (insert-buffer-substring mime::preview/article-buffer beg end) - (let ((f (cdr (or (assoc ctype mime-view-content-filter-alist) - (assq t mime-view-content-filter-alist))))) - (and (functionp f) - (funcall f ctype params encoding) - ) - ))) - -(defun mime-preview/display-message/partial () - (save-restriction - (goto-char (point-max)) - (if (not (search-backward "\n\n" nil t)) - (insert "\n") - ) - (let ((be (point-max))) - (narrow-to-region be be) - (insert mime-view-announcement-for-message/partial) - (mime-add-button (point-min)(point-max) - (function mime-view-play-content)) - ))) - -(defun mime-article/get-uu-filename (param &optional encoding) - (if (member (or encoding - (cdr (assq 'encoding param)) - ) - mime-view-uuencode-encoding-name-list) - (save-excursion - (or (if (re-search-forward "^begin [0-9]+ " nil t) - (if (looking-at ".+$") - (buffer-substring (match-beginning 0)(match-end 0)) - )) - "")) - )) - -(defun mime-article/get-subject (param &optional encoding) - (or (std11-find-field-body '("Content-Description" "Subject")) - (let (ret) - (if (or (and (setq ret (mime/Content-Disposition)) - (setq ret (assoc "filename" (cdr ret))) - ) - (setq ret (assoc "name" param)) - (setq ret (assoc "x-name" param)) - ) - (std11-strip-quoted-string (cdr ret)) - )) - (mime-article/get-uu-filename param encoding) - "")) - - -;;; @ content information -;;; - -(defun mime-article/point-content-number (p &optional cinfo) - (or cinfo - (setq cinfo mime::article/content-info) - ) - (let ((b (mime::content-info/point-min cinfo)) - (e (mime::content-info/point-max cinfo)) - (c (mime::content-info/children cinfo)) - ) - (if (and (<= b p)(<= p e)) - (or (let (co ret (sn 0)) - (catch 'tag - (while c - (setq co (car c)) - (setq ret (mime-article/point-content-number p co)) - (cond ((eq ret t) (throw 'tag (list sn))) - (ret (throw 'tag (cons sn ret))) - ) - (setq c (cdr c)) - (setq sn (1+ sn)) - ))) - t)))) - -(defun mime-article/rcnum-to-cinfo (rcnum &optional cinfo) - (or cinfo - (setq cinfo mime::article/content-info) - ) - (find-if (function - (lambda (ci) - (equal (mime::content-info/rcnum ci) rcnum) - )) - (mime/flatten-content-info cinfo) - )) - -(defun mime-article/cnum-to-cinfo (cn &optional cinfo) - (or cinfo - (setq cinfo mime::article/content-info) - ) - (if (eq cn t) - cinfo - (let ((sn (car cn))) - (if (null sn) - cinfo - (let ((rc (nth sn (mime::content-info/children cinfo)))) - (if rc - (mime-article/cnum-to-cinfo (cdr cn) rc) - )) - )))) - -(defun mime/flatten-content-info (&optional cinfo) - (or cinfo - (setq cinfo mime::article/content-info) - ) - (let ((dest (list cinfo)) - (rcl (mime::content-info/children cinfo)) - ) - (while rcl - (setq dest (nconc dest (mime/flatten-content-info (car rcl)))) - (setq rcl (cdr rcl)) - ) - dest)) - -(defun mime-preview/point-pcinfo (p &optional pcl) - (or pcl - (setq pcl mime::preview/content-list) - ) - (catch 'tag - (let ((r pcl) cell) - (while r - (setq cell (car r)) - (if (and (<= (mime::preview-content-info/point-min cell) p) - (<= p (mime::preview-content-info/point-max cell)) - ) - (throw 'tag cell) - ) - (setq r (cdr r)) - )) - (car (last pcl)) - )) - - -;;; @ MIME viewer mode -;;; - -(defconst mime-view-menu-title "MIME-View") -(defconst mime-view-menu-list - '((up "Move to upper content" mime-view-up-content) - (previous "Move to previous content" mime-view-previous-content) - (next "Move to next content" mime-view-next-content) - (scroll-down "Scroll to previous content" mime-view-scroll-down-content) - (scroll-up "Scroll to next content" mime-view-scroll-up-content) - (play "Play Content" mime-view-play-content) - (extract "Extract Content" mime-view-extract-content) - (print "Print" mime-view-print-content) - (x-face "Show X Face" mime-view-display-x-face) - ) - "Menu for MIME Viewer") - -(cond (running-xemacs - (defvar mime-view-xemacs-popup-menu - (cons mime-view-menu-title - (mapcar (function - (lambda (item) - (vector (nth 1 item)(nth 2 item) t) - )) - mime-view-menu-list))) - (defun mime-view-xemacs-popup-menu (event) - "Popup the menu in the MIME Viewer buffer" - (interactive "e") - (select-window (event-window event)) - (set-buffer (event-buffer event)) - (popup-menu 'mime-view-xemacs-popup-menu)) - (defvar mouse-button-2 'button2) - ) - (t - (defvar mouse-button-2 [mouse-2]) - )) - -(defun mime-view-define-keymap (&optional default) - (let ((mime-view-mode-map (if (keymapp default) - (copy-keymap default) - (make-sparse-keymap) - ))) - (define-key mime-view-mode-map - "u" (function mime-view-up-content)) - (define-key mime-view-mode-map - "p" (function mime-view-previous-content)) - (define-key mime-view-mode-map - "n" (function mime-view-next-content)) - (define-key mime-view-mode-map - "\e\t" (function mime-view-previous-content)) - (define-key mime-view-mode-map - "\t" (function mime-view-next-content)) - (define-key mime-view-mode-map - " " (function mime-view-scroll-up-content)) - (define-key mime-view-mode-map - "\M- " (function mime-view-scroll-down-content)) - (define-key mime-view-mode-map - "\177" (function mime-view-scroll-down-content)) - (define-key mime-view-mode-map - "\C-m" (function mime-view-next-line-content)) - (define-key mime-view-mode-map - "\C-\M-m" (function mime-view-previous-line-content)) - (define-key mime-view-mode-map - "v" (function mime-view-play-content)) - (define-key mime-view-mode-map - "e" (function mime-view-extract-content)) - (define-key mime-view-mode-map - "\C-c\C-p" (function mime-view-print-content)) - (define-key mime-view-mode-map - "a" (function mime-view-follow-content)) - (define-key mime-view-mode-map - "q" (function mime-view-quit)) - (define-key mime-view-mode-map - "h" (function mime-view-show-summary)) - (define-key mime-view-mode-map - "\C-c\C-x" (function mime-view-kill-buffer)) - (define-key mime-view-mode-map - "<" (function beginning-of-buffer)) - (define-key mime-view-mode-map - ">" (function end-of-buffer)) - (define-key mime-view-mode-map - "?" (function describe-mode)) - (if (functionp default) - (setq mime-view-mode-map - (append mime-view-mode-map (list (cons t default))) - )) - (if mouse-button-2 - (define-key mime-view-mode-map - mouse-button-2 (function mime-button-dispatcher)) - ) - (cond (running-xemacs - (define-key mime-view-mode-map - mouse-button-3 (function mime-view-xemacs-popup-menu)) - ) - ((>= emacs-major-version 19) - (define-key mime-view-mode-map [menu-bar mime-view] - (cons mime-view-menu-title - (make-sparse-keymap mime-view-menu-title))) - (mapcar (function - (lambda (item) - (define-key mime-view-mode-map - (vector 'menu-bar 'mime-view (car item)) - (cons (nth 1 item)(nth 2 item)) - ) - )) - (reverse mime-view-menu-list) - ) - )) - (use-local-map mime-view-mode-map) - (run-hooks 'mime-view-define-keymap-hook) - )) - -(defun mime-view-mode (&optional mother ctl encoding ibuf obuf - default-keymap-or-function) - "Major mode for viewing MIME message. - -Here is a list of the standard keys for mime-view-mode. - -key feature ---- ------- - -u Move to upper content -p or M-TAB Move to previous content -n or TAB Move to next content -SPC Scroll up or move to next content -M-SPC or DEL Scroll down or move to previous content -RET Move to next line -M-RET Move to previous line -v Decode current content as `play mode' -e Decode current content as `extract mode' -C-c C-p Decode current content as `print mode' -a Followup to current content. -x Display X-Face -q Quit -button-2 Move to point under the mouse cursor - and decode current content as `play mode' -" - (interactive) - (let ((buf (get-buffer mime/output-buffer-name))) - (if buf - (save-excursion - (set-buffer buf) - (erase-buffer) - ))) - (let ((ret (mime-view-setup-buffer ctl encoding ibuf obuf)) - (win-conf (current-window-configuration)) - ) - (prog1 - (switch-to-buffer (car ret)) - (setq mime::preview/original-window-configuration win-conf) - (if mother - (progn - (setq mime::preview/mother-buffer mother) - )) - (mime-view-define-keymap default-keymap-or-function) - (setq mime::preview/content-list (nth 1 ret)) - (goto-char - (let ((ce (mime::preview-content-info/point-max - (car mime::preview/content-list) - )) - e) - (goto-char (point-min)) - (search-forward "\n\n" nil t) - (setq e (match-end 0)) - (if (<= e ce) - e - ce))) - (run-hooks 'mime-view-mode-hook) - ))) - -(defun mime-preview/point-content-number (point) - (save-window-excursion - (let ((pc (mime-preview/point-pcinfo (point))) - cinfo) - (switch-to-buffer (mime::preview-content-info/buffer pc)) - (setq cinfo (mime::preview-content-info/content-info pc)) - (mime-article/point-content-number (mime::content-info/point-min cinfo)) - ))) - -(defun mime-preview/cinfo-to-pcinfo (cinfo) - (let ((rpcl mime::preview/content-list) cell) - (catch 'tag - (while rpcl - (setq cell (car rpcl)) - (if (eq cinfo (mime::preview-content-info/content-info cell)) - (throw 'tag cell) - ) - (setq rpcl (cdr rpcl)) - )))) - -(autoload 'mime-preview/decode-content "mime-play") - -(defvar mime-view-decoding-mode "play" "MIME body decoding mode") - -(defun mime-view-play-content () - (interactive) - (let ((mime-view-decoding-mode "play")) - (mime-preview/decode-content) - )) - -(defun mime-view-extract-content () - (interactive) - (let ((mime-view-decoding-mode "extract")) - (mime-preview/decode-content) - )) - -(defun mime-view-print-content () - (interactive) - (let ((mime-view-decoding-mode "print")) - (mime-preview/decode-content) - )) - -(defun mime-view-follow-content () - (interactive) - (let ((root-cinfo - (mime::preview-content-info/content-info - (car mime::preview/content-list))) - pc p-beg p-end cinfo rcnum) - (let ((rest mime::preview/content-list) - b e cell len rc) - (if (catch 'tag - (while (setq cell (car rest)) - (setq b (mime::preview-content-info/point-min cell) - e (mime::preview-content-info/point-max cell)) - (setq rest (cdr rest)) - (if (and (<= b (point))(<= (point) e)) - (throw 'tag cell) - ) - )) - (progn - (setq pc cell - cinfo (mime::preview-content-info/content-info pc) - rcnum (mime::content-info/rcnum cinfo)) - (setq len (length rcnum)) - (setq p-beg (mime::preview-content-info/point-min pc) - p-end (mime::preview-content-info/point-max pc)) - (while (and (setq cell (car rest)) - (progn - (setq rc - (mime::content-info/rcnum - (mime::preview-content-info/content-info - cell))) - (equal rcnum - (nthcdr (- (length rc) len) rc)) - )) - (setq p-end (mime::preview-content-info/point-max cell)) - (setq rest (cdr rest)) - )))) - (if pc - (let* ((mode (mime-preview/get-original-major-mode)) - (new-name (format "%s-%s" (buffer-name) (reverse rcnum))) - new-buf - (the-buf (current-buffer)) - (a-buf mime::preview/article-buffer) - (hb (mime::content-info/point-min cinfo)) - (he (mime::content-info/point-max cinfo)) - fields from to cc reply-to subj mid f) - (save-excursion - (set-buffer (setq new-buf (get-buffer-create new-name))) - (erase-buffer) - (insert-buffer-substring the-buf p-beg p-end) - (goto-char (point-min)) - (if (mime-view-header-visible-p rcnum root-cinfo) - (delete-region (goto-char (point-min)) - (if (re-search-forward "^$" nil t) - (match-end 0) - (point-min))) - ) - (goto-char (point-min)) - (insert "\n") - (goto-char (point-min)) - (let ((rcnum (mime::content-info/rcnum cinfo)) ci str) - (while (progn - (setq str - (save-excursion - (set-buffer a-buf) - (setq ci (mime-article/rcnum-to-cinfo rcnum)) - (save-restriction - (narrow-to-region - (mime::content-info/point-min ci) - (mime::content-info/point-max ci) - ) - (std11-header-string-except - (concat "^" - (apply (function regexp-or) fields) - ":") "")))) - (if (string-equal (mime::content-info/type ci) - "message/rfc822") - nil - (if str - (insert str) - ) - rcnum)) - (setq fields (std11-collect-field-names) - rcnum (cdr rcnum)) - ) - ) - (let ((rest mime-view-following-required-fields-list)) - (while rest - (let ((field-name (car rest))) - (or (std11-field-body field-name) - (insert - (format - (concat field-name - ": " - (save-excursion - (set-buffer the-buf) - (set-buffer mime::preview/mother-buffer) - (set-buffer mime::preview/article-buffer) - (std11-field-body field-name) - ) - "\n"))) - )) - (setq rest (cdr rest)) - )) - (eword-decode-header) - ) - (let ((f (cdr (assq mode mime-view-following-method-alist)))) - (if (functionp f) - (funcall f new-buf) - (message - (format - "Sorry, following method for %s is not implemented yet." - mode)) - )) - )))) - -(defun mime-view-display-x-face () - (interactive) - (save-window-excursion - (set-buffer mime::preview/article-buffer) - (mime-view-x-face-function) - )) - -(defun mime-view-up-content () - (interactive) - (let* ((pc (mime-preview/point-pcinfo (point))) - (cinfo (mime::preview-content-info/content-info pc)) - (rcnum (mime::content-info/rcnum cinfo)) - ) - (if rcnum - (let ((r (save-excursion - (set-buffer (mime::preview-content-info/buffer pc)) - (mime-article/rcnum-to-cinfo (cdr rcnum)) - )) - (rpcl mime::preview/content-list) - cell) - (while (and - (setq cell (car rpcl)) - (not (eq r (mime::preview-content-info/content-info cell))) - ) - (setq rpcl (cdr rpcl)) - ) - (goto-char (mime::preview-content-info/point-min cell)) - ) - (mime-view-quit) - ))) - -(defun mime-view-previous-content () - (interactive) - (let* ((pcl mime::preview/content-list) - (p (point)) - (i (- (length pcl) 1)) - beg) - (catch 'tag - (while (> i 0) - (setq beg (mime::preview-content-info/point-min (nth i pcl))) - (if (> p beg) - (throw 'tag (goto-char beg)) - ) - (setq i (- i 1)) - ) - (let ((f (assq mime::preview/original-major-mode - mime-view-over-to-previous-method-alist))) - (if f - (funcall (cdr f)) - )) - ) - )) - -(defun mime-view-next-content () - (interactive) - (let ((pcl mime::preview/content-list) - (p (point)) - beg) - (catch 'tag - (while pcl - (setq beg (mime::preview-content-info/point-min (car pcl))) - (if (< p beg) - (throw 'tag (goto-char beg)) - ) - (setq pcl (cdr pcl)) - ) - (let ((f (assq mime::preview/original-major-mode - mime-view-over-to-next-method-alist))) - (if f - (funcall (cdr f)) - )) - ) - )) - -(defun mime-view-scroll-up-content (&optional h) - (interactive) - (or h - (setq h (- (window-height) 1)) - ) - (if (= (point) (point-max)) - (let ((f (assq mime::preview/original-major-mode - mime-view-over-to-next-method-alist))) - (if f - (funcall (cdr f)) - )) - (let ((pcl mime::preview/content-list) - (p (point)) - np beg) - (setq np - (or (catch 'tag - (while pcl - (setq beg (mime::preview-content-info/point-min (car pcl))) - (if (< p beg) - (throw 'tag beg) - ) - (setq pcl (cdr pcl)) - )) - (point-max))) - (forward-line h) - (if (> (point) np) - (goto-char np) - ) - ;;(show-subtree) - )) - ) - -(defun mime-view-scroll-down-content (&optional h) - (interactive) - (or h - (setq h (- (window-height) 1)) - ) - (if (= (point) (point-min)) - (let ((f (assq mime::preview/original-major-mode - mime-view-over-to-previous-method-alist))) - (if f - (funcall (cdr f)) - )) - (let ((pcl mime::preview/content-list) - (p (point)) - pp beg) - (setq pp - (or (let ((i (- (length pcl) 1))) - (catch 'tag - (while (> i 0) - (setq beg (mime::preview-content-info/point-min - (nth i pcl))) - (if (> p beg) - (throw 'tag beg) - ) - (setq i (- i 1)) - ))) - (point-min))) - (forward-line (- h)) - (if (< (point) pp) - (goto-char pp) - ))) - ) - -(defun mime-view-next-line-content () - (interactive) - (mime-view-scroll-up-content 1) - ) - -(defun mime-view-previous-line-content () - (interactive) - (mime-view-scroll-down-content 1) - ) - -(defun mime-view-quit () - (interactive) - (let ((r (save-excursion - (set-buffer (mime::preview-content-info/buffer - (mime-preview/point-pcinfo (point)))) - (assq major-mode mime-view-quitting-method-alist) - ))) - (if r - (funcall (cdr r)) - ))) - -(defun mime-view-show-summary () - (interactive) - (let ((r (save-excursion - (set-buffer - (mime::preview-content-info/buffer - (mime-preview/point-pcinfo (point))) - ) - (assq major-mode mime-view-show-summary-method) - ))) - (if r - (funcall (cdr r)) - ))) - -(defun mime-view-kill-buffer () - (interactive) - (kill-buffer (current-buffer)) - ) - - -;;; @ end -;;; - -(provide 'mime-view) - -(run-hooks 'mime-view-load-hook) - -;;; mime-view.el ends here diff --git a/semi-setup.el b/semi-setup.el deleted file mode 100644 index 9e6a0af..0000000 --- a/semi-setup.el +++ /dev/null @@ -1,140 +0,0 @@ -;;; semi-setup.el --- setup file for MIME-View. - -;; Copyright (C) 1994,1995,1996,1997 Free Software Foundation, Inc. - -;; Author: MORIOKA Tomohiko -;; Version: $Id: semi-setup.el,v 0.15 1997-03-14 08:46:14 morioka Exp $ -;; Keywords: mail, news, MIME, multimedia, multilingual, encoded-word - -;; This file is part of SEMI (SEMI is Emacs MIME Interfaces). - -;; This program is free software; you can redistribute it and/or -;; modify it under the terms of the GNU General Public License as -;; published by the Free Software Foundation; either version 2, or (at -;; your option) any later version. - -;; This program is distributed in the hope that it will be useful, but -;; WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Code: - -(require 'mime-def) -(require 'file-detect) - - -;;; @ for mime-view -;;; - -(call-after-loaded - 'mime-view - (function - (lambda () - ;; for message/partial - (require 'mime-partial) - ))) - - -;; for image/* and X-Face -(defvar mime-setup-enable-inline-image - (and window-system - (or running-xemacs - (and (featurep 'mule)(module-installed-p 'bitmap)) - )) - "*If it is non-nil, semi-setup sets up to use mime-image.") - -(if mime-setup-enable-inline-image - (call-after-loaded 'mime-view - (function - (lambda () - (require 'mime-image) - ))) - ) - - -(defvar mime-setup-enable-pgp - (module-installed-p 'mailcrypt) - "*If it is non-nil, semi-setup sets uf to use mime-pgp.") - -;; for PGP -(if mime-setup-enable-pgp - (call-after-loaded 'mime-view - (function - (lambda () - (require 'mime-pgp) - ))) - ) - - -;;; @ for mime-edit -;;; - -(defun mime-setup-decode-message-header () - (save-excursion - (save-restriction - (goto-char (point-min)) - (narrow-to-region - (point-min) - (if (re-search-forward - (concat "^" (regexp-quote mail-header-separator) "$") - nil t) - (match-beginning 0) - (point-max) - )) - (eword-decode-header) - (set-buffer-modified-p nil) - ))) - -(add-hook 'mime-edit-mode-hook 'mime-setup-decode-message-header) - - -;;; @@ variables -;;; - -(defvar mime-setup-use-signature t - "If it is not nil, mime-setup sets up to use signature.el.") - -(defvar mime-setup-default-signature-key "\C-c\C-s" - "*Key to insert signature.") - -(defvar mime-setup-signature-key-alist '((mail-mode . "\C-c\C-w")) - "Alist of major-mode vs. key to insert signature.") - - -;;; @@ for signature -;;; - -(defun mime-setup-set-signature-key () - (let ((key (or (cdr (assq major-mode mime-setup-signature-key-alist)) - mime-setup-default-signature-key))) - (define-key (current-local-map) key (function insert-signature)) - )) - -(if mime-setup-use-signature - (progn - (autoload 'insert-signature "signature" "Insert signature" t) - (add-hook 'mime-edit-mode-hook 'mime-setup-set-signature-key) - (setq gnus-signature-file nil) - (setq mail-signature nil) - (setq message-signature nil) - )) - - -;;; @ for mu-cite -;;; - -(add-hook 'mu-cite/pre-cite-hook 'eword-decode-header) - - -;;; @ end -;;; - -(provide 'semi-setup) - -;;; semi-setup.el ends here