code.delx.au - gnu-emacs/blob - lisp/mail/mh-mime.el

   1 ;;; mh-mime.el --- mh-e support for composing MIME messages
   2
   3 ;; Copyright (C) 1993, 1995, 2001, 2002 Free Software Foundation, Inc.
   4
   5 ;; Author: Bill Wohler <wohler@newt.com>
   6 ;; Maintainer: Bill Wohler <wohler@newt.com>
   7 ;; Keywords: mail
   8 ;; See: mh-e.el
   9
  10 ;; This file is part of GNU Emacs.
  11
  12 ;; GNU Emacs is free software; you can redistribute it and/or modify
  13 ;; it under the terms of the GNU General Public License as published by
  14 ;; the Free Software Foundation; either version 2, or (at your option)
  15 ;; any later version.
  16
  17 ;; GNU Emacs is distributed in the hope that it will be useful,
  18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  20 ;; GNU General Public License for more details.
  21
  22 ;; You should have received a copy of the GNU General Public License
  23 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  24 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  25 ;; Boston, MA 02111-1307, USA.
  26
  27 ;;; Commentary:
  28
  29 ;; Internal support for mh-e package.
  30 ;; Support for generating an mhn composition file.
  31 ;; MIME is supported only by MH 6.8 or later.
  32
  33 ;;; Change Log:
  34
  35 ;; $Id: mh-mime.el,v 1.26 2002/04/07 19:20:56 wohler Exp $
  36
  37 ;;; Code:
  38
  39 (provide 'mh-mime)
  40 (require 'mh-comp)
  41
  42 ;; To do:
  43 ;; paragraph code should not fill # lines if MIME enabled.
  44 ;; implement mh-auto-edit-mhn (if non-nil, \\[mh-send-letter]
  45 ;;      invokes mh-edit-mhn automatically before sending.)
  46 ;;      actually, instead of mh-auto-edit-mhn,
  47 ;;      should read automhnproc from profile
  48 ;; MIME option to mh-forward
  49 ;; command to move to content-description insertion point
  50
  51 (defvar mh-mhn-args nil
  52   "Extra arguments to have \\[mh-edit-mhn] pass to the \"mhn\" command.
  53 The arguments are passed to mhn if \\[mh-edit-mhn] is given a
  54 prefix argument.  Normally default arguments to mhn are specified in the
  55 MH profile.")
  56
  57 (defvar mh-edit-mhn-hook nil
  58   "Invoked on the formatted letter by \\<mh-letter-mode-map>\\[mh-edit-mhn].")
  59
  60 (defun mh-have-file-command ()
  61   "Return t if 'file' command is on the system.
  62 'file -i' is used to get MIME type of composition insertion."
  63   (when (not (boundp 'mh-have-file-command))
  64     (load "executable" t t)     ; executable-find not autoloaded in emacs20
  65     (setq mh-have-file-command
  66           (and (fboundp 'executable-find)
  67                (executable-find "file") ; file command exists
  68                                         ;   and accepts -i and -b args.
  69                (zerop (call-process "file" nil nil nil "-i" "-b"
  70                                     (expand-file-name "inc" mh-progs))))))
  71   mh-have-file-command)
  72
  73 (defun mh-file-mime-type (filename)
  74   "Return MIME type of FILENAME from file command.
  75 Returns nil if file command not on system."
  76   (cond
  77    ((not (mh-have-file-command))
  78     nil)                                ;No file command, exit now.
  79    ((not (and (file-exists-p filename)(file-readable-p filename)))
  80     nil)
  81    (t
  82     (save-excursion
  83       (let ((tmp-buffer (get-buffer-create mh-temp-buffer)))
  84         (set-buffer tmp-buffer)
  85         (unwind-protect
  86             (progn
  87               (call-process "file" nil '(t nil) nil "-b" "-i"
  88                             (expand-file-name filename))
  89               (goto-char (point-min))
  90               (if (not (re-search-forward mh-media-type-regexp nil t))
  91                   nil
  92                 (match-string 0)))
  93           (kill-buffer tmp-buffer)))))))
  94
  95 (defvar mh-mhn-compose-insert-p nil
  96   "Buffer-local variable to know whether MIME insertion was done.
  97 Triggers an automatic call to `mh-edit-mhn' in `mh-send-letter'.")
  98 (make-variable-buffer-local 'mh-mhn-compose-insert-p)
  99
 100 ;;; This is needed for Emacs20 which doesn't have mailcap-mime-types.
 101 (defvar mh-mime-content-types
 102   '(("application/mac-binhex40") ("application/msword")
 103     ("application/octet-stream") ("application/pdf") ("application/pgp-keys")
 104     ("application/pgp-signature") ("application/pkcs7-signature")
 105     ("application/postscript") ("application/rtf")
 106     ("application/vnd.ms-excel") ("application/vnd.ms-powerpoint")
 107     ("application/vnd.ms-project") ("application/vnd.ms-tnef")
 108     ("application/wordperfect5.1") ("application/wordperfect6.0")
 109     ("application/zip")
 110
 111     ("audio/basic") ("audio/mpeg")
 112
 113     ("image/gif") ("image/jpeg") ("image/png")
 114
 115     ("message/delivery-status")
 116     ("message/external-body") ("message/partial") ("message/rfc822")
 117
 118     ("text/enriched") ("text/html") ("text/plain") ("text/rfc822-headers")
 119     ("text/richtext") ("text/xml")
 120
 121     ("video/mpeg") ("video/quicktime"))
 122   "Legal MIME content types.
 123 See documentation for \\[mh-edit-mhn].")
 124
 125 (defvar mh-media-type-regexp
 126   (concat (regexp-opt '("text" "image" "audio" "video" "application"
 127                         "multipart" "message") t)
 128           "/[-.+a-zA-Z0-9]+")
 129   "Regexp matching valid media types used in MIME attachment compositions.")
 130
 131 (defun mh-mhn-compose-insertion (filename type description attributes)
 132   "Add a directive to insert a MIME message part from a file.
 133 This is the typical way to insert non-text parts in a message. Arguments are
 134 FILENAME, which tells where to find the file, TYPE, the MIME content type,
 135 DESCRIPTION, a line of text for the Content-Description field. ATTRIBUTES is a
 136 comma separated list of name=value pairs that is appended to the Content-Type
 137 field of the attachment.
 138 See also \\[mh-edit-mhn]."
 139   (interactive (let ((filename (read-file-name "Insert contents of: ")))
 140                  (list
 141                   filename
 142                   (or (mh-file-mime-type filename)
 143                       (completing-read "Content-Type: "
 144                                        (if (and (require 'mailcap nil t)
 145                                                 (fboundp 'mailcap-mime-types))
 146                                            (mapcar 'list (mailcap-mime-types))
 147                                          mh-mime-content-types)))
 148                   (read-string "Content-Description: ")
 149                   (read-string "Content-Attributes: "
 150                                (concat "name=\""
 151                                        (file-name-nondirectory filename)
 152                                        "\"")))))
 153   (mh-mhn-compose-type filename type description attributes ))
 154
 155 (defun mh-mhn-compose-type (filename type
 156                             &optional description attributes comment)
 157   (setq mh-mhn-compose-insert-p t)
 158   (beginning-of-line)
 159   (insert "#" type)
 160   (and attributes
 161        (insert "; " attributes))
 162   (and comment
 163        (insert " (" comment ")"))
 164   (insert " [")
 165   (and description
 166        (insert description))
 167   (insert "] " (expand-file-name filename))
 168   (insert "\n"))
 169
 170
 171 (defun mh-mhn-compose-anon-ftp (host filename type description)
 172   "Add a directive for a MIME anonymous ftp external body part.
 173 This directive tells MH to include a reference to a
 174 message/external-body part retrievable by anonymous FTP.  Arguments
 175 are HOST and FILENAME, which tell where to find the file, TYPE, the
 176 MIME content type, and DESCRIPTION, a line of text for the
 177 Content-description header.  See also \\[mh-edit-mhn]."
 178   (interactive (list
 179                 (read-string "Remote host: ")
 180                 (read-string "Remote filename: ")
 181                 (completing-read "External Content-Type: "
 182                                  (if (and (require 'mailcap nil t)
 183                                           (fboundp 'mailcap-mime-types))
 184                                      (mapcar 'list (mailcap-mime-types))
 185                                    mh-mime-content-types))
 186                 (read-string "External Content-Description: ")))
 187   (mh-mhn-compose-external-type "anon-ftp" host filename
 188                                 type description))
 189
 190 (defun mh-mhn-compose-external-compressed-tar (host filename description)
 191   "Add a directive to include a MIME reference to a compressed tar file.
 192 The file should be available via anonymous ftp.  This directive
 193 tells MH to include a reference to a message/external-body part.
 194 Arguments are HOST and FILENAME, which tell where to find the file, and
 195 DESCRIPTION, a line of text for the Content-description header.
 196 See also \\[mh-edit-mhn]."
 197   (interactive (list
 198                 (read-string "Remote host: ")
 199                 (read-string "Remote filename: ")
 200                 (read-string "Tar file Content-description: ")))
 201   (mh-mhn-compose-external-type "anon-ftp" host filename
 202                                 "application/octet-stream"
 203                                 description
 204                                 "type=tar; conversions=x-compress"
 205                                 "mode=image"))
 206
 207
 208 (defun mh-mhn-compose-external-type (access-type host filename type
 209                                      &optional description
 210                                      attributes extra-params comment)
 211   (setq mh-mhn-compose-insert-p t)
 212   (beginning-of-line)
 213   (insert "#@" type)
 214   (and attributes
 215        (insert "; " attributes))
 216   (and comment
 217        (insert " (" comment ") "))
 218   (insert " [")
 219   (and description
 220        (insert description))
 221   (insert "] ")
 222   (insert "access-type=" access-type "; ")
 223   (insert "site=" host)
 224   (insert "; name=" (file-name-nondirectory filename))
 225   (insert "; directory=\"" (file-name-directory filename) "\"")
 226   (and extra-params
 227        (insert "; " extra-params))
 228   (insert "\n"))
 229
 230 (defun mh-mhn-compose-forw (&optional description folder messages)
 231   "Add a forw directive to this message, to forward a message with MIME.
 232 This directive tells MH to include the named messages in this one.
 233 Arguments are DESCRIPTION, a line of text for the Content-description header,
 234 and FOLDER and MESSAGES, which name the message(s) to be forwarded.
 235 See also \\[mh-edit-mhn]."
 236   (interactive (list
 237                 (read-string "Forw Content-description: ")
 238                 (mh-prompt-for-folder "Message from" mh-sent-from-folder nil)
 239                 (read-string (format "Messages%s: "
 240                                      (if mh-sent-from-msg
 241                                          (format " [%d]" mh-sent-from-msg)
 242                                        "")))))
 243   (setq mh-mhn-compose-insert-p t)
 244   (beginning-of-line)
 245   (insert "#forw [")
 246   (and description
 247        (not (string= description ""))
 248        (insert description))
 249   (insert "]")
 250   (and folder
 251        (not (string= folder ""))
 252        (insert " " folder))
 253   (if (and messages
 254            (not (string= messages "")))
 255       (let ((start (point)))
 256         (insert " " messages)
 257         (subst-char-in-region start (point) ?, ? ))
 258     (if mh-sent-from-msg
 259         (insert " " (int-to-string mh-sent-from-msg))))
 260   (insert "\n"))
 261
 262 (defun mh-edit-mhn (&optional extra-args)
 263   "Format the current draft for MIME, expanding any mhn directives.
 264
 265 Process the current draft with the mhn program, which, using directives
 266 already inserted in the draft, fills in all the MIME components and header
 267 fields.
 268
 269 This step should be done last just before sending the message.
 270
 271 The `\\[mh-revert-mhn-edit]' command undoes this command. The arguments in the
 272 list `mh-mhn-args' are passed to mhn if this function is passed an optional
 273 prefix argument EXTRA-ARGS.
 274
 275 For assistance with creating mhn directives to insert various types of
 276 components in a message, see \\[mh-mhn-compose-insertion] (generic insertion
 277 from a file), \\[mh-mhn-compose-anon-ftp] (external reference to file via
 278 anonymous ftp), \\[mh-mhn-compose-external-compressed-tar] \ \(reference to
 279 compressed tar file via anonymous ftp), and \\[mh-mhn-compose-forw] (forward
 280 message). If these helper functions are used, `mh-edit-mhn' is run
 281 automatically when the draft is sent.
 282
 283 The mhn program is part of MH version 6.8 or later."
 284   (interactive "*P")
 285   (save-buffer)
 286   (message "mhn editing...")
 287   (cond
 288    (mh-nmh-p
 289     (mh-exec-cmd-error nil
 290                        "mhbuild" (if extra-args mh-mhn-args) buffer-file-name))
 291    (t
 292     (mh-exec-cmd-error (format "mhdraft=%s" buffer-file-name)
 293                        "mhn" (if extra-args mh-mhn-args) buffer-file-name)))
 294   (setq mh-mhn-compose-insert-p nil)
 295   (revert-buffer t t)
 296   (message "mhn editing...done")
 297   (run-hooks 'mh-edit-mhn-hook))
 298
 299
 300 (defun mh-revert-mhn-edit (noconfirm)
 301   "Undo the effect of \\[mh-edit-mhn] by reverting to the backup file.
 302 Optional non-nil argument NOCONFIRM means don't ask for confirmation."
 303   (interactive "*P")
 304   (if (null buffer-file-name)
 305       (error "Buffer does not seem to be associated with any file"))
 306   (let ((backup-strings '("," "#"))
 307         backup-file)
 308     (while (and backup-strings
 309                 (not (file-exists-p
 310                       (setq backup-file
 311                             (concat (file-name-directory buffer-file-name)
 312                                     (car backup-strings)
 313                                     (file-name-nondirectory buffer-file-name)
 314                                     ".orig")))))
 315       (setq backup-strings (cdr backup-strings)))
 316     (or backup-strings
 317         (error "Backup file for %s no longer exists!" buffer-file-name))
 318     (or noconfirm
 319         (yes-or-no-p (format "Revert buffer from file %s? "
 320                              backup-file))
 321         (error "Revert not confirmed"))
 322     (let ((buffer-read-only nil))
 323       (erase-buffer)
 324       (insert-file-contents backup-file))
 325     (after-find-file nil)))
 326
 327 ;;; mh-mime.el ends here