home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 2: Applications / Linux Cubed Series 2 - Applications.iso / editors / emacs / xemacs / xemacs-1.006 / xemacs-1 / lib / xemacs-19.13 / lisp / vm / vm-reply.el < prev    next >
Encoding:
Text File  |  1995-08-18  |  36.0 KB  |  988 lines
  1. ;;; Mailing, forwarding, and replying commands for VM
  2. ;;; Copyright (C) 1989, 1990, 1991, 1993, 1994, 1995 Kyle E. Jones
  3. ;;;
  4. ;;; This program is free software; you can redistribute it and/or modify
  5. ;;; it under the terms of the GNU General Public License as published by
  6. ;;; the Free Software Foundation; either version 1, or (at your option)
  7. ;;; any later version.
  8. ;;;
  9. ;;; This program is distributed in the hope that it will be useful,
  10. ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  11. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  12. ;;; GNU General Public License for more details.
  13. ;;;
  14. ;;; You should have received a copy of the GNU General Public License
  15. ;;; along with this program; if not, write to the Free Software
  16. ;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  17.  
  18. (provide 'vm-reply)
  19.  
  20. (defun vm-do-reply (to-all include-text count)
  21.     (let ((mlist (vm-select-marked-or-prefixed-messages count))
  22.       (dir default-directory)
  23.       (message-pointer vm-message-pointer)
  24.       (case-fold-search t)
  25.       to cc subject mp in-reply-to references tmp tmp2 newsgroups)
  26.       (setq mp mlist)
  27.       (while mp 
  28.     (cond
  29.      ((eq mlist mp)
  30.       (cond ((setq to
  31.                (let ((reply-to
  32.                   (vm-get-header-contents (car mp) "Reply-To:")))
  33.              (if (vm-ignored-reply-to reply-to)
  34.                  nil
  35.                reply-to ))))
  36.         ((setq to (vm-get-header-contents (car mp) "From:")))
  37.         ;; bad, but better than nothing for some
  38.         ((setq to (vm-grok-From_-author (car mp))))
  39.         (t (error "No From: or Reply-To: header in message")))
  40.       (setq subject (vm-get-header-contents (car mp) "Subject:")
  41.         in-reply-to
  42.         (and vm-in-reply-to-format
  43.              (let ((vm-summary-uninteresting-senders nil))
  44.                (vm-sprintf 'vm-in-reply-to-format (car mp))))
  45.         in-reply-to (and (not (equal "" in-reply-to)) in-reply-to))
  46.       (and subject vm-reply-subject-prefix
  47.            (let ((case-fold-search t))
  48.          (not
  49.           (equal
  50.            (string-match (regexp-quote vm-reply-subject-prefix)
  51.                  subject)
  52.            0)))
  53.            (setq subject (concat vm-reply-subject-prefix subject))))
  54.      (t (cond ((setq tmp (vm-get-header-contents (car mp) "Reply-To:"))
  55.            (setq to (concat to "," tmp)))
  56.           ((setq tmp (vm-get-header-contents (car mp) "From:"))
  57.            (setq to (concat to "," tmp)))
  58.           ;; bad, but better than nothing for some
  59.           ((setq tmp (vm-grok-From_-author (car mp)))
  60.            (setq to (concat to "," tmp)))
  61.           (t (error "No From: or Reply-To: header in message")))))
  62.     (if to-all
  63.         (progn
  64.           (setq tmp (vm-get-header-contents (car mp) "To:"))
  65.           (setq tmp2 (vm-get-header-contents (car mp) "Cc:"))
  66.           (if tmp
  67.           (if cc
  68.               (setq cc (concat cc "," tmp))
  69.             (setq cc tmp)))
  70.           (if tmp2
  71.           (if cc
  72.               (setq cc (concat cc "," tmp2))
  73.             (setq cc tmp2)))))
  74.     (setq references
  75.           (cons (vm-get-header-contents (car mp) "References:")
  76.             (cons (vm-get-header-contents (car mp) "In-reply-to:")
  77.               (cons (vm-get-header-contents (car mp) "Message-ID:")
  78.                 references))))
  79.     (setq newsgroups
  80.           (cons (or (and to-all (vm-get-header-contents (car mp) "Followup-To:"))
  81.             (vm-get-header-contents (car mp) "Newsgroups:"))
  82.             newsgroups))
  83.     (setq mp (cdr mp)))
  84.       (if vm-strip-reply-headers
  85.       (let ((mail-use-rfc822 t))
  86.         (and to (setq to (mail-strip-quoted-names to)))
  87.         (and cc (setq cc (mail-strip-quoted-names cc)))))
  88.       (setq to (vm-parse-addresses to)
  89.         cc (vm-parse-addresses cc))
  90.       (if vm-reply-ignored-addresses
  91.       (setq to (vm-strip-ignored-addresses to)
  92.         cc (vm-strip-ignored-addresses cc)))
  93.       (setq to (vm-delete-duplicates to nil t))
  94.       (setq cc (vm-delete-duplicates
  95.         (append (vm-delete-duplicates cc nil t)
  96.             to (copy-sequence to))
  97.         t t))
  98.       (and to (setq to (mapconcat 'identity to ",\n    ")))
  99.       (and cc (setq cc (mapconcat 'identity cc ",\n    ")))
  100.       (and (null to) (setq to cc cc nil))
  101.       (setq references (delq nil references)
  102.         references (mapconcat 'identity references " ")
  103.         references (vm-parse references "[^<]*\\(<[^>]+>\\)")
  104.         references (vm-delete-duplicates references)
  105.         references (if references (mapconcat 'identity references "\n\t")))
  106.       (setq newsgroups (delq nil newsgroups)
  107.         newsgroups (mapconcat 'identity newsgroups ",")
  108.         newsgroups (vm-parse newsgroups "[ \t\f\r\n,]*\\([^ \t\f\r\n,]+\\)")
  109.         newsgroups (vm-delete-duplicates newsgroups)
  110.         newsgroups (if newsgroups (mapconcat 'identity newsgroups ",")))
  111.       (vm-mail-internal
  112.        (format "reply to %s%s" (vm-su-full-name (car mlist))
  113.            (if (cdr mlist) ", ..." ""))
  114.        to subject in-reply-to cc references newsgroups)
  115.       (make-local-variable 'vm-reply-list)
  116.       (setq vm-system-state 'replying
  117.         vm-reply-list mlist
  118.         default-directory dir)
  119.       (if include-text
  120.       (save-excursion
  121.         (goto-char (point-min))
  122.         (let ((case-fold-search nil))
  123.           (re-search-forward
  124.            (concat "^" (regexp-quote mail-header-separator) "$") nil 0))
  125.         (forward-char 1)
  126.         (while mlist
  127.           (vm-yank-message (car mlist))
  128.           (goto-char (point-max))
  129.           (setq mlist (cdr mlist)))))
  130.       (run-hooks 'vm-reply-hook)
  131.       (run-hooks 'vm-mail-mode-hook)))
  132.  
  133. (defun vm-strip-ignored-addresses (addresses)
  134.   (setq addresses (copy-sequence addresses))
  135.   (let (re-list list addr-list)
  136.     (setq re-list vm-reply-ignored-addresses)
  137.     (while re-list
  138.       (setq addr-list addresses)
  139.       (while addr-list
  140.     (if (string-match (car re-list) (car addr-list))
  141.         (setq addresses (delq (car addr-list) addresses)))
  142.     (setq addr-list (cdr addr-list)))
  143.       (setq re-list (cdr re-list))))
  144.   addresses )
  145.  
  146. (defun vm-ignored-reply-to (reply-to)
  147.   (if reply-to
  148.       (let (re-list result)
  149.     (setq re-list vm-reply-ignored-reply-tos)
  150.     (while re-list
  151.       (if (string-match (car re-list) reply-to)
  152.           (setq result t re-list nil)
  153.         (setq re-list (cdr re-list))))
  154.     result )))
  155.  
  156. (defun vm-mail-yank-default (message)
  157.   (save-excursion
  158.     (vm-reorder-message-headers nil vm-included-text-headers
  159.                 vm-included-text-discard-header-regexp)
  160.     ;; if all the headers are gone, delete the trailing blank line, too.
  161.     (if (eq (following-char) ?\n)
  162.     (delete-char 1))
  163.     (if vm-included-text-attribution-format
  164.     (let ((vm-summary-uninteresting-senders nil))
  165.       (insert (vm-sprintf 'vm-included-text-attribution-format message))))
  166.     ; turn off zmacs-regions for Lucid Emacs 19
  167.     ; and get around transient-mark-mode in FSF Emacs 19
  168.     ; all this so that (mark) does what it did in v18, sheesh.
  169.     (let* ((zmacs-regions nil)
  170.        (mark-even-if-inactive t)
  171.        (end (mark-marker)))
  172.       (while (< (point) end)
  173.     (insert vm-included-text-prefix)
  174.     (forward-line 1)))))
  175.  
  176. (defun vm-yank-message-other-folder (folder)
  177.   "Like vm-yank-message except the message is yanked from a folder other
  178. than the one that spawned the current Mail mode buffer.  The name of the
  179. folder is read from the minibuffer.
  180.  
  181. Don't call this function from a program."
  182.   (interactive
  183.    (list
  184.     (let ((dir (if vm-folder-directory
  185.             (expand-file-name vm-folder-directory)
  186.           default-directory))
  187.       (last-command last-command)
  188.       (this-command this-command))
  189.       (read-file-name "Yank from folder: " dir nil t))))
  190.   (let ((b (current-buffer)) newbuf sumbuf default result prompt mp)
  191.     (set-buffer (or (vm-get-file-buffer folder) (find-file-noselect folder)))
  192.     (setq newbuf (current-buffer))
  193.     (if (not (eq major-mode 'vm-mode))
  194.     (vm-mode))
  195.     (if (null vm-message-pointer)
  196.     (error "No messages in folder %s" folder))
  197.     (setq default (vm-number-of (car vm-message-pointer)))
  198.     (save-excursion
  199.       (save-window-excursion
  200.     (save-window-excursion
  201.       (vm-summarize))
  202.     (vm-display vm-summary-buffer t '(vm-yank-message-other-folder)
  203.             '(vm-yank-message-other-folder composing-message))
  204.     (setq sumbuf (current-buffer))
  205.     (setq prompt (format "Yank message number: (default %s) " default)
  206.           result 0)
  207.     (while (zerop result)
  208.       (setq result (read-string prompt))
  209.       (and (string= result "") default (setq result default))
  210.       (setq result (string-to-int result)))
  211.     (if (null (setq mp (nthcdr (1- result) vm-message-list)))
  212.         (error "No such message."))))
  213.     (set-buffer b)
  214.     (unwind-protect
  215.     (let ((vm-mail-buffer newbuf))
  216.       (vm-yank-message (car mp)))
  217.       (vm-bury-buffer newbuf)
  218.       (vm-bury-buffer sumbuf))))
  219.  
  220. (defun vm-yank-message (message)
  221.   "Yank message number N into the current buffer at point.
  222. When called interactively N is always read from the minibuffer.  When
  223. called non-interactively the first argument is expected to be a
  224. message struct.
  225.  
  226. This command is meant to be used in VM created Mail mode buffers; the
  227. yanked message comes from the mail buffer containing the message you
  228. are replying to, forwarding, or invoked VM's mail command from.
  229.  
  230. All message headers are yanked along with the text.  Point is
  231. left before the inserted text, the mark after.  Any hook
  232. functions bound to mail-citation-hook are run, after inserting
  233. the text and setting point and mark.  For backward compatibility,
  234. if mail-citation-hook is set to nil, `mail-yank-hooks' is run
  235. instead.
  236.  
  237. If mail-citation-hook and mail-yank-hooks are both nil, this
  238. default action is taken: the yanked headers are trimmed as
  239. specified by vm-included-text-headers and
  240. vm-included-text-discard-header-regexp, and the value of
  241. vm-included-text-prefix is prepended to every yanked line."
  242.   (interactive
  243.    (list
  244.    ;; What we really want for the first argument is a message struct,
  245.    ;; but if called interactively, we let the user type in a message
  246.    ;; number instead.
  247.     (let (mp default
  248.       (result 0)
  249.       prompt
  250.       (last-command last-command)
  251.       (this-command this-command))
  252.       (save-excursion
  253.     (vm-select-folder-buffer)
  254.     (setq default (and vm-message-pointer
  255.                (vm-number-of (car vm-message-pointer)))
  256.           prompt (if default
  257.              (format "Yank message number: (default %s) "
  258.                  default)
  259.                "Yank message number: "))
  260.     (while (zerop result)
  261.       (setq result (read-string prompt))
  262.       (and (string= result "") default (setq result default))
  263.       (setq result (string-to-int result)))
  264.     (if (null (setq mp (nthcdr (1- result) vm-message-list)))
  265.         (error "No such message.")))
  266.       (car mp))))
  267.   (if (not (bufferp vm-mail-buffer))
  268.       (error "This is not a VM Mail mode buffer."))
  269.   (if (null (buffer-name vm-mail-buffer))
  270.       (error "The folder buffer containing message %d has been killed."
  271.          (vm-number-of message)))
  272.   (vm-display nil nil '(vm-yank-message) '(vm-yank-message composing-message))
  273.   (setq message (vm-real-message-of message))
  274.   (let ((b (current-buffer)) (start (point)) end)
  275.     (save-restriction
  276.       (widen)
  277.       (save-excursion
  278.     (set-buffer (vm-buffer-of message))
  279.     (save-restriction
  280.       (widen)
  281.       (append-to-buffer b (vm-headers-of message) (vm-text-end-of message))
  282.       (setq end (vm-marker (+ start (- (vm-text-end-of message)
  283.                        (vm-headers-of message))) b))))
  284.       (push-mark end)
  285.       (cond (mail-citation-hook (run-hooks 'mail-citation-hook))
  286.         (mail-yank-hooks (run-hooks 'mail-yank-hooks))
  287.         (t (vm-mail-yank-default message))))))
  288.  
  289. (defun vm-mail-send-and-exit (arg)
  290.   "Just like mail-send-and-exit except that VM flags the appropriate message(s)
  291. as having been replied to, if appropriate."
  292.   (interactive "P")
  293.   (let ((b (current-buffer)))
  294.     (vm-mail-send)
  295.     (cond ((null (buffer-name b)) ;; dead buffer
  296.        (vm-display nil nil '(vm-mail-send-and-exit)
  297.                '(vm-mail-send-and-exit reading-message startup)))
  298.       (t
  299.        (vm-display b nil '(vm-mail-send-and-exit)
  300.                '(vm-mail-send-and-exit reading-message startup))
  301.        (vm-bury-buffer b)))))
  302.  
  303. (defun vm-keep-mail-buffer (buffer)
  304.   ;; keep this buffer if the user demands it
  305.   (if (memq buffer vm-kept-mail-buffers)
  306.       (setq vm-kept-mail-buffers
  307.         (delq buffer vm-kept-mail-buffers)))
  308.   (setq vm-kept-mail-buffers (cons buffer vm-kept-mail-buffers)
  309.     vm-kept-mail-buffers (vm-delete 'buffer-name
  310.                     vm-kept-mail-buffers t))
  311.   (if (not (eq vm-keep-sent-messages t))
  312.       (let ((extras (nthcdr (or vm-keep-sent-messages 0)
  313.                 vm-kept-mail-buffers)))
  314.     (mapcar (function
  315.          (lambda (b)
  316.            (and (buffer-name b) (kill-buffer b))))
  317.         extras)
  318.     (and vm-kept-mail-buffers extras
  319.          (setcdr (memq (car extras) vm-kept-mail-buffers) nil)))))
  320.  
  321. (defun vm-help-tale ()
  322.   (save-excursion
  323.     (goto-char (point-min))
  324.     (while (vm-match-header)
  325.       (if (not (vm-match-header "To:\\|Resent-To:\\|Cc:\\|Resent-Cc:"))
  326.       (goto-char (vm-matched-header-end))
  327.     (goto-char (vm-matched-header-contents-start))
  328.     (if (re-search-forward "[^, \t][ \t]*\n[ \t\n]+[^ \t\n]"
  329.                    (vm-matched-header-contents-end)
  330.                    t)
  331.         (error "tale is an idiot, and so are you. :-)"))
  332.     (goto-char (vm-matched-header-end))))))
  333.  
  334. (defun vm-mail-send ()
  335.   "Just like mail-send except that VM flags the appropriate message(s)
  336. as replied to, forwarded, etc, if appropriate."
  337.   (interactive)
  338.   (if vm-tale-is-an-idiot
  339.       (vm-help-tale))
  340.   (if (and vm-confirm-mail-send
  341.        (not (y-or-n-p "Send the message? ")))
  342.       (error "Message not sent."))
  343.   ;; this to prevent Emacs 19 from asking whether a message that
  344.   ;; has already been sent should be sent again.  VM renames mail
  345.   ;; buffers after the message has been sent, so the user should
  346.   ;; already know that the message has been sent.
  347.   (set-buffer-modified-p t)
  348.   ;; don't want a buffer change to occur here
  349.   ;; save-excursion to be sure.
  350.   (save-excursion
  351.     (mail-send))
  352.   (vm-rename-current-mail-buffer)
  353.   (cond ((eq vm-system-state 'replying)
  354.      (vm-mail-mark-replied))
  355.     ((eq vm-system-state 'forwarding)
  356.      (vm-mail-mark-forwarded))
  357.     ((eq vm-system-state 'redistributing)
  358.      (vm-mail-mark-redistributed)))
  359.   (vm-keep-mail-buffer (current-buffer))
  360.   (vm-display nil nil '(vm-mail-send) '(vm-mail-send)))
  361.  
  362. (defun vm-rename-current-mail-buffer ()
  363.   (if vm-rename-current-buffer-function
  364.       (funcall vm-rename-current-buffer-function)
  365.     (let ((case-fold-search nil))
  366.       (if (not (string-match "^sent " (buffer-name)))
  367.       (let (prefix name n)
  368.         (if (not (= ?* (aref (buffer-name) 0)))
  369.         (setq prefix (format "sent %s" (buffer-name)))
  370.           (let (recipients)
  371.         (cond ((not (zerop (length (setq recipients
  372.                          (mail-fetch-field "To"))))))
  373.               ((not (zerop (length (setq recipients
  374.                          (mail-fetch-field "Cc"))))))
  375.               ((not (zerop (length (setq recipients
  376.                          (mail-fetch-field "Bcc"))))))
  377.                     ; can't happen?!?
  378.               (t (setq recipients "the horse with no name")))
  379.         (setq prefix (format "sent mail to %s" recipients))))
  380.         (if (> (length prefix) 44)
  381.         (setq prefix (concat (substring prefix 0 40) " ...")))
  382.         (setq name prefix n 2)
  383.         (while (get-buffer name)
  384.           (setq name (format "%s<%d>" prefix n))
  385.           (vm-increment n))
  386.         (rename-buffer name))))))
  387.  
  388. (defun vm-mail-mark-replied ()
  389.   (save-excursion
  390.     (let ((mp vm-reply-list))
  391.       (while mp
  392.     (if (null (buffer-name (vm-buffer-of (car mp))))
  393.         ()
  394.       (set-buffer (vm-buffer-of (car mp)))
  395.       (cond ((and (memq (car mp) vm-message-list)
  396.               (null (vm-replied-flag (car mp))))
  397.          (vm-set-replied-flag (car mp) t))))
  398.     (setq mp (cdr mp)))
  399.       (vm-update-summary-and-mode-line))))
  400.  
  401. (defun vm-mail-mark-forwarded ()
  402.   (save-excursion
  403.     (let ((mp vm-forward-list))
  404.       (while mp
  405.     (if (null (buffer-name (vm-buffer-of (car mp))))
  406.         ()
  407.       (set-buffer (vm-buffer-of (car mp)))
  408.       (cond ((and (memq (car mp) vm-message-list)
  409.               (null (vm-forwarded-flag (car mp))))
  410.          (vm-set-forwarded-flag (car mp) t))))
  411.     (setq mp (cdr mp)))
  412.       (vm-update-summary-and-mode-line))))
  413.  
  414. (defun vm-mail-mark-redistributed ()
  415.   (save-excursion
  416.     (let ((mp vm-redistribute-list))
  417.       (while mp
  418.     (if (null (buffer-name (vm-buffer-of (car mp))))
  419.         ()
  420.       (set-buffer (vm-buffer-of (car mp)))
  421.       (cond ((and (memq (car mp) vm-message-list)
  422.               (null (vm-redistributed-flag (car mp))))
  423.          (vm-set-redistributed-flag (car mp) t))))
  424.     (setq mp (cdr mp)))
  425.       (vm-update-summary-and-mode-line))))
  426.  
  427. (defun vm-reply (count)
  428.   "Reply to the sender of the current message.
  429. Numeric prefix argument N means to reply to the current message plus the
  430. next N-1 messages.  A negative N means reply to the current message and
  431. the previous N-1 messages. 
  432.  
  433. If invoked on marked messages (via vm-next-command-uses-marks),
  434. all marked messages will be replied to.
  435.  
  436. You will be placed into a standard Emacs Mail mode buffer to compose and
  437. send your message.  See the documentation for the function `mail' for
  438. more info.
  439.  
  440. Note that the normal binding of C-c C-y in the reply buffer is
  441. automatically changed to vm-yank-message during a reply.  This
  442. allows you to yank any message from the current folder into a
  443. reply.
  444.  
  445. Normal VM commands may be accessed in the reply buffer by prefixing them
  446. with C-c C-v."
  447.   (interactive "p")
  448.   (vm-follow-summary-cursor)
  449.   (vm-select-folder-buffer)
  450.   (vm-check-for-killed-summary)
  451.   (vm-error-if-folder-empty)
  452.   (vm-do-reply nil nil count))
  453.  
  454. (defun vm-reply-include-text (count)
  455.   "Reply to the sender (only) of the current message and include text
  456. from the message.  See the documentation for function vm-reply for details."
  457.   (interactive "p")
  458.   (vm-follow-summary-cursor)
  459.   (vm-select-folder-buffer)
  460.   (vm-check-for-killed-summary)
  461.   (vm-error-if-folder-empty)
  462.   (vm-do-reply nil t count))
  463.  
  464. (defun vm-followup (count)
  465.   "Reply to all recipients of the current message.
  466. See the documentation for the function vm-reply for details."
  467.   (interactive "p")
  468.   (vm-follow-summary-cursor)
  469.   (vm-select-folder-buffer)
  470.   (vm-check-for-killed-summary)
  471.   (vm-error-if-folder-empty)
  472.   (vm-do-reply t nil count))
  473.  
  474. (defun vm-followup-include-text (count)
  475.   "Reply to all recipients of the current message and include text from
  476. the message.  See the documentation for the function vm-reply for details."
  477.   (interactive "p")
  478.   (vm-follow-summary-cursor)
  479.   (vm-select-folder-buffer)
  480.   (vm-check-for-killed-summary)
  481.   (vm-error-if-folder-empty)
  482.   (vm-do-reply t t count))
  483.  
  484. (defun vm-forward-message-all-headers ()
  485.   "Like vm-forward-message but always forwards all the headers."
  486.   (interactive)
  487.   (let ((vm-forwarded-headers nil)
  488.     (vm-unforwarded-header-regexp "only-drop-this-header"))
  489.     (vm-forward-message)))
  490.  
  491. (defun vm-forward-message ()
  492.   "Forward the current message to one or more recipients.
  493. You will be placed in a Mail mode buffer as you would with a
  494. reply, but you must fill in the To: header and perhaps the
  495. Subject: header manually."
  496.   (interactive)
  497.   (vm-follow-summary-cursor)
  498.   (vm-select-folder-buffer)
  499.   (vm-check-for-killed-summary)
  500.   (vm-error-if-folder-empty)
  501.   (if (eq last-command 'vm-next-command-uses-marks)
  502.       (let ((vm-digest-send-type vm-forwarding-digest-type))
  503.     (setq this-command 'vm-next-command-uses-marks)
  504.     (command-execute 'vm-send-digest))
  505.     (let ((dir default-directory)
  506.       (mp vm-message-pointer))
  507.       (save-restriction
  508.     (widen)
  509.     (vm-mail-internal
  510.      (format "forward of %s's note re: %s"
  511.          (vm-su-full-name (car vm-message-pointer))
  512.          (vm-su-subject (car vm-message-pointer)))
  513.      nil
  514.      (and vm-forwarding-subject-format
  515.           (let ((vm-summary-uninteresting-senders nil))
  516.         (vm-sprintf 'vm-forwarding-subject-format (car mp)))))
  517.     (make-local-variable 'vm-forward-list)
  518.     (setq vm-system-state 'forwarding
  519.           vm-forward-list (list (car mp))
  520.           default-directory dir)
  521.     (goto-char (point-min))
  522.     (re-search-forward
  523.      (concat "^" (regexp-quote mail-header-separator) "\n") nil 0)
  524.     (cond ((equal vm-forwarding-digest-type "rfc934")
  525.            (vm-rfc934-encapsulate-messages
  526.         vm-forward-list vm-forwarded-headers
  527.         vm-unforwarded-header-regexp))
  528.           ((equal vm-forwarding-digest-type "rfc1153")
  529.            (vm-rfc1153-encapsulate-messages
  530.         vm-forward-list vm-forwarded-headers
  531.         vm-unforwarded-header-regexp))
  532.           ((equal vm-forwarding-digest-type nil)
  533.            (vm-no-frills-encapsulate-message
  534.         (car vm-forward-list) vm-forwarded-headers
  535.         vm-unforwarded-header-regexp)))
  536.     (mail-position-on-field "To"))
  537.       (run-hooks 'vm-forward-message-hook)
  538.       (run-hooks 'vm-mail-mode-hook))))
  539.  
  540. (defun vm-resend-bounced-message ()
  541.   "Extract the original text from a bounced message and resend it.
  542. You will be placed in a Mail mode buffer with the extracted message and
  543. you can change the recipient address before resending the message."
  544.   (interactive)
  545.   (vm-follow-summary-cursor)
  546.   (vm-select-folder-buffer)
  547.   (vm-check-for-killed-summary)
  548.   (vm-error-if-folder-empty)
  549.   (let ((b (current-buffer)) start
  550.     (dir default-directory)
  551.     (lim (vm-text-end-of (car vm-message-pointer))))
  552.       (save-restriction
  553.     (widen)
  554.     (save-excursion
  555.       (goto-char (vm-text-of (car vm-message-pointer)))
  556.       (let ((case-fold-search t))
  557.         ;; What a wonderful world it would be if mailers used a single
  558.         ;; message encapsulation standard instead all the weird variants
  559.         ;; It is useless to try to cover them all.
  560.         ;; This simple rule should cover the sanest of the formats
  561.         (if (not (re-search-forward "^Received:" lim t))
  562.         (error "This doesn't look like a bounced message."))
  563.         (beginning-of-line)
  564.         (setq start (point))))
  565.     ;; briefly nullify vm-mail-header-from to keep vm-mail-internal
  566.     ;; from inserting another From header.
  567.     (let ((vm-mail-header-from nil))
  568.       (vm-mail-internal
  569.        (format "retry of bounce from %s"
  570.            (vm-su-from (car vm-message-pointer)))))
  571.     (goto-char (point-min))
  572.     (insert-buffer-substring b start lim)
  573.     (delete-region (point) (point-max))
  574.     (goto-char (point-min))
  575.     ;; delete all but pertinent headers
  576.     (vm-reorder-message-headers nil nil "\\(X-VM-\\|Status:\\|Sender:\\)")
  577.     (vm-reorder-message-headers nil vm-resend-bounced-headers
  578.                     vm-resend-bounced-discard-header-regexp)
  579.     (if (search-forward "\n\n" nil t)
  580.         (replace-match "")
  581.       (goto-char (point-max)))
  582.     (insert ?\n mail-header-separator ?\n)
  583.     (mail-position-on-field "To")
  584.     (setq default-directory dir)))
  585.   (run-hooks 'vm-resend-bounced-message-hook)
  586.   (run-hooks 'vm-mail-mode-hook))
  587.  
  588. (defun vm-resend-message ()
  589.   "Resend the current message to someone else.
  590. The current message will be copied to a Mail mode buffer and you
  591. can edit the message and send it as usual.
  592.  
  593. NOTE: since you are doing a resend, a Resent-To header is
  594. provided for you to fill in.  If you don't fill it in, when you
  595. send the message it will go to the original recipients listed in
  596. the To and Cc headers.  You may also create a Resent-Cc header."
  597.   (interactive)
  598.   (vm-follow-summary-cursor)
  599.   (vm-select-folder-buffer)
  600.   (vm-check-for-killed-summary)
  601.   (vm-error-if-folder-empty)
  602.   (save-restriction
  603.     (widen)
  604.     (let ((b (current-buffer))
  605.       (dir default-directory)
  606.       (vmp vm-message-pointer)
  607.       (start (vm-headers-of (car vm-message-pointer)))
  608.       (lim (vm-text-end-of (car vm-message-pointer))))
  609.       ;; briefly nullify vm-mail-header-from to keep vm-mail-internal
  610.       ;; from inserting another From header.
  611.       (let ((vm-mail-header-from nil))
  612.     (vm-mail-internal
  613.      (format "resend of %s's note re: %s"
  614.          (vm-su-full-name (car vm-message-pointer))
  615.          (vm-su-subject (car vm-message-pointer)))))
  616.       (goto-char (point-min))
  617.       (insert-buffer-substring b start lim)
  618.       (delete-region (point) (point-max))
  619.       (goto-char (point-min))
  620.       (if vm-mail-header-from
  621.       (insert "Resent-From: " vm-mail-header-from ?\n))
  622.       (insert "Resent-To: \n")
  623.       (if mail-self-blind
  624.       (insert "Bcc: " (user-login-name) ?\n))
  625.       (if mail-archive-file-name
  626.       (insert "FCC: " mail-archive-file-name ?\n))
  627.       ;; delete all but pertinent headers
  628.       (vm-reorder-message-headers nil nil "\\(X-VM-\\|Status:\\|Sender:\\)")
  629.       (vm-reorder-message-headers nil vm-resend-headers
  630.                   vm-resend-discard-header-regexp)
  631.       (if (search-forward "\n\n" nil t)
  632.       (replace-match ""))
  633.       (insert ?\n mail-header-separator ?\n)
  634.       (goto-char (point-min))
  635.       (mail-position-on-field "Resent-To")
  636.       (make-local-variable 'vm-redistribute-list)
  637.       (setq vm-system-state 'redistributing
  638.         vm-redistribute-list (list (car vmp))
  639.         default-directory dir)
  640.       (run-hooks 'vm-resend-message-hook)
  641.       (run-hooks 'vm-mail-mode-hook))))
  642.  
  643. (defun vm-send-digest (&optional prefix)
  644.   "Send a digest of all messages in the current folder to recipients.
  645. The type of the digest is specified by the variable vm-digest-send-type.
  646. You will be placed in a Mail mode buffer as is usual with replies, but you
  647. must fill in the To: and Subject: headers manually.
  648.  
  649. Prefix arg means to insert a list of preamble lines at the beginning of
  650. the digest.  One line is generated for each message being digestified.
  651. The variable vm-digest-preamble-format determines the format of the
  652. preamble lines.
  653.  
  654. If invoked on marked messages (via vm-next-command-uses-marks),
  655. only marked messages will be put into the digest."
  656.   (interactive "P")
  657.   (vm-select-folder-buffer)
  658.   (vm-check-for-killed-summary)
  659.   (vm-error-if-folder-empty)
  660.   (let ((dir default-directory)
  661.     (mp vm-message-pointer)
  662.     ;; prefix arg doesn't have "normal" meaning here, so only call
  663.     ;; vm-select-marked-or-prefixed-messages if we're using marks.
  664.     (mlist (if (eq last-command 'vm-next-command-uses-marks)
  665.            (vm-select-marked-or-prefixed-messages 0)
  666.          vm-message-list))
  667.     start)
  668.     (save-restriction
  669.       (widen)
  670.       (vm-mail-internal (format "digest from %s" (buffer-name)))
  671.       (make-local-variable 'vm-forward-list)
  672.       (setq vm-system-state 'forwarding
  673.         vm-forward-list mlist
  674.         default-directory dir)
  675.       (goto-char (point-min))
  676.       (re-search-forward (concat "^" (regexp-quote mail-header-separator)
  677.                  "\n"))
  678.       (goto-char (match-end 0))
  679.       (setq start (point)
  680.         mp mlist)
  681.       (vm-unsaved-message "Building %s digest..." vm-digest-send-type)
  682.       (cond ((equal vm-digest-send-type "rfc934")
  683.          (vm-rfc934-encapsulate-messages
  684.           mlist vm-rfc934-digest-headers
  685.           vm-rfc934-digest-discard-header-regexp))
  686.         ((equal vm-digest-send-type "rfc1153")
  687.          (vm-rfc1153-encapsulate-messages
  688.           mlist vm-rfc1153-digest-headers
  689.           vm-rfc1153-digest-discard-header-regexp)))
  690.       (goto-char start)
  691.       (setq mp mlist)
  692.       (if prefix
  693.       (progn
  694.         (vm-unsaved-message "Building digest preamble...")
  695.         (while mp
  696.           (let ((vm-summary-uninteresting-senders nil))
  697.         (insert (vm-sprintf 'vm-digest-preamble-format (car mp)) "\n"))
  698.           (if vm-digest-center-preamble
  699.           (progn
  700.             (forward-char -1)
  701.             (center-line)
  702.             (forward-char 1)))
  703.           (setq mp (cdr mp)))))
  704.       (mail-position-on-field "To")
  705.       (message "Building %s digest... done" vm-digest-send-type)))
  706.   (run-hooks 'vm-send-digest-hook)
  707.   (run-hooks 'vm-mail-mode-hook))
  708.  
  709. (defun vm-send-rfc934-digest (&optional preamble)
  710.   "Like vm-send-digest but always sends an RFC 934 digest."
  711.   (interactive "P")
  712.   (let ((vm-digest-send-type "rfc934"))
  713.     (vm-send-digest preamble)))
  714.  
  715. (defun vm-send-rfc1153-digest (&optional preamble)
  716.   "Like vm-send-digest but always sends an RFC 1153 digest."
  717.   (interactive "P")
  718.   (let ((vm-digest-send-type "rfc1153"))
  719.     (vm-send-digest preamble)))
  720.  
  721. (defun vm-continue-composing-message (&optional not-picky)
  722.   "Find and select the most recently used mail composition buffer.
  723. If the selected buffer is already a Mail mode buffer then it is
  724. buried before beginning the search.  Non Mail mode buffers and
  725. unmodified Mail buffers are skipped.  Prefix arg means unmodified
  726. Mail mode buffers are not skipped.  If no suitable buffer is
  727. found, the current buffer remains selected."
  728.   (interactive "P")
  729.   (if (eq major-mode 'mail-mode)
  730.       (vm-bury-buffer (current-buffer)))
  731.   (let ((b (vm-find-composition-buffer not-picky)))
  732.     (if (not (or (null b) (eq b (current-buffer))))
  733.     (progn
  734.       ;; avoid having the window configuration code choose a
  735.       ;; different composition buffer.
  736.       (vm-unbury-buffer b)
  737.       (set-buffer b)
  738.       (if (and vm-frame-per-composition (vm-multiple-frames-possible-p)
  739.            ;; only pop up a frame if there's an undisplay
  740.            ;; hook in place to make the frame go away.
  741.            vm-undisplay-buffer-hook)
  742.           (let ((w (vm-get-buffer-window b)))
  743.         (if (null w)
  744.             (vm-goto-new-frame 'composition)
  745.           (select-window w)
  746.           (and vm-warp-mouse-to-new-frame
  747.                (vm-warp-mouse-to-frame-maybe (vm-window-frame w))))
  748.         ;; need to do this here too, since XEmacs has per
  749.         ;; frame buffer lists.
  750.         (vm-unbury-buffer b)
  751.         (vm-set-hooks-for-frame-deletion)))
  752.       (vm-display b t '(vm-continue-composing-message)
  753.               '(vm-continue-composing-message composing-message)))
  754.       (message "No composition buffers found"))))
  755.  
  756. ;; to quiet the v19 byte compiler
  757. (defvar mail-mode-map)
  758. (defvar mail-aliases)
  759. (defvar mail-default-reply-to)
  760. (defvar mail-signature-file)
  761.  
  762. (defun vm-mail-internal
  763.     (&optional buffer-name to subject in-reply-to cc references newsgroups)
  764.   (let ((folder-buffer nil))
  765.     (if (memq major-mode '(vm-mode vm-virtual-mode))
  766.     (setq folder-buffer (current-buffer)))
  767.     (set-buffer (generate-new-buffer (or buffer-name "*VM-mail*")))
  768.     ;; avoid trying to write auto-save files in potentially
  769.     ;; unwritable directories.
  770.     (setq default-directory (or vm-folder-directory (expand-file-name "~/")))
  771.     (auto-save-mode (if auto-save-default 1 -1))
  772.     (mail-mode)
  773.     (use-local-map vm-mail-mode-map)
  774.     ;; make mail-mode-map the parent of this vm-mail-mode-map, if we can.
  775.     ;; do it only once.
  776.     (if (not vm-mail-mode-map-parented)
  777.     (cond ((fboundp 'set-keymap-parents)
  778.            (set-keymap-parents vm-mail-mode-map (list mail-mode-map)))
  779.           ((consp mail-mode-map)
  780.            (nconc vm-mail-mode-map mail-mode-map)
  781.            (setq vm-mail-mode-map-parented t))))
  782.     (setq vm-mail-buffer folder-buffer
  783.       mode-popup-menu (and vm-use-menus
  784.                    (vm-menu-support-possible-p)
  785.                    (vm-menu-mode-menu)))
  786.     ;; sets up popup menu for FSF Emacs
  787.     (and vm-use-menus (vm-menu-support-possible-p)
  788.      (vm-menu-install-mail-mode-menu))
  789.     (if (fboundp 'mail-aliases-setup) ; use mail-abbrevs.el if present
  790.     (mail-aliases-setup)
  791.       (if (eq mail-aliases t)
  792.       (progn
  793.         (setq mail-aliases nil)
  794.         (if (file-exists-p "~/.mailrc")
  795.         (build-mail-aliases)))))
  796.     (if (stringp vm-mail-header-from)
  797.     (insert "From: " vm-mail-header-from "\n"))
  798.     (insert "To: " (or to "") "\n")
  799.     (and cc (insert "Cc: " cc "\n"))
  800.     (insert "Subject: " (or subject "") "\n")
  801.     (and newsgroups (insert "Newsgroups: " newsgroups "\n"))
  802.     (and in-reply-to (insert "In-Reply-To: " in-reply-to "\n"))
  803.     (and references (insert "References: " references "\n"))
  804.     ;; REPLYTO support for FSF Emacs v19.29
  805.     (and (eq mail-default-reply-to t)
  806.      (setq mail-default-reply-to (getenv "REPLYTO")))
  807.     (if mail-default-reply-to
  808.     (insert "Reply-To: " mail-default-reply-to "\n"))
  809.     (if mail-self-blind
  810.     (insert "Bcc: " (user-login-name) "\n"))
  811.     (if mail-archive-file-name
  812.     (insert "FCC: " mail-archive-file-name "\n"))
  813.     (if mail-default-headers
  814.     (insert mail-default-headers))
  815.     (if (not (= (preceding-char) ?\n))
  816.     (insert ?\n))
  817.     (insert mail-header-separator "\n")
  818.     (cond ((stringp mail-signature)
  819.        (save-excursion
  820.          (insert mail-signature)))
  821.       ((eq mail-signature t)
  822.        (save-excursion
  823.          (insert "-- \n")
  824.          (insert-file-contents (or (and (boundp 'mail-signature-file)
  825.                         (stringp mail-signature-file)
  826.                         mail-signature-file)
  827.                        "~/.signature")))))
  828.     ;; move this buffer to the head of the buffer list so window
  829.     ;; config stuff will select it as the composition buffer.
  830.     (vm-unbury-buffer (current-buffer))
  831.     ;; make a new frame if the user wants it.
  832.     (if (and vm-frame-per-composition (vm-multiple-frames-possible-p))
  833.     (progn
  834.       (vm-goto-new-frame 'composition)
  835.       (vm-set-hooks-for-frame-deletion)))
  836.     ;; now do window configuration
  837.     (vm-display (current-buffer) t
  838.         '(vm-mail
  839.           vm-mail-other-frame
  840.           vm-mail-other-window
  841.           vm-reply
  842.           vm-reply-other-frame
  843.           vm-reply-include-text
  844.           vm-reply-include-text-other-frame
  845.           vm-followup
  846.           vm-followup-other-frame
  847.           vm-followup-include-text
  848.           vm-followup-include-text-other-frame
  849.           vm-send-digest
  850.           vm-send-digest-other-frame
  851.           vm-send-rfc934-digest
  852.           vm-send-rfc934-digest-other-frame
  853.           vm-send-rfc1153-digest
  854.           vm-send-rfc1153-digest-other-frame
  855.           vm-forward-message
  856.           vm-forward-message-other-frame
  857.           vm-forward-message-all-headers
  858.           vm-forward-message-all-headers-other-frame
  859.           vm-resend-message
  860.           vm-resend-message-other-frame
  861.           vm-resend-bounced-message
  862.           vm-resend-bounced-message-other-frame)
  863.         (list this-command 'composing-message))
  864.     (if (null to)
  865.     (mail-position-on-field "To"))
  866.     (run-hooks 'mail-setup-hook)))
  867.  
  868. (defun vm-reply-other-frame (count)
  869.   "Like vm-reply, but run in a newly created frame."
  870.   (interactive "p")
  871.   (if (vm-multiple-frames-possible-p)
  872.       (vm-goto-new-frame 'composition))
  873.   (let ((vm-frame-per-composition nil)
  874.     (vm-search-other-frames nil))
  875.     (vm-reply count))
  876.   (if (vm-multiple-frames-possible-p)
  877.       (vm-set-hooks-for-frame-deletion)))
  878.  
  879. (defun vm-reply-include-text-other-frame (count)
  880.   "Like vm-reply-include-text, but run in a newly created frame."
  881.   (interactive "p")
  882.   (if (vm-multiple-frames-possible-p)
  883.       (vm-goto-new-frame 'composition))
  884.   (let ((vm-frame-per-composition nil)
  885.     (vm-search-other-frames nil))
  886.     (vm-reply-include-text count))
  887.   (if (vm-multiple-frames-possible-p)
  888.       (vm-set-hooks-for-frame-deletion)))
  889.  
  890. (defun vm-followup-other-frame (count)
  891.   "Like vm-followup, but run in a newly created frame."
  892.   (interactive "p")
  893.   (if (vm-multiple-frames-possible-p)
  894.       (vm-goto-new-frame 'composition))
  895.   (let ((vm-frame-per-composition nil)
  896.     (vm-search-other-frames nil))
  897.     (vm-followup count))
  898.   (if (vm-multiple-frames-possible-p)
  899.       (vm-set-hooks-for-frame-deletion)))
  900.  
  901. (defun vm-followup-include-text-other-frame (count)
  902.   "Like vm-followup-include-text, but run in a newly created frame."
  903.   (interactive "p")
  904.   (if (vm-multiple-frames-possible-p)
  905.       (vm-goto-new-frame 'composition))
  906.   (let ((vm-frame-per-composition nil)
  907.     (vm-search-other-frames nil))
  908.     (vm-followup-include-text count))
  909.   (if (vm-multiple-frames-possible-p)
  910.       (vm-set-hooks-for-frame-deletion)))
  911.  
  912. (defun vm-forward-message-all-headers-other-frame ()
  913.   "Like vm-forward-message-all-headers, but run in a newly created frame."
  914.   (interactive)
  915.   (if (vm-multiple-frames-possible-p)
  916.       (vm-goto-new-frame 'composition))
  917.   (let ((vm-frame-per-composition nil)
  918.     (vm-search-other-frames nil))
  919.     (vm-forward-message-all-headers))
  920.   (if (vm-multiple-frames-possible-p)
  921.       (vm-set-hooks-for-frame-deletion)))
  922.  
  923. (defun vm-forward-message-other-frame ()
  924.   "Like vm-forward-message, but run in a newly created frame."
  925.   (interactive)
  926.   (if (vm-multiple-frames-possible-p)
  927.       (vm-goto-new-frame 'composition))
  928.   (let ((vm-frame-per-composition nil)
  929.     (vm-search-other-frames nil))
  930.     (vm-forward-message))
  931.   (if (vm-multiple-frames-possible-p)
  932.       (vm-set-hooks-for-frame-deletion)))
  933.  
  934. (defun vm-resend-message-other-frame ()
  935.   "Like vm-resend-message, but run in a newly created frame."
  936.   (interactive)
  937.   (if (vm-multiple-frames-possible-p)
  938.       (vm-goto-new-frame 'composition))
  939.   (let ((vm-frame-per-composition nil)
  940.     (vm-search-other-frames nil))
  941.     (vm-resend-message))
  942.   (if (vm-multiple-frames-possible-p)
  943.       (vm-set-hooks-for-frame-deletion)))
  944.  
  945. (defun vm-resend-bounced-message-other-frame ()
  946.   "Like vm-resend-bounced-message, but run in a newly created frame."
  947.   (interactive)
  948.   (if (vm-multiple-frames-possible-p)
  949.       (vm-goto-new-frame 'composition))
  950.   (let ((vm-frame-per-composition nil)
  951.     (vm-search-other-frames nil))
  952.     (vm-resend-bounced-message))
  953.   (if (vm-multiple-frames-possible-p)
  954.       (vm-set-hooks-for-frame-deletion)))
  955.  
  956. (defun vm-send-digest-other-frame (&optional prefix)
  957.   "Like vm-send-digest, but run in a newly created frame."
  958.   (interactive "P")
  959.   (if (vm-multiple-frames-possible-p)
  960.       (vm-goto-new-frame 'composition))
  961.   (let ((vm-frame-per-composition nil)
  962.     (vm-search-other-frames nil))
  963.     (vm-send-digest prefix))
  964.   (if (vm-multiple-frames-possible-p)
  965.       (vm-set-hooks-for-frame-deletion)))
  966.  
  967. (defun vm-send-rfc934-digest-other-frame (&optional prefix)
  968.   "Like vm-send-rfc934-digest, but run in a newly created frame."
  969.   (interactive "P")
  970.   (if (vm-multiple-frames-possible-p)
  971.       (vm-goto-new-frame 'composition))
  972.   (let ((vm-frame-per-composition nil)
  973.     (vm-search-other-frames nil))
  974.     (vm-send-rfc934-digest prefix))
  975.   (if (vm-multiple-frames-possible-p)
  976.       (vm-set-hooks-for-frame-deletion)))
  977.  
  978. (defun vm-send-rfc1153-digest-other-frame (&optional prefix)
  979.   "Like vm-send-rfc1153-digest, but run in a newly created frame."
  980.   (interactive "P")
  981.   (if (vm-multiple-frames-possible-p)
  982.       (vm-goto-new-frame 'composition))
  983.   (let ((vm-frame-per-composition nil)
  984.     (vm-search-other-frames nil))
  985.     (vm-send-rfc1153-digest prefix))
  986.   (if (vm-multiple-frames-possible-p)
  987.       (vm-set-hooks-for-frame-deletion)))
  988.