🚀 go-pugleaf

In article <7826@charon.cwi.nl> guido@cwi.nl (Guido van Rossum) writes:

   >;; mime-compise.el

   This seems to work with the *default* Emacs mail package, but not with
   mh-e.  Has anybody ported this to mh-e?  (There's already a MIME
   *reading* hook for mh-e, but sending leaves much to wish...)

Amazing you should mention that.  Just added it last night (thanks to
a helpful net.contributor).  Here's a newer version.

(One new feature, audio-snippet, will only work on SGI Indigo's and
4D/35's at the moment.  Anyone out there on this system, please let me
know if it works for you.  Comments welcome.  Also, don't set
mime-use-selective-display to t yet, it's not safe.)

;;; --------------------------------------------------------------------------
;;; File: --- mime-compose.el ---
;;; Author: Marc Andreessen (marca@ncsa.uiuc.edu)
;;; Copyright (C) National Center for Supercomputing Applications, 1992.
;;;
;;; Further hacked by: Keith Waclena <k-waclena@uchicago.edu>
;;;
;;; 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 1, 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 your copy of Emacs; if not, write to the Free Software
;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
;;;
;;; CONTENTS
;;;
;;; mime-compose: Utility routines for composing MIME-compliant mail.
;;; $Revision: 1.7 $
;;; $Date: 1992/11/03 22:12:58 $
;;;
;;; ------------------------------ INSTRUCTIONS ------------------------------
;;;
;;; Use the normal Emacs mail composer (C-x m).
;;;
;;; (Or, use with Emacs mh-e by loading this file *after* loading mh-e.
;;; Try putting (require 'mime-compose) in mh-letter-mode-hook.)
;;;
;;; Do nothing special to prepare a message to have MIME elements
;;; included in it.
;;;
;;; The basic commands to add MIME elements (images, audio, etc.) to a
;;; message are as follows:
;;;
;;; mail-mode  mh-e         command
;;; ---------  ---------    -------
;;; C-c g      C-c C-m g    Add a GIF file.
;;; C-c j      C-c C-m j    Add a JPEG file.
;;; C-c a      C-c C-m a    Add a (basic) audio file.
;;; C-c p      C-c C-m p    Add a PostScript file.
;;;
;;; (Note that mime-compose assumes you have the 'mmencode' program
;;; installed on your system.  See 'WHAT MIME IS' below for more
;;; information on mmencode and the metamail distribution.)
;;;
;;; Some mime-compose commands create data themselves; these follow:
;;;
;;; C-c x     C-c C-m x
;;;   Add the result of an X-window dump.  The program named in
;;;   mime-xwd-command will be run, and the resulting dump will be
;;;   inserted into the message.
;;;
;;; If you have a raw binary file and MIME doesn't have built-in
;;; support for it (e.g. an Emacs Lisp byte-compiled file), you can
;;; use:
;;;
;;; C-c r     C-c C-m r
;;;   Add a raw binary file.  You will be prompted for both the
;;;   filename and the content type of the file; if you do not give a
;;;   content type, the default (application/octet-stream) will be
;;;   used, and the recipient will be able to have his/her MIME mail
;;;   handler extract the raw binary file from the message.
;;;
;;; In addition to including files and generating inclusions on the
;;; fly, you can also point to external elements: files that will not
;;; be included in the document, but can be accessed by the recipient
;;; in some other way (most commonly, via FTP).  The following
;;; commands handle this:
;;;
;;; C-c e     C-c C-m e
;;;   Point to an external file (assumed to be accessable via
;;;   anonymous FTP).  You will be prompted for the name of the FTP
;;;   site, the remote directory name, and remote filename, the remote
;;;   file's content type, and a description of the remote file.
;;;   Content type can be any MIME content type (examples include
;;;   'image/gif', 'audio/basic', and 'application/postscript'; see
;;;   the MIME RFC and your local mailcap file for more information).
;;; C-c f     C-c C-m f
;;;   This is the same as 'C-c e', except that the file will be
;;;   accessed via regular FTP rather than anonymous FTP -- a username
;;;   and password will have to be provided by the recipient to gain
;;;   access to the file.
;;;
;;; ---------------------------- ADDITIONAL NOTES ----------------------------
;;;
;;; If you are running Lucid Emacs, the mail-mode popup menu (attached
;;; to the third mouse button) will include mime-compose entries.
;;;
;;; After your message has been `mimified' (by including a MIME
;;; element), it is best not to put trailing text outside the final
;;; boundary at the end of the file -- such text will not be
;;; considered to be part of the message by MIME-compliant mail
;;; readers (although it will still be sent).
;;;
;;; A command that usually isn't necessary, but is provided in case
;;; you wish to send a plaintext message with the various MIME headers
;;; and boundaries, is:
;;;
;;; C-c m     C-c C-m m     Mimify a message.
;;;
;;; MIME messages can contain elements and structures not yet
;;; supported by mime-compose.  If you have ideas or code, please send
;;; them to the author.
;;;
;;; ------------------------ WHAT MIME-COMPOSE IS NOT ------------------------
;;;
;;; mime-compose is not a MIME message handler.  It will not interpret
;;; MIME messages, display images, or anything similar.
;;;
;;; mime-compose is not intelligent enough (yet) to construct complex
;;; MIME messages (with nested boundaries, parallel message elements,
;;; and so on).
;;;
;;; mime-compose will not enforce correctness (MIME compliance) on
;;; your messages.  mime-compose generates MIME-compliant message
;;; elements, but will sit quietly if you alter them or add your own
;;; incorrect elements.
;;;
;;; ------------------------------ WHAT MIME IS ------------------------------
;;;
;;; MIME defines a format for email messages containing non-plaintext
;;; elements (images, audio, etc.).  MIME is detailed in Internet RFC
;;; 1341, by N. Borenstein and N. Freed.  You can FTP this RFC from
;;; many archive sites, including uxc.cso.uiuc.edu.
;;;
;;; Few mail readers handle MIME messages, yet.  However, most popular
;;; mail readers can be easily patched to feed MIME messages to a
;;; program called 'metamail', which can handle MIME messages.  You
;;; can FTP metamail from thumper.bellcore.com in /pub/nsb as
;;; mm.tar.Z.  Since mime-compose requires the existence of the
;;; program 'mmencode' (from the metamail distribution) to insert
;;; binary files into messages, it is a Good Idea to have metamail
;;; installed on your system.
;;;
;;; --------------------------------------------------------------------------
;;; LCD Archive Entry:
;;; mime-compose|Marc Andreessen|marca@ncsa.uiuc.edu
;;; |MIME-compliant message generation utilities.
;;; |$Date: 1992/11/03 22:12:58 $|$Revision: 1.7 $|
;;; --------------------------------------------------------------------------

(provide 'mime-compose)
(require 'sendmail)

(defvar mime-primary-boundary "bucketofwarmspit"
  "*Word used as a MIME boundary.")

(defvar mime-xwd-command "xwd -frame"
  "*Command used to do a window dump under the X Window System.")

(defvar mime-use-selective-display nil
  "*Use selective-display to hide bodies of MIME enclosures.")

(defun mime-primary-boundary ()
  "Return the current primary boundary."
  mime-primary-boundary)

(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 ((modp (buffer-modified-p)))
    (unwind-protect
        (subst-char-in-region from to
			      (if (= flag ?\n) ?\^M ?\n)
			      flag t)
     (set-buffer-modified-p modp))))

(defun mime-mimify-message ()
  "Add MIME headers to a message.  Add an initial informational message
for mailreaders that don't process MIME automatically.  Add an initial
area for plaintext.  Add a closing boundary at the end of the message.
This function is safe to call more than once."
  (interactive)
  (let ((mail-header-separator (if (eq major-mode 'mh-letter-mode)
				   "\n\n\\|^-+$"
				 mail-header-separator)))
    (or
     (save-excursion
       (goto-char (point-min))
       (re-search-forward "^Mime-Version: "
                          (save-excursion
                            (goto-char (point-min))
                            (re-search-forward mail-header-separator)
                            (point))
                          t))
     (let ((mime-virgin-message (save-excursion
                                  (next-line -1)
                                  (looking-at mail-header-separator))))
       (if mime-virgin-message
           (insert "\n"))
       ;; Configure selective-display if we want it...
       (if mime-use-selective-display
           (setq selective-display t))
       (save-excursion
         (save-excursion
           (goto-char (point-min))
           (re-search-forward mail-header-separator)
           (beginning-of-line)
           (insert "Mime-Version: 1.0\n")
           (insert "Content-Type: multipart/mixed;\n")
           (insert "\tboundary=" (mime-primary-boundary) "\n")
           (next-line 1)
           (insert "> THIS IS A MESSAGE IN 'MIME' FORMAT.\n")
           (insert 
            "> If you are reading this, your mail reader may not support MIME.\n")
           (insert 
            "> Some parts of this message will be readable as plain text.\n")
           (insert "\n")
           (goto-char (point-max))
           (insert "\n")
           (insert "\n")
           (insert "--" (mime-primary-boundary) "--\n"))
         (save-excursion
           (goto-char (point-min))
           (re-search-forward mail-header-separator)
           (beginning-of-line)
           (next-line 5)
           (insert "--" (mime-primary-boundary) "\n")
           (insert "Content-type: text/plain\n")
           (insert "\n"))
         (if mime-virgin-message
             (backward-delete-char 1)))))))

(defun mime-include-binary-file (filename content-type)
  "Include a binary file at point in a MIME message.  Encode it
in base64 mode."
  (mime-mimify-message)
  (push-mark)
  (insert "--" (mime-primary-boundary) "\n")
  (insert "Content-type: " content-type "\n")
  (insert "Content-Transfer-Encoding: base64\n")
  (insert "\n")
  (let ((start (point)) end)
    (next-line 1)
    (save-excursion
      (next-line -1)
      (insert-file filename))
    (setq end (point))
    (shell-command-on-region start end "mmencode" t)
    (setq end (point))
    (if selective-display
        (mime-flag-region start (- end 1) ?\^M))
    (insert "\n")
    (insert "--" (mime-primary-boundary) "\n")
    (insert "Content-type: text/plain\n")
    (insert "\n\n")
    (next-line -1)))

(defun mime-include-nonbinary-file (filename content-type)
  "Include a nonbinary file at point in a MIME message.  Encode it
in quoted-printable mode."
  (mime-mimify-message)
  (push-mark)
  (insert "--" (mime-primary-boundary) "\n")
  (insert "Content-type: " content-type "\n")
  (insert "Content-Transfer-Encoding: quoted-printable\n")
  (insert "\n")
  (let ((start (point)) end)
    (next-line 1)
    (save-excursion
      (next-line -1)
      (insert-file filename))
    (setq end (point))
    (shell-command-on-region start end "mmencode -q" t)
    (setq end (point))
    (insert "\n")
    (insert "--" (mime-primary-boundary) "\n")
    (insert "Content-type: text/plain\n")
    (insert "\n\n")
    (next-line -1)))

(defun mime-include-external (site directory name content-type description 
                                   access-type)
  "Include an external pointer in a MIME message."
  (mime-mimify-message)
  (insert "--" (mime-primary-boundary) "\n")
  (insert "Content-type: message/external-body;\n")
  (insert "\taccess-type=\"" access-type "\";\n")
  (insert "\tsite=\"" site "\";\n")
  (insert "\tdirectory=\"" directory "\";\n")
  (insert "\tname=\"" name "\"\n")
  (insert "Content-description: " description "\n")
  (insert "\n")
  (insert "Content-type: " content-type "\n")
  (insert "\n")
  (insert "\n")
  (insert "--" (mime-primary-boundary) "\n")
  (insert "Content-type: text/plain\n")
  (insert "\n"))

(defun mime-include-external-anonftp (site directory name content-type 
                                           description)
  "Include an external pointer (anonymous FTP) in a MIME message."
  (interactive "sFTP site: \nsRemote directory name: \nsRemote filename: \nsContent type: \nsDescription: ")
  (mime-include-external site directory name content-type description "anon-ftp"))

(defun mime-include-external-ftp (site directory name content-type description)
  "Include an external pointer (regular FTP) in a MIME message."
  (interactive "sFTP site: \nsRemote directory name: \nsRemote filename: \nsContent type: \nsDescription: ")
  (mime-include-external site directory name content-type description "ftp"))

(defun mime-include-xwd-dump ()
  "Run xwd and include the results in a MIME message."
  (interactive)
  (mime-mimify-message)
  (push-mark)
  (insert "--" (mime-primary-boundary) "\n")
  (insert "Content-type: image/x-xwd\n")
  (insert "Content-Transfer-Encoding: base64\n")
  (insert "\n")
  (let ((start (point)) end)
    (next-line 1)
    (save-excursion
      (next-line -1)
      (shell-command mime-xwd-command t))
    (setq end (point))
    (shell-command-on-region start end "mmencode" t)
    (setq end (point))
    (insert "\n")
    (insert "--" (mime-primary-boundary) "\n")
    (insert "Content-type: text/plain\n")
    (insert "\n\n")
    (next-line -1)))

(defun mime-grab-audio-snippet ()
  (let ((audio-process))
    (setq audio-process 
          (start-process "snippet" "snippet" 
                         "recordaiff" "-n" "1" "-s" "8" "-r" "8000"
                         "/tmp/fooblatz.aiff"))
    ;; Quick hack to make Emacs sit until recording is done.
    (y-or-n-p "Press y or n when finished: ")
    (interrupt-process "snippet")
    ;; Wait until recordaiff has written data to disk. */
    (while (eq (process-status "snippet") 'run)
      (message "Waiting...")
      (sleep-for 1))
    ;; Kill off recordaiff and our buffer.
    (delete-process "snippet")
    (kill-buffer "snippet")
    ;; Remove the old mulaw file and do the conversion.
    (shell-command "rm -r /tmp/fooblatz")
    (shell-command 
     "sfconvert /tmp/fooblatz.aiff /tmp/fooblatz -o mulaw")))

(defun mime-include-audio-snippet ()
  "Record a snippet of audio in a MIME message.  This will only work
on SGI IRIS Indigo's and PI/35's."
  (interactive)
  (mime-mimify-message)
  (push-mark)
  (insert "--" (mime-primary-boundary) "\n")
  (insert "Content-type: audio/basic\n")
  (insert "Content-Transfer-Encoding: base64\n")
  (insert "\n")
  (let ((start (point)) end)
    (next-line 1)
    (save-excursion
      (next-line -1)
      (mime-grab-audio-snippet)
      (insert-file "/tmp/fooblatz"))
    (setq end (point))
    (shell-command-on-region start end "mmencode" t)
    (setq end (point))
    (insert "\n")
    (insert "--" (mime-primary-boundary) "\n")
    (insert "Content-type: text/plain\n")
    (insert "\n\n")
    (next-line -1)))

(defun mime-include-gif (filename)
  "Include a GIF file."
  (interactive "fGIF image filename: ")
  (mime-include-binary-file filename "image/gif"))
(defun mime-include-jpeg (filename)
  "Include a JPEG file."
  (interactive "fJPEG image filename: ")
  (mime-include-binary-file filename "image/jpeg"))
(defun mime-include-audio (filename)
  "Include an audio file."
  (interactive "fAudio filename: ")
  (mime-include-binary-file filename "audio/basic"))
(defun mime-include-postscript (filename)
  "Include a PostScript file."
  (interactive "fPostScript filename: ")
  (mime-include-nonbinary-file filename "application/postscript"))
(defun mime-include-raw-binary (filename content-type)
  "Include a raw binary file."
  (interactive "fRaw binary filename: \nsContent type (RET for default): ")
  (if (string= content-type "")
      (setq content-type "application/octet-stream"))
  (mime-include-binary-file filename content-type))

;;; Add functions to basic mail mode.
(define-key mail-mode-map "\C-cm" 'mime-mimify-message)
(define-key mail-mode-map "\C-cg" 'mime-include-gif)
(define-key mail-mode-map "\C-cj" 'mime-include-jpeg)
(define-key mail-mode-map "\C-ca" 'mime-include-audio)
(define-key mail-mode-map "\C-cp" 'mime-include-postscript)
(define-key mail-mode-map "\C-cr" 'mime-include-raw-binary)
(define-key mail-mode-map "\C-cx" 'mime-include-xwd-dump)
(define-key mail-mode-map "\C-ce" 'mime-include-external-anonftp)
(define-key mail-mode-map "\C-cf" 'mime-include-external-ftp)
(define-key mail-mode-map "\C-cs" 'mime-include-audio-snippet)

;;; Add functions to MH letter mode.
(if (boundp 'mh-letter-mode-map)
    (if (or (not (boundp 'mh-letter-mode-mime-map)) 
            (not mh-letter-mode-mime-map))
        (progn
          (setq mh-letter-mode-mime-map (make-sparse-keymap))
          (define-key mh-letter-mode-map "\C-c\C-m" mh-letter-mode-mime-map)
          (define-key mh-letter-mode-mime-map "m" 'mime-mimify-message)
          (define-key mh-letter-mode-mime-map "g" 'mime-include-gif)
          (define-key mh-letter-mode-mime-map "j" 'mime-include-jpeg)
          (define-key mh-letter-mode-mime-map "a" 'mime-include-audio)
          (define-key mh-letter-mode-mime-map "p" 'mime-include-postscript)
          (define-key mh-letter-mode-mime-map "r" 'mime-include-raw-binary)
          (define-key mh-letter-mode-mime-map "x" 'mime-include-xwd-dump)
          (define-key mh-letter-mode-mime-map "e" 
            'mime-include-external-anonftp)
          (define-key mh-letter-mode-mime-map "f" 
            'mime-include-external-ftp)
          (define-key mh-letter-mode-mime-map "s"
            'mime-include-audio-snippet))))

;;; -------------------------------- Menubar ---------------------------------

(defvar mime-running-lemacs (string-match "Lucid" emacs-version)
  "Non-nil if running Lucid Emacs.")

;; All we do at the moment is replace the popup menu defined in
;; Lucid Emacs 19.3's sendmail.el.
(if mime-running-lemacs
    (progn
      (setq mail-mode-menu
        '("Mail Mode"
          "Sending Mail:"
          "----"
          ["Send and Exit"		mail-send-and-exit		t]
          ["Send Mail"			mail-send			t]
          ["Sent Via"			mail-sent-via			t]
          "----"
          "Go to Field:"
          "----"
          ["To:"			mail-to				t]
          ["Subject:"			mail-subject			t]
          ["CC:"			mail-cc				t]
          ["BCC:"			mail-bcc			t]
          ["Text"			mail-text			t]
          "----"
          "Miscellaneous Commands:"
          "----"
          ["Yank Original"		mail-yank-original		t]
          ["Fill Yanked Message"	mail-fill-yanked-message	t]
          ["Insert Signature"		mail-signature			t]
          "----"
          "MIME Inclusions:"
          "----"
          ["Include GIF File"           mime-include-gif                t]
          ["Include JPEG File"          mime-include-jpeg               t]
          ["Include Audio File"         mime-include-audio              t]
          ["Include PostScript File"    mime-include-postscript         t]
          ["Include XWD Dump"           mime-include-xwd-dump           t]
          ["Include Raw Binary File"    mime-include-raw-binary         t]
          ["Include External AnonFTP"   mime-include-external-anonftp   t]
          ["Include External FTP"       mime-include-external-ftp       t]
          "----"
          ["Abort" kill-buffer t]
          ))))

;;; ----------------------------- New mail-send ------------------------------

;; If we're not running Lemacs, pop in a new mail-send routine.
(if (not mime-running-lemacs)
    (defun mail-send ()
      "Send the message in the current buffer.
If  mail-interactive  is non-nil, wait for success indication
or error messages, and inform user.
Otherwise any failure is reported in a message back to
the user from the mailer."
      (interactive)
      (message "Sending...")
      (run-hooks 'mail-send-hook)
      (funcall send-mail-function)
      (set-buffer-modified-p nil)
      (delete-auto-save-file-if-necessary)
      (message "Sending...done")))

;;; --------------------------------- Hooks ----------------------------------

;; Author: Daniel LaLiberte (liberte@cs.uiuc.edu).

(defun mime-unfrob-selective-display ()
  "Prepare the current message to be really sent."
  (message "Unfrobbing selective-display...")
  (mime-flag-region (point-min) (point-max) ?\n))

(defun mime-postpend-unique-hook (hook-var hook-function)
  "Postpend HOOK-VAR with HOOK-FUNCTION, if it is not already an element.
hook-var's value may be a single function or a list of functions."
  (if (boundp hook-var)
      (let ((value (symbol-value hook-var)))
        (if (and (listp value) (not (eq (car value) 'lambda)))
            (and (not (memq hook-function value))
                 (set hook-var (append value (list hook-function))))
          (and (not (eq hook-function value))
               (set hook-var (append value (list hook-function))))))
    (set hook-var (list hook-function))))

;; Before the message is sent, remove the selective display crap.
(mime-postpend-unique-hook 'mail-send-hook 'mime-unfrob-selective-display)

---------------------------------

Marc

--
Marc Andreessen
Software Development Group
National Center for Supercomputing Applications
marca@ncsa.uiuc.edu