mh-mime.el 60.7 KB
Newer Older
Bill Wohler's avatar
Bill Wohler committed
1
;;; mh-mime.el --- MH-E support for composing MIME messages
Richard M. Stallman's avatar
Richard M. Stallman committed
2

3 4
;; Copyright (C) 1993, 1995, 2001, 02, 03, 2004, 2005
;;  Free Software Foundation, Inc.
Bill Wohler's avatar
Bill Wohler committed
5 6 7 8 9

;; Author: Bill Wohler <wohler@newt.com>
;; Maintainer: Bill Wohler <wohler@newt.com>
;; Keywords: mail
;; See: mh-e.el
Richard M. Stallman's avatar
Richard M. Stallman committed
10

11
;; This file is part of GNU Emacs.
Richard M. Stallman's avatar
Richard M. Stallman committed
12

Karl Heuer's avatar
Karl Heuer committed
13
;; GNU Emacs is free software; you can redistribute it and/or modify
Richard M. Stallman's avatar
Richard M. Stallman committed
14 15 16 17
;; 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.

Karl Heuer's avatar
Karl Heuer committed
18
;; GNU Emacs is distributed in the hope that it will be useful,
Richard M. Stallman's avatar
Richard M. Stallman committed
19 20 21 22 23
;; 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
Erik Naggum's avatar
Erik Naggum committed
24 25 26
;; along with GNU Emacs; see the file COPYING.  If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.
Richard M. Stallman's avatar
Richard M. Stallman committed
27 28 29

;;; Commentary:

Bill Wohler's avatar
Bill Wohler committed
30
;; Internal support for MH-E package.
Erik Naggum's avatar
Erik Naggum committed
31 32
;; Support for generating an mhn composition file.
;; MIME is supported only by MH 6.8 or later.
Richard M. Stallman's avatar
Richard M. Stallman committed
33

Karl Heuer's avatar
Karl Heuer committed
34 35
;;; Change Log:

Richard M. Stallman's avatar
Richard M. Stallman committed
36 37
;;; Code:

