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

   1 ;;; vm-reply.el --- Mailing, forwarding, and replying commands
   2 ;;
   3 ;; Copyright (C) 1989-2001 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
  21 ;;; Code:
  22
  23 (defun vm-add-reply-subject-prefix (message &optional start)
  24   (when (not start)
  25     (goto-char (point-min))
  26     (re-search-forward (regexp-quote mail-header-separator) (point-max))
  27     (forward-char 1)
  28     (setq start (point)))
  29   (goto-char start)
  30   (if (and message vm-included-text-attribution-format)
  31       (let ((vm-summary-uninteresting-senders nil))
  32         (insert (vm-summary-sprintf
  33                  vm-included-text-attribution-format
  34                  message))))
  35   (while (re-search-forward "^" (point-max) t)
  36     (insert vm-included-text-prefix)))
  37
  38 ;;;###autoload
  39 (defun vm-do-reply (to-all include-text count)
  40     (let ((mlist (vm-select-marked-or-prefixed-messages count))
  41           (dir default-directory)
  42           (message-pointer vm-message-pointer)
  43           (case-fold-search t)
  44           to cc subject in-reply-to references
  45           mp tmp tmp2 newsgroups)
  46       (setq mp mlist)
  47       (while mp
  48         (cond ((add-to-list 'to
  49                        (let ((reply-to
  50                               (vm-get-header-contents (car mp) "Reply-To:"
  51                                                       ", ")))
  52                          (if (vm-ignored-reply-to reply-to)
  53                              nil
  54                            reply-to ))))
  55               ((add-to-list 'to (vm-get-header-contents (car mp) "From:"
  56                                                         ", ")))
  57                 ;; bad, but better than nothing for some
  58               ((add-to-list 'to (vm-grok-From_-author (car mp))))
  59                 (t (error "No From: or Reply-To: header in message")))
  60
  61         (let ((this-subject (vm-get-header-contents (car mp) "Subject:"))
  62               (this-reply-to (and vm-in-reply-to-format
  63                      (let ((vm-summary-uninteresting-senders nil))
  64                                     (vm-summary-sprintf vm-in-reply-to-format
  65                                                         (car mp))))))
  66           (if (and this-subject vm-reply-subject-prefix
  67                    (not (string-match vm-reply-subject-prefix this-subject)))
  68               (setq this-subject (concat vm-reply-subject-prefix
  69                                          this-subject)))
  70
  71           (unless subject
  72             (setq subject (concat this-subject
  73                                   (if (cdr mlist)
  74                                       (format " [and %d more messages]"
  75                                               (length (cdr mlist)))))))
  76           (setq in-reply-to (if in-reply-to
  77                                 (concat in-reply-to ",\n\t" this-reply-to)
  78                               this-reply-to)))
  79
  80         (cond ((setq tmp (vm-get-header-contents (car mp) "Reply-To:" ", "))
  81                (if (not (vm-ignored-reply-to tmp))
  82                    (add-to-list 'to tmp)))
  83               ((setq tmp (vm-get-header-contents (car mp) "From:" ", "))
  84                (add-to-list 'to tmp))
  85                   ;; bad, but better than nothing for some
  86                   ((setq tmp (vm-grok-From_-author (car mp)))
  87                (add-to-list 'to tmp))
  88               (t (error "No From: or Reply-To: header in message")))
  89
  90         (if to-all
  91             (progn
  92               (setq tmp (vm-get-header-contents (car mp) "To:" ", "))
  93               (setq tmp2 (vm-get-header-contents (car mp) "Cc:" ", "))
  94               (if tmp
  95                   (if cc
  96                       (setq cc (concat cc "," tmp))
  97                     (setq cc tmp)))
  98               (if tmp2
  99                   (if cc
 100                       (setq cc (concat cc "," tmp2))
 101                     (setq cc tmp2)))))
 102         (setq references
 103               (cons (or (vm-get-header-contents (car mp) "References:" " ")
 104                         (vm-get-header-contents (car mp) "In-reply-to:" " "))
 105                     (cons (vm-get-header-contents (car mp) "Message-ID:" " ")
 106                           references)))
 107         (setq newsgroups
 108               (cons (or (and to-all
 109                              (vm-get-header-contents (car mp)
 110                                                      "Followup-To:" ","))
 111                         (vm-get-header-contents (car mp) "Newsgroups:" ","))
 112                     newsgroups))
 113         (setq mp (cdr mp)))
 114
 115       (if (null to) nil
 116         (setq tmp (car to))
 117         (setq to (cdr to))
 118         (while to
 119           (setq tmp (concat tmp ", " (car to)))
 120           (setq to (cdr to)))
 121         (setq to tmp))
 122
 123       (if vm-strip-reply-headers
 124           (let ((mail-use-rfc822 t))
 125             (and to (setq to (mail-strip-quoted-names to)))
 126             (and cc (setq cc (mail-strip-quoted-names cc)))))
 127       (setq to (vm-parse-addresses to)
 128             cc (vm-parse-addresses cc))
 129       (if vm-reply-ignored-addresses
 130           (setq to (vm-strip-ignored-addresses to)
 131                 cc (vm-strip-ignored-addresses cc)))
 132       (setq to (vm-delete-duplicates to nil t))
 133       (setq cc (vm-delete-duplicates
 134                 (append (vm-delete-duplicates cc nil t)
 135                         to (copy-sequence to))
 136                 t t))
 137       (and to (setq to (mapconcat 'identity to ",\n    ")))
 138       (and cc (setq cc (mapconcat 'identity cc ",\n    ")))
 139       (and (null to) (setq to cc cc nil))
 140       (setq references (delq nil references)
 141             references (mapconcat 'identity references " ")
 142             references (vm-parse references "[^<]*\\(<[^>]+>\\)")
 143             references (vm-delete-duplicates references)
 144             references (if references (mapconcat 'identity references "\n\t")))
 145       (setq newsgroups (delq nil newsgroups)
 146             newsgroups (mapconcat 'identity newsgroups ",")
 147             newsgroups (vm-parse newsgroups "[ \t\f\r\n,]*\\([^ \t\f\r\n,]+\\)")
 148             newsgroups (vm-delete-duplicates newsgroups)
 149             newsgroups (if newsgroups (mapconcat 'identity newsgroups ",")))
 150       (vm-mail-internal
 151        (format "reply to %s%s" (vm-su-full-name (car mlist))
 152                (if (cdr mlist) ", ..." ""))
 153        to subject in-reply-to cc references newsgroups)
 154       (make-local-variable 'vm-reply-list)
 155       (setq vm-system-state 'replying
 156             vm-reply-list mlist
 157             default-directory dir)
 158       (if include-text
 159           (save-excursion
 160             (goto-char (point-min))
 161             (let ((case-fold-search nil))
 162               (re-search-forward
 163                (concat "^" (regexp-quote mail-header-separator) "$") nil 0))
 164             (forward-char 1)
 165             (while mlist
 166               (save-restriction
 167                 (narrow-to-region (point) (point))
 168                 (vm-yank-message (car mlist))
 169                 (goto-char (point-max)))
 170               (setq mlist (cdr mlist)))))
 171       (run-hooks 'vm-reply-hook)
 172       (run-hooks 'vm-mail-mode-hook)))
 173
 174 (defun vm-strip-ignored-addresses (addresses)
 175   (setq addresses (copy-sequence addresses))
 176   (let (re-list list addr-list)
 177     (setq re-list vm-reply-ignored-addresses)
 178     (while re-list
 179       (setq addr-list addresses)
 180       (while addr-list
 181         (if (string-match (car re-list) (car addr-list))
 182             (setq addresses (delq (car addr-list) addresses)))
 183         (setq addr-list (cdr addr-list)))
 184       (setq re-list (cdr re-list))))
 185   addresses )
 186
 187 (defun vm-ignored-reply-to (reply-to)
 188   (if (and reply-to (not (string= reply-to "")))
 189       (let (re-list result)
 190         (setq re-list vm-reply-ignored-reply-tos)
 191         (while re-list
 192           (if (string-match (car re-list) reply-to)
 193               (setq result t re-list nil)
 194             (setq re-list (cdr re-list))))
 195         result)))
 196
 197 ;;;###autoload
 198 (defun vm-mail-yank-default (&optional message)
 199   (save-excursion
 200     (vm-reorder-message-headers nil vm-included-text-headers
 201                                 vm-included-text-discard-header-regexp)
 202     ;; if all the headers are gone, delete the trailing blank line, too.
 203     (if (eq (following-char) ?\n)
 204         (delete-char 1))
 205     (if (and message vm-included-text-attribution-format)
 206         (let ((vm-summary-uninteresting-senders nil))
 207           (insert (vm-summary-sprintf vm-included-text-attribution-format
 208                                       message))))
 209     ; turn off zmacs-regions for Lucid Emacs 19
 210     ; and get around transient-mark-mode in FSF Emacs 19
 211     ; all this so that (mark) does what it did in v18, sheesh.
 212     (let* ((zmacs-regions nil)
 213            (mark-even-if-inactive t)
 214            (end (mark-marker)))
 215       (while (< (point) end)
 216         (insert vm-included-text-prefix)
 217         (forward-line 1)))))
 218
 219 ;;;###autoload
 220 (defun vm-yank-message-other-folder (folder)
 221   "Like vm-yank-message except the message is yanked from a folder other
 222 than the one that spawned the current Mail mode buffer.  The name of the
 223 folder is read from the minibuffer.
 224
 225 Don't call this function from a program."
 226   (interactive
 227    (list
 228     (let ((dir (if vm-folder-directory
 229                     (expand-file-name vm-folder-directory)
 230                   default-directory))
 231           (last-command last-command)
 232           (this-command this-command))
 233       (read-file-name "Yank from folder: " dir nil t))))
 234   (let ((b (current-buffer)) newbuf sumbuf default result prompt mp)
 235     (set-buffer (or (vm-get-file-buffer folder) (find-file-noselect folder)))
 236     (setq newbuf (current-buffer))
 237     (if (not (eq major-mode 'vm-mode))
 238         (vm-mode))
 239     (if vm-presentation-buffer-handle
 240         (vm-bury-buffer vm-presentation-buffer-handle))
 241     (if (null vm-message-pointer)
 242         (error "No messages in folder %s" folder))
 243     (setq default (vm-number-of (car vm-message-pointer)))
 244     (save-excursion
 245       (save-window-excursion
 246         (save-window-excursion
 247           (vm-summarize))
 248         (vm-display vm-summary-buffer t '(vm-yank-message-other-folder)
 249                     '(vm-yank-message-other-folder composing-message))
 250         (setq sumbuf (current-buffer))
 251         (setq prompt (format "Yank message number: (default %s) " default)
 252               result 0)
 253         (while (zerop result)
 254           (setq result (read-string prompt))
 255           (and (string= result "") default (setq result default))
 256           (setq result (string-to-number result)))
 257         (if (null (setq mp (nthcdr (1- result) vm-message-list)))
 258             (error "No such message."))))
 259     (set-buffer b)
 260     (unwind-protect
 261         (let ((vm-mail-buffer newbuf))
 262           (vm-yank-message (car mp)))
 263       (vm-bury-buffer newbuf)
 264       (vm-bury-buffer sumbuf))))
 265
 266 ;;;###autoload
 267 (defun vm-yank-message (message)
 268   "Yank message number N into the current buffer at point.
 269 When called interactively N is always read from the minibuffer.  When
 270 called non-interactively the first argument is expected to be a
 271 message struct.
 272
 273 This command is meant to be used in VM created Mail mode buffers; the
 274 yanked message comes from the mail buffer containing the message you
 275 are replying to, forwarding, or invoked VM's mail command from.
 276
 277 All message headers are yanked along with the text.  Point is
 278 left before the inserted text, the mark after.  Any hook
 279 functions bound to `mail-citation-hook' are run, after inserting
 280 the text and setting point and mark.  For backward compatibility,
 281 if mail-citation-hook is set to nil, `mail-yank-hooks' is run
 282 instead.
 283
 284 If mail-citation-hook and mail-yank-hooks are both nil, this
 285 default action is taken: the yanked headers are trimmed as
 286 specified by `vm-included-text-headers' and
 287 `vm-included-text-discard-header-regexp', and the value of
 288 `vm-included-text-prefix' is prepended to every yanked line."
 289   (interactive
 290    (list
 291     ;; What we really want for the first argument is a message struct,
 292     ;; but if called interactively, we let the user type in a message
 293     ;; number instead.
 294     (let (mp default
 295              (result 0)
 296              prompt
 297              (last-command last-command)
 298              (this-command this-command))
 299       (save-excursion
 300         (vm-select-folder-buffer)
 301         (setq default (and vm-message-pointer
 302                            (vm-number-of (car vm-message-pointer)))
 303               prompt (if default
 304                          (format "Yank message number: (default %s) "
 305                                  default)
 306                        "Yank message number: "))
 307         (while (zerop result)
 308           (setq result (read-string prompt))
 309           (and (string= result "") default (setq result default))
 310           (setq result (string-to-number result)))
 311         (if (null (setq mp (nthcdr (1- result) vm-message-list)))
 312             (error "No such message.")))
 313       (car mp))))
 314   (if (not (bufferp vm-mail-buffer))
 315       (error "This is not a VM Mail mode buffer."))
 316   (if (null (buffer-name vm-mail-buffer))
 317       (error "The folder buffer containing message %d has been killed."
 318              (vm-number-of message)))
 319   (vm-display nil nil '(vm-yank-message) '(vm-yank-message composing-message))
 320   (setq message (vm-real-message-of message))
 321   (let ((b (current-buffer)) (start (point)) end insert-start)
 322     (save-restriction
 323       (widen)
 324       (save-excursion
 325         (if vm-reply-include-presentation
 326             (let ((text
 327                    (save-excursion
 328                      (vm-select-folder-buffer)
 329                      ;; ensure the current message is presented
 330                      (vm-show-current-message)
 331                      (vm-select-folder-buffer)
 332                      (if vm-presentation-buffer
 333                          (set-buffer vm-presentation-buffer))
 334                      (vm-buffer-substring-no-properties (point-min) (point-max)))))
 335               (insert text)
 336               (setq end (point-marker)))
 337           (if (vectorp (vm-mm-layout message))
 338               (let* ((o (vm-mm-layout message))
 339                      layout new-layout
 340                      (type (car (vm-mm-layout-type o)))
 341                      (alternatives 0)
 342                      (parts (list o)))
 343                 (vm-insert-region-from-buffer (vm-buffer-of message)
 344                                               (vm-headers-of message)
 345                                               (vm-text-of message))
 346                 (while parts
 347                   (setq layout (car parts))
 348                   (cond ((vm-mime-text-type-layout-p layout)
 349                          (if (cond ((vm-mime-types-match
 350                                      "text/enriched"
 351                                      (car (vm-mm-layout-type layout)))
 352                                     (vm-mime-display-internal-text/enriched
 353                                      layout))
 354                                    ((vm-mime-types-match
 355                                      "message/rfc822"
 356                                      (car (vm-mm-layout-type layout)))
 357                                     (vm-mime-display-internal-message/rfc822
 358                                      layout))
 359 ;; no text/html for now
 360 ;;                               ((vm-mime-types-match
 361 ;;                                 "text/html"
 362 ;;                                 (car (vm-mm-layout-type layout)))
 363 ;;                                (vm-mime-display-internal-text/html
 364 ;;                                 layout))
 365                                    ((member (downcase (car (vm-mm-layout-type
 366                                                             layout)))
 367                                             vm-included-mime-types-list)
 368                                     (vm-mime-display-internal-text/plain
 369                                      layout t))
 370                                    ;; convert the layout if possible
 371                                    ((and (not (vm-mm-layout-is-converted layout))
 372                                          (vm-mime-can-convert (car (vm-mm-layout-type
 373                                                                     layout)))
 374                                          (setq new-layout
 375                                                (vm-mime-convert-undisplayable-layout
 376                                                 layout)))
 377                                     (vm-decode-mime-layout new-layout)))
 378                              ;; we have found a part to insert, thus skip the
 379                              ;; remaining alternatives
 380                              (while (> alternatives 1)
 381                                (setq parts (cdr parts)
 382                                      alternatives (1- alternatives)))
 383
 384                            (if (not (member (downcase (car (vm-mm-layout-type
 385                                                             layout)))
 386                                             vm-included-mime-types-list))
 387                                nil
 388                              ;; charset problems probably
 389                              ;; just dump the raw bits
 390                              (setq insert-start (point))
 391                              (vm-mime-insert-mime-body layout)
 392                              (vm-mime-transfer-decode-region layout
 393                                                              insert-start
 394                                                              (point))))
 395                          (setq alternatives (1- alternatives))
 396                          (setq parts (cdr parts)))
 397                         ;; burst composite types
 398                         ((vm-mime-composite-type-p
 399                           (car (vm-mm-layout-type layout)))
 400                          (setq alternatives (length (vm-mm-layout-parts (car parts))))
 401                          (setq parts (nconc (copy-sequence
 402                                              (vm-mm-layout-parts
 403                                               (car parts)))
 404                                             (cdr parts))))
 405                         ;; skip non-text parts
 406                         (t
 407                          (setq alternatives (1- alternatives))
 408                          (setq parts (cdr parts)))))
 409                 (setq end (point-marker)))
 410             (set-buffer (vm-buffer-of message))
 411             (save-restriction
 412               (widen)
 413               ;; decode MIME encoded words so supercite and other
 414               ;; mail-citation-hook denizens won't have to eat 'em.
 415               (append-to-buffer b (vm-headers-of message)
 416                                 (vm-text-end-of message))
 417               (set-buffer b)
 418               (setq end (point-marker))
 419               (if vm-display-using-mime
 420                   (progn
 421                     (narrow-to-region start end)
 422                     (vm-decode-mime-encoded-words)))))))
 423       ;; get rid of read-only text properties on the text, as
 424       ;; they will only cause trouble.
 425       (let ((inhibit-read-only t))
 426         (remove-text-properties (point-min) (point-max)
 427                                 '(read-only nil invisible nil)
 428                                 (current-buffer)))
 429
 430       ;; decode MIME encoded words so supercite and other
 431       ;; mail-citation-hook denizens won't have to eat 'em.
 432       (if vm-display-using-mime
 433           (save-restriction
 434             (narrow-to-region start end)
 435             (vm-decode-mime-encoded-words))))
 436
 437     (push-mark end)
 438     (cond (mail-citation-hook (run-hooks 'mail-citation-hook))
 439           (mail-yank-hooks (run-hooks 'mail-yank-hooks))
 440           (t (vm-mail-yank-default message)))))
 441
 442 ;;;###autoload
 443 (defun vm-mail-send-and-exit (&rest ignored)
 444   "Send message and maybe delete the composition buffer.
 445 The value of `vm-keep-sent-mesages' determines whether the composition buffer
 446 is deleted.  If the composition is a reply to a message in a currently visited
 447 folder, that message is marked as having been replied to."
 448   (interactive "P")
 449   (vm-check-for-killed-folder)
 450   (if (and (boundp 'mail-alias-file)
 451            mail-alias-file
 452            (not (eq (user-uid) 0)))
 453       (error "Must be superuser to use mail-alias-file.  Please set mail-alias-file to nil."))
 454   (let ((b (current-buffer)))
 455     (vm-mail-send)
 456     (cond ((null (buffer-name b)) ;; dead buffer
 457            ;; This improves window configuration behavior in
 458            ;; XEmacs.  It avoids taking the folder buffer from
 459            ;; one frame and attaching it to the selected frame.
 460            (set-buffer (window-buffer (selected-window)))
 461            (vm-display nil nil '(vm-mail-send-and-exit)
 462                        '(vm-mail-send-and-exit
 463                          reading-message
 464                          startup)))
 465           (t
 466            (vm-display b nil '(vm-mail-send-and-exit)
 467                        '(vm-mail-send-and-exit reading-message startup))
 468            (vm-bury-buffer b)))))
 469
 470 (defun vm-keep-mail-buffer (buffer)
 471   (vm-keep-some-buffers buffer 'vm-kept-mail-buffers vm-keep-sent-messages))
 472
 473 (defun vm-help-tale ()
 474   (save-excursion
 475     (goto-char (point-min))
 476     (while (vm-match-header)
 477       (if (not (vm-match-header "To:\\|Resent-To:\\|Cc:\\|Resent-Cc:"))
 478           (goto-char (vm-matched-header-end))
 479         (goto-char (vm-matched-header-contents-start))
 480         (if (re-search-forward "[^, \t][ \t]*\n[ \t\n]+[^ \t\n]"
 481                                (vm-matched-header-contents-end)
 482                                t)
 483             (error "tale is an idiot, and so are you. :-)"))
 484         (goto-char (vm-matched-header-end))))))
 485
 486 (defun vm-mail-mode-insert-message-id-maybe ()
 487   (if (not vm-mail-header-insert-message-id)
 488       nil
 489     (save-restriction
 490       (save-excursion
 491         (let ((resent nil))
 492           (if (or (vm-mail-mode-get-header-contents "Resent-To:")
 493                   (vm-mail-mode-get-header-contents "Resent-Cc:")
 494                   (vm-mail-mode-get-header-contents "Resent-Bcc:"))
 495               (progn
 496                 (vm-mail-mode-remove-header "Resent-Message-ID:")
 497                 (setq resent t))
 498             (vm-mail-mode-remove-header "Message-ID:"))
 499           (widen)
 500           (goto-char (point-min))
 501           (insert (format "%sMessage-ID: %s\n"
 502                           (if resent "Resent-" "")
 503                           (vm-make-message-id))))))))
 504
 505 (defun vm-mail-mode-insert-date-maybe ()
 506   (if (not vm-mail-header-insert-date)
 507       nil
 508     (save-restriction
 509       (save-excursion
 510         (let* ((timezone (car (current-time-zone)))
 511                (hour (/ timezone 3600))
 512                (min (/ (- timezone (* hour 3600)) 60))
 513                (time (current-time))
 514                (resent nil))
 515           (if (or (vm-mail-mode-get-header-contents "Resent-To:")
 516                   (vm-mail-mode-get-header-contents "Resent-Cc:")
 517                   (vm-mail-mode-get-header-contents "Resent-Bcc:"))
 518               (progn
 519                 (vm-mail-mode-remove-header "Resent-Date:")
 520                 (setq resent t))
 521             (vm-mail-mode-remove-header "Date:"))
 522           (widen)
 523           (goto-char (point-min))
 524           (insert (format "%sDate: " (if resent "Resent-" ""))
 525                   (capitalize
 526                    (car (nth (string-to-number (format-time-string "%w" time))
 527                              vm-weekday-alist)))
 528                   ", "
 529                   ;; %e generated " 2".  Go from string to int
 530                   ;; to string to get rid of the blank.
 531                   (int-to-string
 532                    (string-to-number
 533                     (format-time-string "%e" time)))
 534                   " "
 535                   (capitalize
 536                    (car (nth
 537                          (1- (string-to-number (format-time-string "%m" time)))
 538                          vm-month-alist)))
 539                   (format-time-string " %Y %H:%M:%S" time)
 540                   (format " %s%02d%02d"
 541                           (if (< timezone 0) "-" "+")
 542                           (abs hour)
 543                           (abs min))
 544 ;; localization in Europe and elsewhere can cause %Z to return
 545 ;; 8-bit chars, which are forbidden in headers.
 546 ;;                (format-time-string " (%Z)" time)
 547                   "\n"))))))
 548
 549 (defun vm-mail-mode-remove-message-id-maybe ()
 550   (if vm-mail-header-insert-message-id
 551       (let ((resent nil))
 552         (if (or (vm-mail-mode-get-header-contents "Resent-To:")
 553                 (vm-mail-mode-get-header-contents "Resent-Cc:")
 554                 (vm-mail-mode-get-header-contents "Resent-Bcc:"))
 555             (progn
 556               (vm-mail-mode-remove-header "Resent-Message-ID:")
 557               (setq resent t))
 558           (vm-mail-mode-remove-header "Message-ID:")))))
 559
 560 (defun vm-mail-mode-remove-date-maybe ()
 561   (if vm-mail-header-insert-date
 562       (let ((resent nil))
 563         (if (or (vm-mail-mode-get-header-contents "Resent-To:")
 564                 (vm-mail-mode-get-header-contents "Resent-Cc:")
 565                 (vm-mail-mode-get-header-contents "Resent-Bcc:"))
 566             (progn
 567               (vm-mail-mode-remove-header "Resent-Date:")
 568               (setq resent t))
 569           (vm-mail-mode-remove-header "Date:")))))
 570
 571 (defvar vm-dont-ask-coding-system-question nil)
 572
 573 (cond ((and vm-fsfemacs-mule-p
 574             (fboundp 'select-message-coding-system)
 575             (not (fboundp 'vm-old-select-message-coding-system)))
 576        (fset 'vm-old-select-message-coding-system
 577              (symbol-function 'select-message-coding-system))
 578        (defun select-message-coding-system (&rest ignored)
 579          (if vm-dont-ask-coding-system-question
 580              nil
 581            (apply 'vm-old-select-message-coding-system ignored)))))
 582
 583 (defvar select-safe-coding-system-function)
 584
 585 (defvar coding-system-for-write)
 586
 587 ;;;###autoload
 588 (defun vm-mail-send ()
 589   "Just like mail-send except that VM flags the appropriate message(s)
 590 as replied to, forwarded, etc, if appropriate."
 591   (interactive)
 592   (if vm-tale-is-an-idiot
 593       (vm-help-tale))
 594   ;; protect value of this-command from minibuffer read
 595   (let ((this-command this-command))
 596     (if (and vm-confirm-mail-send
 597              (not (y-or-n-p "Send the message? ")))
 598         (error "Message not sent.")))
 599   (save-excursion (run-hooks 'vm-mail-send-hook))
 600   (vm-mail-mode-insert-date-maybe)
 601   (vm-mail-mode-insert-message-id-maybe)
 602   ;; send mail using MIME if user requests it and if the buffer
 603   ;; has not already been MIME encoded.
 604   (if (and vm-send-using-mime
 605            (null (vm-mail-mode-get-header-contents "MIME-Version:")))
 606       (vm-mime-encode-composition))
 607   ;; this to prevent Emacs 19 from asking whether a message that
 608   ;; has already been sent should be sent again.  VM renames mail
 609   ;; buffers after the message has been sent, so the user should
 610   ;; already know that the message has been sent.
 611   (set-buffer-modified-p t)
 612   (let ((composition-buffer (current-buffer))
 613         ;; preserve these in case the composition buffer gets
 614         ;; killed.
 615         (vm-reply-list vm-reply-list)
 616         (vm-forward-list vm-forward-list)
 617         (vm-redistribute-list vm-redistribute-list))
 618     ;; fragment message using message/partial if it is too big.
 619     (if (and vm-send-using-mime
 620              (integerp vm-mime-max-message-size)
 621              (> (buffer-size) vm-mime-max-message-size))
 622         (let (list)
 623           (setq list (vm-mime-fragment-composition vm-mime-max-message-size))
 624           (while list
 625             (save-excursion
 626               (set-buffer (car list))
 627               (vm-mail-send)
 628               (kill-buffer (car list)))
 629             (setq list (cdr list)))
 630           ;; what mail-send would have done
 631           (set-buffer-modified-p nil))
 632       ;; don't want a buffer change to occur here
 633       ;; save-excursion to be sure.
 634       ;;
 635       ;; also protect value of this-command from minibuffer reads
 636       (let ((this-command this-command)
 637             ;; set up coding-system-for-write so that FCC uses
 638             ;; the correct coding system to save the message into
 639             ;; a folder.
 640             (coding-system-for-write
 641              (if (stringp mail-archive-file-name)
 642                  (vm-get-file-line-ending-coding-system
 643                   mail-archive-file-name)
 644                (and (boundp 'coding-system-for-write)
 645                     coding-system-for-write)))
 646             ;; For Emacs 21.
 647             (mail-send-nonascii t)
 648             (sendmail-coding-system (vm-binary-coding-system))
 649             (vm-dont-ask-coding-system-question t)
 650             (select-safe-coding-system-function nil))
 651         (save-excursion
 652           (mail-send))))
 653     ;; be careful, something could have killed the composition
 654     ;; buffer inside mail-send.
 655     (if (eq (current-buffer) composition-buffer)
 656         (progn
 657           (cond ((eq vm-system-state 'replying)
 658                  (vm-mail-mark-replied))
 659                 ((eq vm-system-state 'forwarding)
 660                  (vm-mail-mark-forwarded))
 661                 ((eq vm-system-state 'redistributing)
 662                  (vm-mail-mark-redistributed)))
 663           (vm-rename-current-mail-buffer)
 664           (vm-keep-mail-buffer (current-buffer))))
 665     (vm-display nil nil '(vm-mail-send) '(vm-mail-send))))
 666
 667 ;;;###autoload
 668 (defun vm-mail-mode-get-header-contents (header-name-regexp)
 669   (let (regexp)
 670     (setq regexp (concat "^\\(" header-name-regexp "\\)\\|\\(^"
 671                          (regexp-quote mail-header-separator) "$\\)"))
 672     (save-excursion
 673       (save-restriction
 674         (widen)
 675         (goto-char (point-min))
 676         (let ((case-fold-search t))
 677           (if (and (re-search-forward regexp nil t)
 678                    (match-beginning 1)
 679                    (progn (goto-char (match-beginning 0))
 680                           (vm-match-header)))
 681               (vm-matched-header-contents)
 682             nil ))))))
 683
 684 ;;;###autoload
 685 (defun vm-mail-mode-remove-header (header-name-regexp)
 686   (let (regexp)
 687     (setq regexp (concat "^\\(" header-name-regexp "\\)\\|\\(^"
 688                          (regexp-quote mail-header-separator) "$\\)"))
 689     (save-excursion
 690       (save-restriction
 691         (widen)
 692         (goto-char (point-min))
 693         (let ((case-fold-search t))
 694           (if (and (re-search-forward regexp nil t)
 695                    (match-beginning 1)
 696                    (progn (goto-char (match-beginning 0))
 697                           (vm-match-header)))
 698               (delete-region (vm-matched-header-start) (vm-matched-header-end))
 699             nil ))))))
 700
 701 (defun vm-rename-current-mail-buffer ()
 702   (if vm-rename-current-buffer-function
 703       (funcall vm-rename-current-buffer-function)
 704     (let ((case-fold-search nil))
 705       (if (not (string-match "^sent " (buffer-name)))
 706           (let (prefix name n)
 707             (if (not (string-match "^mail to \\?" (buffer-name)))
 708                 (setq prefix (format "sent %s" (buffer-name)))
 709               (let (recipients)
 710                 (cond ((not (zerop (length (setq recipients
 711                                                  (mail-fetch-field "To"))))))
 712                       ((not (zerop (length (setq recipients
 713                                                  (mail-fetch-field "Cc"))))))
 714                       ((not (zerop (length (setq recipients
 715                                                  (mail-fetch-field "Bcc"))))))
 716                                         ; can't happen?!?
 717                       (t (setq recipients "the horse with no name")))
 718                 (setq prefix (format "sent mail to %s" recipients))))
 719             (if (> (length prefix) 44)
 720                 (setq prefix (concat (substring prefix 0 40) " ...")))
 721             (setq name prefix n 2)
 722             (while (get-buffer name)
 723               (setq name (format "%s<%d>" prefix n))
 724               (vm-increment n))
 725             (rename-buffer name))))))
 726
 727 (defun vm-mail-mark-replied ()
 728   (save-excursion
 729     (let ((mp vm-reply-list))
 730       (while mp
 731         (if (null (buffer-name (vm-buffer-of (car mp))))
 732             ()
 733           (set-buffer (vm-buffer-of (car mp)))
 734           (cond ((and (memq (car mp) vm-message-list)
 735                       (null (vm-replied-flag (car mp))))
 736                  (vm-set-replied-flag (car mp) t))))
 737         (setq mp (cdr mp)))
 738       (vm-update-summary-and-mode-line))))
 739
 740 (defun vm-mail-mark-forwarded ()
 741   (save-excursion
 742     (let ((mp vm-forward-list))
 743       (while mp
 744         (if (null (buffer-name (vm-buffer-of (car mp))))
 745             ()
 746           (set-buffer (vm-buffer-of (car mp)))
 747           (cond ((and (memq (car mp) vm-message-list)
 748                       (null (vm-forwarded-flag (car mp))))
 749                  (vm-set-forwarded-flag (car mp) t))))
 750         (setq mp (cdr mp)))
 751       (vm-update-summary-and-mode-line))))
 752
 753 (defun vm-mail-mark-redistributed ()
 754   (save-excursion
 755     (let ((mp vm-redistribute-list))
 756       (while mp
 757         (if (null (buffer-name (vm-buffer-of (car mp))))
 758             ()
 759           (set-buffer (vm-buffer-of (car mp)))
 760           (cond ((and (memq (car mp) vm-message-list)
 761                       (null (vm-redistributed-flag (car mp))))
 762                  (vm-set-redistributed-flag (car mp) t))))
 763         (setq mp (cdr mp)))
 764       (vm-update-summary-and-mode-line))))
 765
 766 ;;;###autoload
 767 (defun vm-reply (count)
 768   "Reply to the sender of the current message.
 769 Numeric prefix argument N means to reply to the current message plus the
 770 next N-1 messages.  A negative N means reply to the current message and
 771 the previous N-1 messages.
 772
 773 If invoked on marked messages (via vm-next-command-uses-marks),
 774 all marked messages will be replied to.
 775
 776 You will be placed into a standard Emacs Mail mode buffer to compose and
 777 send your message.  See the documentation for the function `mail' for
 778 more info.
 779
 780 Note that the normal binding of C-c C-y in the reply buffer is
 781 automatically changed to vm-yank-message during a reply.  This
 782 allows you to yank any message from the current folder into a
 783 reply.
 784
 785 Normal VM commands may be accessed in the reply buffer by prefixing them
 786 with C-c C-v."
 787   (interactive "p")
 788   (vm-follow-summary-cursor)
 789   (vm-select-folder-buffer)
 790   (vm-check-for-killed-summary)
 791   (vm-error-if-folder-empty)
 792   (vm-do-reply nil nil count))
 793
 794 ;;;###autoload
 795 (defun vm-reply-include-text (count)
 796   "Reply to the sender (only) of the current message and include text
 797 from the message.  See the documentation for function vm-reply for details."
 798   (interactive "p")
 799   (vm-follow-summary-cursor)
 800   (vm-select-folder-buffer)
 801   (vm-check-for-killed-summary)
 802   (vm-error-if-folder-empty)
 803   (vm-do-reply nil t count))
 804
 805 ;;;###autoload
 806 (defun vm-followup (count)
 807   "Reply to all recipients of the current message.
 808 See the documentation for the function vm-reply for details."
 809   (interactive "p")
 810   (vm-follow-summary-cursor)
 811   (vm-select-folder-buffer)
 812   (vm-check-for-killed-summary)
 813   (vm-error-if-folder-empty)
 814   (vm-do-reply t nil count))
 815
 816 ;;;###autoload
 817 (defun vm-followup-include-text (count)
 818   "Reply to all recipients of the current message and include text from
 819 the message.  See the documentation for the function vm-reply for details."
 820   (interactive "p")
 821   (vm-follow-summary-cursor)
 822   (vm-select-folder-buffer)
 823   (vm-check-for-killed-summary)
 824   (vm-error-if-folder-empty)
 825   (vm-do-reply t t count))
 826
 827 ;;;###autoload
 828 (defun vm-forward-message-all-headers ()
 829   "Like vm-forward-message but always forwards all the headers."
 830   (interactive)
 831   (let ((vm-forwarded-headers nil)
 832         (vm-unforwarded-header-regexp "only-drop-this-header")
 833         ;; set these because vm-forward-message calls vm-send-digest
 834         ;; if there is more than one message to be forwarded.
 835         (vm-rfc934-digest-headers nil)
 836         (vm-rfc934-digest-discard-header-regexp "only-drop-this-header")
 837         (vm-rfc1153-digest-headers nil)
 838         (vm-rfc1153-digest-discard-header-regexp "only-drop-this-header")
 839         (vm-mime-digest-headers nil)
 840         (vm-mime-digest-discard-header-regexp "only-drop-this-header"))
 841     (vm-forward-message)))
 842
 843 ;;;###autoload
 844 (defun vm-forward-message ()
 845   "Forward the current message to one or more recipients.
 846 You will be placed in a Mail mode buffer as you would with a
 847 reply, but you must fill in the To: header and perhaps the
 848 Subject: header manually."
 849   (interactive)
 850   (vm-follow-summary-cursor)
 851   (vm-select-folder-buffer)
 852   (vm-check-for-killed-summary)
 853   (vm-error-if-folder-empty)
 854   (if (and (eq last-command 'vm-next-command-uses-marks)
 855            (cdr (vm-select-marked-or-prefixed-messages 0)))
 856       (let ((vm-digest-send-type vm-forwarding-digest-type))
 857         (setq this-command 'vm-next-command-uses-marks)
 858         (command-execute 'vm-send-digest))
 859     (let ((dir default-directory)
 860           (miming (and vm-send-using-mime
 861                        (equal vm-forwarding-digest-type "mime")))
 862           mail-buffer
 863           header-end
 864           (mp (vm-select-marked-or-prefixed-messages 1)))
 865       (save-restriction
 866         (widen)
 867         (vm-mail-internal
 868          (format "forward of %s's note re: %s"
 869                  (vm-su-full-name (car vm-message-pointer))
 870                  (vm-su-subject (car vm-message-pointer)))
 871          nil
 872          (and vm-forwarding-subject-format
 873               (let ((vm-summary-uninteresting-senders nil))
 874                 (vm-summary-sprintf vm-forwarding-subject-format
 875                                     (car mp)))))
 876         (make-local-variable 'vm-forward-list)
 877         (setq vm-system-state 'forwarding
 878               vm-forward-list (list (car mp))
 879               default-directory dir)
 880         (if miming
 881             (progn
 882               (setq mail-buffer (current-buffer))
 883               (set-buffer (vm-make-work-buffer "*vm-forward-buffer*"))
 884               (setq header-end (point))
 885               (insert "\n"))
 886           (goto-char (point-min))
 887           (re-search-forward (concat "^" (regexp-quote mail-header-separator)
 888                                      "\n"))
 889           (goto-char (match-end 0))
 890           (setq header-end (match-beginning 0)))
 891         (cond ((equal vm-forwarding-digest-type "mime")
 892                (vm-mime-encapsulate-messages (list (car mp))
 893                                              vm-forwarded-headers
 894                                              vm-unforwarded-header-regexp
 895                                              nil)
 896                (goto-char header-end)
 897                (insert "MIME-Version: 1.0\n")
 898                (insert "Content-Type: message/rfc822\n")
 899                (insert "Content-Transfer-Encoding: "
 900                        (vm-determine-proper-content-transfer-encoding
 901                         (point)
 902                         (point-max))
 903                        "\n")
 904                (insert "Content-Description: forwarded message\n")
 905                ;; eight bit chars will get \201 prepended if we
 906                ;; don't do this.
 907                (if vm-fsfemacs-mule-p
 908                    (set-buffer-multibyte t)))
 909               ((equal vm-forwarding-digest-type "rfc934")
 910                (vm-rfc934-encapsulate-messages
 911                 vm-forward-list vm-forwarded-headers
 912                 vm-unforwarded-header-regexp))
 913               ((equal vm-forwarding-digest-type "rfc1153")
 914                (vm-rfc1153-encapsulate-messages
 915                 vm-forward-list vm-forwarded-headers
 916                 vm-unforwarded-header-regexp))
 917               ((equal vm-forwarding-digest-type nil)
 918                (vm-no-frills-encapsulate-message
 919                 (car vm-forward-list) vm-forwarded-headers
 920                 vm-unforwarded-header-regexp)))
 921       (if miming
 922           (let ((b (current-buffer)))
 923             (set-buffer mail-buffer)
 924             (mail-text)
 925             (vm-mime-attach-object b "message/rfc822" nil
 926                                    "forwarded message" t)
 927             (add-hook 'kill-buffer-hook
 928                       (list 'lambda ()
 929                             (list 'if (list 'eq mail-buffer '(current-buffer))
 930                                   (list 'kill-buffer b))))))
 931         (mail-position-on-field "To"))
 932       (run-hooks 'vm-forward-message-hook)
 933       (run-hooks 'vm-mail-mode-hook))))
 934
 935 ;;;###autoload
 936 (defun vm-resend-bounced-message ()
 937   "Extract the original text from a bounced message and resend it.
 938 You will be placed in a Mail mode buffer with the extracted message and
 939 you can change the recipient address before resending the message."
 940   (interactive)
 941   (vm-follow-summary-cursor)
 942   (vm-select-folder-buffer)
 943   (vm-check-for-killed-summary)
 944   (vm-error-if-folder-empty)
 945   (let ((b (current-buffer)) start
 946         (dir default-directory)
 947         (layout (vm-mm-layout (car vm-message-pointer)))
 948         (lim (vm-text-end-of (car vm-message-pointer))))
 949       (save-restriction
 950         (widen)
 951         (if (or (not (vectorp layout))
 952                 (not (setq layout (vm-mime-layout-contains-type
 953                                    layout "message/rfc822"))))
 954             (save-excursion
 955               (goto-char (vm-text-of (car vm-message-pointer)))
 956               (let ((case-fold-search t))
 957                 ;; What a wonderful world it would be if mailers
 958                 ;; used a single message encapsulation standard
 959                 ;; instead of all the weird variants. It is
 960                 ;; useless to try to cover them all.  This simple
 961                 ;; rule should cover the sanest of the formats
 962                 (if (not (re-search-forward "^Received:" lim t))
 963                     (error "This doesn't look like a bounced message."))
 964                 (beginning-of-line)
 965                 (setq start (point)))))
 966         ;; briefly nullify vm-mail-header-from to keep vm-mail-internal
 967         ;; from inserting another From header.
 968         (let ((vm-mail-header-from nil))
 969           (vm-mail-internal
 970            (format "retry of bounce from %s"
 971                    (vm-su-from (car vm-message-pointer)))))
 972         (goto-char (point-min))
 973         (if (vectorp layout)
 974             (progn
 975               (setq start (point))
 976               (vm-mime-insert-mime-body layout)
 977               (vm-mime-transfer-decode-region layout start (point)))
 978           (insert-buffer-substring b start lim))
 979         (delete-region (point) (point-max))
 980         (goto-char (point-min))
 981         ;; delete all but pertinent headers
 982         (vm-reorder-message-headers nil nil "\\(X-VM-\\|Status:\\|Sender:\\)")
 983         (vm-reorder-message-headers nil vm-resend-bounced-headers
 984                                     vm-resend-bounced-discard-header-regexp)
 985         (if (search-forward "\n\n" nil t)
 986             (replace-match "")
 987           (goto-char (point-max)))
 988         (insert ?\n mail-header-separator ?\n)
 989         (goto-char (point-min))
 990         (if vm-mail-header-from
 991             (insert "Resent-From: " vm-mail-header-from ?\n))
 992         (if (vm-mail-mode-get-header-contents "Resent-To:")
 993             (mail-position-on-field "Resent-To")
 994           (insert "Resent-To: \n")
 995           (forward-char -1))
 996         (setq default-directory dir)))
 997   (run-hooks 'vm-resend-bounced-message-hook)
 998   (run-hooks 'vm-mail-mode-hook))
 999
1000 ;;;###autoload
1001 (defun vm-resend-message ()
1002   "Resend the current message to someone else.
1003 The current message will be copied to a Mail mode buffer and you
1004 can edit the message and send it as usual.
1005
1006 NOTE: since you are doing a resend, a Resent-To header is provided
1007 for you to fill in the new recipient list.  If you don't fill in
1008 this header, what happens when you send the message is undefined.
1009 You may also create a Resent-Cc header."
1010   (interactive)
1011   (vm-follow-summary-cursor)
1012   (vm-select-folder-buffer)
1013   (vm-check-for-killed-summary)
1014   (vm-error-if-folder-empty)
1015   (save-restriction
1016     (widen)
1017     (let ((b (current-buffer))
1018           (dir default-directory)
1019           (vmp vm-message-pointer)
1020           (start (vm-headers-of (car vm-message-pointer)))
1021           (lim (vm-text-end-of (car vm-message-pointer))))
1022       ;; briefly nullify vm-mail-header-from to keep vm-mail-internal
1023       ;; from inserting another From header.
1024       (let ((vm-mail-header-from nil))
1025         (vm-mail-internal
1026          (format "resend of %s's note re: %s"
1027                  (vm-su-full-name (car vm-message-pointer))
1028                  (vm-su-subject (car vm-message-pointer)))))
1029       (goto-char (point-min))
1030       (insert-buffer-substring b start lim)
1031       (delete-region (point) (point-max))
1032       (goto-char (point-min))
1033       (if vm-mail-header-from
1034           (insert "Resent-From: " vm-mail-header-from ?\n))
1035       (insert "Resent-To: \n")
1036       (if mail-self-blind
1037           (insert "Bcc: "
1038                   (cond ((and vm-xemacs-p (fboundp 'user-mail-address))
1039                          (user-mail-address))
1040                         ((and (boundp 'user-mail-address)
1041                               (stringp user-mail-address))
1042                          user-mail-address)
1043                         (t (user-login-name)))
1044                   ?\n))
1045       (if mail-archive-file-name
1046           (insert "FCC: " mail-archive-file-name ?\n))
1047       ;; delete all but pertinent headers
1048       (vm-reorder-message-headers nil nil "\\(X-VM-\\|Status:\\|Sender:\\)")
1049       (vm-reorder-message-headers nil vm-resend-headers
1050                                   vm-resend-discard-header-regexp)
1051       (if (search-forward "\n\n" nil t)
1052           (replace-match ""))
1053       (insert ?\n mail-header-separator ?\n)
1054       (goto-char (point-min))
1055       (mail-position-on-field "Resent-To")
1056       (make-local-variable 'vm-redistribute-list)
1057       (setq vm-system-state 'redistributing
1058             vm-redistribute-list (list (car vmp))
1059             default-directory dir)
1060       (run-hooks 'vm-resend-message-hook)
1061       (run-hooks 'vm-mail-mode-hook))))
1062
1063 ;;;###autoload
1064 (defun vm-send-digest (&optional prefix)
1065   "Send a digest of all messages in the current folder to recipients.
1066 The type of the digest is specified by the variable vm-digest-send-type.
1067 You will be placed in a Mail mode buffer as is usual with replies, but you
1068 must fill in the To: and Subject: headers manually.
1069
1070 Prefix arg means to insert a list of preamble lines at the beginning of
1071 the digest.  One line is generated for each message being digestified.
1072 The variable vm-digest-preamble-format determines the format of the
1073 preamble lines.
1074
1075 If invoked on marked messages (via vm-next-command-uses-marks),
1076 only marked messages will be put into the digest."
1077   (interactive "P")
1078   (vm-select-folder-buffer)
1079   (vm-check-for-killed-summary)
1080   (vm-error-if-folder-empty)
1081   (let ((dir default-directory)
1082         (miming (and vm-send-using-mime (equal vm-digest-send-type "mime")))
1083         mp mail-buffer b
1084         ;; prefix arg doesn't have "normal" meaning here, so only call
1085         ;; vm-select-marked-or-prefixed-messages if we're using marks.
1086         (mlist (if (eq last-command 'vm-next-command-uses-marks)
1087                    (vm-select-marked-or-prefixed-messages 0)
1088                  vm-message-list))
1089         start header-end boundary)
1090     (save-restriction
1091       (widen)
1092       (vm-mail-internal
1093        (format "digest from %s" (buffer-name))
1094        nil
1095        (and vm-forwarding-subject-format
1096             (let ((vm-summary-uninteresting-senders nil))
1097               (concat (vm-summary-sprintf vm-forwarding-subject-format (car mlist))
1098                       (if (cdr mlist)
1099                           (format " [and %d more messages]"
1100                                   (length (cdr mlist))))))))
1101       (make-local-variable 'vm-forward-list)
1102       (setq vm-system-state 'forwarding
1103             vm-forward-list mlist
1104             default-directory dir)
1105       (if miming
1106           (progn
1107             (setq mail-buffer (current-buffer))
1108             (set-buffer (vm-make-work-buffer "*vm-digest-buffer*"))
1109             (setq header-end (point))
1110             (insert "\n")
1111             (setq start (point-marker)))
1112         (goto-char (point-min))
1113         (re-search-forward (concat "^" (regexp-quote mail-header-separator)
1114                                    "\n"))
1115         (goto-char (match-end 0))
1116         (setq start (point-marker)
1117               header-end (match-beginning 0)))
1118       (message "Building %s digest..." vm-digest-send-type)
1119       (cond ((equal vm-digest-send-type "mime")
1120              (setq boundary (vm-mime-encapsulate-messages
1121                              mlist vm-mime-digest-headers
1122                              vm-mime-digest-discard-header-regexp
1123                              t))
1124              (goto-char header-end)
1125              (insert "MIME-Version: 1.0\n")
1126              (insert (if vm-mime-avoid-folding-content-type
1127                          "Content-Type: multipart/digest; boundary=\""
1128                        "Content-Type: multipart/digest;\n\tboundary=\"")
1129                      boundary "\"\n")
1130              (insert "Content-Transfer-Encoding: "
1131                      (vm-determine-proper-content-transfer-encoding
1132                       (point)
1133                       (point-max))
1134                      "\n"))
1135             ((equal vm-digest-send-type "rfc934")
1136              (vm-rfc934-encapsulate-messages
1137               mlist vm-rfc934-digest-headers
1138               vm-rfc934-digest-discard-header-regexp))
1139             ((equal vm-digest-send-type "rfc1153")
1140              (vm-rfc1153-encapsulate-messages
1141               mlist vm-rfc1153-digest-headers
1142               vm-rfc1153-digest-discard-header-regexp))
1143             ((equal vm-digest-send-type nil)
1144              (while mlist
1145                (vm-no-frills-encapsulate-message
1146                 (car mlist) vm-forwarded-headers
1147                 vm-unforwarded-header-regexp)
1148                (setq mlist (cdr mlist)))))
1149
1150       (goto-char start)
1151       (setq mp mlist)
1152       (if miming
1153           (let ((b (current-buffer)))
1154             (set-buffer mail-buffer)
1155             (mail-text)
1156             (vm-mime-attach-object b "multipart/digest"
1157                                    (list (concat "boundary=\""
1158                                                  boundary "\"")) nil t)
1159             (add-hook 'kill-buffer-hook
1160                       (list 'lambda ()
1161                             (list 'if (list 'eq mail-buffer '(current-buffer))
1162                                   (list 'kill-buffer b))))))
1163       (if prefix
1164           (save-excursion
1165             (message "Building digest preamble...")
1166             (if miming
1167                 (progn
1168                   (set-buffer mail-buffer)
1169                   (mail-text)))
1170             (while mp
1171               (let ((vm-summary-uninteresting-senders nil))
1172                 (insert (vm-summary-sprintf vm-digest-preamble-format
1173                                             (car mp)) "\n"))
1174               (if vm-digest-center-preamble
1175                   (progn
1176                     (forward-char -1)
1177                     (center-line)
1178                     (forward-char 1)))
1179               (setq mp (cdr mp)))))
1180       (mail-position-on-field "To")
1181       (message "Building %s digest... done" vm-digest-send-type)))
1182   (run-hooks 'vm-send-digest-hook)
1183   (run-hooks 'vm-mail-mode-hook))
1184
1185 ;;;###autoload
1186 (defun vm-send-rfc934-digest (&optional preamble)
1187   "Like vm-send-digest but always sends an RFC 934 digest."
1188   (interactive "P")
1189   (let ((vm-digest-send-type "rfc934"))
1190     (vm-send-digest preamble)))
1191
1192 ;;;###autoload
1193 (defun vm-send-rfc1153-digest (&optional preamble)
1194   "Like vm-send-digest but always sends an RFC 1153 digest."
1195   (interactive "P")
1196   (let ((vm-digest-send-type "rfc1153"))
1197     (vm-send-digest preamble)))
1198
1199 ;;;###autoload
1200 (defun vm-send-mime-digest (&optional preamble)
1201   "Like vm-send-digest but always sends an MIME (multipart/digest) digest."
1202   (interactive "P")
1203   (let ((vm-digest-send-type "mime"))
1204     (vm-send-digest preamble)))
1205
1206 ;;;###autoload
1207 (defun vm-continue-composing-message (&optional not-picky)
1208   "Find and select the most recently used mail composition buffer.
1209 If the selected buffer is already a Mail mode buffer then it is
1210 buried before beginning the search.  Non Mail mode buffers and
1211 unmodified Mail buffers are skipped.  Prefix arg means unmodified
1212 Mail mode buffers are not skipped.  If no suitable buffer is
1213 found, the current buffer remains selected."
1214   (interactive "P")
1215   (if (eq major-mode 'mail-mode)
1216       (vm-bury-buffer (current-buffer)))
1217   (let ((b (vm-find-composition-buffer not-picky)))
1218     (if (not (or (null b) (eq b (current-buffer))))
1219         (progn
1220           ;; avoid having the window configuration code choose a
1221           ;; different composition buffer.
1222           (vm-unbury-buffer b)
1223           (set-buffer b)
1224           (if (and vm-mutable-frames vm-frame-per-composition
1225                    (vm-multiple-frames-possible-p)
1226                    ;; only pop up a frame if there's an undisplay
1227                    ;; hook in place to make the frame go away.
1228                    vm-undisplay-buffer-hook)
1229               (let ((w (vm-get-buffer-window b)))
1230                 (if (null w)
1231                     (vm-goto-new-frame 'composition)
1232                   (select-window w)
1233                   (and vm-warp-mouse-to-new-frame
1234                        (vm-warp-mouse-to-frame-maybe (vm-window-frame w))))
1235                 ;; need to do this here too, since XEmacs has per
1236                 ;; frame buffer lists.
1237                 (vm-unbury-buffer b)
1238                 (vm-set-hooks-for-frame-deletion)))
1239           (vm-display b t '(vm-continue-composing-message)
1240                       '(vm-continue-composing-message composing-message)))
1241       (message "No composition buffers found"))))
1242
1243 ;;;###autoload
1244 (defun vm-mail-to-mailto-url (url)
1245   (vm-session-initialization)
1246   (vm-check-for-killed-folder)
1247   (vm-select-folder-buffer-if-possible)
1248   (vm-check-for-killed-summary)
1249   (let ((list (vm-parse url "^mailto:\\([^?]+\\)\\??\\|\\([^&]+\\)&?"
1250                         '(1 2)))
1251         to subject in-reply-to cc references newsgroups body
1252         tem header value header-list)
1253     (setq to (car list)
1254           to (vm-url-decode-string to)
1255           list (cdr list))
1256     (while list
1257       (setq tem (vm-parse (car list) "\\([^=]+\\)=?"))
1258       (if (null (nth 1 tem))
1259           nil
1260         (setq header (downcase (vm-url-decode-string (car tem)))
1261               value (vm-url-decode-string (nth 1 tem)))
1262         (if (member header '("subject" "in-reply-to" "cc"
1263                              "references" "newsgroups" "body"))
1264             ;; set the variable let-bound above
1265             (set (intern header) value)
1266           ;; we'll insert the header later
1267           (setq header-list (cons header (cons value header-list)))))
1268       (setq list (cdr list)))
1269     (vm-mail-internal nil to subject in-reply-to cc references newsgroups)
1270     (save-excursion
1271       (goto-char (point-min))
1272       (while header-list
1273         (insert (car header-list) ": ")
1274         (capitalize-region (point) (save-excursion (beginning-of-line) (point)))
1275         (insert (nth 1 header-list) "\n")
1276         (setq header-list (nthcdr 2 header-list)))
1277       (if (null body)
1278           nil
1279         (mail-text)
1280         (save-excursion (insert (vm-url-decode-string body) "\n"))
1281         ;; CRLF to LF for line breaks in the body
1282         (while (search-forward "\r\n" nil t)
1283           (replace-match "\n"))))
1284     (run-hooks 'vm-mail-hook)
1285     (run-hooks 'vm-mail-mode-hook)))
1286
1287 ;; to quiet the v19 byte compiler
1288 (defvar mail-mode-map)
1289 (defvar mail-aliases)
1290 (defvar mail-default-reply-to)
1291 (defvar mail-signature-file)
1292 (defvar mail-personal-alias-file)
1293
1294 (defun vm-drop-buffer-name-chars (buffer-name)
1295   "Replace chars matching `vm-drop-buffer-name-chars' by an \"_\"."
1296   (let ((r vm-drop-buffer-name-chars))
1297     (if (eq r t) (setq r "[^\x0-\x80]"))
1298     (if (and buffer-name r)
1299         (vm-replace-in-string buffer-name r "_" t)
1300       buffer-name)))
1301
1302 ;;;###autoload
1303 (defun vm-mail-internal
1304     (&optional buffer-name to subject in-reply-to cc references newsgroups)
1305     "Create a message buffer and set it up according to args.
1306 Fills in the headers as given by the arguments.
1307 Binds the `vm-mail-mode-map' and hooks"
1308   (let ((folder-buffer nil))
1309     (if (memq major-mode '(vm-mode vm-virtual-mode))
1310         (setq folder-buffer (current-buffer)))
1311     (setq buffer-name (if buffer-name
1312                           (vm-decode-mime-encoded-words-in-string buffer-name)
1313                         "mail to ?"))
1314     (setq buffer-name (vm-drop-buffer-name-chars buffer-name))
1315     (set-buffer (generate-new-buffer buffer-name))
1316     ;; FSF Emacs: try to prevent write-region (called to handle FCC) from
1317     ;; asking the user to choose a safe coding system.
1318     (if (and vm-fsfemacs-mule-p (fboundp 'set-buffer-file-coding-system))
1319         (set-buffer-file-coding-system 'raw-text))
1320     ;; avoid trying to write auto-save files in potentially
1321     ;; unwritable directories.
1322     (setq default-directory (or vm-folder-directory (expand-file-name "~/")))
1323     (auto-save-mode (if auto-save-default 1 -1))
1324     (mail-mode)
1325     ;; TM infests mail mode, uninfest it if VM's MIME stuff is in
1326     ;; use.
1327     (if vm-send-using-mime
1328         (vm-mail-mode-remove-tm-hooks))
1329     (use-local-map vm-mail-mode-map)
1330     ;; make mail-mode-map the parent of this vm-mail-mode-map, if we can.
1331     ;; do it only once.
1332     (if (not vm-mail-mode-map-parented)
1333         (cond ((fboundp 'set-keymap-parents)
1334                (set-keymap-parents vm-mail-mode-map (list mail-mode-map))
1335                (setq vm-mail-mode-map-parented t))
1336               ((consp mail-mode-map)
1337                (nconc vm-mail-mode-map mail-mode-map)
1338                (setq vm-mail-mode-map-parented t))))
1339     (setq vm-mail-buffer folder-buffer
1340           mode-popup-menu (and vm-use-menus
1341                                (vm-menu-support-possible-p)
1342                                (vm-menu-mode-menu)))
1343     (and vm-use-menus (vm-menu-support-possible-p)
1344          (vm-menu-install-mail-mode-menu))
1345     (if (fboundp 'mail-aliases-setup) ; use mail-abbrevs.el if present
1346         (mail-aliases-setup)
1347       (if (eq mail-aliases t)
1348           (progn
1349             (setq mail-aliases nil)
1350             (if (file-exists-p (or mail-personal-alias-file "~/.mailrc"))
1351                 (build-mail-aliases)))))
1352     (if (stringp vm-mail-header-from)
1353         (insert "From: " vm-mail-header-from "\n"))
1354     (setq to (if to (vm-decode-mime-encoded-words-in-string to))
1355           subject (if subject (vm-decode-mime-encoded-words-in-string subject))
1356           cc (if cc (vm-decode-mime-encoded-words-in-string cc)))
1357     (insert "To: " (or to "") "\n")
1358     (and cc (insert "Cc: " cc "\n"))
1359     (insert "Subject: " (or subject "") "\n")
1360     (and newsgroups (insert "Newsgroups: " newsgroups "\n"))
1361     (and in-reply-to (insert "In-Reply-To: " in-reply-to "\n"))
1362     (and references (insert "References: " references "\n"))
1363     (insert "X-Mailer: VM " (vm-version) " under ")
1364     (cond ((boundp 'emacs-version)
1365            (insert emacs-version))
1366           (t
1367            (insert "Unknown Emacs")))
1368     (if (functionp 'emacsw32-version)
1369         (insert " [" (emacsw32-version) "]"))
1370     (if (boundp 'system-configuration)
1371         (insert " (" system-configuration ")"))
1372     (insert "\n")
1373     ;; REPLYTO environmental variable support
1374     ;; note that in FSF Emacs v19.29 we would initialize if the
1375     ;; value was t.  nil is the trigger value used now.
1376     (and (eq mail-default-reply-to nil)
1377          (setq mail-default-reply-to (getenv "REPLYTO")))
1378     (if mail-default-reply-to
1379         (insert "Reply-To: " mail-default-reply-to "\n"))
1380     (if mail-self-blind
1381         (insert "Bcc: "
1382                 (cond ((and vm-xemacs-p (fboundp 'user-mail-address))
1383                        (user-mail-address))
1384                       ((and (boundp 'user-mail-address)
1385                             (stringp user-mail-address))
1386                        user-mail-address)
1387                       (t (user-login-name)))
1388                 ?\n))
1389     (if mail-archive-file-name
1390         (insert "FCC: " mail-archive-file-name "\n"))
1391     (if mail-default-headers
1392         (insert mail-default-headers))
1393     (if (not (= (preceding-char) ?\n))
1394         (insert ?\n))
1395     (insert mail-header-separator "\n")
1396     (if mail-signature
1397         (save-excursion
1398           (save-restriction
1399             (narrow-to-region (point) (point))
1400             (cond ((stringp mail-signature)
1401                    (insert mail-signature))
1402                   ((eq mail-signature t)
1403                    (insert-file-contents (or (and (boundp 'mail-signature-file)
1404                                                   (stringp mail-signature-file)
1405                                                   mail-signature-file)
1406                                              "~/.signature")))
1407                   (t
1408                    (let ((str (eval mail-signature)))
1409                      (if (stringp str)
1410                          (insert str)))))
1411             (goto-char (point-min))
1412             (if (looking-at "\n*-- \n")
1413                 nil
1414               (insert "\n-- \n"))
1415             (goto-char (point-max)))))
1416     ;; move this buffer to the head of the buffer list so window
1417     ;; config stuff will select it as the composition buffer.
1418     (vm-unbury-buffer (current-buffer))
1419     ;; make a new frame if the user wants it.
1420     (if (and vm-mutable-frames vm-frame-per-composition
1421              (vm-multiple-frames-possible-p))
1422         (progn
1423           (vm-goto-new-frame 'composition)
1424           (vm-set-hooks-for-frame-deletion)))
1425     ;; now do window configuration
1426     (vm-display (current-buffer) t
1427                 '(vm-mail
1428                   vm-mail-other-frame
1429                   vm-mail-other-window
1430                   vm-reply
1431                   vm-reply-other-frame
1432                   vm-reply-include-text
1433                   vm-reply-include-text-other-frame
1434                   vm-followup
1435                   vm-followup-other-frame
1436                   vm-followup-include-text
1437                   vm-followup-include-text-other-frame
1438                   vm-send-digest
1439                   vm-send-digest-other-frame
1440                   vm-send-rfc934-digest
1441                   vm-send-rfc934-digest-other-frame
1442                   vm-send-rfc1153-digest
1443                   vm-send-rfc1153-digest-other-frame
1444                   vm-send-mime-digest
1445                   vm-send-mime-digest-other-frame
1446                   vm-forward-message
1447                   vm-forward-message-other-frame
1448                   vm-forward-message-all-headers
1449                   vm-forward-message-all-headers-other-frame
1450                   vm-resend-message
1451                   vm-resend-message-other-frame
1452                   vm-resend-bounced-message
1453                   vm-resend-bounced-message-other-frame)
1454                 (list this-command 'composing-message))
1455     (if (null to)
1456         (mail-position-on-field "To"))
1457     (cond ((and vm-xemacs-p
1458                 (fboundp 'start-itimer)
1459                 (null (get-itimer "vm-rename-mail"))
1460            (start-itimer "vm-rename-mail"
1461                          'vm-update-composition-buffer-name
1462                          1.5 1.5 t)))
1463           ((and (fboundp 'run-with-idle-timer)
1464                 (null vm-update-composition-buffer-name-timer))
1465            (setq vm-update-composition-buffer-name-timer
1466                  (run-with-idle-timer 1.5 t 'vm-update-composition-buffer-name))))
1467     (run-hooks 'mail-setup-hook)))
1468
1469 ;;;###autoload
1470 (defun vm-reply-other-frame (count)
1471   "Like vm-reply, but run in a newly created frame."
1472   (interactive "p")
1473   (if (vm-multiple-frames-possible-p)
1474       (vm-goto-new-frame 'composition))
1475   (let ((vm-frame-per-composition nil)
1476         (vm-search-other-frames nil))
1477     (vm-reply count))
1478   (if (vm-multiple-frames-possible-p)
1479       (vm-set-hooks-for-frame-deletion)))
1480
1481 ;;;###autoload
1482 (defun vm-reply-include-text-other-frame (count)
1483   "Like vm-reply-include-text, but run in a newly created frame."
1484   (interactive "p")
1485   (if (vm-multiple-frames-possible-p)
1486       (vm-goto-new-frame 'composition))
1487   (let ((vm-frame-per-composition nil)
1488         (vm-search-other-frames nil))
1489     (vm-reply-include-text count))
1490   (if (vm-multiple-frames-possible-p)
1491       (vm-set-hooks-for-frame-deletion)))
1492
1493 ;;;###autoload
1494 (defun vm-followup-other-frame (count)
1495   "Like vm-followup, but run in a newly created frame."
1496   (interactive "p")
1497   (if (vm-multiple-frames-possible-p)
1498       (vm-goto-new-frame 'composition))
1499   (let ((vm-frame-per-composition nil)
1500         (vm-search-other-frames nil))
1501     (vm-followup count))
1502   (if (vm-multiple-frames-possible-p)
1503       (vm-set-hooks-for-frame-deletion)))
1504
1505 ;;;###autoload
1506 (defun vm-followup-include-text-other-frame (count)
1507   "Like vm-followup-include-text, but run in a newly created frame."
1508   (interactive "p")
1509   (if (vm-multiple-frames-possible-p)
1510       (vm-goto-new-frame 'composition))
1511   (let ((vm-frame-per-composition nil)
1512         (vm-search-other-frames nil))
1513     (vm-followup-include-text count))
1514   (if (vm-multiple-frames-possible-p)
1515       (vm-set-hooks-for-frame-deletion)))
1516
1517 ;;;###autoload
1518 (defun vm-forward-message-all-headers-other-frame ()
1519   "Like vm-forward-message-all-headers, but run in a newly created frame."
1520   (interactive)
1521   (if (vm-multiple-frames-possible-p)
1522       (vm-goto-new-frame 'composition))
1523   (let ((vm-frame-per-composition nil)
1524         (vm-search-other-frames nil))
1525     (vm-forward-message-all-headers))
1526   (if (vm-multiple-frames-possible-p)
1527       (vm-set-hooks-for-frame-deletion)))
1528
1529 ;;;###autoload
1530 (defun vm-forward-message-other-frame ()
1531   "Like vm-forward-message, but run in a newly created frame."
1532   (interactive)
1533   (if (vm-multiple-frames-possible-p)
1534       (vm-goto-new-frame 'composition))
1535   (let ((vm-frame-per-composition nil)
1536         (vm-search-other-frames nil))
1537     (vm-forward-message))
1538   (if (vm-multiple-frames-possible-p)
1539       (vm-set-hooks-for-frame-deletion)))
1540
1541 ;;;###autoload
1542 (defun vm-resend-message-other-frame ()
1543   "Like vm-resend-message, but run in a newly created frame."
1544   (interactive)
1545   (if (vm-multiple-frames-possible-p)
1546       (vm-goto-new-frame 'composition))
1547   (let ((vm-frame-per-composition nil)
1548         (vm-search-other-frames nil))
1549     (vm-resend-message))
1550   (if (vm-multiple-frames-possible-p)
1551       (vm-set-hooks-for-frame-deletion)))
1552
1553 ;;;###autoload
1554 (defun vm-resend-bounced-message-other-frame ()
1555   "Like vm-resend-bounced-message, but run in a newly created frame."
1556   (interactive)
1557   (if (vm-multiple-frames-possible-p)
1558       (vm-goto-new-frame 'composition))
1559   (let ((vm-frame-per-composition nil)
1560         (vm-search-other-frames nil))
1561     (vm-resend-bounced-message))
1562   (if (vm-multiple-frames-possible-p)
1563       (vm-set-hooks-for-frame-deletion)))
1564
1565 ;;;###autoload
1566 (defun vm-send-digest-other-frame (&optional prefix)
1567   "Like vm-send-digest, but run in a newly created frame."
1568   (interactive "P")
1569   (if (vm-multiple-frames-possible-p)
1570       (vm-goto-new-frame 'composition))
1571   (let ((vm-frame-per-composition nil)
1572         (vm-search-other-frames nil))
1573     (vm-send-digest prefix))
1574   (if (vm-multiple-frames-possible-p)
1575       (vm-set-hooks-for-frame-deletion)))
1576
1577 ;;;###autoload
1578 (defun vm-send-rfc934-digest-other-frame (&optional prefix)
1579   "Like vm-send-rfc934-digest, but run in a newly created frame."
1580   (interactive "P")
1581   (if (vm-multiple-frames-possible-p)
1582       (vm-goto-new-frame 'composition))
1583   (let ((vm-frame-per-composition nil)
1584         (vm-search-other-frames nil))
1585     (vm-send-rfc934-digest prefix))
1586   (if (vm-multiple-frames-possible-p)
1587       (vm-set-hooks-for-frame-deletion)))
1588
1589 ;;;###autoload
1590 (defun vm-send-rfc1153-digest-other-frame (&optional prefix)
1591   "Like vm-send-rfc1153-digest, but run in a newly created frame."
1592   (interactive "P")
1593   (if (vm-multiple-frames-possible-p)
1594       (vm-goto-new-frame 'composition))
1595   (let ((vm-frame-per-composition nil)
1596         (vm-search-other-frames nil))
1597     (vm-send-rfc1153-digest prefix))
1598   (if (vm-multiple-frames-possible-p)
1599       (vm-set-hooks-for-frame-deletion)))
1600
1601 ;;;###autoload
1602 (defun vm-send-mime-digest-other-frame (&optional prefix)
1603   "Like vm-send-mime-digest, but run in a newly created frame."
1604   (interactive "P")
1605   (if (vm-multiple-frames-possible-p)
1606       (vm-goto-new-frame 'composition))
1607   (let ((vm-frame-per-composition nil)
1608         (vm-search-other-frames nil))
1609     (vm-send-mime-digest prefix))
1610   (if (vm-multiple-frames-possible-p)
1611       (vm-set-hooks-for-frame-deletion)))
1612
1613 (defvar enriched-mode)
1614
1615 ;;;###autoload
1616 (defun vm-preview-composition ()
1617   "Show how the current composition buffer might be displayed
1618 in a MIME-aware mail reader.  VM copies and encodes the current
1619 mail composition buffer and displays it as a mail folder.
1620 Type `q' to quit this temp folder and return to composing your
1621 message."
1622   (interactive)
1623   (if (not (eq major-mode 'mail-mode))
1624       (error "Command must be used in a VM Mail mode buffer."))
1625   (let ((temp-buffer nil)
1626         (mail-buffer (current-buffer))
1627         (enriched (and (boundp 'enriched-mode) enriched-mode))
1628         e-list)
1629     (unwind-protect
1630         (progn
1631           (setq temp-buffer (generate-new-buffer "composition preview"))
1632           (set-buffer temp-buffer)
1633           ;; so vm-mime-xxxx-encode-composition won't complain
1634           (setq major-mode 'mail-mode)
1635           (set (make-local-variable 'enriched-mode) enriched)
1636           (vm-insert-region-from-buffer mail-buffer)
1637           (goto-char (point-min))
1638           (or (vm-mail-mode-get-header-contents "From")
1639               (insert "From: " (user-login-name) "\n"))
1640           (or (vm-mail-mode-get-header-contents "Message-ID")
1641               (insert (format "Message-ID: <fake.%d.%d@fake.fake>\n"
1642                               (random 1000000) (random 1000000))))
1643           (or (vm-mail-mode-get-header-contents "Date")
1644               (insert "Date: "
1645                       (format-time-string "%a, %d %b %Y %H%M%S %Z"
1646                                           (current-time))
1647                       "\n"))
1648           (and vm-send-using-mime
1649                (null (vm-mail-mode-get-header-contents "MIME-Version:"))
1650                (vm-mime-encode-composition))
1651           (vm-remove-mail-mode-header-separator)
1652           (vm-munge-message-separators 'mmdf (point-min) (point-max))
1653           (goto-char (point-min))
1654           (insert (vm-leading-message-separator 'mmdf))
1655           (goto-char (point-max))
1656           (if (not (eq (preceding-char) ?\n))
1657               (insert ?\n))
1658           (insert (vm-trailing-message-separator 'mmdf))
1659           (set-buffer-modified-p nil)
1660           ;; point of no return, don't kill it if the user quits
1661           (setq temp-buffer nil)
1662           (let ((vm-auto-decode-mime-messages t)
1663                 (vm-auto-displayed-mime-content-types t))
1664             (vm-save-buffer-excursion
1665              (vm-goto-new-folder-frame-maybe 'folder)
1666              (vm-mode)))
1667           (message
1668            (substitute-command-keys
1669             "Type \\[vm-quit] to continue composing your message"))
1670           ;; temp buffer, don't offer to save it.
1671           (setq buffer-offer-save nil)
1672           (vm-display (or vm-presentation-buffer (current-buffer)) t
1673                       (list this-command) '(vm-mode startup)))
1674       (and temp-buffer (kill-buffer temp-buffer)))))
1675
1676 (defun vm-update-composition-buffer-name ()
1677   (if (and (eq major-mode 'mail-mode)
1678            (save-match-data (string-match "^\\(mail\\|reply\\) to "
1679                                           (buffer-name))))
1680       (let ((to (mail-fetch-field "To"))
1681             (cc (mail-fetch-field "Cc"))
1682             (curbufname (buffer-name))
1683             (deactivate-mark)
1684             fmt newbufname
1685             (ellipsis ""))
1686         (cond (vm-reply-list (setq fmt "reply to %s%s"))
1687               (t (setq fmt "mail to %s%s")))
1688         (setq to (vm-parse-addresses to)
1689               cc (vm-parse-addresses cc))
1690         (if (or (cdr to)
1691                 (and (car to) (car cc)))
1692             (setq ellipsis ", ..."))
1693         (setq newbufname (or (car to) (car cc) "foo (?)")
1694               newbufname (funcall vm-chop-full-name-function newbufname)
1695               newbufname (or (car newbufname) (car (cdr newbufname)))
1696               newbufname (format fmt newbufname ellipsis))
1697         (if (equal newbufname curbufname)
1698             nil
1699           (setq newbufname (vm-drop-buffer-name-chars newbufname))
1700           (rename-buffer newbufname t)))))
1701
1702 ;;;###autoload
1703 (defun vm-mail-mode-remove-tm-hooks ()
1704   (remove-hook 'mail-setup-hook 'turn-on-mime-edit)
1705   (remove-hook 'mail-setup-hook 'mime/decode-message-header)
1706   (remove-hook 'mail-setup-hook 'mime/editor-mode)
1707   (remove-hook 'mail-send-hook  'mime-edit-maybe-translate)
1708   (remove-hook 'mail-send-hook 'mime-editor/maybe-translate))
1709
1710 (provide 'vm-reply)
1711
1712 ;;; vm-reply.el ends here