cgit.sxemacs.org Git - packages/blob - xemacs-packages/vm/lisp/vm-mime.el

   1 ;;; vm-mime.el ---  MIME support functions
   2 ;;
   3 ;; Copyright (C) 1997-2003 Kyle E. Jones
   4 ;; Copyright (C) 2003-2006 Robert Widhopf-Fenk
   5 ;;
   6 ;; This program is free software; you can redistribute it and/or modify
   7 ;; it under the terms of the GNU General Public License as published by
   8 ;; the Free Software Foundation; either version 2 of the License, or
   9 ;; (at your option) any later version.
  10 ;;
  11 ;;; This program is distributed in the hope that it will be useful,
  12 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 ;; GNU General Public License for more details.
  15 ;;
  16 ;; You should have received a copy of the GNU General Public License along
  17 ;; with this program; if not, write to the Free Software Foundation, Inc.,
  18 ;; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
  19
  20 ;;; Code:
  21 (eval-when-compile
  22   (require 'cl))
  23
  24 (defvar enable-multibyte-characters)
  25 (defvar default-enable-multibyte-characters)
  26
  27 (defun vm-mime-error (&rest args)
  28   (signal 'vm-mime-error (list (apply 'format args)))
  29   (error "can't return from vm-mime-error"))
  30
  31 (if (fboundp 'define-error)
  32     (progn
  33       (define-error 'vm-image-too-small "Image too small")
  34       (define-error 'vm-mime-error "MIME error"))
  35   (put 'vm-image-too-small 'error-conditions '(vm-image-too-small error))
  36   (put 'vm-image-too-small 'error-message "Image too small")
  37   (put 'vm-mime-error 'error-conditions '(vm-mime-error error))
  38   (put 'vm-mime-error 'error-message "MIME error"))
  39
  40 ;; A lot of the more complicated MIME character set processing is only
  41 ;; practical under MULE.
  42 (eval-when-compile
  43   (defvar latin-unity-ucs-list))
  44
  45 (defcustom vm-coding-system-priorities nil
  46   "*List of coding systems for VM to use, for outgoing mail, in order of
  47 preference.
  48
  49 If you find that your outgoing mail is being encoded in `iso-2022-jp' and
  50 you'd prefer something more widely used outside of Japan be used instead,
  51 you could load the `latin-unity' and `un-define' libraries under XEmacs
  52 21.4, and intialize this list to something like `(iso-8859-1 iso-8859-15
  53 utf-8)'. ")
  54
  55 (defun vm-get-coding-system-priorities ()
  56   "Return the value of `vm-coding-system-priorities', or a reasonable
  57 default for it if it's nil.  "
  58   (if vm-coding-system-priorities
  59       vm-coding-system-priorities
  60     (let ((res '(iso-8859-1 iso-8859-2 iso-8859-15 iso-8859-16 utf-8)))
  61       (dolist (list-item res)
  62         ;; Assumes iso-8859-1 is always available, which is reasonable.
  63         (unless (coding-system-p (find-coding-system list-item))
  64           (delq list-item res)))
  65       res)))
  66
  67 (defcustom vm-mime-ucs-list nil
  68   "*List of coding systems that can encode all chars emacs knows.")
  69
  70 (defun vm-get-mime-ucs-list ()
  71   "Return the value of `vm-mime-ucs-list', or a reasonable default for it if
  72 it's nil.  This is used instead of `vm-mime-ucs-list' directly in order to
  73 allow runtime checks for optional features like `mule-ucs' or
  74 `latin-unity'.  "
  75   (if vm-mime-ucs-list
  76       vm-mime-ucs-list
  77     (if (featurep 'latin-unity)
  78         latin-unity-ucs-list
  79       (if (coding-system-p (find-coding-system 'utf-8))
  80           '(utf-8 iso-2022-jp ctext escape-quoted)
  81         '(iso-2022-jp ctext escape-quoted)))))
  82
  83 (defun vm-update-mime-charset-maps ()
  84   "Check for the presence of certain Mule coding systems, and add
  85 information about the corresponding MIME character sets to VM's
  86 configuration.  "
  87   ;; Add some extra charsets that may not have been defined onto the end
  88   ;; of vm-mime-mule-charset-to-coding-alist.
  89   (mapcar (lambda (x)
  90             (and (coding-system-p (find-coding-system x))
  91                  ;; Not using vm-string-assoc because of some quoting
  92                  ;; weirdness it's doing.
  93                  (if (not (assoc
  94                            (format "%s" x)
  95                            vm-mime-mule-charset-to-coding-alist))
  96                      (add-to-list 'vm-mime-mule-charset-to-coding-alist
  97                                   (list (format "%s" x) x)))))
  98           '(utf-8 iso-8859-15 iso-8859-14 iso-8859-16
  99             alternativnyj iso-8859-6 iso-8859-7 koi8-c koi8-o koi8-ru koi8-t
 100             koi8-u macintosh windows-1250 windows-1251 windows-1252
 101             windows-1253 windows-1256))
 102
 103   ;; And make sure that the map back from coding-systems is good for
 104   ;; those charsets.
 105   (mapcar (lambda (x)
 106             (or (assoc (car (cdr x)) vm-mime-mule-coding-to-charset-alist)
 107                 (add-to-list 'vm-mime-mule-coding-to-charset-alist
 108                              (list (car (cdr x)) (car x)))))
 109           vm-mime-mule-charset-to-coding-alist)
 110   ;; Whoops, doesn't get picked up for some reason.
 111   (add-to-list 'vm-mime-mule-coding-to-charset-alist
 112                '(iso-8859-1 "iso-8859-1")))
 113
 114 (when vm-xemacs-mule-p
 115   (require 'vm-vars)
 116   (vm-update-mime-charset-maps)
 117   ;; If the user loads Mule-UCS, re-evaluate the MIME charset maps.
 118   (unless (coding-system-p (find-coding-system 'utf-8))
 119     (eval-after-load "un-define" `(vm-update-mime-charset-maps)))
 120   ;; Ditto for latin-unity.
 121   (unless (featurep 'latin-unity)
 122     (eval-after-load "latin-unity" `(vm-update-mime-charset-maps))))
 123
 124 (defun vm-make-layout (&rest plist)
 125   (vector
 126    (plist-get plist 'type)
 127    (plist-get plist 'qtype)
 128    (plist-get plist 'encoding)
 129    (plist-get plist 'id)
 130    (plist-get plist 'description)
 131    (plist-get plist 'disposition)
 132    (plist-get plist 'qdisposition)
 133    (plist-get plist 'header-start)
 134    (plist-get plist 'header-end)
 135    (plist-get plist 'body-start)
 136    (plist-get plist 'body-end)
 137    (plist-get plist 'parts)
 138    (plist-get plist 'cache)
 139    (plist-get plist 'message-symbol)
 140    (plist-get plist 'display-error)
 141    (plist-get plist 'layout-is-converted)
 142    (plist-get plist 'unconverted-layout)))
 143
 144 (defun vm-mm-layout-type (e) (aref e 0))
 145 (defun vm-mm-layout-qtype (e) (aref e 1))
 146 (defun vm-mm-layout-encoding (e) (aref e 2))
 147 (defun vm-mm-layout-id (e) (aref e 3))
 148 (defun vm-mm-layout-description (e) (aref e 4))
 149 (defun vm-mm-layout-disposition (e) (aref e 5))
 150 (defun vm-mm-layout-qdisposition (e) (aref e 6))
 151 (defun vm-mm-layout-header-start (e) (aref e 7))
 152 (defun vm-mm-layout-header-end (e) (aref e 8))
 153 (defun vm-mm-layout-body-start (e) (aref e 9))
 154 (defun vm-mm-layout-body-end (e) (aref e 10))
 155 (defun vm-mm-layout-parts (e) (aref e 11))
 156 (defun vm-mm-layout-cache (e) (aref e 12))
 157 (defun vm-mm-layout-message-symbol (e) (aref e 13))
 158 (defun vm-mm-layout-message (e)
 159   (symbol-value (vm-mm-layout-message-symbol e)))
 160 ;; if display of MIME part fails, error string will be here.
 161 (defun vm-mm-layout-display-error (e) (aref e 14))
 162 (defun vm-mm-layout-is-converted (e) (aref e 15))
 163 (defun vm-mm-layout-unconverted-layout (e) (aref e 16))
 164
 165 (defun vm-set-mm-layout-type (e type) (aset e 0 type))
 166 (defun vm-set-mm-layout-qtype (e type) (aset e 1 type))
 167 (defun vm-set-mm-layout-encoding (e encoding) (aset e 2 encoding))
 168 (defun vm-set-mm-layout-id (e id) (aset e 3 id))
 169 (defun vm-set-mm-layout-description (e des) (aset e 4 des))
 170 (defun vm-set-mm-layout-disposition (e d) (aset e 5 d))
 171 (defun vm-set-mm-layout-qdisposition (e d) (aset e 6 d))
 172 (defun vm-set-mm-layout-header-start (e start) (aset e 7 start))
 173 (defun vm-set-mm-layout-header-end (e start) (aset e 8 start))
 174 (defun vm-set-mm-layout-body-start (e start) (aset e 9 start))
 175 (defun vm-set-mm-layout-body-end (e end) (aset e 10 end))
 176 (defun vm-set-mm-layout-parts (e parts) (aset e 11 parts))
 177 (defun vm-set-mm-layout-cache (e c) (aset e 12 c))
 178 (defun vm-set-mm-layout-display-error (e c) (aset e 14 c))
 179 (defun vm-set-mm-layout-is-converted (e c) (asef e 15 c))
 180 (defun vm-set-mm-layout-unconverted-layout (e layout) (aset e 16 layout))
 181
 182 (defun vm-mime-make-message-symbol (m)
 183   (let ((s (make-symbol "<<m>>")))
 184     (set s m)
 185     s ))
 186
 187 (defun vm-mime-make-cache-symbol ()
 188   (let ((s (make-symbol "<<c>>")))
 189     (set s s)
 190     s ))
 191
 192 (defun vm-mm-layout (m)
 193   (or (vm-mime-layout-of m)
 194       (progn (vm-set-mime-layout-of m (vm-mime-parse-entity-safe m))
 195              (vm-mime-layout-of m))))
 196
 197 (defun vm-mm-encoded-header (m)
 198   (or (vm-mime-encoded-header-flag-of m)
 199       (progn (setq m (vm-real-message-of m))
 200              (vm-set-mime-encoded-header-flag-of
 201               m
 202               (save-excursion
 203                 (set-buffer (vm-buffer-of m))
 204                 (save-excursion
 205                   (save-restriction
 206                     (widen)
 207                     (goto-char (vm-headers-of m))
 208                     (let ((case-fold-search t))
 209                       (or (re-search-forward vm-mime-encoded-word-regexp
 210                                              (vm-text-of m) t)
 211                           'none))))))
 212              (vm-mime-encoded-header-flag-of m))))
 213
 214 (defun vm-mime-Q-decode-region (start end)
 215   (interactive "r")
 216   (let ((buffer-read-only nil))
 217     (subst-char-in-region start end ?_ (string-to-char " ") t)
 218     (vm-mime-qp-decode-region start end)))
 219
 220 (fset 'vm-mime-B-decode-region 'vm-mime-base64-decode-region)
 221
 222 (defun vm-mime-Q-encode-region (start end)
 223   (let ((buffer-read-only nil)
 224         (val))
 225     (setq val (vm-mime-qp-encode-region start end t)) ; may modify buffer
 226     (subst-char-in-region start (min end (point-max))
 227                           (string-to-char " ") ?_ t)
 228     val ))
 229
 230 (defun vm-mime-B-encode-region (start end)
 231   (vm-mime-base64-encode-region start end nil t))
 232
 233 (defun vm-mime-base64-decode-string (string)
 234   (vm-with-string-as-temp-buffer
 235    string
 236    (function
 237     (lambda () (vm-mime-base64-decode-region (point-min) (point-max))))))
 238
 239 (defun vm-mime-base64-encode-string (string)
 240   (vm-with-string-as-temp-buffer
 241    string
 242    (function
 243     (lambda () (vm-mime-base64-encode-region (point-min) (point-max)
 244                                              nil t)))))
 245
 246 (defun vm-mime-crlf-to-lf-region (start end)
 247   (let ((buffer-read-only nil))
 248     (save-excursion
 249       (save-restriction
 250         (narrow-to-region start end)
 251         (goto-char start)
 252         (while (search-forward "\r\n" nil t)
 253           (delete-char -2)
 254           (insert "\n"))))))
 255
 256 (defun vm-mime-lf-to-crlf-region (start end)
 257   (let ((buffer-read-only nil))
 258     (save-excursion
 259       (save-restriction
 260         (narrow-to-region start end)
 261         (goto-char start)
 262         (while (search-forward "\n" nil t)
 263           (delete-char -1)
 264           (insert "\r\n"))))))
 265
 266 (defun vm-encode-coding-region (b-start b-end coding-system &rest foo)
 267   (let ((work-buffer nil)
 268         start end
 269         oldsize
 270         retval
 271         (b (current-buffer)))
 272     (unwind-protect
 273         (save-excursion
 274           (setq work-buffer (vm-make-work-buffer))
 275           (set-buffer work-buffer)
 276           (insert-buffer-substring b b-start b-end)
 277           (setq oldsize (buffer-size))
 278           (setq retval (apply 'encode-coding-region (point-min) (point-max)
 279                               coding-system foo))
 280           (setq start (point-min) end (point-max))
 281           (setq retval (buffer-size))
 282           (save-excursion
 283             (set-buffer b)
 284             (goto-char b-start)
 285             (insert-buffer-substring work-buffer start end)
 286             (delete-region (point) (+ (point) oldsize))
 287             ;; Fixup the end point.  I have found no other way to
 288             ;; let the calling function know where the region ends
 289             ;; after encode-coding-region has scrambled the markers.
 290             (and (markerp b-end)
 291                  (set-marker b-end (point)))
 292             retval ))
 293       (and work-buffer (kill-buffer work-buffer)))))
 294
 295 (defun vm-decode-coding-region (b-start b-end coding-system &rest foo)
 296   (let ((work-buffer nil)
 297         start end
 298         oldsize
 299         retval
 300         (b (current-buffer)))
 301     (unwind-protect
 302         (save-excursion
 303           (setq work-buffer (vm-make-work-buffer))
 304           (setq oldsize (- b-end b-start))
 305           (set-buffer work-buffer)
 306           (insert-buffer-substring b b-start b-end)
 307           (setq retval (apply 'decode-coding-region (point-min) (point-max)
 308                               coding-system foo))
 309           (and vm-fsfemacs-p (set-buffer-multibyte t))
 310           (setq start (point-min) end (point-max))
 311           (save-excursion
 312             (set-buffer b)
 313             (goto-char b-start)
 314             (delete-region (point) (+ (point) oldsize))
 315             (insert-buffer-substring work-buffer start end)
 316             ;; Fixup the end point.  I have found no other way to
 317             ;; let the calling function know where the region ends
 318             ;; after decode-coding-region has scrambled the markers.
 319             (and (markerp b-end)
 320                  (set-marker b-end (point)))
 321             retval ))
 322       (and work-buffer (kill-buffer work-buffer)))))
 323
 324 (defun vm-mime-charset-decode-region (charset start end)
 325   (or (markerp end) (setq end (vm-marker end)))
 326   (cond ((or vm-xemacs-mule-p vm-fsfemacs-mule-p)
 327          (if (or (and vm-xemacs-p (memq (device-type) '(x gtk mswindows)))
 328                  vm-fsfemacs-p
 329                  (vm-mime-tty-can-display-mime-charset charset)
 330                  nil)
 331              (let ((buffer-read-only nil)
 332                    (cell (cdr (vm-string-assoc
 333                                charset
 334                                vm-mime-mule-charset-to-coding-alist)))
 335                    (opoint (point)))
 336                (if cell
 337                    (progn
 338                      ;; decode 8-bit indeterminate char to correct
 339                      ;; char in correct charset.
 340                      (vm-decode-coding-region start end (car cell))
 341                      (put-text-property start end 'vm-string t)
 342                      (put-text-property start end 'vm-charset charset)
 343                      (put-text-property start end 'vm-coding (car cell))))
 344                ;; In XEmacs 20.0 beta93 decode-coding-region moves point.
 345                (goto-char opoint))))
 346         ((not (vm-multiple-fonts-possible-p)) nil)
 347         ((vm-mime-default-face-charset-p charset) nil)
 348         (t
 349          (let ((font (cdr (vm-string-assoc
 350                            charset
 351                            vm-mime-charset-font-alist)))
 352                (face (make-face (make-symbol "temp-face")))
 353                (e (vm-make-extent start end)))
 354            (put-text-property start end 'vm-string t)
 355            (put-text-property start end 'vm-charset charset)
 356            (if font
 357                (condition-case data
 358                    (progn (set-face-font face font)
 359                           (if vm-fsfemacs-p
 360                               (put-text-property start end 'face face)
 361                             (vm-set-extent-property e 'duplicable t)
 362                             (vm-set-extent-property e 'face face)))
 363                  (error nil)))))))
 364
 365 (defun vm-mime-transfer-decode-region (layout start end)
 366   (let ((case-fold-search t) (crlf nil))
 367     (if (or (vm-mime-types-match "text" (car (vm-mm-layout-type layout)))
 368             (vm-mime-types-match "message" (car (vm-mm-layout-type layout))))
 369         (setq crlf t))
 370     (cond ((string-match "^base64$" (vm-mm-layout-encoding layout))
 371            (vm-mime-base64-decode-region start end crlf))
 372           ((string-match "^quoted-printable$"
 373                          (vm-mm-layout-encoding layout))
 374            (vm-mime-qp-decode-region start end))
 375           ((string-match "^x-uue$\\|^x-uuencode$"
 376                          (vm-mm-layout-encoding layout))
 377            (vm-mime-uuencode-decode-region start end crlf)))))
 378
 379 (defun vm-mime-base64-decode-region (start end &optional crlf)
 380   (or (markerp end) (setq end (vm-marker end)))
 381   (and (> (- end start) 200)
 382        (message "Decoding base64..."))
 383   (let ((work-buffer nil)
 384         (done nil)
 385         (counter 0)
 386         (bits 0)
 387         (lim 0) inputpos
 388         (non-data-chars (concat "^=" vm-mime-base64-alphabet)))
 389     (unwind-protect
 390         (save-excursion
 391           (cond
 392            ((and (featurep 'base64)
 393                  (fboundp 'base64-decode-region)
 394                  ;; W3 reportedly has a Lisp version of this, and
 395                  ;; there's no point running it.
 396                  (subrp (symbol-function 'base64-decode-region))
 397                  ;; The FSF Emacs version of this is unforgiving
 398                  ;; of errors, which is not in the spirit of the
 399                  ;; MIME spec, so avoid using it.
 400                  (not vm-fsfemacs-p))
 401             (condition-case data
 402                 (base64-decode-region start end)
 403               (error (vm-mime-error "%S" data)))
 404             (and crlf (vm-mime-crlf-to-lf-region start end)))
 405            (t
 406             (setq work-buffer (vm-make-work-buffer))
 407             (if vm-mime-base64-decoder-program
 408                 (let* ((binary-process-output t) ; any text already has CRLFs
 409                        ;; use binary coding system in FSF Emacs/MULE
 410                        (coding-system-for-read (vm-binary-coding-system))
 411                        (coding-system-for-write (vm-binary-coding-system))
 412                        (status (apply 'vm-run-command-on-region
 413                                       start end work-buffer
 414                                       vm-mime-base64-decoder-program
 415                                       vm-mime-base64-decoder-switches)))
 416                   (if (not (eq status t))
 417                       (vm-mime-error "%s" (cdr status))))
 418               (goto-char start)
 419               (skip-chars-forward non-data-chars end)
 420               (while (not done)
 421                 (setq inputpos (point))
 422                 (cond
 423                  ((> (skip-chars-forward vm-mime-base64-alphabet end) 0)
 424                   (setq lim (point))
 425                   (while (< inputpos lim)
 426                     (setq bits (+ bits
 427                                   (aref vm-mime-base64-alphabet-decoding-vector
 428                                         (char-after inputpos))))
 429                     (vm-increment counter)
 430                     (vm-increment inputpos)
 431                     (cond ((= counter 4)
 432                            (vm-insert-char (lsh bits -16) 1 nil work-buffer)
 433                            (vm-insert-char (logand (lsh bits -8) 255) 1 nil
 434                                            work-buffer)
 435                            (vm-insert-char (logand bits 255) 1 nil work-buffer)
 436                            (setq bits 0 counter 0))
 437                           (t (setq bits (lsh bits 6)))))))
 438                 (cond
 439                  ((= (point) end)
 440                   (if (not (zerop counter))
 441                       (vm-mime-error "at least %d bits missing at end of base64 encoding"
 442                                      (* (- 4 counter) 6)))
 443                   (setq done t))
 444                  ((= (char-after (point)) 61) ; 61 is ASCII equals
 445                   (setq done t)
 446                   (cond ((= counter 1)
 447                          (vm-mime-error "at least 2 bits missing at end of base64 encoding"))
 448                         ((= counter 2)
 449                          (vm-insert-char (lsh bits -10) 1 nil work-buffer))
 450                         ((= counter 3)
 451                          (vm-insert-char (lsh bits -16) 1 nil work-buffer)
 452                          (vm-insert-char (logand (lsh bits -8) 255)
 453                                          1 nil work-buffer))
 454                         ((= counter 0) t)))
 455                  (t (skip-chars-forward non-data-chars end)))))
 456             (and crlf
 457                  (save-excursion
 458                    (set-buffer work-buffer)
 459                    (vm-mime-crlf-to-lf-region (point-min) (point-max))))
 460             (goto-char start)
 461             (insert-buffer-substring work-buffer)
 462             (delete-region (point) end))))
 463       (and work-buffer (kill-buffer work-buffer))))
 464   (and (> (- end start) 200)
 465        (message "Decoding base64... done")))
 466
 467 (defun vm-mime-base64-encode-region (start end &optional crlf B-encoding)
 468   (or (markerp end) (setq end (vm-marker end)))
 469   (and (> (- end start) 200)
 470        (message "Encoding base64..."))
 471   (let ((work-buffer nil)
 472         (buffer-undo-list t)
 473         (counter 0)
 474         (cols 0)
 475         (bits 0)
 476         (alphabet vm-mime-base64-alphabet)
 477         inputpos)
 478     (unwind-protect
 479         (save-excursion
 480           (and crlf (vm-mime-lf-to-crlf-region start end))
 481           (cond
 482            ((and (featurep 'base64)
 483                  (fboundp 'base64-encode-region)
 484                  ;; W3 reportedly has a Lisp version of this, and
 485                  ;; there's no point running it.
 486                  (subrp (symbol-function 'base64-encode-region)))
 487             (condition-case data
 488                 (base64-encode-region start end B-encoding)
 489               (wrong-number-of-arguments
 490                ;; call with two args and then strip out the
 491                ;; newlines if we're doing B encoding.
 492                (condition-case data
 493                    (base64-encode-region start end)
 494                  (error (vm-mime-error "%S" data)))
 495                (if B-encoding
 496                    (save-excursion
 497                      (goto-char start)
 498                      (while (search-forward "\n" end t)
 499                        (delete-char -1)))))
 500               (error (vm-mime-error "%S" data))))
 501            (t
 502             (setq work-buffer (vm-make-work-buffer))
 503             (if vm-mime-base64-encoder-program
 504                 (let ((status (apply 'vm-run-command-on-region
 505                                      start end work-buffer
 506                                      vm-mime-base64-encoder-program
 507                                      vm-mime-base64-encoder-switches)))
 508                   (if (not (eq status t))
 509                       (vm-mime-error "%s" (cdr status)))
 510                   (if B-encoding
 511                       (save-excursion
 512                         (set-buffer work-buffer)
 513                         ;; if we're B encoding, strip out the line breaks
 514                         (goto-char (point-min))
 515                         (while (search-forward "\n" nil t)
 516                           (delete-char -1)))))
 517               (setq inputpos start)
 518               (while (< inputpos end)
 519                 (setq bits (+ bits (char-after inputpos)))
 520                 (vm-increment counter)
 521                 (cond ((= counter 3)
 522                        (vm-insert-char (aref alphabet (lsh bits -18)) 1 nil
 523                                        work-buffer)
 524                        (vm-insert-char (aref alphabet (logand (lsh bits -12) 63))
 525                                        1 nil work-buffer)
 526                        (vm-insert-char (aref alphabet (logand (lsh bits -6) 63))
 527                                        1 nil work-buffer)
 528                        (vm-insert-char (aref alphabet (logand bits 63)) 1 nil
 529                                        work-buffer)
 530                        (setq cols (+ cols 4))
 531                        (cond ((= cols 72)
 532                               (setq cols 0)
 533                               (if (not B-encoding)
 534                                   (vm-insert-char ?\n 1 nil work-buffer))))
 535                        (setq bits 0 counter 0))
 536                       (t (setq bits (lsh bits 8))))
 537                 (vm-increment inputpos))
 538               ;; write out any remaining bits with appropriate padding
 539               (if (= counter 0)
 540                   nil
 541                 (setq bits (lsh bits (- 16 (* 8 counter))))
 542                 (vm-insert-char (aref alphabet (lsh bits -18)) 1 nil
 543                                 work-buffer)
 544                 (vm-insert-char (aref alphabet (logand (lsh bits -12) 63))
 545                                 1 nil work-buffer)
 546                 (if (= counter 1)
 547                     (vm-insert-char ?= 2 nil work-buffer)
 548                   (vm-insert-char (aref alphabet (logand (lsh bits -6) 63))
 549                                   1 nil work-buffer)
 550                   (vm-insert-char ?= 1 nil work-buffer)))
 551               (if (> cols 0)
 552                   (vm-insert-char ?\n 1 nil work-buffer)))
 553             (or (markerp end) (setq end (vm-marker end)))
 554             (goto-char start)
 555             (insert-buffer-substring work-buffer)
 556             (delete-region (point) end)))
 557           (and (> (- end start) 200)
 558                (message "Encoding base64... done"))
 559           (- end start))
 560       (and work-buffer (kill-buffer work-buffer)))))
 561
 562 (defun vm-mime-qp-decode-region (start end)
 563   (and (> (- end start) 200)
 564        (message "Decoding quoted-printable..."))
 565   (let ((work-buffer nil)
 566         (buf (current-buffer))
 567         (case-fold-search nil)
 568         (hex-digit-alist '((?0 .  0)  (?1 .  1)  (?2 .  2)  (?3 .  3)
 569                            (?4 .  4)  (?5 .  5)  (?6 .  6)  (?7 .  7)
 570                            (?8 .  8)  (?9 .  9)  (?A . 10)  (?B . 11)
 571                            (?C . 12)  (?D . 13)  (?E . 14)  (?F . 15)
 572                            ;; some mailer uses lower-case hex
 573                            ;; digits despite this being forbidden
 574                            ;; by the MIME spec.
 575                            (?a . 10)  (?b . 11)  (?c . 12)  (?d . 13)
 576                            (?e . 14)  (?f . 15)))
 577         inputpos stop-point copy-point)
 578     (unwind-protect
 579         (save-excursion
 580           (setq work-buffer (vm-make-work-buffer))
 581           (if vm-mime-qp-decoder-program
 582               (let* ((binary-process-output t) ; any text already has CRLFs
 583                      ;; use binary coding system in FSF Emacs/MULE
 584                      (coding-system-for-read (vm-binary-coding-system))
 585                      (coding-system-for-write (vm-binary-coding-system))
 586                      (status (apply 'vm-run-command-on-region
 587                                     start end work-buffer
 588                                     vm-mime-qp-decoder-program
 589                                     vm-mime-qp-decoder-switches)))
 590                 (if (not (eq status t))
 591                     (vm-mime-error "%s" (cdr status))))
 592             (goto-char start)
 593             (setq inputpos start)
 594             (while (< inputpos end)
 595               (skip-chars-forward "^=\n" end)
 596               (setq stop-point (point))
 597               (cond ((looking-at "\n")
 598                      ;; spaces or tabs before a hard line break must be ignored
 599                      (skip-chars-backward " \t")
 600                      (setq copy-point (point))
 601                      (goto-char stop-point))
 602                     (t (setq copy-point stop-point)))
 603               (save-excursion
 604                 (set-buffer work-buffer)
 605                 (insert-buffer-substring buf inputpos copy-point))
 606               (cond ((= (point) end) t)
 607                     ((looking-at "\n")
 608                      (vm-insert-char ?\n 1 nil work-buffer)
 609                      (forward-char))
 610                     (t;; looking at =
 611                      (forward-char)
 612                      ;; a-f because some mailers use lower case hex
 613                      ;; digits despite them being forbidden by the
 614                      ;; MIME spec.
 615                      (cond ((looking-at "[0-9A-Fa-f][0-9A-Fa-f]")
 616                             (vm-insert-char (+ (* (cdr (assq (char-after (point))
 617                                                              hex-digit-alist))
 618                                                   16)
 619                                                (cdr (assq (char-after
 620                                                            (1+ (point)))
 621                                                           hex-digit-alist)))
 622                                             1 nil work-buffer)
 623                             (forward-char 2))
 624                            ((looking-at "\n") ; soft line break
 625                             (forward-char))
 626                            ((looking-at "\r")
 627                             ;; assume the user's goatloving
 628                             ;; delivery software didn't convert
 629                             ;; from Internet's CRLF newline
 630                             ;; convention to the local LF
 631                             ;; convention.
 632                             (forward-char))
 633                            ((looking-at "[ \t]")
 634                             ;; garbage added in transit
 635                             (skip-chars-forward " \t" end))
 636                            (t (vm-mime-error "something other than line break or hex digits after = in quoted-printable encoding")))))
 637               (setq inputpos (point))))
 638           (or (markerp end) (setq end (vm-marker end)))
 639           (goto-char start)
 640           (insert-buffer-substring work-buffer)
 641           (delete-region (point) end))
 642       (and work-buffer (kill-buffer work-buffer))))
 643   (and (> (- end start) 200)
 644        (message "Decoding quoted-printable... done")))
 645
 646 (defun vm-mime-qp-encode-region (start end &optional Q-encoding quote-from)
 647   (and (> (- end start) 200)
 648        (message "Encoding quoted-printable..."))
 649   (let ((work-buffer nil)
 650         (buf (current-buffer))
 651         (cols 0)
 652         (hex-digit-alist '((?0 .  0)  (?1 .  1)  (?2 .  2)  (?3 .  3)
 653                            (?4 .  4)  (?5 .  5)  (?6 .  6)  (?7 .  7)
 654                            (?8 .  8)  (?9 .  9)  (?A . 10)  (?B . 11)
 655                            (?C . 12)  (?D . 13)  (?E . 14)  (?F . 15)))
 656         char inputpos)
 657
 658     (unwind-protect
 659         (save-excursion
 660           (setq work-buffer (vm-make-work-buffer))
 661           (if vm-mime-qp-encoder-program
 662               (let* ((binary-process-output t) ; any text already has CRLFs
 663                      ;; use binary coding system in FSF Emacs/MULE
 664                      (coding-system-for-read (vm-binary-coding-system))
 665                      (coding-system-for-write (vm-binary-coding-system))
 666                      (status (apply 'vm-run-command-on-region
 667                                     start end work-buffer
 668                                     vm-mime-qp-encoder-program
 669                                     vm-mime-qp-encoder-switches)))
 670                 (if (not (eq status t))
 671                     (vm-mime-error "%s" (cdr status)))
 672                 (if quote-from
 673                     (save-excursion
 674                       (set-buffer work-buffer)
 675                       (goto-char (point-min))
 676                       (while (re-search-forward "^From " nil t)
 677                         (replace-match "=46rom " t t))))
 678                 (if Q-encoding
 679                     (save-excursion
 680                       (set-buffer work-buffer)
 681                       ;; strip out the line breaks
 682                       (goto-char (point-min))
 683                       (while (search-forward "=\n" nil t)
 684                         (delete-char -2))
 685                       ;; strip out the soft line breaks
 686                       (goto-char (point-min))
 687                       (while (search-forward "\n" nil t)
 688                         (delete-char -1)))))
 689             (setq inputpos start)
 690             (while (< inputpos end)
 691               (setq char (char-after inputpos))
 692               (cond ((= char ?\n)
 693                      (vm-insert-char char 1 nil work-buffer)
 694                      (setq cols 0))
 695                     ((and (= char 32)
 696                           (not (= (1+ inputpos) end))
 697                           (not (= ?\n (char-after (1+ inputpos)))))
 698                      (vm-insert-char char 1 nil work-buffer)
 699                      (vm-increment cols))
 700                     ((or (< char 33) (> char 126)
 701                          ;; =
 702                          (= char 61)
 703                          ;; ?
 704                          (and Q-encoding (= char 63))
 705                          ;; _
 706                          (and Q-encoding (= char 95))
 707                          (and quote-from (= cols 0)
 708                               (let ((case-fold-search nil))
 709                                 (looking-at "From ")))
 710                          (and (= cols 0) (= char ?.)
 711                               (looking-at "\\.\\(\n\\|\\'\\)")))
 712                      (vm-insert-char ?= 1 nil work-buffer)
 713                      (vm-insert-char (car (rassq (lsh (logand char 255) -4)
 714                                                  hex-digit-alist))
 715                                      1 nil work-buffer)
 716                      (vm-insert-char (car (rassq (logand char 15)
 717                                                  hex-digit-alist))
 718                                      1 nil work-buffer)
 719                      (setq cols (+ cols 3)))
 720                     (t (vm-insert-char char 1 nil work-buffer)
 721                        (vm-increment cols)))
 722               (cond ((> cols 70)
 723                      (setq cols 0)
 724                      (if Q-encoding
 725                          nil
 726                        (vm-insert-char ?= 1 nil work-buffer)
 727                        (vm-insert-char ?\n 1 nil work-buffer))))
 728               (vm-increment inputpos)))
 729           (or (markerp end) (setq end (vm-marker end)))
 730           (goto-char start)
 731           (insert-buffer-substring work-buffer)
 732           (delete-region (point) end)
 733           (and (> (- end start) 200)
 734                (message "Encoding quoted-printable... done"))
 735           (- end start))
 736       (and work-buffer (kill-buffer work-buffer)))))
 737
 738 (defun vm-mime-uuencode-decode-region (start end &optional crlf)
 739   (message "Decoding uuencoded stuff...")
 740   (let ((work-buffer nil)
 741         (region-buffer (current-buffer))
 742         (case-fold-search nil)
 743         (tempfile (vm-make-tempfile-name)))
 744     (unwind-protect
 745         (save-excursion
 746           (setq work-buffer (vm-make-work-buffer))
 747           (set-buffer work-buffer)
 748           (insert-buffer-substring region-buffer start end)
 749           (goto-char (point-min))
 750           (or (re-search-forward "^begin [0-7][0-7][0-7] " nil t)
 751               (vm-mime-error "no begin line"))
 752           (delete-region (point) (progn (forward-line 1) (point)))
 753           (insert tempfile "\n")
 754           (goto-char (point-max))
 755           (beginning-of-line)
 756           ;; Eudora reportedly doesn't terminate uuencoded multipart
 757           ;; bodies with a line break. 21 June 1998.
 758           ;; Actually it looks like Eudora doesn't understand the
 759           ;; multipart newline boundary rule at all and can leave
 760           ;; all types of attachments missing a line break.
 761           (if (looking-at "^end\\'")
 762               (progn
 763                 (goto-char (point-max))
 764                 (insert "\n")))
 765           (if (stringp vm-mime-uuencode-decoder-program)
 766               (let* ((binary-process-output t) ; any text already has CRLFs
 767                      ;; use binary coding system in FSF Emacs/MULE
 768                      (coding-system-for-read (vm-binary-coding-system))
 769                      (coding-system-for-write (vm-binary-coding-system))
 770                      (status (apply 'vm-run-command-on-region
 771                                     (point-min) (point-max) nil
 772                                     vm-mime-uuencode-decoder-program
 773                                     vm-mime-uuencode-decoder-switches)))
 774                 (if (not (eq status t))
 775                     (vm-mime-error "%s" (cdr status))))
 776             (vm-mime-error "no uuencode decoder program defined"))
 777           (delete-region (point-min) (point-max))
 778           (insert-file-contents-literally tempfile)
 779           (and crlf
 780                (vm-mime-crlf-to-lf-region (point-min) (point-max)))
 781           (set-buffer region-buffer)
 782           (or (markerp end) (setq end (vm-marker end)))
 783           (goto-char start)
 784           (insert-buffer-substring work-buffer)
 785           (delete-region (point) end))
 786       (and work-buffer (kill-buffer work-buffer))
 787       (vm-error-free-call 'delete-file tempfile)))
 788   (message "Decoding uuencoded stuff... done"))
 789
 790 (defun vm-decode-mime-message-headers (&optional m)
 791   (let ((case-fold-search t)
 792         (buffer-read-only nil)
 793         charset need-conversion encoding match-start match-end start end
 794         previous-end)
 795     (save-excursion
 796       (if m (goto-char (vm-headers-of m)))
 797       (while (re-search-forward vm-mime-encoded-word-regexp
 798                                 (if m (vm-text-of m) (point-max)) t)
 799         (setq match-start (match-beginning 0)
 800               match-end (match-end 0)
 801               charset (buffer-substring (match-beginning 1) (match-end 1))
 802               need-conversion nil
 803               encoding (buffer-substring (match-beginning 4) (match-end 4))
 804               start (match-beginning 5)
 805               end (vm-marker (match-end 5)))
 806         ;; don't change anything if we can't display the
 807         ;; character set properly.
 808         (if (and (not (vm-mime-charset-internally-displayable-p charset))
 809                  (not (setq need-conversion
 810                             (vm-mime-can-convert-charset charset))))
 811             nil
 812           ;; suppress whitespace between encoded words.
 813           (and previous-end
 814                (string-match "\\`[ \t\n]*\\'"
 815                              (buffer-substring previous-end match-start))
 816                (setq match-start previous-end))
 817           (delete-region end match-end)
 818           (condition-case data
 819               (cond ((string-match "B" encoding)
 820                      (vm-mime-B-decode-region start end))
 821                     ((string-match "Q" encoding)
 822                      (vm-mime-Q-decode-region start end))
 823                     (t (vm-mime-error "unknown encoded word encoding, %s"
 824                                       encoding)))
 825             (vm-mime-error (apply 'message (cdr data))
 826                            (goto-char start)
 827                            (insert "**invalid encoded word**")
 828                            (delete-region (point) end)))
 829           (and need-conversion
 830                (setq charset (vm-mime-charset-convert-region
 831                               charset start end)))
 832           (vm-mime-charset-decode-region charset start end)
 833           (goto-char end)
 834           (setq previous-end end)
 835           (delete-region match-start start))))))
 836
 837 (defun vm-decode-mime-encoded-words ()
 838   (let ((case-fold-search t)
 839         (buffer-read-only nil)
 840         charset need-conversion encoding match-start match-end start end)
 841     (save-excursion
 842       (goto-char (point-min))
 843       (while (re-search-forward vm-mime-encoded-word-regexp nil t)
 844         (setq match-start (match-beginning 0)
 845               match-end (match-end 0)
 846               charset (buffer-substring (match-beginning 1) (match-end 1))
 847               need-conversion nil
 848               encoding (buffer-substring (match-beginning 4) (match-end 4))
 849               start (match-beginning 5)
 850               end (vm-marker (match-end 5)))
 851         ;; don't change anything if we can't display the
 852         ;; character set properly.
 853         (if (and (not (vm-mime-charset-internally-displayable-p charset))
 854                  (not (setq need-conversion
 855                             (vm-mime-can-convert-charset charset))))
 856             nil
 857           (delete-region end match-end)
 858           (condition-case data
 859               (cond ((string-match "B" encoding)
 860                      (vm-mime-B-decode-region start end))
 861                     ((string-match "Q" encoding)
 862                      (vm-mime-Q-decode-region start end))
 863                     (t (vm-mime-error "unknown encoded word encoding, %s"
 864                                       encoding)))
 865             (vm-mime-error (apply 'message (cdr data))
 866                            (goto-char start)
 867                            (insert "**invalid encoded word**")
 868                            (delete-region (point) end)))
 869           (and need-conversion
 870                (setq charset (vm-mime-charset-convert-region
 871                               charset start end)))
 872           (vm-mime-charset-decode-region charset start end)
 873           (goto-char end)
 874           (delete-region match-start start))))))
 875
 876 (defun vm-decode-mime-encoded-words-in-string (string)
 877   (if (and vm-display-using-mime
 878            (let ((case-fold-search t))
 879              (string-match vm-mime-encoded-word-regexp string)))
 880       (vm-with-string-as-temp-buffer string 'vm-decode-mime-encoded-words)
 881     string ))
 882
 883 (defun vm-reencode-mime-encoded-words ()
 884   (let ((charset nil)
 885         start coding pos q-encoding
 886         old-size
 887         (case-fold-search t)
 888         (done nil))
 889     (save-excursion
 890       (setq start (point-min))
 891       (while (not done)
 892         (setq charset (get-text-property start 'vm-charset))
 893         (setq pos (next-single-property-change start 'vm-charset))
 894         (or pos (setq pos (point-max) done t))
 895         (if charset
 896             (progn
 897               (if (setq coding (get-text-property start 'vm-coding))
 898                   (progn
 899                     (setq old-size (buffer-size))
 900                     (encode-coding-region start pos coding)
 901                     (setq pos (+ pos (- (buffer-size) old-size)))))
 902               (setq pos
 903                     (+ start
 904                        (if (setq q-encoding
 905                                  (string-match "^iso-8859-\\|^us-ascii"
 906                                                charset))
 907                            (vm-mime-Q-encode-region start pos)
 908                          (vm-mime-B-encode-region start pos))))
 909               (goto-char pos)
 910               (insert "?=")
 911               (setq pos (point))
 912               (goto-char start)
 913               (insert "=?" charset "?" (if q-encoding "Q" "B") "?")
 914               (setq pos (+ pos (- (point) start)))))
 915         (setq start pos)))))
 916
 917 (defun vm-reencode-mime-encoded-words-in-string (string)
 918   (if (and vm-display-using-mime
 919            (text-property-any 0 (length string) 'vm-string t string))
 920       (vm-with-string-as-temp-buffer string 'vm-reencode-mime-encoded-words)
 921     string ))
 922
 923 (fset 'vm-mime-parse-content-header 'vm-parse-structured-header)
 924
 925 (defun vm-mime-get-header-contents (header-name-regexp)
 926   (let ((contents nil)
 927         regexp)
 928     (setq regexp (concat "^\\(" header-name-regexp "\\)\\|\\(^$\\)"))
 929     (save-excursion
 930       (let ((case-fold-search t))
 931         (if (and (re-search-forward regexp nil t)
 932                  (match-beginning 1)
 933                  (progn (goto-char (match-beginning 0))
 934                         (vm-match-header)))
 935             (vm-matched-header-contents)
 936           nil )))))
 937
 938 (defun vm-mime-parse-entity (&optional m default-type default-encoding
 939                                        passing-message-only)
 940   (catch 'return-value
 941     (save-excursion
 942       (if (and m (not passing-message-only))
 943           (progn
 944             (setq m (vm-real-message-of m))
 945             (set-buffer (vm-buffer-of m))))
 946       (let ((case-fold-search t) version type qtype encoding id description
 947             disposition qdisposition boundary boundary-regexp start end
 948             multipart-list pos-list c-t c-t-e done p returnval)
 949         (save-excursion
 950           (save-restriction
 951             (if (and m (not passing-message-only))
 952                 (progn
 953                   (setq version (vm-get-header-contents m "MIME-Version:")
 954                         version (car (vm-mime-parse-content-header version))
 955                         type (vm-get-header-contents m "Content-Type:")
 956                         version (if (or version
 957                                         vm-mime-require-mime-version-header)
 958                                     version
 959                                   (if type "1.0" nil))
 960                         qtype (vm-mime-parse-content-header type ?\; t)
 961                         type (vm-mime-parse-content-header type ?\;)
 962                         encoding (vm-get-header-contents
 963                                   m "Content-Transfer-Encoding:")
 964                         version (if (or version
 965                                         vm-mime-require-mime-version-header)
 966                                     version
 967                                   (if encoding "1.0" nil))
 968                         encoding (or encoding "7bit")
 969                         encoding (or (car
 970                                       (vm-mime-parse-content-header encoding))
 971                                      "7bit")
 972                         id (vm-get-header-contents m "Content-ID:")
 973                         id (car (vm-mime-parse-content-header id))
 974                         description (vm-get-header-contents
 975                                      m "Content-Description:")
 976                         description (and description
 977                                          (if (string-match "^[ \t\n]*$"
 978                                                            description)
 979                                              nil
 980                                            description))
 981                         disposition (vm-get-header-contents
 982                                      m "Content-Disposition:")
 983                         qdisposition (and disposition
 984                                           (vm-mime-parse-content-header
 985                                            disposition ?\; t))
 986                         disposition (and disposition
 987                                          (vm-mime-parse-content-header
 988                                           disposition ?\;)))
 989                   (widen)
 990                   (narrow-to-region (vm-headers-of m) (vm-text-end-of m)))
 991               (goto-char (point-min))
 992               (setq type (vm-mime-get-header-contents "Content-Type:")
 993                     qtype (or (vm-mime-parse-content-header type ?\; t)
 994                               default-type)
 995                     type (or (vm-mime-parse-content-header type ?\;)
 996                              default-type)
 997                     encoding (or (vm-mime-get-header-contents
 998                                   "Content-Transfer-Encoding:")
 999                                  default-encoding)
1000                     encoding (or (car (vm-mime-parse-content-header encoding))
1001                                  default-encoding)
1002                     id (vm-mime-get-header-contents "Content-ID:")
1003                     id (car (vm-mime-parse-content-header id))
1004                     description (vm-mime-get-header-contents
1005                                  "Content-Description:")
1006                     description (and description (if (string-match "^[ \t\n]*$"
1007                                                                    description)
1008                                                      nil
1009                                                    description))
1010                     disposition (vm-mime-get-header-contents
1011                                  "Content-Disposition:")
1012                     qdisposition (and disposition
1013                                       (vm-mime-parse-content-header
1014                                        disposition ?\; t))
1015                     disposition (and disposition
1016                                      (vm-mime-parse-content-header
1017                                       disposition ?\;))))
1018             (cond ((null m) t)
1019                   (passing-message-only t)
1020                   ((null version)
1021                    (throw 'return-value 'none))
1022                   ((or vm-mime-ignore-mime-version (string= version "1.0")) t)
1023                   (t (vm-mime-error "Unsupported MIME version: %s" version)))
1024             ;; deal with known losers
1025             ;; Content-Type: text
1026             (cond ((and type (string-match "^text$" (car type)))
1027                    (setq type '("text/plain" "charset=us-ascii")
1028                          qtype '("text/plain" "charset=us-ascii"))))
1029             (cond ((and m (not passing-message-only) (null type))
1030                    (throw 'return-value
1031                           (vm-make-layout
1032                            'type '("text/plain" "charset=us-ascii")
1033                            'qtype '("text/plain" "charset=us-ascii")
1034                            'encoding encoding
1035                            'id id
1036                            'description description
1037                            'disposition disposition
1038                            'qdisposition qdisposition
1039                            'header-start (vm-headers-of m)
1040                            'header-end (vm-marker (1- (vm-text-of m)))
1041                            'body-start (vm-text-of m)
1042                            'body-end (vm-text-end-of m)
1043                            'cache (vm-mime-make-cache-symbol)
1044                            'message-symbol (vm-mime-make-message-symbol m)
1045                            )))
1046                   ((null type)
1047                    (goto-char (point-min))
1048                    (or (re-search-forward "^\n\\|\n\\'" nil t)
1049                        (vm-mime-error "MIME part missing header/body separator line"))
1050                    (vm-make-layout
1051                     'type default-type
1052                     'qtype default-type
1053                     'encoding encoding
1054                     'id id
1055                     'description description
1056                     'disposition disposition
1057                     'qdisposition qdisposition
1058                     'header-start (vm-marker (point-min))
1059                     'header-body (vm-marker (1- (point)))
1060                     'body-start (vm-marker (point))
1061                     'body-end (vm-marker (point-max))
1062                     'cache (vm-mime-make-cache-symbol)
1063                     'message-symbol (vm-mime-make-message-symbol m)
1064                     ))
1065                   ((null (string-match "[^/ ]+/[^/ ]+" (car type)))
1066                    (vm-mime-error "Malformed MIME content type: %s"
1067                                   (car type)))
1068                   ((and (string-match "^multipart/\\|^message/" (car type))
1069                         (null (string-match "^\\(7bit\\|8bit\\|binary\\)$"
1070                                             encoding))
1071                         (if vm-mime-ignore-composite-type-opaque-transfer-encoding
1072                             (progn
1073                               ;; Some mailers declare an opaque
1074                               ;; encoding on a composite type even
1075                               ;; though it's only a subobject that
1076                               ;; uses that encoding.  Deal with it
1077                               ;; by assuming a proper transfer encoding.
1078                               (setq encoding "binary")
1079                               ;; return nil so and-clause will fail
1080                               nil )
1081                           t ))
1082                    (vm-mime-error "Opaque transfer encoding used with multipart or message type: %s, %s" (car type) encoding))
1083                   ((and (string-match "^message/partial$" (car type))
1084                         (null (string-match "^7bit$" encoding)))
1085                    (vm-mime-error "Non-7BIT transfer encoding used with message/partial message: %s" encoding))
1086                   ((string-match "^multipart/digest" (car type))
1087                    (setq c-t '("message/rfc822")
1088                          c-t-e "7bit"))
1089                   ((string-match "^multipart/" (car type))
1090                    (setq c-t '("text/plain" "charset=us-ascii")
1091                          c-t-e "7bit")) ; below
1092                   ((string-match "^message/\\(rfc822\\|news\\|external-body\\)"
1093                                  (car type))
1094                    (setq c-t '("text/plain" "charset=us-ascii")
1095                          c-t-e "7bit")
1096                    (goto-char (point-min))
1097                    (or (re-search-forward "^\n\\|\n\\'" nil t)
1098                        (vm-mime-error "MIME part missing header/body separator line"))
1099                    (throw 'return-value
1100                           (vm-make-layout
1101                            'type type
1102                            'qtype qtype
1103                            'encoding encoding
1104                            'id id
1105                            'description description
1106                            'disposition disposition
1107                            'qdisposition qdisposition
1108                            'header-start (vm-marker (point-min))
1109                            'header-end (vm-marker (1- (point)))
1110                            'body-start (vm-marker (point))
1111                            'body-end (vm-marker (point-max))
1112                            'parts (list
1113                                    (save-restriction
1114                                      (narrow-to-region (point) (point-max))
1115                                      (vm-mime-parse-entity-safe m c-t c-t-e t)))
1116                            'cache (vm-mime-make-cache-symbol)
1117                            'message-symbol (vm-mime-make-message-symbol m)
1118                            )))
1119                   (t
1120                    (goto-char (point-min))
1121                    (or (re-search-forward "^\n\\|\n\\'" nil t)
1122                        (vm-mime-error "MIME part missing header/body separator line"))
1123                    (throw 'return-value
1124                           (vm-make-layout
1125                            'type type
1126                            'qtype qtype
1127                            'encoding encoding
1128                            'id id
1129                            'description description
1130                            'disposition disposition
1131                            'qdisposition qdisposition
1132                            'header-start (vm-marker (point-min))
1133                            'header-end (vm-marker (1- (point)))
1134                            'body-start (vm-marker (point))
1135                            'body-end (vm-marker (point-max))
1136                            'cache (vm-mime-make-cache-symbol)
1137                            'message-symbol (vm-mime-make-message-symbol m)
1138                            ))))
1139             (setq p (cdr type)
1140                   boundary nil)
1141             (while p
1142               (if (string-match "^boundary=" (car p))
1143                   (setq boundary (car (vm-parse (car p) "=\\(.+\\)"))
1144                         p nil)
1145                 (setq p (cdr p))))
1146             (or boundary
1147                 (vm-mime-error
1148                  "Boundary parameter missing in %s type specification"
1149                  (car type)))
1150             ;; the \' in the regexp is to "be liberal" in the
1151             ;; face of broken software that does not add a line
1152             ;; break after the final boundary of a nested
1153             ;; multipart entity.
1154             (setq boundary-regexp
1155                   (concat "^--" (regexp-quote boundary)
1156                           "\\(--\\)?[ \t]*\\(\n\\|\\'\\)"))
1157             (goto-char (point-min))
1158             (setq start nil
1159                   multipart-list nil
1160                   done nil)
1161             (while (and (not done) (re-search-forward boundary-regexp nil 0))
1162               (if (null start)
1163                   (setq start (match-end 0))
1164                 (and (match-beginning 1)
1165                      (setq done t))
1166                 (setq pos-list (cons start
1167                                      (cons (1- (match-beginning 0)) pos-list))
1168                       start (match-end 0))))
1169             (if (and (not done)
1170                      (not vm-mime-ignore-missing-multipart-boundary))
1171                 (vm-mime-error "final %s boundary missing" boundary)
1172               (if (and start (not done))
1173                   (setq pos-list (cons start (cons (point) pos-list)))))
1174             (setq pos-list (nreverse pos-list))
1175             (while pos-list
1176               (setq start (car pos-list)
1177                     end (car (cdr pos-list))
1178                     pos-list (cdr (cdr pos-list)))
1179               (save-excursion
1180                 (save-restriction
1181                   (narrow-to-region start end)
1182                   (setq multipart-list
1183                         (cons (vm-mime-parse-entity-safe m c-t c-t-e t)
1184                               multipart-list)))))
1185             (goto-char (point-min))
1186             (or (re-search-forward "^\n\\|\n\\'" nil t)
1187                 (vm-mime-error "MIME part missing header/body separator line"))
1188             (vm-make-layout
1189              'type type
1190              'qtype qtype
1191              'encoding encoding
1192              'id id
1193              'description description
1194              'disposition disposition
1195              'qdisposition qdisposition
1196              'header-start (vm-marker (point-min))
1197              'header-end (vm-marker (1- (point)))
1198              'body-start (vm-marker (point))
1199              'body-end (vm-marker (point-max))
1200              'parts (nreverse multipart-list)
1201              'cache (vm-mime-make-cache-symbol)
1202              'message-symbol (vm-mime-make-message-symbol m)
1203              )))))))
1204
1205 (defun vm-mime-parse-entity-safe (&optional m c-t c-t-e p-m-only)
1206   (or c-t (setq c-t '("text/plain" "charset=us-ascii")))
1207   (or c-t-e (setq c-t-e "7bit"))
1208   ;; don't let subpart parse errors make the whole parse fail.  use default
1209   ;; type if the parse fails.
1210   (condition-case error-data
1211       (vm-mime-parse-entity m c-t c-t-e p-m-only)
1212     (vm-mime-error
1213      (message "%s" (car (cdr error-data)))
1214 ;;; don't sleep, no one cares about MIME syntax errors
1215 ;;;     (sleep-for 2)
1216      (let ((header (if (and m (not p-m-only))
1217                        (vm-headers-of m)
1218                      (vm-marker (point-min))))
1219            (text (if (and m (not p-m-only))
1220                      (vm-text-of m)
1221                    (save-excursion
1222                      (re-search-forward "^\n\\|\n\\'"
1223                                         nil 0)
1224                      (vm-marker (point)))))
1225            (text-end (if (and m (not p-m-only))
1226                          (vm-text-end-of m)
1227                        (vm-marker (point-max)))))
1228      (vm-make-layout
1229       'type '("error/error")
1230       'qtype '("error/error")
1231       'encoding (vm-determine-proper-content-transfer-encoding text text-end)
1232       ;; cram the error message into the description slot
1233       'description (car (cdr error-data))
1234       ;; mark as an attachment to improve the chance that the user
1235       ;; will see the description.
1236       'disposition '("attachment")
1237       'qdisposition '("attachment")
1238       'header-start header
1239       'header-end (vm-marker (1- text))
1240       'body-start text
1241       'body-end text-end
1242       'cache (vm-mime-make-cache-symbol)
1243       'message-symbol (vm-mime-make-message-symbol m)
1244       )))))
1245
1246 (defun vm-mime-get-xxx-parameter-internal (name param-list)
1247   "Return the parameter NAME from PARAM-LIST."
1248   (let ((match-end (1+ (length name)))
1249         (name-regexp (concat (regexp-quote name) "="))
1250         (case-fold-search t)
1251         (done nil))
1252     (while (and param-list (not done))
1253       (if (and (string-match name-regexp (car param-list))
1254                (= (match-end 0) match-end))
1255           (setq done t)
1256         (setq param-list (cdr param-list))))
1257     (and (car param-list)
1258          (substring (car param-list) match-end))))
1259
1260 (defun vm-mime-get-xxx-parameter (name param-list)
1261   "Return the parameter NAME from PARAM-LIST.
1262
1263 If parameter value continuations was used, i.e. the parameter was split into
1264 shorter pieces, rebuilt it from them."
1265   (or (vm-mime-get-xxx-parameter-internal name param-list)
1266       (let ((n 0) content p)
1267         (while (setq p (vm-mime-get-xxx-parameter-internal
1268                         (format "%s*%d" name n)
1269                         param-list))
1270           (setq n (1+ n)
1271                 content (concat content p)))
1272         content)))
1273
1274 (defun vm-mime-get-parameter (layout name)
1275   (let ((string (vm-mime-get-xxx-parameter name (cdr (vm-mm-layout-type layout)))))
1276     (if string (vm-decode-mime-encoded-words-in-string string))))
1277
1278 (defun vm-mime-get-disposition-parameter (layout name)
1279   (let ((string (vm-mime-get-xxx-parameter name (cdr (vm-mm-layout-disposition layout)))))
1280     (if string (vm-decode-mime-encoded-words-in-string string))))
1281
1282 (defun vm-mime-set-xxx-parameter (name value param-list)
1283   (let ((match-end (1+ (length name)))
1284         (name-regexp (concat (regexp-quote name) "="))
1285         (case-fold-search t)
1286         (done nil))
1287     (while (and param-list (not done))
1288       (if (and (string-match name-regexp (car param-list))
1289                (= (match-end 0) match-end))
1290           (setq done t)
1291         (setq param-list (cdr param-list))))
1292     (and (car param-list)
1293          (setcar param-list (concat name "=" value)))))
1294
1295 (defun vm-mime-set-parameter (layout name value)
1296   (vm-mime-set-xxx-parameter name value (cdr (vm-mm-layout-type layout))))
1297
1298 (defun vm-mime-set-qparameter (layout name value)
1299   (setq value (concat "\"" value "\""))
1300   (vm-mime-set-xxx-parameter name value (cdr (vm-mm-layout-qtype layout))))
1301
1302 (defun vm-mime-insert-mime-body (layout)
1303   (vm-insert-region-from-buffer (marker-buffer (vm-mm-layout-body-start layout))
1304                                 (vm-mm-layout-body-start layout)
1305                                 (vm-mm-layout-body-end layout)))
1306
1307 (defun vm-mime-insert-mime-headers (layout)
1308   (vm-insert-region-from-buffer (marker-buffer (vm-mm-layout-header-start layout))
1309                                 (vm-mm-layout-header-start layout)
1310                                 (vm-mm-layout-header-end layout)))
1311
1312 (defvar buffer-display-table)
1313 (defvar standard-display-table)
1314 (defvar buffer-file-type)
1315 (defun vm-make-presentation-copy (m)
1316   (let ((mail-buffer (current-buffer))
1317         b mm
1318         (real-m (vm-real-message-of m))
1319         (modified (buffer-modified-p)))
1320     (cond ((or (null vm-presentation-buffer-handle)
1321                (null (buffer-name vm-presentation-buffer-handle)))
1322            (let ((default-enable-multibyte-characters t))
1323              (setq b (generate-new-buffer (concat (buffer-name)
1324                                                   " Presentation"))))
1325            (save-excursion
1326              (set-buffer b)
1327              (if (fboundp 'buffer-disable-undo)
1328                  (buffer-disable-undo (current-buffer))
1329                ;; obfuscation to make the v19 compiler not whine
1330                ;; about obsolete functions.
1331                (let ((x 'buffer-flush-undo))
1332                  (funcall x (current-buffer))))
1333              (setq mode-name "VM Presentation"
1334                    major-mode 'vm-presentation-mode
1335                    vm-message-pointer (list nil)
1336                    vm-mail-buffer mail-buffer
1337                    mode-popup-menu (and vm-use-menus
1338                                         (vm-menu-support-possible-p)
1339                                         (vm-menu-mode-menu))
1340                    ;; Default to binary file type for DOS/NT.
1341                    buffer-file-type t
1342                    ;; Tell XEmacs/MULE not to mess with the text on writes.
1343                    buffer-read-only t
1344                    mode-line-format vm-mode-line-format)
1345              ;; scroll in place messes with scroll-up and this loses
1346              (defvar scroll-in-place)
1347              (make-local-variable 'scroll-in-place)
1348              (setq scroll-in-place nil)
1349              (if (fboundp 'set-buffer-file-coding-system)
1350                  (set-buffer-file-coding-system (vm-binary-coding-system) t))
1351              (vm-fsfemacs-nonmule-display-8bit-chars)
1352              (if (and vm-mutable-frames vm-frame-per-folder
1353                       (vm-multiple-frames-possible-p))
1354                  (vm-set-hooks-for-frame-deletion))
1355              (use-local-map vm-mode-map)
1356              (vm-toolbar-install-or-uninstall-toolbar)
1357              (and (vm-menu-support-possible-p)
1358                   (vm-menu-install-menus))
1359              (run-hooks 'vm-presentation-mode-hook))
1360            (setq vm-presentation-buffer-handle b)))
1361     (setq b vm-presentation-buffer-handle
1362           vm-presentation-buffer vm-presentation-buffer-handle
1363           vm-mime-decoded nil)
1364     ;; W3 or some other external mode might set some local colors
1365     ;; in this buffer; remove them before displaying a different
1366     ;; message here.
1367     (if (fboundp 'remove-specifier)
1368         (progn
1369           (remove-specifier (face-foreground 'default) b)
1370           (remove-specifier (face-background 'default) b)))
1371     (save-excursion
1372       (set-buffer (vm-buffer-of real-m))
1373       (save-restriction
1374         (widen)
1375         ;; must reference this now so that headers will be in
1376         ;; their final position before the message is copied.
1377         ;; otherwise the vheader offset computed below will be
1378         ;; wrong.
1379         (vm-vheaders-of real-m)
1380         (set-buffer b)
1381         (widen)
1382         (let ((buffer-read-only nil)
1383               (inhibit-read-only t)
1384               (modified (buffer-modified-p)))
1385           (unwind-protect
1386               (progn
1387                 (erase-buffer)
1388                 (insert-buffer-substring (vm-buffer-of real-m)
1389                                          (vm-start-of real-m)
1390                                          (vm-end-of real-m)))
1391             (set-buffer-modified-p modified)))
1392         (setq mm (copy-sequence m))
1393         (vm-set-location-data-of mm (vm-copy (vm-location-data-of m)))
1394         (set-marker (vm-start-of mm) (point-min))
1395         (set-marker (vm-headers-of mm) (+ (vm-start-of mm)
1396                                           (- (vm-headers-of real-m)
1397                                              (vm-start-of real-m))))
1398         (set-marker (vm-vheaders-of mm) (+ (vm-start-of mm)
1399                                            (- (vm-vheaders-of real-m)
1400                                               (vm-start-of real-m))))
1401         (set-marker (vm-text-of mm) (+ (vm-start-of mm)
1402                                        (- (vm-text-of real-m)
1403                                           (vm-start-of real-m))))
1404         (set-marker (vm-text-end-of mm) (+ (vm-start-of mm)
1405                                            (- (vm-text-end-of real-m)
1406                                               (vm-start-of real-m))))
1407         (set-marker (vm-end-of mm) (+ (vm-start-of mm)
1408                                       (- (vm-end-of real-m)
1409                                          (vm-start-of real-m))))
1410         (setcar vm-message-pointer mm)))))
1411
1412 (fset 'vm-presentation-mode 'vm-mode)
1413 (put 'vm-presentation-mode 'mode-class 'special)
1414
1415 (defvar buffer-file-coding-system)
1416
1417 ;; TODO: integrate with the FSF's unify-8859-on-encoding-mode stuff.
1418 (defun vm-determine-proper-charset (beg end)
1419   "Work out what MIME character set to use for sending a message.
1420
1421 Uses `us-ascii' if the message is entirely ASCII compatible.  If MULE is not
1422 available, and the message contains contains non-ASCII characters, consults
1423 the variable `vm-mime-8bit-composition-charset' or uses `iso-8859-1.' if
1424 that is nil.
1425
1426 Under MULE, `vm-coding-system-priorities' is searched, in order, for a coding
1427 system that will encode all the characters in the message. If none is found,
1428 consults the variable `vm-mime-8bit-composition-charset' or uses `iso-2022-jp',
1429 which will preserve information for all the character sets of which Emacs is
1430 aware - at the expense of being incompatible with the recipient's software, if
1431 that recipient is outside of East Asia."
1432   (save-excursion
1433     (save-restriction
1434       (narrow-to-region beg end)
1435         (if (or vm-xemacs-mule-p
1436                 (and vm-fsfemacs-mule-p enable-multibyte-characters))
1437             ;; Okay, we're on a MULE build.
1438             (let ((charsets (delq 'ascii
1439                                   (vm-charsets-in-region (point-min)
1440                                                          (point-max)))))
1441               (cond
1442                ;; No non-ASCII chars? Right, that makes it easy for us.
1443                ((null charsets) "us-ascii")
1444
1445                ;; Check whether the buffer can be encoded using one of the
1446                ;; vm-coding-system-priorities coding systems.
1447                ((catch 'done
1448
1449                   ;; We can't really do this intelligently unless latin-unity
1450                   ;; is available.
1451                   (if (featurep 'latin-unity)
1452                       (let ((csetzero charsets)
1453                             ;; Check what latin character sets are in the
1454                             ;; buffer.
1455                             (csets (latin-unity-representations-feasible-region
1456                                     beg end))
1457                             (psets (latin-unity-representations-present-region
1458                                     beg end))
1459                             (systems (vm-get-coding-system-priorities)))
1460
1461                         ;; If one of the character sets is outside of latin
1462                         ;; unity's remit, check for a universal character
1463                         ;; set in vm-coding-system-priorities, and pass back
1464                         ;; the first one.
1465                         ;;
1466                         ;; Otherwise, there's no remapping that latin unity
1467                         ;; can do for us, and we should default to something
1468                         ;; iso-2022 based. (Since we're not defaulting to
1469                         ;; Unicode, at the moment.)
1470
1471                         (while csetzero
1472                           (if (not (memq
1473                                     (car csetzero) latin-unity-character-sets))
1474                               (let ((ucs-list (vm-get-mime-ucs-list))
1475                                     (preapproved
1476                                      (vm-get-coding-system-priorities)))
1477                                 (while preapproved
1478                                   (if (memq (car preapproved) ucs-list)
1479                                       (throw 'done
1480                                              (car (cdr (assq
1481                                                         (vm-coding-system-name
1482                                                          (car preapproved))
1483                                       vm-mime-mule-coding-to-charset-alist)))))
1484                                   (setq preapproved (cdr preapproved)))
1485                                 ;; Nothing universal in the preapproved list.
1486                                 (throw 'done nil)))
1487                           (setq csetzero (cdr csetzero)))
1488
1489                         ;; Okay, we're able to remap using latin-unity. Do so.
1490                         (while systems
1491                           (let ((sys (latin-unity-massage-name (car systems)
1492                                                'buffer-default)))
1493                             (when (latin-unity-maybe-remap (point-min)
1494                                                            (point-max) sys
1495                                                            csets psets t)
1496                               (throw 'done (second (assq
1497                                                     (vm-coding-system-name sys)
1498                                     vm-mime-mule-coding-to-charset-alist)))))
1499                           (setq systems (cdr systems)))
1500                         (throw 'done nil))
1501
1502                     ;; Right, latin-unity isn't available.  If there's only
1503                     ;; one non-ASCII character set in the region, and the
1504                     ;; corresponding coding system is on the preapproved
1505                     ;; list before the first universal character set, pass
1506                     ;; it back. Otherwise, if a universal character set is
1507                     ;; on the preapproved list, pass the first one of them
1508                     ;; back. Otherwise, pass back nil and use the
1509                     ;; "iso-2022-jp" entry below.
1510
1511                     (let ((csetzero charsets)
1512                           (preapproved (vm-get-coding-system-priorities))
1513                           (ucs-list (vm-get-mime-ucs-list)))
1514                       (if (null (cdr csetzero))
1515                           (while preapproved
1516                             ;; If we encounter a universal character set on
1517                             ;; the preapproved list, pass it back.
1518                             (if (memq (car preapproved) ucs-list)
1519                                 (throw 'done (second (assq
1520                                                       (vm-coding-system-name
1521                                                        (car preapproved))
1522                                      vm-mime-mule-coding-to-charset-alist))))
1523
1524                             ;; The preapproved entry isn't universal. Check if
1525                             ;; it's related to the single non-ASCII MULE
1526                             ;; charset in the buffer (that is, if the
1527                             ;; conceptually unordered MULE list of characters
1528                             ;; is based on a corresponding ISO character set,
1529                             ;; and thus the ordered ISO character set can
1530                             ;; encode all the characters in the MIME charset.)
1531                             ;;
1532                             ;; The string equivalence test is used because we
1533                             ;; don't have another mapping that is useful
1534                             ;; here. Nnngh.
1535
1536                             (if (string=
1537                                  (car (cdr (assoc (car csetzero)
1538                                    vm-mime-mule-charset-to-charset-alist)))
1539                                  (car (cdr (assoc (car preapproved)
1540                                    vm-mime-mule-coding-to-charset-alist))))
1541                                 (throw 'done
1542                                        (car (cdr (assoc (car csetzero)
1543                                     vm-mime-mule-charset-to-charset-alist)))))
1544                             (setq preapproved (cdr preapproved)))
1545
1546                         ;; Okay, there's more than one MULE character set in
1547                         ;; the buffer. Check for a universal entry in the
1548                         ;; preapproved list; if it exists pass it back,
1549                         ;; otherwise fall through to the iso-2022-jp below,
1550                         ;; because nothing on the preapproved list is
1551                         ;; appropriate.
1552
1553                         (while preapproved
1554                             ;; If we encounter a universal character set on
1555                             ;; the preapproved list, pass it back.
1556                             (when (memq (car preapproved) ucs-list)
1557                                 (throw 'done (second (assq
1558                                                       (vm-coding-system-name
1559                                                        (car preapproved))
1560                                      vm-mime-mule-coding-to-charset-alist))))
1561                             (setq preapproved (cdr preapproved)))))
1562                     (throw 'done nil))))
1563                ;; Couldn't do any magic with vm-coding-system-priorities. Pass
1564                ;; back a Japanese iso-2022 MIME character set.
1565                (t (or vm-mime-8bit-composition-charset "iso-2022-jp"))))
1566           ;; If we're non-MULE and there are eight bit characters, use a
1567           ;; sensible default.
1568           (goto-char (point-min))
1569           (if (re-search-forward "[^\000-\177]" nil t)
1570               (or vm-mime-8bit-composition-charset "iso-8859-1")
1571           ;; We're non-MULE and there are purely 7bit characters in the
1572           ;; region. Return vm-mime-7bit-c-c.
1573           vm-mime-7bit-composition-charset)))))
1574
1575 (defun vm-determine-proper-content-transfer-encoding (beg end)
1576   (save-excursion
1577     (save-restriction
1578       (narrow-to-region beg end)
1579       (catch 'done
1580         (goto-char (point-min))
1581         (and (re-search-forward "[\000\015]" nil t)
1582              (throw 'done "binary"))
1583
1584         (let ((toolong nil) bol)
1585           (goto-char (point-min))
1586           (setq bol (point))
1587           (while (and (not (eobp)) (not toolong))
1588             (forward-line)
1589             (setq toolong (> (- (point) bol) 998)
1590                   bol (point)))
1591           (and toolong (throw 'done "binary")))
1592
1593         (goto-char (point-min))
1594         (and (re-search-forward "[^\000-\177]" nil t)
1595              (throw 'done "8bit"))
1596
1597         "7bit"))))
1598
1599 (defun vm-mime-types-match (type type/subtype)
1600   (let ((case-fold-search t))
1601     (cond ((string-match "/" type)
1602            (if (and (string-match (regexp-quote type) type/subtype)
1603                     (equal 0 (match-beginning 0))
1604                     (equal (length type/subtype) (match-end 0)))
1605                t
1606              nil ))
1607           ((and (string-match (regexp-quote type) type/subtype)
1608                 (equal 0 (match-beginning 0))
1609                 (equal (save-match-data
1610                          (string-match "/" type/subtype (match-end 0)))
1611                        (match-end 0)))))))
1612
1613 (defvar native-sound-only-on-console)
1614
1615 (defun vm-mime-can-display-internal (layout &optional deep)
1616   (let ((type (car (vm-mm-layout-type layout))))
1617     (cond ((vm-mime-types-match "image/jpeg" type)
1618            (and (vm-image-type-available-p 'jpeg) (vm-images-possible-here-p)))
1619           ((vm-mime-types-match "image/gif" type)
1620            (and (vm-image-type-available-p 'gif) (vm-images-possible-here-p)))
1621           ((vm-mime-types-match "image/png" type)
1622            (and (vm-image-type-available-p 'png) (vm-images-possible-here-p)))
1623           ((vm-mime-types-match "image/tiff" type)
1624            (and (vm-image-type-available-p 'tiff) (vm-images-possible-here-p)))
1625           ((vm-mime-types-match "image/xpm" type)
1626            (and (vm-image-type-available-p 'xpm) (vm-images-possible-here-p)))
1627           ((vm-mime-types-match "image/pbm" type)
1628            (and (vm-image-type-available-p 'pbm) (vm-images-possible-here-p)))
1629           ((vm-mime-types-match "image/xbm" type)
1630            (and (vm-image-type-available-p 'xbm) (vm-images-possible-here-p)))
1631           ((vm-mime-types-match "audio/basic" type)
1632            (and vm-xemacs-p
1633                 (or (featurep 'native-sound)
1634                     (featurep 'nas-sound))
1635                 (or (device-sound-enabled-p)
1636                     (and (featurep 'native-sound)
1637                          (not native-sound-only-on-console)
1638                          (memq (device-type) '(x gtk))))))
1639           ((vm-mime-types-match "multipart" type) t)
1640           ((vm-mime-types-match "message/external-body" type)
1641            (or (not deep)
1642                (vm-mime-can-display-internal
1643                 (car (vm-mm-layout-parts layout)) t)))
1644           ((vm-mime-types-match "message" type) t)
1645           ((vm-mime-types-match "text/html" type)
1646            (and (fboundp 'w3-region)
1647                 vm-mime-use-w3-for-text/html
1648                 ;; this because GNUS bogusly sets up autoloads
1649                 ;; for w3-region even if W3 isn't installed.
1650                 (fboundp 'w3-about)
1651                 (let ((charset (or (vm-mime-get-parameter layout "charset")
1652                                    "us-ascii")))
1653                   (vm-mime-charset-internally-displayable-p charset))))
1654           ((vm-mime-types-match "text" type)
1655            (let ((charset (or (vm-mime-get-parameter layout "charset")
1656                               "us-ascii")))
1657              (or (vm-mime-charset-internally-displayable-p charset)
1658                  (vm-mime-can-convert-charset charset))))
1659           (t nil))))
1660
1661 (defun vm-mime-can-convert (type)
1662   (or (vm-mime-can-convert-0 type vm-mime-type-converter-alist)
1663       (vm-mime-can-convert-0 type vm-mime-image-type-converter-alist)))
1664
1665 (defun vm-mime-can-convert-0 (type alist)
1666   (let (
1667         ;; fake layout. make it the wrong length so an error will
1668         ;; be signaled if vm-mime-can-display-internal ever asks
1669         ;; for one of the other fields
1670         (fake-layout (make-vector 1 (list nil)))
1671         best second-best)
1672     (while (and alist (not best))
1673       (cond ((and (vm-mime-types-match (car (car alist)) type)
1674                   (not (vm-mime-types-match (nth 1 (car alist)) type)))
1675              (cond ((and (not best)
1676                          (progn
1677                            (setcar (aref fake-layout 0) (nth 1 (car alist)))
1678                            (vm-mime-can-display-internal fake-layout)))
1679                     (setq best (car alist)))
1680                    ((and (not second-best)
1681                          (vm-mime-find-external-viewer (nth 1 (car alist))))
1682                     (setq second-best (car alist))))))
1683       (setq alist (cdr alist)))
1684     (or best second-best)))
1685
1686 (defun vm-mime-convert-undisplayable-layout (layout)
1687   (catch 'done
1688     (let ((ooo (vm-mime-can-convert (car (vm-mm-layout-type layout))))
1689           ex work-buffer)
1690       (message "Converting %s to %s..."
1691                (car (vm-mm-layout-type layout))
1692                (nth 1 ooo))
1693       (save-excursion
1694         (setq work-buffer (vm-make-work-buffer " *mime object*"))
1695         (vm-register-message-garbage 'kill-buffer work-buffer)
1696         (set-buffer work-buffer)
1697         ;; call-process-region calls write-region.
1698         ;; don't let it do CR -> LF translation.
1699         (setq selective-display nil)
1700         (vm-mime-insert-mime-body layout)
1701         (vm-mime-transfer-decode-region layout (point-min) (point-max))
1702         ;; It is annoying to use cat for conversion of a mime type which
1703         ;; is just plain text.  Therefore we do not call it ...
1704         (setq ex 0)
1705         (if (= (length ooo) 2)
1706             (if (search-forward-regexp "\n\n" (point-max) t)
1707                 (delete-region (point-min) (match-beginning 0)))
1708         (setq ex (call-process-region (point-min) (point-max) shell-file-name
1709                                         t t nil shell-command-switch (nth 2 ooo))))
1710         (if (not (eq ex 0))
1711             (progn
1712               (switch-to-buffer work-buffer)
1713               (message "Conversion from %s to %s failed (exit code %s)"
1714                        (car (vm-mm-layout-type layout))
1715                        (nth 1 ooo)
1716                        ex)
1717               (sit-for 5)
1718               (throw 'done nil)))
1719         (goto-char (point-min))
1720         (insert "Content-Type: " (nth 1 ooo) "\n")
1721         (insert "Content-Transfer-Encoding: binary\n\n")
1722         (set-buffer-modified-p nil)
1723         (message "Converting %s to %s... done"
1724                  (car (vm-mm-layout-type layout))
1725                  (nth 1 ooo))
1726         (vm-make-layout
1727          'type (append (list (nth 1 ooo)) (cdr (vm-mm-layout-type layout)))
1728          'qtype (append (list (nth 1 ooo)) (cdr (vm-mm-layout-type layout)))
1729          'encoding "binary"
1730          'id (vm-mm-layout-id layout)
1731          'description (vm-mm-layout-description layout)
1732          'disposition (vm-mm-layout-disposition layout)
1733          'qdisposition (vm-mm-layout-qdisposition layout)
1734          'header-start (vm-marker (point-min))
1735          'header-end (vm-marker (1- (point)))
1736          'body-start (vm-marker (point))
1737          'body-end (vm-marker (point-max))
1738          'cache (vm-mime-make-cache-symbol)
1739          'message-symbol (vm-mime-make-message-symbol
1740                           (vm-mm-layout-message layout))
1741          'layout-is-converted t
1742          'unconverted-layout layout
1743          )))))
1744
1745 (defun vm-mime-can-convert-charset (charset)
1746   (vm-mime-can-convert-charset-0 charset vm-mime-charset-converter-alist))
1747
1748 (defun vm-mime-can-convert-charset-0 (charset alist)
1749   (let ((done nil))
1750     (while (and alist (not done))
1751       (cond ((and (vm-string-equal-ignore-case (car (car alist)) charset)
1752                   (vm-mime-charset-internally-displayable-p
1753                    (nth 1 (car alist))))
1754              (setq done t))
1755             (t (setq alist (cdr alist)))))
1756     (and alist (car alist))))
1757
1758 (defun vm-mime-convert-undisplayable-charset (layout)
1759   (let ((charset (vm-mime-get-parameter layout "charset"))
1760         ooo work-buffer)
1761     (setq ooo (vm-mime-can-convert-charset charset))
1762     (message "Converting charset %s to %s..."
1763              charset
1764              (nth 1 ooo))
1765     (save-excursion
1766       (setq work-buffer (vm-make-work-buffer " *mime object*"))
1767       (vm-register-message-garbage 'kill-buffer work-buffer)
1768       (set-buffer work-buffer)
1769       ;; call-process-region calls write-region.
1770       ;; don't let it do CR -> LF translation.
1771       (setq selective-display nil)
1772       (vm-mime-insert-mime-body layout)
1773       (vm-mime-transfer-decode-region layout (point-min) (point-max))
1774       (call-process-region (point-min) (point-max) shell-file-name
1775                            t t nil shell-command-switch (nth 2 ooo))
1776       (setq layout
1777             (vm-make-layout
1778              'type (copy-sequence (vm-mm-layout-type layout))
1779              'qtype (copy-sequence (vm-mm-layout-type layout))
1780              'encoding "binary"
1781              'id (vm-mm-layout-id layout)
1782              'description (vm-mm-layout-description layout)
1783              'disposition (vm-mm-layout-disposition layout)
1784              'qdisposition (vm-mm-layout-qdisposition layout)
1785              'header-start (vm-marker (point-min))
1786              'header-body (vm-marker (1- (point)))
1787              'body-start (vm-marker (point))
1788              'body-end (vm-marker (point-max))
1789              'cache (vm-mime-make-cache-symbol)
1790              'message-symbol (vm-mime-make-message-symbol
1791                               (vm-mm-layout-message layout))
1792              'layout-is-converted t
1793              'onconverted-layout layout
1794              ))
1795       (vm-mime-set-parameter layout "charset" (nth 1 ooo))
1796       (vm-mime-set-qparameter layout "charset" (nth 1 ooo))
1797       (goto-char (point-min))
1798       (insert-before-markers "Content-Type: " (car (vm-mm-layout-type layout)))
1799       (insert-before-markers ";\n\t"
1800                              (mapconcat 'identity
1801                                         (car (vm-mm-layout-type layout))
1802                                         ";\n\t")
1803                              "\n")
1804       (insert-before-markers "Content-Transfer-Encoding: binary\n\n")
1805       (set-buffer-modified-p nil)
1806       (message "Converting charset %s to %s... done"
1807                charset
1808                (nth 1 ooo))
1809       layout)))
1810
1811 (defun vm-mime-charset-convert-region (charset b-start b-end)
1812   (let ((b (current-buffer))
1813         start end oldsize work-buffer ooo)
1814     (setq ooo (vm-mime-can-convert-charset charset))
1815     (unwind-protect
1816         (save-excursion
1817           (setq work-buffer (vm-make-work-buffer " *mime object*"))
1818           (setq oldsize (- b-end b-start))
1819           (set-buffer work-buffer)
1820           (insert-buffer-substring b b-start b-end)
1821           ;; call-process-region calls write-region.
1822           ;; don't let it do CR -> LF translation.
1823           (setq selective-display nil)
1824           (call-process-region (point-min) (point-max) shell-file-name
1825                                t t nil shell-command-switch (nth 2 ooo))
1826           (and vm-fsfemacs-mule-p (set-buffer-multibyte t))
1827           (setq start (point-min) end (point-max))
1828           (save-excursion
1829             (set-buffer b)
1830             (goto-char b-start)
1831             (insert-buffer-substring work-buffer start end)
1832             (delete-region (point) (+ (point) oldsize)))
1833           (nth 1 ooo))
1834       (and work-buffer (kill-buffer work-buffer)))))
1835
1836 (defun vm-mime-should-display-button (layout dont-honor-content-disposition)
1837   (if (and vm-honor-mime-content-disposition
1838            (not dont-honor-content-disposition)
1839            (vm-mm-layout-disposition layout))
1840       (let ((case-fold-search t))
1841         (string-match "^attachment$" (car (vm-mm-layout-disposition layout))))
1842     (let ((i-list vm-auto-displayed-mime-content-types)
1843           (type (car (vm-mm-layout-type layout)))
1844           (matched nil))
1845       (if (if (eq i-list t)
1846               nil
1847             (while (and i-list (not matched))
1848               (if (vm-mime-types-match (car i-list) type)
1849                   (setq matched t)
1850                 (setq i-list (cdr i-list))))
1851             (not matched))
1852           t
1853         (setq i-list vm-auto-displayed-mime-content-type-exceptions
1854               matched nil)
1855         (while (and i-list (not matched))
1856           (if (vm-mime-types-match (car i-list) type)
1857               (setq matched t)
1858             (setq i-list (cdr i-list))))
1859         matched ))))
1860
1861 (defun vm-mime-should-display-internal (layout)
1862   (let ((i-list vm-mime-internal-content-types)
1863         (type (car (vm-mm-layout-type layout)))
1864         (matched nil))
1865     (if (if (eq i-list t)
1866             t
1867           (while (and i-list (not matched))
1868             (if (vm-mime-types-match (car i-list) type)
1869                 (setq matched t)
1870               (setq i-list (cdr i-list))))
1871           matched )
1872         (progn
1873           (setq i-list vm-mime-internal-content-type-exceptions
1874                 matched nil)
1875           (while (and i-list (not matched))
1876             (if (vm-mime-types-match (car i-list) type)
1877                 (setq matched t)
1878               (setq i-list (cdr i-list))))
1879           (not matched))
1880       nil )))
1881
1882 (defun vm-mime-find-external-viewer (type)
1883   (catch 'done
1884     (let ((list vm-mime-external-content-type-exceptions)
1885           (matched nil))
1886       (while list
1887         (if (vm-mime-types-match (car list) type)
1888             (throw 'done nil)
1889           (setq list (cdr list))))
1890       (setq list vm-mime-external-content-types-alist)
1891       (while (and list (not matched))
1892         (if (and (vm-mime-types-match (car (car list)) type)
1893                  (cdr (car list)))
1894             (setq matched (cdr (car list)))
1895           (setq list (cdr list))))
1896       matched )))
1897 (fset 'vm-mime-can-display-external 'vm-mime-find-external-viewer)
1898
1899 (defun vm-mime-delete-button-maybe (extent)
1900   (let ((buffer-read-only))
1901     ;; if displayed MIME object should replace the button
1902     ;; remove the button now.
1903     (cond ((vm-extent-property extent 'vm-mime-disposable)
1904            (delete-region (vm-extent-start-position extent)
1905                           (vm-extent-end-position extent))
1906            (vm-detach-extent extent)))))
1907
1908 ;;;###autoload
1909 (defun vm-decode-mime-message ()
1910   "Decode the MIME objects in the current message.
1911
1912 The first time this command is run on a message, decoding is done.
1913 The second time, buttons for all the objects are displayed instead.
1914 The third time, the raw, undecoded data is displayed.
1915
1916 If decoding, the decoded objects might be displayed immediately, or
1917 buttons might be displayed that you need to activate to view the
1918 object.  See the documentation for the variables
1919
1920     vm-auto-displayed-mime-content-types
1921     vm-auto-displayed-mime-content-type-exceptions
1922     vm-mime-internal-content-types
1923     vm-mime-internal-content-type-exceptions
1924     vm-mime-external-content-types-alist
1925
1926 to see how to control whether you see buttons or objects.
1927
1928 If the variable vm-mime-display-function is set, then its value
1929 is called as a function with no arguments, and none of the
1930 actions mentioned in the preceding paragraphs are taken.  At the
1931 time of the call, the current buffer will be the presentation
1932 buffer for the folder and a copy of the current message will be
1933 in the buffer.  The function is expected to make the message
1934 `MIME presentable' to the user in whatever manner it sees fit."
1935   (interactive)
1936   (vm-follow-summary-cursor)
1937   (vm-select-folder-buffer)
1938   (vm-check-for-killed-summary)
1939   (vm-check-for-killed-presentation)
1940   (vm-error-if-folder-empty)
1941   (if (and (not vm-display-using-mime)
1942            (null vm-mime-display-function))
1943       (error "MIME display disabled, set vm-display-using-mime non-nil to enable."))
1944   (if vm-mime-display-function
1945       (progn
1946         (vm-make-presentation-copy (car vm-message-pointer))
1947         (set-buffer vm-presentation-buffer)
1948         (funcall vm-mime-display-function))
1949     (if vm-mime-decoded
1950         (if (eq vm-mime-decoded 'decoded)
1951             (let ((vm-preview-lines nil)
1952                   (vm-auto-decode-mime-messages t)
1953                   (vm-honor-mime-content-disposition nil)
1954                   (vm-auto-displayed-mime-content-types '("multipart"))
1955                   (vm-auto-displayed-mime-content-type-exceptions nil))
1956               (setq vm-mime-decoded nil)
1957               (intern (buffer-name) vm-buffers-needing-display-update)
1958               (save-excursion
1959                 (vm-preview-current-message))
1960               (setq vm-mime-decoded 'buttons))
1961           (let ((vm-preview-lines nil)
1962                 (vm-auto-decode-mime-messages nil))
1963             (intern (buffer-name) vm-buffers-needing-display-update)
1964             (vm-preview-current-message)))
1965       (let ((layout (vm-mm-layout (car vm-message-pointer)))
1966             (m (car vm-message-pointer)))
1967         (message "Decoding MIME message...")
1968         (cond ((stringp layout)
1969                (error "Invalid MIME message: %s" layout)))
1970         (if (vm-mime-plain-message-p m)
1971             (error "Message needs no decoding."))
1972         (if (not vm-presentation-buffer)
1973             ;; maybe user killed it - make a new one
1974             (progn
1975               (vm-make-presentation-copy (car vm-message-pointer))
1976               (vm-expose-hidden-headers))
1977           (set-buffer vm-presentation-buffer))
1978         (if (and (interactive-p) (eq vm-system-state 'previewing))
1979             (let ((vm-display-using-mime nil))
1980               (vm-show-current-message)))
1981         (setq m (car vm-message-pointer))
1982         (vm-save-restriction
1983          (widen)
1984          (goto-char (vm-text-of m))
1985          (let ((buffer-read-only nil)
1986                (modified (buffer-modified-p)))
1987            (unwind-protect
1988                (save-excursion
1989                  (and (not (eq (vm-mm-encoded-header m) 'none))
1990                       (vm-decode-mime-message-headers m))
1991                  (if (vectorp layout)
1992                      (progn
1993                        (vm-decode-mime-layout layout)
1994                        (delete-region (point) (point-max))))
1995                  (vm-energize-urls)
1996                  (vm-highlight-headers-maybe)
1997                  (vm-energize-headers-and-xfaces))
1998              (set-buffer-modified-p modified))))
1999         (save-excursion (set-buffer vm-mail-buffer)
2000                         (setq vm-mime-decoded 'decoded))
2001         (intern (buffer-name vm-mail-buffer) vm-buffers-needing-display-update)
2002         (vm-update-summary-and-mode-line)
2003         (message "Decoding MIME message... done"))))
2004   (vm-display nil nil '(vm-decode-mime-message)
2005               '(vm-decode-mime-message reading-message)))
2006
2007 (defun vm-decode-mime-layout (layout &optional dont-honor-c-d)
2008   (let ((modified (buffer-modified-p))
2009         new-layout file type type2 type-no-subtype (extent nil))
2010     (unwind-protect
2011         (progn
2012           (if (not (vectorp layout))
2013               (progn
2014                 (setq extent layout
2015                       layout (vm-extent-property extent 'vm-mime-layout))
2016                 (goto-char (vm-extent-start-position extent))))
2017           (setq type (downcase (car (vm-mm-layout-type layout)))
2018                 type-no-subtype (car (vm-parse type "\\([^/]+\\)")))
2019           (cond ((and vm-infer-mime-types
2020                       (or (and vm-mime-attachment-infer-type-for-text-attachments
2021                                (vm-mime-types-match "text/plain" type))
2022                           (vm-mime-types-match "application/octet-stream" type))
2023                       (setq file
2024                             (or
2025                              (vm-mime-get-disposition-parameter layout
2026                                                                 "filename")
2027                              (vm-mime-get-parameter layout "name")))
2028                       (setq type2 (vm-mime-default-type-from-filename file))
2029                       (not (vm-mime-types-match type type2)))
2030                  (vm-set-mm-layout-type layout (list type2))
2031                  (vm-set-mm-layout-qtype layout
2032                                          (list (concat "\"" type2 "\"")))
2033                  (setq type (downcase (car (vm-mm-layout-type layout)))
2034                        type-no-subtype (car (vm-parse type "\\([^/]+\\)")))))
2035
2036           (cond ((and (vm-mime-should-display-button layout dont-honor-c-d)
2037                       (or (condition-case nil
2038                               (funcall (intern
2039                                         (concat "vm-mime-display-button-"
2040                                                 type))
2041                                        layout)
2042                             (void-function nil))
2043                           (condition-case nil
2044                               (funcall (intern
2045                                         (concat "vm-mime-display-button-"
2046                                                 type-no-subtype))
2047                                        layout)
2048                             (void-function nil)))))
2049                 ((and (vm-mime-should-display-internal layout)
2050                       (or (condition-case nil
2051                               (funcall (intern
2052                                         (concat "vm-mime-display-internal-"
2053                                                 type))
2054                                        layout)
2055                             (void-function nil))
2056                           (condition-case nil
2057                               (funcall (intern
2058                                         (concat "vm-mime-display-internal-"
2059                                                 type-no-subtype))
2060                                        layout)
2061                             (void-function nil)))))
2062                 ((vm-mime-types-match "multipart" type)
2063                  (or (condition-case nil
2064                          (funcall (intern
2065                                    (concat "vm-mime-display-internal-"
2066                                            type))
2067                                   layout)
2068                        (void-function nil))
2069                      (vm-mime-display-internal-multipart/mixed layout)))
2070                 ((and (vm-mime-can-display-external type)
2071                       (vm-mime-display-external-generic layout))
2072                  (and extent (vm-set-extent-property
2073                               extent 'vm-mime-disposable nil)))
2074                 ((and (not (vm-mm-layout-is-converted layout))
2075                       (vm-mime-can-convert type)
2076                       (setq new-layout
2077                             (vm-mime-convert-undisplayable-layout layout)))
2078                  ;; a button should always go away if we're doing
2079                  ;; a conversion.
2080                  (if extent
2081                      (vm-set-extent-property extent 'vm-mime-disposable t))
2082                  (vm-decode-mime-layout new-layout))
2083                 (t (and extent (vm-mime-rewrite-failed-button
2084                                 extent
2085                                 (or (vm-mm-layout-display-error layout)
2086                                     "no external viewer defined for type")))
2087                    (if (vm-mime-types-match type "message/external-body")
2088                        (if (null extent)
2089                            (vm-mime-display-button-xxxx layout t)
2090                          (setq extent nil))
2091                      (vm-mime-display-internal-application/octet-stream
2092                       (or extent layout)))))
2093           (and extent (vm-mime-delete-button-maybe extent)))
2094       (set-buffer-modified-p modified)))
2095   t )
2096
2097 (defun vm-mime-display-button-text (layout)
2098   (vm-mime-display-button-xxxx layout t))
2099
2100 (defun vm-mime-display-internal-text (layout)
2101   (vm-mime-display-internal-text/plain layout))
2102
2103 (defun vm-mime-display-internal-text/html (layout)
2104   (if (and (fboundp 'w3-region)
2105            vm-mime-use-w3-for-text/html)
2106       (condition-case error-data
2107           (let ((buffer-read-only nil)
2108                 (start (point))
2109                 (charset (or (vm-mime-get-parameter layout "charset")
2110                              "us-ascii"))
2111                 end buffer-size)
2112             (message "Inlining text/html, be patient...")
2113             (vm-mime-insert-mime-body layout)
2114             (setq end (point-marker))
2115             (vm-mime-transfer-decode-region layout start end)
2116             (vm-mime-charset-decode-region charset start end)
2117             ;; w3-region apparently deletes all the text in the
2118             ;; region and then insert new text.  This makes the
2119             ;; end == start.  The fix is to move the end marker
2120             ;; forward with a placeholder character so that when
2121             ;; w3-region delete all the text, end will still be
2122             ;; ahead of the insertion point and so will be moved
2123             ;; forward when the new text is inserted.  We'll
2124             ;; delete the placeholder afterward.
2125             (goto-char end)
2126             (insert-before-markers "z")
2127             (w3-region start (1- end))
2128             (goto-char end)
2129             (delete-char -1)
2130             ;; remove read-only text properties
2131             (let ((inhibit-read-only t))
2132               (remove-text-properties start end '(read-only nil)))
2133             (goto-char end)
2134             (message "Inlining text/html... done")
2135             t )
2136         (error (vm-set-mm-layout-display-error
2137                 layout
2138                 (format "Inline HTML display failed: %s"
2139                         (prin1-to-string error-data)))
2140                (message "%s" (vm-mm-layout-display-error layout))
2141                (sleep-for 2)
2142                nil ))
2143     (vm-set-mm-layout-display-error layout "Need W3 to inline HTML")
2144     (message "%s" (vm-mm-layout-display-error layout))
2145     nil ))
2146
2147 (defun vm-mime-display-internal-text/plain (layout &optional no-highlighting)
2148   (let ((start (point)) end need-conversion
2149         (buffer-read-only nil)
2150         (charset (or (vm-mime-get-parameter layout "charset") "us-ascii")))
2151     (if (and (not (vm-mime-charset-internally-displayable-p charset))
2152              (not (setq need-conversion (vm-mime-can-convert-charset charset))))
2153         (progn
2154           (vm-set-mm-layout-display-error
2155            layout (concat "Undisplayable charset: " charset))
2156           nil)
2157       (vm-mime-insert-mime-body layout)
2158       (setq end (point-marker))
2159       (vm-mime-transfer-decode-region layout start end)
2160       (and need-conversion
2161            (setq charset (vm-mime-charset-convert-region charset start end)))
2162       (vm-mime-charset-decode-region charset start end)
2163       (or no-highlighting (vm-energize-urls-in-message-region start end))
2164       (if (and vm-fill-paragraphs-containing-long-lines
2165                (not no-highlighting))
2166           (let ((needmsg (> (- end start) 12000)))
2167             (if needmsg
2168                 (message "Searching for paragraphs to fill..."))
2169             (vm-fill-paragraphs-containing-long-lines
2170              vm-fill-paragraphs-containing-long-lines
2171              start end)
2172             (if needmsg
2173                 (message "Searching for paragraphs to fill... done"))))
2174       (goto-char end)
2175       t )))
2176
2177 (defun vm-mime-display-internal-text/enriched (layout)
2178   (require 'enriched)
2179   (let ((start (point)) end
2180         (buffer-read-only nil)
2181         (enriched-verbose t)
2182         (charset (or (vm-mime-get-parameter layout "charset") "us-ascii")))
2183     (message "Decoding text/enriched, be patient...")
2184     (vm-mime-insert-mime-body layout)
2185     (setq end (point-marker))
2186     (vm-mime-transfer-decode-region layout start end)
2187     (vm-mime-charset-decode-region charset start end)
2188     ;; enriched-decode expects a couple of headers at the top of
2189     ;; the region and will remove anything that looks like a
2190     ;; header.  Put a header section here for it to eat so it
2191     ;; won't eat message text instead.
2192     (goto-char start)
2193     (insert "Comment: You should not see this header\n\n")
2194     (condition-case errdata
2195         (enriched-decode start end)
2196       (error (vm-set-mm-layout-display-error
2197               layout (format "enriched-decode signaled %s" errdata))
2198              (message "%s" (vm-mm-layout-display-error layout))
2199              (sleep-for 2)
2200              nil ))
2201     (vm-energize-urls-in-message-region start end)
2202     (goto-char end)
2203     (message "Decoding text/enriched... done")
2204     t ))
2205
2206 (defun vm-mime-display-external-generic (layout)
2207   (let ((program-list (copy-sequence
2208                        (vm-mime-find-external-viewer
2209                         (car (vm-mm-layout-type layout)))))
2210         (buffer-read-only nil)
2211         start
2212         (coding-system-for-read (vm-binary-coding-system))
2213         (coding-system-for-write (vm-binary-coding-system))
2214         (append-file t)
2215         process tempfile cache end suffix basename)
2216     (setq cache (get (vm-mm-layout-cache layout)
2217                      'vm-mime-display-external-generic)
2218           process (nth 0 cache)
2219           tempfile (nth 1 cache))
2220     (if (and (processp process) (eq (process-status process) 'run))
2221         t
2222       (cond ((or (null tempfile) (null (file-exists-p tempfile)))
2223              (setq suffix (vm-mime-extract-filename-suffix layout)
2224                    suffix (or suffix
2225                               (vm-mime-find-filename-suffix-for-type layout)))
2226              (setq basename
2227                    (or (vm-mime-get-disposition-parameter layout "filename")
2228                        (vm-mime-get-parameter layout "name")))
2229              (setq tempfile (vm-make-tempfile suffix basename))
2230              (vm-register-message-garbage-files (list tempfile))
2231              (vm-mime-send-body-to-file layout nil tempfile t)))
2232
2233       ;; quote file name for shell command only
2234       (or (cdr program-list)
2235           (setq tempfile (shell-quote-argument tempfile)))
2236
2237       ;; expand % specs
2238       (let ((p program-list)
2239             (vm-mf-attachment-file tempfile))
2240         (while p
2241           (if (string-match "\\([^%]\\|^\\)%f" (car p))
2242               (setq append-file nil))
2243           (setcar p (vm-mime-sprintf (car p) layout))
2244           (setq p (cdr p))))
2245
2246       (message "Launching %s..." (mapconcat 'identity program-list " "))
2247       (setq process
2248             (if (cdr program-list)
2249                 (apply 'start-process
2250                        (format "view %25s"
2251                                (vm-mime-sprintf
2252                                 (vm-mime-find-format-for-layout layout)
2253                                 layout))
2254                        nil (if append-file
2255                                (append program-list (list tempfile))
2256                              program-list))
2257               (apply 'start-process
2258                      (format "view %25s"
2259                              (vm-mime-sprintf
2260                               (vm-mime-find-format-for-layout layout)
2261                               layout))
2262                      nil
2263                      (or shell-file-name "sh")
2264                      shell-command-switch
2265                      (if append-file
2266                          (list (concat (car program-list) " " tempfile))
2267                        program-list))))
2268       (process-kill-without-query process t)
2269       (message "Launching %s... done" (mapconcat 'identity
2270                                                  program-list
2271                                                  " "))
2272       (if vm-mime-delete-viewer-processes
2273           (vm-register-message-garbage 'delete-process process))
2274       (put (vm-mm-layout-cache layout)
2275            'vm-mime-display-external-generic
2276            (list process tempfile))))
2277   t )
2278
2279 (defun vm-mime-display-internal-application/octet-stream (layout)
2280   (if (vectorp layout)
2281       (let ((buffer-read-only nil)
2282             (vm-mf-default-action "save to a file"))
2283         (vm-mime-insert-button
2284          (vm-mime-sprintf (vm-mime-find-format-for-layout layout) layout)
2285          (function
2286           (lambda (layout)
2287             (save-excursion
2288               (vm-mime-display-internal-application/octet-stream layout))))
2289          layout nil))
2290     (goto-char (vm-extent-start-position layout))
2291     (setq layout (vm-extent-property layout 'vm-mime-layout))
2292     ;; support old "name" paramater for application/octet-stream
2293     ;; but don't override the "filename" parameter extracted from
2294     ;; Content-Disposition, if any.
2295     (let ((default-filename
2296             (if (vm-mime-get-disposition-parameter layout "filename")
2297                 nil
2298               (vm-mime-get-parameter layout "name")))
2299           (file nil))
2300       (setq file (vm-mime-send-body-to-file layout default-filename))
2301       (if vm-mime-delete-after-saving
2302           (let ((vm-mime-confirm-delete nil))
2303             ;; we don't care if the delete fails
2304             (condition-case nil
2305                 (vm-delete-mime-object (expand-file-name file))
2306               (error nil))))))
2307   t )
2308 (fset 'vm-mime-display-button-application/octet-stream
2309       'vm-mime-display-internal-application/octet-stream)
2310
2311 (defun vm-mime-display-button-application (layout)
2312   (vm-mime-display-button-xxxx layout nil))
2313
2314 (defun vm-mime-display-button-image (layout)
2315   (vm-mime-display-button-xxxx layout t))
2316
2317 (defun vm-mime-display-button-audio (layout)
2318   (vm-mime-display-button-xxxx layout nil))
2319
2320 (defun vm-mime-display-button-video (layout)
2321   (vm-mime-display-button-xxxx layout t))
2322
2323 (defun vm-mime-display-button-message (layout)
2324   (vm-mime-display-button-xxxx layout t))
2325
2326 (defun vm-mime-display-button-multipart (layout)
2327   (vm-mime-display-button-xxxx layout t))
2328
2329 (defun vm-mime-display-internal-multipart/mixed (layout)
2330   (let ((part-list (vm-mm-layout-parts layout)))
2331     (while part-list
2332       (vm-decode-mime-layout (car part-list))
2333       (setq part-list (cdr part-list)))
2334     t ))
2335
2336 (defun vm-mime-display-internal-multipart/alternative (layout)
2337   (if vm-mime-show-alternatives
2338       (let ((vm-mime-show-alternatives 'mixed))
2339         (vm-mime-display-internal-multipart/mixed layout))
2340     (vm-mime-display-internal-show-multipart/alternative layout)))
2341
2342 (defun vm-mime-display-internal-show-multipart/alternative (layout)
2343   (let (best-layout)
2344     (cond ((eq vm-mime-alternative-select-method 'best)
2345            (let ((done nil)
2346                  (best nil)
2347                  part-list type)
2348              (setq part-list (vm-mm-layout-parts layout)
2349                    part-list (nreverse (copy-sequence part-list)))
2350              (while (and part-list (not done))
2351                (setq type (car (vm-mm-layout-type (car part-list))))
2352                (if (or (vm-mime-can-display-internal (car part-list) t)
2353                        (vm-mime-find-external-viewer type))
2354                    (setq best (car part-list)
2355                          done t)
2356                  (setq part-list (cdr part-list))))
2357              (setq best-layout (or best (car (vm-mm-layout-parts layout))))))
2358           ((eq vm-mime-alternative-select-method 'best-internal)
2359            (let ((done nil)
2360                  (best nil)
2361                  (second-best nil)
2362                  part-list type)
2363              (setq part-list (vm-mm-layout-parts layout)
2364                    part-list (nreverse (copy-sequence part-list)))
2365              (while (and part-list (not done))
2366                (setq type (car (vm-mm-layout-type (car part-list))))
2367                (cond ((and (vm-mime-can-display-internal (car part-list) t)
2368                            (vm-mime-should-display-internal (car part-list)))
2369                       (setq best (car part-list)
2370                             done t))
2371                      ((and (null second-best)
2372                            (vm-mime-find-external-viewer type))
2373                       (setq second-best (car part-list))))
2374                (setq part-list (cdr part-list)))
2375              (setq best-layout (or best second-best
2376                                    (car (vm-mm-layout-parts layout))))))
2377           ((and (consp vm-mime-alternative-select-method)
2378                 (eq (car vm-mime-alternative-select-method)
2379                     'favorite-internal))
2380            (let ((done nil)
2381                  (best nil)
2382                  (saved-part-list
2383                   (nreverse (copy-sequence (vm-mm-layout-parts layout))))
2384                  (favs (cdr vm-mime-alternative-select-method))
2385                  (second-best nil)
2386                  part-list type)
2387              (while (and favs (not done))
2388                (setq part-list saved-part-list)
2389                (while (and part-list (not done))
2390                  (setq type (car (vm-mm-layout-type (car part-list))))
2391                  (cond ((or (vm-mime-can-display-internal (car part-list) t)
2392                             (vm-mime-find-external-viewer type))
2393                         (if (vm-mime-types-match (car favs) type)
2394                             (setq best (car part-list)
2395                                   done t)
2396                           (or second-best
2397                               (setq second-best (car part-list))))))
2398                  (setq part-list (cdr part-list)))
2399                (setq favs (cdr favs)))
2400              (setq best-layout (or best second-best
2401                                    (car (vm-mm-layout-parts layout))))))
2402           ((and (consp vm-mime-alternative-select-method)
2403                 (eq (car vm-mime-alternative-select-method) 'favorite))
2404            (let ((done nil)
2405                  (best nil)
2406                  (saved-part-list
2407                   (nreverse (copy-sequence (vm-mm-layout-parts layout))))
2408                  (favs (cdr vm-mime-alternative-select-method))
2409                  (second-best nil)
2410                  part-list type)
2411              (while (and favs (not done))
2412                (setq part-list saved-part-list)
2413                (while (and part-list (not done))
2414                  (setq type (car (vm-mm-layout-type (car part-list))))
2415                  (cond ((and (vm-mime-can-display-internal (car part-list) t)
2416                              (vm-mime-should-display-internal (car part-list)))
2417                         (if (vm-mime-types-match (car favs) type)
2418                             (setq best (car part-list)
2419                                   done t)
2420                           (or second-best
2421                               (setq second-best (car part-list))))))
2422                  (setq part-list (cdr part-list)))
2423                (setq favs (cdr favs)))
2424              (setq best-layout (or best second-best
2425                                    (car (vm-mm-layout-parts layout)))))))
2426     (and best-layout (vm-decode-mime-layout best-layout))))
2427
2428 (defun vm-mime-display-button-multipart/parallel (layout)
2429   (vm-mime-insert-button
2430    (concat
2431     ;; display the file name or disposition
2432     (let ((file (or (vm-mime-get-disposition-parameter layout "filename")
2433                     (vm-mime-get-parameter layout "name"))))
2434       (if file (format " %s " file) ""))
2435     (vm-mime-sprintf (vm-mime-find-format-for-layout layout) layout) )
2436    (function
2437     (lambda (layout)
2438       (save-excursion
2439         (let ((vm-auto-displayed-mime-content-types t)
2440               (vm-auto-displayed-mime-content-type-exceptions nil))
2441           (vm-decode-mime-layout layout t)))))
2442    layout t))
2443
2444 (fset 'vm-mime-display-internal-multipart/parallel
2445       'vm-mime-display-internal-multipart/mixed)
2446
2447 (defun vm-mime-display-internal-multipart/digest (layout)
2448   (if (vectorp layout)
2449       (let ((buffer-read-only nil))
2450         (vm-mime-insert-button
2451          (vm-mime-sprintf (vm-mime-find-format-for-layout layout) layout)
2452          (function
2453           (lambda (layout)
2454             (save-excursion
2455               (vm-mime-display-internal-multipart/digest layout))))
2456          layout nil))
2457     (goto-char (vm-extent-start-position layout))
2458     (setq layout (vm-extent-property layout 'vm-mime-layout))
2459     (set-buffer (generate-new-buffer (format "digest from %s/%s"
2460                                              (buffer-name vm-mail-buffer)
2461                                              (vm-number-of
2462                                               (car vm-message-pointer)))))
2463     (setq vm-folder-type vm-default-folder-type)
2464     (let ((ident-header nil))
2465       (if vm-digest-identifier-header-format
2466           (setq ident-header (vm-summary-sprintf
2467                               vm-digest-identifier-header-format
2468                               (vm-mm-layout-message layout))))
2469       (vm-mime-burst-layout layout ident-header))
2470     (vm-save-buffer-excursion
2471      (vm-goto-new-folder-frame-maybe 'folder)
2472      (vm-mode)
2473      (if (vm-should-generate-summary)
2474          (progn
2475            (vm-goto-new-summary-frame-maybe)
2476            (vm-summarize))))
2477     ;; temp buffer, don't offer to save it.
2478     (setq buffer-offer-save nil)
2479     (vm-display (or vm-presentation-buffer (current-buffer)) t
2480                 (list this-command) '(vm-mode startup)))
2481   t )
2482
2483 (fset 'vm-mime-display-button-multipart/digest
2484       'vm-mime-display-internal-multipart/digest)
2485
2486 (defun vm-mime-display-button-message/rfc822 (layout)
2487   (let ((buffer-read-only nil))
2488     (vm-mime-insert-button
2489      (vm-mime-sprintf (vm-mime-find-format-for-layout layout) layout)
2490      (function
2491       (lambda (layout)
2492         (save-excursion
2493           (vm-mime-display-internal-message/rfc822 layout))))
2494      layout nil)))
2495
2496 (fset 'vm-mime-display-button-message/news
2497       'vm-mime-display-button-message/rfc822)
2498
2499 (defun vm-mime-display-internal-message/rfc822 (layout)
2500   (if (vectorp layout)
2501       (let ((start (point))
2502             (buffer-read-only nil))
2503         (vm-mime-insert-mime-headers (car (vm-mm-layout-parts layout)))
2504         (insert ?\n)
2505         (save-excursion
2506           (goto-char start)
2507           (vm-reorder-message-headers nil vm-visible-headers
2508                                       vm-invisible-header-regexp))
2509         (save-restriction
2510           (narrow-to-region start (point))
2511           (vm-decode-mime-encoded-words))
2512         (vm-mime-display-internal-multipart/mixed layout))
2513     (goto-char (vm-extent-start-position layout))
2514     (setq layout (vm-extent-property layout 'vm-mime-layout))
2515     (set-buffer (generate-new-buffer
2516                  (format "message from %s/%s"
2517                          (buffer-name vm-mail-buffer)
2518                          (vm-number-of
2519                           (car vm-message-pointer)))))
2520     (if vm-fsfemacs-mule-p
2521         (set-buffer-multibyte nil))
2522     (setq vm-folder-type vm-default-folder-type)
2523     (vm-mime-burst-layout layout nil)
2524     (set-buffer-modified-p nil)
2525     (vm-save-buffer-excursion
2526      (vm-goto-new-folder-frame-maybe 'folder)
2527      (vm-mode)
2528      (if (vm-should-generate-summary)
2529          (progn
2530            (vm-goto-new-summary-frame-maybe)
2531            (vm-summarize))))
2532     ;; temp buffer, don't offer to save it.
2533     (setq buffer-offer-save nil)
2534     (vm-display (or vm-presentation-buffer (current-buffer)) t
2535                 (list this-command) '(vm-mode startup)))
2536   t )
2537 (fset 'vm-mime-display-internal-message/news
2538       'vm-mime-display-internal-message/rfc822)
2539
2540 (defun vm-mime-display-internal-message/delivery-status (layout)
2541   (vm-mime-display-internal-text/plain layout t))
2542
2543 (defun vm-mime-retrieve-external-body (layout)
2544   "Fetch an external body into the current buffer.
2545 LAYOUT is the MIME layout struct for the message/external-body object."
2546   (let ((access-method (downcase (vm-mime-get-parameter layout "access-type")))
2547         (work-buffer (current-buffer)))
2548     (cond ((string= access-method "local-file")
2549            (let ((name (vm-mime-get-parameter layout "name")))
2550              (if (null name)
2551                  (vm-mime-error
2552                   "%s access type missing `name' parameter"
2553                   access-method))
2554              (if (not (file-exists-p name))
2555                  (vm-mime-error "file %s does not exist" name))
2556              (condition-case data
2557                  (insert-file-contents name)
2558                (error (signal 'vm-mime-error (cdr data))))))
2559           ((and (string= access-method "url")
2560                 vm-url-retrieval-methods)
2561            (defvar w3-configuration-directory) ; for bytecompiler
2562            (let ((url (vm-mime-get-parameter layout "url"))
2563                  ;; needed or url-retrieve will bitch
2564                  (w3-configuration-directory
2565                   (if (boundp 'w3-configuration-directory)
2566                       w3-configuration-directory
2567                     "~")))
2568              (if (null url)
2569                  (vm-mime-error
2570                   "%s access type missing `url' parameter"
2571                   access-method))
2572              (setq url (vm-with-string-as-temp-buffer
2573                         url
2574                         (function
2575                          (lambda ()
2576                            (goto-char (point-min))
2577                            (while (re-search-forward "[ \t\n]" nil t)
2578                              (delete-char -1))))))
2579              (vm-mime-fetch-url-with-programs url work-buffer)))
2580           ((and (or (string= access-method "ftp")
2581                     (string= access-method "anon-ftp"))
2582                 (or (fboundp 'efs-file-handler-function)
2583                     (fboundp 'ange-ftp-hook-function)))
2584            (let ((name (vm-mime-get-parameter layout "name"))
2585                  (directory (vm-mime-get-parameter layout "directory"))
2586                  (site (vm-mime-get-parameter layout "site"))
2587                  user)
2588              (if (null name)
2589                  (vm-mime-error
2590                   "%s access type missing `name' parameter"
2591                   access-method))
2592              (if (null site)
2593                  (vm-mime-error
2594                   "%s access type missing `site' parameter"
2595                   access-method))
2596              (cond ((string= access-method "ftp")
2597                     (setq user (read-string
2598                                 (format "User name to access %s: "
2599                                         site)
2600                                 (user-login-name))))
2601                    (t (setq user "anonymous")))
2602              (if (and (string= access-method "ftp")
2603                       vm-url-retrieval-methods
2604                       (vm-mime-fetch-url-with-programs
2605                        (if directory
2606                            (concat "ftp:////" site "/"
2607                                    directory "/" name)
2608                          (concat "ftp:////" site "/" name))
2609                        work-buffer))
2610                  t
2611                (cond (directory
2612                       (setq directory
2613                             (concat "/" user "@" site ":" directory))
2614                       (setq name (expand-file-name name directory)))
2615                      (t
2616                       (setq name (concat "/" user "@" site ":"
2617                                          name))))
2618                (condition-case data
2619                    (insert-file-contents name)
2620                  (error (signal 'vm-mime-error
2621                                 (format "%s" (cdr data)))))))))))
2622
2623
2624 (defun vm-mime-display-internal-message/external-body (layout)
2625   (let ((child-layout (car (vm-mm-layout-parts layout)))
2626         (access-method (downcase (vm-mime-get-parameter layout "access-type")))
2627         ob
2628         (work-buffer nil))
2629     ;; Normal objects have the header and body in the same
2630     ;; buffer.  A retrieved external-body has the body in a
2631     ;; different buffer from the header, so we use this as an
2632     ;; indicator of whether the retrieval work has been dnoe
2633     ;; yet.
2634     (unwind-protect
2635         (cond
2636          ((and (eq access-method "mail-server")
2637                (vm-mm-layout-id child-layout)
2638                (setq ob (vm-mime-find-leaf-content-id-in-layout-folder
2639                          layout (vm-mm-layout-id child-layout))))
2640           (setq child-layout ob))
2641          ((eq (marker-buffer (vm-mm-layout-header-start child-layout))
2642               (marker-buffer (vm-mm-layout-body-start child-layout)))
2643           (condition-case data
2644               (save-excursion
2645                 (setq work-buffer
2646                       (vm-make-multibyte-work-buffer
2647                        (format "*%s mime object*"
2648                                (car (vm-mm-layout-type child-layout)))))
2649                 (set-buffer work-buffer)
2650                 (if (fboundp 'set-buffer-file-coding-system)
2651                     (set-buffer-file-coding-system
2652                      (vm-binary-coding-system) t))
2653                 (cond
2654                  ((or (string= access-method "ftp")
2655                       (string= access-method "anon-ftp")
2656                       (string= access-method "local-file")
2657                       (string= access-method "url"))
2658                   (vm-mime-retrieve-external-body layout))
2659                  ((string= access-method "mail-server")
2660                   (let ((server (vm-mime-get-parameter layout "server"))
2661                         (subject (vm-mime-get-parameter layout "subject")))
2662                     (if (null server)
2663                         (vm-mime-error
2664                          "%s access type missing `server' parameter"
2665                          access-method))
2666                     (if (not
2667                          (y-or-n-p
2668                           (format
2669                            "Send message to %s to retrieve external body? "
2670                            server)))
2671                         (error "Aborted"))
2672                     (vm-mail-internal
2673                      (format "mail to MIME mail server %s" server)
2674                      server subject)
2675                     (mail-text)
2676                     (vm-mime-insert-mime-body child-layout)
2677                     (let ((vm-confirm-mail-send nil))
2678                       (vm-mail-send))
2679                     (message "Retrieval message sent.  Retry viewing this object after the response arrives.")
2680                     (sleep-for 2)))
2681                  (t
2682                   (vm-mime-error "unsupported access method: %s"
2683                                  access-method)))
2684                 (cond (child-layout
2685                        (setq work-buffer nil)
2686                        (vm-set-mm-layout-body-end child-layout
2687                                                   (vm-marker (point-max)))
2688                        (vm-set-mm-layout-body-start child-layout
2689                                                     (vm-marker
2690                                                      (point-min))))))
2691             (vm-mime-error
2692              (vm-set-mm-layout-display-error layout (cdr data))
2693              (setq child-layout nil)))))
2694       (and work-buffer (kill-buffer work-buffer)))
2695     (and child-layout (vm-decode-mime-layout child-layout))))
2696
2697 (defun vm-mime-fetch-url-with-programs (url buffer)
2698   (and
2699    (eq t (cond ((if (and (memq 'wget vm-url-retrieval-methods)
2700                          (condition-case data
2701                              (vm-run-command-on-region (point) (point)
2702                                                        buffer
2703                                                        vm-wget-program
2704                                                        "-q" "-O" "-" url)
2705                            (error nil)))
2706                     t
2707                   (save-excursion
2708                     (set-buffer buffer)
2709                     (erase-buffer)
2710                     nil )))
2711                ((if (and (memq 'w3m vm-url-retrieval-methods)
2712                          (condition-case data
2713                              (vm-run-command-on-region (point) (point)
2714                                                        buffer
2715                                                        vm-w3m-program
2716                                                        "-dump_source" url)
2717                            (error nil)))
2718                     t
2719                   (save-excursion
2720                     (set-buffer buffer)
2721                     (erase-buffer)
2722                     nil )))
2723                ((if (and (memq 'fetch vm-url-retrieval-methods)
2724                          (condition-case data
2725                              (vm-run-command-on-region (point) (point)
2726                                                        buffer
2727                                                        vm-fetch-program
2728                                                        "-o" "-" url)
2729                            (error nil)))
2730                     t
2731                   (save-excursion
2732                     (set-buffer buffer)
2733                     (erase-buffer)
2734                     nil )))
2735                ((if (and (memq 'curl vm-url-retrieval-methods)
2736                          (condition-case data
2737                              (vm-run-command-on-region (point) (point)
2738                                                        buffer
2739                                                        vm-curl-program
2740                                                        url)
2741                            (error nil)))
2742                     t
2743                   (save-excursion
2744                     (set-buffer buffer)
2745                     (erase-buffer)
2746                     nil )))
2747                ((if (and (memq 'lynx vm-url-retrieval-methods)
2748                          (condition-case data
2749                              (vm-run-command-on-region (point) (point)
2750                                                        buffer
2751                                                        vm-lynx-program
2752                                                        "-source" url)
2753                            (error nil)))
2754                     t
2755                   (save-excursion
2756                     (set-buffer buffer)
2757                     (erase-buffer)
2758                     nil )))))
2759    (save-excursion
2760      (set-buffer buffer)
2761      (not (zerop (buffer-size))))))
2762
2763 (defun vm-mime-internalize-local-external-bodies (layout)
2764   (cond ((vm-mime-types-match "message/external-body"
2765                               (car (vm-mm-layout-type layout)))
2766          (if (not (string= (downcase
2767                             (vm-mime-get-parameter layout "access-type"))
2768                            "local-file"))
2769              nil
2770            (let ((work-buffer nil))
2771              (unwind-protect
2772                  (let ((child-layout (car (vm-mm-layout-parts layout)))
2773                        oldsize
2774                        (i (1- (length layout))))
2775                    (save-excursion
2776                      (setq work-buffer
2777                            (vm-make-multibyte-work-buffer
2778                             (format "*%s mime object*"
2779                                     (car (vm-mm-layout-type child-layout)))))
2780                      (set-buffer work-buffer)
2781                      (vm-mime-retrieve-external-body layout))
2782                    (goto-char (vm-mm-layout-body-start child-layout))
2783                    (setq oldsize (buffer-size))
2784                    (condition-case data
2785                        (insert-buffer-substring work-buffer)
2786                      (error (signal 'vm-mime-error (cdr data))))
2787                    (goto-char (+ (point) (- (buffer-size) oldsize)))
2788                    (if (< (point) (vm-mm-layout-body-end child-layout))
2789                        (delete-region (point)
2790                                       (vm-mm-layout-body-end child-layout))
2791                      (vm-set-mm-layout-body-end child-layout (point-marker)))
2792                    (delete-region (vm-mm-layout-header-start layout)
2793                                   (vm-mm-layout-body-start layout))
2794                    (while (>= i 0)
2795                      (aset layout i (aref child-layout i))
2796                      (setq i (1- i)))))
2797              (and work-buffer (kill-buffer work-buffer)))))
2798         ((vm-mime-composite-type-p (car (vm-mm-layout-type layout)))
2799          (let ((p (vm-mm-layout-parts layout)))
2800            (while p
2801              (vm-mime-internalize-local-external-bodies (car p))
2802              (setq p (cdr p)))))
2803         (t nil)))
2804
2805 (defun vm-mime-display-internal-message/partial (layout)
2806   (if (vectorp layout)
2807       (let ((buffer-read-only nil))
2808         (vm-mime-insert-button
2809          (vm-mime-sprintf (vm-mime-find-format-for-layout layout) layout)
2810          (function
2811           (lambda (layout)
2812             (save-excursion
2813               (vm-mime-display-internal-message/partial layout))))
2814          layout nil))
2815     (message "Assembling message...")
2816     (let ((parts nil)
2817           (missing nil)
2818           (work-buffer nil)
2819           extent id o number total m i prev part-header-pos
2820           p-id p-number p-total p-list)
2821       (setq extent layout
2822             layout (vm-extent-property extent 'vm-mime-layout)
2823             id (vm-mime-get-parameter layout "id"))
2824       (if (null id)
2825           (vm-mime-error
2826            "message/partial message missing id parameter"))
2827       (save-excursion
2828         (set-buffer (marker-buffer (vm-mm-layout-body-start layout)))
2829         (save-excursion
2830           (save-restriction
2831             (widen)
2832             (goto-char (point-min))
2833             (while (and (search-forward id nil t)
2834                         (setq m (vm-message-at-point)))
2835               (setq o (vm-mm-layout m))
2836               (if (not (vectorp o))
2837                   nil
2838                 (setq p-list (vm-mime-find-message/partials o id))
2839                 (while p-list
2840                   (setq p-id (vm-mime-get-parameter (car p-list) "id"))
2841                   (setq p-total (vm-mime-get-parameter (car p-list) "total"))
2842                   (if (null p-total)
2843                       nil
2844                     (setq p-total (string-to-number p-total))
2845                     (if (< p-total 1)
2846                         (vm-mime-error "message/partial specified part total < 1, %d" p-total))
2847                     (if total
2848                         (if (not (= total p-total))
2849                             (vm-mime-error "message/partial specified total differs between parts, (%d != %d)" p-total total))
2850                       (setq total p-total)))
2851                   (setq p-number (vm-mime-get-parameter (car p-list) "number"))
2852                   (if (null p-number)
2853                       (vm-mime-error
2854                        "message/partial message missing number parameter"))
2855                   (setq p-number (string-to-number p-number))
2856                   (if (< p-number 1)
2857                       (vm-mime-error "message/partial part number < 1, %d"
2858                                      p-number))
2859                   (if (and total (> p-number total))
2860                       (vm-mime-error "message/partial part number greater than expected number of parts, (%d > %d)" p-number total))
2861                   (setq parts (cons (list p-number (car p-list)) parts)
2862                         p-list (cdr p-list))))
2863               (goto-char (vm-mm-layout-body-end o))))))
2864       (if (null total)
2865           (vm-mime-error "total number of parts not specified in any message/partial part"))
2866       (setq parts (sort parts
2867                         (function
2868                          (lambda (p q)
2869                            (< (car p)
2870                               (car q))))))
2871       (setq i 0
2872             p-list parts)
2873       (while p-list
2874         (cond ((< i (car (car p-list)))
2875                (vm-increment i)
2876                (cond ((not (= i (car (car p-list))))
2877                       (setq missing (cons i missing)))
2878                      (t (setq prev p-list
2879                               p-list (cdr p-list)))))
2880               (t
2881                ;; remove duplicate part
2882                (setcdr prev (cdr p-list))
2883                (setq p-list (cdr p-list)))))
2884       (while (< i total)
2885         (vm-increment i)
2886         (setq missing (cons i missing)))
2887       (if missing
2888           (vm-mime-error "part%s %s%s missing"
2889                          (if (cdr missing) "s" "")
2890                          (mapconcat
2891                           (function identity)
2892                           (nreverse (mapcar 'int-to-string
2893                                             (or (cdr missing) missing)))
2894                           ", ")
2895                          (if (cdr missing)
2896                              (concat " and " (car missing))
2897                            "")))
2898       (set-buffer (generate-new-buffer "assembled message"))
2899       (if vm-fsfemacs-mule-p
2900           (set-buffer-multibyte nil))
2901       (setq vm-folder-type vm-default-folder-type)
2902       (vm-mime-insert-mime-headers (car (cdr (car parts))))
2903       (goto-char (point-min))
2904       (vm-reorder-message-headers
2905        nil nil
2906 "\\(Encrypted\\|Content-\\|MIME-Version\\|Message-ID\\|Subject\\|X-VM-\\|Status\\)")
2907       (goto-char (point-max))
2908       (setq part-header-pos (point))
2909       (while parts
2910         (vm-mime-insert-mime-body (car (cdr (car parts))))
2911         (setq parts (cdr parts)))
2912       (goto-char part-header-pos)
2913       (vm-reorder-message-headers
2914        nil '("Subject" "MIME-Version" "Content-" "Message-ID" "Encrypted") nil)
2915       (vm-munge-message-separators vm-folder-type (point-min) (point-max))
2916       (goto-char (point-min))
2917       (insert (vm-leading-message-separator))
2918       (goto-char (point-max))
2919       (insert (vm-trailing-message-separator))
2920       (set-buffer-modified-p nil)
2921       (message "Assembling message... done")
2922       (vm-save-buffer-excursion
2923        (vm-goto-new-folder-frame-maybe 'folder)
2924        (vm-mode)
2925        (if (vm-should-generate-summary)
2926            (progn
2927              (vm-goto-new-summary-frame-maybe)
2928              (vm-summarize))))
2929       ;; temp buffer, don't offer to save it.
2930       (setq buffer-offer-save nil)
2931       (vm-display (or vm-presentation-buffer (current-buffer)) t
2932                   (list this-command) '(vm-mode startup)))
2933     t ))
2934 (fset 'vm-mime-display-button-message/partial
2935       'vm-mime-display-internal-message/partial)
2936
2937 (defun vm-mime-display-internal-image-xxxx (layout image-type name)
2938   (cond
2939    (vm-xemacs-p
2940     (vm-mime-display-internal-image-xemacs-xxxx layout image-type name))
2941    ((and vm-fsfemacs-p (fboundp 'image-type-available-p))
2942     (vm-mime-display-internal-image-fsfemacs-21-xxxx layout image-type name))
2943    (vm-fsfemacs-p
2944     (vm-mime-display-internal-image-fsfemacs-19-xxxx layout image-type name))))
2945
2946 (defun vm-mime-display-internal-image-xemacs-xxxx (layout image-type name)
2947   (if (and (vm-images-possible-here-p)
2948            (vm-image-type-available-p image-type))
2949       (let ((start (point-marker)) end tempfile g e
2950             (selective-display nil)
2951             (incremental vm-mime-display-image-strips-incrementally)
2952             do-strips
2953             (keymap (make-sparse-keymap))
2954             (buffer-read-only nil))
2955         (if (and (setq tempfile (get (vm-mm-layout-cache layout)
2956                                      'vm-mime-display-internal-image-xxxx))
2957                  (file-readable-p tempfile))
2958             nil
2959           (vm-mime-insert-mime-body layout)
2960           (setq end (point-marker))
2961           (vm-mime-transfer-decode-region layout start end)
2962           (setq tempfile (vm-make-tempfile))
2963           (vm-register-folder-garbage-files (list tempfile))
2964           ;; coding system for presentation buffer is binary so
2965           ;; we don't need to set it here.
2966           (write-region start end tempfile nil 0)
2967           (put (vm-mm-layout-cache layout)
2968                'vm-mime-display-internal-image-xxxx
2969                tempfile)
2970           (delete-region start end))
2971         (if (not (bolp))
2972             (insert "\n"))
2973         (setq do-strips (and (stringp vm-imagemagick-convert-program)
2974                              vm-mime-use-image-strips))
2975         (cond (do-strips
2976                (condition-case error-data
2977                    (let ((strips (vm-make-image-strips tempfile
2978                                                        (* 2 (font-height
2979                                                         (face-font 'default)))
2980                                                        image-type
2981                                                        t incremental))
2982                          process image-list extent-list
2983                          start
2984                          (first t))
2985                      (define-key keymap 'button3 'vm-menu-popup-image-menu)
2986                      (setq process (car strips)
2987                            strips (cdr strips)
2988                            image-list strips)
2989                      (vm-register-message-garbage-files strips)
2990                      (setq start (point))
2991                      (while strips
2992                        (setq g (make-glyph
2993                                 (list
2994                                  (cons nil
2995                                        (vector 'string
2996                                                ':data
2997                                                (if (or first
2998                                                        (null (cdr strips)))
2999                                                    (progn
3000                                                      (setq first nil)
3001                                                      "+-----+")
3002                                                  "|image|"))))))
3003                        (insert " \n")
3004                        (setq e (vm-make-extent (- (point) 2) (1- (point))))
3005                        (vm-set-extent-property e 'begin-glyph g)
3006                        (vm-set-extent-property e 'start-open t)
3007                        (vm-set-extent-property e 'keymap keymap)
3008                        (setq extent-list (cons e extent-list))
3009                        (setq strips (cdr strips)))
3010                      (setq e (make-extent start (point)))
3011                      (vm-set-extent-property e 'start-open t)
3012                      (vm-set-extent-property e 'vm-mime-layout layout)
3013                      (vm-set-extent-property e 'vm-mime-disposable t)
3014                      (vm-set-extent-property e 'keymap keymap)
3015                      (save-excursion
3016                        (set-buffer (process-buffer process))
3017                        (set (make-local-variable 'vm-image-list) image-list)
3018                        (set (make-local-variable 'vm-image-type) image-type)
3019                        (set (make-local-variable 'vm-image-type-name)
3020                             name)
3021                        (set (make-local-variable 'vm-extent-list)
3022                             (nreverse extent-list)))
3023                      (if incremental
3024                          (set-process-filter
3025                           process
3026                           'vm-process-filter-display-some-image-strips))
3027                      (set-process-sentinel
3028                       process
3029                       'vm-process-sentinel-display-image-strips))
3030                  (vm-image-too-small
3031                   (setq do-strips nil))
3032                  (error
3033                   (message "Failed making image strips: %s" error-data)
3034                   ;; fallback to the non-strips way
3035                   (setq do-strips nil)))))
3036         (cond ((not do-strips)
3037                (message "Creating %s glyph..." name)
3038                (setq g (make-glyph
3039                         (list
3040                          (cons (list 'win)
3041                                (vector image-type ':file tempfile))
3042                          (cons (list 'win)
3043                                (vector 'string
3044                                        ':data
3045                                        (format "[Unknown/Bad %s image encoding]"
3046                                                name)))
3047                          (cons nil
3048                                (vector 'string
3049                                        ':data
3050                                        (format "[%s image]\n" name))))))
3051                (message "")
3052                ;; XEmacs 21.2 can pixel scroll images (sort of)
3053                ;; if the entire image is above the baseline.
3054                (set-glyph-baseline g 100)
3055                (if (memq image-type '(xbm))
3056                    (set-glyph-face g 'vm-monochrome-image))
3057                (insert " \n")
3058                (define-key keymap 'button3 'vm-menu-popup-image-menu)
3059                (setq e (vm-make-extent (- (point) 2) (1- (point))))
3060                (vm-set-extent-property e 'keymap keymap)
3061                (vm-set-extent-property e 'begin-glyph g)
3062                (vm-set-extent-property e 'vm-mime-layout layout)
3063                (vm-set-extent-property e 'vm-mime-disposable t)
3064                (vm-set-extent-property e 'start-open t)))
3065         t )))
3066
3067 (defvar vm-menu-fsfemacs-image-menu)
3068
3069 (defun vm-mime-display-internal-image-fsfemacs-21-xxxx (layout image-type name)
3070   (if (and (vm-images-possible-here-p)
3071            (vm-image-type-available-p image-type))
3072       (let (start end tempfile image work-buffer
3073             (selective-display nil)
3074             (incremental vm-mime-display-image-strips-incrementally)
3075             do-strips
3076             (buffer-read-only nil))
3077         (if (and (setq tempfile (get (vm-mm-layout-cache layout)
3078                                      'vm-mime-display-internal-image-xxxx))
3079                  (file-readable-p tempfile))
3080             nil
3081           (unwind-protect
3082               (progn
3083                 (save-excursion
3084                   (setq work-buffer (vm-make-work-buffer))
3085                   (set-buffer work-buffer)
3086                   (setq start (point))
3087                   (vm-mime-insert-mime-body layout)
3088                   (setq end (point-marker))
3089                   (vm-mime-transfer-decode-region layout start end)
3090                   (setq tempfile (vm-make-tempfile))
3091                   (let ((coding-system-for-write (vm-binary-coding-system)))
3092                     (write-region start end tempfile nil 0))
3093                   (put (vm-mm-layout-cache layout)
3094                        'vm-mime-display-internal-image-xxxx
3095                        tempfile))
3096                 (vm-register-folder-garbage-files (list tempfile)))
3097             (and work-buffer (kill-buffer work-buffer))))
3098         (if (not (bolp))
3099             (insert-char ?\n 1))
3100         (setq do-strips (and (stringp vm-imagemagick-convert-program)
3101                              vm-mime-use-image-strips))
3102         (cond (do-strips
3103                (condition-case error-data
3104                    (let ((strips (vm-make-image-strips
3105                                   tempfile
3106                                   (* 2 (frame-char-height))
3107                                   image-type t incremental))
3108                          (first t)
3109                          start o process image-list overlay-list)
3110                      (setq process (car strips)
3111                            strips (cdr strips)
3112                            image-list strips)
3113                      (vm-register-message-garbage-files strips)
3114                      (setq start (point))
3115                      (while strips
3116                        (if (or first (null (cdr strips)))
3117                            (progn
3118                              (setq first nil)
3119                              (insert "+-----+"))
3120                          (insert "|image|"))
3121                        (setq o (make-overlay (- (point) 7) (point)))
3122                        (overlay-put o 'evaporate t)
3123                        (setq overlay-list (cons o overlay-list))
3124                        (insert "\n")
3125                        (setq strips (cdr strips)))
3126                      (setq o (make-overlay start (point) nil t nil))
3127                      (overlay-put o 'vm-mime-layout layout)
3128                      (overlay-put o 'vm-mime-disposable t)
3129                      (if vm-use-menus
3130                          (overlay-put o 'vm-image vm-menu-fsfemacs-image-menu))
3131                      (save-excursion
3132                        (set-buffer (process-buffer process))
3133                        (set (make-local-variable 'vm-image-list) image-list)
3134                        (set (make-local-variable 'vm-image-type) image-type)
3135                        (set (make-local-variable 'vm-image-type-name)
3136                             name)
3137                        (set (make-local-variable 'vm-overlay-list)
3138                             (nreverse overlay-list)))
3139                      (if incremental
3140                          (set-process-filter
3141                           process
3142                           'vm-process-filter-display-some-image-strips))
3143                      (set-process-sentinel
3144                       process
3145                       'vm-process-sentinel-display-image-strips))
3146                  (vm-image-too-small
3147                   (setq do-strips nil))
3148                  (error
3149                   (message "Failed making image strips: %s" error-data)
3150                   ;; fallback to the non-strips way
3151                   (setq do-strips nil)))))
3152         (cond ((not do-strips)
3153                (setq image (list 'image ':type image-type ':file tempfile))
3154                ;; insert one char so we can attach the image to it.
3155                (insert "z")
3156                (put-text-property (1- (point)) (point) 'display image)
3157                (clear-image-cache t)
3158                (let (o)
3159                  (setq o (make-overlay (- (point) 1) (point) nil t nil))
3160                  (overlay-put o 'evaporate t)
3161                  (overlay-put o 'vm-mime-layout layout)
3162                  (overlay-put o 'vm-mime-disposable t)
3163                  (if vm-use-menus
3164                      (overlay-put o 'vm-image vm-menu-fsfemacs-image-menu)))))
3165         t )
3166     nil ))
3167
3168 (defun vm-mime-display-internal-image-fsfemacs-19-xxxx (layout image-type name)
3169   (if (and (vm-images-possible-here-p)
3170            (vm-image-type-available-p image-type))
3171       (catch 'done
3172         (let ((selective-display nil)
3173               start end origfile workfile image work-buffer
3174               (hroll (if vm-fsfemacs-mule-p
3175                          (+ (cdr (assq 'internal-border-width
3176                                        (frame-parameters)))
3177                             (if (memq (cdr (assq 'vertical-scroll-bars
3178                                                  (frame-parameters)))
3179                                       '(t left))
3180                                 (vm-fsfemacs-scroll-bar-width)
3181                               0))
3182                        (cdr (assq 'internal-border-width
3183                                   (frame-parameters)))))
3184               (vroll (cdr (assq 'internal-border-width (frame-parameters))))
3185               (reverse (eq (cdr (assq 'background-mode (frame-parameters)))
3186                            'dark))
3187               blob strips
3188               dims width height char-width char-height
3189               horiz-pad vert-pad trash-list
3190               (buffer-read-only nil))
3191           (if (and (setq blob (get (vm-mm-layout-cache layout)
3192                                    'vm-mime-display-internal-image-xxxx))
3193                    (file-exists-p (car blob))
3194                    (progn
3195                      (setq origfile (car blob)
3196                            workfile (nth 1 blob)
3197                            width (nth 2 blob)
3198                            height (nth 3 blob)
3199                            char-width (nth 4 blob)
3200                            char-height (nth 5 blob))
3201                      (and (= char-width (frame-char-width))
3202                           (= char-height (frame-char-height)))))
3203               (setq strips (nth 6 blob))
3204             (unwind-protect
3205                 (progn
3206                   (save-excursion
3207                     (setq work-buffer (vm-make-work-buffer))
3208                     (set-buffer work-buffer)
3209                     (if (and origfile (file-exists-p origfile))
3210                         (progn
3211                           (insert-file-contents origfile)
3212                           (setq start (point-min)
3213                                 end (vm-marker (point-max))))
3214                       (setq start (point))
3215                       (vm-mime-insert-mime-body layout)
3216                       (setq end (point-marker))
3217                       (vm-mime-transfer-decode-region layout start end)
3218                       (setq origfile (vm-make-tempfile))
3219                       (setq trash-list (cons origfile trash-list))
3220                       (let ((coding-system-for-write (vm-binary-coding-system)))
3221                         (write-region start end origfile nil 0)))
3222                     (setq dims (condition-case error-data
3223                                    (vm-get-image-dimensions origfile)
3224                                  (error
3225                                   (message "Failed getting image dimensions: %s"
3226                                            error-data)
3227                                   (throw 'done nil)))
3228                           width (nth 0 dims)
3229                           height (nth 1 dims)
3230                           char-width (frame-char-width)
3231                           char-height (frame-char-height)
3232                           horiz-pad (if (< width char-width)
3233                                         (- char-width width)
3234                                       (% width char-width))
3235                           horiz-pad (if (zerop horiz-pad)
3236                                         horiz-pad
3237                                       (- char-width horiz-pad))
3238                           vert-pad (if (< height char-height)
3239                                        (- char-height height)
3240                                      (% height char-height))
3241                           vert-pad (if (zerop vert-pad)
3242                                        vert-pad
3243                                      (- char-height vert-pad)))
3244                     ;; crop one line from the bottom of the image
3245                     ;; if vertical padding needed is odd so that
3246                     ;; the image height plus the padding will be an
3247                     ;; exact multiple of the char height.
3248                     (if (not (zerop (% vert-pad 2)))
3249                         (setq height (1- height)
3250                               vert-pad (1+ vert-pad)))
3251                     (call-process-region start end
3252                                          vm-imagemagick-convert-program
3253                                          t t nil
3254                                          (if reverse "-negate" "-matte")
3255                                          "-crop"
3256                                          (format "%dx%d+0+0" width height)
3257                                          "-page"
3258                                          (format "%dx%d+0+0" width height)
3259                                          "-mattecolor" "white"
3260                                          "-frame"
3261                                          (format "%dx%d+0+0"
3262                                                  (/ (1+ horiz-pad) 2)
3263                                                  (/ vert-pad 2))
3264                                          "-"
3265                                          "-")
3266                     (setq width (+ width (* 2 (/ (1+ horiz-pad) 2)))
3267                           height (+ height (* 2 (/ vert-pad 2))))
3268                     (if (null workfile)
3269                         (setq workfile (vm-make-tempfile)
3270                               trash-list (cons workfile trash-list)))
3271                     (let ((coding-system-for-write (vm-binary-coding-system)))
3272                       (write-region (point-min) (point-max) workfile nil 0))
3273                     (put (vm-mm-layout-cache layout)
3274                          'vm-mime-display-internal-image-xxxx
3275                          (list origfile workfile width height
3276                                char-width char-height)))
3277                   (and trash-list
3278                        (vm-register-folder-garbage-files trash-list)))
3279               (and work-buffer (kill-buffer work-buffer))))
3280           (if (not (bolp))
3281               (insert-char ?\n 1))
3282           (condition-case error-data
3283               (let (o i-start start process image-list overlay-list)
3284                 (if (and strips (file-exists-p (car strips)))
3285                     (setq image-list strips)
3286                   (setq strips (vm-make-image-strips workfile char-height
3287                                                      image-type t nil
3288                                                      hroll vroll)
3289                         process (car strips)
3290                         strips (cdr strips)
3291                         image-list strips)
3292                   (put (vm-mm-layout-cache layout)
3293                        'vm-mime-display-internal-image-xxxx
3294                        (list origfile workfile width height
3295                              char-width char-height
3296                              strips))
3297                   (vm-register-message-garbage-files strips))
3298                 (setq i-start (point))
3299                 (while strips
3300                   (setq start (point))
3301                   (insert-char ?\  (/ width char-width))
3302                   (put-text-property start (point) 'face 'vm-image-placeholder)
3303                   (setq o (make-overlay start (point) nil t))
3304                   (overlay-put o 'evaporate t)
3305                   (setq overlay-list (cons o overlay-list))
3306                   (insert "\n")
3307                   (setq strips (cdr strips)))
3308                 (setq o (make-overlay i-start (point) nil t nil))
3309                 (overlay-put o 'vm-mime-layout layout)
3310                 (overlay-put o 'vm-mime-disposable t)
3311                 (if vm-use-menus
3312                     (overlay-put o 'vm-image vm-menu-fsfemacs-image-menu))
3313                 (if process
3314                     (save-excursion
3315                       (set-buffer (process-buffer process))
3316                       (set (make-local-variable 'vm-image-list) image-list)
3317                       (set (make-local-variable 'vm-image-type) image-type)
3318                       (set (make-local-variable 'vm-image-type-name)
3319                            name)
3320                       (set (make-local-variable 'vm-overlay-list)
3321                            (nreverse overlay-list))
3322                       ;; incremental strip display intentionally
3323                       ;; omitted because it makes the Emacs 19
3324                       ;; display completely repaint for each new
3325                       ;; strip.
3326                       (set-process-sentinel
3327                        process
3328                        'vm-process-sentinel-display-image-strips))
3329                   (vm-display-image-strips-on-overlay-regions image-list
3330                                                               (nreverse
3331                                                                overlay-list)
3332                                                               image-type)))
3333             (error
3334              (message "Failed making image strips: %s" error-data)))
3335           t ))
3336     nil ))
3337
3338 (defun vm-get-image-dimensions (file)
3339   (let (work-buffer width height)
3340     (unwind-protect
3341         (save-excursion
3342           (setq work-buffer (vm-make-work-buffer))
3343           (set-buffer work-buffer)
3344           (call-process vm-imagemagick-identify-program nil t nil file)
3345           (goto-char (point-min))
3346           (or (search-forward " " nil t)
3347               (error "no spaces in 'identify' output: %s"
3348                      (buffer-string)))
3349           (if (not (re-search-forward "\\b\\([0-9]+\\)x\\([0-9]+\\)\\b" nil t))
3350               (error "file dimensions missing from 'identify' output: %s"
3351                      (buffer-string)))
3352           (setq width (string-to-number (match-string 1))
3353                 height (string-to-number (match-string 2))))
3354       (and work-buffer (kill-buffer work-buffer)))
3355     (list width height)))
3356
3357 (defun vm-imagemagick-type-indicator-for (image-type)
3358   (cond ((eq image-type 'jpeg) "jpeg:")
3359         ((eq image-type 'gif) "gif:")
3360         ((eq image-type 'png) "png:")
3361         ((eq image-type 'tiff) "tiff:")
3362         ((eq image-type 'xpm) "xpm:")
3363         ((eq image-type 'pbm) "pbm:")
3364         ((eq image-type 'xbm) "xbm:")
3365         (t "")))
3366
3367 (defun vm-make-image-strips (file min-height image-type async incremental
3368                                   &optional hroll vroll)
3369   (or hroll (setq hroll 0))
3370   (or vroll (setq vroll 0))
3371   (let ((process-connection-type nil)
3372         (i 0)
3373         (output-type (vm-imagemagick-type-indicator-for image-type))
3374         image-list dimensions width height starty newfile work-buffer
3375         quotient remainder adjustment process)
3376     (setq dimensions (vm-get-image-dimensions file)
3377           width (car dimensions)
3378           height (car (cdr dimensions)))
3379     (if (< height min-height)
3380         (signal 'vm-image-too-small nil))
3381     (setq quotient (/ height min-height)
3382           remainder (% height min-height)
3383           adjustment (/ remainder quotient)
3384           remainder (% remainder quotient)
3385           starty 0)
3386     (unwind-protect
3387         (save-excursion
3388           (setq work-buffer (vm-make-work-buffer))
3389           (set-buffer work-buffer)
3390           (goto-char (point-min))
3391           (while (< starty height)
3392             (setq newfile (vm-make-tempfile))
3393             (if async
3394                 (progn
3395                   (insert vm-imagemagick-convert-program
3396                           " -crop"
3397                           (format " %dx%d+0+%d"
3398                                   width
3399                                   (+ min-height adjustment
3400                                      (if (zerop remainder) 0 1))
3401                                   starty)
3402                           " -page"
3403                           (format " %dx%d+0+0"
3404                                   width
3405                                   (+ min-height adjustment
3406                                      (if (zerop remainder) 0 1)))
3407                           (format " -roll +%d+%d" hroll vroll)
3408                           " \"" file "\" \"" output-type newfile "\"\n")
3409                   (if incremental
3410                       (progn
3411                         (insert "echo XZXX" (int-to-string i) "XZXX\n")))
3412                   (setq i (1+ i)))
3413               (call-process vm-imagemagick-convert-program nil nil nil
3414                             "-crop"
3415                             (format "%dx%d+0+%d"
3416                                     width
3417                                     (+ min-height adjustment
3418                                        (if (zerop remainder) 0 1))
3419                                     starty)
3420                             "-page"
3421                             (format "%dx%d+0+0"
3422                                     width
3423                                     (+ min-height adjustment
3424                                        (if (zerop remainder) 0 1)))
3425                             "-roll"
3426                             (format "+%d+%d" hroll vroll)
3427                             file (concat output-type newfile)))
3428             (setq image-list (cons newfile image-list)
3429                   starty (+ starty min-height adjustment
3430                             (if (zerop remainder) 0 1))
3431                   remainder (if (= 0 remainder) 0 (1- remainder))))
3432           (if (not async)
3433               nil
3434             (goto-char (point-max))
3435             (insert "exit\n")
3436             (setq process
3437                   (start-process (format "image strip maker for %s" file)
3438                                  (current-buffer)
3439                                  shell-file-name))
3440             (process-send-string process (buffer-string))
3441             (setq work-buffer nil))
3442           (if async
3443               (cons process (nreverse image-list))
3444             (nreverse image-list)))
3445       (and work-buffer (kill-buffer work-buffer)))))
3446
3447 (defvar vm-image-list)
3448 (defvar vm-image-type)
3449 (defvar vm-image-type-name)
3450 (defvar vm-extent-list)
3451 (defvar vm-overlay-list)
3452 (defun vm-process-sentinel-display-image-strips (process what-happened)
3453   (save-excursion
3454     (set-buffer (process-buffer process))
3455     (cond ((and (boundp 'vm-extent-list)
3456                 (boundp 'vm-image-list))
3457            (let ((strips vm-image-list)
3458                  (extents vm-extent-list)
3459                  (image-type vm-image-type)
3460                  (type-name vm-image-type-name))
3461              (vm-display-image-strips-on-extents strips extents image-type
3462                                                  type-name)))
3463           ((and (boundp 'vm-overlay-list)
3464                 (overlay-buffer (car vm-overlay-list))
3465                 (boundp 'vm-image-list))
3466            (let ((strips vm-image-list)
3467                  (overlays vm-overlay-list)
3468                  (image-type vm-image-type))
3469              (vm-display-image-strips-on-overlay-regions strips overlays
3470                                                          image-type))))
3471     (kill-buffer (current-buffer))))
3472
3473 (defun vm-display-image-strips-on-extents (strips extents image-type type-name)
3474   (let (g)
3475     (while (and strips
3476                 (file-exists-p (car strips))
3477                 (extent-live-p (car extents))
3478                 (extent-object (car extents)))
3479       (setq g (make-glyph
3480                (list
3481                 (cons (list 'win)
3482                       (vector image-type ':file (car strips)))
3483                 (cons (list 'win)
3484                       (vector
3485                        'string
3486                        ':data
3487                        (format "[Unknown/Bad %s image encoding]"
3488                                type-name)))
3489                 (cons nil
3490                       (vector 'string
3491                               ':data
3492                               (format "[%s image]\n" type-name))))))
3493       (set-glyph-baseline g 50)
3494       (if (memq image-type '(xbm))
3495           (set-glyph-face g 'vm-monochrome-image))
3496       (set-extent-begin-glyph (car extents) g)
3497       (setq strips (cdr strips)
3498             extents (cdr extents)))))
3499
3500 (defun vm-display-image-strips-on-overlay-regions (strips overlays image-type)
3501   (let (prop value omodified)
3502     (save-excursion
3503       (set-buffer (overlay-buffer (car vm-overlay-list)))
3504       (setq omodified (buffer-modified-p))
3505       (save-restriction
3506         (widen)
3507         (unwind-protect
3508             (let ((buffer-read-only nil))
3509               (if (fboundp 'image-type-available-p)
3510                   (setq prop 'display)
3511                 (setq prop 'face))
3512               (while (and strips
3513                           (file-exists-p (car strips))
3514                           (overlay-end (car overlays)))
3515                 (if (fboundp 'image-type-available-p)
3516                     (setq value (list 'image ':type image-type
3517                                       ':file (car strips)
3518                                       ':ascent 50))
3519                   (setq value (make-face (make-symbol "<vm-image-face>")))
3520                   (set-face-stipple value (car strips)))
3521                 (put-text-property (overlay-start (car overlays))
3522                                    (overlay-end (car overlays))
3523                                    prop value)
3524                 (setq strips (cdr strips)
3525                       overlays (cdr overlays))))
3526           (set-buffer-modified-p omodified))))))
3527
3528 (defun vm-process-filter-display-some-image-strips (process output)
3529   (let (which-strips (i 0))
3530     (while (string-match "XZXX\\([0-9]+\\)XZXX" output i)
3531       (setq which-strips (cons (string-to-number (match-string 1 output))
3532                                which-strips)
3533             i (match-end 0)))
3534     (save-excursion
3535       (set-buffer (process-buffer process))
3536       (cond ((and (boundp 'vm-extent-list)
3537                   (boundp 'vm-image-list))
3538              (let ((strips vm-image-list)
3539                    (extents vm-extent-list)
3540                    (image-type vm-image-type)
3541                    (type-name vm-image-type-name))
3542                (vm-display-some-image-strips-on-extents strips extents
3543                                                         image-type
3544                                                         type-name
3545                                                         which-strips)))
3546             ((and (boundp 'vm-overlay-list)
3547                   (overlay-buffer (car vm-overlay-list))
3548                   (boundp 'vm-image-list))
3549              (let ((strips vm-image-list)
3550                    (overlays vm-overlay-list)
3551                    (image-type vm-image-type))
3552                (vm-display-some-image-strips-on-overlay-regions
3553                 strips overlays image-type which-strips)))))))
3554
3555 (defun vm-display-some-image-strips-on-extents
3556   (strips extents image-type type-name which-strips)
3557   (let (g sss eee)
3558     (while which-strips
3559       (setq sss (nthcdr (car which-strips) strips)
3560             eee (nthcdr (car which-strips) extents))
3561       (cond ((and sss
3562                   (file-exists-p (car sss))
3563                   (extent-live-p (car eee))
3564                   (extent-object (car eee)))
3565              (setq g (make-glyph
3566                       (list
3567                        (cons (list 'win)
3568                              (vector image-type ':file (car sss)))
3569                        (cons (list 'win)
3570                              (vector
3571                               'string
3572                               ':data
3573                               (format "[Unknown/Bad %s image encoding]"
3574                                       type-name)))
3575                        (cons nil
3576                              (vector 'string
3577                                      ':data
3578                                      (format "[%s image]\n" type-name))))))
3579              (set-glyph-baseline g 50)
3580              (if (memq image-type '(xbm))
3581                  (set-glyph-face g 'vm-monochrome-image))
3582              (set-extent-begin-glyph (car eee) g)))
3583       (setq which-strips (cdr which-strips)))))
3584
3585 (defun vm-display-some-image-strips-on-overlay-regions
3586   (strips overlays image-type which-strips)
3587   (let (sss ooo prop value omodified)
3588     (save-excursion
3589       (set-buffer (overlay-buffer (car vm-overlay-list)))
3590       (setq omodified (buffer-modified-p))
3591       (save-restriction
3592         (widen)
3593         (unwind-protect
3594             (let ((buffer-read-only nil))
3595               (if (fboundp 'image-type-available-p)
3596                   (setq prop 'display)
3597                 (setq prop 'face))
3598               (while which-strips
3599                 (setq sss (nthcdr (car which-strips) strips)
3600                       ooo (nthcdr (car which-strips) overlays))
3601                 (cond ((and sss
3602                             (file-exists-p (car sss))
3603                             (overlay-end (car ooo)))
3604                        (if (fboundp 'image-type-available-p)
3605                            (setq value (list 'image ':type image-type
3606                                              ':file (car sss)
3607                                              ':ascent 50))
3608                          (setq value (make-face (make-symbol
3609                                                  "<vm-image-face>")))
3610                          (set-face-stipple value (car sss)))
3611                        (put-text-property (overlay-start (car ooo))
3612                                           (overlay-end (car ooo))
3613                                           prop value)))
3614                 (setq which-strips (cdr which-strips))))
3615           (set-buffer-modified-p omodified))))))
3616
3617 (defun vm-mime-display-internal-image/gif (layout)
3618   (vm-mime-display-internal-image-xxxx layout 'gif "GIF"))
3619
3620 (defun vm-mime-display-internal-image/jpeg (layout)
3621   (vm-mime-display-internal-image-xxxx layout 'jpeg "JPEG"))
3622
3623 (defun vm-mime-display-internal-image/png (layout)
3624   (vm-mime-display-internal-image-xxxx layout 'png "PNG"))
3625
3626 (defun vm-mime-display-internal-image/tiff (layout)
3627   (vm-mime-display-internal-image-xxxx layout 'tiff "TIFF"))
3628
3629 (defun vm-mime-display-internal-image/xpm (layout)
3630   (vm-mime-display-internal-image-xxxx layout 'xpm "XPM"))
3631
3632 (defun vm-mime-display-internal-image/pbm (layout)
3633   (vm-mime-display-internal-image-xxxx layout 'pbm "PBM"))
3634
3635 (defun vm-mime-display-internal-image/xbm (layout)
3636   (vm-mime-display-internal-image-xxxx layout 'xbm "XBM"))
3637
3638 (defun vm-mime-frob-image-xxxx (extent &rest convert-args)
3639   (let* ((layout (vm-extent-property extent 'vm-mime-layout))
3640          (blob (get (vm-mm-layout-cache layout)
3641                     'vm-mime-display-internal-image-xxxx))
3642          success tempfile
3643          (work-buffer nil))
3644     ;; Emacs 19 uses a different layout cache than XEmacs or Emacs 21+.
3645     ;; The cache blob is a list in that case.
3646     (if (consp blob)
3647         (setq tempfile (car blob))
3648       (setq tempfile blob))
3649     (unwind-protect
3650         (save-excursion
3651           (setq work-buffer (vm-make-work-buffer))
3652           (set-buffer work-buffer)
3653           (setq success
3654                 (eq 0 (apply 'call-process vm-imagemagick-convert-program
3655                              tempfile t nil
3656                              (append convert-args (list "-" "-")))))
3657           (if success
3658               (progn
3659                 (write-region (point-min) (point-max) tempfile nil 0)
3660                 (if (consp blob)
3661                     (setcar (nthcdr 5 blob) 0))
3662                 (put (vm-mm-layout-cache layout) 'vm-image-modified t))))
3663       (and work-buffer (kill-buffer work-buffer)))
3664     (if success
3665         (progn
3666           (vm-mark-image-tempfile-as-message-garbage-once layout tempfile)
3667           (vm-mime-display-generic extent)))))
3668
3669 (defun vm-mark-image-tempfile-as-message-garbage-once (layout tempfile)
3670   (if (get (vm-mm-layout-cache layout) 'vm-message-garbage)
3671       nil
3672     (vm-register-message-garbage-files (list tempfile))
3673     (put (vm-mm-layout-cache layout) 'vm-message-garbage t)))
3674
3675 (defun vm-mime-rotate-image-left (extent)
3676   (vm-mime-frob-image-xxxx extent "-rotate" "-90"))
3677
3678 (defun vm-mime-rotate-image-right (extent)
3679   (vm-mime-frob-image-xxxx extent "-rotate" "90"))
3680
3681 (defun vm-mime-mirror-image (extent)
3682   (vm-mime-frob-image-xxxx extent "-flop"))
3683
3684 (defun vm-mime-brighten-image (extent)
3685   (vm-mime-frob-image-xxxx extent "-modulate" "115"))
3686
3687 (defun vm-mime-dim-image (extent)
3688   (vm-mime-frob-image-xxxx extent "-modulate" "85"))
3689
3690 (defun vm-mime-monochrome-image (extent)
3691   (vm-mime-frob-image-xxxx extent "-monochrome"))
3692
3693 (defun vm-mime-revert-image (extent)
3694   (let* ((layout (vm-extent-property extent 'vm-mime-layout))
3695          (blob (get (vm-mm-layout-cache layout)
3696                     'vm-mime-display-internal-image-xxxx))
3697          tempfile)
3698     ;; Emacs 19 uses a different layout cache than XEmacs or Emacs 21+.
3699     ;; The cache blob is a list in that case.
3700     (if (consp blob)
3701         (setq tempfile (car blob))
3702       (setq tempfile blob))
3703     (and (stringp tempfile)
3704          (vm-error-free-call 'delete-file tempfile))
3705     (put (vm-mm-layout-cache layout) 'vm-image-modified nil)
3706     (vm-mime-display-generic extent)))
3707
3708 (defun vm-mime-larger-image (extent)
3709   (let* ((layout (vm-extent-property extent 'vm-mime-layout))
3710          (blob (get (vm-mm-layout-cache layout)
3711                     'vm-mime-display-internal-image-xxxx))
3712          dims tempfile)
3713     ;; Emacs 19 uses a different layout cache than XEmacs or Emacs 21+.
3714     ;; The cache blob is a list in that case.
3715     (if (consp blob)
3716         (setq tempfile (car blob))
3717       (setq tempfile blob))
3718     (setq dims (vm-get-image-dimensions tempfile))
3719     (vm-mime-frob-image-xxxx extent
3720                              "-scale"
3721                              (concat (int-to-string (* 2 (car dims)))
3722                                      "x"
3723                                      (int-to-string (* 2 (nth 1 dims)))))))
3724
3725 (defun vm-mime-smaller-image (extent)
3726   (let* ((layout (vm-extent-property extent 'vm-mime-layout))
3727          (blob (get (vm-mm-layout-cache layout)
3728                     'vm-mime-display-internal-image-xxxx))
3729          dims tempfile)
3730     ;; Emacs 19 uses a different layout cache than XEmacs or Emacs 21+.
3731     ;; The cache blob is a list in that case.
3732     (if (consp blob)
3733         (setq tempfile (car blob))
3734       (setq tempfile blob))
3735     (setq dims (vm-get-image-dimensions tempfile))
3736     (vm-mime-frob-image-xxxx extent
3737                              "-scale"
3738                              (concat (int-to-string (/ (car dims) 2))
3739                                      "x"
3740                                      (int-to-string (/ (nth 1 dims) 2))))))
3741
3742 (defun vm-mime-display-internal-audio/basic (layout)
3743   (if (and vm-xemacs-p
3744            (or (featurep 'native-sound)
3745                (featurep 'nas-sound))
3746            (or (device-sound-enabled-p)
3747                (and (featurep 'native-sound)
3748                     (not native-sound-only-on-console)
3749                     (memq (device-type) '(x gtk)))))
3750       (let ((start (point-marker)) end tempfile
3751             (selective-display nil)
3752             (buffer-read-only nil))
3753         (if (setq tempfile (get (vm-mm-layout-cache layout)
3754                                 'vm-mime-display-internal-audio/basic))
3755             nil
3756           (vm-mime-insert-mime-body layout)
3757           (setq end (point-marker))
3758           (vm-mime-transfer-decode-region layout start end)
3759           (setq tempfile (vm-make-tempfile))
3760           (vm-register-folder-garbage-files (list tempfile))
3761           ;; coding system for presentation buffer is binary, so
3762           ;; we don't need to set it here.
3763           (write-region start end tempfile nil 0)
3764           (put (vm-mm-layout-cache layout)
3765                'vm-mime-display-internal-audio/basic
3766                tempfile)
3767           (delete-region start end))
3768         (start-itimer "audioplayer"
3769                       (list 'lambda nil (list 'play-sound-file tempfile))
3770                       1)
3771         t )
3772     nil ))
3773
3774 (defun vm-mime-display-generic (layout)
3775   (save-excursion
3776     (let ((vm-auto-displayed-mime-content-types t)
3777           (vm-auto-displayed-mime-content-type-exceptions nil))
3778       (vm-decode-mime-layout layout t))))
3779
3780 (defun vm-mime-display-button-xxxx (layout disposable)
3781   (vm-mime-insert-button
3782    (vm-mime-sprintf (vm-mime-find-format-for-layout layout) layout)
3783    (function vm-mime-display-generic)
3784    layout disposable))
3785
3786 (defun vm-find-layout-extent-at-point ()
3787   (cond (vm-fsfemacs-p
3788          (let (o-list o retval (found nil))
3789            (setq o-list (overlays-at (point)))
3790            (while (and o-list (not found))
3791              (cond ((overlay-get (car o-list) 'vm-mime-layout)
3792                     (setq found t)
3793                     (setq retval (car o-list))))
3794              (setq o-list (cdr o-list)))
3795            retval ))
3796         (vm-xemacs-p
3797          (extent-at (point) nil 'vm-mime-layout))))
3798
3799 ;;;###autoload
3800 (defun vm-mime-run-display-function-at-point (&optional function dispose)
3801   "Display the MIME object at point according to its type."
3802   (interactive)
3803   ;; save excursion to keep point from moving.  its motion would
3804   ;; drag window point along, to a place arbitrarily far from
3805   ;; where it was when the user triggered the button.
3806   (save-excursion
3807     (let ((e (vm-find-layout-extent-at-point))
3808           retval )
3809       (cond ((null e) nil)
3810             (vm-fsfemacs-p
3811              (funcall (or function (overlay-get e 'vm-mime-function))
3812                       e))
3813             (vm-xemacs-p
3814              (funcall (or function (extent-property e 'vm-mime-function))
3815                       e))))))
3816
3817 ;;;###autoload
3818 (defun vm-mime-reader-map-save-file ()
3819   "Write the MIME object at point to a file."
3820   (interactive)
3821   ;; make sure point doesn't move, we need it to stay on the tag
3822   ;; if the user wants to delete after saving.
3823   (let (file)
3824     (save-excursion
3825       (setq file (vm-mime-run-display-function-at-point
3826                   'vm-mime-send-body-to-file)))
3827     (if vm-mime-delete-after-saving
3828         (let ((vm-mime-confirm-delete nil))
3829           ;; we don't care if the delete fails
3830           (condition-case nil
3831               (vm-delete-mime-object (expand-file-name file))
3832             (error nil))))
3833     file ))
3834
3835 ;;;###autoload
3836 (defun vm-mime-reader-map-save-message ()
3837   "Save the MIME object at point to a folder."
3838   (interactive)
3839   ;; make sure point doesn't move, we need it to stay on the tag
3840   ;; if the user wants to delete after saving.
3841   (let (folder)
3842     (save-excursion
3843       (setq folder (vm-mime-run-display-function-at-point
3844                     'vm-mime-send-body-to-folder)))
3845     (if vm-mime-delete-after-saving
3846         (let ((vm-mime-confirm-delete nil))
3847           ;; we don't care if the delete fails
3848           (condition-case nil
3849               (vm-delete-mime-object folder)
3850             (error nil))))))
3851
3852 ;;;###autoload
3853 (defun vm-mime-reader-map-pipe-to-command ()
3854   "Pipe the MIME object at point to a shell command."
3855   (interactive)
3856   (vm-mime-run-display-function-at-point
3857    'vm-mime-pipe-body-to-queried-command))
3858
3859 ;;;###autoload
3860 (defun vm-mime-reader-map-pipe-to-printer ()
3861   "Print the MIME object at point."
3862   (interactive)
3863   (vm-mime-run-display-function-at-point 'vm-mime-send-body-to-printer))
3864
3865 ;;;###autoload
3866 (defun vm-mime-reader-map-display-using-external-viewer ()
3867   "Display the MIME object at point with an external viewer."
3868   (interactive)
3869   (vm-mime-run-display-function-at-point
3870    'vm-mime-display-body-using-external-viewer))
3871
3872 ;;;###autoload
3873 (defun vm-mime-reader-map-display-using-default ()
3874   "Display the MIME object at point using the `default' face."
3875   (interactive)
3876   (vm-mime-run-display-function-at-point 'vm-mime-display-body-as-text))
3877
3878 ;;;###autoload
3879 (defun vm-mime-reader-map-display-object-as-type ()
3880   "Display the MIME object at point as some other type."
3881   (interactive)
3882   (vm-mime-run-display-function-at-point 'vm-mime-display-object-as-type))
3883
3884 ;; for the karking compiler
3885 (defvar vm-menu-mime-dispose-menu)
3886
3887 (defun vm-mime-set-image-stamp-for-type (e type)
3888   (cond
3889    (vm-xemacs-p
3890     (vm-mime-xemacs-set-image-stamp-for-type e type))
3891    (vm-fsfemacs-p
3892     (vm-mime-fsfemacs-set-image-stamp-for-type e type))))
3893
3894 (defvar vm-mime-type-images
3895   '(("text" "text.xpm")
3896     ("image" "image.xpm")
3897     ("audio" "audio.xpm")
3898     ("video" "video.xpm")
3899     ("message" "message.xpm")
3900     ("application" "application.xpm")
3901     ("multipart" "multipart.xpm")))
3902
3903 (defun vm-mime-xemacs-set-image-stamp-for-type (e type)
3904   (if (and (vm-images-possible-here-p)
3905            (vm-image-type-available-p 'xpm)
3906            (> (device-bitplanes) 7))
3907       (let ((dir (expand-file-name "mime" (vm-image-directory)))
3908             (tuples vm-mime-type-images)
3909             glyph file sym p)
3910         (setq file (catch 'done
3911                      (while tuples
3912                        (if (vm-mime-types-match (car (car tuples)) type)
3913                            (throw 'done (car tuples))
3914                          (setq tuples (cdr tuples))))
3915                      nil)
3916               file (and file (nth 1 file))
3917               sym (and file (intern file vm-image-obarray))
3918               glyph (and sym (boundp sym) (symbol-value sym))
3919               glyph (or glyph
3920                         (and file
3921                              (make-glyph
3922                               (list
3923                                (vector 'xpm ':file
3924                                        (expand-file-name file dir))
3925                                [nothing])))))
3926         (and sym (not (boundp sym)) (set sym glyph))
3927         (and glyph (set-extent-begin-glyph e glyph)))))
3928
3929 (defun vm-mime-fsfemacs-set-image-stamp-for-type (e type)
3930   (if (and (vm-images-possible-here-p)
3931            (vm-image-type-available-p 'xpm))
3932       (let ((dir (expand-file-name "mime" (vm-image-directory)))
3933         (tuples vm-mime-type-images)
3934              file)
3935         (setq file (catch 'done
3936                      (while tuples
3937                        (if (vm-mime-types-match (car (car tuples)) type)
3938                            (throw 'done (car tuples))
3939                          (setq tuples (cdr tuples))))
3940                      nil)
3941               file (and file (nth 1 file))
3942               file (and file (expand-file-name file dir)))
3943         (if file
3944             (save-excursion
3945               (let ((buffer-read-only nil))
3946                 (set-buffer (overlay-buffer e))
3947                 (goto-char (overlay-start e))
3948                 (insert "x")
3949                 (move-overlay e (1- (point)) (overlay-end e))
3950                 (put-text-property (1- (point)) (point) 'display
3951                                    (list 'image
3952                                          ':ascent 80
3953                                          ':color-symbols
3954                                            (list
3955                                             (cons "background"
3956                                                   (cdr (assq
3957                                                         'background-color
3958                                                         (frame-parameters)))))
3959                                          ':type 'xpm
3960                                          ':file file))))))))
3961
3962 (defun vm-mime-insert-button (caption action layout disposable)
3963   (let ((start (point)) e
3964         (keymap vm-mime-reader-map)
3965         (buffer-read-only nil))
3966     (if (fboundp 'set-keymap-parents)
3967         (if (current-local-map)
3968             (set-keymap-parents keymap (list (current-local-map))))
3969       (setq keymap (append keymap (current-local-map))))
3970     (if (not (bolp))
3971         (insert "\n"))
3972     (insert caption "\n")
3973     ;; we must use the same interface that the vm-extent functions
3974     ;; use.  if they use overlays, then we call make-overlay.
3975     (if (eq (symbol-function 'vm-make-extent) 'make-overlay)
3976         ;; we MUST have the five arg make-overlay.  overlays must
3977         ;; advance when text is inserted at their start position or
3978         ;; inline text and graphics will seep into the button
3979         ;; overlay and then be removed when the button is removed.
3980         (setq e (make-overlay start (point) nil t nil))
3981       (setq e (make-extent start (point)))
3982       (set-extent-property e 'start-open t)
3983       (set-extent-property e 'end-open t))
3984     (vm-mime-set-image-stamp-for-type e (car (vm-mm-layout-type layout)))
3985     ;; for emacs
3986     (vm-set-extent-property e 'mouse-face 'highlight)
3987     (vm-set-extent-property e 'local-map keymap)
3988     ;; for xemacs
3989     (vm-set-extent-property e 'highlight t)
3990     (vm-set-extent-property e 'keymap keymap)
3991     (vm-set-extent-property e 'balloon-help 'vm-mouse-3-help)
3992     ;; for all
3993     (vm-set-extent-property e 'vm-button t)
3994     (vm-set-extent-property e 'vm-mime-disposable disposable)
3995     (vm-set-extent-property e 'face vm-mime-button-face)
3996     (vm-set-extent-property e 'vm-mime-layout layout)
3997     (vm-set-extent-property e 'vm-mime-function action)
3998     ;; for vm-continue-postponed-message
3999     (if vm-xemacs-p
4000         (vm-set-extent-property e 'duplicable t)
4001       (put-text-property (overlay-start e)
4002                          (overlay-end e)
4003                          'vm-mime-layout layout))
4004     ;; return t as decoding worked
4005     t))
4006
4007 (defun vm-mime-rewrite-failed-button (button error-string)
4008   (let* ((buffer-read-only nil)
4009          (start (point)))
4010     (goto-char (vm-extent-start-position button))
4011     (insert (format "DISPLAY FAILED -- %s\n" error-string))
4012     (vm-set-extent-endpoints button start (vm-extent-end-position button))
4013     (delete-region (point) (vm-extent-end-position button))))
4014
4015
4016 ;; From: Eric E. Dors
4017 ;; Date: 1999/04/01
4018 ;; Newsgroups: gnu.emacs.vm.info
4019 ;; example filter-alist variable
4020 (defvar vm-mime-write-file-filter-alist
4021   '(("application/mac-binhex40" . "hexbin -s "))
4022   "*A list of filter used when writing attachements to files!"
4023   )
4024
4025 ;; function to parse vm-mime-write-file-filter-alist
4026 (defun vm-mime-find-write-filter (type)
4027   (let ((e-alist vm-mime-write-file-filter-alist)
4028         (matched nil))
4029     (while (and e-alist (not matched))
4030       (if (and (vm-mime-types-match (car (car e-alist)) type)
4031                (cdr (car e-alist)))
4032           (setq matched (cdr (car e-alist)))
4033         (setq e-alist (cdr e-alist))))
4034     matched))
4035
4036 (defun vm-mime-send-body-to-file (layout &optional default-filename file
4037                                          overwrite)
4038   (if (not (vectorp layout))
4039       (setq layout (vm-extent-property layout 'vm-mime-layout)))
4040   (or default-filename
4041       (setq default-filename
4042             (or (vm-mime-get-disposition-parameter layout "filename")
4043                 (vm-mime-get-parameter layout "name"))))
4044   (and default-filename
4045        (setq default-filename (file-name-nondirectory default-filename)))
4046   (let ((work-buffer nil)
4047         ;; evade the XEmacs dialog box, yeccch.
4048         (use-dialog-box nil)
4049         (dir vm-mime-attachment-save-directory)
4050         (done nil))
4051     (if file
4052         nil
4053       (while (not done)
4054         (setq file
4055               (read-file-name
4056                (if default-filename
4057                    (format "Write MIME body to file (default %s): "
4058                            default-filename)
4059                  "Write MIME body to file: ")
4060                dir default-filename)
4061               file (expand-file-name file dir))
4062         (if (not (file-directory-p file))
4063             (setq done t)
4064           (if (null default-filename)
4065               (error "%s is a directory" file))
4066           (setq file (expand-file-name default-filename file)
4067                 done t))))
4068     (save-excursion
4069       (unwind-protect
4070           (let ((coding-system-for-read (vm-binary-coding-system)))
4071             (setq work-buffer (vm-make-work-buffer))
4072             (set-buffer work-buffer)
4073             (setq selective-display nil)
4074             ;; Tell DOS/Windows NT whether the file is binary
4075             (setq buffer-file-type (not (vm-mime-text-type-layout-p layout)))
4076             ;; Tell XEmacs/MULE not to mess with the bits unless
4077             ;; this is a text type.
4078             (if (fboundp 'set-buffer-file-coding-system)
4079                 (if (vm-mime-text-type-layout-p layout)
4080                     (set-buffer-file-coding-system
4081                      (vm-line-ending-coding-system) nil)
4082                   (set-buffer-file-coding-system (vm-binary-coding-system) t)))
4083             (vm-mime-insert-mime-body layout)
4084             (vm-mime-transfer-decode-region layout (point-min) (point-max))
4085             (unless (or overwrite (not (file-exists-p file)))
4086               (or (y-or-n-p "File exists, overwrite? ")
4087                   (error "Aborted")))
4088             ;; Bind the jka-compr-compression-info-list to nil so
4089             ;; that jka-compr won't compress already compressed
4090             ;; data.  This is a crock, but as usual I'm getting
4091             ;; the bug reports for somebody else's bad code.
4092             (let ((jka-compr-compression-info-list nil)
4093                   (command (vm-mime-find-write-filter
4094                             (car (vm-mm-layout-type layout)))))
4095               (if command (shell-command-on-region (point-min) (point-max)
4096                                                    (concat command " > " file))
4097                 (write-region (point-min) (point-max) file nil nil)))
4098
4099             file )
4100         (and work-buffer (kill-buffer work-buffer))))))
4101
4102 (defun vm-mime-send-body-to-folder (layout &optional default-filename)
4103   (if (not (vectorp layout))
4104       (setq layout (vm-extent-property layout 'vm-mime-layout)))
4105   (let ((work-buffer nil)
4106         (type (car (vm-mm-layout-type layout)))
4107         file)
4108     (if (not (or (vm-mime-types-match type "message/rfc822")
4109                  (vm-mime-types-match type "message/news")))
4110         (vm-mime-send-body-to-file layout default-filename)
4111       (save-excursion
4112         (unwind-protect
4113             (let ((coding-system-for-read (vm-binary-coding-system))
4114                   (coding-system-for-write (vm-binary-coding-system)))
4115               (setq work-buffer (vm-make-work-buffer))
4116               (set-buffer work-buffer)
4117               (setq selective-display nil)
4118               ;; Tell DOS/Windows NT whether the file is binary
4119               (setq buffer-file-type t)
4120               ;; Tell XEmacs/MULE not to mess with the bits unless
4121               ;; this is a text type.
4122               (if (fboundp 'set-buffer-file-coding-system)
4123                   (set-buffer-file-coding-system
4124                    (vm-line-ending-coding-system) nil))
4125               (vm-mime-insert-mime-body layout)
4126               (vm-mime-transfer-decode-region layout (point-min) (point-max))
4127               (goto-char (point-min))
4128               (insert (vm-leading-message-separator 'mmdf))
4129               (goto-char (point-max))
4130               (insert (vm-trailing-message-separator 'mmdf))
4131               (set-buffer-modified-p nil)
4132               (vm-mode t)
4133               (let ((vm-check-folder-types t)
4134                     (vm-convert-folder-types t))
4135                 (setq file (call-interactively 'vm-save-message)))
4136               (vm-quit-no-change)
4137               file )
4138           (and work-buffer (kill-buffer work-buffer)))))))
4139
4140 (defun vm-mime-pipe-body-to-command (command layout &optional discard-output)
4141   (if (not (vectorp layout))
4142       (setq layout (vm-extent-property layout 'vm-mime-layout)))
4143   (let ((output-buffer (if discard-output
4144                            0
4145                          (get-buffer-create "*Shell Command Output*")))
4146         (work-buffer nil))
4147     (save-excursion
4148       (if (bufferp output-buffer)
4149           (progn
4150             (set-buffer output-buffer)
4151             (erase-buffer)))
4152       (unwind-protect
4153           (progn
4154             (setq work-buffer (vm-make-work-buffer))
4155             ;; call-process-region calls write-region.
4156             ;; don't let it do CR -> LF translation.
4157             (setq selective-display nil)
4158             (set-buffer work-buffer)
4159             (if vm-fsfemacs-mule-p
4160                 (set-buffer-multibyte nil))
4161             (vm-mime-insert-mime-body layout)
4162             (vm-mime-transfer-decode-region layout (point-min) (point-max))
4163             (let ((pop-up-windows (and pop-up-windows
4164                                        (eq vm-mutable-windows t)))
4165                   (process-coding-system-alist
4166                    (if (vm-mime-text-type-layout-p layout)
4167                        nil
4168                      (list (cons "." (vm-binary-coding-system)))))
4169                   ;; Tell DOS/Windows NT whether the input is binary
4170                   (binary-process-input
4171                    (not
4172                     (vm-mime-text-type-layout-p layout))))
4173               (call-process-region (point-min) (point-max)
4174                                    (or shell-file-name "sh")
4175                                    nil output-buffer nil
4176                                    shell-command-switch command)))
4177         (and work-buffer (kill-buffer work-buffer)))
4178       (if (bufferp output-buffer)
4179           (progn
4180             (set-buffer output-buffer)
4181             (if (not (zerop (buffer-size)))
4182                 (vm-display output-buffer t (list this-command)
4183                             '(vm-pipe-message-to-command))
4184               (vm-display nil nil (list this-command)
4185                           '(vm-pipe-message-to-command)))))))
4186   t )
4187
4188 (defun vm-mime-pipe-body-to-queried-command (layout &optional discard-output)
4189   (let ((command (read-string "Pipe object to command: ")))
4190     (vm-mime-pipe-body-to-command command layout discard-output)))
4191
4192 (defun vm-mime-pipe-body-to-queried-command-discard-output (layout)
4193   (vm-mime-pipe-body-to-queried-command layout t))
4194
4195 (defun vm-mime-send-body-to-printer (layout)
4196   (vm-mime-pipe-body-to-command (mapconcat (function identity)
4197                                            (nconc (list vm-print-command)
4198                                                   vm-print-command-switches)
4199                                            " ")
4200                                 layout))
4201
4202 (defun vm-mime-display-body-as-text (button)
4203   (let ((vm-auto-displayed-mime-content-types '("text/plain"))
4204         (vm-auto-displayed-mime-content-type-exceptions nil)
4205         (layout (copy-sequence (vm-extent-property button 'vm-mime-layout))))
4206     (vm-set-extent-property button 'vm-mime-disposable t)
4207     (vm-set-extent-property button 'vm-mime-layout layout)
4208     ;; not universally correct, but close enough.
4209     (vm-set-mm-layout-type layout '("text/plain" "charset=us-ascii"))
4210     (goto-char (vm-extent-start-position button))
4211     (vm-decode-mime-layout button t)))
4212
4213 (defun vm-mime-display-object-as-type (button)
4214   (let ((vm-auto-displayed-mime-content-types t)
4215         (vm-auto-displayed-mime-content-type-exceptions nil)
4216         (old-layout (vm-extent-property button 'vm-mime-layout))
4217         layout
4218         (type (read-string "View as MIME type: ")))
4219     (setq layout (copy-sequence old-layout))
4220     (vm-set-extent-property button 'vm-mime-layout layout)
4221     ;; not universally correct, but close enough.
4222     (setcar (vm-mm-layout-type layout) type)
4223     (goto-char (vm-extent-start-position button))
4224     (vm-decode-mime-layout button t)))
4225
4226 (defun vm-mime-display-body-using-external-viewer (button)
4227   (let ((layout (vm-extent-property button 'vm-mime-layout))
4228         (vm-mime-external-content-type-exceptions nil))
4229     (goto-char (vm-extent-start-position button))
4230     (if (not (vm-mime-find-external-viewer (car (vm-mm-layout-type layout))))
4231         (error "No viewer defined for type %s"
4232                (car (vm-mm-layout-type layout)))
4233       (vm-mime-display-external-generic layout))))
4234
4235 (defun vm-mime-convert-body-then-display (button)
4236   (let ((layout (vm-mime-convert-undisplayable-layout
4237                  (vm-extent-property button 'vm-mime-layout))))
4238     (if (null layout)
4239         nil
4240       (vm-set-extent-property button 'vm-mime-disposable t)
4241       (vm-set-extent-property button 'vm-mime-layout layout)
4242       (goto-char (vm-extent-start-position button))
4243       (vm-decode-mime-layout button t))))
4244
4245 (defun vm-mime-get-button-layout (e)
4246   (vm-mime-run-display-function-at-point
4247    (function
4248     (lambda (e)
4249       (vm-extent-property e 'vm-mime-layout)))))
4250
4251 (defun vm-mime-scrub-description (string)
4252   (let ((work-buffer nil))
4253       (save-excursion
4254        (unwind-protect
4255            (progn
4256              (setq work-buffer (vm-make-work-buffer))
4257              (set-buffer work-buffer)
4258              (insert string)
4259              (while (re-search-forward "[ \t\n]+" nil t)
4260                (replace-match " "))
4261              (buffer-string))
4262          (and work-buffer (kill-buffer work-buffer))))))
4263
4264 ;; unused
4265 ;;(defun vm-mime-layout-description (layout)
4266 ;;  (let ((type (car (vm-mm-layout-type layout)))
4267 ;;      description name)
4268 ;;    (setq description
4269 ;;        (if (vm-mm-layout-description layout)
4270 ;;            (vm-mime-scrub-description (vm-mm-layout-description layout))))
4271 ;;    (concat
4272 ;;     (if description description "")
4273 ;;     (if description ", " "")
4274 ;;     (cond ((vm-mime-types-match "multipart/digest" type)
4275 ;;          (let ((n (length (vm-mm-layout-parts layout))))
4276 ;;            (format "digest (%d message%s)" n (if (= n 1) "" "s"))))
4277 ;;         ((vm-mime-types-match "multipart/alternative" type)
4278 ;;          "multipart alternative")
4279 ;;         ((vm-mime-types-match "multipart" type)
4280 ;;          (let ((n (length (vm-mm-layout-parts layout))))
4281 ;;            (format "multipart message (%d part%s)" n (if (= n 1) "" "s"))))
4282 ;;         ((vm-mime-types-match "text/plain" type)
4283 ;;          (format "plain text%s"
4284 ;;                  (let ((charset (vm-mime-get-parameter layout "charset")))
4285 ;;                    (if charset
4286 ;;                        (concat ", " charset)
4287 ;;                      ""))))
4288 ;;         ((vm-mime-types-match "text/enriched" type)
4289 ;;          "enriched text")
4290 ;;         ((vm-mime-types-match "text/html" type)
4291 ;;          "HTML")
4292 ;;         ((vm-mime-types-match "image/gif" type)
4293 ;;          "GIF image")
4294 ;;         ((vm-mime-types-match "image/jpeg" type)
4295 ;;          "JPEG image")
4296 ;;         ((and (vm-mime-types-match "application/octet-stream" type)
4297 ;;               (setq name (vm-mime-get-parameter layout "name"))
4298 ;;               (save-match-data (not (string-match "^[ \t]*$" name))))
4299 ;;          name)
4300 ;;         (t type)))))
4301
4302 (defun vm-mime-layout-contains-type (layout type)
4303   (if (vm-mime-types-match type (car (vm-mm-layout-type layout)))
4304       layout
4305     (let ((p (vm-mm-layout-parts layout))
4306           (result nil)
4307           (done nil))
4308       (while (and p (not done))
4309         (if (setq result (vm-mime-layout-contains-type (car p) type))
4310             (setq done t)
4311           (setq p (cdr p))))
4312       result )))
4313
4314 ;; breadth first traversal
4315 (defun vm-mime-find-digests-in-layout (layout)
4316   (let ((layout-list (list layout))
4317         layout-type
4318         (result nil))
4319     (while layout-list
4320       (setq layout-type (car (vm-mm-layout-type (car layout-list))))
4321       (cond ((string-match "^multipart/digest\\|message/\\(rfc822\\|news\\)"
4322                            layout-type)
4323              (setq result (nconc result (list (car layout-list)))))
4324             ((vm-mime-composite-type-p layout-type)
4325              (setq layout-list (nconc layout-list
4326                                       (copy-sequence
4327                                        (vm-mm-layout-parts
4328                                         (car layout-list)))))))
4329       (setq layout-list (cdr layout-list)))
4330     result ))
4331
4332 (defun vm-mime-plain-message-p (m)
4333   (save-match-data
4334     (let ((o (vm-mm-layout m))
4335           (case-fold-search t))
4336       (and (eq (vm-mm-encoded-header m) 'none)
4337            (or (not (vectorp o))
4338                (and (vm-mime-types-match "text/plain"
4339                                          (car (vm-mm-layout-type o)))
4340                     (let* ((charset (or (vm-mime-get-parameter o "charset")
4341                                         "us-ascii")))
4342                       (vm-mime-default-face-charset-p charset))
4343                     (string-match "^\\(7bit\\|8bit\\|binary\\)$"
4344                                   (vm-mm-layout-encoding o))))))))
4345
4346 (defun vm-mime-text-type-p (type)
4347   (let ((case-fold-search t))
4348     (or (string-match "^text/" type) (string-match "^message/" type))))
4349
4350 (defun vm-mime-text-type-layout-p (layout)
4351   (or (vm-mime-types-match "text" (car (vm-mm-layout-type layout)))
4352       (vm-mime-types-match "message" (car (vm-mm-layout-type layout)))))
4353
4354
4355 (defun vm-mime-tty-can-display-mime-charset (name)
4356   "Can the current TTY correctly display the given MIME character set?"
4357   (and (fboundp 'console-tty-output-coding-system)
4358        ;; Is this check too paranoid?
4359        (coding-system-p (console-tty-output-coding-system))
4360        (fboundp 'coding-system-get)
4361        (let
4362            ;; Nnngh, latin-unity-base-name isn't doing the right thing for
4363            ;; me with MULE-UCS and UTF-8 as the terminal coding system. Of
4364            ;; course, it's not evident that it _can_ do the right thing.
4365            ;;
4366            ;; The intention is that ourtermcs is the version of the
4367            ;; coding-system without line-ending information attached to its
4368            ;; end.
4369            ((ourtermcs (coding-system-name
4370                         (or (car
4371                              (coding-system-get
4372                               (console-tty-output-coding-system)
4373                               'alias-coding-systems))
4374                             (coding-system-base
4375                              (console-tty-output-coding-system))))))
4376          (or (eq ourtermcs (car
4377                             (cdr
4378                              (vm-string-assoc
4379                               name vm-mime-mule-charset-to-coding-alist))))
4380              ;; The vm-mime-mule-charset-to-coding-alist check is to make
4381              ;; sure it does the right thing with a nonsense MIME character
4382              ;; set name.
4383              (and (memq ourtermcs (vm-get-mime-ucs-list))
4384                   (vm-string-assoc name vm-mime-mule-charset-to-coding-alist)
4385                   t)
4386              (vm-mime-default-face-charset-p name)))))
4387
4388 (defun vm-mime-charset-internally-displayable-p (name)
4389   "Can the given MIME charset be displayed within emacs by by VM?"
4390   (cond ((and vm-xemacs-mule-p (memq (device-type) '(x gtk mswindows)))
4391          (or (vm-string-assoc name vm-mime-mule-charset-to-coding-alist)
4392              (vm-mime-default-face-charset-p name)))
4393         ((and vm-fsfemacs-mule-p (memq window-system '(x mac win32 w32)))
4394          (or (vm-string-assoc name vm-mime-mule-charset-to-coding-alist)
4395              (vm-mime-default-face-charset-p name)))
4396         ((vm-multiple-fonts-possible-p)
4397          (or (vm-mime-default-face-charset-p name)
4398              (vm-string-assoc name vm-mime-charset-font-alist)))
4399
4400         ;; If the terminal-coding-system variable is set to something that
4401         ;; can encode all the characters of the given MIME character set,
4402         ;; then we can display any message in the given MIME character set
4403         ;; internally.
4404
4405         ((vm-mime-tty-can-display-mime-charset name))
4406         (t
4407          (vm-mime-default-face-charset-p name))))
4408
4409 (defun vm-mime-default-face-charset-p (charset)
4410   (and (or (eq vm-mime-default-face-charsets t)
4411            (and (consp vm-mime-default-face-charsets)
4412                 (vm-string-member charset vm-mime-default-face-charsets)))
4413        (not (vm-string-member charset
4414                               vm-mime-default-face-charset-exceptions))))
4415
4416
4417 (defun vm-mime-find-message/partials (layout id)
4418   (let ((list nil)
4419         (type (vm-mm-layout-type layout)))
4420     (cond ((vm-mime-composite-type-p (car (vm-mm-layout-type layout)))
4421            (let ((parts (vm-mm-layout-parts layout)) o)
4422              (while parts
4423                (setq o (vm-mime-find-message/partials (car parts) id))
4424                (if o
4425                    (setq list (nconc o list)))
4426                (setq parts (cdr parts)))))
4427           ((vm-mime-types-match "message/partial" (car type))
4428            (if (equal (vm-mime-get-parameter layout "id") id)
4429                (setq list (cons layout list)))))
4430     list ))
4431
4432 (defun vm-mime-find-leaf-content-id-in-layout-folder (layout id)
4433   (save-excursion
4434     (save-restriction
4435       (let (m (o nil))
4436         (set-buffer (vm-buffer-of
4437                      (vm-real-message-of
4438                       (vm-mm-layout-message layout))))
4439         (widen)
4440         (goto-char (point-min))
4441         (while (and (search-forward id nil t)
4442                     (setq m (vm-message-at-point)))
4443           (setq o (vm-mm-layout m))
4444           (if (not (vectorp o))
4445               nil
4446             (setq o (vm-mime-find-leaf-content-id o id))
4447             (if (null o)
4448                 nil
4449               ;; if we found it, end the search loop
4450               (goto-char (point-max)))))
4451         o ))))
4452
4453 (defun vm-mime-find-leaf-content-id (layout id)
4454   (let ((list nil)
4455         (type (vm-mm-layout-type layout)))
4456     (catch 'done
4457       (cond ((vm-mime-composite-type-p (car (vm-mm-layout-type layout)))
4458              (let ((parts (vm-mm-layout-parts layout)) o)
4459                (while parts
4460                  (setq o (vm-mime-find-leaf-content-id (car parts) id))
4461                  (if o
4462                      (throw 'done o))
4463                  (setq parts (cdr parts)))))
4464             (t
4465              (if (equal (vm-mm-layout-id layout) id)
4466                  (throw 'done layout)))))))
4467
4468 (defun vm-message-at-point ()
4469   (let ((mp vm-message-list)
4470         (point (point))
4471         (done nil))
4472     (while (and mp (not done))
4473       (if (and (>= point (vm-start-of (car mp)))
4474                (<= point (vm-end-of (car mp))))
4475           (setq done t)
4476         (setq mp (cdr mp))))
4477     (car mp)))
4478
4479 (defun vm-mime-make-multipart-boundary ()
4480   (let ((boundary (make-string 10 ?a))
4481         (i 0))
4482     (random t)
4483     (while (< i (length boundary))
4484       (aset boundary i (aref vm-mime-base64-alphabet
4485                              (% (vm-abs (lsh (random) -8))
4486                                 (length vm-mime-base64-alphabet))))
4487       (vm-increment i))
4488     boundary ))
4489
4490 (defun vm-mime-extract-filename-suffix (layout)
4491   (let ((filename (or (vm-mime-get-disposition-parameter layout "filename")
4492                       (vm-mime-get-parameter layout "name")))
4493         (suffix nil) i)
4494     (if (and filename (string-match "\\.[^.]+$" filename))
4495         (setq suffix (substring filename (match-beginning 0) (match-end 0))))
4496     suffix ))
4497
4498 (defun vm-mime-find-filename-suffix-for-type (layout)
4499   (let ((type (car (vm-mm-layout-type layout)))
4500         suffix
4501         (alist vm-mime-attachment-auto-suffix-alist))
4502     (while alist
4503       (if (vm-mime-types-match (car (car alist)) type)
4504           (setq suffix (cdr (car alist))
4505                 alist nil)
4506         (setq alist (cdr alist))))
4507     suffix ))
4508
4509 ;;;###autoload
4510 (defun vm-mime-attach-file (file type &optional charset description
4511                             no-suggested-filename)
4512   "Attach a file to a VM composition buffer to be sent along with the message.
4513 The file is not inserted into the buffer and MIME encoded until
4514 you execute `vm-mail-send' or `vm-mail-send-and-exit'.  A visible tag
4515 indicating the existence of the attachment is placed in the
4516 composition buffer.  You can move the attachment around or remove
4517 it entirely with normal text editing commands.  If you remove the
4518 attachment tag, the attachment will not be sent.
4519
4520 First argument, FILE, is the name of the file to attach.  Second
4521 argument, TYPE, is the MIME Content-Type of the file.  Optional
4522 third argument CHARSET is the character set of the attached
4523 document.  This argument is only used for text types, and it is
4524 ignored for other types.  Optional fourth argument DESCRIPTION
4525 should be a one line description of the file.  Nil means include
4526 no description.  Optional fifth argument NO-SUGGESTED-FILENAME non-nil
4527 means that VM should not add a filename to the Content-Disposition
4528 header created for the object.
4529
4530 When called interactively all arguments are read from the
4531 minibuffer.
4532
4533 This command is for attaching files that do not have a MIME
4534 header section at the top.  For files with MIME headers, you
4535 should use vm-mime-attach-mime-file to attach such a file.  VM
4536 will extract the content type information from the headers in
4537 this case and not prompt you for it in the minibuffer."
4538   (interactive
4539    ;; protect value of last-command and this-command
4540    (let ((last-command last-command)
4541          (this-command this-command)
4542          (completion-ignored-extensions nil)
4543          (charset nil)
4544          description file default-type type)
4545      (if (null vm-send-using-mime)
4546          (error "MIME attachments disabled, set vm-send-using-mime non-nil to enable."))
4547      (setq file (vm-read-file-name "Attach file: "
4548                                    vm-mime-attachment-source-directory
4549                                    nil t)
4550            default-type (or (vm-mime-default-type-from-filename file)
4551                             "application/octet-stream")
4552            type (completing-read
4553                  (format "Content type (default %s): "
4554                          default-type)
4555                  vm-mime-type-completion-alist)
4556            type (if (> (length type) 0) type default-type))
4557      (if (vm-mime-types-match "text" type)
4558          (setq charset (completing-read "Character set (default US-ASCII): "
4559                                         vm-mime-charset-completion-alist)
4560                charset (if (> (length charset) 0) charset)))
4561      (setq description (read-string "One line description: "))
4562      (if (string-match "^[ \t]*$" description)
4563          (setq description nil))
4564      (list file type charset description nil)))
4565   (if (null vm-send-using-mime)
4566       (error "MIME attachments disabled, set vm-send-using-mime non-nil to enable."))
4567   (if (file-directory-p file)
4568       (error "%s is a directory, cannot attach" file))
4569   (if (not (file-exists-p file))
4570       (error "No such file: %s" file))
4571   (if (not (file-readable-p file))
4572       (error "You don't have permission to read %s" file))
4573   (and charset (setq charset (list (concat "charset=" charset))))
4574   (and description (setq description (vm-mime-scrub-description description)))
4575   (vm-mime-attach-object file type charset description nil))
4576
4577 ;;;###autoload
4578 (defun vm-mime-attach-mime-file (file type)
4579   "Attach a MIME encoded file to a VM composition buffer to be sent
4580 along with the message.
4581
4582 The file is not inserted into the buffer until you execute
4583 vm-mail-send or vm-mail-send-and-exit.  A visible tag indicating
4584 the existence of the attachment is placed in the composition
4585 buffer.  You can move the attachment around or remove it entirely
4586 with normal text editing commands.  If you remove the attachment
4587 tag, the attachment will not be sent.
4588
4589 The first argument, FILE, is the name of the file to attach.
4590 When called interactively the FILE argument is read from the
4591 minibuffer.
4592
4593 The second argument, TYPE, is the MIME Content-Type of the object.
4594
4595 This command is for attaching files that have a MIME
4596 header section at the top.  For files without MIME headers, you
4597 should use vm-mime-attach-file to attach the file."
4598   (interactive
4599    ;; protect value of last-command and this-command
4600    (let ((last-command last-command)
4601          (this-command this-command)
4602          file type default-type)
4603      (if (null vm-send-using-mime)
4604          (error "MIME attachments disabled, set vm-send-using-mime non-nil to enable."))
4605      (setq file (vm-read-file-name "Attach file: "
4606                                    vm-mime-attachment-source-directory
4607                                    nil t)
4608            default-type (or (vm-mime-default-type-from-filename file)
4609                             "application/octet-stream")
4610            type (completing-read
4611                  (format "Content type (default %s): "
4612                          default-type)
4613                  vm-mime-type-completion-alist)
4614            type (if (> (length type) 0) type default-type))
4615      (list file type)))
4616   (if (null vm-send-using-mime)
4617       (error "MIME attachments disabled, set vm-send-using-mime non-nil to enable."))
4618   (if (file-directory-p file)
4619       (error "%s is a directory, cannot attach" file))
4620   (if (not (file-exists-p file))
4621       (error "No such file: %s" file))
4622   (if (not (file-readable-p file))
4623       (error "You don't have permission to read %s" file))
4624   (vm-mime-attach-object file type nil nil t))
4625
4626 ;;;###autoload
4627 (defun vm-mime-attach-buffer (buffer type &optional charset description)
4628   "Attach a buffer to a VM composition buffer to be sent along with
4629 the message.
4630
4631 The buffer contents are not inserted into the composition
4632 buffer and MIME encoded until you execute `vm-mail-send' or
4633 `vm-mail-send-and-exit'.  A visible tag indicating the existence
4634 of the attachment is placed in the composition buffer.  You
4635 can move the attachment around or remove it entirely with
4636 normal text editing commands.  If you remove the attachment
4637 tag, the attachment will not be sent.
4638
4639 First argument, BUFFER, is the buffer or name of the buffer to
4640 attach.  Second argument, TYPE, is the MIME Content-Type of the
4641 file.  Optional third argument CHARSET is the character set of
4642 the attached document.  This argument is only used for text
4643 types, and it is ignored for other types.  Optional fourth
4644 argument DESCRIPTION should be a one line description of the
4645 file.  Nil means include no description.
4646
4647 When called interactively all arguments are read from the
4648 minibuffer.
4649
4650 This command is for attaching files that do not have a MIME
4651 header section at the top.  For files with MIME headers, you
4652 should use vm-mime-attach-mime-file to attach such a file.  VM
4653 will extract the content type information from the headers in
4654 this case and not prompt you for it in the minibuffer."
4655   (interactive
4656    ;; protect value of last-command and this-command
4657    (let ((last-command last-command)
4658          (this-command this-command)
4659          (charset nil)
4660          description file default-type type buffer buffer-name)
4661      (if (null vm-send-using-mime)
4662          (error "MIME attachments disabled, set vm-send-using-mime non-nil to enable."))
4663      (setq buffer-name (read-buffer "Attach buffer: " nil t)
4664            default-type (or (vm-mime-default-type-from-filename buffer-name)
4665                             "application/octet-stream")
4666            type (completing-read
4667                  (format "Content type (default %s): "
4668                          default-type)
4669                  vm-mime-type-completion-alist)
4670            type (if (> (length type) 0) type default-type))
4671      (if (vm-mime-types-match "text" type)
4672          (setq charset (completing-read "Character set (default US-ASCII): "
4673                                         vm-mime-charset-completion-alist)
4674                charset (if (> (length charset) 0) charset)))
4675      (setq description (read-string "One line description: "))
4676      (if (string-match "^[ \t]*$" description)
4677          (setq description nil))
4678      (list buffer-name type charset description)))
4679   (if (null (setq buffer (get-buffer buffer)))
4680       (error "Buffer %s does not exist." buffer))
4681   (if (null vm-send-using-mime)
4682       (error "MIME attachments disabled, set vm-send-using-mime non-nil to enable."))
4683   (and charset (setq charset (list (concat "charset=" charset))))
4684   (and description (setq description (vm-mime-scrub-description description)))
4685   (vm-mime-attach-object buffer type charset description nil))
4686
4687 ;;;###autoload
4688 (defun vm-mime-attach-message (message &optional description)
4689   "Attach a message from a folder to a VM composition buffer
4690 to be sent along with the message.
4691
4692 The message is not inserted into the buffer and MIME encoded until
4693 you execute `vm-mail-send' or `vm-mail-send-and-exit'.  A visible tag
4694 indicating the existence of the attachment is placed in the
4695 composition buffer.  You can move the attachment around or remove
4696 it entirely with normal text editing commands.  If you remove the
4697 attachment tag, the attachment will not be sent.
4698
4699 First argument, MESSAGE, is either a VM message struct or a list
4700 of message structs.  When called interactively a message number is read
4701 from the minibuffer.  The message will come from the parent
4702 folder of this composition.  If the composition has no parent,
4703 the name of a folder will be read from the minibuffer before the
4704 message number is read.
4705
4706 If this command is invoked with a prefix argument, the name of a
4707 folder is read and that folder is used instead of the parent
4708 folder of the composition.
4709
4710 If this command is invoked on marked message (via
4711 `vm-next-command-uses-marks') the marked messages in the selected
4712 folder will be attached as a MIME message digest.
4713
4714 Optional second argument DESCRIPTION is a one-line description of
4715 the message being attached.  This is also read from the
4716 minibuffer if the command is run interactively."
4717   (interactive
4718    ;; protect value of last-command and this-command
4719    (let ((last-command last-command)
4720          (this-command this-command)
4721          (result 0)
4722          mlist mp default prompt description folder)
4723      (if (null vm-send-using-mime)
4724          (error "MIME attachments disabled, set vm-send-using-mime non-nil to enable."))
4725      (if current-prefix-arg
4726          (setq vm-mail-buffer (vm-read-folder-name)
4727                vm-mail-buffer (if (string= vm-mail-buffer "") nil
4728                                 (setq current-prefix-arg nil)
4729                                 (get-buffer vm-mail-buffer))))
4730      (cond ((or current-prefix-arg (null vm-mail-buffer)
4731                 (not (buffer-live-p vm-mail-buffer)))
4732             (let ((dir (if vm-folder-directory
4733                            (expand-file-name vm-folder-directory)
4734                          default-directory))
4735                   file)
4736               (let ((last-command last-command)
4737                     (this-command this-command))
4738                 (setq file (read-file-name "Attach message from folder: "
4739                                            dir nil t)))
4740               (save-excursion
4741                 (set-buffer
4742                  (let ((coding-system-for-read (vm-binary-coding-system)))
4743                    (find-file-noselect file)))
4744                 (setq folder (current-buffer))
4745                 (vm-mode)
4746                 (setq mlist (vm-select-marked-or-prefixed-messages 0)))))
4747            (t
4748             (setq folder vm-mail-buffer)
4749             (save-excursion
4750               (set-buffer folder)
4751               (setq mlist (vm-select-marked-or-prefixed-messages 0)))))
4752      (if (null mlist)
4753          (save-excursion
4754            (set-buffer folder)
4755            (setq default (and vm-message-pointer
4756                               (vm-number-of (car vm-message-pointer)))
4757                  prompt (if default
4758                             (format "Yank message number: (default %s) "
4759                                     default)
4760                           "Yank message number: "))
4761            (while (zerop result)
4762              (setq result (read-string prompt))
4763              (and (string= result "") default (setq result default))
4764              (setq result (string-to-number result)))
4765            (if (null (setq mp (nthcdr (1- result) vm-message-list)))
4766                (error "No such message."))))
4767      (setq description (read-string "Description: "))
4768      (if (string-match "^[ \t]*$" description)
4769          (setq description nil))
4770      (list (or mlist (car mp)) description)))
4771   (if (null vm-send-using-mime)
4772       (error "MIME attachments disabled, set vm-send-using-mime non-nil to enable."))
4773   (if (not (consp message))
4774       (let* ((buf (generate-new-buffer "*attached message*"))
4775              (m (vm-real-message-of message))
4776              (folder (vm-buffer-of m)))
4777         (save-excursion
4778           (set-buffer buf)
4779           (if vm-fsfemacs-mule-p
4780               (set-buffer-multibyte nil))
4781           (vm-insert-region-from-buffer folder (vm-headers-of m)
4782                                         (vm-text-end-of m))
4783           (goto-char (point-min))
4784           (vm-reorder-message-headers nil nil
4785                                       vm-internal-unforwarded-header-regexp))
4786         (and description (setq description
4787                                (vm-mime-scrub-description description)))
4788         (vm-mime-attach-object buf "message/rfc822" nil description nil)
4789         (make-local-variable 'vm-forward-list)
4790         (setq vm-system-state 'forwarding
4791               vm-forward-list (list message))
4792         (add-hook 'kill-buffer-hook
4793                   (list 'lambda ()
4794                         (list 'if (list 'eq (current-buffer) '(current-buffer))
4795                               (list 'kill-buffer buf)))))
4796     (let ((buf (generate-new-buffer "*attached messages*"))
4797           boundary)
4798       (save-excursion
4799         (set-buffer buf)
4800         (setq boundary (vm-mime-encapsulate-messages
4801                         message vm-mime-digest-headers
4802                         vm-mime-digest-discard-header-regexp
4803                         t))
4804         (goto-char (point-min))
4805         (insert "MIME-Version: 1.0\n")
4806         (insert (if vm-mime-avoid-folding-content-type
4807                     "Content-Type: multipart/digest; boundary=\""
4808                   "Content-Type: multipart/digest;\n\tboundary=\"")
4809                 boundary "\"\n")
4810         (insert "Content-Transfer-Encoding: "
4811                 (vm-determine-proper-content-transfer-encoding
4812                  (point)
4813                  (point-max))
4814                 "\n\n"))
4815       (and description (setq description
4816                              (vm-mime-scrub-description description)))
4817       (vm-mime-attach-object buf "multipart/digest"
4818                              (list (concat "boundary=\""
4819                                            boundary "\"")) nil t)
4820       (make-local-variable 'vm-forward-list)
4821       (setq vm-system-state 'forwarding
4822             vm-forward-list (copy-sequence message))
4823       (add-hook 'kill-buffer-hook
4824                 (list 'lambda ()
4825                       (list 'if (list 'eq (current-buffer) '(current-buffer))
4826                             (list 'kill-buffer buf)))))))
4827
4828 ;;;###autoload
4829 (defun vm-mime-attach-object-from-message (composition)
4830   "Attach a object from the current message to a VM composition buffer.
4831
4832 The object is not inserted into the buffer and MIME encoded until
4833 you execute `vm-mail-send' or `vm-mail-send-and-exit'.  A visible tag
4834 indicating the existence of the object is placed in the
4835 composition buffer.  You can move the object around or remove
4836 it entirely with normal text editing commands.  If you remove the
4837 object tag, the object will not be sent.
4838
4839 First argument COMPOSITION is the buffer into which the object
4840 will be inserted.  When this function is called interactively
4841 COMPOSITION's name will be read from the minibuffer."
4842   (interactive
4843    ;; protect value of last-command and this-command
4844    (let ((last-command last-command)
4845          (this-command this-command))
4846      (list
4847       (read-buffer "Attach object to buffer: "
4848                    (vm-find-composition-buffer) t))))
4849   (if (null vm-send-using-mime)
4850       (error "MIME attachments disabled, set vm-send-using-mime non-nil to enable."))
4851   (vm-check-for-killed-summary)
4852   (vm-error-if-folder-empty)
4853
4854   (let (e layout (work-buffer nil) buf start w)
4855     (setq e (vm-find-layout-extent-at-point)
4856           layout (and e (vm-extent-property e 'vm-mime-layout)))
4857     (unwind-protect
4858         (if (null layout)
4859             (error "No MIME object found at point.")
4860           (save-excursion
4861             (setq work-buffer (vm-make-work-buffer))
4862             (set-buffer work-buffer)
4863             (vm-mime-insert-mime-headers layout)
4864             (insert "\n")
4865             (setq start (point))
4866             (vm-mime-insert-mime-body layout)
4867             (vm-mime-transfer-decode-region layout start (point-max))
4868             (goto-char (point-min))
4869             (vm-reorder-message-headers nil nil "Content-Transfer-Encoding:")
4870             (insert "Content-Transfer-Encoding: binary\n")
4871             (set-buffer composition)
4872             (vm-mime-attach-object work-buffer
4873                                    (car (vm-mm-layout-type layout))
4874                                    (cdr (vm-mm-layout-type layout))
4875                                    (vm-mm-layout-description layout)
4876                                    t)
4877             ;; move windwo point forward so that if this command
4878             ;; is used consecutively, the insertions will be in
4879             ;; the correct order in the composition buffer.
4880             (setq w (vm-get-buffer-window composition))
4881             (and w (set-window-point w (point)))
4882             (setq buf work-buffer
4883                   work-buffer nil)
4884             (add-hook 'kill-buffer-hook
4885                       (list 'lambda ()
4886                             (list 'if (list 'eq (current-buffer)
4887                                             '(current-buffer))
4888                                   (list 'kill-buffer buf))))))
4889       (and work-buffer (kill-buffer work-buffer)))))
4890
4891 (defun vm-mime-attach-object (object type params description mimed
4892                               &optional no-suggested-filename)
4893   (if (not (eq major-mode 'mail-mode))
4894       (error "Command must be used in a VM Mail mode buffer."))
4895   (if (vm-mail-mode-get-header-contents "MIME-Version")
4896       (error "Can't attach MIME object to already encoded MIME buffer."))
4897   (let (start end e tag-string disposition
4898         (fb (list vm-mime-forward-local-external-bodies)))
4899     (if (< (point) (save-excursion (mail-text) (point)))
4900         (mail-text))
4901     (setq start (point))
4902     (if (listp object)
4903         (setq tag-string (format "[ATTACHMENT %s, %s]" (nth 4 object) type))
4904       (setq tag-string (format "[ATTACHMENT %s, %s]" object
4905                              (or type "MIME file"))))
4906     (insert tag-string "\n")
4907     (setq end (1- (point)))
4908     (if (and (stringp object) (not mimed))
4909         (progn
4910           (if (or (vm-mime-types-match "application" type)
4911                   (vm-mime-types-match "model" type))
4912               (setq disposition (list "attachment"))
4913             (setq disposition (list "inline")))
4914           (if (not no-suggested-filename)
4915               (setq type (concat type "; name=\"" (file-name-nondirectory object) "\"")
4916                     disposition (nconc disposition
4917                                        (list
4918                                         (concat "filename=\""
4919                                                 (file-name-nondirectory object)
4920                                                 "\""))))))
4921       (setq disposition (list "unspecified")))
4922     (if (listp object) (setq disposition (nth 3 object)))
4923
4924     (cond (vm-fsfemacs-p
4925            (put-text-property start end 'front-sticky nil)
4926            (put-text-property start end 'rear-nonsticky t)
4927 ;; can't be intangible because menu clicking at a position needs
4928 ;; to set point inside the tag so that a command can access the
4929 ;; text properties there.
4930 ;;         (put-text-property start end 'intangible object)
4931            (put-text-property start end 'face vm-mime-button-face)
4932            (put-text-property start end 'vm-mime-forward-local-refs fb)
4933            (put-text-property start end 'vm-mime-type type)
4934            (put-text-property start end 'vm-mime-object object)
4935            (put-text-property start end 'vm-mime-parameters params)
4936            (put-text-property start end 'vm-mime-description description)
4937            (put-text-property start end 'vm-mime-disposition disposition)
4938            (put-text-property start end 'vm-mime-encoding nil)
4939            (put-text-property start end 'vm-mime-encoded mimed)
4940            (put-text-property start end 'duplicable t)
4941            )
4942           (vm-xemacs-p
4943            (setq e (make-extent start end))
4944            (vm-mime-set-image-stamp-for-type e (or type "text/plain"))
4945            (set-extent-property e 'start-open t)
4946            (set-extent-property e 'face vm-mime-button-face)
4947            (set-extent-property e 'duplicable t)
4948            (let ((keymap (make-sparse-keymap)))
4949              (if vm-popup-menu-on-mouse-3
4950                  (define-key keymap 'button3
4951                    'vm-menu-popup-attachment-menu))
4952              (define-key keymap [return] 'vm-mime-change-content-disposition)
4953              (set-extent-property e 'keymap keymap)
4954              (set-extent-property e 'balloon-help 'vm-mouse-3-help))
4955            (set-extent-property e 'vm-mime-forward-local-refs fb)
4956            (set-extent-property e 'vm-mime-type type)
4957            (set-extent-property e 'vm-mime-object object)
4958            (set-extent-property e 'vm-mime-parameters params)
4959            (set-extent-property e 'vm-mime-description description)
4960            (set-extent-property e 'vm-mime-disposition disposition)
4961            (set-extent-property e 'vm-mime-encoding nil)
4962            (set-extent-property e 'vm-mime-encoded mimed)))))
4963
4964 (defun vm-mime-attachment-forward-local-refs-at-point ()
4965   (cond (vm-fsfemacs-p
4966          (let ((fb (get-text-property (point) 'vm-mime-forward-local-refs)))
4967            (car fb) ))
4968         (vm-xemacs-p
4969          (let* ((e (extent-at (point) nil 'vm-mime-type))
4970                 (fb (extent-property e 'vm-mime-forward-local-refs)))
4971            (car fb) ))))
4972
4973 (defun vm-mime-set-attachment-forward-local-refs-at-point (val)
4974   (cond (vm-fsfemacs-p
4975          (let ((fb (get-text-property (point) 'vm-mime-forward-local-refs)))
4976            (setcar fb val) ))
4977         (vm-xemacs-p
4978          (let* ((e (extent-at (point) nil 'vm-mime-type))
4979                 (fb (extent-property e 'vm-mime-forward-local-refs)))
4980            (setcar fb val) ))))
4981
4982 (defun vm-mime-delete-attachment-button ()
4983   (cond (vm-fsfemacs-p
4984          ;; TODO
4985          )
4986         (vm-xemacs-p
4987          (let ((e (extent-at (point) nil 'vm-mime-type)))
4988            (delete-region (extent-start-position e)
4989                           (extent-end-position e))))))
4990
4991 (defun vm-mime-delete-attachment-button-keep-infos ()
4992   (cond (vm-fsfemacs-p
4993          ;; TODO
4994          )
4995         (vm-xemacs-p
4996          (let ((e (extent-at (point) nil 'vm-mime-type)))
4997            (save-excursion
4998              (goto-char (1+ (extent-start-position e)))
4999              (insert " --- DELETED ")
5000              (goto-char (extent-end-position e))
5001              (insert " ---")
5002              (delete-extent e))))))
5003
5004 ;;;###autoload
5005 (defun vm-mime-change-content-disposition ()
5006   (interactive)
5007   (vm-mime-set-attachment-disposition-at-point
5008    (intern
5009     (completing-read "Disposition-type: "
5010                      '(("unspecified") ("inline") ("attachment"))
5011                      nil
5012                      t))))
5013
5014 (defun vm-mime-attachment-disposition-at-point ()
5015   (cond (vm-fsfemacs-p
5016          (let ((disp (get-text-property (point) 'vm-mime-disposition)))
5017            (intern (car disp))))
5018         (vm-xemacs-p
5019          (let* ((e (extent-at (point) nil 'vm-mime-disposition))
5020                 (disp (extent-property e 'vm-mime-disposition)))
5021            (intern (car disp))))))
5022
5023 (defun vm-mime-set-attachment-disposition-at-point (sym)
5024   (cond (vm-fsfemacs-p
5025          (let ((disp (get-text-property (point) 'vm-mime-disposition)))
5026            (setcar disp (symbol-name sym))))
5027         (vm-xemacs-p
5028          (let* ((e (extent-at (point) nil 'vm-mime-disposition))
5029                 (disp (extent-property e 'vm-mime-disposition)))
5030            (setcar disp (symbol-name sym))))))
5031
5032
5033 (defun vm-mime-attachment-encoding-at-point ()
5034   (cond (vm-fsfemacs-p
5035          (get-text-property (point) 'vm-mime-encoding))
5036         (vm-xemacs-p
5037          (let ((e (extent-at (point) nil 'vm-mime-encoding)))
5038            (if e (extent-property e 'vm-mime-encoding))))))
5039
5040 (defun vm-mime-set-attachment-encoding-at-point (sym)
5041   (cond (vm-fsfemacs-p
5042          (set-text-property (point) 'vm-mime-encoding sym))
5043         (vm-xemacs-p
5044          (let ((e (extent-at (point) nil 'vm-mime-disposition)))
5045            (set-extent-property e 'vm-mime-encoding sym)))))
5046
5047 (defun vm-disallow-overlay-endpoint-insertion (overlay after start end
5048                                                &optional old-size)
5049   (cond ((null after) nil)
5050         ((= start (overlay-start overlay))
5051          (move-overlay overlay end (overlay-end overlay)))
5052         ((= start (overlay-end overlay))
5053          (move-overlay overlay (overlay-start overlay) start))))
5054
5055 (defun vm-mime-fake-attachment-overlays (start end)
5056   (let ((o-list nil)
5057         (done nil)
5058         (pos start)
5059         object props o)
5060     (save-excursion
5061       (save-restriction
5062         (narrow-to-region start end)
5063         (while (not done)
5064           (setq object (get-text-property pos 'vm-mime-object))
5065           (setq pos (next-single-property-change pos 'vm-mime-object))
5066           (or pos (setq pos (point-max) done t))
5067           (if object
5068               (progn
5069                 (setq o (make-overlay start pos))
5070                 (overlay-put o 'insert-in-front-hooks
5071                              '(vm-disallow-overlay-endpoint-insertion))
5072                 (overlay-put o 'insert-behind-hooks
5073                              '(vm-disallow-overlay-endpoint-insertion))
5074                 (setq props (text-properties-at start))
5075                 (while props
5076                   (overlay-put o (car props) (car (cdr props)))
5077                   (setq props (cdr (cdr props))))
5078                 (setq o-list (cons o o-list))))
5079           (setq start pos))
5080         o-list ))))
5081
5082 (defun vm-mime-default-type-from-filename (file)
5083   (let ((alist vm-mime-attachment-auto-type-alist)
5084         (case-fold-search t)
5085         (done nil))
5086     (while (and alist (not done))
5087       (if (string-match (car (car alist)) file)
5088           (setq done t)
5089         (setq alist (cdr alist))))
5090     (and alist (cdr (car alist)))))
5091
5092 (defun vm-remove-mail-mode-header-separator ()
5093   (save-excursion
5094     (goto-char (point-min))
5095     (if (re-search-forward (concat "^" mail-header-separator "$") nil t)
5096         (progn
5097           (delete-region (match-beginning 0) (match-end 0))
5098            t )
5099       nil )))
5100
5101 (defun vm-add-mail-mode-header-separator ()
5102   (save-excursion
5103     (goto-char (point-min))
5104     (if (re-search-forward "^$" nil t)
5105         (replace-match mail-header-separator t t))))
5106
5107 (defun vm-mime-transfer-encode-region (encoding beg end crlf)
5108   (let ((case-fold-search t)
5109         (armor-from (and vm-mime-composition-armor-from-lines
5110                          (let ((case-fold-search nil))
5111                            (save-excursion
5112                              (goto-char beg)
5113                              (re-search-forward "^From " nil t)))))
5114         (armor-dot (let ((case-fold-search nil))
5115                      (save-excursion
5116                        (goto-char beg)
5117                        (re-search-forward "^\\.\n" nil t)))))
5118     (cond ((string-match "^binary$" encoding)
5119            (vm-mime-base64-encode-region beg end crlf)
5120            (setq encoding "base64"))
5121           ((and (not armor-from) (not armor-dot)
5122                 (string-match "^7bit$" encoding)) t)
5123           ((string-match "^base64$" encoding) t)
5124           ((string-match "^quoted-printable$" encoding) t)
5125           ((eq vm-mime-8bit-text-transfer-encoding 'quoted-printable)
5126            (vm-mime-qp-encode-region beg end nil armor-from)
5127            (setq encoding "quoted-printable"))
5128           ((eq vm-mime-8bit-text-transfer-encoding 'base64)
5129            (vm-mime-base64-encode-region beg end crlf)
5130            (setq encoding "base64"))
5131           ((or armor-from armor-dot)
5132            (vm-mime-qp-encode-region beg end nil armor-from)
5133            (setq encoding "quoted-printable")))
5134     (downcase encoding) ))
5135
5136 (defun vm-mime-transfer-encode-layout (layout)
5137   (let ((list (vm-mm-layout-parts layout))
5138         (type (car (vm-mm-layout-type layout)))
5139         (encoding "7bit")
5140         (vm-mime-8bit-text-transfer-encoding
5141          vm-mime-8bit-text-transfer-encoding))
5142   (cond ((vm-mime-composite-type-p type)
5143          ;; MIME messages of type "message" and
5144          ;; "multipart" are required to have a non-opaque
5145          ;; content transfer encoding.  This means that
5146          ;; if the user only wants to send out 7bit data,
5147          ;; then any subpart that contains 8bit data must
5148          ;; have an opaque (qp or base64) 8->7bit
5149          ;; conversion performed on it so that the
5150          ;; enclosing entity can use a non-opaque
5151          ;; encoding.
5152          ;;
5153          ;; message/partial requires a "7bit" encoding so
5154          ;; force 8->7 conversion in that case.
5155          (cond ((memq vm-mime-8bit-text-transfer-encoding
5156                       '(quoted-printable base64))
5157                 t)
5158                ((vm-mime-types-match "message/partial" type)
5159                 (setq vm-mime-8bit-text-transfer-encoding
5160                       'quoted-printable)))
5161          (while list
5162            (if (equal (vm-mime-transfer-encode-layout (car list)) "8bit")
5163                (setq encoding "8bit"))
5164            (setq list (cdr list))))
5165         (t
5166          (if (and (vm-mime-types-match "message/partial" type)
5167                   (not (memq vm-mime-8bit-text-transfer-encoding
5168                              '(quoted-printable base64))))
5169                 (setq vm-mime-8bit-text-transfer-encoding
5170                       'quoted-printable))
5171          (setq encoding
5172                (vm-mime-transfer-encode-region (vm-mm-layout-encoding layout)
5173                                                (vm-mm-layout-body-start layout)
5174                                                (vm-mm-layout-body-end layout)
5175                                                (vm-mime-text-type-layout-p
5176                                                 layout)))))
5177   (if (not (equal encoding (downcase (car (vm-mm-layout-type layout)))))
5178       (save-excursion
5179         (save-restriction
5180           (goto-char (vm-mm-layout-header-start layout))
5181           (narrow-to-region (point) (vm-mm-layout-header-end layout))
5182           (vm-reorder-message-headers nil nil "Content-Transfer-Encoding:")
5183           (if (not (equal encoding "7bit"))
5184               (insert "CONTENT-TRANSFER-ENCODING: " encoding "\n"))
5185           encoding )))))
5186
5187 (defun vm-mime-text-description (start end)
5188   (save-excursion
5189     (goto-char start)
5190     (if (looking-at "[ \t\n]*-- \n")
5191         ".signature"
5192       (if (re-search-forward "^-- \n" nil t)
5193           "message body and .signature"
5194         "message body text"))))
5195 ;; tried this but random text in the object tag does't look right.
5196 ;;      (skip-chars-forward " \t\n")
5197 ;;      (let ((description (buffer-substring (point) (min (+ (point) 20) end)))
5198 ;;          (ellipsis (< (+ (point) 20) end))
5199 ;;          (i nil))
5200 ;;      (while (setq i (string-match "[\t\r\n]" description i))
5201 ;;        (aset description i " "))
5202 ;;      (cond ((= 0 (length description)) nil)
5203 ;;            (ellipsis (concat description "..."))
5204 ;;            (t description))))))
5205
5206 ;;;###autoload
5207 (defun vm-delete-mime-object (&optional saved-file)
5208   "Delete the contents of MIME object referred to by the MIME button at point.
5209 The MIME object is replaced by a text/plain object that briefly
5210 describes what was deleted."
5211   (interactive)
5212   (vm-follow-summary-cursor)
5213   (vm-select-folder-buffer)
5214   (vm-check-for-killed-summary)
5215   (vm-check-for-killed-presentation)
5216   (vm-error-if-folder-read-only)
5217   (vm-error-if-folder-empty)
5218   (if (and (vm-virtual-message-p (car vm-message-pointer))
5219            (null (vm-virtual-messages-of (car vm-message-pointer))))
5220       (error "Can't edit unmirrored virtual messages."))
5221   (and vm-presentation-buffer
5222        (set-buffer vm-presentation-buffer))
5223   (let (layout label)
5224     (cond (vm-fsfemacs-p
5225            (let (o-list o (found nil))
5226              (setq o-list (overlays-at (point)))
5227              (while (and o-list (not found))
5228                (setq o (car o-list))
5229                (cond ((setq layout (overlay-get o 'vm-mime-layout))
5230                       (setq found t)
5231                       (if (eq layout
5232                               (vm-mime-layout-of
5233                                (vm-mm-layout-message layout)))
5234                           (error "Can't delete only MIME object; use vm-delete-message instead."))
5235                       (if vm-mime-confirm-delete
5236                           (or (y-or-n-p (vm-mime-sprintf "Delete %t? " layout))
5237                               (error "Aborted")))
5238                       (vm-mime-discard-layout-contents layout saved-file)))
5239                (setq o-list (cdr o-list)))
5240              (if (not found)
5241                  (error "No MIME button found at point."))
5242              (let ((inhibit-read-only t)
5243                    (buffer-read-only nil))
5244                (save-excursion
5245                  (vm-save-restriction
5246                   (goto-char (overlay-start o))
5247                   (setq label (vm-mime-sprintf vm-mime-deleted-object-label layout))
5248                   (insert label)
5249                   (delete-region (point) (overlay-end o)))))))
5250           (vm-xemacs-p
5251            (let ((e (extent-at (point) nil 'vm-mime-layout)))
5252              (if (null e)
5253                  (error "No MIME button found at point.")
5254                (setq layout (extent-property e 'vm-mime-layout))
5255                (if (eq layout (vm-mime-layout-of
5256                                (vm-mm-layout-message layout)))
5257                    (error "Can't delete only MIME object; use vm-delete-message instead."))
5258                (if vm-mime-confirm-delete
5259                    (or (y-or-n-p (vm-mime-sprintf "Delete %t? " layout))
5260                        (error "Aborted")))
5261                (let ((inhibit-read-only t)
5262                      opos
5263                      (buffer-read-only nil))
5264                  (save-excursion
5265                    (vm-save-restriction
5266                      (goto-char (extent-start-position e))
5267                      (setq opos (point))
5268                      (setq label (vm-mime-sprintf vm-mime-deleted-object-label layout))
5269                      (insert label)
5270                      (delete-region (point) (extent-end-position e))
5271                      (set-extent-endpoints e opos (point)))))
5272                (vm-mime-discard-layout-contents layout saved-file)))))
5273     (when (interactive-p)
5274       ;; make the change visible and place the cursor behind the removed object
5275       (vm-discard-cached-data)
5276       (when vm-presentation-buffer
5277         (set-buffer vm-presentation-buffer)
5278         (re-search-forward (regexp-quote label) (point-max) t)))))
5279
5280 (defun vm-mime-discard-layout-contents (layout &optional file)
5281   (save-excursion
5282     (let ((inhibit-read-only t)
5283           (buffer-read-only nil)
5284           (m (vm-mm-layout-message layout))
5285           newid new-layout)
5286       (set-buffer (vm-buffer-of m))
5287       (vm-save-restriction
5288         (widen)
5289         (if (vm-mm-layout-is-converted layout)
5290             (setq layout (vm-mm-layout-unconverted-layout layout)))
5291         (goto-char (vm-mm-layout-header-start layout))
5292         (cond ((null file)
5293                (insert "Content-Type: text/plain; charset=us-ascii\n\n")
5294                (vm-set-mm-layout-body-start layout (point-marker))
5295                (insert (vm-mime-sprintf vm-mime-deleted-object-label layout)))
5296               (t
5297                (insert "Content-Type: message/external-body; access-type=local-file; name=\"" file "\"\n")
5298                (insert "Content-Transfer-Encoding: 7bit\n\n")
5299                (insert "Content-Type: " (car (vm-mm-layout-qtype layout)))
5300                (if (cdr (vm-mm-layout-qtype layout))
5301                    (let ((p (cdr (vm-mm-layout-qtype layout))))
5302                      (insert "; " (mapconcat 'identity p "; "))))
5303                (insert "\n")
5304                (if (vm-mm-layout-qdisposition layout)
5305                    (let ((p (vm-mm-layout-qdisposition layout)))
5306                      (insert "Content-Disposition: "
5307                              (mapconcat 'identity p "; ")
5308                              "\n")))
5309                (if (vm-mm-layout-id layout)
5310                    (insert "Content-ID: " (vm-mm-layout-id layout) "\n")
5311                  (setq newid (vm-make-message-id))
5312                  (insert "Content-ID: " newid "\n"))
5313                (insert "Content-Transfer-Encoding: binary\n\n")
5314                (insert "[Deleted " (vm-mime-sprintf "%d]\n" layout))
5315                (insert "[Saved to " file " on " (system-name) "]\n")))
5316         (delete-region (point) (vm-mm-layout-body-end layout))
5317         (vm-set-edited-flag-of m t)
5318         (vm-set-byte-count-of m nil)
5319         (vm-set-line-count-of m nil)
5320         (vm-set-stuff-flag-of m t)
5321         ;; For the dreaded From_-with-Content-Length folders recompute
5322         ;; the message length and make a new Content-Length header.
5323         (if (eq (vm-message-type-of m) 'From_-with-Content-Length)
5324             (let (length)
5325               (goto-char (vm-headers-of m))
5326               ;; first delete all copies of Content-Length
5327               (while (and (re-search-forward vm-content-length-search-regexp
5328                                              (vm-text-of m) t)
5329                           (null (match-beginning 1))
5330                           (progn (goto-char (match-beginning 0))
5331                                  (vm-match-header vm-content-length-header)))
5332                 (delete-region (vm-matched-header-start)
5333                                (vm-matched-header-end)))
5334               ;; now compute the message body length
5335               (setq length (- (vm-end-of m) (vm-text-of m)))
5336               ;; insert the header
5337               (goto-char (vm-headers-of m))
5338               (insert vm-content-length-header " "
5339                       (int-to-string length) "\n")))
5340         ;; make sure we get the summary updated.  The 'edited'
5341         ;; flag might already be set and therefore trying to set
5342         ;; it again might not have triggered an update.  We need
5343         ;; the update because the message size has changed.
5344         (vm-mark-for-summary-update (vm-mm-layout-message layout))
5345         (cond (file
5346                (save-restriction
5347                  (narrow-to-region (vm-mm-layout-header-start layout)
5348                                    (vm-mm-layout-body-end layout))
5349                  (setq new-layout (vm-mime-parse-entity-safe))
5350                  ;; should use accessor and mutator functions
5351                  ;; to copy the layout struct members, but i'm
5352                  ;; tired.
5353                  (let ((i (1- (length layout))))
5354                    (while (>= i 0)
5355                      (aset layout i (aref new-layout i))
5356                      (setq i (1- i))))))
5357               (t
5358                (vm-set-mm-layout-type layout '("text/plain"))
5359                (vm-set-mm-layout-qtype layout '("text/plain"))
5360                (vm-set-mm-layout-encoding layout "7bit")
5361                (vm-set-mm-layout-id layout nil)
5362                (vm-set-mm-layout-description
5363                 layout
5364                 (vm-mime-sprintf "Deleted %d" layout))
5365                (vm-set-mm-layout-disposition layout nil)
5366                (vm-set-mm-layout-qdisposition layout nil)
5367                (vm-set-mm-layout-parts layout nil)
5368                (vm-set-mm-layout-display-error layout nil)))))))
5369
5370 (defun vm-mime-encode-words (&optional encoding)
5371   (goto-char (point-min))
5372
5373   ;; find right encoding
5374   (setq encoding (or encoding vm-mime-encode-headers-type))
5375   (save-excursion
5376     (when (stringp encoding)
5377       (setq encoding
5378             (if (re-search-forward encoding (point-max) t)
5379                 'B
5380               'Q))))
5381   ;; now encode the words
5382   (let ((case-fold-search nil)
5383         start end charset coding)
5384     (while (re-search-forward vm-mime-encode-words-regexp (point-max) t)
5385       (setq start (match-beginning 0)
5386             end   (vm-marker (match-end 0))
5387             charset (or (vm-determine-proper-charset start end)
5388                         vm-mime-8bit-composition-charset)
5389             coding (vm-string-assoc charset vm-mime-mule-charset-to-coding-alist)
5390             coding (and coding (cadr coding)))
5391       ;; encode coding system body
5392       (when (and coding (not (eq coding 'no-conversion)))
5393         (vm-encode-coding-region start end coding))
5394       ;; encode
5395       (if (eq encoding 'Q)
5396           (vm-mime-Q-encode-region start end)
5397         (vm-mime-base64-encode-region  start end))
5398       ;; insert start and end markers
5399       (goto-char start)
5400       (insert "=?" charset "?" (format "%s" encoding) "?")
5401       (setq start (point))
5402       (goto-char end)
5403       (insert "?=")
5404       ;; goto end for next round
5405       (goto-char end))))
5406
5407 ;;;###autoload
5408 (defun vm-mime-encode-words-in-string (string &optional encoding)
5409   (vm-with-string-as-temp-buffer string 'vm-mime-encode-words))
5410
5411 (defun vm-mime-encode-headers ()
5412   "Encodes the headers of a message.
5413
5414 Only the words containing a non 7bit ASCII char are encoded, but not the whole
5415 header as this will cause trouble for the recipients and authors headers.
5416
5417 Whitespace between encoded words is trimmed during decoding and thus those
5418 should be encoded together."
5419   (interactive)
5420   (save-excursion
5421     (let ((headers (concat "^\\(" vm-mime-encode-headers-regexp "\\):"))
5422           (case-fold-search nil)
5423           (encoding vm-mime-encode-headers-type)
5424           body-start
5425           start end)
5426       (goto-char (point-min))
5427       (search-forward mail-header-separator)
5428       (setq body-start (vm-marker (match-beginning 0)))
5429       (goto-char (point-min))
5430
5431       (while (re-search-forward headers body-start t)
5432         (goto-char (match-end 0))
5433         (setq start (point))
5434         (when (not (looking-at "\\s-"))
5435           (insert " ")
5436           (backward-char 1))
5437         (save-excursion
5438           (setq end (or (and (re-search-forward "^[^ \t:]+:" body-start t)
5439                              (match-beginning 0))
5440                         body-start)))
5441         (vm-save-restriction
5442          (narrow-to-region start end)
5443          (vm-mime-encode-words))
5444         (goto-char end)))))
5445
5446 ;;;###autoload
5447 (defun vm-mime-encode-composition ()
5448  "MIME encode the current mail composition buffer.
5449 Attachment tags added to the buffer with `vm-mime-attach-file' are expanded
5450 and the approriate content-type and boundary markup information is added."
5451   (interactive)
5452
5453   (vm-disable-modes vm-disable-modes-before-encoding)
5454
5455   (vm-mime-encode-headers)
5456
5457   (buffer-enable-undo)
5458   (let ((unwind-needed t)
5459         (mybuffer (current-buffer)))
5460     (unwind-protect
5461         (progn
5462           (cond (vm-xemacs-p
5463                  (vm-mime-xemacs-encode-composition))
5464                 (vm-fsfemacs-p
5465                  (vm-mime-fsfemacs-encode-composition))
5466                 (t
5467                  (error "don't know how to MIME encode composition for %s"
5468                         (emacs-version))))
5469           (setq unwind-needed nil))
5470       (and unwind-needed (consp buffer-undo-list)
5471            (eq mybuffer (current-buffer))
5472            (setq buffer-undo-list (primitive-undo 1 buffer-undo-list))))))
5473
5474 (defvar enriched-mode)
5475
5476 ;; Non-XEmacs specific changes to this function should be made to
5477 ;; vm-mime-fsfemacs-encode-composition as well.
5478
5479 (defun vm-mime-xemacs-encode-composition ()
5480   "Encode the current message using MIME.
5481
5482 The Multipurpose Internet Message Extensions extend the original format of
5483 Internet mail to allow non-US-ASCII textual messages, non-textual messages,
5484 multipart message bodies, and non-US-ASCII information in message headers.
5485
5486 This function chooses the MIME character set(s) to use, and transforms the
5487 message content from the XEmacs-internal encoding to the corresponding
5488 octets in that MIME character set.
5489
5490 It then applies some transfer encoding to the message. For details of the
5491 transfer encodings available, see the documentation for
5492 `vm-mime-8bit-text-transfer-encoding.'
5493
5494 Finally, it creates the headers that are necessary to identify the message
5495 as one that uses MIME.
5496
5497 Under MULE, it explicitly sets `buffer-file-coding-system' to a binary
5498  (no-transformation) coding system, to avoid further transformation of the
5499 message content when it's passed to the MTA (that is, the mail transfer
5500 agent; under Unix, normally sendmail.)"
5501   (save-restriction
5502     (widen)
5503     (if (not (eq major-mode 'mail-mode))
5504         (error "Command must be used in a VM Mail mode buffer."))
5505     (or (null (vm-mail-mode-get-header-contents "MIME-Version:"))
5506         (error "Message is already MIME encoded."))
5507     (let ((8bit nil)
5508           (just-one nil)
5509           (boundary-positions nil)
5510           (enriched (and (boundp 'enriched-mode) enriched-mode))
5511           forward-local-refs already-mimed layout e e-list boundary
5512           type encoding charset params description disposition object
5513           opoint-min
5514           postponed-attachment)
5515       ;;Make sure we don't double encode UTF-8 (for example) text.
5516       (setq buffer-file-coding-system (vm-binary-coding-system))
5517       (goto-char (mail-text-start))
5518       (setq e-list (extent-list nil (point) (point-max))
5519             e-list (vm-delete (function
5520                                (lambda (e)
5521                                  (extent-property e 'vm-mime-object)))
5522                               e-list t)
5523             e-list (sort e-list (function
5524                                  (lambda (e1 e2)
5525                                    (< (extent-end-position e1)
5526                                       (extent-end-position e2))))))
5527       ;; If there's just one attachment and no other readable
5528       ;; text in the buffer then make the message type just be
5529       ;; the attachment type rather than sending a multipart
5530       ;; message with one attachment
5531       (setq just-one (and (= (length e-list) 1)
5532                           (looking-at "[ \t\n]*")
5533                           (= (match-end 0)
5534                              (extent-start-position (car e-list)))
5535                           (save-excursion
5536                             (goto-char (extent-end-position (car e-list)))
5537                             (looking-at "[ \t\n]*\\'"))))
5538       (if (null e-list)
5539           (progn
5540             (narrow-to-region (point) (point-max))
5541             ;; support enriched-mode for text/enriched composition
5542             (if enriched
5543                 (let ((enriched-initial-annotation ""))
5544                   (enriched-encode (point-min) (point-max))))
5545
5546             (setq charset (vm-determine-proper-charset (point-min)
5547                                                        (point-max)))
5548             (if vm-xemacs-mule-p
5549                 (encode-coding-region
5550                  (point-min) (point-max)
5551
5552                  ;; What about the case where vm-m-m-c-t-c-a doesn't have an
5553                  ;; entry for the given charset? That shouldn't happen, if
5554                  ;; vm-mime-mule-coding-to-charset-alist and
5555                  ;; vm-mime-mule-charset-to-coding-alist have complete and
5556                  ;; matching entries. Admittedly this last is not a
5557                  ;; given. Should we make it so on startup? (By setting the
5558                  ;; key for any missing entries in
5559                  ;; vm-mime-mule-coding-to-charset-alist to being (format
5560                  ;; "%s" coding-system), if necessary.)
5561
5562                  (car (cdr (vm-string-assoc
5563                             charset vm-mime-mule-charset-to-coding-alist)))))
5564
5565             (enriched-mode -1)
5566             (setq encoding (vm-determine-proper-content-transfer-encoding
5567                             (point-min)
5568                             (point-max))
5569                   encoding (vm-mime-transfer-encode-region encoding
5570                                                            (point-min)
5571                                                            (point-max)
5572                                                            t))
5573             (widen)
5574             (vm-remove-mail-mode-header-separator)
5575             (goto-char (point-min))
5576             (vm-reorder-message-headers
5577              nil nil "\\(Content-Type:\\|Content-Transfer-Encoding\\|MIME-Version:\\)")
5578             (insert "MIME-Version: 1.0\n")
5579             (if enriched
5580                 (insert "Content-Type: text/enriched; charset=" charset "\n")
5581               (insert "Content-Type: text/plain; charset=" charset "\n"))
5582             (insert "Content-Transfer-Encoding: " encoding "\n")
5583             (vm-add-mail-mode-header-separator))
5584         (while e-list
5585           (setq e (car e-list))
5586           (if (or just-one
5587                   (save-excursion
5588                     (eq (extent-start-position e)
5589                         (re-search-forward "[ \t\n]*"
5590                                            (extent-start-position e) t))))
5591               (delete-region (point) (extent-start-position e))
5592             (narrow-to-region (point) (extent-start-position e))
5593             (if enriched
5594                 (let ((enriched-initial-annotation ""))
5595                   (enriched-encode (point-min) (point-max))))
5596
5597             (setq charset (vm-determine-proper-charset (point-min)
5598                                                        (point-max)))
5599             (if vm-xemacs-mule-p
5600                 (encode-coding-region
5601                  (point-min) (point-max)
5602
5603                  ;; What about the case where vm-m-m-c-t-c-a doesn't have an
5604                  ;; entry for the given charset? That shouldn't happen, if
5605                  ;; vm-mime-mule-coding-to-charset-alist and
5606                  ;; vm-mime-mule-charset-to-coding-alist have complete and
5607                  ;; matching entries. Admittedly this last is not a
5608                  ;; given. Should we make it so on startup? (By setting the
5609                  ;; key for any missing entries in
5610                  ;; vm-mime-mule-coding-to-charset-alist to being (format
5611                  ;; "%s" coding-system), if necessary.)
5612
5613                  (car (cdr (vm-string-assoc
5614                             charset vm-mime-mule-charset-to-coding-alist)))))
5615
5616             (setq encoding (vm-determine-proper-content-transfer-encoding
5617                             (point-min)
5618                             (point-max))
5619                   encoding (vm-mime-transfer-encode-region encoding
5620                                                            (point-min)
5621                                                            (point-max)
5622                                                            t)
5623                   description (vm-mime-text-description (point-min)
5624                                                         (point-max)))
5625             (setq boundary-positions (cons (point-marker) boundary-positions))
5626             (if enriched
5627                 (insert "Content-Type: text/enriched; charset=" charset "\n")
5628               (insert "Content-Type: text/plain; charset=" charset "\n"))
5629             (if description
5630                 (insert "Content-Description: " description "\n"))
5631             (insert "Content-Transfer-Encoding: " encoding "\n\n")
5632             (widen))
5633           (goto-char (extent-start-position e))
5634           (narrow-to-region (point) (point))
5635           (setq object (extent-property e 'vm-mime-object))
5636
5637           ;; insert the object
5638           (cond ((bufferp object)
5639                  (insert-buffer-substring object))
5640                 ((listp object)
5641                  (save-restriction
5642                    (save-excursion (set-buffer (nth 0 object))
5643                                    (widen))
5644                    (setq boundary-positions (cons (point-marker)
5645                                                   boundary-positions))
5646                    (insert-buffer-substring (nth 0 object)
5647                                             (nth 1 object)
5648                                             (nth 2 object))
5649                    (setq postponed-attachment t)
5650                    ))
5651                 ((stringp object)
5652                  (let ((coding-system-for-read
5653                         (if (vm-mime-text-type-p
5654                              (extent-property e 'vm-mime-type))
5655                             (vm-line-ending-coding-system)
5656                           (vm-binary-coding-system)))
5657                        ;; keep no undos
5658                        (buffer-undo-list t)
5659                        ;; no transformations!
5660                        (format-alist nil)
5661                        ;; no decompression!
5662                        (jka-compr-compression-info-list nil)
5663                        ;; don't let buffer-file-coding-system be changed
5664                        ;; by insert-file-contents.  The
5665                        ;; value we bind to it to here isn't important.
5666                        (buffer-file-coding-system (vm-binary-coding-system)))
5667                    (insert-file-contents object))))
5668           ;; gather information about the object from the extent.
5669           (if (setq already-mimed (extent-property e 'vm-mime-encoded))
5670               (setq layout (vm-mime-parse-entity
5671                             nil (list "text/plain" "charset=us-ascii")
5672                             "7bit")
5673                     type (or (extent-property e 'vm-mime-type)
5674                              (car (vm-mm-layout-type layout)))
5675                     params (or (extent-property e 'vm-mime-parameters)
5676                                (cdr (vm-mm-layout-qtype layout)))
5677                     forward-local-refs
5678                         (car (extent-property e 'vm-mime-forward-local-refs))
5679                     description (extent-property e 'vm-mime-description)
5680                     disposition
5681                       (if (not
5682                            (equal
5683                             (car (extent-property e 'vm-mime-disposition))
5684                             "unspecified"))
5685                           (extent-property e 'vm-mime-disposition)
5686                         (vm-mm-layout-qdisposition layout)))
5687             (setq type (extent-property e 'vm-mime-type)
5688                   params (extent-property e 'vm-mime-parameters)
5689                   forward-local-refs
5690                       (car (extent-property e 'vm-mime-forward-local-refs))
5691                   description (extent-property e 'vm-mime-description)
5692                   disposition
5693                     (if (not (equal
5694                               (car (extent-property e 'vm-mime-disposition))
5695                               "unspecified"))
5696                         (extent-property e 'vm-mime-disposition)
5697                       nil)))
5698           (cond ((vm-mime-types-match "text" type)
5699                  (setq encoding
5700                        (or
5701                         (extent-property e 'vm-mime-encoding)
5702                         (vm-determine-proper-content-transfer-encoding
5703                          (if already-mimed
5704                              (vm-mm-layout-body-start layout)
5705                            (point-min))
5706                          (point-max)))
5707                        encoding (vm-mime-transfer-encode-region
5708                                  encoding
5709                                  (if already-mimed
5710                                      (vm-mm-layout-body-start layout)
5711                                    (point-min))
5712                                  (point-max)
5713                                  t))
5714                  (setq 8bit (or 8bit (equal encoding "8bit"))))
5715                 ((vm-mime-composite-type-p type)
5716                  (setq opoint-min (point-min))
5717                  (if (not already-mimed)
5718                      (progn
5719                        (goto-char (point-min))
5720                        (insert "Content-Type: " type "\n")
5721                        ;; vm-mime-transfer-encode-layout will replace
5722                        ;; this if the transfer encoding changes.
5723                        (insert "Content-Transfer-Encoding: 7bit\n\n")
5724                        (setq layout (vm-mime-parse-entity
5725                                      nil (list "text/plain" "charset=us-ascii")
5726                                      "7bit"))
5727                        (setq already-mimed t)))
5728                  (and layout (not forward-local-refs)
5729                       (vm-mime-internalize-local-external-bodies layout))
5730                  (setq encoding (vm-mime-transfer-encode-layout layout))
5731                  (setq 8bit (or 8bit (equal encoding "8bit")))
5732                  (goto-char (point-max))
5733                  (widen)
5734                  (narrow-to-region opoint-min (point)))
5735                 ((not postponed-attachment)
5736                  (and layout (not forward-local-refs)
5737                       (vm-mime-internalize-local-external-bodies layout))
5738                  (if already-mimed
5739                      (setq encoding (vm-mime-transfer-encode-layout layout))
5740                    (vm-mime-base64-encode-region (point-min) (point-max))
5741                    (setq encoding "base64"))))
5742           (if (or just-one postponed-attachment)
5743               nil
5744             (goto-char (point-min))
5745             (setq boundary-positions (cons (point-marker) boundary-positions))
5746             (if (not already-mimed)
5747                 nil
5748               ;; trim headers
5749               (vm-reorder-message-headers nil '("Content-ID:") nil)
5750               ;; remove header/text separator
5751               (goto-char (1- (vm-mm-layout-body-start layout)))
5752               (if (looking-at "\n")
5753                   (delete-char 1)))
5754             (insert "Content-Type: " type)
5755             (if params
5756                 (if vm-mime-avoid-folding-content-type
5757                     (insert "; " (mapconcat 'identity params "; ") "\n")
5758                   (insert ";\n\t" (mapconcat 'identity params ";\n\t") "\n"))
5759               (insert "\n"))
5760             (and description
5761                  (insert "Content-Description: " description "\n"))
5762             (if disposition
5763                 (progn
5764                   (insert "Content-Disposition: " (car disposition))
5765                   (if (cdr disposition)
5766                       (insert ";\n\t" (mapconcat 'identity
5767                                                  (cdr disposition)
5768                                                  ";\n\t")))
5769                   (insert "\n")))
5770             (insert "Content-Transfer-Encoding: " encoding "\n\n"))
5771           (goto-char (point-max))
5772           (widen)
5773           (save-excursion
5774             (goto-char (extent-start-position e))
5775             (vm-assert (looking-at "\\[ATTACHMENT")))
5776           (delete-region (extent-start-position e)
5777                          (extent-end-position e))
5778           (detach-extent e)
5779           (if (looking-at "\n")
5780               (delete-char 1))
5781           (setq e-list (cdr e-list)))
5782         ;; handle the remaining chunk of text after the last
5783         ;; extent, if any.
5784         (if (or just-one (looking-at "[ \t\n]*\\'"))
5785             (delete-region (point) (point-max))
5786           (if enriched
5787               (let ((enriched-initial-annotation ""))
5788                 (enriched-encode (point) (point-max))))
5789           (setq charset (vm-determine-proper-charset (point)
5790                                                      (point-max)))
5791           (if vm-xemacs-mule-p
5792               (encode-coding-region
5793                (point) (point-max)
5794
5795                ;; What about the case where vm-m-m-c-t-c-a doesn't have an
5796                ;; entry for the given charset? That shouldn't happen, if
5797                ;; vm-mime-mule-coding-to-charset-alist and
5798                ;; vm-mime-mule-charset-to-coding-alist have complete and
5799                ;; matching entries. Admittedly this last is not a
5800                ;; given. Should we make it so on startup? (By setting the
5801                ;; key for any missing entries in
5802                ;; vm-mime-mule-coding-to-charset-alist to being (format "%s"
5803                ;; coding-system), if necessary.)
5804
5805                  (car (cdr (vm-string-assoc
5806                             charset vm-mime-mule-charset-to-coding-alist)))))
5807
5808           (setq encoding (vm-determine-proper-content-transfer-encoding
5809                           (point)
5810                           (point-max))
5811                 encoding (vm-mime-transfer-encode-region encoding
5812                                                          (point)
5813                                                          (point-max)
5814                                                          t)
5815                 description (vm-mime-text-description (point) (point-max)))
5816           (setq 8bit (or 8bit (equal encoding "8bit")))
5817           (setq boundary-positions (cons (point-marker) boundary-positions))
5818           (if enriched
5819               (insert "Content-Type: text/enriched; charset=" charset "\n")
5820             (insert "Content-Type: text/plain; charset=" charset "\n"))
5821           (if description
5822               (insert "Content-Description: " description "\n"))
5823           (insert "Content-Transfer-Encoding: " encoding "\n\n")
5824           (goto-char (point-max)))
5825         (setq boundary (vm-mime-make-multipart-boundary))
5826         (mail-text)
5827         (while (re-search-forward (concat "^--"
5828                                           (regexp-quote boundary)
5829                                           "\\(--\\)?$")
5830                                   nil t)
5831           (setq boundary (vm-mime-make-multipart-boundary))
5832           (mail-text))
5833         (goto-char (point-max))
5834         (or just-one (insert "\n--" boundary "--\n"))
5835         (while boundary-positions
5836           (goto-char (car boundary-positions))
5837           (insert "\n--" boundary "\n")
5838           (setq boundary-positions (cdr boundary-positions)))
5839         (if (and just-one already-mimed)
5840             (progn
5841               (goto-char (vm-mm-layout-header-start layout))
5842               ;; trim headers
5843               (vm-reorder-message-headers nil '("Content-ID:") nil)
5844               ;; remove header/text separator
5845               (goto-char (vm-mm-layout-header-end layout))
5846               (if (looking-at "\n")
5847                   (delete-char 1))
5848               ;; copy remainder to enclosing entity's header section
5849               (goto-char (point-max))
5850               (if (not just-one)
5851                   (insert-buffer-substring (current-buffer)
5852                                            (vm-mm-layout-header-start layout)
5853                                            (vm-mm-layout-body-start layout)))
5854               (delete-region (vm-mm-layout-header-start layout)
5855                              (vm-mm-layout-body-start layout))))
5856         (goto-char (point-min))
5857         (vm-remove-mail-mode-header-separator)
5858         (vm-reorder-message-headers
5859          nil nil "\\(Content-Type:\\|MIME-Version:\\|Content-Transfer-Encoding\\)")
5860         (vm-add-mail-mode-header-separator)
5861         (insert "MIME-Version: 1.0\n")
5862         (if (not just-one)
5863             (insert (if vm-mime-avoid-folding-content-type
5864                         "Content-Type: multipart/mixed; boundary=\""
5865                       "Content-Type: multipart/mixed;\n\tboundary=\"")
5866                     boundary "\"\n")
5867           (insert "Content-Type: " type)
5868           (if params
5869               (if vm-mime-avoid-folding-content-type
5870                   (insert "; " (mapconcat 'identity params "; ") "\n")
5871                 (insert ";\n\t" (mapconcat 'identity params ";\n\t") "\n"))
5872             (insert "\n")))
5873         (if (and just-one description)
5874             (insert "Content-Description: " description "\n"))
5875         (if (and just-one disposition)
5876             (progn
5877               (insert "Content-Disposition: " (car disposition))
5878               (if (cdr disposition)
5879                   (if vm-mime-avoid-folding-content-type
5880                       (insert "; " (mapconcat 'identity (cdr disposition) "; ")
5881                               "\n")
5882                     (insert ";\n\t" (mapconcat 'identity (cdr disposition)
5883                                                ";\n\t") "\n"))
5884                 (insert "\n"))))
5885         (if just-one
5886             (insert "Content-Transfer-Encoding: " encoding "\n")
5887           (if 8bit
5888               (insert "Content-Transfer-Encoding: 8bit\n")
5889             (insert "Content-Transfer-Encoding: 7bit\n")))))))
5890
5891 ;; Non-FSF-Emacs specific changes to this function should be
5892 ;; made to vm-mime-xemacs-encode-composition as well.
5893 (defun vm-mime-fsfemacs-encode-composition ()
5894   (save-restriction
5895     (widen)
5896     (if (not (eq major-mode 'mail-mode))
5897         (error "Command must be used in a VM Mail mode buffer."))
5898     (or (null (vm-mail-mode-get-header-contents "MIME-Version:"))
5899         (error "Message is already MIME encoded."))
5900     (let ((8bit nil)
5901           (just-one nil)
5902           (boundary-positions nil)
5903           (enriched (and (boundp 'enriched-mode) enriched-mode))
5904           forward-local-refs already-mimed layout o o-list boundary
5905           type encoding charset params description disposition object
5906           opoint-min delete-object postponed-attachment)
5907       (goto-char (mail-text-start))
5908       (setq o-list (vm-mime-fake-attachment-overlays (point) (point-max))
5909             o-list (vm-delete (function
5910                                (lambda (o)
5911                                  (overlay-get o 'vm-mime-object)))
5912                               o-list t)
5913             o-list (sort o-list (function
5914                                  (lambda (e1 e2)
5915                                    (< (overlay-end e1)
5916                                       (overlay-end e2))))))
5917       ;; If there's just one attachment and no other readable
5918       ;; text in the buffer then make the message type just be
5919       ;; the attachment type rather than sending a multipart
5920       ;; message with one attachment
5921       (setq just-one (and (= (length o-list) 1)
5922                           (looking-at "[ \t\n]*")
5923                           (= (match-end 0)
5924                              (overlay-start (car o-list)))
5925                           (save-excursion
5926                             (goto-char (overlay-end (car o-list)))
5927                             (looking-at "[ \t\n]*\\'"))))
5928       (if (null o-list)
5929           (progn
5930             (narrow-to-region (point) (point-max))
5931            ;; support enriched-mode for text/enriched composition
5932             (if enriched
5933                 (let ((enriched-initial-annotation ""))
5934                   (enriched-encode (point-min) (point-max))))
5935             (setq charset (vm-determine-proper-charset (point-min)
5936                                                        (point-max)))
5937             (if vm-fsfemacs-mule-p
5938                 (let ((coding-system
5939                        (car (cdr (vm-string-assoc
5940                                   charset
5941                                   vm-mime-mule-charset-to-coding-alist)))))
5942                   (if (null coding-system)
5943                       (error "Can't find a coding system for charset %s"
5944                              charset)
5945                     (encode-coding-region (point-min) (point-max)
5946                                           coding-system))))
5947             (setq encoding (vm-determine-proper-content-transfer-encoding
5948                             (point-min)
5949                             (point-max))
5950                   encoding (vm-mime-transfer-encode-region encoding
5951                                                            (point-min)
5952                                                            (point-max)
5953                                                            t))
5954             (widen)
5955             (vm-remove-mail-mode-header-separator)
5956             (goto-char (point-min))
5957             (vm-reorder-message-headers
5958              nil nil "\\(Content-Type:\\|Content-Transfer-Encoding\\|MIME-Version:\\)")
5959             (insert "MIME-Version: 1.0\n")
5960             (if enriched
5961                 (insert "Content-Type: text/enriched; charset=" charset "\n")
5962               (insert "Content-Type: text/plain; charset=" charset "\n"))
5963             (insert "Content-Transfer-Encoding: " encoding "\n")
5964             (vm-add-mail-mode-header-separator))
5965         (while o-list
5966           (setq o (car o-list))
5967           (if (or just-one
5968                   (save-excursion
5969                     (eq (overlay-start o)
5970                         (re-search-forward "[ \t\n]*" (overlay-start o) t))))
5971               (delete-region (point) (overlay-start o))
5972             (narrow-to-region (point) (overlay-start o))
5973            ;; support enriched-mode for text/enriched composition
5974             (if enriched
5975                 (let ((enriched-initial-annotation ""))
5976                   (save-excursion
5977                     ;; insert/delete trick needed to avoid
5978                     ;; enriched-mode tags from seeping into the
5979                     ;; attachment overlays.  I really wish
5980                     ;; front-advance / rear-advance overlay
5981                     ;; endpoint properties actually worked.
5982                     (goto-char (point-max))
5983                     (insert-before-markers "\n")
5984                     (enriched-encode (point-min) (1- (point)))
5985                     (goto-char (point-max))
5986                     (delete-char -1))))
5987             (setq charset (vm-determine-proper-charset (point-min)
5988                                                        (point-max)))
5989             (if vm-fsfemacs-mule-p
5990                 (let ((coding-system
5991                        (car (cdr (vm-string-assoc
5992                                   charset
5993                                   vm-mime-mule-charset-to-coding-alist)))))
5994                   (if (null coding-system)
5995                       (error "Can't find a coding system for charset %s"
5996                              charset)
5997                     (encode-coding-region (point-min) (point-max)
5998                                           coding-system))))
5999             (setq encoding (vm-determine-proper-content-transfer-encoding
6000                             (point-min)
6001                             (point-max))
6002                   encoding (vm-mime-transfer-encode-region encoding
6003                                                            (point-min)
6004                                                            (point-max)
6005                                                            t)
6006                   description (vm-mime-text-description (point-min)
6007                                                         (point-max)))
6008             (setq boundary-positions (cons (point-marker) boundary-positions))
6009             (if enriched
6010                 (insert "Content-Type: text/enriched; charset=" charset "\n")
6011               (insert "Content-Type: text/plain; charset=" charset "\n"))
6012             (if description
6013                 (insert "Content-Description: " description "\n"))
6014             (insert "Content-Transfer-Encoding: " encoding "\n\n")
6015             (widen))
6016           (goto-char (overlay-start o))
6017           (narrow-to-region (point) (point))
6018           (setq object (overlay-get o 'vm-mime-object))
6019           (setq delete-object nil)
6020           (cond ((bufferp object)
6021                  ;; Under Emacs 20.7 inserting a unibyte buffer
6022                  ;; contents that contain 8-bit characters into a
6023                  ;; multibyte buffer causes the inserted data to be
6024                  ;; corrupted with the dreaded \201 corruption.  So
6025                  ;; we write the data out to disk and let the file
6026                  ;; be inserted, which gets aoround the problem.
6027                  (let ((tempfile (vm-make-tempfile)))
6028                    ;; make note to delete the tempfile after insertion
6029                    (setq delete-object t)
6030                    (save-excursion
6031                      (set-buffer object)
6032                      (let ((buffer-file-coding-system
6033                                (vm-binary-coding-system)))
6034                        (write-region (point-min) (point-max) tempfile nil 0))
6035                      (setq object tempfile)))))
6036           ;; insert attachment from postponed message
6037           (cond ((listp object)
6038                  (save-restriction
6039                    (save-excursion (set-buffer (nth 0 object))
6040                                    (widen))
6041                    (setq boundary-positions (cons (point-marker)
6042                                                   boundary-positions))
6043                    (insert-buffer-substring (nth 0 object)
6044                                             (nth 1 object)
6045                                             (nth 2 object))
6046                    (setq postponed-attachment t)
6047                    )))
6048           ;; insert the object
6049           (cond ((stringp object)
6050                  ;; as of FSF Emacs 19.34, even with the hooks
6051                  ;; we've attached to the attachment overlays,
6052                  ;; text STILL can be inserted into them when
6053                  ;; font-lock is enabled.  Explaining why is
6054                  ;; beyond the scope of this comment and I
6055                  ;; don't know the answer anyway.  This
6056                  ;; insertion dance work to prevent it.
6057                  (insert-before-markers " ")
6058                  (forward-char -1)
6059                  (let ((coding-system-for-read
6060                         (if (vm-mime-text-type-p
6061                              (overlay-get o 'vm-mime-type))
6062                             (vm-line-ending-coding-system)
6063                           (vm-binary-coding-system)))
6064                        ;; keep no undos
6065                        (buffer-undo-list t)
6066                        ;; no transformations!
6067                        (format-alist nil)
6068                        ;; no decompression!
6069                        (jka-compr-compression-info-list nil)
6070                        ;; don't let buffer-file-coding-system be
6071                        ;; changed by insert-file-contents.  The
6072                        ;; value we bind to it to here isn't
6073                        ;; important.
6074                        (buffer-file-coding-system (vm-binary-coding-system))
6075                        ;; For NTEmacs 19: need to do this to make
6076                        ;; sure CRs aren't eaten.
6077                        (file-name-buffer-file-type-alist '(("." . t))))
6078                    (condition-case data
6079                        (insert-file-contents object)
6080                      (error
6081                       (if delete-object
6082                           (vm-error-free-call 'delete-file object))
6083                       ;; font-lock could signal this error in FSF
6084                       ;; Emacs versions prior to 21.0.  Catch it
6085                       ;; and ignore it.
6086                       (if (equal data '(error "Invalid search bound (wrong side of point)"))
6087                           nil
6088                         (signal (car data) (cdr data))))))
6089                  (if delete-object
6090                      (vm-error-free-call 'delete-file object))
6091                  (goto-char (point-max))
6092                  (delete-char -1)))
6093           ;; gather information about the object from the extent.
6094           (if (setq already-mimed (overlay-get o 'vm-mime-encoded))
6095               (setq layout (vm-mime-parse-entity
6096                             nil (list "text/plain" "charset=us-ascii")
6097                             "7bit")
6098                     type (or (overlay-get o 'vm-mime-type)
6099                              (car (vm-mm-layout-type layout)))
6100                     params (or (overlay-get o 'vm-mime-parameters)
6101                                (cdr (vm-mm-layout-qtype layout)))
6102                     forward-local-refs
6103                         (car (overlay-get o 'vm-mime-forward-local-refs))
6104                     description (overlay-get o 'vm-mime-description)
6105                     disposition
6106                     (if (not
6107                          (equal
6108                           (car (overlay-get o 'vm-mime-disposition))
6109                           "unspecified"))
6110                         (overlay-get o 'vm-mime-disposition)
6111                       (vm-mm-layout-qdisposition layout)))
6112             (setq type (overlay-get o 'vm-mime-type)
6113                   params (overlay-get o 'vm-mime-parameters)
6114                   forward-local-refs
6115                       (car (overlay-get o 'vm-mime-forward-local-refs))
6116                   description (overlay-get o 'vm-mime-description)
6117                   disposition
6118                   (if (not (equal
6119                             (car (overlay-get o 'vm-mime-disposition))
6120                             "unspecified"))
6121                       (overlay-get o 'vm-mime-disposition)
6122                     nil)))
6123           (cond ((vm-mime-types-match "text" type)
6124                  (setq encoding
6125                        (or (overlay-get o 'vm-mime-encoding)
6126                            (vm-determine-proper-content-transfer-encoding
6127                             (if already-mimed
6128                                 (vm-mm-layout-body-start layout)
6129                               (point-min))
6130                             (point-max)))
6131                        encoding (vm-mime-transfer-encode-region
6132                                  encoding
6133                                  (if already-mimed
6134                                      (vm-mm-layout-body-start layout)
6135                                    (point-min))
6136                                  (point-max)
6137                                  t))
6138                  (setq 8bit (or 8bit (equal encoding "8bit"))))
6139                 ((vm-mime-composite-type-p type)
6140                  (setq opoint-min (point-min))
6141                  (if (not already-mimed)
6142                      (progn
6143                        (goto-char (point-min))
6144                        (insert "Content-Type: " type "\n")
6145                        ;; vm-mime-transfer-encode-layout will replace
6146                        ;; this if the transfer encoding changes.
6147                        (insert "Content-Transfer-Encoding: 7bit\n\n")
6148                        (setq layout (vm-mime-parse-entity
6149                                      nil (list "text/plain" "charset=us-ascii")
6150                                      "7bit"))
6151                        (setq already-mimed t)))
6152                  (and layout (not forward-local-refs)
6153                       (vm-mime-internalize-local-external-bodies layout))
6154                  (setq encoding (vm-mime-transfer-encode-layout layout))
6155                  (setq 8bit (or 8bit (equal encoding "8bit")))
6156                  (goto-char (point-max))
6157                  (widen)
6158                  (narrow-to-region opoint-min (point)))
6159                 ((not postponed-attachment)
6160                  (and layout (not forward-local-refs)
6161                       (vm-mime-internalize-local-external-bodies layout))
6162                  (if already-mimed
6163                      (setq encoding (vm-mime-transfer-encode-layout layout))
6164                    (vm-mime-base64-encode-region (point-min) (point-max))
6165                    (setq encoding "base64"))))
6166           (if (or just-one postponed-attachment)
6167               nil
6168             (goto-char (point-min))
6169             (setq boundary-positions (cons (point-marker) boundary-positions))
6170             (if (not already-mimed)
6171                 nil
6172               ;; trim headers
6173               (vm-reorder-message-headers nil '("Content-ID:") nil)
6174               ;; remove header/text separator
6175               (goto-char (1- (vm-mm-layout-body-start layout)))
6176               (if (looking-at "\n")
6177                   (delete-char 1)))
6178             (insert "Content-Type: " type)
6179             (if params
6180                 (if vm-mime-avoid-folding-content-type
6181                     (insert "; " (mapconcat 'identity params "; ") "\n")
6182                   (insert ";\n\t" (mapconcat 'identity params ";\n\t") "\n"))
6183               (insert "\n"))
6184             (and description
6185                  (insert "Content-Description: " description "\n"))
6186             (if disposition
6187                 (progn
6188                   (insert "Content-Disposition: " (car disposition))
6189                   (if (cdr disposition)
6190                       (insert ";\n\t" (mapconcat 'identity
6191                                                  (cdr disposition)
6192                                                  ";\n\t")))
6193                   (insert "\n")))
6194             (insert "Content-Transfer-Encoding: " encoding "\n\n"))
6195           (goto-char (point-max))
6196           (widen)
6197           (save-excursion
6198             (goto-char (overlay-start o))
6199             (vm-assert (looking-at "\\[ATTACHMENT")))
6200           (delete-region (overlay-start o)
6201                          (overlay-end o))
6202           (delete-overlay o)
6203           (if (looking-at "\n")
6204               (delete-char 1))
6205           (setq o-list (cdr o-list)))
6206         ;; handle the remaining chunk of text after the last
6207         ;; extent, if any.
6208         (if (or just-one (looking-at "[ \t\n]*\\'"))
6209             (delete-region (point) (point-max))
6210           ;; support enriched-mode for text/enriched composition
6211           (if enriched
6212               (let ((enriched-initial-annotation ""))
6213                 (enriched-encode (point) (point-max))))
6214           (setq charset (vm-determine-proper-charset (point)
6215                                                      (point-max)))
6216           (if vm-fsfemacs-mule-p
6217               (let ((coding-system
6218                      (car (cdr (vm-string-assoc
6219                                 charset
6220                                 vm-mime-mule-charset-to-coding-alist)))))
6221                 (if (null coding-system)
6222                     (error "Can't find a coding system for charset %s"
6223                            charset)
6224                   (encode-coding-region (point) (point-max)
6225                                         coding-system))))
6226           (setq encoding (vm-determine-proper-content-transfer-encoding
6227                           (point)
6228                           (point-max))
6229                 encoding (vm-mime-transfer-encode-region encoding
6230                                                          (point)
6231                                                          (point-max)
6232                                                          t)
6233                 description (vm-mime-text-description (point) (point-max)))
6234           (setq 8bit (or 8bit (equal encoding "8bit")))
6235           (setq boundary-positions (cons (point-marker) boundary-positions))
6236           (if enriched
6237               (insert "Content-Type: text/enriched; charset=" charset "\n")
6238             (insert "Content-Type: text/plain; charset=" charset "\n"))
6239           (if description
6240               (insert "Content-Description: " description "\n"))
6241           (insert "Content-Transfer-Encoding: " encoding "\n\n")
6242           (goto-char (point-max)))
6243         (setq boundary (vm-mime-make-multipart-boundary))
6244         (mail-text)
6245         (while (re-search-forward (concat "^--"
6246                                           (regexp-quote boundary)
6247                                           "\\(--\\)?$")
6248                                   nil t)
6249           (setq boundary (vm-mime-make-multipart-boundary))
6250           (mail-text))
6251         (goto-char (point-max))
6252         (or just-one (insert "\n--" boundary "--\n"))
6253         (while boundary-positions
6254           (goto-char (car boundary-positions))
6255           (insert "\n--" boundary "\n")
6256           (setq boundary-positions (cdr boundary-positions)))
6257         (if (and just-one already-mimed)
6258             (progn
6259               (goto-char (vm-mm-layout-header-start layout))
6260               ;; trim headers
6261               (vm-reorder-message-headers nil '("Content-ID:") nil)
6262               ;; remove header/text separator
6263               (goto-char (vm-mm-layout-header-end layout))
6264               (if (looking-at "\n")
6265                   (delete-char 1))
6266            ;; copy remainder to enclosing entity's header section
6267               (goto-char (point-max))
6268               (if (not just-one)
6269                   (insert-buffer-substring (current-buffer)
6270                                            (vm-mm-layout-header-start layout)
6271                                            (vm-mm-layout-body-start layout)))
6272               (delete-region (vm-mm-layout-header-start layout)
6273                              (vm-mm-layout-body-start layout))))
6274         (goto-char (point-min))
6275         (vm-remove-mail-mode-header-separator)
6276         (vm-reorder-message-headers
6277          nil nil "\\(Content-Type:\\|MIME-Version:\\|Content-Transfer-Encoding\\)")
6278         (vm-add-mail-mode-header-separator)
6279         (insert "MIME-Version: 1.0\n")
6280         (if (not just-one)
6281             (insert (if vm-mime-avoid-folding-content-type
6282                         "Content-Type: multipart/mixed; boundary=\""
6283                       "Content-Type: multipart/mixed;\n\tboundary=\"")
6284                     boundary "\"\n")
6285           (insert "Content-Type: " type)
6286           (if params
6287               (if vm-mime-avoid-folding-content-type
6288                   (insert "; " (mapconcat 'identity params "; ") "\n")
6289                 (insert ";\n\t" (mapconcat 'identity params ";\n\t") "\n"))
6290             (insert "\n")))
6291         (if (and just-one description)
6292             (insert "Content-Description: " description "\n"))
6293         (if (and just-one disposition)
6294             (progn
6295               (insert "Content-Disposition: " (car disposition))
6296               (if (cdr disposition)
6297                   (if vm-mime-avoid-folding-content-type
6298                       (insert "; " (mapconcat 'identity (cdr disposition) "; ")
6299                               "\n")
6300                     (insert ";\n\t" (mapconcat 'identity (cdr disposition)
6301                                                ";\n\t") "\n"))
6302                 (insert "\n"))))
6303         (if just-one
6304             (insert "Content-Transfer-Encoding: " encoding "\n")
6305           (if 8bit
6306               (insert "Content-Transfer-Encoding: 8bit\n")
6307             (insert "Content-Transfer-Encoding: 7bit\n")))))))
6308
6309 (defun vm-mime-fragment-composition (size)
6310   (save-restriction
6311     (widen)
6312     (message "Fragmenting message...")
6313     (let ((buffers nil)
6314           (total-markers nil)
6315           (id (vm-mime-make-multipart-boundary))
6316           (n 1)
6317           b header-start header-end master-buffer start end)
6318       (vm-remove-mail-mode-header-separator)
6319       ;; message/partial must have "7bit" content transfer
6320       ;; encoding, so force everything to be encoded for
6321       ;; 7bit transmission.
6322       (let ((vm-mime-8bit-text-transfer-encoding
6323              (if (eq vm-mime-8bit-text-transfer-encoding '8bit)
6324                  'quoted-printable
6325                vm-mime-8bit-text-transfer-encoding)))
6326         (vm-mime-transfer-encode-layout
6327          (vm-mime-parse-entity nil (list "text/plain" "charset=us-ascii")
6328                                "7bit")))
6329       (goto-char (point-min))
6330       (setq header-start (point))
6331       (search-forward "\n\n")
6332       (setq header-end (1- (point)))
6333       (setq master-buffer (current-buffer))
6334       (goto-char (point-min))
6335       (setq start (point))
6336       (while (not (eobp))
6337         (condition-case nil
6338             (progn
6339               (forward-char (max (- size 150) 2000))
6340               (beginning-of-line))
6341           (end-of-buffer nil))
6342         (setq end (point))
6343         (setq b (generate-new-buffer (concat (buffer-name) " part "
6344                                              (int-to-string n))))
6345         (setq buffers (cons b buffers))
6346         (set-buffer b)
6347         (make-local-variable 'vm-send-using-mime)
6348         (setq vm-send-using-mime nil)
6349         (insert-buffer-substring master-buffer header-start header-end)
6350         (goto-char (point-min))
6351         (vm-reorder-message-headers nil nil
6352          "\\(Content-Type:\\|MIME-Version:\\|Content-Transfer-Encoding\\)")
6353         (insert "MIME-Version: 1.0\n")
6354         (insert (format
6355                  (if vm-mime-avoid-folding-content-type
6356                      "Content-Type: message/partial; id=%s; number=%d"
6357                    "Content-Type: message/partial;\n\tid=%s;\n\tnumber=%d")
6358                  id n))
6359         (if vm-mime-avoid-folding-content-type
6360             (insert (format "; total=" n))
6361           (insert (format ";\n\ttotal=" n)))
6362         (setq total-markers (cons (point) total-markers))
6363         (insert "\nContent-Transfer-Encoding: 7bit\n")
6364         (goto-char (point-max))
6365         (insert mail-header-separator "\n")
6366         (insert-buffer-substring master-buffer start end)
6367         (vm-increment n)
6368         (set-buffer master-buffer)
6369         (setq start (point)))
6370       (vm-decrement n)
6371       (vm-add-mail-mode-header-separator)
6372       (let ((bufs buffers))
6373         (while bufs
6374           (set-buffer (car bufs))
6375           (goto-char (car total-markers))
6376           (prin1 n (current-buffer))
6377           (setq bufs (cdr bufs)
6378                 total-markers (cdr total-markers)))
6379         (set-buffer master-buffer))
6380       (message "Fragmenting message... done")
6381       (nreverse buffers))))
6382
6383 ;; moved to vm-reply.el, not MIME-specific.
6384 (fset 'vm-mime-preview-composition 'vm-preview-composition)
6385
6386 (defun vm-mime-composite-type-p (type)
6387   (or (vm-mime-types-match "message/rfc822" type)
6388       (vm-mime-types-match "message/news" type)
6389       (vm-mime-types-match "multipart" type)))
6390
6391 ;; Unused currrently.
6392 ;;
6393 ;;(defun vm-mime-map-atomic-layouts (function list)
6394 ;;  (while list
6395 ;;    (if (vm-mime-composite-type-p (car (vm-mm-layout-type (car list))))
6396 ;;      (vm-mime-map-atomic-layouts function (vm-mm-layout-parts (car list)))
6397 ;;      (funcall function (car list)))
6398 ;;    (setq list (cdr list))))
6399
6400 (defun vm-mime-sprintf (format layout)
6401   ;; compile the format into an eval'able s-expression
6402   ;; if it hasn't been compiled already.
6403   (let ((match (assoc format vm-mime-compiled-format-alist)))
6404     (if (null match)
6405         (progn
6406           (vm-mime-compile-format format)
6407           (setq match (assoc format vm-mime-compiled-format-alist))))
6408     ;; The local variable name `vm-mime-layout' is mandatory here for
6409     ;; the format s-expression to work.
6410     (let ((vm-mime-layout layout))
6411       (eval (cdr match)))))
6412
6413 (defun vm-mime-compile-format (format)
6414   (let ((return-value (vm-mime-compile-format-1 format 0)))
6415     (setq vm-mime-compiled-format-alist
6416           (cons (cons format (nth 1 return-value))
6417                 vm-mime-compiled-format-alist))))
6418
6419 (defun vm-mime-compile-format-1 (format start-index)
6420   (or start-index (setq start-index 0))
6421   (let ((case-fold-search nil)
6422         (done nil)
6423         (sexp nil)
6424         (sexp-fmt nil)
6425         (last-match-end start-index)
6426         new-match-end conv-spec)
6427     (store-match-data nil)
6428     (while (not done)
6429       (while
6430           (and (not done)
6431                (string-match
6432                 "%\\(-\\)?\\([0-9]+\\)?\\(\\.\\(-?[0-9]+\\)\\)?\\([()acdefknNstTx%]\\)"
6433                 format last-match-end))
6434         (setq conv-spec (aref format (match-beginning 5)))
6435         (setq new-match-end (match-end 0))
6436         (if (memq conv-spec '(?\( ?a ?c ?d ?e ?f ?k ?n ?N ?s ?t ?T ?x))
6437             (progn
6438               (cond ((= conv-spec ?\()
6439                      (save-match-data
6440                        (let ((retval (vm-mime-compile-format-1 format
6441                                                                (match-end 5))))
6442                          (setq sexp (cons (nth 1 retval) sexp)
6443                                new-match-end (car retval)))))
6444                     ((= conv-spec ?a)
6445                      (setq sexp (cons (list 'vm-mf-default-action
6446                                             'vm-mime-layout) sexp)))
6447                     ((= conv-spec ?c)
6448                      (setq sexp (cons (list 'vm-mf-text-charset
6449                                             'vm-mime-layout) sexp)))
6450                     ((= conv-spec ?d)
6451                      (setq sexp (cons (list 'vm-mf-content-description
6452                                             'vm-mime-layout) sexp)))
6453                     ((= conv-spec ?e)
6454                      (setq sexp (cons (list 'vm-mf-content-transfer-encoding
6455                                             'vm-mime-layout) sexp)))
6456                     ((= conv-spec ?f)
6457                      (setq sexp (cons (list 'vm-mf-attachment-file
6458                                             'vm-mime-layout) sexp)))
6459                     ((= conv-spec ?k)
6460                      (setq sexp (cons (list 'vm-mf-event-for-default-action
6461                                             'vm-mime-layout) sexp)))
6462                     ((= conv-spec ?n)
6463                      (setq sexp (cons (list 'vm-mf-parts-count
6464                                             'vm-mime-layout) sexp)))
6465                     ((= conv-spec ?N)
6466                      (setq sexp (cons (list 'vm-mf-partial-number
6467                                             'vm-mime-layout) sexp)))
6468                     ((= conv-spec ?s)
6469                      (setq sexp (cons (list 'vm-mf-parts-count-pluralizer
6470                                             'vm-mime-layout) sexp)))
6471                     ((= conv-spec ?t)
6472                      (setq sexp (cons (list 'vm-mf-content-type
6473                                             'vm-mime-layout) sexp)))
6474                     ((= conv-spec ?T)
6475                      (setq sexp (cons (list 'vm-mf-partial-total
6476                                             'vm-mime-layout) sexp)))
6477                     ((= conv-spec ?x)
6478                      (setq sexp (cons (list 'vm-mf-external-body-content-type
6479                                             'vm-mime-layout) sexp))))
6480               (cond ((and (match-beginning 1) (match-beginning 2))
6481                      (setcar sexp
6482                              (list
6483                               (if (eq (aref format (match-beginning 2)) ?0)
6484                                   'vm-numeric-left-justify-string
6485                                 'vm-left-justify-string)
6486                               (car sexp)
6487                               (string-to-number
6488                                (substring format
6489                                           (match-beginning 2)
6490                                           (match-end 2))))))
6491                     ((match-beginning 2)
6492                      (setcar sexp
6493                              (list
6494                               (if (eq (aref format (match-beginning 2)) ?0)
6495                                   'vm-numeric-right-justify-string
6496                                 'vm-right-justify-string)
6497                               (car sexp)
6498                               (string-to-number
6499                                (substring format
6500                                           (match-beginning 2)
6501                                           (match-end 2)))))))
6502               (cond ((match-beginning 3)
6503                      (setcar sexp
6504                              (list 'vm-truncate-string (car sexp)
6505                                    (string-to-number
6506                                     (substring format
6507                                                (match-beginning 4)
6508                                                (match-end 4)))))))
6509               (setq sexp-fmt
6510                     (cons "%s"
6511                           (cons (substring format
6512                                            last-match-end
6513                                            (match-beginning 0))
6514                                 sexp-fmt))))
6515           (setq sexp-fmt
6516                 (cons (if (eq conv-spec ?\))
6517                           (prog1 "" (setq done t))
6518                         "%%")
6519                       (cons (substring format
6520                                        (or last-match-end 0)
6521                                        (match-beginning 0))
6522                             sexp-fmt))))
6523         (setq last-match-end new-match-end))
6524       (if (not done)
6525           (setq sexp-fmt
6526                 (cons (substring format last-match-end (length format))
6527                       sexp-fmt)
6528                 done t))
6529       (setq sexp-fmt (apply 'concat (nreverse sexp-fmt)))
6530       (if sexp
6531           (setq sexp (cons 'format (cons sexp-fmt (nreverse sexp))))
6532         (setq sexp sexp-fmt)))
6533     (list last-match-end sexp)))
6534
6535 (defun vm-mime-find-format-for-layout (layout)
6536   (let ((p vm-mime-button-format-alist)
6537         (type (car (vm-mm-layout-type layout))))
6538     (catch 'done
6539       (cond ((vm-mime-types-match "error/error" type)
6540              (throw 'done "%d"))
6541             ((vm-mime-types-match "text/x-vm-deleted" type)
6542              (throw 'done "%d")))
6543       (while p
6544         (if (vm-mime-types-match (car (car p)) type)
6545             (throw 'done (cdr (car p)))
6546           (setq p (cdr p))))
6547       "%-25.25t [%k to %a]" )))
6548
6549 (defun vm-mf-content-type (layout)
6550   (car (vm-mm-layout-type layout)))
6551
6552 (defun vm-mf-external-body-content-type (layout)
6553   (car (vm-mm-layout-type (car (vm-mm-layout-parts layout)))))
6554
6555 (defun vm-mf-content-transfer-encoding (layout)
6556   (vm-mm-layout-encoding layout))
6557
6558 (defun vm-mf-content-description (layout)
6559   (or (vm-mm-layout-description layout)
6560       (let ((p vm-mime-type-description-alist)
6561             (type (car (vm-mm-layout-type layout))))
6562         (catch 'done
6563           (while p
6564             (if (vm-mime-types-match (car (car p)) type)
6565                 (throw 'done (cdr (car p)))
6566               (setq p (cdr p))))
6567           nil ))
6568       (vm-mf-content-type layout)))
6569
6570 (defun vm-mf-text-charset (layout)
6571   (or (vm-mime-get-parameter layout "charset")
6572       "us-ascii"))
6573
6574 (defun vm-mf-parts-count (layout)
6575   (int-to-string (length (vm-mm-layout-parts layout))))
6576
6577 (defun vm-mf-parts-count-pluralizer (layout)
6578   (if (= 1 (length (vm-mm-layout-parts layout))) "" "s"))
6579
6580 (defun vm-mf-partial-number (layout)
6581   (or (vm-mime-get-parameter layout "number")
6582       "?"))
6583
6584 (defun vm-mf-partial-total (layout)
6585   (or (vm-mime-get-parameter layout "total")
6586       "?"))
6587
6588 (defun vm-mf-attachment-file (layout)
6589   (or vm-mf-attachment-file ;; for %f expansion in external viewer arg lists
6590       (vm-mime-get-disposition-parameter layout "filename")
6591       (vm-mime-get-parameter layout "name")
6592       "<no suggested filename>"))
6593
6594 (defun vm-mf-event-for-default-action (layout)
6595   (if (vm-mouse-support-possible-here-p)
6596       "Click mouse-2"
6597     "Press RETURN"))
6598
6599 (defun vm-mf-default-action (layout)
6600   (if (eq vm-mime-show-alternatives 'mixed)
6601       (concat (vm-mf-default-action-orig layout) " alternative")
6602     (vm-mf-default-action-orig layout)))
6603
6604 (defun vm-mf-default-action-orig (layout)
6605   (or vm-mf-default-action
6606       (let (cons)
6607         (cond ((or (vm-mime-can-display-internal layout)
6608                    (vm-mime-find-external-viewer
6609                     (car (vm-mm-layout-type layout))))
6610                (let ((p vm-mime-default-action-string-alist)
6611                      (type (car (vm-mm-layout-type layout))))
6612                  (catch 'done
6613                    (while p
6614                      (if (vm-mime-types-match (car (car p)) type)
6615                          (throw 'done (cdr (car p)))
6616                        (setq p (cdr p))))
6617                    nil )))
6618               ((setq cons (vm-mime-can-convert
6619                            (car (vm-mm-layout-type layout))))
6620                (format "convert to %s and display" (nth 1 cons)))
6621               (t "save to a file")))
6622       ;; should not be reached
6623       "burn in the raging fires of hell forever"))
6624
6625 (provide 'vm-mime)
6626
6627 ;;; vm-mime.el ends here