home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / languages / elisp / packages / vm / vm-reply.el < prev    next >
Encoding:
Text File  |  1989-09-11  |  9.4 KB  |  271 lines
  1. ;;; Mailing, forwarding, and replying commands for VM
  2. ;;; Copyright (C) 1989 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. (require 'vm)
  19.  
  20. (defun vm-do-reply (to-all include-text)
  21.   (vm-follow-summary-cursor)
  22.   (if vm-mail-buffer
  23.       (set-buffer vm-mail-buffer))
  24.   (vm-error-if-folder-empty)
  25.   (save-restriction
  26.     (widen)
  27.     (let ((mail-buffer (current-buffer))
  28.       (text-start (vm-text-of (car vm-message-pointer)))
  29.       (text-end (vm-text-end-of (car vm-message-pointer)))
  30.       (mp vm-message-pointer)
  31.       to cc subject message-id tmp)
  32.       (cond ((setq to (vm-get-header-contents (car mp) "Reply-To")))
  33.         ((setq to (vm-get-header-contents (car mp) "From")))
  34.         ((setq to (vm-grok-From_-author (car mp))))
  35.         (t (error "Cannot find a From: or Reply-To: header in message")))
  36.       (setq subject (vm-get-header-contents (car mp) "Subject")
  37.         message-id (and vm-in-reply-to-format
  38.                 (vm-sprintf 'vm-in-reply-to-format (car mp))))
  39.       (if to-all
  40.       (progn
  41.         (setq cc (vm-get-header-contents (car mp) "To"))
  42.         (setq tmp (vm-get-header-contents (car mp) "Cc"))
  43.         (if tmp
  44.         (if cc
  45.             (setq cc (concat cc ",\n\t" tmp))
  46.           (setq cc tmp)))))
  47.       (if vm-strip-reply-headers
  48.       (let ((mail-use-rfc822 t))
  49.         (require 'mail-utils)
  50.         (and to (setq to (mail-strip-quoted-names to)))
  51.         (and cc (setq cc (mail-strip-quoted-names cc)))))
  52.       (if (mail nil to subject message-id cc)
  53.       (progn
  54.         (use-local-map (copy-keymap (current-local-map)))
  55.         (local-set-key "\C-c\C-y" 'vm-yank-message)
  56.         (local-set-key "\C-c\C-s" 'vm-mail-send)
  57.         (local-set-key "\C-c\C-c" 'vm-mail-send-and-exit)
  58.         (local-set-key "\C-c\C-v" vm-mode-map)
  59.         (setq vm-mail-buffer mail-buffer
  60.           vm-message-pointer mp)
  61.         (cond (include-text
  62.            (goto-char (point-max))
  63.            (insert-buffer-substring mail-buffer text-start text-end)
  64.            (goto-char (- (point) (- text-end text-start)))
  65.            (save-excursion
  66.              (if vm-included-text-attribution-format
  67.              (insert (vm-sprintf
  68.                   'vm-included-text-attribution-format
  69.                   (car mp))))
  70.              (while (and (re-search-forward "^" nil t) (not (eobp)))
  71.                (replace-match vm-included-text-prefix t t))))))))))
  72.  
  73. (defun vm-yank-message (n prefix)
  74.   "Yank message number N into the current buffer at point.
  75.  
  76. This command is meant to be used in VM created *mail* buffers; the
  77. yanked message comes from the mail buffer containing the message you
  78. are replying to, forwarding, or invoked VM's mail command from.
  79.  
  80. All message headers are yanked along with the text.  Point is left
  81. before the inserted text, the mark after.  Any hook functions bound to
  82. mail-yank-hooks are run, aftert inserting the text and setting point
  83. and mark.
  84.  
  85. Prefix arg means to ignore mail-yank-hooks, don't set the mark, prepend the
  86. value of vm-included-text-prefix to every yanked line, and don't yank any
  87. headers other than those specified in vm-visible-headers."
  88.   (interactive
  89.    (list
  90.     (let (default (result 0) prompt)
  91.       (save-excursion
  92.     (if (and vm-mail-buffer (buffer-name vm-mail-buffer))
  93.         (set-buffer vm-mail-buffer))
  94.     (setq default (and vm-message-pointer
  95.                (vm-number-of (car vm-message-pointer)))
  96.           prompt (if default
  97.              (format "Yank message number: (default %s) "
  98.                  default)
  99.                "Yank message number: "))
  100.     (while (zerop result)
  101.       (setq result (read-string prompt))
  102.       (and (string= result "") default (setq result default))
  103.       (setq result (string-to-int result))))
  104.       result )
  105.     current-prefix-arg ))
  106.   (if (not (bufferp vm-mail-buffer))
  107.       (error "This is not a VM *mail* buffer."))
  108.   (if (null (buffer-name vm-mail-buffer))
  109.       (error "The mail buffer containing message %d has been killed." n))
  110.   (let ((b (current-buffer)) (start (point)) mp end)
  111.     (save-restriction
  112.       (widen)
  113.       (save-excursion
  114.     (set-buffer vm-mail-buffer)
  115.     (setq mp (nthcdr (1- n) vm-message-list))
  116.     (if (null mp)
  117.         (error "No such message."))
  118.     (save-restriction
  119.       (widen)
  120.       (append-to-buffer b (if prefix
  121.                   (vm-vheaders-of (car mp))
  122.                 (vm-start-of (car mp)))
  123.                 (vm-text-end-of (car mp)))
  124.       (setq end (vm-marker (+ start (- (vm-text-end-of (car mp))
  125.                        (if prefix
  126.                            (vm-vheaders-of (car mp))
  127.                          (vm-start-of (car mp))))) b))))
  128.       (if prefix
  129.       (save-excursion
  130.         (while (and (< (point) end) (re-search-forward "^" end t))
  131.           (replace-match vm-included-text-prefix t t)
  132.           (forward-line)))
  133.     ;; Delete UNIX From or MMDF ^A^A^A^A line
  134.     (delete-region (point) (progn (forward-line) (point)))
  135.     (push-mark end)
  136.     (run-hooks 'mail-yank-hooks)))))
  137.  
  138. (defun vm-mail-send-and-exit (arg)
  139.   "Just like mail-send-and-exit except that VM marks the appropriate message
  140. as having been replied to, if appropriate."
  141.   (interactive "P")
  142.   (let ((reply-buf (current-buffer)))
  143.     (mail-send-and-exit arg)
  144.     (save-excursion
  145.       (set-buffer reply-buf)
  146.       (vm-mark-replied))))
  147.  
  148. (defun vm-mail-send ()
  149.   "Just like mail-send except that VM marks the appropriate message
  150. as having been replied to, if appropriate."
  151.   (interactive)
  152.   (mail-send)
  153.   (vm-mark-replied))
  154.  
  155. (defun vm-mark-replied ()
  156.   (if (and (bufferp vm-mail-buffer) (buffer-name vm-mail-buffer))
  157.       (save-excursion
  158.     (let ((mp vm-message-pointer))
  159.       (set-buffer vm-mail-buffer)
  160.       (cond ((and (memq (car mp) vm-message-list)
  161.               (null (vm-replied-flag (car mp))))
  162.          (vm-set-replied-flag (car mp) t)
  163.          (vm-update-summary-and-mode-line)))))))
  164.  
  165. (defun vm-reply ()
  166.   "Reply to the sender of the current message.
  167. You will be deposited into a standard Emacs *mail* buffer to compose and
  168. send your message.  See the documentation for the function `mail' for
  169. more info.
  170.  
  171. Note that the normal binding of C-c C-y in the *mail* buffer is
  172. automatically changed to vm-yank-message during a reply.  This allows
  173. you to yank any message from the current folder into a reply.
  174.  
  175. Normal VM commands may be accessed in the reply buffer by prefixing them
  176. with C-c C-v."
  177.   (interactive)
  178.   (vm-do-reply nil nil))
  179.  
  180. (defun vm-reply-include-text ()
  181.   "Reply to the sender (only) of the current message and include text
  182. from the message.  See the documentation for function vm-reply for details."
  183.   (interactive)
  184.   (vm-do-reply nil t))
  185.  
  186. (defun vm-followup ()
  187.   "Reply to all recipients of the current message.
  188. See the documentation for the function vm-reply for details."
  189.   (interactive)
  190.   (vm-do-reply t nil))
  191.  
  192. (defun vm-followup-include-text ()
  193.   "Reply to all recipients of the current message and include text from
  194. the message.  See the documentation for the function vm-reply for details."
  195.   (interactive)
  196.   (vm-do-reply t t))
  197.  
  198. (defun vm-forward-message ()
  199.   "Forward the current message to one or more third parties.
  200. You will be placed in a *mail* buffer as is usual with replies, but you
  201. must fill in the To: and Subject: headers manually." 
  202.   (interactive)
  203.   (vm-follow-summary-cursor)
  204.   (if vm-mail-buffer
  205.       (set-buffer vm-mail-buffer))
  206.   (vm-error-if-folder-empty)
  207.   (let ((b (current-buffer))
  208.     (m (car vm-message-pointer))
  209.     (start))
  210.     (save-restriction
  211.       (widen)
  212.       (cond ((mail nil nil (and vm-forwarding-subject-format
  213.                 (vm-sprintf 'vm-forwarding-subject-format m)))
  214.          (use-local-map (copy-keymap (current-local-map)))
  215.          (local-set-key "\C-c\C-y" 'vm-yank-message)
  216.          (local-set-key "\C-c\C-v" vm-mode-map)
  217.          (setq vm-mail-buffer b)
  218.          (goto-char (point-max))
  219.          (insert "------- Start of forwarded message -------\n")
  220.          (setq start (point))
  221.          (insert-buffer-substring b
  222.                       (save-excursion
  223.                     (set-buffer b)
  224.                     (goto-char (vm-start-of m))
  225.                     (forward-line 1)
  226.                     (point))
  227.                       (vm-text-end-of m))
  228.          (if vm-rfc934-forwarding
  229.          (vm-rfc934-char-stuff-region start (point)))
  230.          (insert "------- End of forwarded message -------\n")
  231.          (goto-char (point-min))
  232.          (end-of-line))))))
  233.  
  234. (defun vm-mail ()
  235.   "Send a mail message from within VM."
  236.   (interactive)
  237.   (vm-follow-summary-cursor)
  238.   (if vm-mail-buffer
  239.       (set-buffer vm-mail-buffer))
  240.   (let ((mail-buffer (current-buffer)))
  241.     (cond ((mail)
  242.        (use-local-map (copy-keymap (current-local-map)))
  243.        (local-set-key "\C-c\C-y" 'vm-yank-message)
  244.        (local-set-key "\C-c\C-v" vm-mode-map)
  245.        (setq vm-mail-buffer mail-buffer)))))
  246.  
  247. (defun vm-send-digest ()
  248.   "Send a digest of all messages in the current folder to recipients.
  249. You will be placed in a *mail* buffer as is usual with replies, but you
  250. must fill in the To: and Subject: headers manually." 
  251.   (interactive)
  252.   (if vm-mail-buffer
  253.       (set-buffer vm-mail-buffer))
  254.   (vm-error-if-folder-empty)
  255.   (let ((b (current-buffer))
  256.     (start))
  257.     (save-restriction
  258.       (widen)
  259.       (cond
  260.        ((mail)
  261.     (use-local-map (copy-keymap (current-local-map)))
  262.     (local-set-key "\C-c\C-y" 'vm-yank-message)
  263.     (local-set-key "\C-c\C-v" vm-mode-map)
  264.     (setq vm-mail-buffer b)
  265.     (goto-char (point-max))
  266.     (setq start (point))
  267.     (insert-buffer-substring b)
  268.     (vm-digestify-region start (point))
  269.     (goto-char (point-min))
  270.     (end-of-line))))))
  271.