Bill Wohler's avatar
Bill Wohler committed
38
(eval-when-compile (require 'mh-acros))
Bill Wohler's avatar
Bill Wohler committed
39 40
(mh-require-cl)
(require 'mh-comp)
Bill Wohler's avatar
Bill Wohler committed
41
(require 'gnus-util)
Bill Wohler's avatar
Bill Wohler committed
42
(require 'mh-gnus)
Bill Wohler's avatar
Bill Wohler committed
43 44 45 46 47 48 49

(autoload 'gnus-article-goto-header "gnus-art")
(autoload 'article-emphasize "gnus-art")
(autoload 'gnus-get-buffer-create "gnus")
(autoload 'gnus-eval-format "gnus-spec")
(autoload 'widget-convert-button "wid-edit")
(autoload 'message-options-set-recipient "message")
Bill Wohler's avatar
Bill Wohler committed
50
(autoload 'mml-unsecure-message "mml-sec")
Bill Wohler's avatar
Bill Wohler committed
51 52 53 54 55
(autoload 'mml-minibuffer-read-file "mml")
(autoload 'mml-minibuffer-read-description "mml")
(autoload 'mml-insert-empty-tag "mml")
(autoload 'mml-to-mime "mml")
(autoload 'mml-attach-file "mml")
Bill Wohler's avatar
Bill Wohler committed
56
(autoload 'rfc2047-decode-region "rfc2047")
Bill Wohler's avatar
Bill Wohler committed
57

Bill Wohler's avatar
Bill Wohler committed
58
;;;###mh-autoload
Bill Wohler's avatar
Bill Wohler committed
59 60 61 62 63 64 65 66 67 68 69 70
(defun mh-compose-insertion (&optional inline)
  "Add a directive to insert a MIME part from a file, using mhn or gnus.
If the variable `mh-compose-insertion' is set to 'mhn, then that will be used.
If it is set to 'gnus, then that will be used instead.
Optional argument INLINE means make it an inline attachment."
  (interactive "P")
  (if (equal mh-compose-insertion 'gnus)
      (if inline
          (mh-mml-attach-file "inline")
        (mh-mml-attach-file))
    (call-interactively 'mh-mhn-compose-insertion)))

Bill Wohler's avatar
Bill Wohler committed
71
;;;###mh-autoload
Bill Wohler's avatar
Bill Wohler committed
72 73 74 75 76 77 78 79 80 81
(defun mh-compose-forward (&optional description folder message)
  "Add a MIME directive to forward a message, using mhn or gnus.
If the variable `mh-compose-insertion' is set to 'mhn, then that will be used.
If it is set to 'gnus, then that will be used instead.
Optional argument DESCRIPTION is a description of the attachment.
Optional argument FOLDER is the folder from which the forwarded message should
come.
Optional argument MESSAGE is the message to forward.
If any of the optional arguments are absent, they are prompted for."
  (interactive (list
Bill Wohler's avatar
Bill Wohler committed
82 83 84
                (read-string "Forw Content-description: ")
                (mh-prompt-for-folder "Message from" mh-sent-from-folder nil)
                (read-string (format "Messages%s: "
Bill Wohler's avatar
Bill Wohler committed
85
                                     (if (numberp mh-sent-from-msg)
Bill Wohler's avatar
Bill Wohler committed
86
                                         (format " [%d]" mh-sent-from-msg)
Bill Wohler's avatar
Bill Wohler committed
87
                                       "")))))
Bill Wohler's avatar
Bill Wohler committed
88 89 90
  (if (equal mh-compose-insertion 'gnus)
      (mh-mml-forward-message description folder message)
    (mh-mhn-compose-forw description folder message)))
Richard M. Stallman's avatar
Richard M. Stallman committed
91 92 93 94

;; To do:
;; paragraph code should not fill # lines if MIME enabled.
;; implement mh-auto-edit-mhn (if non-nil, \\[mh-send-letter]
Bill Wohler's avatar
Bill Wohler committed
95
;;      invokes mh-edit-mhn automatically before sending.)
Richard M. Stallman's avatar
Richard M. Stallman committed
96 97 98 99 100
;;      actually, instead of mh-auto-edit-mhn,
;;      should read automhnproc from profile
;; MIME option to mh-forward
;; command to move to content-description insertion point

Karl Heuer's avatar
Karl Heuer committed
101 102 103 104 105 106
(defvar mh-mhn-args nil
  "Extra arguments to have \\[mh-edit-mhn] pass to the \"mhn\" command.
The arguments are passed to mhn if \\[mh-edit-mhn] is given a
prefix argument.  Normally default arguments to mhn are specified in the
MH profile.")

Bill Wohler's avatar
Bill Wohler committed
107 108 109 110 111 112 113 114 115
(defvar mh-media-type-regexp
  (concat (regexp-opt '("text" "image" "audio" "video" "application"
                        "multipart" "message") t)
          "/[-.+a-zA-Z0-9]+")
  "Regexp matching valid media types used in MIME attachment compositions.")

;; Just defvar the variable to avoid compiler warning... This doesn't bind
;; the variable, so things should work exactly as before.
(defvar mh-have-file-command)
Karl Heuer's avatar
Karl Heuer committed
116

Bill Wohler's avatar
Bill Wohler committed
117
;;;###mh-autoload
Bill Wohler's avatar
Bill Wohler committed
118 119 120 121
(defun mh-have-file-command ()
  "Return t if 'file' command is on the system.
'file -i' is used to get MIME type of composition insertion."
  (when (not (boundp 'mh-have-file-command))
Bill Wohler's avatar
Bill Wohler committed
122
    (load "executable" t t)        ; executable-find not autoloaded in emacs20
Bill Wohler's avatar
Bill Wohler committed
123 124 125 126 127 128 129 130
    (setq mh-have-file-command
          (and (fboundp 'executable-find)
               (executable-find "file") ; file command exists
                                        ;   and accepts -i and -b args.
               (zerop (call-process "file" nil nil nil "-i" "-b"
                                    (expand-file-name "inc" mh-progs))))))
  mh-have-file-command)

Bill Wohler's avatar
Bill Wohler committed
131 132
(defvar mh-file-mime-type-substitutions
  '(("application/msword" "\.xls" "application/ms-excel")
Bill Wohler's avatar
Bill Wohler committed
133 134
    ("application/msword" "\.ppt" "application/ms-powerpoint")
    ("text/plain" "\.vcf" "text/x-vcard"))
Bill Wohler's avatar
Bill Wohler committed
135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155
  "Substitutions to make for Content-Type returned from file command.
The first element is the Content-Type returned by the file command.
The second element is a regexp matching the file name, usually the extension.
The third element is the Content-Type to replace with.")

(defun mh-file-mime-type-substitute (content-type filename)
  "Return possibly changed CONTENT-TYPE on the FILENAME.
Substitutions are made from the `mh-file-mime-type-substitutions' variable."
  (let ((subst mh-file-mime-type-substitutions)
        (type) (match) (answer content-type)
        (case-fold-search t))
    (while subst
      (setq type (car (car subst))
            match (elt (car subst) 1))
      (if (and (string-equal content-type type)
               (string-match match filename))
          (setq answer (elt (car subst) 2)
                subst nil)
        (setq subst (cdr subst))))
    answer))

Bill Wohler's avatar
Bill Wohler committed
156
;;;###mh-autoload
Bill Wohler's avatar
Bill Wohler committed
157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175
(defun mh-file-mime-type (filename)
  "Return MIME type of FILENAME from file command.
Returns nil if file command not on system."
  (cond
   ((not (mh-have-file-command))
    nil)                                ;No file command, exit now.
   ((not (and (file-exists-p filename)(file-readable-p filename)))
    nil)
   (t
    (save-excursion
      (let ((tmp-buffer (get-buffer-create mh-temp-buffer)))
        (set-buffer tmp-buffer)
        (unwind-protect
            (progn
              (call-process "file" nil '(t nil) nil "-b" "-i"
                            (expand-file-name filename))
              (goto-char (point-min))
              (if (not (re-search-forward mh-media-type-regexp nil t))
                  nil
Bill Wohler's avatar
Bill Wohler committed
176
                (mh-file-mime-type-substitute (match-string 0) filename)))
Bill Wohler's avatar
Bill Wohler committed
177 178 179
          (kill-buffer tmp-buffer)))))))

;;; This is needed for Emacs20 which doesn't have mailcap-mime-types.
Richard M. Stallman's avatar
Richard M. Stallman committed
180
(defvar mh-mime-content-types
Bill Wohler's avatar
Bill Wohler committed
181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197
  '(("application/mac-binhex40") ("application/msword")
    ("application/octet-stream") ("application/pdf") ("application/pgp-keys")
    ("application/pgp-signature") ("application/pkcs7-signature")
    ("application/postscript") ("application/rtf")
    ("application/vnd.ms-excel") ("application/vnd.ms-powerpoint")
    ("application/vnd.ms-project") ("application/vnd.ms-tnef")
    ("application/wordperfect5.1") ("application/wordperfect6.0")
    ("application/zip")

    ("audio/basic") ("audio/mpeg")

    ("image/gif") ("image/jpeg") ("image/png")

    ("message/delivery-status")
    ("message/external-body") ("message/partial") ("message/rfc822")

    ("text/enriched") ("text/html") ("text/plain") ("text/rfc822-headers")
Bill Wohler's avatar
Bill Wohler committed
198
    ("text/richtext") ("text/x-vcard") ("text/xml")
Bill Wohler's avatar
Bill Wohler committed
199 200

    ("video/mpeg") ("video/quicktime"))
201
  "Valid MIME content types.
Bill Wohler's avatar
Bill Wohler committed
202 203
See documentation for \\[mh-edit-mhn].")

Bill Wohler's avatar
Bill Wohler committed
204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227
;; RFC 2045 - Multipurpose Internet Mail Extensions (MIME) Part One:
;;            Format of Internet Message Bodies.
;; RFC 2046 - Multipurpose Internet Mail Extensions (MIME) Part Two:
;;            Media Types.
;; RFC 2049 - Multipurpose Internet Mail Extensions (MIME) Part Five:
;;            Conformance Criteria and Examples.
;; RFC 2017 - Definition of the URL MIME External-Body Access-Type
;; RFC 1738 - Uniform Resource Locators (URL)
(defvar mh-access-types
  '(("anon-ftp")        ; RFC2046 Anonymous File Transfer Protocol
    ("file")            ; RFC1738 Host-specific file names
    ("ftp")             ; RFC2046 File Transfer Protocol
    ("gopher")          ; RFC1738 The Gopher Protocol
    ("http")            ; RFC1738 Hypertext Transfer Protocol
    ("local-file")      ; RFC2046 Local file access
    ("mail-server")     ; RFC2046 mail-server Electronic mail address
    ("mailto")          ; RFC1738 Electronic mail address
    ("news")            ; RFC1738 Usenet news
    ("nntp")            ; RFC1738 Usenet news using NNTP access
    ("propspero")       ; RFC1738 Prospero Directory Service
    ("telnet")          ; RFC1738 Telnet
    ("tftp")            ; RFC2046 Trivial File Transfer Protocol
    ("url")             ; RFC2017 URL scheme MIME access-type Protocol
    ("wais"))           ; RFC1738 Wide Area Information Servers
228
  "Valid MIME access-type values.")
Bill Wohler's avatar
Bill Wohler committed
229

Bill Wohler's avatar
Bill Wohler committed
230
;;;###mh-autoload
231
(defun mh-mhn-compose-insertion (filename type description attributes)
Karl Heuer's avatar
Karl Heuer committed
232
  "Add a directive to insert a MIME message part from a file.
Bill Wohler's avatar
Bill Wohler committed
233 234 235 236 237 238 239
This is the typical way to insert non-text parts in a message.

Arguments are FILENAME, which tells where to find the file, TYPE, the MIME
content type, DESCRIPTION, a line of text for the Content-Description field.
ATTRIBUTES is a comma separated list of name=value pairs that is appended to
the Content-Type field of the attachment.

Bill Wohler's avatar
Bill Wohler committed
240 241
See also \\[mh-edit-mhn]."
  (interactive (let ((filename (read-file-name "Insert contents of: ")))
Bill Wohler's avatar
Bill Wohler committed
242 243
                 (list
                  filename
Bill Wohler's avatar
Bill Wohler committed
244
                  (or (mh-file-mime-type filename)
Bill Wohler's avatar
Bill Wohler committed
245 246 247 248 249 250 251 252 253
                      (completing-read "Content-Type: "
                                       (if (fboundp 'mailcap-mime-types)
                                           (mapcar 'list (mailcap-mime-types))
                                         mh-mime-content-types)))
                  (read-string "Content-Description: ")
                  (read-string "Content-Attributes: "
                               (concat "name=\""
                                       (file-name-nondirectory filename)
                                       "\"")))))
254
  (mh-mhn-compose-type filename type description attributes ))
Richard M. Stallman's avatar
Richard M. Stallman committed
255

256
(defun mh-mhn-compose-type (filename type
Bill Wohler's avatar
Bill Wohler committed
257
                                     &optional description attributes comment)
Bill Wohler's avatar
Bill Wohler committed
258 259 260 261 262
  "Insert a mhn directive to insert a file.

The file specified by FILENAME is encoded as TYPE. An optional DESCRIPTION is
used as the Content-Description field, optional set of ATTRIBUTES and an
optional COMMENT can also be included."
Richard M. Stallman's avatar
Richard M. Stallman committed
263 264 265 266 267 268 269 270 271
  (beginning-of-line)
  (insert "#" type)
  (and attributes
       (insert "; " attributes))
  (and comment
       (insert " (" comment ")"))
  (insert " [")
  (and description
       (insert description))
272
  (insert "] " (expand-file-name filename))
Richard M. Stallman's avatar
Richard M. Stallman committed
273 274 275
  (insert "\n"))


Bill Wohler's avatar
Bill Wohler committed
276
;;;###mh-autoload
277
(defun mh-mhn-compose-anon-ftp (host filename type description)
Karl Heuer's avatar
Karl Heuer committed
278
  "Add a directive for a MIME anonymous ftp external body part.
Bill Wohler's avatar
Bill Wohler committed
279 280 281 282 283 284 285 286
This directive tells MH to include a reference to a message/external-body part
retrievable by anonymous FTP.

Arguments are HOST and FILENAME, which tell where to find the file, TYPE, the
MIME content type, and DESCRIPTION, a line of text for the Content-description
header.

See also \\[mh-edit-mhn]."
Richard M. Stallman's avatar
Richard M. Stallman committed
287
  (interactive (list
Bill Wohler's avatar
Bill Wohler committed
288 289 290 291 292 293 294
                (read-string "Remote host: ")
                (read-string "Remote filename: ")
                (completing-read "External Content-Type: "
                                 (if (fboundp 'mailcap-mime-types)
                                     (mapcar 'list (mailcap-mime-types))
                                   mh-mime-content-types))
                (read-string "External Content-Description: ")))
295
  (mh-mhn-compose-external-type "anon-ftp" host filename
Bill Wohler's avatar
Bill Wohler committed
296
                                type description))
Richard M. Stallman's avatar
Richard M. Stallman committed
297

Bill Wohler's avatar
Bill Wohler committed
298
;;;###mh-autoload
299
(defun mh-mhn-compose-external-compressed-tar (host filename description)
Karl Heuer's avatar
Karl Heuer committed
300
  "Add a directive to include a MIME reference to a compressed tar file.
Bill Wohler's avatar
Bill Wohler committed
301 302 303
The file should be available via anonymous ftp. This directive tells MH to
include a reference to a message/external-body part.

304
Arguments are HOST and FILENAME, which tell where to find the file, and
Karl Heuer's avatar
Karl Heuer committed
305
DESCRIPTION, a line of text for the Content-description header.
Bill Wohler's avatar
Bill Wohler committed
306

Richard M. Stallman's avatar
Richard M. Stallman committed
307 308
See also \\[mh-edit-mhn]."
  (interactive (list
Bill Wohler's avatar
Bill Wohler committed
309 310 311
                (read-string "Remote host: ")
                (read-string "Remote filename: ")
                (read-string "Tar file Content-description: ")))
312
  (mh-mhn-compose-external-type "anon-ftp" host filename
Bill Wohler's avatar
Bill Wohler committed
313 314 315 316
                                "application/octet-stream"
                                description
                                "type=tar; conversions=x-compress"
                                "mode=image"))
Richard M. Stallman's avatar
Richard M. Stallman committed
317

Bill Wohler's avatar
Bill Wohler committed
318
;;;###mh-autoload
319
(defun mh-mhn-compose-external-type (access-type host filename type
Bill Wohler's avatar
Bill Wohler committed
320 321 322
                                                 &optional description
                                                 attributes extra-params
                                                 comment)
Bill Wohler's avatar
Bill Wohler committed
323 324 325 326 327 328 329 330 331 332
  "Add a directive to include a MIME reference to a remote file.
The file should be available via anonymous ftp. This directive tells MH to
include a reference to a message/external-body part.

Arguments are ACCESS-TYPE, HOST and FILENAME, which tell where to find the
file and TYPE which is the MIME Content-Type. Optional arguments include
DESCRIPTION, a line of text for the Content-description header, ATTRIBUTES,
EXTRA-PARAMS, and COMMENT.

See also \\[mh-edit-mhn]."
Bill Wohler's avatar
Bill Wohler committed
333 334 335 336 337 338 339 340 341 342 343 344
  (interactive (list
                (completing-read "Access Type: " mh-access-types)
                (read-string "Remote host: ")
                (read-string "Remote url-path: ")
                (completing-read "Content-Type: "
                                 (if (fboundp 'mailcap-mime-types)
                                     (mapcar 'list (mailcap-mime-types))
                                   mh-mime-content-types))
                (if current-prefix-arg (read-string "Content-description: "))
                (if current-prefix-arg (read-string "Attributes: "))
                (if current-prefix-arg (read-string "Extra Parameters: "))
                (if current-prefix-arg (read-string "Comment: "))))
Richard M. Stallman's avatar
Richard M. Stallman committed
345 346 347 348 349 350 351 352 353 354 355 356
  (beginning-of-line)
  (insert "#@" type)
  (and attributes
       (insert "; " attributes))
  (and comment
       (insert " (" comment ") "))
  (insert " [")
  (and description
       (insert description))
  (insert "] ")
  (insert "access-type=" access-type "; ")
  (insert "site=" host)
357
  (insert "; name=" (file-name-nondirectory filename))
Bill Wohler's avatar
Bill Wohler committed
358 359 360
  (let ((directory (file-name-directory filename)))
    (and directory
         (insert "; directory=\"" directory "\"")))
Richard M. Stallman's avatar
Richard M. Stallman committed
361 362 363 364
  (and extra-params
       (insert "; " extra-params))
  (insert "\n"))

Bill Wohler's avatar
Bill Wohler committed
365
;;;###mh-autoload
Karl Heuer's avatar
Karl Heuer committed
366
(defun mh-mhn-compose-forw (&optional description folder messages)
Karl Heuer's avatar
Karl Heuer committed
367
  "Add a forw directive to this message, to forward a message with MIME.
Richard M. Stallman's avatar
Richard M. Stallman committed
368
This directive tells MH to include the named messages in this one.
Bill Wohler's avatar
Bill Wohler committed
369

Richard M. Stallman's avatar
Richard M. Stallman committed
370
Arguments are DESCRIPTION, a line of text for the Content-description header,
Karl Heuer's avatar
Karl Heuer committed
371
and FOLDER and MESSAGES, which name the message(s) to be forwarded.
Bill Wohler's avatar
Bill Wohler committed
372

Richard M. Stallman's avatar
Richard M. Stallman committed
373 374
See also \\[mh-edit-mhn]."
  (interactive (list
Bill Wohler's avatar
Bill Wohler committed
375 376 377
                (read-string "Forw Content-description: ")
                (mh-prompt-for-folder "Message from" mh-sent-from-folder nil)
                (read-string (format "Messages%s: "
Bill Wohler's avatar
Bill Wohler committed
378
                                     (if (numberp mh-sent-from-msg)
Bill Wohler's avatar
Bill Wohler committed
379 380
                                         (format " [%d]" mh-sent-from-msg)
                                       "")))))
Richard M. Stallman's avatar
Richard M. Stallman committed
381 382 383 384 385 386 387 388 389
  (beginning-of-line)
  (insert "#forw [")
  (and description
       (not (string= description ""))
       (insert description))
  (insert "]")
  (and folder
       (not (string= folder ""))
       (insert " " folder))
Karl Heuer's avatar
Karl Heuer committed
390
  (if (and messages
Bill Wohler's avatar
Bill Wohler committed
391
           (not (string= messages "")))
Richard M. Stallman's avatar
Richard M. Stallman committed
392
      (let ((start (point)))
Bill Wohler's avatar
Bill Wohler committed
393 394
        (insert " " messages)
        (subst-char-in-region start (point) ?, ? ))
Bill Wohler's avatar
Bill Wohler committed
395
    (if (numberp mh-sent-from-msg)
Bill Wohler's avatar
Bill Wohler committed
396
        (insert " " (int-to-string mh-sent-from-msg))))
Richard M. Stallman's avatar
Richard M. Stallman committed
397 398
  (insert "\n"))

Bill Wohler's avatar
Bill Wohler committed
399
;;;###mh-autoload
Karl Heuer's avatar
Karl Heuer committed
400 401
(defun mh-edit-mhn (&optional extra-args)
  "Format the current draft for MIME, expanding any mhn directives.
Bill Wohler's avatar
Bill Wohler committed
402 403 404 405 406

Process the current draft with the mhn program, which, using directives
already inserted in the draft, fills in all the MIME components and header
fields.

Bill Wohler's avatar
Bill Wohler committed
407 408
This step is performed automatically when sending the message, but this
function may be called manually before sending the draft as well.
Bill Wohler's avatar
Bill Wohler committed
409 410 411 412 413 414 415 416 417 418

The `\\[mh-revert-mhn-edit]' command undoes this command. The arguments in the
list `mh-mhn-args' are passed to mhn if this function is passed an optional
prefix argument EXTRA-ARGS.

For assistance with creating mhn directives to insert various types of
components in a message, see \\[mh-mhn-compose-insertion] (generic insertion
from a file), \\[mh-mhn-compose-anon-ftp] (external reference to file via
anonymous ftp), \\[mh-mhn-compose-external-compressed-tar] \ \(reference to
compressed tar file via anonymous ftp), and \\[mh-mhn-compose-forw] (forward
Bill Wohler's avatar
Bill Wohler committed
419
message).
Bill Wohler's avatar
Bill Wohler committed
420

Bill Wohler's avatar
Bill Wohler committed
421 422 423
The value of `mh-edit-mhn-hook' is a list of functions to be called, with no
arguments, after performing the conversion.

Bill Wohler's avatar
Bill Wohler committed
424
The mhn program is part of MH version 6.8 or later."
Karl Heuer's avatar
Karl Heuer committed
425
  (interactive "*P")
Bill Wohler's avatar
Bill Wohler committed
426
  (mh-mhn-quote-unescaped-sharp)
Richard M. Stallman's avatar
Richard M. Stallman committed
427 428
  (save-buffer)
  (message "mhn editing...")
Bill Wohler's avatar
Bill Wohler committed
429
  (cond
Bill Wohler's avatar
Bill Wohler committed
430
   ((mh-variant-p 'nmh)
Bill Wohler's avatar
Bill Wohler committed
431 432 433 434 435
    (mh-exec-cmd-error nil
                       "mhbuild" (if extra-args mh-mhn-args) buffer-file-name))
   (t
    (mh-exec-cmd-error (format "mhdraft=%s" buffer-file-name)
                       "mhn" (if extra-args mh-mhn-args) buffer-file-name)))
Richard M. Stallman's avatar
Richard M. Stallman committed
436
  (revert-buffer t t)
Karl Heuer's avatar
Karl Heuer committed
437 438
  (message "mhn editing...done")
  (run-hooks 'mh-edit-mhn-hook))
Richard M. Stallman's avatar
Richard M. Stallman committed
439

Bill Wohler's avatar
Bill Wohler committed
440 441 442 443 444 445 446 447 448 449 450 451 452
(defun mh-mhn-quote-unescaped-sharp ()
  "Quote `#' characters that haven't been quoted for `mhbuild'.
If the `#' character is present in the first column, but it isn't part of a
MHN directive then `mhbuild' gives an error. This function will quote all such
characters."
  (save-excursion
    (goto-char (point-min))
    (while (re-search-forward "^#" nil t)
      (beginning-of-line)
      (unless (mh-mhn-directive-present-p (point) (line-end-position))
        (insert "#"))
      (goto-char (line-end-position)))))

Bill Wohler's avatar
Bill Wohler committed
453
;;;###mh-autoload
Richard M. Stallman's avatar
Richard M. Stallman committed
454
(defun mh-revert-mhn-edit (noconfirm)
Bill Wohler's avatar
Bill Wohler committed
455 456
  "Undo the effect of \\[mh-edit-mhn] by reverting to the backup file.
Optional non-nil argument NOCONFIRM means don't ask for confirmation."
Richard M. Stallman's avatar
Richard M. Stallman committed
457 458 459 460
  (interactive "*P")
  (if (null buffer-file-name)
      (error "Buffer does not seem to be associated with any file"))
  (let ((backup-strings '("," "#"))
Bill Wohler's avatar
Bill Wohler committed
461
        backup-file)
Richard M. Stallman's avatar
Richard M. Stallman committed
462
    (while (and backup-strings
Bill Wohler's avatar
Bill Wohler committed
463 464 465 466 467 468
                (not (file-exists-p
                      (setq backup-file
                            (concat (file-name-directory buffer-file-name)
                                    (car backup-strings)
                                    (file-name-nondirectory buffer-file-name)
                                    ".orig")))))
Richard M. Stallman's avatar
Richard M. Stallman committed
469 470
      (setq backup-strings (cdr backup-strings)))
    (or backup-strings
Bill Wohler's avatar
Bill Wohler committed
471
        (error "Backup file for %s no longer exists!" buffer-file-name))
Richard M. Stallman's avatar
Richard M. Stallman committed
472
    (or noconfirm
Bill Wohler's avatar
Bill Wohler committed
473 474 475
        (yes-or-no-p (format "Revert buffer from file %s? "
                             backup-file))
        (error "Revert not confirmed"))
Richard M. Stallman's avatar
Richard M. Stallman committed
476 477 478 479
    (let ((buffer-read-only nil))
      (erase-buffer)
      (insert-file-contents backup-file))
    (after-find-file nil)))
480

Bill Wohler's avatar
Bill Wohler committed
481
;;;###mh-autoload
Bill Wohler's avatar
Bill Wohler committed
482 483 484 485 486 487
(defun mh-mhn-directive-present-p (&optional begin end)
  "Check if the text between BEGIN and END might be a MHN directive.
The optional argument BEGIN defaults to the beginning of the buffer, while END
defaults to the the end of the buffer."
  (unless begin (setq begin (point-min)))
  (unless end (setq end (point-max)))
Bill Wohler's avatar
Bill Wohler committed
488 489
  (save-excursion
    (block 'search-for-mhn-directive
Bill Wohler's avatar
Bill Wohler committed
490 491
      (goto-char begin)
      (while (re-search-forward "^#" end t)
Bill Wohler's avatar
Bill Wohler committed
492 493 494 495 496
        (let ((s (buffer-substring-no-properties (point) (line-end-position))))
          (cond ((equal s ""))
                ((string-match "^forw[ \t\n]+" s)
                 (return-from 'search-for-mhn-directive t))
                (t (let ((first-token (car (split-string s "[ \t;@]"))))
Bill Wohler's avatar
Bill Wohler committed
497 498 499
                     (when (and first-token
                                (string-match mh-media-type-regexp
                                              first-token))
Bill Wohler's avatar
Bill Wohler committed
500 501 502
                       (return-from 'search-for-mhn-directive t)))))))
      nil)))

Bill Wohler's avatar
Bill Wohler committed
503 504 505 506


;;; MIME composition functions

Bill Wohler's avatar
Bill Wohler committed
507
;;;###mh-autoload
Bill Wohler's avatar
Bill Wohler committed
508
(defun mh-mml-to-mime ()
Bill Wohler's avatar
Bill Wohler committed
509 510 511
  "Compose MIME message from mml directives.
This step is performed automatically when sending the message, but this
function may be called manually before sending the draft as well."
Bill Wohler's avatar
Bill Wohler committed
512
  (interactive)
Bill Wohler's avatar
Bill Wohler committed
513
  (require 'message)
Bill Wohler's avatar
Bill Wohler committed
514 515
  (when mh-gnus-pgp-support-flag ;; This is only needed for PGP
    (message-options-set-recipient))
Bill Wohler's avatar
Bill Wohler committed
516 517 518 519 520 521 522 523 524 525
  (let ((saved-text (buffer-string))
        (buffer (current-buffer))
        (modified-flag (buffer-modified-p)))
    (condition-case err (mml-to-mime)
      (error
       (with-current-buffer buffer
         (delete-region (point-min) (point-max))
         (insert saved-text)
         (set-buffer-modified-p modified-flag))
       (error (error-message-string err))))))
Bill Wohler's avatar
Bill Wohler committed
526

Bill Wohler's avatar
Bill Wohler committed
527
;;;###mh-autoload
Bill Wohler's avatar
Bill Wohler committed
528 529 530 531
(defun mh-mml-forward-message (description folder message)
  "Forward a message as attachment.
The function will prompt the user for a DESCRIPTION, a FOLDER and MESSAGE
number."
Bill Wohler's avatar
Bill Wohler committed
532
  (let ((msg (if (and (equal message "") (numberp mh-sent-from-msg))
Bill Wohler's avatar
Bill Wohler committed
533 534 535 536 537 538 539 540 541 542 543 544
                 mh-sent-from-msg
               (car (read-from-string message)))))
    (cond ((integerp msg)
           (if (string= "" description)
               ;; Rationale: mml-attach-file constructs a malformed composition
               ;; if the description string is empty.  This fixes SF #625168.
               (mml-attach-file (format "%s%s/%d"
                                        mh-user-path (substring folder 1) msg)
                                "message/rfc822")
             (mml-attach-file (format "%s%s/%d"
                                      mh-user-path (substring folder 1) msg)
                              "message/rfc822"
Bill Wohler's avatar
Bill Wohler committed
545
                              description)))
Bill Wohler's avatar
Bill Wohler committed
546 547
          (t (error "The message number, %s is not a integer!" msg)))))

Bill Wohler's avatar
Bill Wohler committed
548 549 550 551 552 553 554 555 556 557 558 559 560
(defvar mh-mml-cryptographic-method-history ())

;;;###mh-autoload
(defun mh-mml-query-cryptographic-method ()
  "Read the cryptographic method to use."
  (if current-prefix-arg
      (let ((def (or (car mh-mml-cryptographic-method-history)
                     mh-mml-method-default)))
        (completing-read (format "Method: [%s] " def)
                         '(("pgp") ("pgpmime") ("smime"))
                         nil t nil 'mh-mml-cryptographic-method-history def))
    mh-mml-method-default))

Bill Wohler's avatar
Bill Wohler committed
561
;;;###mh-autoload
Bill Wohler's avatar
Bill Wohler committed
562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584
(defun mh-mml-attach-file (&optional disposition)
  "Attach a file to the outgoing MIME message.
The file is not inserted or encoded until you send the message with
`\\[mh-send-letter]'.
Message disposition is \"inline\" or \"attachment\" and is prompted for if
DISPOSITION is nil.

This is basically `mml-attach-file' from gnus, modified such that a prefix
argument yields an `inline' disposition and Content-Type is determined
automatically."
  (let* ((file (mml-minibuffer-read-file "Attach file: "))
         (type (or (mh-file-mime-type file)
                   (completing-read "Content-Type: "
                                    (if (fboundp 'mailcap-mime-types)
                                        (mapcar 'list (mailcap-mime-types))
                                      mh-mime-content-types))))
         (description (mml-minibuffer-read-description))
         (dispos (or disposition
                     (completing-read "Disposition: [attachment] "
                                      '(("attachment")("inline"))
                                      nil t nil nil
                                      "attachment"))))
    (mml-insert-empty-tag 'part 'type type 'filename file
Bill Wohler's avatar
Bill Wohler committed
585
                          'disposition dispos 'description description)))
Bill Wohler's avatar
Bill Wohler committed
586

Bill Wohler's avatar
Bill Wohler committed
587 588
(defvar mh-identity-pgg-default-user-id)

Bill Wohler's avatar
Bill Wohler committed
589 590 591 592 593
(defun mh-secure-message (method mode &optional identity)
  "Add directive to Encrypt/Sign an entire message.
METHOD should be one of: \"pgpmime\", \"pgp\", \"smime\".
MODE should be one of: \"sign\", \"encrypt\", \"signencrypt\", \"none\".
IDENTITY is optionally the default-user-id to use."
Bill Wohler's avatar
Bill Wohler committed
594 595
  (if (not mh-gnus-pgp-support-flag)
      (error "Sorry.  Your version of gnus does not support PGP/GPG")
Bill Wohler's avatar
Bill Wohler committed
596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611
    ;; Check the arguments
    (let ((valid-methods (list "pgpmime" "pgp" "smime"))
          (valid-modes (list "sign" "encrypt" "signencrypt" "none")))
      (if (not (member method valid-methods))
          (error (format "Sorry. METHOD \"%s\" is invalid." method)))
      (if (not (member mode valid-modes))
          (error (format "Sorry. MODE \"%s\" is invalid" mode)))
      (mml-unsecure-message)
      (if (not (string= mode "none"))
        (save-excursion
          (goto-char (point-min))
          (mh-goto-header-end 1)
          (if mh-identity-pgg-default-user-id
              (mml-insert-tag 'secure 'method method 'mode mode
                              'sender mh-identity-pgg-default-user-id)
            (mml-insert-tag 'secure 'method method 'mode mode)))))))
Bill Wohler's avatar
Bill Wohler committed
612

Bill Wohler's avatar
Bill Wohler committed
613
;;;###mh-autoload
Bill Wohler's avatar
Bill Wohler committed
614 615 616
(defun mh-mml-unsecure-message (&optional ignore)
  "Remove any secure message directives.
The IGNORE argument is not used."
Bill Wohler's avatar
Bill Wohler committed
617 618 619
  (interactive "P")
  (if (not mh-gnus-pgp-support-flag)
      (error "Sorry.  Your version of gnus does not support PGP/GPG")
Bill Wohler's avatar
Bill Wohler committed
620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638
    (mml-unsecure-message)))

;;;###mh-autoload
(defun mh-mml-secure-message-sign (method)
  "Add security directive to sign the entire message using METHOD."
  (interactive (list (mh-mml-query-cryptographic-method)))
  (mh-secure-message method "sign" mh-identity-pgg-default-user-id))

;;;###mh-autoload
(defun mh-mml-secure-message-encrypt (method)
  "Add security directive to encrypt the entire message using METHOD."
  (interactive (list (mh-mml-query-cryptographic-method)))
  (mh-secure-message method "encrypt" mh-identity-pgg-default-user-id))

;;;###mh-autoload
(defun mh-mml-secure-message-signencrypt (method)
  "Add security directive to encrypt and sign the entire message using METHOD."
  (interactive (list (mh-mml-query-cryptographic-method)))
  (mh-secure-message method "signencrypt" mh-identity-pgg-default-user-id))
Bill Wohler's avatar
Bill Wohler committed
639 640 641 642 643 644 645 646 647

;;;###mh-autoload
(defun mh-mml-directive-present-p ()
  "Check if the current buffer has text which may be an MML directive."
  (save-excursion
    (goto-char (point-min))
    (re-search-forward
     "\\(<#part\\(.\\|\n\\)*>[ \n\t]*<#/part>\\|^<#secure.+>$\\)"
     nil t)))
Bill Wohler's avatar
Bill Wohler committed
648 649 650 651 652



;;; MIME cleanup

Bill Wohler's avatar
Bill Wohler committed
653
;;;###mh-autoload
Bill Wohler's avatar
Bill Wohler committed
654 655 656 657
(defun mh-mime-cleanup ()
  "Free the decoded MIME parts."
  (let ((mime-data (gethash (current-buffer) mh-globals-hash)))
    ;; This is for Emacs, what about XEmacs?
Bill Wohler's avatar
Bill Wohler committed
658
    (mh-funcall-if-exists remove-images (point-min) (point-max))
Bill Wohler's avatar
Bill Wohler committed
659 660 661 662
    (when mime-data
      (mm-destroy-parts (mh-mime-handles mime-data))
      (remhash (current-buffer) mh-globals-hash))))

Bill Wohler's avatar
Bill Wohler committed
663
;;;###mh-autoload
Bill Wohler's avatar
Bill Wohler committed
664 665 666 667 668 669 670 671 672 673 674 675 676 677 678
(defun mh-destroy-postponed-handles ()
  "Free MIME data for externally displayed mime parts."
  (let ((mime-data (mh-buffer-data)))
    (when mime-data
      (mm-destroy-parts (mh-mime-handles mime-data)))
    (remhash (current-buffer) mh-globals-hash)))

(defun mh-handle-set-external-undisplayer (folder handle function)
  "Replacement for `mm-handle-set-external-undisplayer'.
This is only called in recent versions of Gnus. The MIME handles are stored
in data structures corresponding to MH-E folder buffer FOLDER instead of in
Gnus (as in the original). The MIME part, HANDLE is associated with the
undisplayer FUNCTION."
  (if (mm-keep-viewer-alive-p handle)
      (let ((new-handle (copy-sequence handle)))
Bill Wohler's avatar
Bill Wohler committed
679 680
        (mm-handle-set-undisplayer new-handle function)
        (mm-handle-set-undisplayer handle nil)
Bill Wohler's avatar
Bill Wohler committed
681 682 683 684 685 686 687 688
        (save-excursion
          (set-buffer folder)
          (push new-handle (mh-mime-handles (mh-buffer-data)))))
    (mm-handle-set-undisplayer handle function)))



;;; MIME transformations
Bill Wohler's avatar
Bill Wohler committed
689
(eval-when-compile (require 'font-lock))
Bill Wohler's avatar
Bill Wohler committed
690

Bill Wohler's avatar
Bill Wohler committed
691
;;;###mh-autoload
Bill Wohler's avatar
Bill Wohler committed
692 693 694 695 696
(defun mh-add-missing-mime-version-header ()
  "Some mail programs don't put a MIME-Version header.
I have seen this only in spam, so maybe we shouldn't fix this ;-)"
  (save-excursion
    (goto-char (point-min))
Bill Wohler's avatar
Bill Wohler committed
697 698 699 700 701 702
    (re-search-forward "\n\n" nil t)
    (save-restriction
      (narrow-to-region (point-min) (point))
      (when (and (message-fetch-field "content-type")
                 (not (message-fetch-field "mime-version")))
        (goto-char (point-min))
Bill Wohler's avatar
Bill Wohler committed
703 704
        (insert "MIME-Version: 1.0\n")))))

Bill Wohler's avatar
Bill Wohler committed
705 706 707 708 709 710 711 712 713 714 715 716
(defun mh-small-show-buffer-p ()
  "Check if show buffer is small.
This is used to decide if smileys and graphical emphasis will be displayed."
  (let ((max nil))
    (when (and (boundp 'font-lock-maximum-size) font-lock-maximum-size)
      (cond ((numberp font-lock-maximum-size)
             (setq max font-lock-maximum-size))
            ((listp font-lock-maximum-size)
             (setq max (cdr (or (assoc 'mh-show-mode font-lock-maximum-size)
                                (assoc t font-lock-maximum-size)))))))
    (or (not (numberp max)) (>= (/ max 8) (buffer-size)))))

Bill Wohler's avatar
Bill Wohler committed
717
;;;###mh-autoload
Bill Wohler's avatar
Bill Wohler committed
718 719
(defun mh-display-smileys ()
  "Function to display smileys."
Bill Wohler's avatar
Bill Wohler committed
720 721
  (when (and mh-graphical-smileys-flag (mh-small-show-buffer-p))
    (mh-funcall-if-exists smiley-region (point-min) (point-max))))
Bill Wohler's avatar
Bill Wohler committed
722

Bill Wohler's avatar
Bill Wohler committed
723
;;;###mh-autoload
Bill Wohler's avatar
Bill Wohler committed
724 725
(defun mh-display-emphasis ()
  "Function to display graphical emphasis."
Bill Wohler's avatar
Bill Wohler committed
726
  (when (and mh-graphical-emphasis-flag (mh-small-show-buffer-p))
Bill Wohler's avatar
Bill Wohler committed
727
    (flet ((article-goto-body ()))      ; shadow this function to do nothing
Bill Wohler's avatar
Bill Wohler committed
728 729 730 731 732 733 734 735 736 737 738 739 740
      (save-excursion
        (goto-char (point-min))
        (article-emphasize)))))

;; Copied from gnus-art.el (should be checked for other cool things that can
;; be added to the buttons)
(defvar mh-mime-button-commands
  '((mh-press-button "\r" "Toggle Display")))
(defvar mh-mime-button-map
  (let ((map (make-sparse-keymap)))
    (unless (>= (string-to-number emacs-version) 21)
      ;; XEmacs doesn't care.
      (set-keymap-parent map mh-show-mode-map))
Bill Wohler's avatar
Bill Wohler committed
741 742 743 744
    (mh-do-in-gnu-emacs
     (define-key map [mouse-2] 'mh-push-button))
    (mh-do-in-xemacs
     (define-key map '(button2) 'mh-push-button))
Bill Wohler's avatar
Bill Wohler committed
745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766
    (dolist (c mh-mime-button-commands)
      (define-key map (cadr c) (car c)))
    map))
(defvar mh-mime-button-line-format-alist
  '((?T long-type ?s)
    (?d description ?s)
    (?p index ?s)
    (?e dots ?s)))
(defvar mh-mime-button-line-format "%{%([%p. %d%T]%)%}%e\n")
(defvar mh-mime-security-button-pressed nil)
(defvar mh-mime-security-button-line-format "%{%([[%t:%i]%D]%)%}\n")
(defvar mh-mime-security-button-end-line-format "%{%([[End of %t]%D]%)%}\n")
(defvar mh-mime-security-button-line-format-alist
  '((?t type ?s)
    (?i info ?s)
    (?d details ?s)
    (?D pressed-details ?s)))
(defvar mh-mime-security-button-map
  (let ((map (make-sparse-keymap)))
    (unless (>= (string-to-number emacs-version) 21)
      (set-keymap-parent map mh-show-mode-map))
    (define-key map "\r" 'mh-press-button)
Bill Wohler's avatar
Bill Wohler committed
767 768 769 770
    (mh-do-in-gnu-emacs
     (define-key map [mouse-2] 'mh-push-button))
    (mh-do-in-xemacs
     (define-key map '(button2) 'mh-push-button))
Bill Wohler's avatar
Bill Wohler committed
771 772 773 774 775 776
    map))

(defvar mh-mime-save-parts-directory nil
  "Default to use for `mh-mime-save-parts-default-directory'.
Set from last use.")

Bill Wohler's avatar
Bill Wohler committed
777
;;;###mh-autoload
Bill Wohler's avatar
Bill Wohler committed
778 779 780 781 782 783 784 785 786 787 788 789 790
(defun mh-mime-save-parts (arg)
  "Store the MIME parts of the current message.
If ARG, prompt for directory, else use that specified by the variable
`mh-mime-save-parts-default-directory'. These directories may be superseded by
mh_profile directives, since this function calls on mhstore or mhn to do the
actual storing."
  (interactive "P")
  (let ((msg (if (eq major-mode 'mh-show-mode)
                 (mh-show-buffer-message-number)
               (mh-get-msg-num t)))
        (folder (if (eq major-mode 'mh-show-mode)
                    mh-show-folder-buffer
                  mh-current-folder))
Bill Wohler's avatar
Bill Wohler committed
791
        (command (if (mh-variant-p 'nmh) "mhstore" "mhn"))
Bill Wohler's avatar
Bill Wohler committed
792 793 794 795 796 797
        (directory
         (cond
          ((and (or arg
                    (equal nil mh-mime-save-parts-default-directory)
                    (equal t mh-mime-save-parts-default-directory))
                (not mh-mime-save-parts-directory))
Bill Wohler's avatar
Bill Wohler committed
798
           (read-file-name "Store in directory: " nil nil t nil))
Bill Wohler's avatar
Bill Wohler committed
799 800 801 802
          ((and (or arg
                    (equal t mh-mime-save-parts-default-directory))
                mh-mime-save-parts-directory)
           (read-file-name (format
Bill Wohler's avatar
Bill Wohler committed
803
                            "Store in directory: [%s] "
Bill Wohler's avatar
Bill Wohler committed
804 805 806 807 808 809 810 811 812
                            mh-mime-save-parts-directory)
                           "" mh-mime-save-parts-directory t ""))
          ((stringp mh-mime-save-parts-default-directory)
           mh-mime-save-parts-default-directory)
          (t
           mh-mime-save-parts-directory))))
    (if (and (equal directory "") mh-mime-save-parts-directory)
        (setq directory mh-mime-save-parts-directory))
    (if (not (file-directory-p directory))
Bill Wohler's avatar
Bill Wohler committed
813
        (message "No directory specified")
Bill Wohler's avatar
Bill Wohler committed
814 815 816
      (if (equal nil mh-mime-save-parts-default-directory)
          (setq mh-mime-save-parts-directory directory))
      (save-excursion
Bill Wohler's avatar
Bill Wohler committed
817
        (set-buffer (get-buffer-create mh-log-buffer))
Bill Wohler's avatar
Bill Wohler committed
818 819
        (cd directory)
        (setq mh-mime-save-parts-directory directory)
Bill Wohler's avatar
Bill Wohler committed
820 821 822 823 824 825 826 827
        (let ((initial-size (mh-truncate-log-buffer)))
          (apply 'call-process
                 (expand-file-name command mh-progs) nil t nil
                 (mh-list-to-string (list folder msg "-auto")))
          (if (> (buffer-size) initial-size)
              (save-window-excursion
                (switch-to-buffer-other-window mh-log-buffer)
                (sit-for 3))))))))
Bill Wohler's avatar
Bill Wohler committed
828 829 830 831 832

;; Avoid errors if gnus-sum isn't loaded yet...
(defvar gnus-newsgroup-charset nil)
(defvar gnus-newsgroup-name nil)

Bill Wohler's avatar
Bill Wohler committed
833 834 835
(defun mh-decode-message-body ()
  "Decode message based on charset.
If message has been encoded for transfer take that into account."
Bill Wohler's avatar
Bill Wohler committed
836 837 838 839 840 841 842 843 844
  (let (ct charset cte)
    (goto-char (point-min))
    (re-search-forward "\n\n" nil t)
    (save-restriction
      (narrow-to-region (point-min) (point))
      (setq ct (ignore-errors (mail-header-parse-content-type
                               (message-fetch-field "Content-Type" t)))
            charset (mail-content-type-get ct 'charset)
            cte (message-fetch-field "Content-Transfer-Encoding")))
Bill Wohler's avatar
Bill Wohler committed
845 846 847 848 849 850 851 852 853 854
    (when (stringp cte) (setq cte (mail-header-strip cte)))
    (when (or (not ct) (equal (car ct) "text/plain"))
      (save-restriction
        (narrow-to-region (min (1+ (mh-mail-header-end)) (point-max))
                          (point-max))
        (mm-decode-body charset
                        (and cte (intern (downcase
                                          (gnus-strip-whitespace cte))))
                        (car ct))))))

Bill Wohler's avatar
Bill Wohler committed
855 856 857
;;;###mh-autoload
(defun mh-toggle-mh-decode-mime-flag ()
  "Toggle whether MH-E should decode MIME or not."
Bill Wohler's avatar
Bill Wohler committed
858
  (interactive)
Bill Wohler's avatar
Bill Wohler committed
859 860 861 862
  (setq mh-decode-mime-flag (not mh-decode-mime-flag))
  (mh-show nil t)
  (message (format "(setq mh-decode-mime-flag %s)" mh-decode-mime-flag)))

Bill Wohler's avatar
Bill Wohler committed
863 864 865 866 867 868 869
;;;###mh-autoload
(defun mh-decode-message-header ()
  "Decode RFC2047 encoded message header fields."
  (when mh-decode-mime-flag
    (let ((buffer-read-only nil))
      (rfc2047-decode-region (point-min) (mh-mail-header-end)))))

Bill Wohler's avatar
Bill Wohler committed
870
;;;###mh-autoload
Bill Wohler's avatar
Bill Wohler committed
871 872 873 874 875 876
(defun mh-mime-display (&optional pre-dissected-handles)
  "Display (and possibly decode) MIME handles.
Optional argument, PRE-DISSECTED-HANDLES is a list of MIME handles. If
present they are displayed otherwise the buffer is parsed and then
displayed."
  (let ((handles ())
Bill Wohler's avatar
Bill Wohler committed
877 878
        (folder mh-show-folder-buffer)
        (raw-message-data (buffer-string)))
Bill Wohler's avatar
Bill Wohler committed
879 880 881
    (flet ((mm-handle-set-external-undisplayer
            (handle function)
            (mh-handle-set-external-undisplayer folder handle function)))
Bill Wohler's avatar
Bill Wohler committed
882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897
      (goto-char (point-min))
      (unless (search-forward "\n\n" nil t)
        (goto-char (point-max))
        (insert "\n\n"))

      (condition-case err
          (progn
            ;; If needed dissect the current buffer
            (if pre-dissected-handles
                (setq handles pre-dissected-handles)
              (setq handles (or (mm-dissect-buffer nil) (mm-uu-dissect)))
              (setf (mh-mime-handles (mh-buffer-data))
                    (mm-merge-handles handles
                                      (mh-mime-handles (mh-buffer-data))))
              (unless handles (mh-decode-message-body)))

Bill Wohler's avatar
Bill Wohler committed
898 899 900 901 902
            (cond ((and handles
                        (or (not (stringp (car handles))) (cdr handles)))
                   ;; Goto start of message body
                   (goto-char (point-min))
                   (or (search-forward "\n\n" nil t) (goto-char (point-max)))
Bill Wohler's avatar
Bill Wohler committed
903

Bill Wohler's avatar
Bill Wohler committed
904 905
                   ;; Delete the body
                   (delete-region (point) (point-max))
Bill Wohler's avatar
Bill Wohler committed
906

Bill Wohler's avatar
Bill Wohler committed
907 908 909
                   ;; Display the MIME handles
                   (mh-mime-display-part handles))
                  (t (mh-signature-highlight))))
Bill Wohler's avatar
Bill Wohler committed
910 911 912 913 914
        (error
         (message "Please report this error. The error message is:\n %s"
                  (error-message-string err))
         (delete-region (point-min) (point-max))
         (insert raw-message-data))))))
Bill Wohler's avatar
Bill Wohler committed
915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931

(defun mh-mime-display-part (handle)
  "Decides the viewer to call based on the type of HANDLE."
  (cond ((null handle) nil)
        ((not (stringp (car handle)))
         (mh-mime-display-single handle))
        ((equal (car handle) "multipart/alternative")
         (mh-mime-display-alternative (cdr handle)))
        ((and mh-gnus-pgp-support-flag
              (or (equal (car handle) "multipart/signed")
                  (equal (car handle) "multipart/encrypted")))
         (mh-mime-display-security handle))
        (t (mh-mime-display-mixed (cdr handle)))))

(defun mh-mime-display-alternative (handles)
  "Choose among the alternatives, HANDLES the part that will be displayed.
If no part is preferred then all the parts are displayed."
Bill Wohler's avatar
Bill Wohler committed
932 933
  (let* ((preferred (mm-preferred-alternative handles))
         (others (loop for x in handles unless (eq x preferred) collect x)))
Bill Wohler's avatar
Bill Wohler committed
934
    (cond ((and preferred (stringp (car preferred)))
Bill Wohler's avatar
Bill Wohler committed
935 936
           (mh-mime-display-part preferred)
           (mh-mime-maybe-display-alternatives others))
Bill Wohler's avatar
Bill Wohler committed
937 938 939
          (preferred
           (save-restriction
             (narrow-to-region (point) (if (eobp) (point) (1+ (point))))
Bill Wohler's avatar
Bill Wohler committed
940
             (mh-mime-display-single preferred)
Bill Wohler's avatar
Bill Wohler committed
941
             (mh-mime-maybe-display-alternatives others)
Bill Wohler's avatar
Bill Wohler committed
942 943 944
             (goto-char (point-max))))
          (t (mh-mime-display-mixed handles)))))

Bill Wohler's avatar
Bill Wohler committed
945 946 947 948 949 950 951 952 953 954 955 956
(defun mh-mime-maybe-display-alternatives (alternatives)
  "Show buttons for ALTERNATIVES.
If `mh-mime-display-alternatives-flag' is non-nil then display buttons for
alternative parts that are usually suppressed."
  (when (and mh-display-buttons-for-alternatives-flag alternatives)
    (insert "\n----------------------------------------------------\n")
    (insert "Alternatives:\n")
    (dolist (x alternatives)
      (insert "\n")
      (mh-insert-mime-button x (mh-mime-part-index x) nil))
    (insert "\n----------------------------------------------------\n")))

Bill Wohler's avatar
Bill Wohler committed
957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977
(defun mh-mime-display-mixed (handles)
  "Display the list of MIME parts, HANDLES recursively."
  (mapcar #'mh-mime-display-part handles))

(defun mh-mime-part-index (handle)
  "Generate the button number for MIME part, HANDLE.
Notice that a hash table is used to display the same number when buttons need
to be displayed multiple times (for instance when nested messages are
opened)."
  (or (gethash handle (mh-mime-part-index-hash (mh-buffer-data)))
      (setf (gethash handle (mh-mime-part-index-hash (mh-buffer-data)))
            (incf (mh-mime-parts-count (mh-buffer-data))))))

(defun mh-small-image-p (handle)
  "Decide whether HANDLE is a \"small\" image that can be displayed inline.
This is only useful if a Content-Disposition header is not present."
  (let ((media-test (caddr (assoc (car (mm-handle-type handle))
                                  mh-mm-inline-media-tests)))
        (mm-inline-large-images t))
    (and media-test
         (equal (mm-handle-media-supertype handle) "image")
Bill Wohler's avatar
Bill Wohler committed
978 979 980
         (funcall media-test handle)    ; Since mm-inline-large-images is T,
                                        ; this only tells us if the image is
                                        ; something that emacs can display
Bill Wohler's avatar
Bill Wohler committed
981
         (let* ((image (mm-get-image handle)))
Bill Wohler's avatar
Bill Wohler committed
982 983 984 985 986 987 988 989 990 991 992 993 994 995
           (or (mh-do-in-xemacs
                 (and (mh-funcall-if-exists glyphp image)
                      (< (glyph-width image)
                         (or mh-max-inline-image-width (window-pixel-width)))
                      (< (glyph-height image)
                         (or mh-max-inline-image-height
                             (window-pixel-height)))))
               (mh-do-in-gnu-emacs
                 (let ((size (mh-funcall-if-exists image-size image)))
                   (and size
                        (< (cdr size) (or mh-max-inline-image-height
                                          (1- (window-height))))
                        (< (car size) (or mh-max-inline-image-width
                                          (window-width)))))))))))
Bill Wohler's avatar
Bill Wohler committed
996

Bill Wohler's avatar
Bill Wohler committed
997 998 999
(defun mh-inline-vcard-p (handle)
  "Decide if HANDLE is a vcard that must be displayed inline."
  (let ((type (mm-handle-type handle)))
Bill Wohler's avatar
Bill Wohler committed
1000 1001
    (and (or (featurep 'vcard) (fboundp 'vcard-pretty-print))
         (consp type)
Bill Wohler's avatar
Bill Wohler committed
1002 1003 1004 1005 1006
         (equal (car type) "text/x-vcard")
         (save-excursion
           (save-restriction
             (widen)
             (goto-char (point-min))
Bill Wohler's avatar
Bill Wohler committed
1007
             (not (mh-signature-separator-p)))))))
Bill Wohler's avatar
Bill Wohler committed
1008

Bill Wohler's avatar
Bill Wohler committed
1009 1010 1011 1012 1013 1014 1015 1016 1017
(defun mh-mime-display-single (handle)
  "Display a leaf node, HANDLE in the MIME tree."
  (let* ((type (mm-handle-media-type handle))
         (small-image-flag (mh-small-image-p handle))
         (attachmentp (equal (car (mm-handle-disposition handle))
                             "attachment"))
         (inlinep (and (equal (car (mm-handle-disposition handle)) "inline")
                       (mm-inlinable-p handle)
                       (mm-inlined-p handle)))
Bill Wohler's avatar
Bill Wohler committed
1018 1019 1020 1021 1022
         (displayp (or inlinep                   ; show if inline OR
                       (mh-inline-vcard-p handle);      inline vcard OR
                       (and (not attachmentp)    ;      if not an attachment
                            (or small-image-flag ;        and small image
                                                 ;        and user wants inline
Bill Wohler's avatar
Bill Wohler committed
1023 1024 1025 1026 1027 1028 1029 1030 1031
                                (and (not (equal
                                           (mm-handle-media-supertype handle)
                                           "image"))
                                     (mm-inlinable-p handle)
                                     (mm-inlined-p handle)))))))
    (save-restriction
      (narrow-to-region (point) (if (eobp) (point) (1+ (point))))
      (cond ((and mh-gnus-pgp-support-flag
                  (equal type "application/pgp-signature"))
Bill Wohler's avatar
Bill Wohler committed
1032
             nil)             ; skip signatures as they are already handled...
Bill Wohler's avatar
Bill Wohler committed
1033 1034 1035 1036
            ((not displayp)
             (insert "\n")
             (mh-insert-mime-button handle (mh-mime-part-index handle) nil))
            ((and displayp (not mh-display-buttons-for-inline-parts-flag))
Bill Wohler's avatar
Bill Wohler committed
1037 1038
             (or (mm-display-part handle) (mm-display-part handle))
             (mh-signature-highlight handle))
Bill Wohler's avatar
Bill Wohler committed
1039 1040 1041 1042 1043 1044 1045
            ((and displayp mh-display-buttons-for-inline-parts-flag)
             (insert "\n")
             (mh-insert-mime-button handle (mh-mime-part-index handle) nil)
             (forward-line -1)
             (mh-mm-display-part handle)))
      (goto-char (point-max)))))

Bill Wohler's avatar
Bill Wohler committed
1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067
(defun mh-signature-highlight (&optional handle)
  "Highlight message signature in HANDLE.
The optional argument, HANDLE is a MIME handle if the function is being used
to highlight the signature in a MIME part."
  (let ((regexp
         (cond ((not handle) "^-- $")
               ((not (and (equal (mm-handle-media-supertype handle) "text")
                          (equal (mm-handle-media-subtype handle) "html")))
                "^-- $")
               ((eq (mh-mm-text-html-renderer) 'lynx) "^   --$")
               (t "^--$"))))
    (save-excursion
      (goto-char (point-max))
      (when (re-search-backward regexp nil t)
        (mh-do-in-gnu-emacs
          (let ((ov (make-overlay (point) (point-max))))
            (overlay-put ov 'face 'mh-show-signature-face)
            (overlay-put ov 'evaporate t)))
        (mh-do-in-xemacs
          (set-extent-property (make-extent (point) (point-max))
                               'face 'mh-show-signature-face))))))

Bill Wohler's avatar
Bill Wohler committed
1068 1069 1070 1071
(mh-do-in-xemacs
 (defvar dots)
 (defvar type))

Bill Wohler's avatar
Bill Wohler committed
1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099
(defun mh-insert-mime-button (handle index displayed)
  "Insert MIME button for HANDLE.
INDEX is the part number that will be DISPLAYED. It is also used by commands
like \"K v\" which operate on individual MIME parts."
  ;; The button could be displayed by a previous decode. In that case
  ;; undisplay it if we need a hidden button.
  (when (and (mm-handle-displayed-p handle) (not displayed))
    (mm-display-part handle))
  (let ((name (or (mail-content-type-get (mm-handle-type handle) 'name)
                  (mail-content-type-get (mm-handle-disposition handle)
                                         'filename)
                  (mail-content-type-get (mm-handle-type handle) 'url)
                  ""))
        (type (mm-handle-media-type handle))
        (description (mail-decode-encoded-word-string
                      (or (mm-handle-description handle) "")))
        (dots (if (or displayed (mm-handle-displayed-p handle)) "   " "..."))
        long-type begin end)
    (if (string-match ".*/" name) (setq name (substring name (match-end 0))))
    (setq long-type (concat type (and (not (equal name ""))
                                      (concat "; " name))))
    (unless (equal description "")
      (setq long-type (concat " --- " long-type)))
    (unless (bolp) (insert "\n"))
    (setq begin (point))
    (gnus-eval-format
     mh-mime-button-line-format mh-mime-button-line-format-alist
     `(,@(gnus-local-map-property mh-mime-button-map)
Bill Wohler's avatar
Bill Wohler committed
1100 1101 1102
         mh-callback mh-mm-display-part
         mh-part ,index
         mh-data ,handle))
Bill Wohler's avatar
Bill Wohler committed
1103 1104 1105 1106 1107 1108 1109
    (setq end (point))
    (widget-convert-button
     'link begin end
     :mime-handle handle
     :action 'mh-widget-press-button
     :button-keymap mh-mime-button-map
     :help-echo
Bill Wohler's avatar
Bill Wohler committed
1110 1111 1112
     "Mouse-2 click or press RET (in show buffer) to toggle display")
    (dolist (ov (mh-funcall-if-exists overlays-in begin end))
      (mh-funcall-if-exists overlay-put ov 'evaporate t))))
Bill Wohler's avatar
Bill Wohler committed
1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139

;; There is a bug in Gnus inline image display due to which an extra line
;; gets inserted every time it is viewed. To work around that problem we are
;; using an extra property 'mh-region to remember the region that is added
;; when the button is clicked. The region is then deleted to make sure that
;; no extra lines get inserted.
(defun mh-mm-display-part (handle)
  "Toggle display of button for MIME part, HANDLE."
  (beginning-of-line)
  (let ((id (get-text-property (point) 'mh-part))
        (point (point))
        (window (selected-window))
        (mail-parse-charset 'nil)
        (mail-parse-ignored-charsets nil)
        region buffer-read-only)
    (save-excursion
      (unwind-protect
          (let ((win (get-buffer-window (current-buffer) t)))
            (when win
              (select-window win))
            (goto-char point)

            (if (mm-handle-displayed-p handle)
                ;; This will remove the part.
                (progn
                  ;; Delete the button and displayed part (if any)
                  (let ((region (get-text-property point 'mh-region)))
Bill Wohler's avatar
Bill Wohler committed
1140
                    (when region
Bill Wohler's avatar
Bill Wohler committed
1141 1142
                      (mh-funcall-if-exists
                       remove-images (car region) (cdr region)))
Bill Wohler's avatar
Bill Wohler committed
1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166
                    (mm-display-part handle)
                    (when region
                      (delete-region (car region) (cdr region))))
                  ;; Delete button (if it still remains). This happens for
                  ;; externally displayed parts where the previous step does
                  ;; nothing.
                  (unless (eolp)
                    (delete-region (point) (progn (forward-line) (point)))))
              (save-restriction
                (delete-region (point) (progn (forward-line 1) (point)))
                (narrow-to-region (point) (point))
                ;; Maybe we need another unwind-protect here.
                (when (equal (mm-handle-media-supertype handle) "image")
                  (insert "\n"))
                (when (and (not (eq (ignore-errors (mm-display-part handle))
                                    'inline))
                           (equal (mm-handle-media-supertype handle)
                                  "image"))
                  (goto-char (point-min))
                  (delete-char 1))
                (when (equal (mm-handle-media-supertype handle) "text")
                  (when (eq mh-highlight-citation-p 'gnus)
                    (mh-gnus-article-highlight-citation))
                  (mh-display-smileys)
Bill Wohler's avatar
Bill Wohler committed
1167 1168
                  (mh-display-emphasis)
                  (mh-signature-highlight handle))
Bill Wohler's avatar
Bill Wohler committed
1169 1170