lisp/mh-e/mh-mime.el

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