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

Paul Eggert's avatar
Paul Eggert committed
3
;; Copyright (C) 1993, 1995, 2001-2019 Free Software Foundation, Inc.
Bill Wohler's avatar
Bill Wohler committed
4 5 6 7

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

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

11
;; GNU Emacs is free software: you can redistribute it and/or modify
Richard M. Stallman's avatar
Richard M. Stallman committed
12
;; it under the terms of the GNU General Public License as published by
13 14
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
Richard M. Stallman's avatar
Richard M. Stallman committed
15

Karl Heuer's avatar
Karl Heuer committed
16
;; GNU Emacs is distributed in the hope that it will be useful,
Richard M. Stallman's avatar
Richard M. Stallman committed
17 18 19 20 21
;; 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
22
;; along with GNU Emacs.  If not, see <https://www.gnu.org/licenses/>.
Richard M. Stallman's avatar
Richard M. Stallman committed
23 24 25

;;; Commentary:

Bill Wohler's avatar
Bill Wohler committed
26 27 28 29 30 31 32 33 34 35 36 37
;; Message composition of MIME message is done with either MH-style
;; directives for mhn or mhbuild (MH 6.8 or later) or MML (MIME Meta
;; Language) tags.

;; TODO:
;;   Paragraph code should not fill # lines if MIME enabled.
;;   Implement mh-auto-mh-to-mime (if non-nil, \\[mh-send-letter]
;;      invokes mh-mh-to-mime automatically before sending.)
;;      Actually, instead of mh-auto-mh-to-mime,
;;      should read automhnproc from profile.
;;   MIME option to mh-forward command to move to content-description
;;   insertion point.
Richard M. Stallman's avatar
Richard M. Stallman committed
38

Karl Heuer's avatar
Karl Heuer committed
39 40
;;; Change Log:

Richard M. Stallman's avatar
Richard M. Stallman committed
41 42
;;; Code:

Bill Wohler's avatar
Bill Wohler committed
43 44
(require 'mh-e)
(require 'mh-gnus)                      ;needed because mh-gnus.el not compiled
45

Bill Wohler's avatar
Bill Wohler committed
46
(require 'font-lock)
Bill Wohler's avatar
Bill Wohler committed
47
(require 'gnus-util)
Bill Wohler's avatar
Bill Wohler committed
48 49 50 51
(require 'mailcap)
(require 'mm-decode)
(require 'mm-view)
(require 'mml)
Bill Wohler's avatar
Bill Wohler committed
52 53 54

(autoload 'article-emphasize "gnus-art")
(autoload 'gnus-eval-format "gnus-spec")
Bill Wohler's avatar
Bill Wohler committed
55 56 57
(autoload 'mail-content-type-get "mail-parse")
(autoload 'mail-decode-encoded-word-string "mail-parse")
(autoload 'mail-header-parse-content-type "mail-parse")
58
(autoload 'mail-header-strip-cte "mail-parse")
59
(autoload 'mail-strip-quoted-names "mail-utils")
60 61
(autoload 'message-options-get "message")
(autoload 'message-options-set "message")
Bill Wohler's avatar
Bill Wohler committed
62
(autoload 'message-options-set-recipient "message")
Bill Wohler's avatar
Bill Wohler committed
63
(autoload 'mm-decode-body "mm-bodies")
64
(autoload 'mm-uu-dissect "mm-uu")
65
(autoload 'mml-unsecure-message "mml-sec")
Bill Wohler's avatar
Bill Wohler committed
66
(autoload 'rfc2047-decode-region "rfc2047")
67
(autoload 'widget-convert-button "wid-edit")
Bill Wohler's avatar
Bill Wohler committed
68

Bill Wohler's avatar
Bill Wohler committed
69 70 71 72 73


;;; Variables

;; This has to be a macro, since we do: (setf (mh-buffer-data) ...)
Bill Wohler's avatar
Bill Wohler committed
74
;;;###mh-autoload
Bill Wohler's avatar
Bill Wohler committed
75 76
(defmacro mh-buffer-data ()
  "Convenience macro to get the MIME data structures of the current buffer."
77
  '(gethash (current-buffer) mh-globals-hash))
Bill Wohler's avatar
Bill Wohler committed
78 79

;; Structure to keep track of MIME handles on a per buffer basis.
Stefan Monnier's avatar
Stefan Monnier committed
80
(cl-defstruct (mh-buffer-data (:conc-name mh-mime-)
Bill Wohler's avatar
Bill Wohler committed
81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145
                              (:constructor mh-make-buffer-data))
  (handles ())                          ; List of MIME handles
  (handles-cache (make-hash-table))     ; Cache to avoid multiple decodes of
                                        ; nested messages
  (parts-count 0)                       ; The button number is generated from
                                        ; this number
  (part-index-hash (make-hash-table)))  ; Avoid incrementing the part number
                                        ; for nested messages

(defvar mh-mm-inline-media-tests
  `(("image/jpeg"
     mm-inline-image
     (lambda (handle)
       (mm-valid-and-fit-image-p 'jpeg handle)))
    ("image/png"
     mm-inline-image
     (lambda (handle)
       (mm-valid-and-fit-image-p 'png handle)))
    ("image/gif"
     mm-inline-image
     (lambda (handle)
       (mm-valid-and-fit-image-p 'gif handle)))
    ("image/tiff"
     mm-inline-image
     (lambda (handle)
       (mm-valid-and-fit-image-p 'tiff handle)) )
    ("image/xbm"
     mm-inline-image
     (lambda (handle)
       (mm-valid-and-fit-image-p 'xbm handle)))
    ("image/x-xbitmap"
     mm-inline-image
     (lambda (handle)
       (mm-valid-and-fit-image-p 'xbm handle)))
    ("image/xpm"
     mm-inline-image
     (lambda (handle)
       (mm-valid-and-fit-image-p 'xpm handle)))
    ("image/x-pixmap"
     mm-inline-image
     (lambda (handle)
       (mm-valid-and-fit-image-p 'xpm handle)))
    ("image/bmp"
     mm-inline-image
     (lambda (handle)
       (mm-valid-and-fit-image-p 'bmp handle)))
    ("image/x-portable-bitmap"
     mm-inline-image
     (lambda (handle)
       (mm-valid-and-fit-image-p 'pbm handle)))
    ("text/plain" mm-inline-text identity)
    ("text/enriched" mm-inline-text identity)
    ("text/richtext" mm-inline-text identity)
    ("text/x-patch" mm-display-patch-inline
     (lambda (handle)
       (locate-library "diff-mode")))
    ("application/emacs-lisp" mm-display-elisp-inline identity)
    ("application/x-emacs-lisp" mm-display-elisp-inline identity)
    ("text/html"
     ,(if (fboundp 'mm-inline-text-html) 'mm-inline-text-html 'mm-inline-text)
     (lambda (handle)
       (or (and (boundp 'mm-inline-text-html-renderer)
                mm-inline-text-html-renderer)
           (and (boundp 'mm-text-html-renderer) mm-text-html-renderer))))
    ("text/x-vcard"
146
     mh-mm-inline-text-vcard
Bill Wohler's avatar
Bill Wohler committed
147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175
     (lambda (handle)
       (or (featurep 'vcard)
           (locate-library "vcard"))))
    ("message/delivery-status" mm-inline-text identity)
    ("message/rfc822" mh-mm-inline-message identity)
    ;;("message/partial" mm-inline-partial identity)
    ;;("message/external-body" mm-inline-external-body identity)
    ("text/.*" mm-inline-text identity)
    ("audio/wav" mm-inline-audio
     (lambda (handle)
       (and (or (featurep 'nas-sound) (featurep 'native-sound))
            (device-sound-enabled-p))))
    ("audio/au"
     mm-inline-audio
     (lambda (handle)
       (and (or (featurep 'nas-sound) (featurep 'native-sound))
            (device-sound-enabled-p))))
    ("application/pgp-signature" ignore identity)
    ("application/x-pkcs7-signature" ignore identity)
    ("application/pkcs7-signature" ignore identity)
    ("application/x-pkcs7-mime" ignore identity)
    ("application/pkcs7-mime" ignore identity)
    ("multipart/alternative" ignore identity)
    ("multipart/mixed" ignore identity)
    ("multipart/related" ignore identity)
    ;; Disable audio and image
    ("audio/.*" ignore ignore)
    ("image/.*" ignore ignore)
    ;; Default to displaying as text
176
    (".*" mm-inline-text mh-mm-readable-p))
Bill Wohler's avatar
Bill Wohler committed
177
  "Alist of media types/tests saying whether types can be displayed inline.")
178

Bill Wohler's avatar
Bill Wohler committed
179 180 181
(defvar mh-mime-save-parts-directory nil
  "Default to use for `mh-mime-save-parts-default-directory'.
Set from last use.")
182

Bill Wohler's avatar
Bill Wohler committed
183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222
;; 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))
    (mh-do-in-gnu-emacs
     (define-key map [mouse-2] 'mh-push-button))
    (mh-do-in-xemacs
     (define-key map '(button2) 'mh-push-button))
    (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)
    (mh-do-in-gnu-emacs
     (define-key map [mouse-2] 'mh-push-button))
    (mh-do-in-xemacs
     (define-key map '(button2) 'mh-push-button))
    map))
Bill Wohler's avatar
Bill Wohler committed
223

Bill Wohler's avatar
Bill Wohler committed
224

225

Bill Wohler's avatar
Bill Wohler committed
226
;;; MH-Folder Commands
227

Bill Wohler's avatar
Bill Wohler committed
228
;; Alphabetical.
Richard M. Stallman's avatar
Richard M. Stallman committed
229

Bill Wohler's avatar
Bill Wohler committed
230 231 232
;;;###mh-autoload
(defun mh-display-with-external-viewer (part-index)
  "View attachment externally.
Richard M. Stallman's avatar
Richard M. Stallman committed
233

Bill Wohler's avatar
Bill Wohler committed
234 235 236 237 238 239 240
If Emacs does not know how to view an attachment, you could save
it into a file and then run some program to open it. It is
easier, however, to launch the program directly from MH-E with
this command. While you'll most likely use this to view
spreadsheets and documents, it is also useful to use your browser
to view HTML attachments with higher fidelity than what Emacs can
provide.
Karl Heuer's avatar
Karl Heuer committed
241

Bill Wohler's avatar
Bill Wohler committed
242 243 244 245 246 247
This command displays the attachment associated with the button
under the cursor. If the cursor is not located over a button,
then the cursor first moves to the next button, wrapping to the
beginning of the message if necessary. You can provide a numeric
prefix argument PART-INDEX to view the attachment labeled with
that number.
Bill Wohler's avatar
Bill Wohler committed
248

Bill Wohler's avatar
Bill Wohler committed
249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269
This command tries to provide a reasonable default for the viewer
by calling the Emacs function `mailcap-mime-info'. This function
usually reads the file \"/etc/mailcap\"."
  (interactive "P")
  (when (consp part-index) (setq part-index (car part-index)))
  (mh-folder-mime-action
   part-index
   #'(lambda ()
       (let* ((part (get-text-property (point) 'mh-data))
              (type (mm-handle-media-type part))
              (methods (mapcar (lambda (x) (list (cdr (assoc 'viewer x))))
                               (mailcap-mime-info type 'all)))
              (def (caar methods))
              (prompt (format "Viewer%s: " (if def
                                               (format " (default %s)" def)
                                             "")))
              (method (completing-read prompt methods nil nil nil nil def))
              (folder mh-show-folder-buffer)
              (buffer-read-only nil))
         (when (string-match "^[^% \t]+$" method)
           (setq method (concat method " %s")))
270
         (mh-flet
271 272 273 274 275
          ((mm-handle-set-external-undisplayer
            (handle function)
            (mh-handle-set-external-undisplayer folder handle function)))
          (unwind-protect (mm-display-external part method)
            (set-buffer-modified-p nil)))))
Bill Wohler's avatar
Bill Wohler committed
276
   nil))
Karl Heuer's avatar
Karl Heuer committed
277

Bill Wohler's avatar
Bill Wohler committed
278
;;;###mh-autoload
Bill Wohler's avatar
Bill Wohler committed
279 280 281 282 283 284 285 286 287 288 289 290 291 292 293
(defun mh-folder-inline-mime-part (part-index)
  "Show attachment verbatim.

You can view the raw contents of an attachment with this command.
This command displays (or hides) the contents of the attachment
associated with the button under the cursor verbatim. If the
cursor is not located over a button, then the cursor first moves
to the next button, wrapping to the beginning of the message if
necessary.

You can also provide a numeric prefix argument PART-INDEX to view
the attachment labeled with that number."
  (interactive "P")
  (when (consp part-index) (setq part-index (car part-index)))
  (mh-folder-mime-action part-index #'mh-mime-inline-part nil))
Bill Wohler's avatar
Bill Wohler committed
294

Bill Wohler's avatar
Bill Wohler committed
295 296 297 298 299 300 301 302 303 304 305
(defun mh-mime-inline-part ()
  "Toggle display of the raw MIME part."
  (interactive)
  (let* ((buffer-read-only nil)
         (data (get-text-property (point) 'mh-data))
         (inserted-flag (get-text-property (point) 'mh-mime-inserted))
         (displayed-flag (mm-handle-displayed-p data))
         (point (point))
         start end)
    (cond ((and data (not inserted-flag) (not displayed-flag))
           (let ((contents (mm-get-part data)))
306 307
             (add-text-properties (mh-line-beginning-position)
                                  (mh-line-end-position) '(mh-mime-inserted t))
Bill Wohler's avatar
Bill Wohler committed
308 309 310 311 312
             (setq start (point-marker))
             (forward-line 1)
             (mm-insert-inline data contents)
             (setq end (point-marker))
             (add-text-properties
313
              start (progn (goto-char start) (mh-line-end-position))
Bill Wohler's avatar
Bill Wohler committed
314 315 316 317 318 319
              `(mh-region (,start . ,end)))))
          ((and data (or inserted-flag displayed-flag))
           (mh-press-button)
           (message "MIME part already inserted")))
    (goto-char point)
    (set-buffer-modified-p nil)))
Bill Wohler's avatar
Bill Wohler committed
320

Bill Wohler's avatar
Bill Wohler committed
321
;;;###mh-autoload
Bill Wohler's avatar
Bill Wohler committed
322 323
(defun mh-folder-save-mime-part (part-index)
  "Save (output) attachment.
Bill Wohler's avatar
Bill Wohler committed
324

Bill Wohler's avatar
Bill Wohler committed
325 326 327 328
This command saves the attachment associated with the button under the
cursor. If the cursor is not located over a button, then the cursor
first moves to the next button, wrapping to the beginning of the
message if necessary.
Bill Wohler's avatar
Bill Wohler committed
329

Bill Wohler's avatar
Bill Wohler committed
330 331
You can also provide a numeric prefix argument PART-INDEX to save the
attachment labeled with that number.
Bill Wohler's avatar
Bill Wohler committed
332

Bill Wohler's avatar
Bill Wohler committed
333 334 335 336 337
This command prompts you for a filename and suggests a specific name
if it is available."
  (interactive "P")
  (when (consp part-index) (setq part-index (car part-index)))
  (mh-folder-mime-action part-index #'mh-mime-save-part nil))
338

Bill Wohler's avatar
Bill Wohler committed
339 340 341 342 343 344 345 346 347 348
(defun mh-mime-save-part ()
  "Save MIME part at point."
  (interactive)
  (let ((data (get-text-property (point) 'mh-data)))
    (when data
      (let ((mm-default-directory
             (file-name-as-directory (or mh-mime-save-parts-directory
                                         default-directory))))
        (mh-mm-save-part data)
        (setq mh-mime-save-parts-directory mm-default-directory)))))
Richard M. Stallman's avatar
Richard M. Stallman committed
349

Bill Wohler's avatar
Bill Wohler committed
350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367
;;;###mh-autoload
(defun mh-folder-toggle-mime-part (part-index)
  "View attachment.

This command displays (or hides) the attachment associated with
the button under the cursor. If the cursor is not located over a
button, then the cursor first moves to the next button, wrapping
to the beginning of the message if necessary. This command has
the advantage over related commands of working from the MH-Folder
buffer.

You can also provide a numeric prefix argument PART-INDEX to view
the attachment labeled with that number. If Emacs does not know
how to display the attachment, then Emacs offers to save the
attachment in a file."
  (interactive "P")
  (when (consp part-index) (setq part-index (car part-index)))
  (mh-folder-mime-action part-index #'mh-press-button t))
Richard M. Stallman's avatar
Richard M. Stallman committed
368

Bill Wohler's avatar
Bill Wohler committed
369
;;;###mh-autoload
Bill Wohler's avatar
Bill Wohler committed
370 371
(defun mh-mime-save-parts (prompt)
  "Save attachments.
372

Bill Wohler's avatar
Bill Wohler committed
373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393
You can save all of the attachments at once with this command.
The attachments are saved in the directory specified by the
option `mh-mime-save-parts-default-directory' unless you use a
prefix argument PROMPT in which case you are prompted for the
directory. These directories may be superseded by MH profile
components, since this function calls on \"mhstore\" (\"mhn\") to
do the work."
  (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))
        (command (if (mh-variant-p 'nmh) "mhstore" "mhn"))
        (directory
         (cond
          ((and (or prompt
                    (equal nil mh-mime-save-parts-default-directory)
                    (equal t mh-mime-save-parts-default-directory))
                (not mh-mime-save-parts-directory))
394
           (read-directory-name "Store in directory: " nil nil t))
Bill Wohler's avatar
Bill Wohler committed
395 396 397
          ((and (or prompt
                    (equal t mh-mime-save-parts-default-directory))
                mh-mime-save-parts-directory)
398
           (read-directory-name (format
Bill Wohler's avatar
Bill Wohler committed
399 400 401 402 403 404 405 406 407 408 409 410 411
                            "Store in directory (default %s): "
                            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))
        (message "No directory specified")
      (if (equal nil mh-mime-save-parts-default-directory)
          (setq mh-mime-save-parts-directory directory))
412
      (with-current-buffer (get-buffer-create mh-log-buffer)
Bill Wohler's avatar
Bill Wohler committed
413 414 415 416 417
        (cd directory)
        (setq mh-mime-save-parts-directory directory)
        (let ((initial-size (mh-truncate-log-buffer)))
          (apply 'call-process
                 (expand-file-name command mh-progs) nil t nil
418 419 420
                 (mh-list-to-string (list folder msg "-auto"
                                          (if (not (mh-variant-p 'nmh))
                                              "-store"))))
Bill Wohler's avatar
Bill Wohler committed
421 422 423 424
          (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
425

Bill Wohler's avatar
Bill Wohler committed
426 427 428 429 430 431 432 433 434
;;;###mh-autoload
(defun mh-toggle-mh-decode-mime-flag ()
  "Toggle the value of `mh-decode-mime-flag'."
  (interactive)
  (setq mh-decode-mime-flag (not mh-decode-mime-flag))
  (mh-show nil t)
  (message "%s" (if mh-decode-mime-flag
                    "Processing attachments normally"
                  "Displaying raw message")))
Richard M. Stallman's avatar
Richard M. Stallman committed
435

Bill Wohler's avatar
Bill Wohler committed
436
;;;###mh-autoload
Bill Wohler's avatar
Bill Wohler committed
437 438 439 440 441 442
(defun mh-toggle-mime-buttons ()
  "Toggle option `mh-display-buttons-for-inline-parts-flag'."
  (interactive)
  (setq mh-display-buttons-for-inline-parts-flag
        (not mh-display-buttons-for-inline-parts-flag))
  (mh-show nil t))
443

Bill Wohler's avatar
Bill Wohler committed
444

445

Bill Wohler's avatar
Bill Wohler committed
446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464
;;; MIME Display Routines

(defun mh-mm-inline-message (handle)
  "Display message, HANDLE.
The function decodes the message and displays it. It avoids
decoding the same message multiple times."
  (let ((b (point))
        (clean-message-header mh-clean-message-header-flag)
        (invisible-headers mh-invisible-header-fields-compiled)
        (visible-headers nil))
    (save-excursion
      (save-restriction
        (narrow-to-region b b)
        (mm-insert-part handle)
        (mh-mime-display
         (or (gethash handle (mh-mime-handles-cache (mh-buffer-data)))
             (setf (gethash handle (mh-mime-handles-cache (mh-buffer-data)))
                   (let ((handles (mm-dissect-buffer nil)))
                     (if handles
465
                         (mh-mm-uu-dissect-text-parts handles)
Bill Wohler's avatar
Bill Wohler committed
466 467
                       (setq handles (mm-uu-dissect)))
                     (setf (mh-mime-handles (mh-buffer-data))
468
                           (mh-mm-merge-handles
Bill Wohler's avatar
Bill Wohler committed
469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500
                            handles (mh-mime-handles (mh-buffer-data))))
                     handles))))

        (goto-char (point-min))
        (mh-show-xface)
        (cond (clean-message-header
               (mh-clean-msg-header (point-min)
                                    invisible-headers
                                    visible-headers)
               (goto-char (point-min)))
              (t
               (mh-start-of-uncleaned-message)))
        (mh-decode-message-header)
        (mh-show-addr)
        ;; The other highlighting types don't need anything special
        (when (eq mh-highlight-citation-style 'gnus)
          (mh-gnus-article-highlight-citation))
        (goto-char (point-min))
        (insert "\n------- Forwarded Message\n\n")
        (mh-display-smileys)
        (mh-display-emphasis)
        (mm-handle-set-undisplayer
         handle
         `(lambda ()
            (let (buffer-read-only)
              (if (fboundp 'remove-specifier)
                  ;; This is only valid on XEmacs.
                  (mapcar (lambda (prop)
                            (remove-specifier
                             (face-property 'default prop) (current-buffer)))
                          '(background background-pixmap foreground)))
              (delete-region ,(point-min-marker) ,(point-max-marker)))))))))
Richard M. Stallman's avatar
Richard M. Stallman committed
501

Bill Wohler's avatar
Bill Wohler committed
502
;;;###mh-autoload
Bill Wohler's avatar
Bill Wohler committed
503 504 505 506 507
(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)))))
508

509 510 511 512 513 514
;;;###mh-autoload
(defun mh-decode-message-subject ()
  "Decode RFC2047 encoded message header fields."
  (when mh-decode-mime-flag
    (save-excursion
      (let ((buffer-read-only nil))
515
        (rfc2047-decode-region (progn (mh-goto-header-field "Subject:") (point))
516 517
                               (progn (mh-header-field-end) (point)))))))

Bill Wohler's avatar
Bill Wohler committed
518 519 520 521 522 523 524 525 526
;;;###mh-autoload
(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 ())
        (folder mh-show-folder-buffer)
        (raw-message-data (buffer-string)))
527
    (mh-flet
528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568
     ((mm-handle-set-external-undisplayer
       (handle function)
       (mh-handle-set-external-undisplayer folder handle function)))
     (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)
             (if (setq handles (mm-dissect-buffer nil))
                 (mh-mm-uu-dissect-text-parts handles)
               (setq handles (mm-uu-dissect)))
             (setf (mh-mime-handles (mh-buffer-data))
                   (mh-mm-merge-handles handles
                                        (mh-mime-handles (mh-buffer-data))))
             (unless handles
               (mh-decode-message-body)))

           (cond ((and handles
                       (or (not (stringp (car handles)))
                           (cdr handles)))
                  ;; Go to start of message body
                  (goto-char (point-min))
                  (or (search-forward "\n\n" nil t)
                      (goto-char (point-max)))

                  ;; Delete the body
                  (delete-region (point) (point-max))

                  ;; Display the MIME handles
                  (mh-mime-display-part handles))
                 (t
                  (mh-signature-highlight))))
       (error
        (message "Could not display body: %s" (error-message-string err))
        (delete-region (point-min) (point-max))
        (insert raw-message-data))))))
Richard M. Stallman's avatar
Richard M. Stallman committed
569

Bill Wohler's avatar
Bill Wohler committed
570 571 572 573
(defun mh-decode-message-body ()
  "Decode message based on charset.
If message has been encoded for transfer take that into account."
  (let (ct charset cte)
Bill Wohler's avatar
Bill Wohler committed
574
    (goto-char (point-min))
Bill Wohler's avatar
Bill Wohler committed
575 576 577 578 579 580 581
    (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")))
582
    (when (stringp cte) (setq cte (mail-header-strip-cte cte)))
Bill Wohler's avatar
Bill Wohler committed
583 584 585 586 587
    (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
588
                        (and cte (intern (downcase cte)))
Bill Wohler's avatar
Bill Wohler committed
589
                        (car ct))))))
Bill Wohler's avatar
Bill Wohler committed
590

Bill Wohler's avatar
Bill Wohler committed
591 592 593 594 595 596 597 598 599 600 601 602 603 604
(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-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)))))
605

Bill Wohler's avatar
Bill Wohler committed
606 607 608
(defun mh-mime-display-mixed (handles)
  "Display the list of MIME parts, HANDLES recursively."
  (mapcar #'mh-mime-display-part handles))
609

Bill Wohler's avatar
Bill Wohler committed
610 611 612 613
(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."
  (let* ((preferred (mm-preferred-alternative handles))
Stefan Monnier's avatar
Stefan Monnier committed
614
         (others (cl-loop for x in handles unless (eq x preferred) collect x)))
Bill Wohler's avatar
Bill Wohler committed
615 616 617 618 619 620 621 622 623 624 625 626
    (cond ((and preferred
                (stringp (car preferred)))
           (mh-mime-display-part preferred)
           (mh-mime-maybe-display-alternatives others))
          (preferred
           (save-restriction
             (narrow-to-region (point) (if (eobp) (point) (1+ (point))))
             (mh-mime-display-single preferred)
             (mh-mime-maybe-display-alternatives others)
             (goto-char (point-max))))
          (t
           (mh-mime-display-mixed handles)))))
Bill Wohler's avatar
Bill Wohler committed
627

Bill Wohler's avatar
Bill Wohler committed
628 629 630 631 632 633 634 635 636 637 638
(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
639

Bill Wohler's avatar
Bill Wohler committed
640 641 642 643 644 645 646 647 648 649 650
(defun mh-mime-display-security (handle)
  "Display PGP encrypted/signed message, HANDLE."
  (save-restriction
    (narrow-to-region (point) (point))
    (insert "\n")
    (mh-insert-mime-security-button handle)
    (mh-mime-display-mixed (cdr handle))
    (insert "\n")
    (let ((mh-mime-security-button-line-format
           mh-mime-security-button-end-line-format))
      (mh-insert-mime-security-button handle))
651
    (mh-mm-set-handle-multipart-parameter
Bill Wohler's avatar
Bill Wohler committed
652
     handle 'mh-region (cons (point-min-marker) (point-max-marker)))))
Bill Wohler's avatar
Bill Wohler committed
653

Bill Wohler's avatar
Bill Wohler committed
654 655 656 657 658 659 660
(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")
661
                       (mm-automatic-display-p handle)
Bill Wohler's avatar
Bill Wohler committed
662 663 664 665 666 667 668 669 670 671
                       (mm-inlinable-p handle)
                       (mm-inlined-p handle)))
         (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
                                (and (not (equal
                                           (mm-handle-media-supertype handle)
                                           "image"))
672
                                     (mm-automatic-display-p handle)
Bill Wohler's avatar
Bill Wohler committed
673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694
                                     (mm-inlinable-p handle)
                                     (mm-inlined-p handle)))))))
    (save-restriction
      (narrow-to-region (point) (if (eobp) (point) (1+ (point))))
      (cond ((and mh-pgp-support-flag
                  (equal type "application/pgp-signature"))
             nil)             ; skip signatures as they are already handled...
            ((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))
             (or (mm-display-part handle)
                 (mm-display-part handle))
             (mh-signature-highlight handle))
            ((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)))))
695

Bill Wohler's avatar
Bill Wohler committed
696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715
;; 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)
Bill Wohler's avatar
Bill Wohler committed
716

Bill Wohler's avatar
Bill Wohler committed
717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761
            (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)))
                    (when region
                      (mh-funcall-if-exists
                       remove-images (car region) (cdr region)))
                    (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-style 'gnus)
                    (mh-gnus-article-highlight-citation))
                  (mh-display-smileys)
                  (mh-display-emphasis)
                  (mh-signature-highlight handle))
                (setq region (cons (progn (goto-char (point-min))
                                          (point-marker))
                                   (progn (goto-char (point-max))
                                          (point-marker)))))))
        (when (window-live-p window)
          (select-window window))
        (goto-char point)
        (beginning-of-line)
        (mh-insert-mime-button handle id (mm-handle-displayed-p handle))
        (goto-char point)
        (when region
762 763
          (add-text-properties (mh-line-beginning-position)
                               (mh-line-end-position)
Bill Wohler's avatar
Bill Wohler committed
764
                               `(mh-region ,region)))))))
765

Bill Wohler's avatar
Bill Wohler committed
766 767 768 769 770 771 772
(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)))
Stefan Monnier's avatar
Stefan Monnier committed
773
            (cl-incf (mh-mime-parts-count (mh-buffer-data))))))
Bill Wohler's avatar
Bill Wohler committed
774

Bill Wohler's avatar
Bill Wohler committed
775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800
(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")
         (funcall media-test handle) ; Since mm-inline-large-images is T,
                                        ; this only tells us if the image is
                                        ; something that emacs can display
         (let* ((image (mm-get-image handle)))
           (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
801

Bill Wohler's avatar
Bill Wohler committed
802 803 804 805 806 807 808 809 810 811 812
(defun mh-inline-vcard-p (handle)
  "Decide if HANDLE is a vcard that must be displayed inline."
  (let ((type (mm-handle-type handle)))
    (and (or (featurep 'vcard) (fboundp 'vcard-pretty-print))
         (consp type)
         (equal (car type) "text/x-vcard")
         (save-excursion
           (save-restriction
             (widen)
             (goto-char (point-min))
             (not (mh-signature-separator-p)))))))
Bill Wohler's avatar
Bill Wohler committed
813

Bill Wohler's avatar
Bill Wohler committed
814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834
(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)
            (overlay-put ov 'evaporate t)))
        (mh-do-in-xemacs
          (set-extent-property (make-extent (point) (point-max))
                               'face 'mh-show-signature))))))
835

Bill Wohler's avatar
Bill Wohler committed
836

Bill Wohler's avatar
Bill Wohler committed
837

Bill Wohler's avatar
Bill Wohler committed
838
;;; Button Display
Bill Wohler's avatar
Bill Wohler committed
839

Bill Wohler's avatar
Bill Wohler committed
840
;; Shush compiler.
Bill Wohler's avatar
Bill Wohler committed
841
(mh-do-in-xemacs
Stefan Monnier's avatar
Stefan Monnier committed
842
 (defvar ov))
843

Bill Wohler's avatar
Bill Wohler committed
844 845 846 847 848 849 850 851 852 853 854 855 856 857
(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))
Stefan Monnier's avatar
Stefan Monnier committed
858
        begin end)
Bill Wohler's avatar
Bill Wohler committed
859
    (if (string-match ".*/" name) (setq name (substring name (match-end 0))))
Stefan Monnier's avatar
Stefan Monnier committed
860 861
    ;; These vars are passed by dynamic-scoping to
    ;; mh-mime-button-line-format-alist via gnus-eval-format.
862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879
    (with-suppressed-warnings ((lexical index description dots))
      (mh-dlet* ((index index)
                 (description (mail-decode-encoded-word-string
                               (or (mm-handle-description handle) "")))
                 (dots (if (or displayed (mm-handle-displayed-p handle))
                           "   " "..."))
                 (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
                 `(,@(mh-gnus-local-map-property mh-mime-button-map)
                   mh-callback mh-mm-display-part
                   mh-part ,index
                   mh-data ,handle))))
Bill Wohler's avatar
Bill Wohler committed
880 881 882 883 884 885 886 887 888 889
    (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
     "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
890

Bill Wohler's avatar
Bill Wohler committed
891
;; Shush compiler.
892 893
(defvar mm-verify-function-alist)       ; < Emacs 22
(defvar mm-decrypt-function-alist)      ; < Emacs 22
Bill Wohler's avatar
Bill Wohler committed
894

Bill Wohler's avatar
Bill Wohler committed
895 896
(defun mh-insert-mime-security-button (handle)
  "Display buttons for PGP message, HANDLE."
897
  (let* ((protocol (mh-mm-handle-multipart-ctl-parameter handle 'protocol))
Bill Wohler's avatar
Bill Wohler committed
898 899 900
         (crypto-type (or (nth 2 (assoc protocol mm-verify-function-alist))
                          (nth 2 (assoc protocol mm-decrypt-function-alist))
                          "Unknown"))
Stefan Monnier's avatar
Stefan Monnier committed
901 902 903
         begin end face)
    ;; These vars are passed by dynamic-scoping to
    ;; mh-mime-security-button-line-format-alist via gnus-eval-format.
904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942
    (with-suppressed-warnings ((lexical type info details))
      (mh-dlet* ((type (concat crypto-type
                               (if (equal (car handle) "multipart/signed")
                                   " Signed" " Encrypted")
                               " Part"))
                 (info (or (mh-mm-handle-multipart-ctl-parameter
                            handle 'gnus-info)
                           "Undecided"))
                 (details (mh-mm-handle-multipart-ctl-parameter
                           handle 'gnus-details))
                 pressed-details)
                (setq details (if details (concat "\n" details) ""))
                (setq pressed-details (if mh-mime-security-button-pressed details ""))
                (setq face (mh-mime-security-button-face info))
                (unless (bolp) (insert "\n"))
                (setq begin (point))
                (gnus-eval-format
                 mh-mime-security-button-line-format
                 mh-mime-security-button-line-format-alist
                 `(,@(mh-gnus-local-map-property mh-mime-security-button-map)
                   mh-button-pressed ,mh-mime-security-button-pressed
                   mh-callback mh-mime-security-press-button
                   mh-line-format ,mh-mime-security-button-line-format
                   mh-data ,handle))
                (setq end (point))
                (widget-convert-button 'link begin end
                                       :mime-handle handle
                                       :action 'mh-widget-press-button
                                       :button-keymap mh-mime-security-button-map
                                       :button-face face
                                       :help-echo "Mouse-2 click or press RET (in show buffer) to see security details.")
                (dolist (ov (mh-funcall-if-exists overlays-in begin end))
                  (mh-funcall-if-exists overlay-put ov 'evaporate t))
                (when (equal info "Failed")
                  (let* ((type (if (equal (car handle) "multipart/signed")
                                   "verification" "decryption"))
                         (warning (if (equal type "decryption")
                                      "(passphrase may be incorrect)" "")))
                    (message "%s %s failed %s" crypto-type type warning)))))))
943

Bill Wohler's avatar
Bill Wohler committed
944 945 946 947 948 949 950 951 952 953 954 955
(defun mh-mime-security-button-face (info)
  "Return the button face to use for encrypted/signed mail based on INFO."
  (cond ((string-match "OK" info)       ;Decrypted mail
         'mh-show-pgg-good)
        ((string-match "Failed" info)   ;Decryption failed or signature invalid
         'mh-show-pgg-bad)
        ((string-match "Undecided" info);Unprocessed mail
         'mh-show-pgg-unknown)
        ((string-match "Untrusted" info);Key not trusted
         'mh-show-pgg-unknown)
        (t
         'mh-show-pgg-good)))
Bill Wohler's avatar
Bill Wohler committed
956

Bill Wohler's avatar
Bill Wohler committed
957

958

Bill Wohler's avatar
Bill Wohler committed
959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993
;;; Button Handlers

(defun mh-folder-mime-action (part-index action include-security-flag)
  "Go to PART-INDEX and carry out ACTION.

If PART-INDEX is nil then go to the next part in the buffer. The
search for the next buffer wraps around if end of buffer is reached.
If argument INCLUDE-SECURITY-FLAG is non-nil then include security
info buttons when searching for a suitable parts."
  (unless mh-showing-mode
    (mh-show))
  (mh-in-show-buffer (mh-show-buffer)
    (let ((criterion
           (cond (part-index
                  (lambda (p)
                    (let ((part (get-text-property p 'mh-part)))
                      (and (integerp part) (= part part-index)))))
                 (t (lambda (p)
                      (if include-security-flag
                          (get-text-property p 'mh-data)
                        (integerp (get-text-property p 'mh-part)))))))
          (point (point)))
      (cond ((and (get-text-property point 'mh-part)
                  (or (null part-index)
                      (= (get-text-property point 'mh-part) part-index)))
             (funcall action))
            ((and (get-text-property point 'mh-data)
                  include-security-flag
                  (null part-index))
             (funcall action))
            (t
             (mh-goto-next-button nil criterion)
             (if (= (point) point)
                 (message "No matching MIME part found")
               (funcall action)))))))
Bill Wohler's avatar
Bill Wohler committed
994 995

;;;###mh-autoload
Bill Wohler's avatar
Bill Wohler committed
996 997 998 999 1000 1001 1002 1003 1004
(defun mh-goto-next-button (backward-flag &optional criterion)
  "Search for next button satisfying criterion.

If BACKWARD-FLAG is non-nil search backward in the buffer for a mime
button.
If CRITERION is a function or a symbol which has a function binding
then that function must return non-nil at the button we stop."
  (unless (or (and (symbolp criterion) (fboundp criterion))
              (functionp criterion))
Stefan Monnier's avatar
Stefan Monnier committed
1005
    (setq criterion (lambda (_) t)))
Bill Wohler's avatar
Bill Wohler committed
1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024
  ;; Move to the next button in the buffer satisfying criterion
  (goto-char (or (save-excursion
                   (beginning-of-line)
                   ;; Find point before current button
                   (let ((point-before-current-button
                          (save-excursion
                            (while (get-text-property (point) 'mh-data)
                              (unless (= (forward-line
                                          (if backward-flag 1 -1))
                                         0)
                                (if backward-flag
                                    (goto-char (point-min))
                                  (goto-char (point-max)))))
                            (point))))
                     ;; Skip over current button
                     (while (and (get-text-property (point) 'mh-data)
                                 (not (if backward-flag (bobp) (eobp))))
                       (forward-line (if backward-flag -1 1)))
                     ;; Stop at next MIME button if any exists.
Stefan Monnier's avatar
Stefan Monnier committed
1025
                     (cl-block loop
Bill Wohler's avatar
Bill Wohler committed
1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037
                       (while (/= (progn
                                    (unless (= (forward-line
                                                (if backward-flag -1 1))
                                               0)
                                      (if backward-flag
                                          (goto-char (point-max))
                                        (goto-char (point-min)))
                                      (beginning-of-line))
                                    (point))
                                  point-before-current-button)
                         (when (and (get-text-property (point) 'mh-data)
                                    (funcall criterion (point)))
Stefan Monnier's avatar
Stefan Monnier committed
1038
                           (cl-return-from loop (point))))
Bill Wohler's avatar
Bill Wohler committed
1039 1040
                       nil)))
                 (point))))
1041

Stefan Monnier's avatar
Stefan Monnier committed
1042
(defun mh-widget-press-button (widget _el)
Bill Wohler's avatar
Bill Wohler committed
1043 1044 1045 1046
  "Callback for widget, WIDGET.
Parameter EL is unused."
  (goto-char (widget-get widget :from))
  (mh-press-button))
Bill Wohler's avatar
Bill Wohler committed
1047

Bill Wohler's avatar
Bill Wohler committed
1048 1049
(defun mh-press-button ()
  "View contents of button.
Bill Wohler's avatar
Bill Wohler committed
1050

Bill Wohler's avatar
Bill Wohler committed
1051 1052 1053 1054 1055 1056 1057 1058
This command is a toggle so if you use it again on the same
attachment, the attachment is hidden."
  (interactive)
  (let ((mm-inline-media-tests mh-mm-inline-media-tests)
        (data (get-text-property (point) 'mh-data))
        (function (get-text-property (point) 'mh-callback))
        (buffer-read-only nil)
        (folder mh-show-folder-buffer))
1059
    (mh-flet
1060 1061 1062 1063 1064 1065 1066
     ((mm-handle-set-external-undisplayer
       (handle function)
       (mh-handle-set-external-undisplayer folder handle function)))
     (when (and function (eolp))
       (backward-char))
     (unwind-protect (and function (funcall function data))
       (set-buffer-modified-p nil)))))
Bill Wohler's avatar
Bill Wohler committed
1067

Bill Wohler's avatar
Bill Wohler committed
1068 1069
(defun mh-push-button (event)
  "Click MIME button for EVENT.
Bill Wohler's avatar
Bill Wohler committed
1070

Bill Wohler's avatar
Bill Wohler committed
1071 1072 1073 1074 1075 1076 1077 1078 1079
If the MIME part is visible then it is removed. Otherwise the
part is displayed. This function is called when the mouse is used
to click the MIME button."
  (interactive "e")
  (mh-do-at-event-location event
    (let ((folder mh-show-folder-buffer)
          (mm-inline-media-tests mh-mm-inline-media-tests)
          (data (get-text-property (point) 'mh-data))
          (function (get-text-property (point) 'mh-callback)))
1080
      (mh-flet
1081 1082 1083 1084
       ((mm-handle-set-external-undisplayer
         (handle func)
         (mh-handle-set-external-undisplayer folder handle func)))
       (and function (funcall function data))))))
Bill Wohler's avatar
Bill Wohler committed
1085 1086 1087

(defun mh-handle-set-external-undisplayer (folder handle function)
  "Replacement for `mm-handle-set-external-undisplayer'.
1088 1089 1090 1091 1092

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."
1093
  (if (mh-mm-keep-viewer-alive-p handle)
Bill Wohler's avatar
Bill Wohler committed
1094
      (let ((new-handle (copy-sequence handle)))
Bill Wohler's avatar
Bill Wohler committed
1095 1096
        (mm-handle-set-undisplayer new-handle function)
        (mm-handle-set-undisplayer handle nil)
1097
        (with-current-buffer folder
Bill Wohler's avatar
Bill Wohler committed
1098 1099 1100
          (push new-handle (mh-mime-handles (mh-buffer-data)))))
    (mm-handle-set-undisplayer handle function)))

Bill Wohler's avatar
Bill Wohler committed
1101 1102
(defun mh-mime-security-press-button (handle)
  "Callback from security button for part HANDLE."
1103
  (if (mh-mm-handle-multipart-ctl-parameter handle 'gnus-info)
Bill Wohler's avatar
Bill Wohler committed
1104
      (mh-mime-security-show-details handle)
1105
    (let ((region (mh-mm-handle-multipart-ctl-parameter handle 'mh-region))
Bill Wohler's avatar
Bill Wohler committed
1106 1107 1108 1109
          point)
      (setq point (point))
      (goto-char (car region))
      (delete-region (car region) (cdr region))
1110
      (with-current-buffer (mh-mm-handle-multipart-ctl-parameter handle 'buffer)
Bill Wohler's avatar
Bill Wohler committed
1111 1112
        (let* ((mm-verify-option 'known)
               (mm-decrypt-option 'known)
1113
               (new (mh-mm-possibly-verify-or-decrypt (cdr handle) handle)))
Bill Wohler's avatar
Bill Wohler committed
1114
          (unless (eq new (cdr handle))
1115
            (mh-mm-destroy-parts (cdr handle))
Bill Wohler's avatar
Bill Wohler committed
1116 1117 1118 1119 1120 1121 1122 1123 1124
            (setcdr handle new))))
      (mh-mime-display-security handle)
      (goto-char point))))

;; I rewrote the security part because Gnus doesn't seem to ever minimize
;; the button. That is once the mime-security button is pressed there seems
;; to be no way of getting rid of the inserted text.
(defun mh-mime-security-show-details (handle)
  "Toggle display of detailed security info for HANDLE."
1125
  (let ((details (mh-mm-handle-multipart-ctl-parameter handle 'gnus-details)))
Bill Wohler's avatar
Bill Wohler committed
1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146
    (when details
      (let ((mh-mime-security-button-pressed
             (not (get-text-property (point) 'mh-button-pressed)))
            (mh-mime-security-button-line-format
             (get-text-property (point) 'mh-line-format)))
        (forward-char -1)
        (while (eq (get-text-property (point) 'mh-line-format)
                   mh-mime-security-button-line-format)
          (forward-char -1))
        (forward-char)
        (save-restriction
          (narrow-to-region (point) (point))
          (mh-insert-mime-security-button handle))
        (delete-region
         (point)
         (or (text-property-not-all
              (point) (point-max)
              'mh-line-format mh-mime-security-button-line-format)
             (point-max)))
        (forward-line -1)))))

Bill Wohler's avatar
Bill Wohler committed
1147 1148


Bill Wohler's avatar
Bill Wohler committed
1149
;;; Miscellaneous Article Washing
Bill Wohler's avatar
Bill Wohler committed
1150

Bill Wohler's avatar
Bill Wohler committed
1151
;;;###mh-autoload
Bill Wohler's avatar
Bill Wohler committed
1152 1153
(defun mh-add-missing-mime-version-header ()
  "Some mail programs don't put a MIME-Version header.
1154 1155
I have seen this only in spam, so maybe we shouldn't fix
this ;-)"
Bill Wohler's avatar
Bill Wohler committed
1156 1157
  (save-excursion
    (goto-char (point-min))
Bill Wohler's avatar
Bill Wohler committed
1158 1159 1160 1161 1162 1163
    (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
1164 1165
        (insert "MIME-Version: 1.0\n")))))

Bill Wohler's avatar
Bill Wohler committed
1166
;;;###mh-autoload
Bill Wohler's avatar
Bill Wohler committed
1167
(defun mh-display-smileys ()
1168
  "Display smileys."
Bill Wohler's avatar
Bill Wohler committed
1169 1170
  (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
1171

Bill Wohler's avatar
Bill Wohler committed
1172
;;;###mh-autoload
Bill Wohler's avatar
Bill Wohler committed
1173
(defun mh-display-emphasis ()
1174
  "Display graphical emphasis."
Bill Wohler's avatar
Bill Wohler committed
1175
  (when (and mh-graphical-emphasis-flag (mh-small-show-buffer-p))
1176
    (mh-flet
1177 1178 1179 1180
     ((article-goto-body ()))      ; shadow this function to do nothing
     (save-excursion
       (goto-char (point-min))
       (article-emphasize)))))
Bill Wohler's avatar
Bill Wohler committed
1181

Bill Wohler's avatar
Bill Wohler committed
1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193
(defun mh-small-show-buffer-p ()
  "Check if show buffer is small.
This is used to decide if smileys and graphical emphasis should 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
1194

Bill Wohler's avatar
Bill Wohler committed
1195

Bill Wohler's avatar
Bill Wohler committed
1196

Bill Wohler's avatar
Bill Wohler committed
1197
;;; MH-Letter Commands
1198

Bill Wohler's avatar
Bill Wohler committed
1199
;; MH-E commands are alphabetical; specific support routines follow command.
Bill Wohler's avatar
Bill Wohler committed
1200

Bill Wohler's avatar
Bill Wohler committed
1201 1202 1203
;;;###mh-autoload
(defun mh-compose-forward (&optional description folder range)
  "Add tag to forward a message.
Bill Wohler's avatar
Bill Wohler committed
1204

Bill Wohler's avatar
Bill Wohler committed
1205 1206 1207 1208 1209
You are prompted for a content DESCRIPTION, the name of the
FOLDER in which the messages to forward are located, and a RANGE
of messages, which defaults to the current message in that
folder. Check the documentation of `mh-interactive-range' to see
how RANGE is read in interactive use.
Bill Wohler's avatar
Bill Wohler committed
1210

Bill Wohler's avatar
Bill Wohler committed
1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234
The option `mh-compose-insertion' controls what type of tags are inserted."
  (interactive
   (let* ((description
           (mml-minibuffer-read-description))
          (folder
           (mh-prompt-for-folder "Message from"
                                 mh-sent-from-folder nil))
          (default
            (if (and (equal folder mh-sent-from-folder)
                     (numberp mh-sent-from-msg))
                mh-sent-from-msg
              (nth 0 (mh-translate-range folder "cur"))))
          (range
           (mh-read-range "Forward" folder
                          (or (and default
                                   (number-to-string default))
                              t)
                          t t)))
     (list description folder range)))
  (let ((messages (mapconcat 'identity (mh-list-to-string range) " ")))
    (dolist (message (mh-translate-range folder messages))
      (if (equal mh-compose-insertion 'mml)
          (mh-mml-forward-message description folder (format "%s" message))
        (mh-mh-forward-message description folder (format "%s" message))))))
Bill Wohler's avatar
Bill Wohler committed
1235

Bill Wohler's avatar
Bill Wohler committed
1236
;;;###mh-autoload
Bill Wohler's avatar
Bill Wohler committed
1237 1238
(defun mh-mml-forward-message (description folder message)
  "Forward a message as attachment.
Bill Wohler's avatar
Bill Wohler committed
1239

Bill Wohler's avatar
Bill Wohler committed
1240 1241 1242 1243 1244 1245
The function will prompt the user for a DESCRIPTION, a FOLDER and
MESSAGE number."
  (let ((msg (if (and (equal message "") (numberp mh-sent-from-msg))
                 mh-sent-from-msg
               (string-to-number message))))
    (cond ((integerp msg)
1246 1247 1248 1249 1250
           (mml-attach-file (format "%s%s/%d"
                                    mh-user-path (substring folder 1) msg)
                            "message/rfc822"
                            (if (string= "" description) nil description)
                            "inline"))
1251
          (t (error "The message number, %s, is not an integer" msg)))))
Bill Wohler's avatar
Bill Wohler committed
1252

Bill Wohler's avatar
Bill Wohler committed
1253 1254 1255 1256 1257
(defun mh-mh-forward-message (&optional description folder messages)
  "Add tag to forward a message.
You are prompted for a content DESCRIPTION, the name of the
FOLDER in which the messages to forward are located, and the
MESSAGES' numbers.
Bill Wohler's avatar
Bill Wohler committed
1258

Bill Wohler's avatar
Bill Wohler committed
1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284
See also \\[mh-mh-to-mime]."
  (interactive (list
                (mml-minibuffer-read-description)
                (mh-prompt-for-folder "Message from" mh-sent-from-folder nil)
                (read-string (concat "Messages"
                                     (if (numberp mh-sent-from-msg)
                                         (format " (default %d): "
                                                 mh-sent-from-msg)
                                       ": ")))))
  (beginning-of-line)
  (insert "#forw [")
  (and description
       (not (string= description ""))
       (insert description))
  (insert "]")
  (and folder
       (not (string= folder ""))
       (insert " " folder))
  (if (and messages
           (not (string= messages "")))
      (let ((start (point)))
        (insert " " messages)
        (subst-char-in-region start (point) ?, ? ))
    (if (numberp mh-sent-from-msg)
        (insert " " (int-to-string mh-sent-from-msg))))
  (insert "\n"))
Bill Wohler's avatar
Bill Wohler committed
1285

Bill Wohler's avatar
Bill Wohler committed
1286 1287 1288
;;;###mh-autoload
(defun mh-compose-insertion (&optional inline)
  "Add tag to include a file such as an image or sound.
Bill Wohler's avatar
Bill Wohler committed
1289

Bill Wohler's avatar
Bill Wohler committed
1290 1291 1292 1293
You are prompted for the filename containing the object, the
media type if it cannot be determined automatically, and a
content description. If you're using MH-style directives, you
will also be prompted for additional attributes.
Bill Wohler's avatar
Bill Wohler committed
1294

Bill Wohler's avatar
Bill Wohler committed
1295 1296 1297 1298 1299 1300 1301 1302 1303
The option `mh-compose-insertion' controls what type of tags are
inserted. Optional argument INLINE means make it an inline
attachment."
  (interactive "P")
  (if (equal mh-compose-insertion 'mml)
      (if inline
          (mh-mml-attach-file "inline")
        (mh-mml-attach-file))
    (call-interactively 'mh-mh-attach-file)))
Bill Wohler's avatar
Bill Wohler committed
1304

Bill Wohler's avatar
Bill Wohler committed
1305 1306
(defun mh-mml-attach-file (&optional disposition)
  "Add a tag to insert a MIME message part from a file.
Bill Wohler's avatar
Bill Wohler committed
1307

Bill Wohler's avatar
Bill Wohler committed
1308 1309 1310
You are prompted for the filename containing the object, the
media type if it cannot be determined automatically, a content
description and the DISPOSITION of the attachment.
Bill Wohler's avatar
Bill Wohler committed
1311

Bill Wohler's avatar
Bill Wohler committed
1312 1313 1314 1315 1316 1317 1318
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 (mh-minibuffer-read-type file))
         (description (mml-minibuffer-read-description))
         (dispos (or disposition
1319
                     (mh-mml-minibuffer-read-disposition type))))
Bill Wohler's avatar
Bill Wohler committed
1320 1321
    (mml-insert-empty-tag 'part 'type type 'filename file
                          'disposition dispos 'description description)))
Bill Wohler's avatar
Bill Wohler committed
1322

Bill Wohler's avatar
Bill Wohler committed
1323 1324 1325 1326 1327 1328
(defun mh-mh-attach-file (filename type description attributes)
  "Add a tag to insert a MIME message part from a file.
You are prompted for the FILENAME containing the object, the
media TYPE if it cannot be determined automatically, and a
content DESCRIPTION. In addition, you are also prompted for
additional ATTRIBUTES.
Bill Wohler's avatar
Bill Wohler committed
1329