Newsgroups: fj.editor.emacs,gnu.emacs.sources
Path: galaxy.trc.rwcp.or.jp!jaist-news!cs.titech!wnoc-tyo-news!sh.wide!wnoc-kyo!kuis!kudpc!hakata!kyu-cs!wnoc-fukuoka-news!shiwasu!shiwasu!umerin
From: umerin@mse.kyutech.ac.jp (Masanobu UMEDA)
Subject: Poorman's Simple MIME Composer
Content-Type: text/plain; charset=iso-2022-jp
Sender: news@shiwasu.isci.kyutech.ac.jp
Mime-Version: 1
Organization: Department of Mechanical System Engineering, Kyutech, Japan
Date: Sat, 27 Mar 1993 13:50:46 GMT
Message-ID: <UMERIN.93Mar27225046@orchid.mse.kyutech.ac.jp>
Reply-To: umerin@mse.kyutech.ac.jp
Lines: 556
Xref: galaxy.trc.rwcp.or.jp fj.editor.emacs:3622
X-originally-archived-at: http://galaxy.rwcp.or.jp/text/cgi-bin/newsarticle2?ng=fj.editor.emacs&nb=3622&hd=a
X-reformat-date: Mon, 18 Oct 2004 15:18:22 +0900
X-reformat-comment: Tabs were expanded into 4 column tabstops by the Galaxy's archiver. See http://katsu.watanabe.name/ancientfj/galaxy-format.html for more info.

This is a minor mode for editing MIME message using GNU Emacs.  It is
still in beta-test.  Voice is not completed.  Please do not complain
about it.  On coming v19 emacs, it will be able to be enhanced in much
fancy way.

To use from Mail mode and News mode:

(autoload 'mime-mode "mime" "Edit MIME message." t)
(setq mail-mode-hook
      '(lambda ()
 ;; Turn on MIME mode automatically.
 (mime-mode)))
(setq news-reply-mode-hook
      '(lambda ()
 ;; MIME too.
 (mime-mode)))

You have to "C-c C-c" twice to send mail or post news.  First C-c C-c
exits MIME mode, and the second C-c C-c sends or posts actually.
----------------------------------------------------------------------
;;; Poorman's Simple MIME Composer
;; Copyright (C) 1993 Masanobu UMEDA (umerin@mse.kyutech.ac.jp)
;; $Header: mime.el,v 1.5 93/03/27 22:37:32 umerin Locked $

;; This file is part of GNU Emacs.

;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY.  No author or distributor
;; accepts responsibility to anyone for the consequences of using it
;; or for whether it serves any particular purpose or works at all,
;; unless he says so in writing.  Refer to the GNU Emacs General Public
;; License for full details.

;; Everyone is granted permission to copy, modify and redistribute
;; GNU Emacs, but only under the conditions described in the
;; GNU Emacs General Public License.   A copy of this license is
;; supposed to have been given to you along with GNU Emacs so you
;; can know your rights and responsibilities.  It should be in a
;; file named COPYING.  Among other things, the copyright notice
;; and this notice must be preserved on all copies.

;; LCD Archive Entry:
;; mime|Masanobu UMEDA|umerin@mse.kyutech.ac.jp|
;; Simple MIME Composer|
;; $Date: 93/03/27 22:37:32 $|$Revision: 1.5 $|~/misc/mime.el.Z|

