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

   1 ;;; mh-mime.el --- MH-E support for composing MIME messages
   2
   3 ;; Copyright (C) 1993, 1995, 2001, 2002 Free Software Foundation, Inc.
   4
   5 ;; Author: Bill Wohler <wohler@newt.com>
   6 ;; Maintainer: Bill Wohler <wohler@newt.com>
   7 ;; Keywords: mail
   8 ;; See: mh-e.el
   9
  10 ;; This file is part of GNU Emacs.
  11
  12 ;; GNU Emacs is free software; you can redistribute it and/or modify
  13 ;; it under the terms of the GNU General Public License as published by
  14 ;; the Free Software Foundation; either version 2, or (at your option)
  15 ;; any later version.
  16
  17 ;; GNU Emacs is distributed in the hope that it will be useful,
  18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  20 ;; GNU General Public License for more details.
  21
  22 ;; You should have received a copy of the GNU General Public License
  23 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  24 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  25 ;; Boston, MA 02111-1307, USA.
  26
  27 ;;; Commentary:
  28
  29 ;; Internal support for MH-E package.
  30 ;; Support for generating an mhn composition file.
  31 ;; MIME is supported only by MH 6.8 or later.
  32
  33 ;;; Change Log:
  34
  35 ;; $Id: mh-mime.el,v 1.90 2002/11/22 20:00:48 satyaki Exp $
  36
  37 ;;; Code:
  38
  39 (require 'cl)
  40 (require 'mh-comp)
  41 (require 'mh-utils)
  42 (load "mm-decode" t t)                  ; Non-fatal dependency
  43 (load "mm-uu" t t)                      ; Non-fatal dependency
  44 (load "mailcap" t t)                    ; Non-fatal dependency
  45 (load "smiley" t t)                     ; Non-fatal dependency
  46 (require 'gnus-util)
  47
  48 (autoload 'gnus-article-goto-header "gnus-art")
  49 (autoload 'article-emphasize "gnus-art")
  50 (autoload 'gnus-get-buffer-create "gnus")
  51 (autoload 'gnus-eval-format "gnus-spec")
  52 (autoload 'widget-convert-button "wid-edit")
  53 (autoload 'message-options-set-recipient "message")
  54 (autoload 'mml-secure-message-sign-pgpmime "mml-sec")
  55 (autoload 'mml-secure-message-encrypt-pgpmime "mml-sec")
  56 (autoload 'mml-minibuffer-read-file "mml")
  57 (autoload 'mml-minibuffer-read-description "mml")
  58 (autoload 'mml-insert-empty-tag "mml")
  59 (autoload 'mml-to-mime "mml")
  60 (autoload 'mml-attach-file "mml")
  61
  62 ;;; Hooks
  63 (defcustom mh-edit-mhn-hook nil
  64   "Invoked on the formatted letter by \\<mh-letter-mode-map>\\[mh-edit-mhn]."
  65   :type 'hook
  66   :group 'mh-hook)
  67
  68 ;; Keeps assorted MIME data
  69 (defstruct (mh-buffer-data (:conc-name mh-mime-)
  70                            (:constructor mh-make-buffer-data))
  71   ;; Structure to keep track of MIME handles on a per buffer basis.
  72   (handles ())                          ; List of MIME handles
  73   (handles-cache (make-hash-table))     ; Cache to avoid multiple decodes of
  74                                         ; nested messages
  75   (parts-count 0)                       ; The button number is generated from
  76                                         ; this number
  77   (part-index-hash (make-hash-table)))  ; Avoid incrementing the part number
  78                                         ; for nested messages
  79
  80 ;;; This has to be a macro, since we do: (setf (mh-buffer-data) ...)
  81 (defmacro mh-buffer-data ()
  82   "Convenience macro to get the MIME data structures of the current buffer."
  83   `(gethash (current-buffer) mh-globals-hash))
  84
  85 (defun mh-compose-insertion (&optional inline)
  86   "Add a directive to insert a MIME part from a file, using mhn or gnus.
  87 If the variable `mh-compose-insertion' is set to 'mhn, then that will be used.
  88 If it is set to 'gnus, then that will be used instead.
  89 Optional argument INLINE means make it an inline attachment."
  90   (interactive "P")
  91   (if (equal mh-compose-insertion 'gnus)
  92       (if inline
  93           (mh-mml-attach-file "inline")
  94         (mh-mml-attach-file))
  95     (call-interactively 'mh-mhn-compose-insertion)))
  96
  97 (defun mh-compose-forward (&optional description folder message)
  98   "Add a MIME directive to forward a message, using mhn or gnus.
  99 If the variable `mh-compose-insertion' is set to 'mhn, then that will be used.
 100 If it is set to 'gnus, then that will be used instead.
 101 Optional argument DESCRIPTION is a description of the attachment.
 102 Optional argument FOLDER is the folder from which the forwarded message should
 103 come.
 104 Optional argument MESSAGE is the message to forward.
 105 If any of the optional arguments are absent, they are prompted for."
 106   (interactive (list
 107                 (read-string "Forw Content-description: ")
 108                 (mh-prompt-for-folder "Message from" mh-sent-from-folder nil)
 109                 (read-string (format "Messages%s: "
 110                                      (if mh-sent-from-msg
 111                                          (format " [%d]" mh-sent-from-msg)
 112                                        "")))))
 113   (if (equal mh-compose-insertion 'gnus)
 114       (mh-mml-forward-message description folder message)
 115     (mh-mhn-compose-forw description folder message)))
 116
 117 ;; To do:
 118 ;; paragraph code should not fill # lines if MIME enabled.
 119 ;; implement mh-auto-edit-mhn (if non-nil, \\[mh-send-letter]
 120 ;;      invokes mh-edit-mhn automatically before sending.)
 121 ;;      actually, instead of mh-auto-edit-mhn,
 122 ;;      should read automhnproc from profile
 123 ;; MIME option to mh-forward
 124 ;; command to move to content-description insertion point
 125
 126 (defvar mh-mhn-args nil
 127   "Extra arguments to have \\[mh-edit-mhn] pass to the \"mhn\" command.
 128 The arguments are passed to mhn if \\[mh-edit-mhn] is given a
 129 prefix argument.  Normally default arguments to mhn are specified in the
 130 MH profile.")
 131
 132 (defvar mh-media-type-regexp
 133   (concat (regexp-opt '("text" "image" "audio" "video" "application"
 134                         "multipart" "message") t)
 135           "/[-.+a-zA-Z0-9]+")
 136   "Regexp matching valid media types used in MIME attachment compositions.")
 137
 138 ;; Just defvar the variable to avoid compiler warning... This doesn't bind
 139 ;; the variable, so things should work exactly as before.
 140 (defvar mh-have-file-command)
 141
 142 (defun mh-have-file-command ()
 143   "Return t if 'file' command is on the system.
 144 'file -i' is used to get MIME type of composition insertion."
 145   (when (not (boundp 'mh-have-file-command))
 146     (load "executable" t t)     ; executable-find not autoloaded in emacs20
 147     (setq mh-have-file-command
 148           (and (fboundp 'executable-find)
 149                (executable-find "file") ; file command exists
 150                                         ;   and accepts -i and -b args.
 151                (zerop (call-process "file" nil nil nil "-i" "-b"
 152                                     (expand-file-name "inc" mh-progs))))))
 153   mh-have-file-command)
 154
 155 (defvar mh-file-mime-type-substitutions
 156   '(("application/msword" "\.xls" "application/ms-excel")
 157     ("application/msword" "\.ppt" "application/ms-powerpoint"))
 158   "Substitutions to make for Content-Type returned from file command.
 159 The first element is the Content-Type returned by the file command.
 160 The second element is a regexp matching the file name, usually the extension.
 161 The third element is the Content-Type to replace with.")
 162
 163 (defun mh-file-mime-type-substitute (content-type filename)
 164   "Return possibly changed CONTENT-TYPE on the FILENAME.
 165 Substitutions are made from the `mh-file-mime-type-substitutions' variable."
 166   (let ((subst mh-file-mime-type-substitutions)
 167         (type) (match) (answer content-type)
 168         (case-fold-search t))
 169     (while subst
 170       (setq type (car (car subst))
 171             match (elt (car subst) 1))
 172       (if (and (string-equal content-type type)
 173                (string-match match filename))
 174           (setq answer (elt (car subst) 2)
 175                 subst nil)
 176         (setq subst (cdr subst))))
 177     answer))
 178
 179 (defun mh-file-mime-type (filename)
 180   "Return MIME type of FILENAME from file command.
 181 Returns nil if file command not on system."
 182   (cond
 183    ((not (mh-have-file-command))
 184     nil)                                ;No file command, exit now.
 185    ((not (and (file-exists-p filename)(file-readable-p filename)))
 186     nil)
 187    (t
 188     (save-excursion
 189       (let ((tmp-buffer (get-buffer-create mh-temp-buffer)))
 190         (set-buffer tmp-buffer)
 191         (unwind-protect
 192             (progn
 193               (call-process "file" nil '(t nil) nil "-b" "-i"
 194                             (expand-file-name filename))
 195               (goto-char (point-min))
 196               (if (not (re-search-forward mh-media-type-regexp nil t))
 197                   nil
 198                 (mh-file-mime-type-substitute (match-string 0) filename)))
 199           (kill-buffer tmp-buffer)))))))
 200
 201 ;;; This is needed for Emacs20 which doesn't have mailcap-mime-types.
 202 (defvar mh-mime-content-types
 203   '(("application/mac-binhex40") ("application/msword")
 204     ("application/octet-stream") ("application/pdf") ("application/pgp-keys")
 205     ("application/pgp-signature") ("application/pkcs7-signature")
 206     ("application/postscript") ("application/rtf")
 207     ("application/vnd.ms-excel") ("application/vnd.ms-powerpoint")
 208     ("application/vnd.ms-project") ("application/vnd.ms-tnef")
 209     ("application/wordperfect5.1") ("application/wordperfect6.0")
 210     ("application/zip")
 211
 212     ("audio/basic") ("audio/mpeg")
 213
 214     ("image/gif") ("image/jpeg") ("image/png")
 215
 216     ("message/delivery-status")
 217     ("message/external-body") ("message/partial") ("message/rfc822")
 218
 219     ("text/enriched") ("text/html") ("text/plain") ("text/rfc822-headers")
 220     ("text/richtext") ("text/xml")
 221
 222     ("video/mpeg") ("video/quicktime"))
 223   "Legal MIME content types.
 224 See documentation for \\[mh-edit-mhn].")
 225
 226 (defun mh-mhn-compose-insertion (filename type description attributes)
 227   "Add a directive to insert a MIME message part from a file.
 228 This is the typical way to insert non-text parts in a message.
 229
 230 Arguments are FILENAME, which tells where to find the file, TYPE, the MIME
 231 content type, DESCRIPTION, a line of text for the Content-Description field.
 232 ATTRIBUTES is a comma separated list of name=value pairs that is appended to
 233 the Content-Type field of the attachment.
 234
 235 See also \\[mh-edit-mhn]."
 236   (interactive (let ((filename (read-file-name "Insert contents of: ")))
 237                  (list
 238                   filename
 239                   (or (mh-file-mime-type filename)
 240                       (completing-read "Content-Type: "
 241                                        (if (fboundp 'mailcap-mime-types)
 242                                            (mapcar 'list (mailcap-mime-types))
 243                                          mh-mime-content-types)))
 244                   (read-string "Content-Description: ")
 245                   (read-string "Content-Attributes: "
 246                                (concat "name=\""
 247                                        (file-name-nondirectory filename)
 248                                        "\"")))))
 249   (mh-mhn-compose-type filename type description attributes ))
 250
 251 (defun mh-mhn-compose-type (filename type
 252                             &optional description attributes comment)
 253   "Insert a mhn directive to insert a file.
 254
 255 The file specified by FILENAME is encoded as TYPE. An optional DESCRIPTION is
 256 used as the Content-Description field, optional set of ATTRIBUTES and an
 257 optional COMMENT can also be included."
 258   (setq mh-mhn-compose-insert-flag t)
 259   (beginning-of-line)
 260   (insert "#" type)
 261   (and attributes
 262        (insert "; " attributes))
 263   (and comment
 264        (insert " (" comment ")"))
 265   (insert " [")
 266   (and description
 267        (insert description))
 268   (insert "] " (expand-file-name filename))
 269   (insert "\n"))
 270
 271
 272 (defun mh-mhn-compose-anon-ftp (host filename type description)
 273   "Add a directive for a MIME anonymous ftp external body part.
 274 This directive tells MH to include a reference to a message/external-body part
 275 retrievable by anonymous FTP.
 276
 277 Arguments are HOST and FILENAME, which tell where to find the file, TYPE, the
 278 MIME content type, and DESCRIPTION, a line of text for the Content-description
 279 header.
 280
 281 See also \\[mh-edit-mhn]."
 282   (interactive (list
 283                 (read-string "Remote host: ")
 284                 (read-string "Remote filename: ")
 285                 (completing-read "External Content-Type: "
 286                                  (if (fboundp 'mailcap-mime-types)
 287                                      (mapcar 'list (mailcap-mime-types))
 288                                    mh-mime-content-types))
 289                 (read-string "External Content-Description: ")))
 290   (mh-mhn-compose-external-type "anon-ftp" host filename
 291                                 type description))
 292
 293 (defun mh-mhn-compose-external-compressed-tar (host filename description)
 294   "Add a directive to include a MIME reference to a compressed tar file.
 295 The file should be available via anonymous ftp. This directive tells MH to
 296 include a reference to a message/external-body part.
 297
 298 Arguments are HOST and FILENAME, which tell where to find the file, and
 299 DESCRIPTION, a line of text for the Content-description header.
 300
 301 See also \\[mh-edit-mhn]."
 302   (interactive (list
 303                 (read-string "Remote host: ")
 304                 (read-string "Remote filename: ")
 305                 (read-string "Tar file Content-description: ")))
 306   (mh-mhn-compose-external-type "anon-ftp" host filename
 307                                 "application/octet-stream"
 308                                 description
 309                                 "type=tar; conversions=x-compress"
 310                                 "mode=image"))
 311
 312
 313 (defun mh-mhn-compose-external-type (access-type host filename type
 314                                      &optional description
 315                                      attributes extra-params comment)
 316   "Add a directive to include a MIME reference to a remote file.
 317 The file should be available via anonymous ftp. This directive tells MH to
 318 include a reference to a message/external-body part.
 319
 320 Arguments are ACCESS-TYPE, HOST and FILENAME, which tell where to find the
 321 file and TYPE which is the MIME Content-Type. Optional arguments include
 322 DESCRIPTION, a line of text for the Content-description header, ATTRIBUTES,
 323 EXTRA-PARAMS, and COMMENT.
 324
 325 See also \\[mh-edit-mhn]."
 326   (setq mh-mhn-compose-insert-flag t)
 327   (beginning-of-line)
 328   (insert "#@" type)
 329   (and attributes
 330        (insert "; " attributes))
 331   (and comment
 332        (insert " (" comment ") "))
 333   (insert " [")
 334   (and description
 335        (insert description))
 336   (insert "] ")
 337   (insert "access-type=" access-type "; ")
 338   (insert "site=" host)
 339   (insert "; name=" (file-name-nondirectory filename))
 340   (insert "; directory=\"" (file-name-directory filename) "\"")
 341   (and extra-params
 342        (insert "; " extra-params))
 343   (insert "\n"))
 344
 345 (defun mh-mhn-compose-forw (&optional description folder messages)
 346   "Add a forw directive to this message, to forward a message with MIME.
 347 This directive tells MH to include the named messages in this one.
 348
 349 Arguments are DESCRIPTION, a line of text for the Content-description header,
 350 and FOLDER and MESSAGES, which name the message(s) to be forwarded.
 351
 352 See also \\[mh-edit-mhn]."
 353   (interactive (list
 354                 (read-string "Forw Content-description: ")
 355                 (mh-prompt-for-folder "Message from" mh-sent-from-folder nil)
 356                 (read-string (format "Messages%s: "
 357                                      (if mh-sent-from-msg
 358                                          (format " [%d]" mh-sent-from-msg)
 359                                        "")))))
 360   (setq mh-mhn-compose-insert-flag t)
 361   (beginning-of-line)
 362   (insert "#forw [")
 363   (and description
 364        (not (string= description ""))
 365        (insert description))
 366   (insert "]")
 367   (and folder
 368        (not (string= folder ""))
 369        (insert " " folder))
 370   (if (and messages
 371            (not (string= messages "")))
 372       (let ((start (point)))
 373         (insert " " messages)
 374         (subst-char-in-region start (point) ?, ? ))
 375     (if mh-sent-from-msg
 376         (insert " " (int-to-string mh-sent-from-msg))))
 377   (insert "\n"))
 378
 379 (defun mh-edit-mhn (&optional extra-args)
 380   "Format the current draft for MIME, expanding any mhn directives.
 381
 382 Process the current draft with the mhn program, which, using directives
 383 already inserted in the draft, fills in all the MIME components and header
 384 fields.
 385
 386 This step should be done last just before sending the message.
 387
 388 The `\\[mh-revert-mhn-edit]' command undoes this command. The arguments in the
 389 list `mh-mhn-args' are passed to mhn if this function is passed an optional
 390 prefix argument EXTRA-ARGS.
 391
 392 For assistance with creating mhn directives to insert various types of
 393 components in a message, see \\[mh-mhn-compose-insertion] (generic insertion
 394 from a file), \\[mh-mhn-compose-anon-ftp] (external reference to file via
 395 anonymous ftp), \\[mh-mhn-compose-external-compressed-tar] \ \(reference to
 396 compressed tar file via anonymous ftp), and \\[mh-mhn-compose-forw] (forward
 397 message). If these helper functions are used, `mh-edit-mhn' is run
 398 automatically when the draft is sent.
 399
 400 The value of `mh-edit-mhn-hook' is a list of functions to be called, with no
 401 arguments, after performing the conversion.
 402
 403 The mhn program is part of MH version 6.8 or later."
 404   (interactive "*P")
 405   (save-buffer)
 406   (message "mhn editing...")
 407   (cond
 408    (mh-nmh-flag
 409     (mh-exec-cmd-error nil
 410                        "mhbuild" (if extra-args mh-mhn-args) buffer-file-name))
 411    (t
 412     (mh-exec-cmd-error (format "mhdraft=%s" buffer-file-name)
 413                        "mhn" (if extra-args mh-mhn-args) buffer-file-name)))
 414   (setq mh-mhn-compose-insert-flag nil)
 415   (revert-buffer t t)
 416   (message "mhn editing...done")
 417   (run-hooks 'mh-edit-mhn-hook))
 418
 419 (defun mh-revert-mhn-edit (noconfirm)
 420   "Undo the effect of \\[mh-edit-mhn] by reverting to the backup file.
 421 Optional non-nil argument NOCONFIRM means don't ask for confirmation."
 422   (interactive "*P")
 423   (if (null buffer-file-name)
 424       (error "Buffer does not seem to be associated with any file"))
 425   (let ((backup-strings '("," "#"))
 426         backup-file)
 427     (while (and backup-strings
 428                 (not (file-exists-p
 429                       (setq backup-file
 430                             (concat (file-name-directory buffer-file-name)
 431                                     (car backup-strings)
 432                                     (file-name-nondirectory buffer-file-name)
 433                                     ".orig")))))
 434       (setq backup-strings (cdr backup-strings)))
 435     (or backup-strings
 436         (error "Backup file for %s no longer exists!" buffer-file-name))
 437     (or noconfirm
 438         (yes-or-no-p (format "Revert buffer from file %s? "
 439                              backup-file))
 440         (error "Revert not confirmed"))
 441     (let ((buffer-read-only nil))
 442       (erase-buffer)
 443       (insert-file-contents backup-file))
 444     (after-find-file nil)))
 445
 446 \f
 447
 448 ;;; MIME composition functions
 449
 450 (defun mh-mml-to-mime ()
 451   "Compose MIME message from mml directives."
 452   (interactive)
 453   (when mh-gnus-pgp-support-flag ;; This is only needed for PGP
 454     (message-options-set-recipient))
 455   (mml-to-mime)
 456   (setq mh-mml-compose-insert-flag nil))
 457
 458 (defun mh-mml-forward-message (description folder message)
 459   "Forward a message as attachment.
 460 The function will prompt the user for a DESCRIPTION, a FOLDER and MESSAGE
 461 number."
 462   (let ((msg (if (equal message "")
 463                  mh-sent-from-msg
 464                (car (read-from-string message)))))
 465     (cond ((integerp msg)
 466            (if (string= "" description)
 467                ;; Rationale: mml-attach-file constructs a malformed composition
 468                ;; if the description string is empty.  This fixes SF #625168.
 469                (mml-attach-file (format "%s%s/%d"
 470                                         mh-user-path (substring folder 1) msg)
 471                                 "message/rfc822")
 472              (mml-attach-file (format "%s%s/%d"
 473                                       mh-user-path (substring folder 1) msg)
 474                               "message/rfc822"
 475                               description))
 476            (setq mh-mml-compose-insert-flag t))
 477           (t (error "The message number, %s is not a integer!" msg)))))
 478
 479 (defun mh-mml-attach-file (&optional disposition)
 480   "Attach a file to the outgoing MIME message.
 481 The file is not inserted or encoded until you send the message with
 482 `\\[mh-send-letter]'.
 483 Message disposition is \"inline\" or \"attachment\" and is prompted for if
 484 DISPOSITION is nil.
 485
 486 This is basically `mml-attach-file' from gnus, modified such that a prefix
 487 argument yields an `inline' disposition and Content-Type is determined
 488 automatically."
 489   (let* ((file (mml-minibuffer-read-file "Attach file: "))
 490          (type (or (mh-file-mime-type file)
 491                    (completing-read "Content-Type: "
 492                                     (if (fboundp 'mailcap-mime-types)
 493                                         (mapcar 'list (mailcap-mime-types))
 494                                       mh-mime-content-types))))
 495          (description (mml-minibuffer-read-description))
 496          (dispos (or disposition
 497                      (completing-read "Disposition: [attachment] "
 498                                       '(("attachment")("inline"))
 499                                       nil t nil nil
 500                                       "attachment"))))
 501     (mml-insert-empty-tag 'part 'type type 'filename file
 502                           'disposition dispos 'description description)
 503     (setq mh-mml-compose-insert-flag t)))
 504
 505 (defun mh-mml-secure-message-sign-pgpmime ()
 506   "Add directive to encrypt/sign the entire message."
 507   (interactive)
 508   (if (not mh-gnus-pgp-support-flag)
 509       (error "Sorry.  Your version of gnus does not support PGP/GPG")
 510     (mml-secure-message-sign-pgpmime)
 511     (setq mh-mml-compose-insert-flag t)))
 512
 513 (defun mh-mml-secure-message-encrypt-pgpmime (&optional dontsign)
 514   "Add directive to encrypt and sign the entire message.
 515 If called with a prefix argument DONTSIGN, only encrypt (do NOT sign)."
 516   (interactive "P")
 517   (if (not mh-gnus-pgp-support-flag)
 518       (error "Sorry.  Your version of gnus does not support PGP/GPG")
 519     (mml-secure-message-encrypt-pgpmime dontsign)
 520     (setq mh-mml-compose-insert-flag t)))
 521
 522 \f
 523
 524 ;;; MIME decoding
 525
 526 (defcustom mh-graphical-smileys-flag t
 527   "*Non-nil means graphical smileys are displayed.
 528 Non-nil means that small graphics will be used in the show buffer instead of
 529 patterns like :-), ;-) etc. The setting only has effect if
 530 `mh-decode-mime-flag' is non-nil."
 531   :type 'boolean
 532   :group 'mh-buffer)
 533
 534 (defcustom mh-graphical-emphasis-flag t
 535   "*Non-nil means graphical emphasis is displayed.
 536 Non-nil means that _underline_ will be underlined, *bold* will appear in bold,
 537 /italic/ will appear in italic etc. See `gnus-emphasis-alist' for the whole
 538 list. The setting only has effect if `mh-decode-mime-flag' is non-nil."
 539   :type 'boolean
 540   :group 'mh-buffer)
 541
 542 ;; Small image definition
 543 (defcustom mh-max-inline-image-width nil
 544   "*Maximum inline image width if Content-Disposition is not present.
 545 If nil, image will be displayed if its width is smaller than the width of the
 546 window."
 547   :type '(choice (const nil) integer)
 548   :group 'mh-buffer)
 549
 550 (defcustom mh-max-inline-image-height nil
 551   "*Maximum inline image height if Content-Disposition is not present.
 552 If nil, image will be displayed if its height is smaller than the height of
 553 the window."
 554   :type '(choice (const nil) integer)
 555   :group 'mh-buffer)
 556
 557 (defcustom mh-display-buttons-for-inline-parts-flag nil
 558   "*Non-nil means display buttons for all inline MIME parts.
 559 If non-nil, buttons are displayed for all MIME parts. Inline parts start off
 560 in displayed state but they can be hidden by clicking the button. If nil no
 561 buttons are shown for inline parts."
 562   :type 'boolean
 563   :group 'mh-buffer)
 564
 565 (defcustom mh-mime-save-parts-default-directory t
 566   "Default directory to use for `mh-mime-save-parts'.
 567 If nil, prompt and set for next time the command is used during same session.
 568 If t, prompt always"
 569   :type '(choice (const :tag "Prompt the first time" nil)
 570                  (const :tag "Prompt always" t)
 571                  directory)
 572   :group 'mh)
 573
 574 (defmacro mh-defun-compat (function arg-list &rest body)
 575   "This is a macro to define functions which are not defined.
 576 It is used for Gnus utility functions which were added recently. If FUNCTION
 577 is not defined then it is defined to have argument list, ARG-LIST and body,
 578 BODY."
 579   (let ((defined-p (fboundp function)))
 580     (unless defined-p
 581       `(defun ,function ,arg-list ,@body))))
 582
 583 ;; Copy of original function from gnus-util.el
 584 (mh-defun-compat gnus-local-map-property (map)
 585   "Return a list suitable for a text property list specifying keymap MAP."
 586   (cond (mh-xemacs-flag (list 'keymap map))
 587         ((>= emacs-major-version 21) (list 'keymap map))
 588         (t (list 'local-map map))))
 589
 590 ;; Copy of original function from mm-decode.el
 591 (mh-defun-compat mm-merge-handles (handles1 handles2)
 592   (append (if (listp (car handles1)) handles1 (list handles1))
 593           (if (listp (car handles2)) handles2 (list handles2))))
 594
 595 ;; Copy of function from mm-decode.el
 596 (mh-defun-compat mm-set-handle-multipart-parameter (handle parameter value)
 597   ;; HANDLE could be a CTL.
 598   (if handle
 599       (put-text-property 0 (length (car handle)) parameter value
 600                          (car handle))))
 601
 602 ;; Copy of original macro is in mm-decode.el
 603 (mh-defun-compat mm-handle-multipart-ctl-parameter (handle parameter)
 604   (get-text-property 0 parameter (car handle)))
 605
 606 ;; Copy of original function in mm-decode.el
 607 (mh-defun-compat mm-readable-p (handle)
 608   "Say whether the content of HANDLE is readable."
 609   (and (< (with-current-buffer (mm-handle-buffer handle)
 610             (buffer-size)) 10000)
 611        (mm-with-unibyte-buffer
 612          (mm-insert-part handle)
 613          (and (eq (mm-body-7-or-8) '7bit)
 614               (not (mm-long-lines-p 76))))))
 615
 616 ;; Copy of original function in mm-bodies.el
 617 (mh-defun-compat mm-long-lines-p (length)
 618   "Say whether any of the lines in the buffer is longer than LINES."
 619   (save-excursion
 620     (goto-char (point-min))
 621     (end-of-line)
 622     (while (and (not (eobp))
 623                 (not (> (current-column) length)))
 624       (forward-line 1)
 625       (end-of-line))
 626     (and (> (current-column) length)
 627          (current-column))))
 628
 629 (mh-defun-compat mm-keep-viewer-alive-p (handle)
 630   ;; Released Gnus doesn't keep handles associated with externally displayed
 631   ;; MIME parts. So this will always return nil.
 632   nil)
 633
 634 (mh-defun-compat mm-destroy-parts (list)
 635   "Older emacs don't have this function."
 636   nil)
 637
 638 ;;; This is mm-save-part from gnus 5.10 since that function in emacs21.2 is
 639 ;;; buggy (the args to read-file-name are incorrect). When all supported
 640 ;;; versions of Emacs come with at least Gnus 5.10, we can delete this
 641 ;;; function and rename calls to mh-mm-save-part to mm-save-part.
 642 (defun mh-mm-save-part (handle)
 643   "Write HANDLE to a file."
 644   (let ((name (mail-content-type-get (mm-handle-type handle) 'name))
 645         (filename (mail-content-type-get
 646                    (mm-handle-disposition handle) 'filename))
 647         file)
 648     (when filename
 649       (setq filename (file-name-nondirectory filename)))
 650     (setq file (read-file-name "Save MIME part to: "
 651                                (or mm-default-directory
 652                                    default-directory)
 653                                nil nil (or filename name "")))
 654     (setq mm-default-directory (file-name-directory file))
 655     (and (or (not (file-exists-p file))
 656              (yes-or-no-p (format "File %s already exists; overwrite? "
 657                                   file)))
 658          (mm-save-part-to-file handle file))))
 659
 660 \f
 661
 662 ;;; MIME cleanup
 663
 664 (defun mh-mime-cleanup ()
 665   "Free the decoded MIME parts."
 666   (let ((mime-data (gethash (current-buffer) mh-globals-hash)))
 667     ;; This is for Emacs, what about XEmacs?
 668     (cond ((fboundp 'remove-images)
 669            (remove-images (point-min) (point-max))))
 670     (when mime-data
 671       (mm-destroy-parts (mh-mime-handles mime-data))
 672       (remhash (current-buffer) mh-globals-hash))))
 673
 674 (defun mh-destroy-postponed-handles ()
 675   "Free MIME data for externally displayed mime parts."
 676   (let ((mime-data (mh-buffer-data)))
 677     (when mime-data
 678       (mm-destroy-parts (mh-mime-handles mime-data)))
 679     (remhash (current-buffer) mh-globals-hash)))
 680
 681 (defun mh-handle-set-external-undisplayer (folder handle function)
 682   "Replacement for `mm-handle-set-external-undisplayer'.
 683 This is only called in recent versions of Gnus. The MIME handles are stored
 684 in data structures corresponding to MH-E folder buffer FOLDER instead of in
 685 Gnus (as in the original). The MIME part, HANDLE is associated with the
 686 undisplayer FUNCTION."
 687   (if (mm-keep-viewer-alive-p handle)
 688       (let ((new-handle (copy-sequence handle)))
 689         (mm-handle-set-undisplayer new-handle function)
 690         (mm-handle-set-undisplayer handle nil)
 691         (save-excursion
 692           (set-buffer folder)
 693           (push new-handle (mh-mime-handles (mh-buffer-data)))))
 694     (mm-handle-set-undisplayer handle function)))
 695
 696 \f
 697
 698 ;;; MIME transformations
 699
 700 (defun mh-add-missing-mime-version-header ()
 701   "Some mail programs don't put a MIME-Version header.
 702 I have seen this only in spam, so maybe we shouldn't fix this ;-)"
 703   (save-excursion
 704     (goto-char (point-min))
 705     (when (and (message-fetch-field "content-type")
 706                (not (message-fetch-field "mime-version")))
 707       (when (search-forward "\n\n" nil t)
 708         (forward-line -1)
 709         (insert "MIME-Version: 1.0\n")))))
 710
 711 (defun mh-display-smileys ()
 712   "Function to display smileys."
 713   (when (and mh-graphical-smileys-flag (fboundp 'smiley-region))
 714     (smiley-region (point-min) (point-max))))
 715
 716 (defun mh-display-emphasis ()
 717   "Function to display graphical emphasis."
 718   (when mh-graphical-emphasis-flag
 719     (flet ((article-goto-body ())) ; shadow this function to do nothing
 720       (save-excursion
 721         (goto-char (point-min))
 722         (article-emphasize)))))
 723
 724 ;; Copied from gnus-art.el (should be checked for other cool things that can
 725 ;; be added to the buttons)
 726 (defvar mh-mime-button-commands
 727   '((mh-press-button "\r" "Toggle Display")))
 728 (defvar mh-mime-button-map
 729   (let ((map (make-sparse-keymap)))
 730     (unless (>= (string-to-number emacs-version) 21)
 731       ;; XEmacs doesn't care.
 732       (set-keymap-parent map mh-show-mode-map))
 733     (define-key map [mouse-2] 'mh-push-button)
 734     (dolist (c mh-mime-button-commands)
 735       (define-key map (cadr c) (car c)))
 736     map))
 737 (defvar mh-mime-button-line-format-alist
 738   '((?T long-type ?s)
 739     (?d description ?s)
 740     (?p index ?s)
 741     (?e dots ?s)))
 742 (defvar mh-mime-button-line-format "%{%([%p. %d%T]%)%}%e\n")
 743 (defvar mh-mime-security-button-pressed nil)
 744 (defvar mh-mime-security-button-line-format "%{%([[%t:%i]%D]%)%}\n")
 745 (defvar mh-mime-security-button-end-line-format "%{%([[End of %t]%D]%)%}\n")
 746 (defvar mh-mime-security-button-line-format-alist
 747   '((?t type ?s)
 748     (?i info ?s)
 749     (?d details ?s)
 750     (?D pressed-details ?s)))
 751 (defvar mh-mime-security-button-map
 752   (let ((map (make-sparse-keymap)))
 753     (unless (>= (string-to-number emacs-version) 21)
 754       (set-keymap-parent map mh-show-mode-map))
 755     (define-key map "\r" 'mh-press-button)
 756     (define-key map [mouse-2] 'mh-push-button)
 757     map))
 758
 759 (defvar mh-mime-save-parts-directory nil
 760   "Default to use for `mh-mime-save-parts-default-directory'.
 761 Set from last use.")
 762
 763 (defun mh-mime-save-parts (arg)
 764   "Store the MIME parts of the current message.
 765 If ARG, prompt for directory, else use that specified by the variable
 766 `mh-mime-save-parts-default-directory'. These directories may be superseded by
 767 mh_profile directives, since this function calls on mhstore or mhn to do the
 768 actual storing."
 769   (interactive "P")
 770   (let ((msg (if (eq major-mode 'mh-show-mode)
 771                  (mh-show-buffer-message-number)
 772                (mh-get-msg-num t)))
 773         (folder (if (eq major-mode 'mh-show-mode)
 774                     mh-show-folder-buffer
 775                   mh-current-folder))
 776         (command (if mh-nmh-flag "mhstore" "mhn"))
 777         (directory
 778          (cond
 779           ((and (or arg
 780                     (equal nil mh-mime-save-parts-default-directory)
 781                     (equal t mh-mime-save-parts-default-directory))
 782                 (not mh-mime-save-parts-directory))
 783            (read-file-name "Store in what directory? " nil nil t nil))
 784           ((and (or arg
 785                     (equal t mh-mime-save-parts-default-directory))
 786                 mh-mime-save-parts-directory)
 787            (read-file-name (format
 788                             "Store in what directory? [%s] "
 789                             mh-mime-save-parts-directory)
 790                            "" mh-mime-save-parts-directory t ""))
 791           ((stringp mh-mime-save-parts-default-directory)
 792            mh-mime-save-parts-default-directory)
 793           (t
 794            mh-mime-save-parts-directory))))
 795     (if (and (equal directory "") mh-mime-save-parts-directory)
 796         (setq directory mh-mime-save-parts-directory))
 797     (if (not (file-directory-p directory))
 798         (message "No directory specified.")
 799       (if (equal nil mh-mime-save-parts-default-directory)
 800           (setq mh-mime-save-parts-directory directory))
 801       (save-excursion
 802         (set-buffer (get-buffer-create " *mh-store*"))
 803         (cd directory)
 804         (setq mh-mime-save-parts-directory directory)
 805         (erase-buffer)
 806         (apply 'call-process
 807                (expand-file-name command mh-progs) nil t nil
 808                (mh-list-to-string (list folder msg "-auto")))
 809         (if (> (buffer-size) 0)
 810             (save-window-excursion
 811               (switch-to-buffer-other-window " *mh-store*")
 812               (sit-for 3)))))))
 813
 814 ;; Avoid errors if gnus-sum isn't loaded yet...
 815 (defvar gnus-newsgroup-charset nil)
 816 (defvar gnus-newsgroup-name nil)
 817
 818 (defun mh-mime-display (&optional pre-dissected-handles)
 819   "Display (and possibly decode) MIME handles.
 820 Optional argument, PRE-DISSECTED-HANDLES is a list of MIME handles. If
 821 present they are displayed otherwise the buffer is parsed and then
 822 displayed."
 823   (let ((handles ())
 824         (folder mh-show-folder-buffer))
 825     (flet ((mm-handle-set-external-undisplayer (handle function)
 826              (mh-handle-set-external-undisplayer folder handle function)))
 827       ;; If needed dissect the current buffer
 828       (if pre-dissected-handles
 829         (setq handles pre-dissected-handles)
 830         (setq handles (or (mm-dissect-buffer nil) (mm-uu-dissect)))
 831         (setf (mh-mime-handles (mh-buffer-data))
 832               (mm-merge-handles handles (mh-mime-handles (mh-buffer-data)))))
 833
 834       (when (and handles (or (not (stringp (car handles))) (cdr handles)))
 835         ;; Goto start of message body
 836         (goto-char (point-min))
 837         (or (search-forward "\n\n" nil t) (goto-char (point-max)))
 838
 839         ;; Delete the body
 840         (delete-region (point) (point-max))
 841
 842         ;; Display the MIME handles
 843         (mh-mime-display-part handles)))))
 844
 845 (defun mh-mime-display-part (handle)
 846   "Decides the viewer to call based on the type of HANDLE."
 847   (cond ((null handle) nil)
 848         ((not (stringp (car handle)))
 849          (mh-mime-display-single handle))
 850         ((equal (car handle) "multipart/alternative")
 851          (mh-mime-display-alternative (cdr handle)))
 852         ((and mh-gnus-pgp-support-flag
 853               (or (equal (car handle) "multipart/signed")
 854                   (equal (car handle) "multipart/encrypted")))
 855          (mh-mime-display-security handle))
 856         (t (mh-mime-display-mixed (cdr handle)))))
 857
 858 (defun mh-mime-display-alternative (handles)
 859   "Choose among the alternatives, HANDLES the part that will be displayed.
 860 If no part is preferred then all the parts are displayed."
 861   (let ((preferred (mm-preferred-alternative handles)))
 862     (cond ((and preferred (stringp (car preferred)))
 863            (mh-mime-display-part preferred))
 864           (preferred
 865            (save-restriction
 866              (narrow-to-region (point) (if (eobp) (point) (1+ (point))))
 867              (or (mm-display-part preferred) (mm-display-part preferred))
 868              (goto-char (point-max))))
 869           (t (mh-mime-display-mixed handles)))))
 870
 871 (defun mh-mime-display-mixed (handles)
 872   "Display the list of MIME parts, HANDLES recursively."
 873   (mapcar #'mh-mime-display-part handles))
 874
 875 (defun mh-mime-part-index (handle)
 876   "Generate the button number for MIME part, HANDLE.
 877 Notice that a hash table is used to display the same number when buttons need
 878 to be displayed multiple times (for instance when nested messages are
 879 opened)."
 880   (or (gethash handle (mh-mime-part-index-hash (mh-buffer-data)))
 881       (setf (gethash handle (mh-mime-part-index-hash (mh-buffer-data)))
 882             (incf (mh-mime-parts-count (mh-buffer-data))))))
 883
 884 ;;; Avoid compiler warnings for XEmacs functions...
 885 (eval-when (compile)
 886  (loop for function in '(glyph-width window-pixel-width
 887                          glyph-height window-pixel-height)
 888        do (or (fboundp function) (defalias function 'ignore))))
 889
 890 (defun mh-small-image-p (handle)
 891   "Decide whether HANDLE is a \"small\" image that can be displayed inline.
 892 This is only useful if a Content-Disposition header is not present."
 893   (let ((media-test (caddr (assoc (car (mm-handle-type handle))
 894                                   mh-mm-inline-media-tests)))
 895         (mm-inline-large-images t))
 896     (and media-test
 897          (equal (mm-handle-media-supertype handle) "image")
 898          (funcall media-test handle) ; Since mm-inline-large-images is T,
 899                                      ; this only tells us if the image is
 900                                      ; something that emacs can display
 901          (let* ((image (mm-get-image handle)))
 902            (cond ((fboundp 'glyph-width)
 903                   ;; XEmacs -- totally untested, copied from gnus
 904                   (and (< (glyph-width image)
 905                           (or mh-max-inline-image-width
 906                               (window-pixel-width)))
 907                        (< (glyph-height image)
 908                           (or mh-max-inline-image-height
 909                               (window-pixel-height)))))
 910                  ((fboundp 'image-size)
 911                   ;; Emacs21 -- copied from gnus
 912                   (let ((size (image-size image)))
 913                     (and (< (cdr size)
 914                             (or mh-max-inline-image-height
 915                                 (1- (window-height))))
 916                          (< (car size)
 917                             (or mh-max-inline-image-width (window-width))))))
 918                  (t
 919                   ;; Can't show image inline
 920                   nil))))))
 921
 922 (defun mh-mime-display-single (handle)
 923   "Display a leaf node, HANDLE in the MIME tree."
 924   (let* ((type (mm-handle-media-type handle))
 925          (small-image-flag (mh-small-image-p handle))
 926          (attachmentp (equal (car (mm-handle-disposition handle))
 927                              "attachment"))
 928          (inlinep (and (equal (car (mm-handle-disposition handle)) "inline")
 929                        (mm-inlinable-p handle)
 930                        (mm-inlined-p handle)))
 931          (displayp (or inlinep                   ; display if inline
 932                        (and (not attachmentp)    ; if it is not an attachment
 933                             (or small-image-flag ; display if small image
 934                                                  ; or if user wants inline.
 935                                 (and (not (equal
 936                                            (mm-handle-media-supertype handle)
 937                                            "image"))
 938                                      (mm-inlinable-p handle)
 939                                      (mm-inlined-p handle)))))))
 940     (save-restriction
 941       (narrow-to-region (point) (if (eobp) (point) (1+ (point))))
 942       (cond ((and mh-gnus-pgp-support-flag
 943                   (equal type "application/pgp-signature"))
 944              nil) ; skip signatures as they are already handled...
 945             ((not displayp)
 946              (insert "\n")
 947              (mh-insert-mime-button handle (mh-mime-part-index handle) nil))
 948             ((and displayp (not mh-display-buttons-for-inline-parts-flag))
 949              (or (mm-display-part handle) (mm-display-part handle)))
 950             ((and displayp mh-display-buttons-for-inline-parts-flag)
 951              (insert "\n")
 952              (mh-insert-mime-button handle (mh-mime-part-index handle) nil)
 953              (forward-line -1)
 954              (mh-mm-display-part handle)))
 955       (goto-char (point-max)))))
 956
 957 (defun mh-insert-mime-button (handle index displayed)
 958   "Insert MIME button for HANDLE.
 959 INDEX is the part number that will be DISPLAYED. It is also used by commands
 960 like \"K v\" which operate on individual MIME parts."
 961   ;; The button could be displayed by a previous decode. In that case
 962   ;; undisplay it if we need a hidden button.
 963   (when (and (mm-handle-displayed-p handle) (not displayed))
 964     (mm-display-part handle))
 965   (let ((name (or (mail-content-type-get (mm-handle-type handle) 'name)
 966                   (mail-content-type-get (mm-handle-disposition handle)
 967                                          'filename)
 968                   (mail-content-type-get (mm-handle-type handle) 'url)
 969                   ""))
 970         (type (mm-handle-media-type handle))
 971         (description (mail-decode-encoded-word-string
 972                       (or (mm-handle-description handle) "")))
 973         (dots (if (or displayed (mm-handle-displayed-p handle)) "   " "..."))
 974         long-type begin end)
 975     (if (string-match ".*/" name) (setq name (substring name (match-end 0))))
 976     (setq long-type (concat type (and (not (equal name ""))
 977                                       (concat "; " name))))
 978     (unless (equal description "")
 979       (setq long-type (concat " --- " long-type)))
 980     (unless (bolp) (insert "\n"))
 981     (setq begin (point))
 982     (gnus-eval-format
 983      mh-mime-button-line-format mh-mime-button-line-format-alist
 984      `(,@(gnus-local-map-property mh-mime-button-map)
 985        mh-callback mh-mm-display-part
 986        mh-part ,index
 987        mh-data ,handle))
 988     (setq end (point))
 989     (widget-convert-button
 990      'link begin end
 991      :mime-handle handle
 992      :action 'mh-widget-press-button
 993      :button-keymap mh-mime-button-map
 994      :help-echo
 995      "Mouse-2 click or press RET (in show buffer) to toggle display")))
 996
 997 ;; There is a bug in Gnus inline image display due to which an extra line
 998 ;; gets inserted every time it is viewed. To work around that problem we are
 999 ;; using an extra property 'mh-region to remember the region that is added
1000 ;; when the button is clicked. The region is then deleted to make sure that
1001 ;; no extra lines get inserted.
1002 (defun mh-mm-display-part (handle)
1003   "Toggle display of button for MIME part, HANDLE."
1004   (beginning-of-line)
1005   (let ((id (get-text-property (point) 'mh-part))
1006         (point (point))
1007         (window (selected-window))
1008         (mail-parse-charset 'nil)
1009         (mail-parse-ignored-charsets nil)
1010         region buffer-read-only)
1011     (save-excursion
1012       (unwind-protect
1013           (let ((win (get-buffer-window (current-buffer) t)))
1014             (when win
1015               (select-window win))
1016             (goto-char point)
1017
1018             (if (mm-handle-displayed-p handle)
1019                 ;; This will remove the part.
1020                 (progn
1021                   ;; Delete the button and displayed part (if any)
1022                   (let ((region (get-text-property point 'mh-region)))
1023                     (when region
1024                       (when (fboundp 'remove-images)
1025                         (remove-images (car region) (cdr region))))
1026                     (mm-display-part handle)
1027                     (when region
1028                       (delete-region (car region) (cdr region))))
1029                   ;; Delete button (if it still remains). This happens for
1030                   ;; externally displayed parts where the previous step does
1031                   ;; nothing.
1032                   (unless (eolp)
1033                     (delete-region (point) (progn (forward-line) (point)))))
1034               (save-restriction
1035                 (delete-region (point) (progn (forward-line 1) (point)))
1036                 (narrow-to-region (point) (point))
1037                 ;; Maybe we need another unwind-protect here.
1038                 (when (equal (mm-handle-media-supertype handle) "image")
1039                   (insert "\n"))
1040                 (when (and (not (eq (ignore-errors (mm-display-part handle))
1041                                     'inline))
1042                            (equal (mm-handle-media-supertype handle)
1043                                   "image"))
1044                   (goto-char (point-min))
1045                   (delete-char 1))
1046                 (when (equal (mm-handle-media-supertype handle) "text")
1047                   (when (eq mh-highlight-citation-p 'gnus)
1048                     (mh-gnus-article-highlight-citation))
1049                   (mh-display-smileys)
1050                   (mh-display-emphasis))
1051                 (setq region (cons (progn (goto-char (point-min))
1052                                           (point-marker))
1053                                    (progn (goto-char (point-max))
1054                                           (point-marker)))))))
1055         (when (window-live-p window)
1056           (select-window window))
1057         (goto-char point)
1058         (beginning-of-line)
1059         (mh-insert-mime-button handle id (mm-handle-displayed-p handle))
1060         (goto-char point)
1061         (when region
1062           (add-text-properties (line-beginning-position) (line-end-position)
1063                                `(mh-region ,region)))))))
1064
1065 (defun mh-press-button ()
1066   "Press MIME button.
1067 If the MIME part is visible then it is removed. Otherwise the part is
1068 displayed."
1069   (interactive)
1070   (let ((mm-inline-media-tests mh-mm-inline-media-tests)
1071         (data (get-text-property (point) 'mh-data))
1072         (function (get-text-property (point) 'mh-callback))
1073         (buffer-read-only nil)
1074         (folder mh-show-folder-buffer))
1075     (flet ((mm-handle-set-external-undisplayer (handle function)
1076              (mh-handle-set-external-undisplayer folder handle function)))
1077       (when (and function (eolp))
1078         (backward-char))
1079       (unwind-protect (and function (funcall function data))
1080         (set-buffer-modified-p nil)))))
1081
1082 (defun mh-push-button (event)
1083   "Click MIME button for EVENT.
1084 If the MIME part is visible then it is removed. Otherwise the part is
1085 displayed. This function is called when the mouse is used to click the MIME
1086 button."
1087   (interactive "e")
1088   (set-buffer (window-buffer (posn-window (event-start event))))
1089   (select-window (posn-window (event-start event)))
1090   (let* ((pos (posn-point (event-start event)))
1091          (folder mh-show-folder-buffer)
1092          (mm-inline-media-tests mh-mm-inline-media-tests)
1093          (data (get-text-property pos 'mh-data))
1094          (function (get-text-property pos 'mh-callback))
1095          (buffer-read-only nil))
1096     (flet ((mm-handle-set-external-undisplayer (handle function)
1097              (mh-handle-set-external-undisplayer folder handle function)))
1098       (goto-char pos)
1099       (unwind-protect (and function (funcall function data))
1100         (set-buffer-modified-p nil)))))
1101
1102 (defun mh-mime-save-part ()
1103   "Save MIME part at point."
1104   (interactive)
1105   (let ((data (get-text-property (point) 'mh-data)))
1106     (when data
1107       (let ((mm-default-directory mh-mime-save-parts-directory))
1108         (mh-mm-save-part data)
1109         (setq mh-mime-save-parts-directory mm-default-directory)))))
1110
1111 (defun mh-mime-inline-part ()
1112   "Toggle display of the raw MIME part."
1113   (interactive)
1114   (let* ((buffer-read-only nil)
1115          (data (get-text-property (point) 'mh-data))
1116          (inserted-flag (get-text-property (point) 'mh-mime-inserted))
1117          (displayed-flag (mm-handle-displayed-p data))
1118          (point (point))
1119          start end)
1120     (cond ((and data (not inserted-flag) (not displayed-flag))
1121            (let ((contents (mm-get-part data)))
1122              (add-text-properties (line-beginning-position) (line-end-position)
1123                                   '(mh-mime-inserted t))
1124              (setq start (point-marker))
1125              (forward-line 1)
1126              (mm-insert-inline data contents)
1127              (setq end (point-marker))
1128              (add-text-properties
1129               start (progn (goto-char start) (line-end-position))
1130               `(mh-region (,start . ,end)))))
1131           ((and data (or inserted-flag displayed-flag))
1132            (mh-press-button)
1133            (message "MIME part already inserted")))
1134     (goto-char point)
1135     (set-buffer-modified-p nil)))
1136
1137 (defun mh-widget-press-button (widget el)
1138   "Callback for widget, WIDGET.
1139 Parameter EL is unused."
1140   (goto-char (widget-get widget :from))
1141   (mh-press-button))
1142
1143 (defun mh-mime-display-security (handle)
1144   "Display PGP encrypted/signed message, HANDLE."
1145   (insert "\n")
1146   (save-restriction
1147     (narrow-to-region (point) (point))
1148     (mh-insert-mime-security-button handle)
1149     (mh-mime-display-mixed (cdr handle))
1150     (insert "\n")
1151     (let ((mh-mime-security-button-line-format
1152             mh-mime-security-button-end-line-format))
1153       (mh-insert-mime-security-button handle))
1154     (mm-set-handle-multipart-parameter
1155      handle 'mh-region
1156      (cons (set-marker (make-marker) (point-min))
1157            (set-marker (make-marker) (point-max))))))
1158
1159 ;;; I rewrote the security part because Gnus doesn't seem to ever minimize
1160 ;;; the button. That is once the mime-security button is pressed there seems
1161 ;;; to be no way of getting rid of the inserted text.
1162 (defun mh-mime-security-show-details (handle)
1163   "Toggle display of detailed security info for HANDLE."
1164   (let ((details (mm-handle-multipart-ctl-parameter handle 'gnus-details)))
1165     (when details
1166       (let ((mh-mime-security-button-pressed
1167               (not (get-text-property (point) 'mh-button-pressed)))
1168             (mh-mime-security-button-line-format
1169               (get-text-property (point) 'mh-line-format)))
1170         (forward-char -1)
1171         (while (eq (get-text-property (point) 'mh-line-format)
1172                    mh-mime-security-button-line-format)
1173           (forward-char -1))
1174         (forward-char)
1175         (save-restriction
1176           (narrow-to-region (point) (point))
1177           (mh-insert-mime-security-button handle))
1178         (delete-region
1179          (point)
1180          (or (text-property-not-all
1181               (point) (point-max)
1182               'mh-line-format mh-mime-security-button-line-format)
1183              (point-max)))
1184         (forward-line -1)))))
1185
1186 (defun mh-mime-security-press-button (handle)
1187   "Callback from security button for part HANDLE."
1188   (when (mm-handle-multipart-ctl-parameter handle 'gnus-info)
1189     (mh-mime-security-show-details handle)))
1190
1191 ;; These variables should already be initialized in mm-decode.el if we have a
1192 ;; recent enough Gnus. The defvars are here to avoid compiler warnings.
1193 (defvar mm-verify-function-alist nil)
1194 (defvar mm-decrypt-function-alist nil)
1195
1196 (defvar pressed-details)
1197
1198 (defun mh-insert-mime-security-button (handle)
1199   "Display buttons for PGP message, HANDLE."
1200   (let* ((protocol (mm-handle-multipart-ctl-parameter handle 'protocol))
1201          (crypto-type (or (nth 2 (assoc protocol mm-verify-function-alist))
1202                           (nth 2 (assoc protocol mm-decrypt-function-alist))
1203                           "Unknown"))
1204          (type (concat crypto-type
1205                        (if (equal (car handle) "multipart/signed")
1206                            " Signed" " Encrypted")
1207                        " Part"))
1208          (info (or (mm-handle-multipart-ctl-parameter handle 'gnus-info)
1209                    "Undecided"))
1210          (details (mm-handle-multipart-ctl-parameter handle 'gnus-details))
1211          pressed-details begin end)
1212     (setq details (if details (concat "\n" details) ""))
1213     (setq pressed-details (if mh-mime-security-button-pressed details ""))
1214     (unless (bolp) (insert "\n"))
1215     (setq begin (point))
1216     (gnus-eval-format
1217      mh-mime-security-button-line-format
1218      mh-mime-security-button-line-format-alist
1219      `(,@(gnus-local-map-property mh-mime-security-button-map)
1220        mh-button-pressed ,mh-mime-security-button-pressed
1221        mh-callback mh-mime-security-press-button
1222        mh-line-format ,mh-mime-security-button-line-format
1223        mh-data ,handle))
1224     (setq end (point))
1225     (widget-convert-button 'link begin end
1226                            :mime-handle handle
1227                            :action 'mh-widget-press-button
1228                            :button-keymap mh-mime-security-button-map
1229                            :help-echo "Mouse-2 click or press RET (in show buffer) to see security details.")
1230     (when (equal info "Failed")
1231       (let* ((type (if (equal (car handle) "multipart/signed")
1232                        "verification" "decryption"))
1233              (warning (if (equal type "decryption")
1234                           "(passphrase may be incorrect)" "")))
1235         (message "%s %s failed %s" crypto-type type warning)))))
1236
1237 (defun mh-mm-inline-message (handle)
1238   "Display message, HANDLE.
1239 The function decodes the message and displays it. It avoids decoding the same
1240 message multiple times."
1241   (let ((b (point))
1242         (charset (mail-content-type-get (mm-handle-type handle) 'charset))
1243         (clean-message-header mh-clean-message-header-flag)
1244         (invisible-headers mh-invisible-headers)
1245         (visible-headers mh-visible-headers))
1246     (when (and charset (stringp charset))
1247       (setq charset (intern (downcase charset)))
1248       (when (eq charset 'us-ascii)
1249         (setq charset nil)))
1250     (save-excursion
1251       (save-restriction
1252         (narrow-to-region b b)
1253         (mm-insert-part handle)
1254         (mh-mime-display
1255          (or (gethash handle (mh-mime-handles-cache (mh-buffer-data)))
1256              (setf (gethash handle (mh-mime-handles-cache (mh-buffer-data)))
1257                    (let ((handles (or (mm-dissect-buffer nil)
1258                                       (mm-uu-dissect))))
1259                      (setf (mh-mime-handles (mh-buffer-data))
1260                            (mm-merge-handles
1261                             handles (mh-mime-handles (mh-buffer-data))))
1262                      handles))))
1263
1264         (goto-char (point-min))
1265         (cond (clean-message-header
1266                (mh-clean-msg-header (point-min)
1267                                     invisible-headers
1268                                     visible-headers)
1269                (goto-char (point-min)))
1270               (t
1271                (mh-start-of-uncleaned-message)))
1272         (mh-show-xface)
1273         (mh-show-addr)
1274         ;; The other highlighting types don't need anything special
1275         (when (eq mh-highlight-citation-p 'gnus)
1276           (mh-gnus-article-highlight-citation))
1277         (goto-char (point-min))
1278         (insert "\n------- Forwarded Message\n\n")
1279         (mh-display-smileys)
1280         (mh-display-emphasis)
1281         (mm-handle-set-undisplayer
1282          handle
1283          `(lambda ()
1284             (let (buffer-read-only)
1285               (if (fboundp 'remove-specifier)
1286                   ;; This is only valid on XEmacs.
1287                   (mapcar (lambda (prop)
1288                             (remove-specifier
1289                              (face-property 'default prop) (current-buffer)))
1290                           '(background background-pixmap foreground)))
1291               (delete-region ,(point-min-marker) ,(point-max-marker)))))))))
1292
1293 (provide 'mh-mime)
1294
1295 ;;; Local Variables:
1296 ;;; sentence-end-double-space: nil
1297 ;;; End:
1298
1299 ;;; mh-mime.el ends here