--- /dev/null
+;;;
+;;; tm-edit.el --- Simple MIME Composer for GNU Emacs
+;;;
+
+;; Copyright (C) 1993 UMEDA Masanobu
+;; Copyright (C) 1994,1995 MORIOKA Tomohiko
+
+;; Author: UMEDA Masanobu <umerin@mse.kyutech.ac.jp>
+;; MORIOKA Tomohiko <morioka@jaist.ac.jp>
+;; Keywords: mail, news, MIME, multimedia, multilingual
+
+;; This file is not part of GNU Emacs.
+
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; 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, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+;;; Commentary:
+
+;; This is an Emacs minor mode for editing Internet multimedia
+;; messages formatted in MIME (RFC 1521 and RFC 1522). 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 (a multilingual extension to Emacs 18 and 19) 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] or `ISO-2022-INT-1'. 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-mode automatically:
+;;
+;; (autoload 'mime-mode "mime" "Minor mode for editing MIME message." t)
+;;
+;; In case of Mail mode (includes VM mode), you need the following
+;; hook definition:
+;;
+;; (setq mail-mode-hook
+;; (list
+;; (function
+;; (lambda ()
+;; (mime-mode)))))
+;;
+;; In case of MH-E, you need the following hook definition:
+;;
+;; (setq mh-letter-mode-hook
+;; (list
+;; (function
+;; (lambda ()
+;; (mime-mode)
+;; (make-local-variable 'mail-header-separator)
+;; (setq mail-header-separator "--------")))))
+;;
+;; In case of News mode, you need the following hook definition:
+;;
+;; (setq news-reply-mode-hook
+;; (list
+;; (function
+;; (lambda ()
+;; (mime-mode)))))
+;;
+;; Followings are for message forwarding as content-type
+;; "message/rfc822".
+;;
+;; (setq rmail-mode-hook
+;; (list
+;; (function
+;; (lambda ()
+;; ;; Forward mail using MIME.
+;; (require 'mime)
+;; (substitute-key-definition 'rmail-forward
+;; 'mime-forward-from-rmail-using-mail
+;; (current-local-map))
+;; ))))
+;;
+;; (setq gnus-mail-forward-method 'mime-forward-from-gnus-using-mail)
+;; (setq gnus-summary-mode-hook
+;; (list
+;; (function
+;; (lambda ()
+;; ;; Forward article using MIME.
+;; (require 'mime)
+;; ))))
+;;
+;; In case of Emacs 19, it is possible to emphasize the message tags
+;; using font-lock mode as follows:
+;;
+;; (setq mime-mode-hook
+;; (list
+;; (function
+;; (lambda ()
+;; (font-lock-mode 1)
+;; (setq font-lock-keywords (list tm-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-2022-JP]]
+;; \e$B$3$l$O\e(B charset \e$B$r\e(B ISO-2022-JP \e$B$K;XDj$7$?F|K\8l$N\e(B plain \e$B%F%-%9%H$G$9\e(B.
+;;
+;;--[[text/richtext]]
+;; <center>This is a richtext.</center>
+;;
+;;--[[image/gif][base64]]^M...image encoded in base64 comes here...
+;;
+;;--[[audio/basic][base64]]^M...audio encoded in base64 comes here...
+
+;; LCD Archive Entry:
+;; mime|Masanobu UMEDA|umerin@mse.kyutech.ac.jp|
+;; Simple MIME Composer|
+;; $Date: 1995/10/26 11:12:05 $|$Revision: 7.11 $|~/misc/mime.el.Z|
+
+;;; Code:
+
+(require 'sendmail)
+(require 'mail-utils)
+(require 'mel)
+(require 'tl-822)
+(require 'tl-list)
+(require 'tm-view)
+(require 'tm-ew-e)
+(require 'signature)
+
+
+;;; @ version
+;;;
+
+(defconst tm-edit/RCS-ID
+ "$Id: tm-edit.el,v 7.11 1995/10/26 11:12:05 morioka Exp $")
+
+(defconst tm-edit/version (get-version-string tm-edit/RCS-ID))
+
+
+;;; @ variables
+;;;
+
+(defvar mime-prefix "\C-c\C-x"
+ "*Keymap prefix for MIME commands.")
+
+(defvar mime-signature-file "~/.signature.rtf"
+ "*Signature file to be included as a part of a multipart message.")
+
+(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-body-charset-chooser
+ (cond ((boundp 'NEMACS)
+ (function mime-body-charset-chooser-for-nemacs))
+ ((featurep 'mule)
+ (function mime-body-charset-chooser-for-mule))
+ ((string-match "^19\\." emacs-version)
+ (function mime-body-charset-chooser-for-emacs19))
+ (t ;ASCII only emacs
+ (function mime-body-charset-chooser-for-emacs18)))
+ "*Function to identify charset and encoding of a text in a given region.
+The value is a form of (CHARSET . ENCODING), where ENCODING must be a
+full name, such as base64.")
+
+(defvar mime-string-encoder
+ (cond ((boundp 'NEMACS)
+ (function mime-string-encoder-for-nemacs))
+ ((featurep 'mule)
+ (function mime-string-encoder-for-mule))
+ ((string-match "^19\\." emacs-version)
+ (function mime-string-encoder-for-emacs19))
+ (t ;ASCII only emacs
+ (function mime-string-encoder-for-emacs18)))
+ "*Function to encode a string for given encoding method.
+The method is a form of (CHARSET . ENCODING).")
+
+(defvar mime-voice-recorder
+ (function mime-voice-recorder-for-sun)
+ "*Function to record a voice message and return a buffer that contains it.")
+
+(defvar mime-mode-hook nil
+ "*Hook called when enter MIME mode.")
+
+(defvar mime-translate-hook nil
+ "*Hook called before translating into a MIME compliant message.
+To insert a signature file specified by mime-signature-file
+(`.signature.rtf' by default) automatically, call the function
+`tm-edit/insert-signature' from this hook.")
+
+(defvar mime-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")
+ ))
+ ("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" "binary" "ascii"))
+ ("ftp" ("site") ("directory") ("name") ("mode" "binary" "ascii"))
+ ("tftp" ("site") ("name"))
+ ("afs" ("site") ("name"))
+ ("local-file" ("site") ("name"))
+ ("mail-server" ("server" "ftpmail@nic.karrn.ad.jp"))
+ ))
+ ("rfc822")
+ )
+ ("application"
+ ("octet-stream"
+ ("name")
+ ("type" "" "tar" "shar")
+ ("conversions"))
+ ("postscript")
+ ("x-kiss" ("x-cnf")))
+ ("image"
+ ("gif")
+ ("jpeg")
+ ("x-pic")
+ ("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)
+ ("\\.html$"
+ "text" "html" nil nil)
+ ("\\.ps$"
+ "application" "postscript" nil "quoted-printable")
+ ("\\.gif$"
+ "image" "gif" nil "base64"
+ (("Content-Description" . file))
+ )
+ ("\\.jpg$"
+ "image" "jpeg" nil "base64")
+ ("\\.xwd$"
+ "image" "x-xwd" nil "base64")
+ ("\\.xbm$"
+ "image" "x-xbm" nil "base64")
+ ("\\.pic$"
+ "image" "x-pic" nil "base64"
+ (("Content-Description" . file))
+ )
+ ("\\.tiff$"
+ "image" "tiff" nil "base64")
+ ("\\.au$"
+ "audio" "basic" nil "base64")
+ ("\\.mpg$"
+ "video" "mpeg" nil "base64")
+ ("\\.el$"
+ "application" "octet-stream" (("name" . file)
+ ("type" . "emacs-lisp")) "7bit")
+ ("\\.tar.gz$"
+ "application" "octet-stream" (("name" . file)
+ ("type" . "tar")
+ ("conversions" . "gzip")) nil)
+ ("\\.diff$"
+ "application" "octet-stream" (("name" . file)
+ ("type" . "patch")) nil)
+ ("\\.signature"
+ "text" "plain" nil nil)
+ (".*" nil nil nil nil)
+ )
+ "*Alist of file name, types, parameters, and default encoding.
+If encoding is nil, it is determined from its contents.")
+
+(defvar tm-edit/split-message t)
+
+(defvar tm-edit/message-default-max-length 1000)
+
+(defvar tm-edit/message-max-length-alist
+ '((news-reply-mode . 500)))
+
+(defconst tm-edit/message-nuke-headers
+ "\\(^Content-\\|^Subject:\\|^Mime-Version:\\)")
+
+(defvar tm-edit/message-blind-headers "\\(^[BDFbdf]cc:\\|^cc:[ \t]*$\\)")
+
+(defvar tm-edit/message-default-sender-alist
+ '((mail-mode . mail-send-and-exit)
+ (mh-letter-mode . mh-send-letter)
+ (news-reply-mode . gnus-inews-news)))
+
+(defvar tm-edit/message-sender-alist
+ '((mail-mode
+ . (lambda ()
+ (interactive)
+ (sendmail-send-it)
+ ))
+ (mh-letter-mode
+ . (lambda (&optional arg)
+ (interactive "P")
+ (write-region (point-min) (point-max)
+ tm-edit/draft-file-name)
+ (message
+ (format "Sending %d/%d..." (+ i 1) total))
+ (cond (arg
+ (pop-to-buffer "MH mail delivery")
+ (erase-buffer)
+ (mh-exec-cmd-output mh-send-prog t "-watch" "-nopush"
+ "-nodraftfolder"
+ mh-send-args tm-edit/draft-file-name)
+ (goto-char (point-max)) ; show the interesting part
+ (recenter -1)
+ (sit-for 1))
+ (t
+ (apply 'mh-exec-cmd-quiet t mh-send-prog
+ (mh-list-to-string
+ (list "-nopush" "-nodraftfolder"
+ "-noverbose" "-nowatch"
+ mh-send-args tm-edit/draft-file-name)))))
+ (message
+ (format "Sending %d/%d... done" (+ i 1) total))
+ ))
+ ))
+
+(defvar tm-edit/window-config-alist
+ '((mail-mode . nil)
+ (mh-letter-mode . mh-previous-window-config)
+ (news-reply-mode . (cond ((boundp 'gnus-winconf-post-news)
+ (prog1
+ gnus-winconf-post-news
+ (setq gnus-winconf-post-news nil)
+ ))
+ ((boundp 'gnus-prev-winconf)
+ (prog1
+ gnus-prev-winconf
+ (setq gnus-prev-winconf nil)
+ ))
+ ))
+ ))
+
+(defvar tm-edit/news-reply-mode-server-running nil)
+
+(defvar tm-edit/message-before-send-hook-alist
+ '((mh-letter-mode . mh-before-send-letter-hook)))
+
+(defvar tm-edit/message-after-send-hook-alist
+ '((mh-letter-mode
+ . (lambda ()
+ (if mh-annotate-char
+ (mh-annotate-msg mh-sent-from-msg
+ mh-sent-from-folder
+ mh-annotate-char
+ "-component" mh-annotate-field
+ "-text"
+ (format "\"%s %s\""
+ (mh-get-field "To:")
+ (mh-get-field "Cc:"))))))
+ ))
+
+(defvar tm-edit/message-inserter-alist nil)
+
+(defvar mime-tspecials-regexp "[][()<>@,;:\\\"/?.= \t]"
+ "*Specify MIME tspecials.
+Tspecials means any character that matches with it in header must be quoted.")
+
+(defconst tm-edit/single-part-tag-regexp
+ "^--[[][[]\\([^]]*\\)]\\([[]\\([^]]*\\)]\\|\\)]"
+ "*Regexp of MIME tag in the form of [[CONTENT-TYPE][ENCODING]].")
+
+(defconst tm-edit/multipart-beginning-regexp "^--<<\\([^<>]+\\)>>-{\n")
+
+(defconst tm-edit/multipart-end-regexp "^--}-<<\\([^<>]+\\)>>\n")
+
+(defconst tm-edit/beginning-tag-regexp
+ (regexp-or tm-edit/single-part-tag-regexp
+ tm-edit/multipart-beginning-regexp))
+
+(defconst tm-edit/end-tag-regexp
+ (regexp-or tm-edit/single-part-tag-regexp
+ tm-edit/multipart-end-regexp))
+
+(defconst tm-edit/tag-regexp
+ (regexp-or tm-edit/single-part-tag-regexp
+ tm-edit/multipart-beginning-regexp
+ tm-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.")
+
+(defvar mime-multipart-boundary "Multipart"
+ "*Boundary of a multipart message.")
+
+\f
+(defconst tm-edit/mime-version-value
+ (format "1.0 (generated by tm-edit %s)" tm-edit/version)
+ "MIME version number.")
+
+(defvar mime-mode-flag nil)
+(make-variable-buffer-local 'mime-mode-flag)
+
+(or (assq 'mime-mode-flag minor-mode-alist)
+ (setq minor-mode-alist
+ (cons (list 'mime-mode-flag " MIME") minor-mode-alist)))
+
+(defun mime-define-keymap (keymap)
+ "Add MIME commands to KEYMAP."
+ (if (not (keymapp keymap))
+ nil
+ (define-key keymap "\C-t" 'tm-edit/insert-text)
+ (define-key keymap "\C-i" 'tm-edit/insert-file)
+ (define-key keymap "\C-e" 'tm-edit/insert-external)
+ (define-key keymap "\C-v" 'tm-edit/insert-voice)
+ (define-key keymap "\C-y" 'tm-edit/insert-message)
+ (define-key keymap "\C-w" 'tm-edit/insert-signature)
+ (define-key keymap "\C-s" 'tm-edit/insert-signature)
+ (define-key keymap "\C-m" 'tm-edit/insert-tag)
+ (define-key keymap "a" 'tm-edit/enclose-alternative-region)
+ (define-key keymap "p" 'tm-edit/enclose-parallel-region)
+ (define-key keymap "m" 'tm-edit/enclose-mixed-region)
+ (define-key keymap "d" 'tm-edit/enclose-digest-region)
+ (define-key keymap "\C-p" 'tm-edit/preview-message)
+ (define-key keymap "\C-z" 'mime-mode-exit)
+ (define-key keymap "?" 'help-mime-mode)
+ ))
+
+(defconst tm-edit/menu
+ '("MIME"
+ ["Describe MIME Mode" help-mime-mode mime-mode-flag]
+ ["Insert File" tm-edit/insert-file mime-mode-flag]
+ ["Insert External" tm-edit/insert-external mime-mode-flag]
+ ["Insert Voice" tm-edit/insert-voice mime-mode-flag]
+ ["Insert Mail" tm-edit/insert-message mime-mode-flag]
+ ["Insert Signature" tm-edit/insert-signature mime-mode-flag]
+ ["Insert Text" tm-edit/insert-text mime-mode-flag]
+ ["Insert Tag" tm-edit/insert-tag mime-mode-flag]
+ ["Enclose as alternative"
+ tm-edit/enclose-alternative-region mime-mode-flag]
+ ["Enclose as parallel"
+ tm-edit/enclose-parallel-region mime-mode-flag]
+ ["Enclose as serial"
+ tm-edit/enclose-mixed-region mime-mode-flag]
+ ["Enclose as digest"
+ tm-edit/enclose-digest-region mime-mode-flag]
+ ["Preview Message" tm-edit/preview-message mime-mode-flag]
+ )
+ "MIME menubar entry.")
+
+(defun tm-edit/define-menu-for-emacs19 ()
+ "Define menu for Emacs 19."
+ (define-key (current-local-map) [menu-bar mime]
+ (cons "MIME" (make-sparse-keymap "MIME")))
+ (mapcar (function
+ (lambda (item)
+ (define-key (current-local-map)
+ (vector 'menu-bar 'mime (aref item 1))
+ (cons (aref item 0)(aref item 1))
+ )
+ ))
+ (reverse (cdr tm-edit/menu))
+ ))
+
+;;; modified by Pekka Marjola <pema@niksula.hut.fi>
+;;; 1995/9/5 (c.f. [tm-eng:69])
+(defun tm-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 mime-menu)
+ )))
+
+(defvar mime-xemacs-old-bindings nil
+ "A list of commands to restore old bindings.")
+
+(defun mime-xemacs-save-old-bindings (keymap funct)
+ "Save key bindings to a list for setting it back."
+ (let* ((key-bindings (where-is-internal funct keymap))
+ (key-binding nil))
+ (while key-bindings
+ (setq key-binding (pop key-bindings))
+ (setq mime-xemacs-old-bindings
+ (append mime-xemacs-old-bindings
+ (list (list 'define-key keymap key-binding
+ (list 'function funct))))))))
+;;; end
+
+;;;###autoload
+(defun mime-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
+using selective-display facility. 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.
+
+Emacs18: US-ASCII is only available.
+NEmacs: US-ASCII and ISO-2022-JP are available.
+Emacs19: US-ASCII and ISO-8859-1 are available.
+Mule: US-ASCII, ISO-8859-* (except for ISO-8859-6),
+ ISO-2022-JP, ISO-2022-JP-2 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.
+
+Following commands are available in addition to major mode commands:
+\\[tm-edit/insert-text] insert a text message.
+\\[tm-edit/insert-file] insert a (binary) file.
+\\[tm-edit/insert-external] insert a reference to external body.
+\\[tm-edit/insert-voice] insert a voice message.
+\\[tm-edit/insert-message] insert a mail or news message.
+\\[tm-edit/insert-signature] insert a signature file at end.
+\\[tm-edit/insert-tag] insert a new MIME tag.
+\\[tm-edit/enclose-alternative-region] Enclose as multipart/alternative.
+\\[tm-edit/enclose-parallel-region] Enclose as multipart/parallel.
+\\[tm-edit/enclose-mixed-region] Enclose as multipart/mixed.
+\\[tm-edit/enclose-digest-region] Enclose as multipart/digest.
+\\[tm-edit/preview-message] preview editing MIME message.
+\\[mime-mode-exit] exit and translate into a MIME compliant message.
+\\[tm-edit/exit-and-run] exit, translate and run the original command.
+\\[help-mime-mode] show this help.
+
+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-2022-JP]]
+ \e$B$3$l$O\e(B charset \e$B$r\e(B ISO-2022-JP \e$B$K;XDj$7$?F|K\8l$N\e(B plain \e$B%F%-%9\e(B
+ \e$B%H$G$9\e(B.
+ --[[text/richtext]]
+ <center>This is a richtext.</center>
+ --[[image/gif][base64]]^M...image encoded in base64 here...
+ --[[audio/basic][base64]]^M...audio encoded in base64 here...
+
+User customizable variables (not documented all of them):
+ mime-prefix
+ Specifies a key prefix for MIME minor mode commands.
+
+ mime-signature-file
+ Specifies a signature file to be included as part of a multipart
+ message.
+
+ 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-fill-header
+ Fill header fields that contain encoded-words if non-nil.
+
+ mime-auto-hide-body
+ Hide a non-textual body message encoded in base64 after insertion
+ if non-nil.
+
+ mime-body-charset-chooser
+ Specifies a function to identify charset and encoding of a text in
+ a given region. The value is a form of (CHARSET . ENCODING),
+ where ENCODING must be a full name, such as base64.
+
+ mime-string-encoder
+ Specifies a function to encode a string for given encoding method.
+ The method is a form of (CHARSET . ENCODING).
+
+ mime-voice-recorder
+ Specifies a function to record a voice message and return a buffer
+ that contains it. The function mime-voice-recorder-for-sun is for
+ Sun SparcStations.
+
+ mime-mode-hook
+ Turning on MIME mode calls the value of mime-mode-hook, if it is
+ non-nil.
+
+ mime-translate-hook
+ The value of mime-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 tm-edit/insert-signature,
+ the signature file will be inserted automatically.
+
+ mime-exit-hook
+ Turning off MIME mode calls the value of mime-exit-hook, if it is
+ non-nil."
+ (interactive)
+ (if mime-mode-flag
+ (error "You are already editing a MIME message.")
+ (setq mime-mode-flag t)
+ ;; Remember old key bindings.
+ (make-local-variable 'mime-mode-old-local-map)
+ (setq mime-mode-old-local-map (current-local-map))
+ ;; Add MIME commands to current local map.
+ ;; modified by Pekka Marjola <pema@niksula.hut.fi>
+ ;; 1995/9/5 (c.f. [tm-eng:69])
+ (or (string-match "XEmacs\\|Lucid" emacs-version) ; can't use w/ XEmacs
+ (use-local-map (copy-keymap (current-local-map))))
+ ;; end
+
+ (if (not (lookup-key (current-local-map) mime-prefix))
+ (define-key (current-local-map) mime-prefix (make-sparse-keymap)))
+ (mime-define-keymap (lookup-key (current-local-map) mime-prefix))
+ ;; Replace key definitions to avoid sending a message without
+ ;; conversion into a MIME compliant message.
+ ;; modified by Pekka Marjola <pema@niksula.hut.fi>
+ ;; 1995/9/5 (c.f. [tm-eng:69])
+ ;; copy-keymap behaves strangely in XEmacs
+ (cond ((string-match "XEmacs\\|Lucid" emacs-version)
+ (make-variable-buffer-local 'mime-xemacs-old-bindings)
+ (setq mime-xemacs-old-bindings nil)
+ (let ((keymap nil)
+ (keymaps (accessible-keymaps (current-local-map))))
+ (while keymaps
+ (setq keymap (cdr (car keymaps)))
+ (setq keymaps (cdr keymaps))
+ (if (not (keymapp keymap))
+ nil
+ ;; Mail mode:
+ (mime-xemacs-save-old-bindings keymap 'mail-send)
+ (mime-xemacs-save-old-bindings keymap 'mail-send-and-exit)
+ ;; mh-e letter mode:
+ (mime-xemacs-save-old-bindings keymap 'mh-send-letter)
+ ;; Mail mode called from VM:
+ (mime-xemacs-save-old-bindings keymap 'vm-mail-send)
+ (mime-xemacs-save-old-bindings keymap 'vm-mail-send-and-exit)
+ ;; News mode:
+ (mime-xemacs-save-old-bindings keymap 'news-inews)
+ ))
+ )))
+ ;; end
+
+ (let ((keymap nil)
+ (keymaps (accessible-keymaps (current-local-map))))
+ (while keymaps
+ (setq keymap (cdr (car keymaps)))
+ (setq keymaps (cdr keymaps))
+ (if (not (keymapp keymap))
+ nil
+ ;; Mail mode:
+ (substitute-key-definition
+ 'mail-send 'tm-edit/exit-and-run keymap)
+ (substitute-key-definition
+ 'mail-send-and-exit 'tm-edit/exit-and-run keymap)
+ ;; mh-e letter mode:
+ (substitute-key-definition
+ 'mh-send-letter 'tm-edit/exit-and-run keymap)
+ ;; Mail mode called from VM:
+ (substitute-key-definition
+ 'vm-mail-send 'tm-edit/exit-and-run keymap)
+ (substitute-key-definition
+ 'vm-mail-send-and-exit 'tm-edit/exit-and-run keymap)
+ ;; News mode:
+ (substitute-key-definition
+ 'news-inews 'tm-edit/exit-and-run keymap)
+ )))
+ ;; Define menu. Menus for other emacs implementations are
+ ;; welcome.
+ ;; modified by Pekka Marjola <pema@niksula.hut.fi>
+ ;; 1995/9/5 (c.f. [tm-eng:69])
+ (cond ((string-match "XEmacs\\|Lucid" emacs-version)
+ (tm-edit/define-menu-for-xemacs))
+ ((string-match "^19\\." emacs-version)
+ (tm-edit/define-menu-for-emacs19)
+ ))
+ ;; end
+
+ ;; Remember old selective-display.
+ (make-local-variable 'mime-mode-old-selective-display)
+ (setq mime-mode-old-selective-display selective-display)
+ (setq selective-display t)
+ ;; I don't care about saving these.
+ (setq paragraph-start
+ (concat tm-edit/single-part-tag-regexp "\\|" paragraph-start))
+ (setq paragraph-separate
+ (concat tm-edit/single-part-tag-regexp "\\|" paragraph-separate))
+ (run-hooks 'mime-mode-hook)
+ (message
+ (substitute-command-keys
+ "Type \\[mime-mode-exit] to exit MIME mode, and type \\[help-mime-mode] to get help."))
+ ))
+
+;;;###autoload
+(fset 'edit-mime 'mime-mode) ; for convenience
+
+(defun mime-mode-exit (&optional nomime)
+ "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-mode-flag)
+ (error "You aren't editing a MIME message.")
+ (if (not nomime)
+ (progn
+ (run-hooks 'mime-translate-hook)
+ (tm-edit/translate-buffer)))
+ ;; Restore previous state.
+ (setq mime-mode-flag nil)
+ (use-local-map mime-mode-old-local-map)
+
+ ;; modified by Pekka Marjola <pema@niksula.hut.fi>
+ ;; 1995/9/5 (c.f. [tm-eng:69])
+ (if (string-match "XEmacs\\|Lucid" emacs-version)
+ (progn
+ (delete-menu-item '("MIME")) ; should rather be const
+ (while mime-xemacs-old-bindings
+ (eval (pop mime-xemacs-old-bindings)))
+ (local-unset-key mime-prefix)))
+ ;; end
+
+ (setq selective-display mime-mode-old-selective-display)
+ (set-buffer-modified-p (buffer-modified-p))
+ (run-hooks 'mime-exit-hook)
+ (message "Exit MIME mode.")
+ ))
+
+(defun tm-edit/exit-and-run ()
+ (interactive)
+ (mime-mode-exit)
+ (call-interactively 'tm-edit/split-and-send)
+ )
+
+(defun help-mime-mode ()
+ "Show help message about MIME mode."
+ (interactive)
+ (with-output-to-temp-buffer "*Help*"
+ (princ "Edit MIME Mode:\n")
+ (princ (documentation 'mime-mode))
+ (print-help-return-message)))
+
+(defun tm-edit/insert-text ()
+ "Insert a text message.
+Charset is automatically obtained from the mime-body-charset-chooser."
+ (interactive)
+ (if (and (tm-edit/insert-tag "text" nil nil)
+ (looking-at tm-edit/single-part-tag-regexp))
+ (progn
+ ;; Make a space between the following message.
+ (insert "\n")
+ (forward-char -1)
+ )))
+
+(defun tm-edit/insert-file (file)
+ "Insert a message from a file."
+ (interactive "fInsert file as MIME message: ")
+ (let* ((guess (mime-find-file-type file))
+ (pritype (nth 0 guess))
+ (subtype (nth 1 guess))
+ (parameters (nth 2 guess))
+ (default (nth 3 guess)) ;Guess encoding from its file name.
+ (fields (nth 4 guess))
+ (encoding
+ (if (not (interactive-p))
+ default
+ (completing-read
+ (concat "What transfer encoding"
+ (if default
+ (concat " (default "
+ (if (string-equal default "") "\"\"" default)
+ ")"
+ ))
+ ": ")
+ mime-encoding-method-alist nil t nil))))
+ (if (string-equal encoding "")
+ (setq encoding default))
+ (if (or (consp parameters) (consp fields))
+ (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 (file-name-nondirectory file))
+ )
+ (setq parameters (concat parameters "; " attribute "=" value))
+ (setq rest (cdr rest))
+ )
+ (setq rest fields)
+ (while rest
+ (setq cell (car rest))
+ (setq attribute (car cell))
+ (setq value (cdr cell))
+ (if (eq value 'file)
+ (setq value (file-name-nondirectory file))
+ )
+ (setq parameters (concat parameters "\n" attribute ": " value))
+ (setq rest (cdr rest))
+ )
+ ))
+ (tm-edit/insert-tag pritype subtype parameters)
+ (tm-edit/insert-binary-file file encoding)
+ ))
+
+(defun tm-edit/insert-external ()
+ "Insert a reference to external body."
+ (interactive)
+ (tm-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 tm-edit/single-part-tag-regexp)))
+ (insert (mime-make-text-tag) "\n")))
+
+(defun tm-edit/insert-voice ()
+ "Insert a voice message."
+ (interactive)
+ (tm-edit/insert-tag "audio" "basic" nil)
+ (let ((buffer (funcall mime-voice-recorder)))
+ (unwind-protect
+ (tm-edit/insert-binary-buffer buffer "base64")
+ (kill-buffer buffer)
+ )))
+
+(defun tm-edit/insert-signature ()
+ "Insert a signature file specified by mime-signature-file."
+ (interactive)
+ (save-restriction
+ (apply (function tm-edit/insert-tag)
+ (prog1
+ (mime-find-file-type (insert-signature))
+ (narrow-to-region (point-min)(point))
+ ))
+ ))
+\f
+;; Insert a new tag around a point.
+
+(defun tm-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 ((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 (tm-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 (tm-edit/get-contype oldtag) "text")))
+ (setq oldtag nil))
+ (beginning-of-line)
+ (cond ((and oldtag ;Text
+ (not (eobp))
+ (save-excursion
+ (forward-line -1)
+ (looking-at tm-edit/beginning-tag-regexp)
+ )
+ (or mime-ignore-same-text-tag
+ (not (string-equal oldtag newtag))))
+ ;; If point is at the next of current tag, move to the
+ ;; beginning of the tag to disable insertion of extra tag.
+ (forward-line -1))
+ ((and oldtag ;Text
+ (not (eobp))
+ (not (looking-at tm-edit/tag-regexp))
+ (or mime-ignore-same-text-tag
+ (not (string-equal oldtag newtag))))
+ ;; Copy current tag to break a text into two.
+ (save-excursion
+ (insert oldtag "\n")))
+ ((and (null oldtag) ;Not text
+ (not (looking-at tm-edit/tag-regexp)))
+ ;; Adjust insertion point. In the middle of text, it is
+ ;; okay to break the text into two. However, it should not
+ ;; be broken into two, if otherwise.
+ (goto-char (tm-edit/content-end))
+ (if (eolp)
+ (forward-line 1))
+ (if (not (bolp))
+ (insert "\n"))
+ ))
+ ;; 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.
+ )
+ ))
+
+;; Insert the binary content after MIME tag.
+;; modified by MORITA Masahiro <hiro@isl.ntt.JP>
+;; for x-uue
+(defun tm-edit/insert-binary-file (file &optional encoding)
+ "Insert binary FILE at point.
+Optional argument ENCODING specifies an encoding method such as base64."
+ (let ((tmpbuf (get-buffer-create " *MIME insert*")))
+ (save-excursion
+ (set-buffer tmpbuf)
+ (erase-buffer)
+ (let ((mc-flag nil) ;Mule
+ (file-coding-system-for-read
+ (if (featurep 'mule) *noconv*))
+ (kanji-flag nil) ;NEmacs
+ (emx-binary-mode t) ;Stop CRLF to LF conversion in OS/2
+ )
+ (let (jka-compr-compression-info-list
+ jam-zcat-filename-list)
+ (insert-file-contents file))))
+ (prog1
+ (if (and (stringp encoding)
+ (string-equal (downcase encoding) "x-uue"))
+ (progn
+ (require 'mel-u)
+ (let ((uuencode-external-encoder
+ (cons (car uuencode-external-encoder)
+ (list (file-name-nondirectory file))
+ )))
+ (tm-edit/insert-binary-buffer tmpbuf encoding)
+ ))
+ (tm-edit/insert-binary-buffer tmpbuf encoding))
+ (kill-buffer tmpbuf))))
+
+;; Insert the binary content after MIME tag.
+;; modified by MORITA Masahiro <hiro@isl.ntt.JP>
+;; for x-uue
+(defun tm-edit/insert-binary-buffer (buffer &optional encoding)
+ "Insert binary BUFFER 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)
+ (let ((en (downcase encoding)))
+ (or (string-equal en "base64")
+ (string-equal en "x-uue")
+ ))))
+ )
+ (save-restriction
+ (narrow-to-region (1- (point)) (point))
+ (let ((start (point))
+ (emx-binary-mode t)) ;Stop LF to CRLF conversion in OS/2
+ (insert-buffer-substring buffer)
+ ;; Encode binary message if necessary.
+ (if encoding
+ (mime-encode-region encoding start (point-max))))
+ (if hide-p
+ (progn
+ (mime-flag-region (point-min) (1- (point-max)) ?\^M)
+ (goto-char (point-max)))
+ ))
+ ;; Define encoding even if it is 7bit.
+ (if (stringp encoding)
+ (save-excursion
+ (goto-char tagend) ;Make sure which line the tag is on.
+ (tm-edit/define-encoding encoding)))
+ ))
+\f
+;; Commands work on a current message flagment.
+
+(defun tm-edit/goto-tag ()
+ "Search for the beginning of the tagged MIME message."
+ (let ((current (point)) multipart)
+ (if (looking-at tm-edit/tag-regexp)
+ t
+ ;; At first, go to the end.
+ (cond ((re-search-forward tm-edit/beginning-tag-regexp nil t)
+ (goto-char (match-beginning 0)) ;For multiline tag
+ (forward-line -1)
+ (end-of-line)
+ )
+ (t
+ (goto-char (point-max))
+ ))
+ ;; Then search for the beginning.
+ (re-search-backward tm-edit/end-tag-regexp nil t)
+ (beginning-of-line)
+ (or (looking-at tm-edit/beginning-tag-regexp)
+ ;; Restore previous point.
+ (progn
+ (goto-char current)
+ nil
+ ))
+ )))
+
+(defun tm-edit/content-beginning ()
+ "Return the point of the beginning of content."
+ (save-excursion
+ (let ((beg (save-excursion
+ (beginning-of-line) (point))))
+ (if (tm-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 tm-edit/content-end ()
+ "Return the point of the end of content."
+ (save-excursion
+ (let ((beg (save-excursion
+ (beginning-of-line) (point))))
+ (if (tm-edit/goto-tag)
+ (let ((top (point)))
+ (goto-char (match-end 0))
+ (if (and (= beg top) ;Must be on the same line.
+ (= (following-char) ?\^M))
+ (progn
+ (end-of-line)
+ (point))
+ ;; Move to the end of this text.
+ (if (re-search-forward tm-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 (tm-edit/content-beginning))
+ (if (re-search-forward tm-edit/tag-regexp nil 'move)
+ ;; Don't forget a multiline tag.
+ (goto-char (match-beginning 0)))
+ (point))
+ )))
+
+(defun tm-edit/define-charset (charset)
+ "Set charset of current tag to CHARSET."
+ (save-excursion
+ (if (tm-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-set-parameter
+ (tm-edit/get-contype tag) "charset" charset)
+ (tm-edit/get-encoding tag))))
+ )))
+
+(defun tm-edit/define-encoding (encoding)
+ "Set encoding of current tag to ENCODING."
+ (save-excursion
+ (if (tm-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 (tm-edit/get-contype tag) encoding)))
+ )))
+
+(defun tm-edit/choose-charset ()
+ "Choose charset of a text following current point."
+ (save-excursion
+ (let* ((beg (point))
+ (end (tm-edit/content-end)))
+ (car (funcall mime-body-charset-chooser beg end)))))
+
+(defun tm-edit/choose-encoding ()
+ "Choose encoding of a text following current point."
+ (save-excursion
+ (let* ((beg (point))
+ (end (tm-edit/content-end)))
+ (cdr (funcall mime-body-charset-chooser beg end)))))
+
+(defun mime-make-text-tag (&optional subtype)
+ "Make a tag for a text after current point.
+Subtype of text type can be specified by an optional argument SUBTYPE.
+Otherwise, it is obtained from mime-content-types."
+ (let* ((pritype "text")
+ (subtype (or subtype
+ (car (car (cdr (assoc pritype mime-content-types)))))))
+ ;; Charset should be defined later.
+ (mime-make-tag pritype subtype)))
+
+\f
+;; Tag handling functions
+
+(defun mime-make-tag (pritype subtype &optional parameters encoding)
+ "Make a tag of MIME message of PRITYPE, SUBTYPE and optional PARAMETERS."
+ (mime-create-tag (concat (or pritype "") "/" (or subtype "")
+ (or parameters ""))
+ encoding))
+
+(defun mime-create-tag (contype &optional encoding)
+ "Make a tag with CONTENT-TYPE and optional ENCODING."
+ (format (if encoding mime-tag-format-with-encoding mime-tag-format)
+ contype encoding))
+
+(defun tm-edit/get-contype (tag)
+ "Return Content-Type (including parameters) of TAG."
+ (and (stringp tag)
+ (or (string-match tm-edit/single-part-tag-regexp tag)
+ (string-match tm-edit/multipart-beginning-regexp tag)
+ (string-match tm-edit/multipart-end-regexp tag)
+ )
+ (substring tag (match-beginning 1) (match-end 1))
+ ))
+
+(defun tm-edit/get-encoding (tag)
+ "Return encoding of TAG."
+ (and (stringp tag)
+ (string-match tm-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-set-parameter (contype parameter value)
+ "For given CONTYPE set PARAMETER to VALUE."
+ (if (string-match
+ (concat
+ ";[ \t\n]*\\("
+ (regexp-quote parameter)
+ "[ \t\n]*=[ \t\n]*\\([^\" \t\n;]*\\|\"[^\"]*\"\\)\\)[ \t\n]*\\(;\\|$\\)")
+ contype)
+ ;; Change value
+ (concat (substring contype 0 (match-beginning 1))
+ parameter "=" value
+ (substring contype (match-end 1)))
+ (concat contype "; " parameter "=" value)))
+
+(defun mime-strip-parameters (contype)
+ "Return primary content-type and subtype without parameters for CONTYPE."
+ (if (string-match "^[ \t]*\\([^; \t\n]*\\)" contype)
+ (substring contype (match-beginning 1) (match-end 1)) nil))
+
+(defun mime-test-content-type (contype type &optional subtype)
+ "Test if CONTYPE is a TYPE and an optional SUBTYPE."
+ (and (stringp contype)
+ (stringp type)
+ (string-match
+ (concat "^[ \t]*" (downcase type) "/" (downcase (or subtype "")))
+ (downcase contype))))
+
+\f
+;; Basic functions
+
+(defun mime-find-file-type (file)
+ "Guess Content-Type, subtype, and parameters from FILE."
+ (let ((guess nil)
+ (guesses mime-file-types))
+ (while (and (not guess) guesses)
+ (if (string-match (car (car guesses)) file)
+ (setq guess (cdr (car guesses))))
+ (setq guesses (cdr guesses)))
+ guess
+ ))
+
+(defun mime-prompt-for-type ()
+ "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.
+ nil
+ ))
+ (if (string-equal type "")
+ (progn
+ (message "Content type is required.")
+ (beep)
+ (sit-for 1)
+ ))
+ )
+ type
+ ))
+
+(defun mime-prompt-for-subtype (pritype)
+ "Ask for Content-type subtype of Content-Type PRITYPE."
+ (let* ((default (car (car (cdr (assoc pritype mime-content-types)))))
+ (answer
+ (completing-read
+ (if default
+ (concat
+ "What content subtype: (default " default ") ")
+ "What content subtype: ")
+ (cdr (assoc pritype 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-encode-string (encoding string)
+ "Using ENCODING encode a STRING.
+If the STRING is too long, the encoded string may be broken into
+several lines."
+ (save-excursion
+ (set-buffer (get-buffer-create " *MIME encoding*"))
+ (erase-buffer)
+ (insert string)
+ (mime-encode-region encoding (point-min) (point-max))
+ (prog1
+ (buffer-substring (point-min) (point-max))
+ (kill-buffer (current-buffer)))))
+
+(defun mime-decode-string (encoding string)
+ "Using ENCODING decode a STRING."
+ (save-excursion
+ (set-buffer (get-buffer-create " *MIME decoding*"))
+ (erase-buffer)
+ (insert string)
+ (mime-decode-region encoding (point-min) (point-max))
+ (prog1
+ (buffer-substring (point-min) (point-max))
+ (kill-buffer (current-buffer)))))
+
+(defun mime-flag-region (from to flag)
+ "Hides or shows lines from FROM to TO, according to FLAG.
+If FLAG is `\\n' (newline character) then text is shown,
+while if FLAG is `\\^M' (control-M) the text is hidden."
+ (let ((buffer-read-only nil) ;Okay even if write protected.
+ (modp (buffer-modified-p)))
+ (unwind-protect
+ (subst-char-in-region from to
+ (if (= flag ?\n) ?\^M ?\n)
+ flag t)
+ (set-buffer-modified-p modp))))
+
+\f
+;; Translate the tagged MIME messages into a MIME compliant message.
+
+(defun tm-edit/translate-buffer ()
+ "Encode the tagged MIME message in current buffer in MIME compliant message."
+ (interactive)
+ (mime/encode-message-header)
+ (tm-edit/translate-body)
+ )
+
+(defun tm-edit/translate-body ()
+ "Encode the tagged MIME body in current buffer in MIME compliant message."
+ (interactive)
+ (save-excursion
+ (let ((boundary
+ (concat mime-multipart-boundary " " (current-time-string)))
+ (i 1)
+ (time (current-time-string))
+ ret)
+ (while (tm-edit/process-multipart-1
+ (format "%s %s-%d" mime-multipart-boundary time 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 (tm-edit/translate-region
+ beg end
+ (format "%s %s-%d" mime-multipart-boundary time i)))
+ ))
+ (let ((contype (car ret)) ;Content-Type
+ (encoding (nth 1 ret)) ;Content-Transfer-Encoding
+ )
+ ;; Make primary MIME headers.
+ (or (mail-position-on-field "Mime-Version")
+ (insert tm-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 tm-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 tm-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 tm-edit/single-part-tag-regexp nil t)
+ (let* ((tag (buffer-substring (match-beginning 0) (match-end 0)))
+ (contype (tm-edit/get-contype tag))
+ (charset (mime-get-parameter contype "charset"))
+ (encoding (tm-edit/get-encoding tag)))
+ ;; Remove extra whitespaces after the tag.
+ (if (looking-at "[ \t]+$")
+ (delete-region (match-beginning 0) (match-end 0)))
+ (cond ((= (following-char) ?\^M)
+ ;; It must be image, audio or video.
+ (let ((beg (point))
+ (end (tm-edit/content-end)))
+ ;; Insert explicit MIME tags after hidden messages.
+ (forward-line 1)
+ (if (and (not (eobp))
+ (not (looking-at tm-edit/single-part-tag-regexp)))
+ (progn
+ (insert (mime-make-text-tag) "\n")
+ (forward-line -1) ;Process it again as text.
+ ))
+ ;; Show a hidden message. The point is not altered
+ ;; after the conversion.
+ (mime-flag-region beg end ?\n)))
+ ((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 (or charset (tm-edit/choose-charset)))
+ (tm-edit/define-charset charset)
+ ;; Point is now on current tag.
+ ;; Define encoding and encode text if necessary.
+ (if (null encoding) ;Encoding is not specified.
+ (let* ((encoding (tm-edit/choose-encoding))
+ (beg (tm-edit/content-beginning))
+ (end (tm-edit/content-end))
+ (body (buffer-substring beg end))
+ (encoded (funcall mime-string-encoder
+ (cons charset encoding) body)))
+ (if (not (string-equal body encoded))
+ (progn
+ (goto-char beg)
+ (delete-region beg end)
+ (insert encoded)
+ (goto-char beg)))
+ (tm-edit/define-encoding encoding)))
+ (forward-line 1))
+ ((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 (tm-edit/content-beginning))
+ (end (tm-edit/content-end))
+ (body (buffer-substring beg end))
+ (encoded (funcall mime-string-encoder
+ (cons nil encoding) body)))
+ (if (not (string-equal body encoded))
+ (progn
+ (goto-char beg)
+ (delete-region beg end)
+ (insert encoded)
+ (goto-char beg)))
+ (tm-edit/define-encoding encoding))
+ (forward-line 1))
+ )
+ )))
+
+(defun mime-delete-field (field)
+ "Delete header FIELD."
+ (let ((regexp (format "^%s:[ \t]*" field)))
+ (goto-char (point-min))
+ (while (re-search-forward regexp nil t)
+ (delete-region (match-beginning 0)
+ (progn (forward-line 1) (point)))
+ )))
+
+\f
+;;;
+;;; Platform dependent functions
+;;;
+
+;; Emacs 18 implementations
+
+(defun mime-body-charset-chooser-for-emacs18 (begin end)
+ "Return a cons of charset and encoding of a message in a given region.
+Encoding name must be a canonical name, such as `base64'."
+ '("US-ASCII" . nil) ;Default charset of MIME.
+ )
+
+(defun mime-string-encoder-for-emacs18 (method string)
+ "For given METHOD that is a cons of charset and encoding, encode a STRING."
+ (let ((charset (car method))
+ (encoding (cdr method)))
+ (cond ((stringp encoding)
+ (mime-encode-string encoding string))
+ ;; Return string without any encoding.
+ (t string)
+ )))
+
+\f
+;; Emacs 19 implementations
+
+(defun mime-body-charset-chooser-for-emacs19 (begin end)
+ "Return a cons of charset and encoding of a message in a given region.
+Encoding name must be a canonical name, such as `base64'.
+US-ASCII and ISO-8859-1 are supported on Emacs 19."
+ (cond ((save-excursion
+ (goto-char begin)
+ (re-search-forward "[\200-\377]" end t))
+ '("ISO-8859-1" . "quoted-printable"))
+ (t
+ '("US-ASCII" . nil)) ;Default charset of MIME.
+ ))
+
+(defun mime-string-encoder-for-emacs19 (method string)
+ "For given METHOD that is a cons of charset and encoding, encode a STRING."
+ (let ((charset (car method))
+ (encoding (cdr method)))
+ (cond ((stringp encoding)
+ (mime-encode-string encoding string))
+ ;; Return string without any encoding.
+ (t string)
+ )))
+
+\f
+;; NEmacs implementations
+
+(defun mime-body-charset-chooser-for-nemacs (begin end)
+ "Return a cons of charset and encoding of a message in a given region.
+Encoding name must be a canonical name, such as `base64'.
+US-ASCII and ISO-2022-JP are supported on NEmacs."
+ (cond ((check-region-kanji-code begin end)
+ ;; The following are safe encoding methods for use in
+ ;; USENET News systems that strip off all ESCs.
+ ;; '("ISO-2022-JP" . "quoted-printable")
+ ;; '("ISO-2022-JP" . "base64")
+ ;; The following expects transport systems are all MIME
+ ;; compliants. For instance, ESCs are never stripped off.
+ '("ISO-2022-JP" . nil))
+ (t
+ '("US-ASCII" . nil)) ;Default charset of MIME.
+ ))
+
+(defun mime-string-encoder-for-nemacs (method string)
+ "For given METHOD that is a cons of charset and encoding, encode a STRING.
+US-ASCII and ISO-2022-JP are supported on NEmacs."
+ (let ((charset (car method))
+ (encoding (cdr method)))
+ (cond ((stringp encoding)
+ (mime-encode-string encoding
+ ;; Convert internal (EUC) to JIS code.
+ (convert-string-kanji-code string 3 2)
+ ))
+ ;; NEmacs can convert into ISO-2022-JP automatically,
+ ;; but can do it myself as follows:
+ ;;(t (convert-string-kanji-code string 3 2))
+
+ ;; Return string without any encoding.
+ (t string)
+ )))
+
+\f
+;; Mule implementations
+;; Thanks to contributions by wkenji@flab.fujitsu.co.jp (Kenji
+;; WAKAMIYA) and handa@etl.go.jp (Kenichi Handa).
+
+(defun mime-body-charset-chooser-for-mule (begin end)
+ "Return a cons of charset and encoding of a message in a given
+region. Encoding name must be a canonical name, such as `base64'.
+US-ASCII, ISO-8859-* (except for ISO-8859-6), ISO-2022-JP,
+ISO-2022-JP-2 and ISO-2022-INT-1 are supported on Mule. Either of
+charset ISO-2022-JP-2 or ISO-2022-INT-1 is used for multilingual text
+in Mule."
+ (let ((lclist (find-charset-region begin end)))
+ (cond ((null lclist)
+ '("US-ASCII" . nil)) ;Default charset of MIME.
+ ;; Multilingual capability requred.
+ ((and (> (length lclist) 1)
+ (boundp '*iso-2022-int-1*))
+ '("ISO-2022-INT-1" . nil))
+ ((> (length lclist) 1)
+ '("ISO-2022-JP-2" . nil))
+ ;; Simple charset.
+ ((memq lc-ltn1 lclist)
+ '("ISO-8859-1" . "quoted-printable"))
+ ((memq lc-ltn2 lclist)
+ '("ISO-8859-2" . "quoted-printable"))
+ ((memq lc-ltn3 lclist)
+ '("ISO-8859-3" . "quoted-printable"))
+ ((memq lc-ltn4 lclist)
+ '("ISO-8859-4" . "quoted-printable"))
+ ((memq lc-crl lclist)
+ '("ISO-8859-5" . "quoted-printable"))
+ ;;((memq lc-arb lclist)
+ ;; '("ISO-8859-6" . "quoted-printable"))
+ ((memq lc-grk lclist)
+ '("ISO-8859-7" . "quoted-printable"))
+ ((memq lc-hbw lclist)
+ '("ISO-8859-8" . "quoted-printable"))
+ ((memq lc-ltn5 lclist)
+ '("ISO-8859-9" . "quoted-printable"))
+ ((memq lc-jp lclist)
+ '("ISO-2022-JP" . nil))
+ ;; Unknown charset.
+ ((boundp '*iso-2022-int-1*)
+ '("ISO-2022-INT-1" . nil))
+ (t
+ '("ISO-2022-JP-2" . nil))
+ )))
+
+(defun mime-string-encoder-for-mule (method string)
+ "For given METHOD that is a cons of charset and encoding, encode a
+STRING. US-ASCII, ISO-8859-* (except for ISO-8859-6), ISO-2022-JP,
+ISO-2022-JP-2 and ISO-2022-INT-1 are supported on Mule. Either of
+charset ISO-2022-JP-2 or ISO-2022-INT-1 is used for multilingual
+text."
+ (let* ((charset (car method))
+ (encoding (cdr method))
+ (coding-system
+ (cdr (assoc (and (stringp charset) (upcase charset))
+ '(("ISO-8859-1" . *ctext*)
+ ("ISO-8859-2" . *iso-8859-2*)
+ ("ISO-8859-3" . *iso-8859-3*)
+ ("ISO-8859-4" . *iso-8859-4*)
+ ("ISO-8859-5" . *iso-8859-5*)
+ ;;("ISO-8859-6" . *iso-8859-6*)
+ ("ISO-8859-7" . *iso-8859-7*)
+ ("ISO-8859-8" . *iso-8859-8*)
+ ("ISO-8859-9" . *iso-8859-9*)
+ ("ISO-2022-JP" . *junet*)
+ ("ISO-2022-JP-2" . *iso-2022-ss2-7*)
+ ("ISO-2022-INT-1" . *iso-2022-int-1*)
+ )))))
+ ;; In bilingual environment it may be unnecessary to convert the
+ ;; coding system of the string unless transfer encoding is
+ ;; required since such conversion may be performed by mule
+ ;; automatically.
+ (if (not (null coding-system))
+ (setq string (code-convert-string string *internal* coding-system)))
+ (if (stringp encoding)
+ (setq string (mime-encode-string encoding string)))
+ string
+ ))
+
+\f
+;; Sun implementations
+
+(defun mime-voice-recorder-for-sun ()
+ "Record voice in a buffer using Sun audio device, and return the buffer.
+If the environment variable AUDIOHOST is defined, its value is used as
+a recording host instead of local host."
+ (let ((buffer (get-buffer-create " *MIME audio*"))
+ (host (getenv "AUDIOHOST")))
+ (message "Start the recording on %s. Type C-g to finish the recording..."
+ (or host (system-name)))
+ (save-excursion
+ (set-buffer buffer)
+ (erase-buffer)
+ (condition-case errorcode
+ (let ((selective-display nil) ;Disable ^M to nl translation.
+ (mc-flag nil) ;Mule
+ (kanji-flag nil)) ;NEmacs
+ ;; If AUDIOHOST is defined, use the value as recording host.
+ (cond ((not (null host))
+ ;; Disable automatic conversion of coding system if Mule.
+ (if (featurep 'mule)
+ (define-program-coding-system nil "rsh" *noconv*))
+ (call-process "rsh"
+ nil
+ buffer
+ nil
+ host
+ "cat"
+ "/dev/audio"
+ ))
+ (t
+ ;; Disable automatic conversion of coding system if Mule.
+ (if (featurep 'mule)
+ (define-program-coding-system nil "cat" *noconv*))
+ (call-process "cat"
+ "/dev/audio"
+ buffer
+ nil
+ ))))
+ (quit (message "Type C-g to finish recording... done.")
+ buffer ;Return the buffer
+ )))))
+
+\f
+;;;
+;;; Other useful commands.
+;;;
+
+;; Message forwarding commands as content-type "message/rfc822".
+
+(defun tm-edit/insert-message (&optional message)
+ (interactive)
+ (let ((inserter (assoc-value major-mode tm-edit/message-inserter-alist)))
+ (if (and inserter (fboundp inserter))
+ (progn
+ (tm-edit/insert-tag "message" "rfc822")
+ (funcall inserter message)
+ )
+ (message "Sorry, I don't have message inserter for your MUA.")
+ )))
+
+;;;###autoload
+;;; (defun mime-forward-from-rmail-using-mail ()
+;;; "Forward current message in message/rfc822 content-type message from rmail.
+;;; The message will be appended if being composed."
+;;; (interactive)
+;;; ;;>> this gets set even if we abort. Can't do anything about it, though.
+;;; (rmail-set-attribute "forwarded" t)
+;;; (let ((initialized nil)
+;;; (beginning nil)
+;;; (forwarding-buffer (current-buffer))
+;;; (subject (concat "["
+;;; (mail-strip-quoted-names (mail-fetch-field "From"))
+;;; ": " (or (mail-fetch-field "Subject") "") "]")))
+;;; ;; If only one window, use it for the mail buffer.
+;;; ;; Otherwise, use another window for the mail buffer
+;;; ;; so that the Rmail buffer remains visible
+;;; ;; and sending the mail will get back to it.
+;;; (setq initialized
+;;; (if (one-window-p t)
+;;; (mail nil nil subject)
+;;; (mail-other-window nil nil subject)))
+;;; (save-excursion
+;;; (goto-char (point-max))
+;;; (forward-line 1)
+;;; (setq beginning (point))
+;;; (tm-edit/insert-tag "message" "rfc822")
+;;; (insert-buffer forwarding-buffer))
+;;; (if (not initialized)
+;;; (goto-char beginning))
+;;; ))
+
+;;;###autoload
+;;; (defun mime-forward-from-gnus-using-mail ()
+;;; "Forward current article in message/rfc822 content-type message from GNUS.
+;;; The message will be appended if being composed."
+;;; (let ((initialized nil)
+;;; (beginning nil)
+;;; (forwarding-buffer (current-buffer))
+;;; (subject
+;;; (concat "[" gnus-newsgroup-name "] "
+;;; ;;(mail-strip-quoted-names (gnus-fetch-field "From")) ": "
+;;; (or (gnus-fetch-field "Subject") ""))))
+;;; ;; If only one window, use it for the mail buffer.
+;;; ;; Otherwise, use another window for the mail buffer
+;;; ;; so that the Rmail buffer remains visible
+;;; ;; and sending the mail will get back to it.
+;;; (setq initialized
+;;; (if (one-window-p t)
+;;; (mail nil nil subject)
+;;; (mail-other-window nil nil subject)))
+;;; (save-excursion
+;;; (goto-char (point-max))
+;;; (setq beginning (point))
+;;; (tm-edit/insert-tag "message" "rfc822")
+;;; (insert-buffer forwarding-buffer)
+;;; ;; You have a chance to arrange the message.
+;;; (run-hooks 'gnus-mail-forward-hook)
+;;; )
+;;; (if (not initialized)
+;;; (goto-char beginning))
+;;; ))
+
+;;; mime.el ends here
+(defun tm-edit/translate-region (beg end &optional boundary multipart)
+ (if (null boundary)
+ (setq boundary
+ (concat mime-multipart-boundary " " (current-time-string)))
+ )
+ (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.
+ (tm-edit/normalize-body)
+ ;; Counting the number of Content-Type.
+ (goto-char (point-min))
+ (while (re-search-forward tm-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 tm-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 (tm-edit/get-contype tag))
+ (setq encoding (tm-edit/get-encoding tag))
+ ))
+ (t
+ ;; It's a multipart message.
+ (goto-char (point-min))
+ (while (re-search-forward tm-edit/single-part-tag-regexp nil t)
+ (setq tag
+ (buffer-substring (match-beginning 0) (match-end 0)))
+ (delete-region (match-beginning 0) (match-end 0))
+ (setq contype (tm-edit/get-contype tag))
+ (setq encoding (tm-edit/get-encoding tag))
+ (insert "--" boundary "\n")
+ (insert "Content-Type: " contype "\n")
+ (if encoding
+ (insert "Content-Transfer-Encoding: " encoding "\n"))
+ )
+ ;; Define Content-Type as "multipart/mixed".
+ (setq contype
+ (concat "multipart/mixed; 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))
+ (if (not (= (preceding-char) ?\n))
+ ;; Boundary must start with a newline.
+ (insert "\n"))
+ (insert "--" boundary "--\n")))
+ (list contype encoding boundary nparts)
+ ))))
+
+
+(defun tm-edit/find-inmost ()
+ (goto-char (point-min))
+ (if (re-search-forward tm-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 tm-edit/multipart-beginning-regexp nil t)
+ (let (ret)
+ (narrow-to-region (match-beginning 0)(point-max))
+ (tm-edit/find-inmost)
+ )
+ (widen)
+ ;;(delete-region eb ee)
+ (list type bb be eb)
+ ))))
+
+(defun tm-edit/process-multipart-1 (boundary)
+ (let ((ret (tm-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 tm-edit/multipart-end-regexp)
+ (let ((beg (match-beginning 0))
+ (end (match-end 0))
+ )
+ (delete-region beg end)
+ (if (not (looking-at tm-edit/single-part-tag-regexp))
+ (insert (concat (mime-make-text-tag) "\n"))
+ )))
+ (setq boundary (nth 2 (tm-edit/translate-region bb eb boundary t)))
+ (goto-char bb)
+ (insert
+ (format "--[[multipart/%s; boundary=\"%s\"][7bit]]\n"
+ type boundary))
+ boundary)
+ )))
+
+
+;;; @ multipart enclosure
+;;;
+
+(defun tm-edit/enclose-region (type beg end)
+ (save-excursion
+ (goto-char beg)
+ (let ((f (bolp)))
+ (save-restriction
+ (narrow-to-region beg end)
+ (goto-char beg)
+ (if (not f)
+ (insert "\n")
+ )
+ (insert (format "--<<%s>>-{\n" type))
+ (goto-char (point-max))
+ (setq f (bolp))
+ (if (not f)
+ (insert (format "\n--}-<<%s>>" type))
+ (insert (format "--}-<<%s>>\n" type))
+ )
+ (goto-char (point-max))
+ )
+ (if (not (eobp))
+ (progn
+ (if (not f)
+ (if (not (eolp))
+ (insert "\n")
+ (forward-char)
+ )
+ )
+ (if (not (looking-at tm-edit/single-part-tag-regexp))
+ (insert (mime-make-text-tag) "\n")
+ )
+ )
+ (if (not f)
+ (insert "\n")
+ ))
+ )))
+
+(defun tm-edit/enclose-mixed-region (beg end)
+ (interactive "*r")
+ (tm-edit/enclose-region "mixed" beg end)
+ )
+
+(defun tm-edit/enclose-parallel-region (beg end)
+ (interactive "*r")
+ (tm-edit/enclose-region "parallel" beg end)
+ )
+
+(defun tm-edit/enclose-digest-region (beg end)
+ (interactive "*r")
+ (tm-edit/enclose-region "digest" beg end)
+ )
+
+(defun tm-edit/enclose-alternative-region (beg end)
+ (interactive "*r")
+ (tm-edit/enclose-region "alternative" beg end)
+ )
+
+
+;;; @ split
+;;;
+
+(defun tm-edit/split-and-send (&optional cmd)
+ (interactive)
+ (let ((tm-edit/message-max-length
+ (or (cdr (assq major-mode tm-edit/message-max-length-alist))
+ tm-edit/message-default-max-length))
+ (lines (count-lines (point-min) (point-max)))
+ )
+ (if (or (<= lines tm-edit/message-max-length)
+ (not tm-edit/split-message))
+ (call-interactively
+ (or cmd
+ (cdr (assq major-mode tm-edit/message-default-sender-alist))
+ ))
+ (let* ((tm-edit/draft-file-name
+ (or (buffer-file-name)
+ (make-temp-name (expand-file-name "tm-draft" mime/tmp-dir))))
+ (separator mail-header-separator)
+ (config
+ (eval (cdr (assq major-mode tm-edit/window-config-alist))))
+ (id (concat "\""
+ (replace-space-with-underline (current-time-string))
+ "@" (system-name) "\"")))
+
+ (let ((hook (cdr (assq major-mode
+ tm-edit/message-before-send-hook-alist))))
+ (run-hooks hook))
+ (let* ((header (rfc822/get-header-string-except
+ tm-edit/message-nuke-headers separator))
+ (orig-header (rfc822/get-header-string-except
+ tm-edit/message-blind-headers separator))
+ (subject (mail-fetch-field "subject"))
+ (total (+ (/ lines tm-edit/message-max-length)
+ (if (> (mod lines tm-edit/message-max-length) 0)
+ 1)))
+ (i 0)
+ (l tm-edit/message-max-length)
+ (the-buf (current-buffer))
+ (buf (get-buffer "*tmp-send*"))
+ (command
+ (or cmd
+ (cdr (assq major-mode tm-edit/message-sender-alist))
+ (cdr (assq major-mode tm-edit/message-default-sender-alist))))
+ data)
+ (goto-char (point-min))
+ (if (re-search-forward (concat "^" (regexp-quote separator) "$")
+ nil t)
+ (replace-match "")
+ )
+ (if buf
+ (progn
+ (switch-to-buffer buf)
+ (erase-buffer)
+ (switch-to-buffer the-buf)
+ )
+ (setq buf (get-buffer-create "*tmp-send*"))
+ )
+ (switch-to-buffer buf)
+ (make-variable-buffer-local 'mail-header-separator)
+ (setq mail-header-separator separator)
+ (switch-to-buffer the-buf)
+ (goto-char (point-min))
+ (re-search-forward "^$" nil t)
+ (while (< i total)
+ (setq buf (get-buffer "*tmp-send*"))
+ (setq data (buffer-substring
+ (point)
+ (progn
+ (goto-line l)
+ (point))
+ ))
+ (switch-to-buffer buf)
+ (insert header)
+ (insert
+ (format "Subject: %s (%d/%d)\n" subject (+ i 1) total))
+ (insert
+ (format "Mime-Version: 1.0 (split by tm-edit %s)\n"
+ tm-edit/version))
+ (insert
+ (format
+ "Content-Type: message/partial; id=%s; number=%d; total=%d\n%s\n"
+ id (+ i 1) total separator))
+ (if (eq i 0)
+ (insert orig-header))
+ (insert data)
+ (save-excursion
+ (call-interactively command))
+ (erase-buffer)
+ (switch-to-buffer the-buf)
+ (setq l (+ l tm-edit/message-max-length))
+ (setq i (+ i 1))
+ )
+ )
+ (let ((hook
+ (cdr (assq major-mode tm-edit/message-after-send-hook-alist))))
+ (run-hooks 'hook))
+ (set-buffer-modified-p nil)
+ (cond ((y-or-n-p "Kill draft buffer? ")
+ (kill-buffer (current-buffer))
+ (if config
+ (set-window-configuration config))))
+ (message "")
+ ))))
+
+
+;;; @ preview message
+;;;
+
+(defun tm-edit/preview-message ()
+ "preview editing MIME message. [tm-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/temporary-message-mode)
+ (make-local-variable 'mail-header-separator)
+ (setq mail-header-separator separator)
+ (make-local-variable 'mime/editing-buffer)
+ (setq mime/editing-buffer the-buf)
+
+ (run-hooks 'mime-translate-hook)
+ (tm-edit/translate-buffer)
+ (goto-char (point-min))
+ (if (re-search-forward
+ (concat "^" (regexp-quote separator) "$"))
+ (replace-match "")
+ )
+ (mime/viewer-mode)
+ ))
+
+(defun tm-edit/quitting-method ()
+ (let ((temp mime::preview/article-buffer)
+ buf)
+ (mime-viewer/kill-buffer)
+ (set-buffer temp)
+ (setq buf mime/editing-buffer)
+ (kill-buffer temp)
+ (switch-to-buffer buf)
+ ))
+
+(set-alist 'mime-viewer/quitting-method-alist
+ 'mime/temporary-message-mode
+ (function tm-edit/quitting-method)
+ )
+
+
+;;; @ draft preview
+;;;
+;; by "OKABE Yasuo <okabe@kudpc.kyoto-u.ac.jp>
+;; Mon, 10 Apr 1995 20:03:07 +0900
+
+(defvar tm-edit/draft-header-separator-alist
+ '((news-reply-mode . mail-header-separator)
+ (mh-letter-mode . mail-header-separator)
+ ))
+
+(defvar mime::article/draft-header-separator nil)
+
+(defun tm-edit/draft-preview ()
+ (interactive)
+ (let ((sep (assoc-value major-mode tm-edit/draft-header-separator-alist)))
+ (or (stringp sep) (setq sep (eval sep)))
+ (make-variable-buffer-local 'mime::article/draft-header-separator)
+ (goto-char (point-min))
+ (re-search-forward
+ (concat "^\\(" (regexp-quote sep) "\\)?$"))
+ (setq mime::article/draft-header-separator
+ (buffer-substring (match-beginning 0) (match-end 0)))
+ (replace-match "")
+ (mime/viewer-mode (current-buffer))
+ (pop-to-buffer (current-buffer))
+ ))
+
+(defun mime-viewer::quitting-method/draft-preview ()
+ (let ((mother mime/mother-buffer))
+ (save-excursion
+ (switch-to-buffer mother)
+ (goto-char (point-min))
+ (if (and
+ (re-search-forward
+ (concat "^\\("
+ (regexp-quote mime::article/draft-header-separator)
+ "\\)?$") nil t)
+ (bolp))
+ (progn
+ (insert mime::article/draft-header-separator)
+ (set-buffer-modified-p (buffer-modified-p))
+ )))
+ (mime-viewer/kill-buffer)
+ (pop-to-buffer mother)
+ ))
+
+(set-alist 'mime-viewer/quitting-method-alist
+ 'mh-letter-mode
+ (function mime-viewer::quitting-method/draft-preview)
+ )
+
+(set-alist 'mime-viewer/quitting-method-alist
+ 'news-reply-mode
+ (function mime-viewer::quitting-method/draft-preview)
+ )
+
+
+;;; @ etc
+;;;
+
+(defun rfc822/get-header-string-except (pat boundary)
+ (let ((case-fold-search t))
+ (save-excursion
+ (save-restriction
+ (narrow-to-region (goto-char (point-min))
+ (progn
+ (re-search-forward
+ (concat "^\\(" (regexp-quote boundary) "\\)?$")
+ nil t)
+ (match-beginning 0)
+ ))
+ (goto-char (point-min))
+ (let (field header)
+ (while (re-search-forward rfc822/field-top-regexp nil t)
+ (setq field (buffer-substring (match-beginning 0)
+ (rfc822/field-end)
+ ))
+ (if (not (string-match pat field))
+ (setq header (concat header field "\n"))
+ ))
+ header)
+ ))))
+
+(defun replace-space-with-underline (str)
+ (mapconcat (function
+ (lambda (arg)
+ (char-to-string
+ (if (= arg 32)
+ ?_
+ arg)))) str "")
+ )
+
+
+;;; @ end
+;;;
+
+(provide 'tm-edit)
+
+(run-hooks 'tm-edit-load-hook)
projects / elisp / tm.git / commitdiff