;; Content-Type Tag:
;;--[[TYPE/SUBTYPE; OPTIONS]]
;;
;; 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]]
;; $B$3$l$O(B charset $B$r(B iso-2022-jp $B$K;XDj$7$?F|K\8l$N(B plain $B%F%-%9%H$G$9(B.
;;
;;--[[text/richtext]]
;; <center>This is a richtext.</center>
;;
;;--[[image/gif]]^MContent-Transfer-Encoding: base64^M...image comes here...
;;
;;--[[audio/basic]]^MContent-Transfer-Encoding: base64^M...audio comes here...

(provide 'mime)

(defvar mime-prefix "\C-cC-x"
  "*Keymap prefix for MIME commands.")

(defvar mime-content-subtypes
  '(("text" "plain" "richtext")
    ("image" "gif")
    ("audio" "basic")
    ("message" "external-body" "rfc822"))
  "*Alist of content type and its subtypes.")

(defvar mime-content-options
  '(("text"
     ("plain"
      ("charset" "iso-2022-jp" "us-ascii"))
     ("richtext"
      ("charset" "iso-2022-jp" "us-ascii")))
    ("message"
     ("external-body"
      ("access-type" "anon-ftp" "ftp")
      ("site")
      ("directory")
      ("name"))))
  "*Alist of content-type, subtype, options and its values.")

(defvar mime-file-types
  '(("\\.xwd$""image""x-xwd"nil)
    ("\\.xbm$""image""x-xbm"nil)
    ("\\.gif$""image""gif"nil)
    ("\\.jpeg$""image""jpeg"nil)
    ("\\.ps$""application""postscript"nil)
    ("\\.au$""audio""basic"nil))
  "*Alist of file name, types and options.")

(defvar mime-message-encoder
  '(("base64""mmencode""mmencode -u")
    ("quoted-printable""mmencode -q""mmencode -q -u")
    ("8bit"nil nil)
    ("7bit"nil nil) ;Default
    ("binary"nil nil))
  "*Alist of encoding, encoder, and decoder.
Encoder and decoder is a command string, function symbol or lambda
list which take two arguments.  If it is nil, no conversion is done.")

(defvar mime-tag-regexp "^--[[][[]\\([^]]*\\)]]"
  "*Regexp of Content-Type tag in the text.")

(defvar mime-tag-format "--[[%s]]"
  "*Control-string generating a Content-Type tag.")

(defvar mime-multipart-boundary "Multipart"
  "*Boundary of a multipart message.")


(defconst mime-version-number "1"
  "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)))

(defvar mime-mode-map nil)
(if mime-mode-map
    nil
  (setq mime-mode-map (make-sparse-keymap))
  (define-key mime-mode-map "\C-t" 'mime-insert-text)
  (define-key mime-mode-map "\C-v" 'mime-insert-voice)
  (define-key mime-mode-map "\C-e" 'mime-insert-external)
  (define-key mime-mode-map "\C-i" 'mime-include-file)
  (define-key mime-mode-map "\C-z" 'mime-mode-exit)
  (define-key mime-mode-map "?" 'help-mime-mode))

(defun mime-mode ()
  "Minor mode for editing tagged MIME message.

In this mode, basically, the message should be composed in the tagged
MIME format.  The message tag looks like:

'--[[text/plain; charset=iso-2022-jp]]'.

The tag specifies the content-type, subtype, and options of the
message following the tag in terms of MIME.  Messages without any tag
are treated as text/plain by default.  Binary messages such as audio
and image are usually hidden in this mode using selective-display
facility.  The messages in tagged MIME format are translated into a
MIME compliant message when exiting this mode.

Commands with a prefix (specified by the variable mime-prefix):
C-tmime-insert-textinsert text message
C-vmime-insert-voiceinsert voice message
C-emime-insert-externalinsert reference to external body
C-imime-include-fileinsert from a (binary) file
C-zmime-mode-exitexit mime edit mode
?help-mime-modeshow this message

The following is a message example 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]]
$B$3$l$O(B charset $B$r(B iso-2022-jp $B$K;XDj$7$?F|K\8l$N(B plain $B%F%-%9(B
$B%H$G$9(B.
--[[text/richtext]]
<center>This is a richtext.</center>
--[[image/gif]]^MContent-Transfer-Encoding: base64^M...image here...
--[[audio/basic]]^Montent-Transfer-Encoding: base64^M...audio here...

Turning on MIME mode calls the value of mime-mode-hook, if they are
non-nil."
  (interactive)
  (if mime-mode-flag
      (error "You are already editing a MIME.")
    (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))
    (use-local-map (copy-keymap (current-local-map)))
    (local-set-key mime-prefix mime-mode-map)
    ;; These are necessary to avoid sending before conversion into
    ;; MIME in Mail mode and News mode.
    (local-set-key "\C-c\C-c" 'mime-mode-exit)
    (local-set-key "\C-c\C-s" 'mime-mode-exit)
    ;; 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 these.
    (setq paragraph-start
  (concat mime-tag-regexp "\\|" paragraph-start))
    (setq paragraph-separate
  (concat mime-tag-regexp "\\|" paragraph-separate))
    (run-hooks 'mime-mode-hook)
    (message
     (substitute-command-keys
      "Type \\[mime-mode-exit] in this buffer to exit MIME mode."))
    ))

(fset 'edit-mime 'mime-mode); for convenience

(defun mime-mode-exit (&optional nomime)
  "Convert tagged MIME message into 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.")
    (if (not nomime)
(mime-encode-buffer))
    (setq mime-mode-flag nil)
    ;; Restore previous state.
    (use-local-map mime-mode-old-local-map)
    (setq selective-display mime-mode-old-selective-display)
    (set-buffer-modified-p (buffer-modified-p))))

(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 mime-insert-text ()
  "Insert text message."
  (interactive)
  (if (and (mime-insert-message "text" nil nil)
   (looking-at mime-tag-regexp))
      (progn
;; Make a space between the following message.
(insert "\n")
(forward-char -1))))

(defun mime-insert-voice ()
  "Insert voice message."
  (interactive)
  (mime-insert-message "audio" "basic" nil)
  (let ((file (mime-record-voice)))
    (mime-insert-binary-file file "base64")
    (delete-file file)
    ))

(defun mime-insert-external ()
  "Insert reference to external body."
  (interactive)
  (mime-insert-message "message" "external-body" nil)
  ;;(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)))
    (insert "Content-type: " pritype "/" subtype "\n"))
  (if (and (not (eobp))
   (not (looking-at mime-tag-regexp)))
      (insert (mime-make-default-tag) "\n")))

(defun mime-include-file (file)
  "Insert message from a file."
  (interactive "fInclude file: ")
  (let*  ((guess (mime-guess-content file))
  (pritype (nth 0 guess))
  (subtype (nth 1 guess))
  (options (nth 2 guess)))
    (mime-insert-message pritype subtype options)
    (mime-insert-binary-file file "base64")))


;; Insert new MIME tag at around point.

(defun mime-insert-message (&optional pritype subtype options)
  "Insert new MIME message tag.
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 options
  (or options (mime-prompt-for-options pritype subtype)))
    ;; Make a new MIME tag.
    (setq newtag (mime-make-tag pritype subtype options))
    ;; Find an old MIME tag.
    (setq oldtag
  (save-excursion
    (end-of-line)
    (if (re-search-backward mime-tag-regexp nil t)
(buffer-substring (match-beginning 0) (match-end 0)))))
    ;; We are only interested in TEXT.
    (if (and oldtag
     (not (string-match "[^a-zA-Z0-9]text/" oldtag)))
(setq oldtag nil))
    ;; Copy the tag for a message at current point if necessary.
    (if (save-excursion
  (forward-line -1)
  (and (looking-at mime-tag-regexp)
       (progn
 (goto-char (match-end 0))
 (not (= (following-char) ?\^M)))))
(forward-line -1))
    (beginning-of-line)
    (if (and oldtag
     (not (eobp))
     (not (looking-at mime-tag-regexp))
     (not (string-equal oldtag newtag)))
(save-excursion
  (insert oldtag "\n")))
    ;; Make a new tag.
    (if (or (not oldtag)
    (not (string-equal oldtag newtag)))
(progn
  (insert newtag "\n")
  t;New entry is created.
  )
      ;; Restore previous point.
      (goto-char current)
      nil;Nothing is created.
      )
    ))

;; Insert the content of binary file after MIME tag.

(defun mime-insert-binary-file (file &optional encoding)
  "Insert binary FILE at point.
Optional argument specifies an encoding method such as BASE64."
  (let* ((encoding (downcase (or encoding "base64")))
 (encoder (nth 1 (assoc encoding mime-message-encoder))))
    (save-restriction
      (narrow-to-region (1- (point)) (point))
      (insert "Content-Transfer-Encoding: " encoding "\n\n")
      (let ((start (point))
    (kanji-flag nil));NEmacs hack.
(insert-file-contents file)
;; Encode binary message if necessary.
(cond ((stringp encoder)
       (shell-command-on-region start (point-max) encoder t))
      (encoder
       (funcall encoder start (point-max)))
      ))
      (mime-flag-region (point-min) (1- (point-max)) ?\^M)
      (goto-char (point-max))
      )))

;; Guess content type, subtype, and options from file name.

(defun mime-guess-content (file)
  "Guess content type from FILE name."
  (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."
  (completing-read "Content-Type: "
   mime-content-subtypes
   nil
   t
   nil
   ))

(defun mime-prompt-for-subtype (pritype)
  "Ask for Content-type subtype for Content-Type PRITYPE."
  (completing-read "Content subtype: "
   (mapcar (function list)
   (cdr (assoc pritype
       mime-content-subtypes)))
   nil
   t
   (car (cdr (assoc pritype
    mime-content-subtypes)))
   ))

(defun mime-prompt-for-options (pritype subtype)
  "Ask for Content-type options for Content-Type PRITYPE and SUBTYPE."
  (mapconcat
   (function
    (lambda (optlist)
      (concat (car optlist)
      "="
      (if (cdr optlist)
  (completing-read (concat (car optlist) ": ")
   (mapcar (function list)
   (cdr optlist))
   nil
   nil
   (car (cdr optlist)))
(read-string (concat (car optlist) ": ")))
      )))
   (cdr (assoc subtype (cdr (assoc pritype mime-content-options))))
   "; "
   ))

(defun mime-make-tag (pritype subtype &optional options)
  "Make a tag of MIME message of PRITYPE, SUBTYPE and optional OPTIONS."
  (format mime-tag-format
  (concat pritype "/" subtype
  (if (and (stringp options)
   (not (string-equal options "")))
      (concat "; " options))
  )))

(defun mime-make-default-tag ()
  "Make a default tag of MIME message.
Content-type is 'text' and its subtype is obtained from mime-content-options."
  (let* ((pritype "text")
 (subtype (car (car (cdr (assoc pritype mime-content-options))))))
    (mime-make-tag pritype subtype
   (mime-default-options pritype subtype))))

(defun mime-default-options (pritype subtype)
  "Return default options for content-type PRITYPE and SUBTYPE."
  (mapconcat
   (function
    (lambda (optlist)
      (concat (car optlist)
      "="
      (car (cdr optlist)))))
   (cdr (assoc subtype (cdr (assoc pritype mime-content-options))))
   "; "
   ))

(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))))


;; Translate tagged MIME messages into a MIME compliant message.

(defun mime-encode-buffer ()
  "Encode tagged MIME message in current buffer in MIME compliant message."
  (interactive)
  (save-excursion
    (let ((boundary
   (concat mime-multipart-boundary " " (current-time-string)))
  (ctype nil)       ;Content type
  (npart 0))       ;Number of body part
      (save-restriction
;; We are interested in message body.
(goto-char (point-min))
(search-forward (concat "\n" mail-header-separator "\n") nil t)
(narrow-to-region (point) (point-max))
;; Counting the number of Content-Type.
(goto-char (point-min))
(while (re-search-forward mime-tag-regexp nil t)
  (setq npart (1+ npart)))
;; Normalize the body.
(goto-char (point-min))
;; Insert the first MIME tags if necessary.
(if (not (looking-at mime-tag-regexp))
    (progn
      (setq npart (1+ npart))
      (insert (mime-make-default-tag) "\n")
      ))
;; Insert MIME tags after mmencoded messages.
(while (re-search-forward mime-tag-regexp nil t)
  (if (= (following-char) ?\^M)
      (progn
(forward-line 1)
(if (and (not (eobp))
 (not (looking-at mime-tag-regexp)))
    (progn
      (setq npart (1+ npart))
      (insert (mime-make-default-tag) "\n")))
))
  )
;; Begin translation.
(cond ((<= npart 1)
       ;; It's a singular message.
       (goto-char (point-min))
       (while (re-search-forward mime-tag-regexp nil t)
 (setq ctype
       (buffer-substring (match-beginning 1) (match-end 1)))
 (delete-region (match-beginning 0)
(min (1+ (match-end 0)) (point-max)))
 ))
      (t
       ;; It's a multipart message.
       (goto-char (point-min))
       (while (re-search-forward mime-tag-regexp nil t)
 (setq ctype
       (buffer-substring (match-beginning 1) (match-end 1)))
 (delete-region (match-beginning 0) (match-end 0))
 (insert "--" boundary "\n")
 (insert "Content-Type: " ctype)
 ;; Show the text hiden with selective display.
 (if (= (following-char) ?\^M)
     (mime-flag-region (progn (beginning-of-line) (point))
       (progn (end-of-line) (point))
       ?\n)
   (insert "\n"))
 )
       ;; Insert the trailer.
       (goto-char (point-max))
       (if (not (= (preceding-char) ?\n))
   ;; Boundary must start with a newline.
   (insert "\n"))
       (insert "--" boundary "--\n"))
      )
)
      ;; Make primary MIME headers.
      (or (mail-position-on-field "Mime-Version")
  (insert mime-version-number))
      ;; Remove Content-Type field if exists.
      (if (mail-position-on-field "Content-Type")
  (save-restriction
    (goto-char (point-min))
    (search-forward (concat "\n" mail-header-separator "\n"))
    (narrow-to-region (point-min) (point))
    (goto-char (point-min))
    (while (re-search-forward "^Content-Type:[ \t]*" nil t)
      (delete-region (match-beginning 0)
     (progn (forward-line 1) (point))))
    ))
      ;; Then, insert new Content-Type field.
      (cond ((<= npart 1)
     (mail-position-on-field "Content-Type")
     (insert ctype))
    (t
     (mail-position-on-field "Content-Type")
     (insert "multipart/mixed; boundary=\"" boundary "\""))
    )
      )))
--
Masanobu UMEDA
umerin@mse.kyutech.ac.jp
Faculty of Computer Science and System Engineering
Kyushu Institute of Technology
