home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / gnu / lucid / lemacs-19.6 / lisp / vm / vm-reply.el < prev    next >
Encoding:
Text File  |  1992-06-29  |  26.6 KB  |  740 lines
  1. ;;; Mailing, forwarding, and replying commands for VM
  2. ;;; Copyright (C) 1989, 1990, 1991 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. (defun vm-do-reply (to-all include-text count)
  19.   (save-restriction
  20.     (widen)
  21.     (let ((mail-buffer (current-buffer))
  22.       (mlist (vm-select-marked-or-prefixed-messages count))
  23.       (dir default-directory)
  24.       (message-pointer vm-message-pointer)
  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 (vm-get-header-contents (car mp) "Reply-To")))
  31.         ((setq to (vm-get-header-contents (car mp) "From")))
  32.         ((setq to (vm-grok-From_-author (car mp))))
  33.         (t (error "No From: or Reply-To: header in message")))
  34.       (setq subject (vm-get-header-contents (car mp) "Subject")
  35.         in-reply-to (and vm-in-reply-to-format
  36.                  (vm-sprintf 'vm-in-reply-to-format (car mp)))
  37.         in-reply-to (and (not (equal "" in-reply-to)) in-reply-to))
  38.       (and subject vm-reply-subject-prefix
  39.            (let ((case-fold-search t))
  40.          (not
  41.           (equal
  42.            (string-match (regexp-quote vm-reply-subject-prefix)
  43.                  subject)
  44.            0)))
  45.            (setq subject (concat vm-reply-subject-prefix subject))))
  46.      (t (cond ((setq tmp (vm-get-header-contents (car mp) "Reply-To"))
  47.            (setq to (concat to "," tmp)))
  48.           ((setq tmp (vm-get-header-contents (car mp) "From"))
  49.            (setq to (concat to "," tmp)))
  50.           ((setq tmp (vm-grok-From_-author (car mp)))
  51.            (setq to (concat to "," tmp)))
  52.           (t (error "No From: or Reply-To: header in message")))))
  53.     (if to-all
  54.         (progn
  55.           (setq tmp (vm-get-header-contents (car mp) "To"))
  56.           (setq tmp2 (vm-get-header-contents (car mp) "Cc"))
  57.           (if tmp
  58.           (if cc
  59.               (setq cc (concat cc "," tmp))
  60.             (setq cc tmp)))
  61.           (if tmp2
  62.           (if cc
  63.               (setq cc (concat cc "," tmp2))
  64.             (setq cc tmp2)))))
  65.     (setq references
  66.           (cons (vm-get-header-contents (car mp) "References")
  67.             (cons (vm-get-header-contents (car mp) "In-reply-to")
  68.               (cons (vm-get-header-contents (car mp) "Message-ID")
  69.                 references))))
  70.     (setq newsgroups
  71.           (cons (or (and to-all (vm-get-header-contents (car mp) "Followup-To"))
  72.             (vm-get-header-contents (car mp) "Newsgroups"))
  73.             newsgroups))
  74.     (setq mp (cdr mp)))
  75.       (if vm-strip-reply-headers
  76.       (let ((mail-use-rfc822 t))
  77.         (and to (setq to (mail-strip-quoted-names to)))
  78.         (and cc (setq cc (mail-strip-quoted-names cc)))))
  79.       (setq to (vm-parse-addresses to)
  80.         cc (vm-parse-addresses cc))
  81.       (if vm-reply-ignored-addresses
  82.       (setq to (vm-strip-ignored-addresses to)
  83.         cc (vm-strip-ignored-addresses cc)))
  84.       (setq to (vm-delete-duplicates to))
  85.       (setq cc (vm-delete-duplicates
  86.         (append (vm-delete-duplicates cc)
  87.             to (copy-sequence to))
  88.         t))
  89.       (and to (setq to (mapconcat 'identity to ",\n    ")))
  90.       (and cc (setq cc (mapconcat 'identity cc ",\n    ")))
  91.       (and (null to) (setq to cc cc nil))
  92.       (setq references (delq nil references)
  93.         references (mapconcat 'identity references " ")
  94.         references (vm-parse references "[^<]*\\(<[^>]+>\\)")
  95.         references (vm-delete-duplicates references)
  96.         references (if references (mapconcat 'identity references "\n\t")))
  97.       (setq newsgroups (delq nil newsgroups)
  98.         newsgroups (mapconcat 'identity newsgroups ",")
  99.         newsgroups (vm-parse newsgroups "[ \t\f\r\n,]*\\([^ \t\f\r\n,]+\\)")
  100.         newsgroups (vm-delete-duplicates newsgroups)
  101.         newsgroups (if newsgroups (mapconcat 'identity newsgroups ",")))
  102.       (vm-mail-internal
  103.        (format "reply to %s%s" (vm-su-full-name (car mlist))
  104.            (if (cdr mlist) ", ..." ""))
  105.        to subject in-reply-to cc references newsgroups)
  106.       (use-local-map (copy-keymap (current-local-map)))
  107.       (local-set-key "\C-c\C-y" 'vm-yank-message)
  108.       (local-set-key "\C-cy" 'vm-yank-message-other-folder)
  109.       (local-set-key "\C-c\C-s" 'vm-mail-send)
  110.       (local-set-key "\C-c\C-c" 'vm-mail-send-and-exit)
  111.       (local-set-key "\C-c\C-v" vm-mode-map)
  112.       (make-local-variable 'vm-reply-list)
  113.       (setq vm-mail-buffer mail-buffer
  114.         vm-system-state 'replying
  115.         vm-message-pointer message-pointer
  116.         vm-reply-list mlist
  117.         default-directory dir)
  118.       (if include-text
  119.       (save-excursion
  120.         (goto-char (point-min))
  121.         (re-search-forward (concat "^" mail-header-separator "$") nil 0)
  122.         (forward-char 1)
  123.         (while mlist
  124.           (vm-yank-message (car mlist))
  125.           (goto-char (point-max))
  126.           (setq mlist (cdr mlist))))))))
  127.  
  128. (defun vm-strip-ignored-addresses (addresses)
  129.   (setq addresses (copy-sequence addresses))
  130.   (let (re-list list addr-list)
  131.     (setq re-list vm-reply-ignored-addresses)
  132.     (while re-list
  133.       (setq addr-list addresses)
  134.       (while addr-list
  135.     (if (string-match (car re-list) (car addr-list))
  136.         (setq addresses (delq (car addr-list) addresses)))
  137.     (setq addr-list (cdr addr-list)))
  138.       (setq re-list (cdr re-list))))
  139.   addresses )
  140.  
  141. (defun vm-mail-yank-default (message)
  142.   (save-excursion
  143.     (delete-region (point) (progn (search-forward "\n\n") (point)))
  144.     (if vm-included-text-attribution-format
  145.     (insert (vm-sprintf 'vm-included-text-attribution-format message)))
  146.     (let ((zmacs-regions nil))
  147.       (while (and (re-search-forward "^" nil t) (< (point) (mark)))
  148.     (replace-match vm-included-text-prefix t t)))))
  149.  
  150. (defun vm-yank-message-other-folder (folder &optional prefix-argument)
  151.   "Like vm-yank-message except the message is yanked from a folder other
  152. than the one that spawned the current Mail mode buffer.  The name of the
  153. folder is read from the minibuffer.
  154.  
  155. Don't call this function from a program."
  156.   (interactive
  157.    (list
  158.     (let ((dir (if vm-folder-directory
  159.             (expand-file-name vm-folder-directory)
  160.           default-directory)))
  161.       (read-file-name "Yank from folder: " dir nil t))
  162.     current-prefix-arg ))
  163.   (let ((b (current-buffer)) newbuf sumbuf)
  164.     (set-buffer (or (get-file-buffer folder) (find-file-noselect folder)))
  165.     (setq newbuf (current-buffer))
  166.     (if (not (eq major-mode 'vm-mode))
  167.     (vm-mode))
  168.     (if (null vm-message-pointer)
  169.     (error "No messages in folder %s" folder))
  170.     (save-excursion
  171.       (save-window-excursion
  172.     (save-window-excursion
  173.       (vm-summarize))
  174.     (switch-to-buffer vm-summary-buffer)
  175.     (setq sumbuf (current-buffer))
  176.     (delete-other-windows)
  177.     (set-buffer b)
  178.     (unwind-protect
  179.         (let ((prefix-arg prefix-argument)
  180.           (vm-mail-buffer newbuf))
  181.           (command-execute 'vm-yank-message))
  182.       (bury-buffer newbuf)
  183.       (bury-buffer sumbuf))))))
  184.  
  185. (defun vm-yank-message (message &optional prefix)
  186.   "Yank message number N into the current buffer at point.
  187. When called interactively N is always read from the minibuffer.  When
  188. called non-interactively the first argument is expected to be a message
  189. struct.
  190.  
  191. This command is meant to be used in VM created Mail mode buffers; the
  192. yanked message comes from the mail buffer containing the message you
  193. are replying to, forwarding, or invoked VM's mail command from.
  194.  
  195. All message headers are yanked along with the text.  Point is left
  196. before the inserted text, the mark after.  Any hook functions bound to
  197. mail-yank-hooks are run, aftert inserting the text and setting point
  198. and mark.
  199.  
  200. Prefix arg means to ignore mail-yank-hooks, don't set the mark, prepend the
  201. value of vm-included-text-prefix to every yanked line, and don't yank any
  202. headers other than those specified in vm-visible-headers/vm-invisible-headers."
  203.   (interactive
  204.    (list
  205.    ;; What we really want for the first argument is a message struct,
  206.    ;; but if called interactively, we let the user type in a message
  207.    ;; number instead.
  208.     (let (mp default (result 0) prompt)
  209.       (save-excursion
  210.     (vm-select-folder-buffer)
  211.     (setq default (and vm-message-pointer
  212.                (vm-number-of (car vm-message-pointer)))
  213.           prompt (if default
  214.              (format "Yank message number: (default %s) "
  215.                  default)
  216.                "Yank message number: "))
  217.     (while (zerop result)
  218.       (setq result (read-string prompt))
  219.       (and (string= result "") default (setq result default))
  220.       (setq result (string-to-int result)))
  221.     (if (null (setq mp (nthcdr (1- result) vm-message-list)))
  222.         (error "No such message.")))
  223.       (car mp))
  224.     current-prefix-arg ))
  225.   (if (not (bufferp vm-mail-buffer))
  226.       (error "This is not a VM Mail mode buffer."))
  227.   (if (null (buffer-name vm-mail-buffer))
  228.       (error "The mail buffer containing message %d has been killed."
  229.          (vm-number-of message)))
  230.   (let ((b (current-buffer)) (start (point)) mp end)
  231.     (save-restriction
  232.       (widen)
  233.       (save-excursion
  234.     (set-buffer (marker-buffer (vm-start-of message)))
  235.     (save-restriction
  236.       (widen)
  237.       (append-to-buffer b (if prefix
  238.                   (vm-vheaders-of message)
  239.                 (vm-start-of message))
  240.                 (vm-text-end-of message))
  241.       (setq end (vm-marker (+ start (- (vm-text-end-of message)
  242.                        (if prefix
  243.                            (vm-vheaders-of message)
  244.                          (vm-start-of message)))) b))))
  245.       (if prefix
  246.       (save-excursion
  247.         (while (and (< (point) end) (re-search-forward "^" end t))
  248.           (replace-match vm-included-text-prefix t t)
  249.           (forward-line)))
  250.     ;; Delete UNIX From or MMDF ^A^A^A^A line
  251.     (delete-region (point) (progn (forward-line) (point)))
  252.     (push-mark end)
  253.     (if mail-yank-hooks
  254.         (run-hooks 'mail-yank-hooks)
  255.       (vm-mail-yank-default message))))))
  256.  
  257. (defun vm-mail-send-and-exit (arg)
  258.   "Just like mail-send-and-exit except that VM flags the appropriate message(s)
  259. as having been replied to, if appropriate."
  260.   (interactive "P")
  261.   (let ((reply-buf (current-buffer)))
  262.     (mail-send-and-exit arg)
  263.     (save-excursion
  264.       (set-buffer reply-buf)
  265.       (cond ((eq vm-system-state 'replying)
  266.          (vm-mark-replied))
  267.         ((eq vm-system-state 'forwarding)
  268.          (vm-mark-forwarded)))
  269.       (vm-rename-current-mail-buffer)
  270.       ;; keep this buffer if the user demands it
  271.       (if (memq (current-buffer) vm-kept-mail-buffers)
  272.       (setq vm-kept-mail-buffers
  273.         (delq (current-buffer) vm-kept-mail-buffers)))
  274.       (setq vm-kept-mail-buffers (cons (current-buffer) vm-kept-mail-buffers))
  275.       (if (not (eq vm-keep-sent-messages t))
  276.       (let ((extras (nthcdr (or vm-keep-sent-messages 0) vm-kept-mail-buffers)))
  277.         (mapcar (function (lambda (b) (and (buffer-name b) (kill-buffer b)))) extras)
  278.         (and vm-kept-mail-buffers extras
  279.          (setcdr (memq (car extras) vm-kept-mail-buffers) nil)))))))
  280.  
  281. (defun vm-mail-send ()
  282.   "Just like mail-send except that VM flags the appropriate message(s)
  283. as having been replied to, if appropriate."
  284.   (interactive)
  285.   (mail-send)
  286.   (vm-rename-current-mail-buffer)
  287.   (cond ((eq vm-system-state 'replying)
  288.      (vm-mark-replied))
  289.     ((eq vm-system-state 'forwarding)
  290.      (vm-mark-forwarded))))
  291.  
  292. (defun vm-rename-current-mail-buffer ()
  293.   (if (not (string-match "^sent " (buffer-name)))
  294.       (let (prefix name n)
  295.     (if (not (= ?* (aref (buffer-name) 0)))
  296.         (setq prefix (format "sent %s" (buffer-name)))
  297.       (let (recipients)
  298.         (cond ((not (zerop (length (setq recipients (mail-fetch-field "To"))))))
  299.           ((not (zerop (length (setq recipients (mail-fetch-field "Cc"))))))
  300.           (t (setq recipients "the horse with no name")))
  301.         (setq prefix (format "sent mail to %s" recipients))))
  302.     (setq name prefix n 1)
  303.     (while (get-buffer name)
  304.       (setq name (format "%s<%d>" prefix n))
  305.       (vm-increment n))
  306.     (rename-buffer name))))
  307.  
  308. (defun vm-mark-replied ()
  309.   (save-excursion
  310.     (let ((mp vm-reply-list))
  311.       (while mp
  312.     (if (null (marker-buffer (vm-start-of (car mp))))
  313.         ()
  314.       (set-buffer (marker-buffer (vm-start-of (car mp))))
  315.       (cond ((and (memq (car mp) vm-message-list)
  316.               (null (vm-replied-flag (car mp))))
  317.          (vm-set-replied-flag (car mp) t))))
  318.     (setq mp (cdr mp)))
  319.       (vm-update-summary-and-mode-line))))
  320.  
  321. (defun vm-mark-forwarded ()
  322.   (save-excursion
  323.     (let ((mp vm-forward-list))
  324.       (while mp
  325.     (if (null (marker-buffer (vm-start-of (car mp))))
  326.         ()
  327.       (set-buffer (marker-buffer (vm-start-of (car mp))))
  328.       (cond ((and (memq (car mp) vm-message-list)
  329.               (null (vm-forwarded-flag (car mp))))
  330.          (vm-set-forwarded-flag (car mp) t))))
  331.     (setq mp (cdr mp)))
  332.       (vm-update-summary-and-mode-line))))
  333.  
  334. (defun vm-reply (count)
  335.   "Reply to the sender of the current message.
  336. Numeric prefix argument N mans to reply to the current message plus the
  337. next N-1 messages.  A negative N means reply to the current message and
  338. the previous N-1 messages. 
  339.  
  340. If invoked on marked messages (via vm-next-command-uses-marks),
  341. all marked messages will be replied to.
  342.  
  343. You will be placed into a standard Emacs Mail mode buffer to compose and
  344. send your message.  See the documentation for the function `mail' for
  345. more info.
  346.  
  347. Note that the normal binding of C-c C-y in the reply buffer is
  348. automatically changed to vm-yank-message during a reply.  This
  349. allows you to yank any message from the current folder into a
  350. reply.
  351.  
  352. Normal VM commands may be accessed in the reply buffer by prefixing them
  353. with C-c C-v."
  354.   (interactive "p")
  355.   (vm-follow-summary-cursor)
  356.   (vm-select-folder-buffer)
  357.   (vm-check-for-killed-summary)
  358.   (vm-error-if-folder-empty)
  359.   (vm-do-reply nil nil count))
  360.  
  361. (defun vm-reply-include-text (count)
  362.   "Reply to the sender (only) of the current message and include text
  363. from the message.  See the documentation for function vm-reply for details."
  364.   (interactive "p")
  365.   (vm-follow-summary-cursor)
  366.   (vm-select-folder-buffer)
  367.   (vm-check-for-killed-summary)
  368.   (vm-error-if-folder-empty)
  369.   (vm-do-reply nil t count))
  370.  
  371. (defun vm-followup (count)
  372.   "Reply to all recipients of the current message.
  373. See the documentation for the function vm-reply for details."
  374.   (interactive "p")
  375.   (vm-follow-summary-cursor)
  376.   (vm-select-folder-buffer)
  377.   (vm-check-for-killed-summary)
  378.   (vm-error-if-folder-empty)
  379.   (vm-do-reply t nil count))
  380.  
  381. (defun vm-followup-include-text (count)
  382.   "Reply to all recipients of the current message and include text from
  383. the message.  See the documentation for the function vm-reply for details."
  384.   (interactive "p")
  385.   (vm-follow-summary-cursor)
  386.   (vm-select-folder-buffer)
  387.   (vm-check-for-killed-summary)
  388.   (vm-error-if-folder-empty)
  389.   (vm-do-reply t t count))
  390.  
  391. (defun vm-forward-message ()
  392.   "Forward the current message to one or more third parties.
  393. You will be placed in a Mail mode buffer as is usual with replies, but you
  394. must fill in the To: and Subject: headers manually."
  395.   (interactive)
  396.   (vm-follow-summary-cursor)
  397.   (vm-select-folder-buffer)
  398.   (vm-check-for-killed-summary)
  399.   (vm-error-if-folder-empty)
  400.   (if (eq last-command 'vm-next-command-uses-marks)
  401.       (progn (setq this-command 'vm-next-command-uses-marks)
  402.          (command-execute 'vm-send-digest))
  403.     (let ((b (current-buffer))
  404.       (dir default-directory)
  405.       (mp vm-message-pointer)
  406.       start)
  407.       (save-restriction
  408.     (widen)
  409.     (vm-mail-internal
  410.      (format "forward of %s:%s" (buffer-name)
  411.          (vm-number-of (car vm-message-pointer)))
  412.      nil
  413.      (and vm-forwarding-subject-format
  414.           (vm-sprintf 'vm-forwarding-subject-format
  415.               (car mp))))
  416.     (use-local-map (copy-keymap (current-local-map)))
  417.     (local-set-key "\C-c\C-y" 'vm-yank-message)
  418.     (local-set-key "\C-cy" 'vm-yank-message-other-folder)
  419.     (local-set-key "\C-c\C-s" 'vm-mail-send)
  420.     (local-set-key "\C-c\C-c" 'vm-mail-send-and-exit)
  421.     (local-set-key "\C-c\C-v" vm-mode-map)
  422.     (make-local-variable 'vm-forward-list)
  423.     (setq vm-mail-buffer b
  424.           vm-system-state 'forwarding
  425.           vm-forward-list (list (car mp))
  426.           vm-message-pointer mp
  427.           default-directory dir)
  428.     (goto-char (point-max))
  429.     (insert "------- Start of forwarded message -------\n")
  430.     (setq start (point))
  431.     (insert-buffer-substring b
  432.                  (save-excursion
  433.                    (set-buffer b)
  434.                    (goto-char (vm-start-of (car mp)))
  435.                    (forward-line 1)
  436.                    (point))
  437.                  (vm-text-end-of (car mp)))
  438.     (if vm-rfc934-forwarding
  439.         (vm-rfc934-char-stuff-region start (point)))
  440.     (insert "------- End of forwarded message -------\n")
  441.     (goto-char (point-min))
  442.     (end-of-line)))))
  443.  
  444. (defun vm-mail ()
  445.   "Send a mail message from within VM, or from without."
  446.   (interactive)
  447.   (vm-session-initialization)
  448.   (vm-follow-summary-cursor)
  449.   (vm-select-folder-buffer)
  450.   (vm-check-for-killed-summary)
  451.   (let ((mail-buffer (if (memq major-mode '(vm-mode vm-virtual-mode))
  452.              (current-buffer))))
  453.     (vm-mail-internal)
  454.     (if (null mail-buffer)
  455.     ()
  456.       (use-local-map (copy-keymap (current-local-map)))
  457.       (local-set-key "\C-c\C-y" 'vm-yank-message)
  458.       (local-set-key "\C-c\C-v" vm-mode-map)
  459.       (setq vm-mail-buffer mail-buffer))
  460.     (local-set-key "\C-c\C-s" 'vm-mail-send)
  461.     (local-set-key "\C-c\C-c" 'vm-mail-send-and-exit)
  462.     (local-set-key "\C-cy" 'vm-yank-message-other-folder)))
  463.  
  464. (defun vm-resend-bounced-message ()
  465.   "Extract the original text from a bounced message and resend it.
  466. You will be placed in a Mail mode buffer with the extracted message and
  467. you can change the recipient address before resending the message."
  468.   (interactive)
  469.   (vm-follow-summary-cursor)
  470.   (vm-select-folder-buffer)
  471.   (vm-check-for-killed-summary)
  472.   (let ((b (current-buffer)) start
  473.     (dir default-directory)
  474.     (lim (vm-text-end-of (car vm-message-pointer))))
  475.       (save-restriction
  476.     (widen)
  477.     (save-excursion
  478.       (goto-char (vm-text-of (car vm-message-pointer)))
  479.       (let (case-fold-search)
  480.         ;; What a wonderful world it would be if mailers used the
  481.         ;; message encapsulation standard instead the following
  482.         ;; ad hockeries.
  483.         (or
  484.          ;; sendmail
  485.          (search-forward "----- Unsent message follows" lim t)
  486.          ;; smail 2.x
  487.          (search-forward "======= text of message follows" lim t)
  488.          ;; smail 3.x (?)
  489.          (search-forward "- Message text follows:" lim t)
  490.          ;; MMDF
  491.          (search-forward "Your message follows:\n" lim t)
  492.           (search-forward "    Your message begins as follows:\n" lim t)
  493.          ;; zmailer (?)
  494.          (search-forward "---  Original Message  ---" lim t)
  495.          ;; Grapevine
  496.          (search-forward "The text of your message was\n---" lim t)
  497.          (error "This does not appear to be a bounced message."))
  498.         (forward-line 1)
  499.         (setq start (point))))
  500.     (vm-mail-internal
  501.      (format "retry of %s:%s" (buffer-name)
  502.          (vm-number-of (car vm-message-pointer))))
  503.     (use-local-map (copy-keymap (current-local-map)))
  504.     (local-set-key "\C-c\C-y" 'vm-yank-message)
  505.     (local-set-key "\C-cy" 'vm-yank-message-other-folder)
  506.     (local-set-key "\C-c\C-s" 'vm-mail-send)
  507.     (local-set-key "\C-c\C-c" 'vm-mail-send-and-exit)
  508.     (local-set-key "\C-c\C-v" vm-mode-map)
  509.     (goto-char (point-min))
  510.     (insert-buffer-substring b start lim)
  511.     (delete-region (point) (point-max))
  512.     (goto-char (point-min))
  513.     ;; some mailers leave grot at the top of the message.
  514.     ;; trim it.
  515.     (while (not (looking-at vm-generic-header-regexp))
  516.       (delete-region (point) (progn (forward-line 1) (point))))
  517.     ;; delete all but pertinent headers
  518.     (while (looking-at vm-generic-header-regexp)
  519.       (let ((match-end-0 (match-end 0)))
  520.         (if (or
  521.          (looking-at "From:\\|To:\\|Cc:\\|Subject:\\|In-Reply-To\\|Resent-")
  522.          (looking-at "Newsgroups\\|References"))
  523.         (goto-char match-end-0)
  524.           (delete-region (point) match-end-0))))
  525.     (insert mail-header-separator)
  526.     (if (= (following-char) ?\n)
  527.         (forward-char 1)
  528.       (insert "\n"))
  529.     (setq vm-mail-buffer b
  530.           default-directory dir))))
  531.  
  532. (defun vm-resend-message (recipients)
  533.   "Resend the current message to someone else.
  534. You will be proompted in the minibuffer for the space or comma
  535. separated recipient list."
  536.   (interactive "sResend message to: ")
  537.   (vm-follow-summary-cursor)
  538.   (vm-select-folder-buffer)
  539.   (vm-check-for-killed-summary)
  540.   (vm-error-if-folder-empty)
  541.   (let ((vmp vm-message-pointer)
  542.     recipient-list t-buffer m-buffer
  543.     doomed-buffers
  544.     (pop-up-windows (and pop-up-windows (eq vm-mutable-windows t)))
  545.     (mail-header-seaprator ""))
  546.     (setq recipient-list (vm-parse recipients "[ \t,]*\\([^ ,\t]+\\)[ \t,]*"))
  547.     (unwind-protect
  548.     (progn
  549.       (vm-within-current-message-buffer
  550.        (vm-save-restriction
  551.         (widen)
  552.         (save-excursion
  553.           (setq m-buffer (generate-new-buffer "*VM resend*"))
  554.           (set-buffer m-buffer)
  555.           (make-local-variable 'vm-forward-list)
  556.           (setq vm-system-state 'forwarding
  557.             vm-forward-list (list (car vmp)))
  558.           (erase-buffer)
  559.           (insert-buffer-substring
  560.            (marker-buffer (vm-start-of (car vmp)))
  561.            (vm-start-of (car vmp))
  562.            (vm-text-end-of (car vmp))))))
  563.       (set-buffer m-buffer)
  564.       (goto-char (point-min))
  565.       ;; some mailers leave grot at the top of the message.
  566.       ;; trim it.
  567.       (while (not (looking-at vm-generic-header-regexp))
  568.         (delete-region (point) (progn (forward-line 1) (point))))
  569.       ;; indicate that this is a resend.  this should be all
  570.       ;; that's needed, as sendmail will generate the rest.
  571.       ;; But generate a Resent-From is the user is picky
  572.       ;; about the From header.
  573.       (if vm-mail-header-from
  574.           (insert "Resent-From: " vm-mail-header-from "\n"))
  575.       (insert "Resent-To: " (mapconcat 'identity recipient-list ", ") "\n")
  576.       ;; delete all but pertinent headers
  577.       (while (looking-at vm-generic-header-regexp)
  578.         (let ((match-end-0 (match-end 0)))
  579.           (if (not (looking-at "X-VM-\\|Status:"))
  580.           (goto-char match-end-0)
  581.         (delete-region (point) match-end-0))))
  582.       (setq t-buffer
  583.         (generate-new-buffer
  584.          (format "transcript of resend to %s" recipients)))
  585.       (goto-char (point-min))
  586.       (message "Sending...")
  587.       (apply 'call-process-region
  588.          (nconc (list (point-min) (point-max)
  589.                   sendmail-program
  590.                   nil t-buffer mail-interactive
  591.                   "-oi" "-oem")
  592.             (if mail-interactive
  593.                 (list "-v")
  594.               (list "-odb"))
  595.             recipient-list))
  596.       (vm-mark-forwarded)
  597.       (set-buffer t-buffer)
  598.       (if (zerop (buffer-size))
  599.           (message "Sent.")
  600.         (display-buffer t-buffer)
  601.         (bury-buffer t-buffer)
  602.         (setq t-buffer nil)
  603.         (message "")))
  604.       (and t-buffer (kill-buffer t-buffer))
  605.       (and m-buffer (kill-buffer m-buffer)))))
  606.  
  607. (defun vm-send-digest (&optional prefix)
  608.   "Send a digest of all messages in the current folder to recipients.
  609. You will be placed in a *mail* buffer as is usual with replies, but you
  610. must fill in the To: and Subject: headers manually.
  611.  
  612. Prefix arg means to insert a list of preamble lines at the beginning of
  613. the digest.  One line is generated for each message being digestified.
  614. The variable vm-digest-preamble-format determines the format of the
  615. preamble lines.
  616.  
  617. If invoked on marked messages (via vm-next-command-uses-marks),
  618. only marked messages will be put into the digest."
  619.   (interactive "P")
  620.   (vm-select-folder-buffer)
  621.   (vm-check-for-killed-summary)
  622.   (vm-error-if-folder-empty)
  623.   (let ((b (current-buffer))
  624.     (dir default-directory)
  625.     (mp vm-message-pointer)
  626.     ;; prefix arg doesn't have "normal" meaning here, so only call
  627.     ;; vm-select-marked-or-prefixed-messages if we're using marks.
  628.     (mlist (if (eq last-command 'vm-next-command-uses-marks)
  629.            (vm-select-marked-or-prefixed-messages 0)
  630.          vm-message-list))
  631.     start)
  632.     (save-restriction
  633.       (widen)
  634.       (vm-mail-internal (format "digest from %s" (buffer-name)))
  635.       (use-local-map (copy-keymap (current-local-map)))
  636.       (local-set-key "\C-c\C-y" 'vm-yank-message)
  637.       (local-set-key "\C-cy" 'vm-yank-message-other-folder)
  638.       (local-set-key "\C-c\C-s" 'vm-mail-send)
  639.       (local-set-key "\C-c\C-c" 'vm-mail-send-and-exit)
  640.       (local-set-key "\C-c\C-v" vm-mode-map)
  641.       (make-local-variable 'vm-forward-list)
  642.       (setq vm-mail-buffer b
  643.         vm-message-pointer mp
  644.         vm-system-state 'forwarding
  645.         vm-forward-list mlist
  646.         default-directory dir)
  647.       (goto-char (point-max))
  648.       (setq start (point)
  649.         mp mlist)
  650.       (message "Building digest...")
  651.       (while mp
  652.     (insert-buffer-substring (marker-buffer (vm-start-of (car mp)))
  653.                  (vm-start-of (car mp))
  654.                  (vm-end-of (car mp)))
  655.     (setq mp (cdr mp)))
  656.       (vm-digestify-region start (point))
  657.       (goto-char start)
  658.       (setq mp mlist)
  659.       (if prefix
  660.       (progn
  661.         (message "Building digest preamble...")
  662.         (while mp
  663.           (insert (vm-sprintf 'vm-digest-preamble-format (car mp)) "\n")
  664.           (if vm-digest-center-preamble
  665.           (progn
  666.             (forward-char -1)
  667.             (center-line)
  668.             (forward-char 1)))
  669.           (setq mp (cdr mp)))))
  670.       (goto-char (point-min))
  671.       (end-of-line)
  672.       (message "Building digest... done"))))
  673.  
  674. (defun vm-continue-composing-message (&optional not-picky)
  675.   "Find and select the most recently used mail composition buffer.
  676. If the selected buffer is already a Mail mode buffer then it is
  677. buried before beginning the search.  Non Mail mode buffers and
  678. unmodified Mail buffers are skipped.  Prefix arg means unmodified
  679. Mail mode buffers are not skipped.  If no suitable buffer is
  680. found, the current buffer remains selected."
  681.   (interactive "P")
  682.   (if (eq major-mode 'mail-mode)
  683.       (bury-buffer (current-buffer)))
  684.   (let ((b (vm-find-composition-buffer not-picky)))
  685.     (if (not (or (null b) (eq b (current-buffer))))
  686.     (switch-to-buffer b)
  687.       (message "No composition buffers found"))))
  688.  
  689. (defun vm-find-composition-buffer (&optional not-picky)
  690.   (let ((b-list (buffer-list)) choice alternate)
  691.     (save-excursion
  692.      (while b-list
  693.        (set-buffer (car b-list))
  694.        (if (eq major-mode 'mail-mode)
  695.        (if (buffer-modified-p)
  696.            (setq choice (current-buffer)
  697.              b-list nil)
  698.          (and not-picky (null alternate)
  699.           (setq alternate (current-buffer)))
  700.          (setq b-list (cdr b-list)))
  701.      (setq b-list (cdr b-list))))
  702.     (or choice alternate))))
  703.  
  704. (defun vm-mail-internal
  705.      (&optional buffer-name to subject in-reply-to cc references newsgroups)
  706.   (set-buffer (generate-new-buffer (or buffer-name "*VM-mail*")))
  707.   (auto-save-mode auto-save-default)
  708.   (mail-mode)
  709.   (switch-to-buffer (current-buffer))
  710.   (if (fboundp 'mail-aliases-setup)
  711.       (mail-aliases-setup)
  712.     (if (eq mail-aliases t)
  713.     (progn
  714.       (setq mail-aliases nil)
  715.       (if (file-exists-p "~/.mailrc")
  716.           (build-mail-aliases)))))
  717.   (if (stringp vm-mail-header-from)
  718.       (insert "From: " vm-mail-header-from "\n"))
  719.   (insert "To: " (or to "") "\n")
  720.   (and cc (insert "Cc: " cc "\n"))
  721.   (insert "Subject: " (or subject "") "\n")
  722.   (and newsgroups (insert "Newsgroups: " newsgroups "\n"))
  723.   (and in-reply-to (insert "In-Reply-To: " in-reply-to "\n"))
  724.   (and references (insert "References: " references "\n"))
  725.   (if mail-default-reply-to
  726.       (insert "Reply-To: " mail-default-reply-to "\n"))
  727.   (if mail-self-blind
  728.       (insert "Bcc: " (user-login-name) "\n"))
  729.   (if mail-archive-file-name
  730.       (insert "FCC: " mail-archive-file-name "\n"))
  731.   (insert mail-header-separator "\n")
  732.   (save-excursion (vm-set-window-configuration 'composing-message))
  733.   (if to
  734.       (goto-char (point-max))
  735.     (mail-position-on-field "To"))
  736.   (run-hooks 'mail-setup-hook))
  737.  
  738. (require 'mail-utils)
  739. (require 'sendmail)
  740.