lisp/mh-e/mh-mime.el

   1 ;;; mh-mime.el --- MH-E MIME support
   2
   3 ;; Copyright (C) 1993, 1995,
   4 ;;  2001, 2002, 2003, 2004, 2005, 2006 Free Software Foundation, Inc.
   5
   6 ;; Author: Bill Wohler <wohler@newt.com>
   7 ;; Maintainer: Bill Wohler <wohler@newt.com>
   8 ;; Keywords: mail
   9 ;; See: mh-e.el
  10
  11 ;; This file is part of GNU Emacs.
  12
  13 ;; GNU Emacs is free software; you can redistribute it and/or modify
  14 ;; it under the terms of the GNU General Public License as published by
  15 ;; the Free Software Foundation; either version 2, or (at your option)
  16 ;; any later version.
  17
  18 ;; GNU Emacs is distributed in the hope that it will be useful,
  19 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  20 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  21 ;; GNU General Public License for more details.
  22
  23 ;; You should have received a copy of the GNU General Public License
  24 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  25 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  26 ;; Boston, MA 02110-1301, USA.
  27
  28 ;;; Commentary:
  29
  30 ;; Message composition of MIME message is done with either MH-style
  31 ;; directives for mhn or mhbuild (MH 6.8 or later) or MML (MIME Meta
  32 ;; Language) tags.
  33
  34 ;; TODO:
  35 ;;   Paragraph code should not fill # lines if MIME enabled.
  36 ;;   Implement mh-auto-mh-to-mime (if non-nil, \\[mh-send-letter]
  37 ;;      invokes mh-mh-to-mime automatically before sending.)
  38 ;;      Actually, instead of mh-auto-mh-to-mime,
  39 ;;      should read automhnproc from profile.
  40 ;;   MIME option to mh-forward command to move to content-description
  41 ;;   insertion point.
  42
  43 ;;; Change Log:
  44
  45 ;;; Code:
  46
  47 (require 'mh-e)
  48 (require 'mh-gnus)                      ;needed because mh-gnus.el not compiled
  49
  50 (require 'font-lock)
  51 (require 'gnus-util)
  52 (require 'mailcap)
  53 (require 'mm-decode)
  54 (require 'mm-view)
  55 (require 'mml)
  56
  57 (autoload 'article-emphasize "gnus-art")
  58 (autoload 'gnus-eval-format "gnus-spec")
  59 (autoload 'mail-content-type-get "mail-parse")
  60 (autoload 'mail-decode-encoded-word-string "mail-parse")
  61 (autoload 'mail-header-parse-content-type "mail-parse")
  62 (autoload 'mail-header-strip "mail-parse")
  63 (autoload 'message-options-set-recipient "message")
  64 (autoload 'mm-decode-body "mm-bodies")
  65 (autoload 'mm-uu-dissect "mm-uu")
  66 (autoload 'mml-unsecure-message "mml-sec")
  67 (autoload 'rfc2047-decode-region "rfc2047")
  68 (autoload 'widget-convert-button "wid-edit")
  69
  70 \f
  71
  72 ;;; Variables
  73
  74 ;; This has to be a macro, since we do: (setf (mh-buffer-data) ...)
  75 ;;;###mh-autoload
  76 (defmacro mh-buffer-data ()
  77   "Convenience macro to get the MIME data structures of the current buffer."
  78   `(gethash (current-buffer) mh-globals-hash))
  79
  80 ;; Structure to keep track of MIME handles on a per buffer basis.
  81 (mh-defstruct (mh-buffer-data (:conc-name mh-mime-)
  82                               (:constructor mh-make-buffer-data))
  83   (handles ())                          ; List of MIME handles
  84   (handles-cache (make-hash-table))     ; Cache to avoid multiple decodes of
  85                                         ; nested messages
  86   (parts-count 0)                       ; The button number is generated from
  87                                         ; this number
  88   (part-index-hash (make-hash-table)))  ; Avoid incrementing the part number
  89                                         ; for nested messages
  90
  91 (defvar mh-mm-inline-media-tests
  92   `(("image/jpeg"
  93      mm-inline-image
  94      (lambda (handle)
  95        (mm-valid-and-fit-image-p 'jpeg handle)))
  96     ("image/png"
  97      mm-inline-image
  98      (lambda (handle)
  99        (mm-valid-and-fit-image-p 'png handle)))
 100     ("image/gif"
 101      mm-inline-image
 102      (lambda (handle)
 103        (mm-valid-and-fit-image-p 'gif handle)))
 104     ("image/tiff"
 105      mm-inline-image
 106      (lambda (handle)
 107        (mm-valid-and-fit-image-p 'tiff handle)) )
 108     ("image/xbm"
 109      mm-inline-image
 110      (lambda (handle)
 111        (mm-valid-and-fit-image-p 'xbm handle)))
 112     ("image/x-xbitmap"
 113      mm-inline-image
 114      (lambda (handle)
 115        (mm-valid-and-fit-image-p 'xbm handle)))
 116     ("image/xpm"
 117      mm-inline-image
 118      (lambda (handle)
 119        (mm-valid-and-fit-image-p 'xpm handle)))
 120     ("image/x-pixmap"
 121      mm-inline-image
 122      (lambda (handle)
 123        (mm-valid-and-fit-image-p 'xpm handle)))
 124     ("image/bmp"
 125      mm-inline-image
 126      (lambda (handle)
 127        (mm-valid-and-fit-image-p 'bmp handle)))
 128     ("image/x-portable-bitmap"
 129      mm-inline-image
 130      (lambda (handle)
 131        (mm-valid-and-fit-image-p 'pbm handle)))
 132     ("text/plain" mm-inline-text identity)
 133     ("text/enriched" mm-inline-text identity)
 134     ("text/richtext" mm-inline-text identity)
 135     ("text/x-patch" mm-display-patch-inline
 136      (lambda (handle)
 137        (locate-library "diff-mode")))
 138     ("application/emacs-lisp" mm-display-elisp-inline identity)
 139     ("application/x-emacs-lisp" mm-display-elisp-inline identity)
 140     ("text/html"
 141      ,(if (fboundp 'mm-inline-text-html) 'mm-inline-text-html 'mm-inline-text)
 142      (lambda (handle)
 143        (or (and (boundp 'mm-inline-text-html-renderer)
 144                 mm-inline-text-html-renderer)
 145            (and (boundp 'mm-text-html-renderer) mm-text-html-renderer))))
 146     ("text/x-vcard"
 147      mh-mm-inline-text-vcard
 148      (lambda (handle)
 149        (or (featurep 'vcard)
 150            (locate-library "vcard"))))
 151     ("message/delivery-status" mm-inline-text identity)
 152     ("message/rfc822" mh-mm-inline-message identity)
 153     ;;("message/partial" mm-inline-partial identity)
 154     ;;("message/external-body" mm-inline-external-body identity)
 155     ("text/.*" mm-inline-text identity)
 156     ("audio/wav" mm-inline-audio
 157      (lambda (handle)
 158        (and (or (featurep 'nas-sound) (featurep 'native-sound))
 159             (device-sound-enabled-p))))
 160     ("audio/au"
 161      mm-inline-audio
 162      (lambda (handle)
 163        (and (or (featurep 'nas-sound) (featurep 'native-sound))
 164             (device-sound-enabled-p))))
 165     ("application/pgp-signature" ignore identity)
 166     ("application/x-pkcs7-signature" ignore identity)
 167     ("application/pkcs7-signature" ignore identity)
 168     ("application/x-pkcs7-mime" ignore identity)
 169     ("application/pkcs7-mime" ignore identity)
 170     ("multipart/alternative" ignore identity)
 171     ("multipart/mixed" ignore identity)
 172     ("multipart/related" ignore identity)
 173     ;; Disable audio and image
 174     ("audio/.*" ignore ignore)
 175     ("image/.*" ignore ignore)
 176     ;; Default to displaying as text
 177     (".*" mm-inline-text mh-mm-readable-p))
 178   "Alist of media types/tests saying whether types can be displayed inline.")
 179
 180 (defvar mh-mime-save-parts-directory nil
 181   "Default to use for `mh-mime-save-parts-default-directory'.
 182 Set from last use.")
 183
 184 ;; Copied from gnus-art.el (should be checked for other cool things that can
 185 ;; be added to the buttons)
 186 (defvar mh-mime-button-commands
 187   '((mh-press-button "\r" "Toggle Display")))
 188 (defvar mh-mime-button-map
 189   (let ((map (make-sparse-keymap)))
 190     (unless (>= (string-to-number emacs-version) 21)
 191       ;; XEmacs doesn't care.
 192       (set-keymap-parent map mh-show-mode-map))
 193     (mh-do-in-gnu-emacs
 194      (define-key map [mouse-2] 'mh-push-button))
 195     (mh-do-in-xemacs
 196      (define-key map '(button2) 'mh-push-button))
 197     (dolist (c mh-mime-button-commands)
 198       (define-key map (cadr c) (car c)))
 199     map))
 200 (defvar mh-mime-button-line-format-alist
 201   '((?T long-type ?s)
 202     (?d description ?s)
 203     (?p index ?s)
 204     (?e dots ?s)))
 205 (defvar mh-mime-button-line-format "%{%([%p. %d%T]%)%}%e\n")
 206 (defvar mh-mime-security-button-pressed nil)
 207 (defvar mh-mime-security-button-line-format "%{%([[%t:%i]%D]%)%}\n")
 208 (defvar mh-mime-security-button-end-line-format "%{%([[End of %t]%D]%)%}\n")
 209 (defvar mh-mime-security-button-line-format-alist
 210   '((?t type ?s)
 211     (?i info ?s)
 212     (?d details ?s)
 213     (?D pressed-details ?s)))
 214 (defvar mh-mime-security-button-map
 215   (let ((map (make-sparse-keymap)))
 216     (unless (>= (string-to-number emacs-version) 21)
 217       (set-keymap-parent map mh-show-mode-map))
 218     (define-key map "\r" 'mh-press-button)
 219     (mh-do-in-gnu-emacs
 220      (define-key map [mouse-2] 'mh-push-button))
 221     (mh-do-in-xemacs
 222      (define-key map '(button2) 'mh-push-button))
 223     map))
 224
 225 \f
 226
 227 ;;; MH-Folder Commands
 228
 229 ;; Alphabetical.
 230
 231 ;;;###mh-autoload
 232 (defun mh-display-with-external-viewer (part-index)
 233   "View attachment externally.
 234
 235 If Emacs does not know how to view an attachment, you could save
 236 it into a file and then run some program to open it. It is
 237 easier, however, to launch the program directly from MH-E with
 238 this command. While you'll most likely use this to view
 239 spreadsheets and documents, it is also useful to use your browser
 240 to view HTML attachments with higher fidelity than what Emacs can
 241 provide.
 242
 243 This command displays the attachment associated with the button
 244 under the cursor. If the cursor is not located over a button,
 245 then the cursor first moves to the next button, wrapping to the
 246 beginning of the message if necessary. You can provide a numeric
 247 prefix argument PART-INDEX to view the attachment labeled with
 248 that number.
 249
 250 This command tries to provide a reasonable default for the viewer
 251 by calling the Emacs function `mailcap-mime-info'. This function
 252 usually reads the file \"/etc/mailcap\"."
 253   (interactive "P")
 254   (when (consp part-index) (setq part-index (car part-index)))
 255   (mh-folder-mime-action
 256    part-index
 257    #'(lambda ()
 258        (let* ((part (get-text-property (point) 'mh-data))
 259               (type (mm-handle-media-type part))
 260               (methods (mapcar (lambda (x) (list (cdr (assoc 'viewer x))))
 261                                (mailcap-mime-info type 'all)))
 262               (def (caar methods))
 263               (prompt (format "Viewer%s: " (if def
 264                                                (format " (default %s)" def)
 265                                              "")))
 266               (method (completing-read prompt methods nil nil nil nil def))
 267               (folder mh-show-folder-buffer)
 268               (buffer-read-only nil))
 269          (when (string-match "^[^% \t]+$" method)
 270            (setq method (concat method " %s")))
 271          (flet ((mm-handle-set-external-undisplayer (handle function)
 272                   (mh-handle-set-external-undisplayer folder handle function)))
 273            (unwind-protect (mm-display-external part method)
 274              (set-buffer-modified-p nil)))))
 275    nil))
 276
 277 ;;;###mh-autoload
 278 (defun mh-folder-inline-mime-part (part-index)
 279   "Show attachment verbatim.
 280
 281 You can view the raw contents of an attachment with this command.
 282 This command displays (or hides) the contents of the attachment
 283 associated with the button under the cursor verbatim. If the
 284 cursor is not located over a button, then the cursor first moves
 285 to the next button, wrapping to the beginning of the message if
 286 necessary.
 287
 288 You can also provide a numeric prefix argument PART-INDEX to view
 289 the attachment labeled with that number."
 290   (interactive "P")
 291   (when (consp part-index) (setq part-index (car part-index)))
 292   (mh-folder-mime-action part-index #'mh-mime-inline-part nil))
 293
 294 (defun mh-mime-inline-part ()
 295   "Toggle display of the raw MIME part."
 296   (interactive)
 297   (let* ((buffer-read-only nil)
 298          (data (get-text-property (point) 'mh-data))
 299          (inserted-flag (get-text-property (point) 'mh-mime-inserted))
 300          (displayed-flag (mm-handle-displayed-p data))
 301          (point (point))
 302          start end)
 303     (cond ((and data (not inserted-flag) (not displayed-flag))
 304            (let ((contents (mm-get-part data)))
 305              (add-text-properties (mh-line-beginning-position)
 306                                   (mh-line-end-position) '(mh-mime-inserted t))
 307              (setq start (point-marker))
 308              (forward-line 1)
 309              (mm-insert-inline data contents)
 310              (setq end (point-marker))
 311              (add-text-properties
 312               start (progn (goto-char start) (mh-line-end-position))
 313               `(mh-region (,start . ,end)))))
 314           ((and data (or inserted-flag displayed-flag))
 315            (mh-press-button)
 316            (message "MIME part already inserted")))
 317     (goto-char point)
 318     (set-buffer-modified-p nil)))
 319
 320 ;;;###mh-autoload
 321 (defun mh-folder-save-mime-part (part-index)
 322   "Save (output) attachment.
 323
 324 This command saves the attachment associated with the button under the
 325 cursor. If the cursor is not located over a button, then the cursor
 326 first moves to the next button, wrapping to the beginning of the
 327 message if necessary.
 328
 329 You can also provide a numeric prefix argument PART-INDEX to save the
 330 attachment labeled with that number.
 331
 332 This command prompts you for a filename and suggests a specific name
 333 if it is available."
 334   (interactive "P")
 335   (when (consp part-index) (setq part-index (car part-index)))
 336   (mh-folder-mime-action part-index #'mh-mime-save-part nil))
 337
 338 (defun mh-mime-save-part ()
 339   "Save MIME part at point."
 340   (interactive)
 341   (let ((data (get-text-property (point) 'mh-data)))
 342     (when data
 343       (let ((mm-default-directory
 344              (file-name-as-directory (or mh-mime-save-parts-directory
 345                                          default-directory))))
 346         (mh-mm-save-part data)
 347         (setq mh-mime-save-parts-directory mm-default-directory)))))
 348
 349 ;;;###mh-autoload
 350 (defun mh-folder-toggle-mime-part (part-index)
 351   "View attachment.
 352
 353 This command displays (or hides) the attachment associated with
 354 the button under the cursor. If the cursor is not located over a
 355 button, then the cursor first moves to the next button, wrapping
 356 to the beginning of the message if necessary. This command has
 357 the advantage over related commands of working from the MH-Folder
 358 buffer.
 359
 360 You can also provide a numeric prefix argument PART-INDEX to view
 361 the attachment labeled with that number. If Emacs does not know
 362 how to display the attachment, then Emacs offers to save the
 363 attachment in a file."
 364   (interactive "P")
 365   (when (consp part-index) (setq part-index (car part-index)))
 366   (mh-folder-mime-action part-index #'mh-press-button t))
 367
 368 ;;;###mh-autoload
 369 (defun mh-mime-save-parts (prompt)
 370   "Save attachments.
 371
 372 You can save all of the attachments at once with this command.
 373 The attachments are saved in the directory specified by the
 374 option `mh-mime-save-parts-default-directory' unless you use a
 375 prefix argument PROMPT in which case you are prompted for the
 376 directory. These directories may be superseded by MH profile
 377 components, since this function calls on \"mhstore\" (\"mhn\") to
 378 do the work."
 379   (interactive "P")
 380   (let ((msg (if (eq major-mode 'mh-show-mode)
 381                  (mh-show-buffer-message-number)
 382                (mh-get-msg-num t)))
 383         (folder (if (eq major-mode 'mh-show-mode)
 384                     mh-show-folder-buffer
 385                   mh-current-folder))
 386         (command (if (mh-variant-p 'nmh) "mhstore" "mhn"))
 387         (directory
 388          (cond
 389           ((and (or prompt
 390                     (equal nil mh-mime-save-parts-default-directory)
 391                     (equal t mh-mime-save-parts-default-directory))
 392                 (not mh-mime-save-parts-directory))
 393            (read-file-name "Store in directory: " nil nil t nil))
 394           ((and (or prompt
 395                     (equal t mh-mime-save-parts-default-directory))
 396                 mh-mime-save-parts-directory)
 397            (read-file-name (format
 398                             "Store in directory (default %s): "
 399                             mh-mime-save-parts-directory)
 400                            "" mh-mime-save-parts-directory t ""))
 401           ((stringp mh-mime-save-parts-default-directory)
 402            mh-mime-save-parts-default-directory)
 403           (t
 404            mh-mime-save-parts-directory))))
 405     (if (and (equal directory "") mh-mime-save-parts-directory)
 406         (setq directory mh-mime-save-parts-directory))
 407     (if (not (file-directory-p directory))
 408         (message "No directory specified")
 409       (if (equal nil mh-mime-save-parts-default-directory)
 410           (setq mh-mime-save-parts-directory directory))
 411       (save-excursion
 412         (set-buffer (get-buffer-create mh-log-buffer))
 413         (cd directory)
 414         (setq mh-mime-save-parts-directory directory)
 415         (let ((initial-size (mh-truncate-log-buffer)))
 416           (apply 'call-process
 417                  (expand-file-name command mh-progs) nil t nil
 418                  (mh-list-to-string (list folder msg "-auto")))
 419           (if (> (buffer-size) initial-size)
 420               (save-window-excursion
 421                 (switch-to-buffer-other-window mh-log-buffer)
 422                 (sit-for 3))))))))
 423
 424 ;;;###mh-autoload
 425 (defun mh-toggle-mh-decode-mime-flag ()
 426   "Toggle the value of `mh-decode-mime-flag'."
 427   (interactive)
 428   (setq mh-decode-mime-flag (not mh-decode-mime-flag))
 429   (mh-show nil t)
 430   (message "%s" (if mh-decode-mime-flag
 431                     "Processing attachments normally"
 432                   "Displaying raw message")))
 433
 434 ;;;###mh-autoload
 435 (defun mh-toggle-mime-buttons ()
 436   "Toggle option `mh-display-buttons-for-inline-parts-flag'."
 437   (interactive)
 438   (setq mh-display-buttons-for-inline-parts-flag
 439         (not mh-display-buttons-for-inline-parts-flag))
 440   (mh-show nil t))
 441
 442 \f
 443
 444 ;;; MIME Display Routines
 445
 446 (defun mh-mm-inline-message (handle)
 447   "Display message, HANDLE.
 448 The function decodes the message and displays it. It avoids
 449 decoding the same message multiple times."
 450   (let ((b (point))
 451         (clean-message-header mh-clean-message-header-flag)
 452         (invisible-headers mh-invisible-header-fields-compiled)
 453         (visible-headers nil))
 454     (save-excursion
 455       (save-restriction
 456         (narrow-to-region b b)
 457         (mm-insert-part handle)
 458         (mh-mime-display
 459          (or (gethash handle (mh-mime-handles-cache (mh-buffer-data)))
 460              (setf (gethash handle (mh-mime-handles-cache (mh-buffer-data)))
 461                    (let ((handles (mm-dissect-buffer nil)))
 462                      (if handles
 463                          (mh-mm-uu-dissect-text-parts handles)
 464                        (setq handles (mm-uu-dissect)))
 465                      (setf (mh-mime-handles (mh-buffer-data))
 466                            (mh-mm-merge-handles
 467                             handles (mh-mime-handles (mh-buffer-data))))
 468                      handles))))
 469
 470         (goto-char (point-min))
 471         (mh-show-xface)
 472         (cond (clean-message-header
 473                (mh-clean-msg-header (point-min)
 474                                     invisible-headers
 475                                     visible-headers)
 476                (goto-char (point-min)))
 477               (t
 478                (mh-start-of-uncleaned-message)))
 479         (mh-decode-message-header)
 480         (mh-show-addr)
 481         ;; The other highlighting types don't need anything special
 482         (when (eq mh-highlight-citation-style 'gnus)
 483           (mh-gnus-article-highlight-citation))
 484         (goto-char (point-min))
 485         (insert "\n------- Forwarded Message\n\n")
 486         (mh-display-smileys)
 487         (mh-display-emphasis)
 488         (mm-handle-set-undisplayer
 489          handle
 490          `(lambda ()
 491             (let (buffer-read-only)
 492               (if (fboundp 'remove-specifier)
 493                   ;; This is only valid on XEmacs.
 494                   (mapcar (lambda (prop)
 495                             (remove-specifier
 496                              (face-property 'default prop) (current-buffer)))
 497                           '(background background-pixmap foreground)))
 498               (delete-region ,(point-min-marker) ,(point-max-marker)))))))))
 499
 500 ;;;###mh-autoload
 501 (defun mh-decode-message-header ()
 502   "Decode RFC2047 encoded message header fields."
 503   (when mh-decode-mime-flag
 504     (let ((buffer-read-only nil))
 505       (rfc2047-decode-region (point-min) (mh-mail-header-end)))))
 506
 507 ;;;###mh-autoload
 508 (defun mh-mime-display (&optional pre-dissected-handles)
 509   "Display (and possibly decode) MIME handles.
 510 Optional argument, PRE-DISSECTED-HANDLES is a list of MIME
 511 handles. If present they are displayed otherwise the buffer is
 512 parsed and then displayed."
 513   (let ((handles ())
 514         (folder mh-show-folder-buffer)
 515         (raw-message-data (buffer-string)))
 516     (flet ((mm-handle-set-external-undisplayer
 517             (handle function)
 518             (mh-handle-set-external-undisplayer folder handle function)))
 519       (goto-char (point-min))
 520       (unless (search-forward "\n\n" nil t)
 521         (goto-char (point-max))
 522         (insert "\n\n"))
 523
 524       (condition-case err
 525           (progn
 526             ;; If needed dissect the current buffer
 527             (if pre-dissected-handles
 528                 (setq handles pre-dissected-handles)
 529               (if (setq handles (mm-dissect-buffer nil))
 530                   (mh-mm-uu-dissect-text-parts handles)
 531                 (setq handles (mm-uu-dissect)))
 532               (setf (mh-mime-handles (mh-buffer-data))
 533                     (mh-mm-merge-handles handles
 534                                          (mh-mime-handles (mh-buffer-data))))
 535               (unless handles
 536                 (mh-decode-message-body)))
 537
 538             (cond ((and handles
 539                         (or (not (stringp (car handles)))
 540                             (cdr handles)))
 541                    ;; Go to start of message body
 542                    (goto-char (point-min))
 543                    (or (search-forward "\n\n" nil t)
 544                        (goto-char (point-max)))
 545
 546                    ;; Delete the body
 547                    (delete-region (point) (point-max))
 548
 549                    ;; Display the MIME handles
 550                    (mh-mime-display-part handles))
 551                   (t
 552                    (mh-signature-highlight))))
 553         (error
 554          (message "Could not display body: %s" (error-message-string err))
 555          (delete-region (point-min) (point-max))
 556          (insert raw-message-data))))))
 557
 558 (defun mh-decode-message-body ()
 559   "Decode message based on charset.
 560 If message has been encoded for transfer take that into account."
 561   (let (ct charset cte)
 562     (goto-char (point-min))
 563     (re-search-forward "\n\n" nil t)
 564     (save-restriction
 565       (narrow-to-region (point-min) (point))
 566       (setq ct (ignore-errors (mail-header-parse-content-type
 567                                (message-fetch-field "Content-Type" t)))
 568             charset (mail-content-type-get ct 'charset)
 569             cte (message-fetch-field "Content-Transfer-Encoding")))
 570     (when (stringp cte) (setq cte (mail-header-strip cte)))
 571     (when (or (not ct) (equal (car ct) "text/plain"))
 572       (save-restriction
 573         (narrow-to-region (min (1+ (mh-mail-header-end)) (point-max))
 574                           (point-max))
 575         (mm-decode-body charset
 576                         (and cte (intern (downcase
 577                                           (gnus-strip-whitespace cte))))
 578                         (car ct))))))
 579
 580 (defun mh-mime-display-part (handle)
 581   "Decides the viewer to call based on the type of HANDLE."
 582   (cond ((null handle)
 583          nil)
 584         ((not (stringp (car handle)))
 585          (mh-mime-display-single handle))
 586         ((equal (car handle) "multipart/alternative")
 587          (mh-mime-display-alternative (cdr handle)))
 588         ((and mh-pgp-support-flag
 589               (or (equal (car handle) "multipart/signed")
 590                   (equal (car handle) "multipart/encrypted")))
 591          (mh-mime-display-security handle))
 592         (t
 593          (mh-mime-display-mixed (cdr handle)))))
 594
 595 (defun mh-mime-display-mixed (handles)
 596   "Display the list of MIME parts, HANDLES recursively."
 597   (mapcar #'mh-mime-display-part handles))
 598
 599 (defun mh-mime-display-alternative (handles)
 600   "Choose among the alternatives, HANDLES the part that will be displayed.
 601 If no part is preferred then all the parts are displayed."
 602   (let* ((preferred (mm-preferred-alternative handles))
 603          (others (loop for x in handles unless (eq x preferred) collect x)))
 604     (cond ((and preferred
 605                 (stringp (car preferred)))
 606            (mh-mime-display-part preferred)
 607            (mh-mime-maybe-display-alternatives others))
 608           (preferred
 609            (save-restriction
 610              (narrow-to-region (point) (if (eobp) (point) (1+ (point))))
 611              (mh-mime-display-single preferred)
 612              (mh-mime-maybe-display-alternatives others)
 613              (goto-char (point-max))))
 614           (t
 615            (mh-mime-display-mixed handles)))))
 616
 617 (defun mh-mime-maybe-display-alternatives (alternatives)
 618   "Show buttons for ALTERNATIVES.
 619 If `mh-mime-display-alternatives-flag' is non-nil then display
 620 buttons for alternative parts that are usually suppressed."
 621   (when (and mh-display-buttons-for-alternatives-flag alternatives)
 622     (insert "\n----------------------------------------------------\n")
 623     (insert "Alternatives:\n")
 624     (dolist (x alternatives)
 625       (insert "\n")
 626       (mh-insert-mime-button x (mh-mime-part-index x) nil))
 627     (insert "\n----------------------------------------------------\n")))
 628
 629 (defun mh-mime-display-security (handle)
 630   "Display PGP encrypted/signed message, HANDLE."
 631   (save-restriction
 632     (narrow-to-region (point) (point))
 633     (insert "\n")
 634     (mh-insert-mime-security-button handle)
 635     (mh-mime-display-mixed (cdr handle))
 636     (insert "\n")
 637     (let ((mh-mime-security-button-line-format
 638            mh-mime-security-button-end-line-format))
 639       (mh-insert-mime-security-button handle))
 640     (mh-mm-set-handle-multipart-parameter
 641      handle 'mh-region (cons (point-min-marker) (point-max-marker)))))
 642
 643 (defun mh-mime-display-single (handle)
 644   "Display a leaf node, HANDLE in the MIME tree."
 645   (let* ((type (mm-handle-media-type handle))
 646          (small-image-flag (mh-small-image-p handle))
 647          (attachmentp (equal (car (mm-handle-disposition handle))
 648                              "attachment"))
 649          (inlinep (and (equal (car (mm-handle-disposition handle)) "inline")
 650                        (mm-inlinable-p handle)
 651                        (mm-inlined-p handle)))
 652          (displayp (or inlinep                   ; show if inline OR
 653                        (mh-inline-vcard-p handle);      inline vcard OR
 654                        (and (not attachmentp)    ;      if not an attachment
 655                             (or small-image-flag ;        and small image
 656                                                  ;        and user wants inline
 657                                 (and (not (equal
 658                                            (mm-handle-media-supertype handle)
 659                                            "image"))
 660                                      (mm-inlinable-p handle)
 661                                      (mm-inlined-p handle)))))))
 662     (save-restriction
 663       (narrow-to-region (point) (if (eobp) (point) (1+ (point))))
 664       (cond ((and mh-pgp-support-flag
 665                   (equal type "application/pgp-signature"))
 666              nil)             ; skip signatures as they are already handled...
 667             ((not displayp)
 668              (insert "\n")
 669              (mh-insert-mime-button handle (mh-mime-part-index handle) nil))
 670             ((and displayp
 671                   (not mh-display-buttons-for-inline-parts-flag))
 672              (or (mm-display-part handle)
 673                  (mm-display-part handle))
 674              (mh-signature-highlight handle))
 675             ((and displayp
 676                   mh-display-buttons-for-inline-parts-flag)
 677              (insert "\n")
 678              (mh-insert-mime-button handle (mh-mime-part-index handle) nil)
 679              (forward-line -1)
 680              (mh-mm-display-part handle)))
 681       (goto-char (point-max)))))
 682
 683 ;; There is a bug in Gnus inline image display due to which an extra line
 684 ;; gets inserted every time it is viewed. To work around that problem we are
 685 ;; using an extra property 'mh-region to remember the region that is added
 686 ;; when the button is clicked. The region is then deleted to make sure that
 687 ;; no extra lines get inserted.
 688 (defun mh-mm-display-part (handle)
 689   "Toggle display of button for MIME part, HANDLE."
 690   (beginning-of-line)
 691   (let ((id (get-text-property (point) 'mh-part))
 692         (point (point))
 693         (window (selected-window))
 694         (mail-parse-charset 'nil)
 695         (mail-parse-ignored-charsets nil)
 696         region buffer-read-only)
 697     (save-excursion
 698       (unwind-protect
 699           (let ((win (get-buffer-window (current-buffer) t)))
 700             (when win
 701               (select-window win))
 702             (goto-char point)
 703
 704             (if (mm-handle-displayed-p handle)
 705                 ;; This will remove the part.
 706                 (progn
 707                   ;; Delete the button and displayed part (if any)
 708                   (let ((region (get-text-property point 'mh-region)))
 709                     (when region
 710                       (mh-funcall-if-exists
 711                        remove-images (car region) (cdr region)))
 712                     (mm-display-part handle)
 713                     (when region
 714                       (delete-region (car region) (cdr region))))
 715                   ;; Delete button (if it still remains). This happens for
 716                   ;; externally displayed parts where the previous step does
 717                   ;; nothing.
 718                   (unless (eolp)
 719                     (delete-region (point) (progn (forward-line) (point)))))
 720               (save-restriction
 721                 (delete-region (point) (progn (forward-line 1) (point)))
 722                 (narrow-to-region (point) (point))
 723                 ;; Maybe we need another unwind-protect here.
 724                 (when (equal (mm-handle-media-supertype handle) "image")
 725                   (insert "\n"))
 726                 (when (and (not (eq (ignore-errors (mm-display-part handle))
 727                                     'inline))
 728                            (equal (mm-handle-media-supertype handle)
 729                                   "image"))
 730                   (goto-char (point-min))
 731                   (delete-char 1))
 732                 (when (equal (mm-handle-media-supertype handle) "text")
 733                   (when (eq mh-highlight-citation-style 'gnus)
 734                     (mh-gnus-article-highlight-citation))
 735                   (mh-display-smileys)
 736                   (mh-display-emphasis)
 737                   (mh-signature-highlight handle))
 738                 (setq region (cons (progn (goto-char (point-min))
 739                                           (point-marker))
 740                                    (progn (goto-char (point-max))
 741                                           (point-marker)))))))
 742         (when (window-live-p window)
 743           (select-window window))
 744         (goto-char point)
 745         (beginning-of-line)
 746         (mh-insert-mime-button handle id (mm-handle-displayed-p handle))
 747         (goto-char point)
 748         (when region
 749           (add-text-properties (mh-line-beginning-position)
 750                                (mh-line-end-position)
 751                                `(mh-region ,region)))))))
 752
 753 (defun mh-mime-part-index (handle)
 754   "Generate the button number for MIME part, HANDLE.
 755 Notice that a hash table is used to display the same number when
 756 buttons need to be displayed multiple times (for instance when
 757 nested messages are opened)."
 758   (or (gethash handle (mh-mime-part-index-hash (mh-buffer-data)))
 759       (setf (gethash handle (mh-mime-part-index-hash (mh-buffer-data)))
 760             (incf (mh-mime-parts-count (mh-buffer-data))))))
 761
 762 (defun mh-small-image-p (handle)
 763   "Decide whether HANDLE is a \"small\" image that can be displayed inline.
 764 This is only useful if a Content-Disposition header is not present."
 765   (let ((media-test (caddr (assoc (car (mm-handle-type handle))
 766                                   mh-mm-inline-media-tests)))
 767         (mm-inline-large-images t))
 768     (and media-test
 769          (equal (mm-handle-media-supertype handle) "image")
 770          (funcall media-test handle) ; Since mm-inline-large-images is T,
 771                                         ; this only tells us if the image is
 772                                         ; something that emacs can display
 773          (let* ((image (mm-get-image handle)))
 774            (or (mh-do-in-xemacs
 775                  (and (mh-funcall-if-exists glyphp image)
 776                       (< (glyph-width image)
 777                          (or mh-max-inline-image-width (window-pixel-width)))
 778                       (< (glyph-height image)
 779                          (or mh-max-inline-image-height
 780                              (window-pixel-height)))))
 781                (mh-do-in-gnu-emacs
 782                  (let ((size (mh-funcall-if-exists image-size image)))
 783                    (and size
 784                         (< (cdr size) (or mh-max-inline-image-height
 785                                           (1- (window-height))))
 786                         (< (car size) (or mh-max-inline-image-width
 787                                           (window-width)))))))))))
 788
 789 (defun mh-inline-vcard-p (handle)
 790   "Decide if HANDLE is a vcard that must be displayed inline."
 791   (let ((type (mm-handle-type handle)))
 792     (and (or (featurep 'vcard) (fboundp 'vcard-pretty-print))
 793          (consp type)
 794          (equal (car type) "text/x-vcard")
 795          (save-excursion
 796            (save-restriction
 797              (widen)
 798              (goto-char (point-min))
 799              (not (mh-signature-separator-p)))))))
 800
 801 (defun mh-signature-highlight (&optional handle)
 802   "Highlight message signature in HANDLE.
 803 The optional argument, HANDLE is a MIME handle if the function is
 804 being used to highlight the signature in a MIME part."
 805   (let ((regexp
 806          (cond ((not handle) "^-- $")
 807                ((not (and (equal (mm-handle-media-supertype handle) "text")
 808                           (equal (mm-handle-media-subtype handle) "html")))
 809                 "^-- $")
 810                ((eq (mh-mm-text-html-renderer) 'lynx) "^   --$")
 811                (t "^--$"))))
 812     (save-excursion
 813       (goto-char (point-max))
 814       (when (re-search-backward regexp nil t)
 815         (mh-do-in-gnu-emacs
 816           (let ((ov (make-overlay (point) (point-max))))
 817             (overlay-put ov 'face 'mh-show-signature)
 818             (overlay-put ov 'evaporate t)))
 819         (mh-do-in-xemacs
 820           (set-extent-property (make-extent (point) (point-max))
 821                                'face 'mh-show-signature))))))
 822
 823 \f
 824
 825 ;;; Button Display
 826
 827 ;; Shush compiler.
 828 (eval-when-compile (mh-do-in-xemacs (defvar dots) (defvar type) (defvar ov)))
 829
 830 (defun mh-insert-mime-button (handle index displayed)
 831   "Insert MIME button for HANDLE.
 832 INDEX is the part number that will be DISPLAYED. It is also used
 833 by commands like \"K v\" which operate on individual MIME parts."
 834   ;; The button could be displayed by a previous decode. In that case
 835   ;; undisplay it if we need a hidden button.
 836   (when (and (mm-handle-displayed-p handle) (not displayed))
 837     (mm-display-part handle))
 838   (let ((name (or (mail-content-type-get (mm-handle-type handle) 'name)
 839                   (mail-content-type-get (mm-handle-disposition handle)
 840                                          'filename)
 841                   (mail-content-type-get (mm-handle-type handle) 'url)
 842                   ""))
 843         (type (mm-handle-media-type handle))
 844         (description (mail-decode-encoded-word-string
 845                       (or (mm-handle-description handle) "")))
 846         (dots (if (or displayed (mm-handle-displayed-p handle)) "   " "..."))
 847         long-type begin end)
 848     (if (string-match ".*/" name) (setq name (substring name (match-end 0))))
 849     (setq long-type (concat type (and (not (equal name ""))
 850                                       (concat "; " name))))
 851     (unless (equal description "")
 852       (setq long-type (concat " --- " long-type)))
 853     (unless (bolp) (insert "\n"))
 854     (setq begin (point))
 855     (gnus-eval-format
 856      mh-mime-button-line-format mh-mime-button-line-format-alist
 857      `(,@(mh-gnus-local-map-property mh-mime-button-map)
 858          mh-callback mh-mm-display-part
 859          mh-part ,index
 860          mh-data ,handle))
 861     (setq end (point))
 862     (widget-convert-button
 863      'link begin end
 864      :mime-handle handle
 865      :action 'mh-widget-press-button
 866      :button-keymap mh-mime-button-map
 867      :help-echo
 868      "Mouse-2 click or press RET (in show buffer) to toggle display")
 869     (dolist (ov (mh-funcall-if-exists overlays-in begin end))
 870       (mh-funcall-if-exists overlay-put ov 'evaporate t))))
 871
 872 ;; Shush compiler.
 873 (eval-when-compile
 874   (when (< emacs-major-version 22)
 875     (defvar  mm-verify-function-alist)
 876     (defvar  mm-decrypt-function-alist))
 877   (mh-do-in-xemacs
 878     (defvar pressed-details)))
 879
 880 (defun mh-insert-mime-security-button (handle)
 881   "Display buttons for PGP message, HANDLE."
 882   (let* ((protocol (mh-mm-handle-multipart-ctl-parameter handle 'protocol))
 883          (crypto-type (or (nth 2 (assoc protocol mm-verify-function-alist))
 884                           (nth 2 (assoc protocol mm-decrypt-function-alist))
 885                           "Unknown"))
 886          (type (concat crypto-type
 887                        (if (equal (car handle) "multipart/signed")
 888                            " Signed" " Encrypted")
 889                        " Part"))
 890          (info (or (mh-mm-handle-multipart-ctl-parameter handle 'gnus-info)
 891                    "Undecided"))
 892          (details (mh-mm-handle-multipart-ctl-parameter handle 'gnus-details))
 893          pressed-details begin end face)
 894     (setq details (if details (concat "\n" details) ""))
 895     (setq pressed-details (if mh-mime-security-button-pressed details ""))
 896     (setq face (mh-mime-security-button-face info))
 897     (unless (bolp) (insert "\n"))
 898     (setq begin (point))
 899     (gnus-eval-format
 900      mh-mime-security-button-line-format
 901      mh-mime-security-button-line-format-alist
 902      `(,@(mh-gnus-local-map-property mh-mime-security-button-map)
 903          mh-button-pressed ,mh-mime-security-button-pressed
 904          mh-callback mh-mime-security-press-button
 905          mh-line-format ,mh-mime-security-button-line-format
 906          mh-data ,handle))
 907     (setq end (point))
 908     (widget-convert-button 'link begin end
 909                            :mime-handle handle
 910                            :action 'mh-widget-press-button
 911                            :button-keymap mh-mime-security-button-map
 912                            :button-face face
 913                            :help-echo "Mouse-2 click or press RET (in show buffer) to see security details.")
 914     (dolist (ov (mh-funcall-if-exists overlays-in begin end))
 915       (mh-funcall-if-exists overlay-put ov 'evaporate t))
 916     (when (equal info "Failed")
 917       (let* ((type (if (equal (car handle) "multipart/signed")
 918                        "verification" "decryption"))
 919              (warning (if (equal type "decryption")
 920                           "(passphrase may be incorrect)" "")))
 921         (message "%s %s failed %s" crypto-type type warning)))))
 922
 923 (defun mh-mime-security-button-face (info)
 924   "Return the button face to use for encrypted/signed mail based on INFO."
 925   (cond ((string-match "OK" info)       ;Decrypted mail
 926          'mh-show-pgg-good)
 927         ((string-match "Failed" info)   ;Decryption failed or signature invalid
 928          'mh-show-pgg-bad)
 929         ((string-match "Undecided" info);Unprocessed mail
 930          'mh-show-pgg-unknown)
 931         ((string-match "Untrusted" info);Key not trusted
 932          'mh-show-pgg-unknown)
 933         (t
 934          'mh-show-pgg-good)))
 935
 936 \f
 937
 938 ;;; Button Handlers
 939
 940 (defun mh-folder-mime-action (part-index action include-security-flag)
 941   "Go to PART-INDEX and carry out ACTION.
 942
 943 If PART-INDEX is nil then go to the next part in the buffer. The
 944 search for the next buffer wraps around if end of buffer is reached.
 945 If argument INCLUDE-SECURITY-FLAG is non-nil then include security
 946 info buttons when searching for a suitable parts."
 947   (unless mh-showing-mode
 948     (mh-show))
 949   (mh-in-show-buffer (mh-show-buffer)
 950     (let ((criterion
 951            (cond (part-index
 952                   (lambda (p)
 953                     (let ((part (get-text-property p 'mh-part)))
 954                       (and (integerp part) (= part part-index)))))
 955                  (t (lambda (p)
 956                       (if include-security-flag
 957                           (get-text-property p 'mh-data)
 958                         (integerp (get-text-property p 'mh-part)))))))
 959           (point (point)))
 960       (cond ((and (get-text-property point 'mh-part)
 961                   (or (null part-index)
 962                       (= (get-text-property point 'mh-part) part-index)))
 963              (funcall action))
 964             ((and (get-text-property point 'mh-data)
 965                   include-security-flag
 966                   (null part-index))
 967              (funcall action))
 968             (t
 969              (mh-goto-next-button nil criterion)
 970              (if (= (point) point)
 971                  (message "No matching MIME part found")
 972                (funcall action)))))))
 973
 974 ;;;###mh-autoload
 975 (defun mh-goto-next-button (backward-flag &optional criterion)
 976   "Search for next button satisfying criterion.
 977
 978 If BACKWARD-FLAG is non-nil search backward in the buffer for a mime
 979 button.
 980 If CRITERION is a function or a symbol which has a function binding
 981 then that function must return non-nil at the button we stop."
 982   (unless (or (and (symbolp criterion) (fboundp criterion))
 983               (functionp criterion))
 984     (setq criterion (lambda (x) t)))
 985   ;; Move to the next button in the buffer satisfying criterion
 986   (goto-char (or (save-excursion
 987                    (beginning-of-line)
 988                    ;; Find point before current button
 989                    (let ((point-before-current-button
 990                           (save-excursion
 991                             (while (get-text-property (point) 'mh-data)
 992                               (unless (= (forward-line
 993                                           (if backward-flag 1 -1))
 994                                          0)
 995                                 (if backward-flag
 996                                     (goto-char (point-min))
 997                                   (goto-char (point-max)))))
 998                             (point))))
 999                      ;; Skip over current button
1000                      (while (and (get-text-property (point) 'mh-data)
1001                                  (not (if backward-flag (bobp) (eobp))))
1002                        (forward-line (if backward-flag -1 1)))
1003                      ;; Stop at next MIME button if any exists.
1004                      (block loop
1005                        (while (/= (progn
1006                                     (unless (= (forward-line
1007                                                 (if backward-flag -1 1))
1008                                                0)
1009                                       (if backward-flag
1010                                           (goto-char (point-max))
1011                                         (goto-char (point-min)))
1012                                       (beginning-of-line))
1013                                     (point))
1014                                   point-before-current-button)
1015                          (when (and (get-text-property (point) 'mh-data)
1016                                     (funcall criterion (point)))
1017                            (return-from loop (point))))
1018                        nil)))
1019                  (point))))
1020
1021 (defun mh-widget-press-button (widget el)
1022   "Callback for widget, WIDGET.
1023 Parameter EL is unused."
1024   (goto-char (widget-get widget :from))
1025   (mh-press-button))
1026
1027 (defun mh-press-button ()
1028   "View contents of button.
1029
1030 This command is a toggle so if you use it again on the same
1031 attachment, the attachment is hidden."
1032   (interactive)
1033   (let ((mm-inline-media-tests mh-mm-inline-media-tests)
1034         (data (get-text-property (point) 'mh-data))
1035         (function (get-text-property (point) 'mh-callback))
1036         (buffer-read-only nil)
1037         (folder mh-show-folder-buffer))
1038     (flet ((mm-handle-set-external-undisplayer
1039             (handle function)
1040             (mh-handle-set-external-undisplayer folder handle function)))
1041       (when (and function (eolp))
1042         (backward-char))
1043       (unwind-protect (and function (funcall function data))
1044         (set-buffer-modified-p nil)))))
1045
1046 (defun mh-push-button (event)
1047   "Click MIME button for EVENT.
1048
1049 If the MIME part is visible then it is removed. Otherwise the
1050 part is displayed. This function is called when the mouse is used
1051 to click the MIME button."
1052   (interactive "e")
1053   (mh-do-at-event-location event
1054     (let ((folder mh-show-folder-buffer)
1055           (mm-inline-media-tests mh-mm-inline-media-tests)
1056           (data (get-text-property (point) 'mh-data))
1057           (function (get-text-property (point) 'mh-callback)))
1058       (flet ((mm-handle-set-external-undisplayer (handle func)
1059                (mh-handle-set-external-undisplayer folder handle func)))
1060         (and function (funcall function data))))))
1061
1062 (defun mh-handle-set-external-undisplayer (folder handle function)
1063   "Replacement for `mm-handle-set-external-undisplayer'.
1064
1065 This is only called in recent versions of Gnus. The MIME handles
1066 are stored in data structures corresponding to MH-E folder buffer
1067 FOLDER instead of in Gnus (as in the original). The MIME part,
1068 HANDLE is associated with the undisplayer FUNCTION."
1069   (if (mh-mm-keep-viewer-alive-p handle)
1070       (let ((new-handle (copy-sequence handle)))
1071         (mm-handle-set-undisplayer new-handle function)
1072         (mm-handle-set-undisplayer handle nil)
1073         (save-excursion
1074           (set-buffer folder)
1075           (push new-handle (mh-mime-handles (mh-buffer-data)))))
1076     (mm-handle-set-undisplayer handle function)))
1077
1078 (defun mh-mime-security-press-button (handle)
1079   "Callback from security button for part HANDLE."
1080   (if (mh-mm-handle-multipart-ctl-parameter handle 'gnus-info)
1081       (mh-mime-security-show-details handle)
1082     (let ((region (mh-mm-handle-multipart-ctl-parameter handle 'mh-region))
1083           point)
1084       (setq point (point))
1085       (goto-char (car region))
1086       (delete-region (car region) (cdr region))
1087       (with-current-buffer (mh-mm-handle-multipart-ctl-parameter handle 'buffer)
1088         (let* ((mm-verify-option 'known)
1089                (mm-decrypt-option 'known)
1090                (new (mh-mm-possibly-verify-or-decrypt (cdr handle) handle)))
1091           (unless (eq new (cdr handle))
1092             (mh-mm-destroy-parts (cdr handle))
1093             (setcdr handle new))))
1094       (mh-mime-display-security handle)
1095       (goto-char point))))
1096
1097 ;; I rewrote the security part because Gnus doesn't seem to ever minimize
1098 ;; the button. That is once the mime-security button is pressed there seems
1099 ;; to be no way of getting rid of the inserted text.
1100 (defun mh-mime-security-show-details (handle)
1101   "Toggle display of detailed security info for HANDLE."
1102   (let ((details (mh-mm-handle-multipart-ctl-parameter handle 'gnus-details)))
1103     (when details
1104       (let ((mh-mime-security-button-pressed
1105              (not (get-text-property (point) 'mh-button-pressed)))
1106             (mh-mime-security-button-line-format
1107              (get-text-property (point) 'mh-line-format)))
1108         (forward-char -1)
1109         (while (eq (get-text-property (point) 'mh-line-format)
1110                    mh-mime-security-button-line-format)
1111           (forward-char -1))
1112         (forward-char)
1113         (save-restriction
1114           (narrow-to-region (point) (point))
1115           (mh-insert-mime-security-button handle))
1116         (delete-region
1117          (point)
1118          (or (text-property-not-all
1119               (point) (point-max)
1120               'mh-line-format mh-mime-security-button-line-format)
1121              (point-max)))
1122         (forward-line -1)))))
1123
1124 \f
1125
1126 ;;; Miscellaneous Article Washing
1127
1128 ;;;###mh-autoload
1129 (defun mh-add-missing-mime-version-header ()
1130   "Some mail programs don't put a MIME-Version header.
1131 I have seen this only in spam, so maybe we shouldn't fix
1132 this ;-)"
1133   (save-excursion
1134     (goto-char (point-min))
1135     (re-search-forward "\n\n" nil t)
1136     (save-restriction
1137       (narrow-to-region (point-min) (point))
1138       (when (and (message-fetch-field "content-type")
1139                  (not (message-fetch-field "mime-version")))
1140         (goto-char (point-min))
1141         (insert "MIME-Version: 1.0\n")))))
1142
1143 ;;;###mh-autoload
1144 (defun mh-display-smileys ()
1145   "Display smileys."
1146   (when (and mh-graphical-smileys-flag (mh-small-show-buffer-p))
1147     (mh-funcall-if-exists smiley-region (point-min) (point-max))))
1148
1149 ;;;###mh-autoload
1150 (defun mh-display-emphasis ()
1151   "Display graphical emphasis."
1152   (when (and mh-graphical-emphasis-flag (mh-small-show-buffer-p))
1153     (flet ((article-goto-body ()))      ; shadow this function to do nothing
1154       (save-excursion
1155         (goto-char (point-min))
1156         (article-emphasize)))))
1157
1158 (defun mh-small-show-buffer-p ()
1159   "Check if show buffer is small.
1160 This is used to decide if smileys and graphical emphasis should be
1161 displayed."
1162   (let ((max nil))
1163     (when (and (boundp 'font-lock-maximum-size) font-lock-maximum-size)
1164       (cond ((numberp font-lock-maximum-size)
1165              (setq max font-lock-maximum-size))
1166             ((listp font-lock-maximum-size)
1167              (setq max (cdr (or (assoc 'mh-show-mode font-lock-maximum-size)
1168                                 (assoc t font-lock-maximum-size)))))))
1169     (or (not (numberp max)) (>= (/ max 8) (buffer-size)))))
1170
1171 \f
1172
1173 ;;; MH-Letter Commands
1174
1175 ;; MH-E commands are alphabetical; specific support routines follow command.
1176
1177 ;;;###mh-autoload
1178 (defun mh-compose-forward (&optional description folder range)
1179   "Add tag to forward a message.
1180
1181 You are prompted for a content DESCRIPTION, the name of the
1182 FOLDER in which the messages to forward are located, and a RANGE
1183 of messages, which defaults to the current message in that
1184 folder. Check the documentation of `mh-interactive-range' to see
1185 how RANGE is read in interactive use.
1186
1187 The option `mh-compose-insertion' controls what type of tags are inserted."
1188   (interactive
1189    (let* ((description
1190            (mml-minibuffer-read-description))
1191           (folder
1192            (mh-prompt-for-folder "Message from"
1193                                  mh-sent-from-folder nil))
1194           (default
1195             (if (and (equal folder mh-sent-from-folder)
1196                      (numberp mh-sent-from-msg))
1197                 mh-sent-from-msg
1198               (nth 0 (mh-translate-range folder "cur"))))
1199           (range
1200            (mh-read-range "Forward" folder
1201                           (or (and default
1202                                    (number-to-string default))
1203                               t)
1204                           t t)))
1205      (list description folder range)))
1206   (let ((messages (mapconcat 'identity (mh-list-to-string range) " ")))
1207     (dolist (message (mh-translate-range folder messages))
1208       (if (equal mh-compose-insertion 'mml)
1209           (mh-mml-forward-message description folder (format "%s" message))
1210         (mh-mh-forward-message description folder (format "%s" message))))))
1211
1212 ;;;###mh-autoload
1213 (defun mh-mml-forward-message (description folder message)
1214   "Forward a message as attachment.
1215
1216 The function will prompt the user for a DESCRIPTION, a FOLDER and
1217 MESSAGE number."
1218   (let ((msg (if (and (equal message "") (numberp mh-sent-from-msg))
1219                  mh-sent-from-msg
1220                (string-to-number message))))
1221     (cond ((integerp msg)
1222            (if (string= "" description)
1223                ;; Rationale: mml-attach-file constructs a malformed composition
1224                ;; if the description string is empty.  This fixes SF #625168.
1225                (mml-attach-file (format "%s%s/%d"
1226                                         mh-user-path (substring folder 1) msg)
1227                                 "message/rfc822")
1228              (mml-attach-file (format "%s%s/%d"
1229                                       mh-user-path (substring folder 1) msg)
1230                               "message/rfc822"
1231                               description)))
1232           (t (error "The message number, %s, is not a integer" msg)))))
1233
1234 (defun mh-mh-forward-message (&optional description folder messages)
1235   "Add tag to forward a message.
1236 You are prompted for a content DESCRIPTION, the name of the
1237 FOLDER in which the messages to forward are located, and the
1238 MESSAGES' numbers.
1239
1240 See also \\[mh-mh-to-mime]."
1241   (interactive (list
1242                 (mml-minibuffer-read-description)
1243                 (mh-prompt-for-folder "Message from" mh-sent-from-folder nil)
1244                 (read-string (concat "Messages"
1245                                      (if (numberp mh-sent-from-msg)
1246                                          (format " (default %d): "
1247                                                  mh-sent-from-msg)
1248                                        ": ")))))
1249   (beginning-of-line)
1250   (insert "#forw [")
1251   (and description
1252        (not (string= description ""))
1253        (insert description))
1254   (insert "]")
1255   (and folder
1256        (not (string= folder ""))
1257        (insert " " folder))
1258   (if (and messages
1259            (not (string= messages "")))
1260       (let ((start (point)))
1261         (insert " " messages)
1262         (subst-char-in-region start (point) ?, ? ))
1263     (if (numberp mh-sent-from-msg)
1264         (insert " " (int-to-string mh-sent-from-msg))))
1265   (insert "\n"))
1266
1267 ;;;###mh-autoload
1268 (defun mh-compose-insertion (&optional inline)
1269   "Add tag to include a file such as an image or sound.
1270
1271 You are prompted for the filename containing the object, the
1272 media type if it cannot be determined automatically, and a
1273 content description. If you're using MH-style directives, you
1274 will also be prompted for additional attributes.
1275
1276 The option `mh-compose-insertion' controls what type of tags are
1277 inserted. Optional argument INLINE means make it an inline
1278 attachment."
1279   (interactive "P")
1280   (if (equal mh-compose-insertion 'mml)
1281       (if inline
1282           (mh-mml-attach-file "inline")
1283         (mh-mml-attach-file))
1284     (call-interactively 'mh-mh-attach-file)))
1285
1286 (defun mh-mml-attach-file (&optional disposition)
1287   "Add a tag to insert a MIME message part from a file.
1288
1289 You are prompted for the filename containing the object, the
1290 media type if it cannot be determined automatically, a content
1291 description and the DISPOSITION of the attachment.
1292
1293 This is basically `mml-attach-file' from Gnus, modified such that a prefix
1294 argument yields an \"inline\" disposition and Content-Type is determined
1295 automatically."
1296   (let* ((file (mml-minibuffer-read-file "Attach file: "))
1297          (type (mh-minibuffer-read-type file))
1298          (description (mml-minibuffer-read-description))
1299          (dispos (or disposition
1300                      (mh-mml-minibuffer-read-disposition type))))
1301     (mml-insert-empty-tag 'part 'type type 'filename file
1302                           'disposition dispos 'description description)))
1303
1304 (defun mh-mh-attach-file (filename type description attributes)
1305   "Add a tag to insert a MIME message part from a file.
1306 You are prompted for the FILENAME containing the object, the
1307 media TYPE if it cannot be determined automatically, and a
1308 content DESCRIPTION. In addition, you are also prompted for
1309 additional ATTRIBUTES.
1310
1311 See also \\[mh-mh-to-mime]."
1312   (interactive (let ((filename (mml-minibuffer-read-file "Attach file: ")))
1313                  (list
1314                   filename
1315                   (mh-minibuffer-read-type filename)
1316                   (mml-minibuffer-read-description)
1317                   (read-string "Attributes: "
1318                                (concat "name=\""
1319                                        (file-name-nondirectory filename)
1320                                        "\"")))))
1321   (mh-mh-compose-type filename type description attributes))
1322
1323 (defun mh-mh-compose-type (filename type
1324                                      &optional description attributes comment)
1325   "Insert an MH-style directive to insert a file.
1326 The file specified by FILENAME is encoded as TYPE. An optional
1327 DESCRIPTION is used as the Content-Description field, optional
1328 set of ATTRIBUTES and an optional COMMENT can also be included."
1329   (beginning-of-line)
1330   (insert "#" type)
1331   (and attributes
1332        (insert "; " attributes))
1333   (and comment
1334        (insert " (" comment ")"))
1335   (insert " [")
1336   (and description
1337        (insert description))
1338   (insert "] " (expand-file-name filename))
1339   (insert "\n"))
1340
1341 ;;;###mh-autoload
1342 (defun mh-mh-compose-anon-ftp (host filename type description)
1343   "Add tag to include anonymous ftp reference to a file.
1344
1345 You can have your message initiate an \"ftp\" transfer when the
1346 recipient reads the message. You are prompted for the remote HOST
1347 and FILENAME, the media TYPE, and the content DESCRIPTION.
1348
1349 See also \\[mh-mh-to-mime]."
1350   (interactive (list
1351                 (read-string "Remote host: ")
1352                 (read-string "Remote filename: ")
1353                 (mh-minibuffer-read-type "DUMMY-FILENAME")
1354                 (mml-minibuffer-read-description)))
1355   (mh-mh-compose-external-type "anon-ftp" host filename
1356                                type description))
1357
1358 ;;;###mh-autoload
1359 (defun mh-mh-compose-external-compressed-tar (host filename description)
1360   "Add tag to include anonymous ftp reference to a compressed tar file.
1361
1362 In addition to retrieving the file via anonymous \"ftp\" as per
1363 the command \\[mh-mh-compose-anon-ftp], the file will also be
1364 uncompressed and untarred. You are prompted for the remote HOST
1365 and FILENAME and the content DESCRIPTION.
1366
1367 See also \\[mh-mh-to-mime]."
1368   (interactive (list
1369                 (read-string "Remote host: ")
1370                 (read-string "Remote filename: ")
1371                 (mml-minibuffer-read-description)))
1372   (mh-mh-compose-external-type "anon-ftp" host filename
1373                                "application/octet-stream"
1374                                description
1375                                "type=tar; conversions=x-compress"
1376                                "mode=image"))
1377
1378 ;; RFC 2045 - Multipurpose Internet Mail Extensions (MIME) Part One:
1379 ;;            Format of Internet Message Bodies.
1380 ;; RFC 2046 - Multipurpose Internet Mail Extensions (MIME) Part Two:
1381 ;;            Media Types.
1382 ;; RFC 2049 - Multipurpose Internet Mail Extensions (MIME) Part Five:
1383 ;;            Conformance Criteria and Examples.
1384 ;; RFC 2017 - Definition of the URL MIME External-Body Access-Type
1385 ;; RFC 1738 - Uniform Resource Locators (URL)
1386 (defvar mh-access-types
1387   '(("anon-ftp")        ; RFC2046 Anonymous File Transfer Protocol
1388     ("file")            ; RFC1738 Host-specific file names
1389     ("ftp")             ; RFC2046 File Transfer Protocol
1390     ("gopher")          ; RFC1738 The Gopher Protocol
1391     ("http")            ; RFC1738 Hypertext Transfer Protocol
1392     ("local-file")      ; RFC2046 Local file access
1393     ("mail-server")     ; RFC2046 mail-server Electronic mail address
1394     ("mailto")          ; RFC1738 Electronic mail address
1395     ("news")            ; RFC1738 Usenet news
1396     ("nntp")            ; RFC1738 Usenet news using NNTP access
1397     ("propspero")       ; RFC1738 Prospero Directory Service
1398     ("telnet")          ; RFC1738 Telnet
1399     ("tftp")            ; RFC2046 Trivial File Transfer Protocol
1400     ("url")             ; RFC2017 URL scheme MIME access-type Protocol
1401     ("wais"))           ; RFC1738 Wide Area Information Servers
1402   "Valid MIME access-type values.")
1403
1404 ;;;###mh-autoload
1405 (defun mh-mh-compose-external-type (access-type host filename type
1406                                                 &optional description
1407                                                 attributes parameters
1408                                                 comment)
1409   "Add tag to refer to a remote file.
1410
1411 This command is a general utility for referencing external files.
1412 In fact, all of the other commands that insert directives to
1413 access external files call this command. You are prompted for the
1414 ACCESS-TYPE, remote HOST and FILENAME, and content TYPE. If you
1415 provide a prefix argument, you are also prompted for a content
1416 DESCRIPTION, ATTRIBUTES, PARAMETERS, and a COMMENT.
1417
1418 See also \\[mh-mh-to-mime]."
1419   (interactive (list
1420                 (completing-read "Access type: " mh-access-types)
1421                 (read-string "Remote host: ")
1422                 (read-string "Remote filename: ")
1423                 (mh-minibuffer-read-type "DUMMY-FILENAME")
1424                 (if current-prefix-arg (mml-minibuffer-read-description))
1425                 (if current-prefix-arg (read-string "Attributes: "))
1426                 (if current-prefix-arg (read-string "Parameters: "))
1427                 (if current-prefix-arg (read-string "Comment: "))))
1428   (beginning-of-line)
1429   (insert "#@" type)
1430   (and attributes
1431        (insert "; " attributes))
1432   (and comment
1433        (insert " (" comment ") "))
1434   (insert " [")
1435   (and description
1436        (insert description))
1437   (insert "] ")
1438   (insert "access-type=" access-type "; ")
1439   (insert "site=" host)
1440   (insert "; name=" (file-name-nondirectory filename))
1441   (let ((directory (file-name-directory filename)))
1442     (and directory
1443          (insert "; directory=\"" directory "\"")))
1444   (and parameters
1445        (insert "; " parameters))
1446   (insert "\n"))
1447
1448 (defvar mh-mh-to-mime-args nil
1449   "Extra arguments for \\[mh-mh-to-mime] to pass to the \"mhbuild\" command.
1450 The arguments are passed to \"mhbuild\" if \\[mh-mh-to-mime] is
1451 given a prefix argument. Normally default arguments to
1452 \"mhbuild\" are specified in the MH profile.")
1453
1454 ;;;###mh-autoload
1455 (defun mh-mh-to-mime (&optional extra-args)
1456   "Compose MIME message from MH-style directives.
1457
1458 Typically, you send a message with attachments just like any other
1459 message. However, you may take a sneak preview of the MIME encoding if
1460 you wish by running this command.
1461
1462 If you wish to pass additional arguments to \"mhbuild\" (\"mhn\")
1463 to affect how it builds your message, use the option
1464 `mh-mh-to-mime-args'. For example, you can build a consistency
1465 check into the message by setting `mh-mh-to-mime-args' to
1466 \"-check\". The recipient of your message can then run \"mhbuild
1467 -check\" on the message--\"mhbuild\" (\"mhn\") will complain if
1468 the message has been corrupted on the way. This command only
1469 consults this option when given a prefix argument EXTRA-ARGS.
1470
1471 The hook `mh-mh-to-mime-hook' is called after the message has been
1472 formatted.
1473
1474 The effects of this command can be undone by running
1475 \\[mh-mh-to-mime-undo]."
1476   (interactive "*P")
1477   (mh-mh-quote-unescaped-sharp)
1478   (save-buffer)
1479   (message "Running %s..." (if (mh-variant-p 'nmh) "mhbuild" "mhn"))
1480   (cond
1481    ((mh-variant-p 'nmh)
1482     (mh-exec-cmd-error nil
1483                        "mhbuild"
1484                        (if extra-args mh-mh-to-mime-args)
1485                        buffer-file-name))
1486    (t
1487     (mh-exec-cmd-error (format "mhdraft=%s" buffer-file-name)
1488                        "mhn"
1489                        (if extra-args mh-mh-to-mime-args)
1490                        buffer-file-name)))
1491   (revert-buffer t t)
1492   (message "Running %s...done" (if (mh-variant-p 'nmh) "mhbuild" "mhn"))
1493   (run-hooks 'mh-mh-to-mime-hook))
1494
1495 (defun mh-mh-quote-unescaped-sharp ()
1496   "Quote \"#\" characters that haven't been quoted for \"mhbuild\".
1497 If the \"#\" character is present in the first column, but it isn't
1498 part of a MH-style directive then \"mhbuild\" gives an error.
1499 This function will quote all such characters."
1500   (save-excursion
1501     (goto-char (point-min))
1502     (while (re-search-forward "^#" nil t)
1503       (beginning-of-line)
1504       (unless (mh-mh-directive-present-p (point) (mh-line-end-position))
1505         (insert "#"))
1506       (goto-char (mh-line-end-position)))))
1507
1508 ;;;###mh-autoload
1509 (defun mh-mh-to-mime-undo (noconfirm)
1510   "Undo effects of \\[mh-mh-to-mime].
1511
1512 It does this by reverting to a backup file. You are prompted to
1513 confirm this action, but you can avoid the confirmation by adding
1514 a prefix argument NOCONFIRM."
1515   (interactive "*P")
1516   (if (null buffer-file-name)
1517       (error "Buffer does not seem to be associated with any file"))
1518   (let ((backup-strings '("," "#"))
1519         backup-file)
1520     (while (and backup-strings
1521                 (not (file-exists-p
1522                       (setq backup-file
1523                             (concat (file-name-directory buffer-file-name)
1524                                     (car backup-strings)
1525                                     (file-name-nondirectory buffer-file-name)
1526                                     ".orig")))))
1527       (setq backup-strings (cdr backup-strings)))
1528     (or backup-strings
1529         (error "Backup file for %s no longer exists" buffer-file-name))
1530     (or noconfirm
1531         (yes-or-no-p (format "Revert buffer from file %s? "
1532                              backup-file))
1533         (error "Revert not confirmed"))
1534     (let ((buffer-read-only nil))
1535       (erase-buffer)
1536       (insert-file-contents backup-file))
1537     (after-find-file nil)))
1538
1539 ;; Shush compiler.
1540 (eval-when-compile (defvar mh-identity-pgg-default-user-id))
1541
1542 ;;;###mh-autoload
1543 (defun mh-mml-secure-message-encrypt (method)
1544   "Add tag to encrypt the message.
1545
1546 A proper multipart message is created for you when you send the
1547 message. Use the command \\[mh-mml-unsecure-message] to remove
1548 this tag. Use a prefix argument METHOD to be prompted for one of
1549 the possible security methods (see `mh-mml-method-default')."
1550   (interactive (list (mh-mml-query-cryptographic-method)))
1551   (mh-secure-message method "encrypt" mh-identity-pgg-default-user-id))
1552
1553 ;;;###mh-autoload
1554 (defun mh-mml-secure-message-sign (method)
1555   "Add tag to sign the message.
1556
1557 A proper multipart message is created for you when you send the
1558 message. Use the command \\[mh-mml-unsecure-message] to remove
1559 this tag. Use a prefix argument METHOD to be prompted for one of
1560 the possible security methods (see `mh-mml-method-default')."
1561   (interactive (list (mh-mml-query-cryptographic-method)))
1562   (mh-secure-message method "sign" mh-identity-pgg-default-user-id))
1563
1564 ;;;###mh-autoload
1565 (defun mh-mml-secure-message-signencrypt (method)
1566   "Add tag to encrypt and sign the message.
1567
1568 A proper multipart message is created for you when you send the
1569 message. Use the command \\[mh-mml-unsecure-message] to remove
1570 this tag. Use a prefix argument METHOD to be prompted for one of
1571 the possible security methods (see `mh-mml-method-default')."
1572   (interactive (list (mh-mml-query-cryptographic-method)))
1573   (mh-secure-message method "signencrypt" mh-identity-pgg-default-user-id))
1574
1575 (defvar mh-mml-cryptographic-method-history ())
1576
1577 (defun mh-mml-query-cryptographic-method ()
1578   "Read the cryptographic method to use."
1579   (if current-prefix-arg
1580       (let ((def (or (car mh-mml-cryptographic-method-history)
1581                      mh-mml-method-default)))
1582         (completing-read (format "Method (default %s): " def)
1583                          '(("pgp") ("pgpmime") ("smime"))
1584                          nil t nil 'mh-mml-cryptographic-method-history def))
1585     mh-mml-method-default))
1586
1587 (defun mh-secure-message (method mode &optional identity)
1588   "Add tag to encrypt or sign message.
1589
1590 METHOD should be one of: \"pgpmime\", \"pgp\", \"smime\".
1591 MODE should be one of: \"sign\", \"encrypt\", \"signencrypt\", \"none\".
1592 IDENTITY is optionally the default-user-id to use."
1593   (if (not mh-pgp-support-flag)
1594       (error "Your version of Gnus does not support PGP/GPG")
1595     ;; Check the arguments
1596     (let ((valid-methods (list "pgpmime" "pgp" "smime"))
1597           (valid-modes (list "sign" "encrypt" "signencrypt" "none")))
1598       (if (not (member method valid-methods))
1599           (error "Method %s is invalid" method))
1600       (if (not (member mode valid-modes))
1601           (error "Mode %s is invalid" mode))
1602       (mml-unsecure-message)
1603       (if (not (string= mode "none"))
1604         (save-excursion
1605           (goto-char (point-min))
1606           (mh-goto-header-end 1)
1607           (if mh-identity-pgg-default-user-id
1608               (mml-insert-tag 'secure 'method method 'mode mode
1609                               'sender mh-identity-pgg-default-user-id)
1610             (mml-insert-tag 'secure 'method method 'mode mode)))))))
1611
1612 ;;;###mh-autoload
1613 (defun mh-mml-to-mime ()
1614   "Compose MIME message from MML tags.
1615
1616 Typically, you send a message with attachments just like any
1617 other message. However, you may take a sneak preview of the MIME
1618 encoding if you wish by running this command.
1619
1620 This action can be undone by running \\[undo]."
1621   (interactive)
1622   (require 'message)
1623   (when mh-pgp-support-flag ;; This is only needed for PGP
1624     (message-options-set-recipient))
1625   (let ((saved-text (buffer-string))
1626         (buffer (current-buffer))
1627         (modified-flag (buffer-modified-p)))
1628     (condition-case err (mml-to-mime)
1629       (error
1630        (with-current-buffer buffer
1631          (delete-region (point-min) (point-max))
1632          (insert saved-text)
1633          (set-buffer-modified-p modified-flag))
1634        (error (error-message-string err))))))
1635
1636 ;;;###mh-autoload
1637 (defun mh-mml-unsecure-message ()
1638   "Remove any secure message tags."
1639   (interactive)
1640   (if (not mh-pgp-support-flag)
1641       (error "Your version of Gnus does not support PGP/GPG")
1642     (mml-unsecure-message)))
1643
1644 \f
1645
1646 ;;; Support Routines for MH-Letter Commands
1647
1648 ;;;###mh-autoload
1649 (defun mh-mml-tag-present-p ()
1650   "Check if the current buffer has text which may be a MML tag."
1651   (save-excursion
1652     (goto-char (point-min))
1653     (re-search-forward
1654      (concat
1655       "\\(<#\\(mml\\|part\\)\\(.\\|\n\\)*>[ \n\t]*<#/\\(mml\\|part\\)>\\|"
1656       "^<#secure.+>$\\)")
1657      nil t)))
1658
1659 (defvar mh-media-type-regexp
1660   (concat (regexp-opt '("text" "image" "audio" "video" "application"
1661                         "multipart" "message") t)
1662           "/[-.+a-zA-Z0-9]+")
1663   "Regexp matching valid media types used in MIME attachment compositions.")
1664
1665 ;;;###mh-autoload
1666 (defun mh-mh-directive-present-p (&optional begin end)
1667   "Check if the text between BEGIN and END might be a MH-style directive.
1668 The optional argument BEGIN defaults to the beginning of the
1669 buffer, while END defaults to the the end of the buffer."
1670   (unless begin (setq begin (point-min)))
1671   (unless end (setq end (point-max)))
1672   (save-excursion
1673     (block 'search-for-mh-directive
1674       (goto-char begin)
1675       (while (re-search-forward "^#" end t)
1676         (let ((s (buffer-substring-no-properties
1677                   (point) (mh-line-end-position))))
1678           (cond ((equal s ""))
1679                 ((string-match "^forw[ \t\n]+" s)
1680                  (return-from 'search-for-mh-directive t))
1681                 (t (let ((first-token (car (split-string s "[ \t;@]"))))
1682                      (when (and first-token
1683                                 (string-match mh-media-type-regexp
1684                                               first-token))
1685                        (return-from 'search-for-mh-directive t)))))))
1686       nil)))
1687
1688 (defun mh-minibuffer-read-type (filename &optional default)
1689   "Return the content type associated with the given FILENAME.
1690 If the \"file\" command exists and recognizes the given file,
1691 then its value is returned\; otherwise, the user is prompted for
1692 a type (see `mailcap-mime-types').
1693 Optional argument DEFAULT is returned if a type isn't entered."
1694   (mailcap-parse-mimetypes)
1695   (let* ((default (or default
1696                       (mm-default-file-encoding filename)
1697                       "application/octet-stream"))
1698          (probed-type (mh-file-mime-type filename))
1699          (type (or (and (not (equal probed-type "application/octet-stream"))
1700                         probed-type)
1701                    (completing-read
1702                     (format "Content type (default %s): " default)
1703                     (mapcar 'list (mailcap-mime-types))))))
1704     (if (not (equal type ""))
1705         type
1706       default)))
1707
1708 ;;;###mh-autoload
1709 (defun mh-file-mime-type (filename)
1710   "Return MIME type of FILENAME from file command.
1711 Returns nil if file command not on system."
1712   (cond
1713    ((not (mh-have-file-command))
1714     nil)                                ;no file command, exit now
1715    ((not (and (file-exists-p filename)
1716               (file-readable-p filename)))
1717     nil)                               ;no file or not readable, ditto
1718    (t
1719     (save-excursion
1720       (let ((tmp-buffer (get-buffer-create mh-temp-buffer)))
1721         (set-buffer tmp-buffer)
1722         (unwind-protect
1723             (progn
1724               (call-process "file" nil '(t nil) nil "-b" "-i"
1725                             (expand-file-name filename))
1726               (goto-char (point-min))
1727               (if (not (re-search-forward mh-media-type-regexp nil t))
1728                   nil
1729                 (mh-file-mime-type-substitute (match-string 0) filename)))
1730           (kill-buffer tmp-buffer)))))))
1731
1732 (defvar mh-file-mime-type-substitutions
1733   '(("application/msword" "\.xls" "application/ms-excel")
1734     ("application/msword" "\.ppt" "application/ms-powerpoint")
1735     ("text/plain" "\.vcf" "text/x-vcard")
1736     ("text/rtf" "\.rtf" "application/rtf")
1737     ("application/x-zip" "\.sxc" "application/vnd.sun.xml.calc")
1738     ("application/x-zip" "\.sxd" "application/vnd.sun.xml.draw")
1739     ("application/x-zip" "\.sxi" "application/vnd.sun.xml.impress")
1740     ("application/x-zip" "\.sxw" "application/vnd.sun.xml.writer")
1741     ("application/x-zip" "\.odg" "application/vnd.oasis.opendocument.graphics")
1742     ("application/x-zip" "\.odi" "application/vnd.oasis.opendocument.image")
1743     ("application/x-zip" "\.odp"
1744      "application/vnd.oasis.opendocument.presentation")
1745     ("application/x-zip" "\.ods"
1746      "application/vnd.oasis.opendocument.spreadsheet")
1747     ("application/x-zip" "\.odt" "application/vnd.oasis.opendocument.text"))
1748   "Substitutions to make for Content-Type returned from file command.
1749 The first element is the Content-Type returned by the file command.
1750 The second element is a regexp matching the file name, usually the
1751 extension.
1752 The third element is the Content-Type to replace with.")
1753
1754 (defun mh-file-mime-type-substitute (content-type filename)
1755   "Return possibly changed CONTENT-TYPE on the FILENAME.
1756 Substitutions are made from the `mh-file-mime-type-substitutions'
1757 variable."
1758   (let ((subst mh-file-mime-type-substitutions)
1759         (type) (match) (answer content-type)
1760         (case-fold-search t))
1761     (while subst
1762       (setq type (car (car subst))
1763             match (elt (car subst) 1))
1764       (if (and (string-equal content-type type)
1765                (string-match match filename))
1766           (setq answer (elt (car subst) 2)
1767                 subst nil)
1768         (setq subst (cdr subst))))
1769     answer))
1770
1771 (defvar mh-have-file-command 'undefined
1772   "Cached value of function `mh-have-file-command'.
1773 Do not reference this variable directly as it might not have been
1774 initialized. Always use the command `mh-have-file-command'.")
1775
1776 ;;;###mh-autoload
1777 (defun mh-have-file-command ()
1778   "Return t if 'file' command is on the system.
1779 'file -i' is used to get MIME type of composition insertion."
1780   (when (eq mh-have-file-command 'undefined)
1781     (setq mh-have-file-command
1782           (and (fboundp 'executable-find)
1783                (executable-find "file") ; file command exists
1784                                         ;   and accepts -i and -b args.
1785                (zerop (call-process "file" nil nil nil "-i" "-b"
1786                                     (expand-file-name "inc" mh-progs))))))
1787   mh-have-file-command)
1788
1789 \f
1790
1791 ;;; MIME Cleanup
1792
1793 ;;;###mh-autoload
1794 (defun mh-mime-cleanup ()
1795   "Free the decoded MIME parts."
1796   (let ((mime-data (gethash (current-buffer) mh-globals-hash)))
1797     ;; This is for Emacs, what about XEmacs?
1798     (mh-funcall-if-exists remove-images (point-min) (point-max))
1799     (when mime-data
1800       (mh-mm-destroy-parts (mh-mime-handles mime-data))
1801       (remhash (current-buffer) mh-globals-hash))))
1802
1803 ;;;###mh-autoload
1804 (defun mh-destroy-postponed-handles ()
1805   "Free MIME data for externally displayed MIME parts."
1806   (let ((mime-data (mh-buffer-data)))
1807     (when mime-data
1808       (mh-mm-destroy-parts (mh-mime-handles mime-data)))
1809     (remhash (current-buffer) mh-globals-hash)))
1810
1811 (provide 'mh-mime)
1812
1813 ;; Local Variables:
1814 ;; indent-tabs-mode: nil
1815 ;; sentence-end-double-space: nil
1816 ;; End:
1817
1818 ;; arch-tag: 0dd36518-1b64-4a84-8f4e-59f422d3f002
1819 ;;; mh-mime.el ends here