🚀 go-pugleaf

I've been doing some hacking on my VM environment lately; here's the result.

When replying to a message, the screen is made to contain exactly two windows:
one displaying the message being replied to, and the other in which the
message is being composed.  If the message being replied to has been
automatically yanked in (via vm-reply-include-text) then there is only one
window.

After sending a message, if that message is a reply, then there is made to be
exactly one window, displaying the folder which contains the replied-to
message.  If that folder has a summary buffer, then the summary buffer is
displayed as well.

You won't like this if you ever use VM such that it doesn't take over the
whole emacs screen, but I never do.

I've also haired up my mail-yank-hook a bit:

  - included text is prefixed with "> ", except when the included text itself
    is already so prefixed, in which case it's prefixed with ">" instead (so
    that you get lines beginning with text like ">>> " instead of "> > > ".)

  - if, as a result of adding the quote-prefix to each line, any lines get to
    be too long (that is, longer than the fill-column) then (and only then)
    the paragraph that the line is in will be re-filled.  Since this filling
    happens only when necessary, it shouldn't generally mess up the
    indentation of quoted code or diagrams.  The determination of what is a
    paragraph boundary is clever: if one line begins with ">> " and the next
    line begins with ">>> ", there is considered to be a paragraph boundary
    between them.

  - this one's kind of gratuitous, but I like it: if you're replying to a
    message that contains a uuencoded file, most of the body of that file
    will be automatically deleted from the yanked text.  (Since you were no
    doubt going to do that anyway.)

A lot of folks seem to be using my vm-hacks file, so here's the whole thing.
Enjoy...

	-- Jamie

---------- slice 'n' dice ---------------------------------- file: vm-hacks.el
;;; -*- Mode:Emacs-Lisp -*-

;;; VM hacks by jwz.  Improves date-parsing, real-name parsing, makes
;;; vm-forward-message only forward the headers that are visible, makes
;;; yanked message be formatted more nicely, makes replying to messages
;;; frob the window configuration.
;;; last modified: 29-dec-91.

(require 'vm)

(if (not (fboundp 'vm-su-do-date)) (load-library "vm-summary"))

(defun vm-su-do-date (m)
  (let (date
	(case-fold-search t))
    (setq date (or (vm-get-header-contents m "Date") (vm-grok-From_-date m)))
    (cond
     ((null date)
      (vm-set-weekday-of m "")
      (vm-set-monthday-of m "")
      (vm-set-month-of m "")
      (vm-set-month-number-of m "")
      (vm-set-year-of m "")
      (vm-set-hour-of m "")
      (vm-set-zone-of m "")
      nil)
     ((string-match
;; The date format recognized here is the one specified in RFC 822.
;; Some slop is allowed e.g. dashes between the monthday, month and year
;; because such malformed headers have been observed.
;; jwz: added some more slop - dashes between time and zone.
;; Also allow DOTW to be at end, optionally in parens.
;;
;; Handles:
;;     Mon, 3 dec 90 15:25:36 PST
;;     Mon 3 dec 90 15:25:36 PST
;;     03-dec-90 15:25:36 PST
;;     Mon, 3 dec 90 15:25:36-PST
;;     3 Dec 90 15:25 PST (Mon)
"\\(\\([a-z][a-z][a-z]\\),?\\)?[ \t\n]*0?\\([0-9][0-9]?\\)[ \t\n---]*\\([a-z][a-z][a-z]\\)[ \t\n---]*\\([0-9]*[0-9][0-9]\\)[ \t\n]*\\([0-9:]+\\)[- \t\n]*\\([a-z][a-z]?[a-z]?\\|[---+][0-9][0-9][0-9][0-9]\\)[ \t\n]*(?\\([a-z][a-z][a-z]\\)?)?"
       date)
      (if (match-beginning 2)
	  (vm-set-weekday-of m (substring date (match-beginning 2)
					  (match-end 2)))
	  (if (match-beginning 8)
	      (vm-set-weekday-of m (substring date (match-beginning 8)
					      (match-end 8)))
	      (vm-set-weekday-of m "")))
      (vm-set-monthday-of m (substring date (match-beginning 3) (match-end 3)))
      (vm-su-do-month m (substring date (match-beginning 4) (match-end 4)))
      (vm-set-year-of m (substring date (match-beginning 5) (match-end 5)))
      (vm-set-hour-of m (substring date (match-beginning 6) (match-end 6)))
      (vm-set-zone-of m (substring date (match-beginning 7) (match-end 7)))
      t)
     ((string-match
;; UNIX ctime(3) format, with slop allowed in the whitespace, and we allow for
;; the possibility of a timezone at the end.
;; jwz: more slop - allow a comma after the weekday.
;; Handles:
;;     Tue Dec 11 00:13:13 1990
;;     Mon Sep  2 10:42:17 1991
;;     Tue, Dec 11 00:13:13 90 PST
 "\\([a-z][a-z][a-z]\\)[ \t\n,]+\\([a-z][a-z][a-z]\\)[ \t\n]+\\([0-9][0-9]?\\)[ \t\n]*\\([0-9:]+\\)[ \t\n]*[0-9][0-9]\\([0-9][0-9]\\)[ \t\n]*\\([a-z][a-z]?[a-z]?\\|[---+][0-9][0-9][0-9][0-9]\\)?"
       date)
      (vm-set-weekday-of m (substring date (match-beginning 1) (match-end 1)))
      (vm-su-do-month m (substring date (match-beginning 2) (match-end 2)))
      (vm-set-monthday-of m (substring date (match-beginning 3) (match-end 3)))
      (vm-set-hour-of m (substring date (match-beginning 4) (match-end 4)))
      (vm-set-year-of m (substring date (match-beginning 5) (match-end 5)))
      ;; jwz: don't allow nil in the zone slot.
      (vm-set-zone-of m (if (match-beginning 6)
			    (substring date (match-beginning 6)
				       (match-end 6))
			    ""))
      t)
     ((string-match
;; This piece of crap handles:
;;    Aug 29, 1991 08:51 EDT
;;    Aug 29 1991, 08:51-EDT
 "\\([a-z][a-z][a-z]\\)[ \t\n]+\\([0-9][0-9]?\\)[ \t\n,]*\\([0-9]?[0-9]?[0-9][0-9]\\)[- \t,]*\\([0-9:]+\\)[- \t]*\\([a-z][a-z][a-z]\\)?"
	date)
      (vm-su-do-month m (substring date (match-beginning 1) (match-end 1)))
      (vm-set-monthday-of m (substring date (match-beginning 2) (match-end 2)))
      (vm-set-year-of m (substring date (match-beginning 3) (match-end 3)))
      (vm-set-hour-of m (substring date (match-beginning 4) (match-end 4)))
      (vm-set-zone-of m (if (match-beginning 5)
			    (substring date (match-beginning 5)
				       (match-end 5))
			    ""))
      t)
     ((string-match
;; YASTF: Yet Another Sucky Time Format.  Dan Jacobson found this one.
;; Handles:
;;    Tue, Dec 11 12:11:45 CST 1990
;;    Tue Dec 11 12:11 CST 1990
"\\([a-z][a-z][a-z]\\)[ \t\n,]*\\([a-z][a-z][a-z]\\)[ \t\n]*\\([0-9][0-9]?\\)[ \t\n]*\\([0-9:]+\\)[ \t\n]*\\([a-z][a-z][a-z]\\|[-+]?[0-9][0-9][0-9][0-9]\\)[ \t\n]*\\([0-9]?[0-9]?[0-9][0-9]\\)?"
       date)
      (vm-set-weekday-of m (substring date (match-beginning 1) (match-end 1)))
      (vm-su-do-month m (substring date (match-beginning 2) (match-end 2)))
      (vm-set-monthday-of m (substring date (match-beginning 3) (match-end 3)))
      (vm-set-hour-of m (substring date (match-beginning 4) (match-end 4)))
      (vm-set-zone-of m (if (match-beginning 5)
			    (substring date (match-beginning 5)
				       (match-end 5))
			    ""))
      (vm-set-year-of m (if (match-beginning 6)
			    (substring date (match-beginning 6) (match-end 6))
			    ""))
      t)
     ((string-match
;; jwz: I've seen dates of the form "13-AUG-1990 16:11:21.26" from VMS.
	"\\([0-9]+\\)[- \t]*\\([A-Z][A-Z][A-Z]+\\)[- \t]*\\([0-9][0-9][0-9]?[0-9]?\\)[ \t]+\\([0-9:]+\\)\\(\\.[0-9]+\\)?"
	date)
      (vm-set-weekday-of m "")
      (vm-set-monthday-of m (substring date (match-beginning 1) (match-end 1)))
      (vm-su-do-month m (substring date (match-beginning 2) (match-end 2)))
      (vm-set-year-of m (substring date (match-beginning 3) (match-end 3)))
      (vm-set-hour-of m (substring date (match-beginning 4) (match-end 4)))
      (vm-set-zone-of m "")
      t)
     (t
      ;; otherwise, punt.
      (vm-set-weekday-of m "")
      (vm-set-monthday-of m "")
      (vm-set-month-of m "")
      (vm-set-month-number-of m "")
      (vm-set-year-of m "")
      (vm-set-hour-of m "")
      (vm-set-zone-of m "")
      nil))))


;;; There are many systems where the user's real name is encoded in the
;;; user id.  This version of vm-su-do-author parses the user-id to extract
;;; the real name, so that the %F directive does what you want more of the
;;; time.  It handles the following forms of addresses:
;;;
;;;	Jamie.Zawinski@somehost		--> "Jamie Zawinski"
;;;	Jamie_Zawinski@somehost		--> "Jamie Zawinski"
;;;	Jamie_W._Zawinski@somehost	--> "Jamie W. Zawinski"
;;;	Jamie.W.Zawinski@somehost	--> "Jamie W Zawinski"
;;;	"Jamie Zawinski"@somehost	--> "Jamie Zawinski"
;;; also
;;;	jwz ("Jamie Zawinski")		--> "Jamie Zawinski"
;;;	jwz (Jamie Zawinski (comment))	--> "Jamie Zawinski"
;;;	jwz (Jamie Zawinski -- comment)	--> "Jamie Zawinski"
;;; and likewise in the "name <uid>" form.

(if (not (fboundp 'vm-su-do-author)) (load-library "vm-summary"))  ; redefine

(defun vm-su-do-author (m)
  (let (full-name from)
    (setq full-name (vm-get-header-contents m "Full-Name"))
    (setq from (or (vm-get-header-contents m "From") (vm-grok-From_-author m)))
    (cond ((null from)
	   (setq from "???")
	   (if (null full-name)
	       (setq full-name "???")))
	  ((string-match "^\\([^< \t\n]+\\([ \t\n]+[^< \t\n]+\\)*\\)?[ \t\n]*\\(<\\([^>]+\\)>\\)"
			 from)
	   ;; Matches "Real Name <uid>"
	   (if (and (match-beginning 1) (null full-name))
	       (setq full-name
		     (substring from (match-beginning 1) (match-end 1))))
	   (setq from (substring from (match-beginning 4) (match-end 4))))
	  ((string-match "^[^(]*(\\(.*\\))[^)]*$" from)
	   ;; Matches "uid (Real Name)" as well as "uid (real (really) name)"
	   ;; and "uid (real name (comment))"
	   (if (null full-name)
	       (setq full-name (substring from (match-beginning 1)
					  (match-end 1))))
	   (setq from
		 (concat
		  (substring from (match-beginning 0) (1- (match-beginning 1)))
		  (substring from (1+ (match-end 1)) (match-end 0))))))
    ;; ewe ewe see pee...
    (if (and vm-gargle-uucp (string-match
"\\([^!@:.]+\\)\\(\\.[^!@:]+\\)?!\\([^!@: \t\n]+\\)\\(@\\([^!@:. \t\n]+\\)\\(.[^ \t\n]+\\)?\\)?[ \t\n]*$"
			     from))
	(setq from
	      (concat
	       (substring from (match-beginning 3) (match-end 3)) "@"
	       (if (and (match-beginning 5) (match-beginning 2)
			(not (match-beginning 6)))
		   (concat (substring from (match-beginning 5) (match-end 5))
			   ".")
		 "")
	       (substring from (match-beginning 1)
			  (or (match-end 2) (match-end 1)))
	       (if (match-end 2) "" ".UUCP"))))
    (if (or (null full-name) (string-match "^[ \t]*$" full-name))
	(setq full-name from))
    ;; derive username from address if address is of the form "User.Name@Host"
    ;; or "User_Name@Host" or "\"User Name\"@Host".
    (if (or (string-match "^[^!@%]+[._][^._%@]*[^@%][@%]" full-name)
	    (string-match "^[^!@%]*\"[^!@%]+ [^ %@]*[^@%][@%]" full-name))
	(setq full-name (substring full-name 0 (1- (match-end 0)))))
    (setq full-name (vm-clean-username full-name))
    (vm-set-full-name-of m full-name)
    (vm-set-from-of m from)))

(defun vm-clean-username (string)
  "Strips garbage from the user full name string."
  (if (string-match "[%@!]" string)  ; this ain't no user name!  It's an address!
      string
    (let ((case-fold-search t))
      ;; take off leading and trailing non-alpha chars (quotes, parens, digits, etc)
      (if (string-match "\\`[^a-z]+" string)
	  (setq string (substring string (match-end 0))))
      (if (string-match "[^a-z]+\\'" string)
	  (setq string (substring string 0 (match-beginning 0))))
      ;; replace tabs, multiple spaces, dots, and underscores with a single space.
      ;; but don't replace ". " with " " because that could be an initial.
      (while (string-match "\\(\t\\|  +\\|\\(\\.\\)[^ \t_]\\|_+\\)" string)
	(setq string (concat (substring string 0
					(or (match-beginning 2)
					    (match-beginning 1)))
			     " "
			     (substring string (or (match-end 2)
						   (match-end 1))))))
      ;; If the string contains trailing parenthesized comments, nuke 'em.
      ;; (As in "John Doe -- Pinhead" or "John Doe (Pinhead)".)
      (if (string-match "[^ \t]\\([ \t]*\\((\\| --\\)\\)" string)
	  (progn
	    (setq string (substring string 0 (match-beginning 1)))
	    ;; lose any non-alpha rubbish this may have exposed.
	    (if (string-match "[^a-z]+\\'" string)
		(setq string (substring string 0 (match-beginning 0))))))
      string)))


;;; do yanking in a slightly more pretty way.

(defun my-mail-yank-hook ()
  (save-excursion
    (delete-region (point) (progn (search-forward "\n\n") (point)))
    (if vm-included-text-attribution-format
	;; `message' is a local of `vm-yank-message'.
	(insert (vm-sprintf 'vm-included-text-attribution-format message)))
    (beginning-of-line)

    (let ((p (point))
	  (active-regions nil)) ;v19ism
      ;;
      ;; First, strip out any uuencode garbage.  I get a lot of these, so
      ;; I find it handy to have them automatically removed from followups...
      ;;
      (if (re-search-forward "^begin [0-7][0-7][0-7]" nil t)
	  (progn
	    (forward-line 2)
	    (let ((p2 (point)))
	      (if (re-search-forward "^end$")
		  (progn
		    (forward-line -2)
		    (delete-region p2 (point))
		    (insert "...\n"))))))
      (goto-char p)
      ;;
      ;; Insert "> " at the beginning of every line, except that if the line
      ;; already begins with ">", don't insert the space, so we get ">> "
      ;; instead of "> > ".
      ;;
      (while (< (point) (mark))
	(insert (if (looking-at ">") ">" "> "))
	(forward-line 1))
      ;;
      ;; Now make a second pass and fill any paragraphs that were too long.
      ;; Only paragraphs which were too long are reindented, to avoid losing
      ;; by reindenting code or diagrams.  Quote-nesting is considered a
      ;; paragraph boundary.
      ;;
      (goto-char p)
      (while (< (point) (mark))
	(end-of-line)
	(if (> (current-column) fill-column)
	    (let (p2 str re fill-prefix)
	      (beginning-of-line)
	      (looking-at "^>*")
	      (setq str (make-string (- (match-end 0) (match-beginning 0))
				     ?>))
	      (setq fill-prefix (concat str " "))
	      (setq re (concat "^" str "[^>][^> \t\n\r-]+"))
	      ;; maybe this `while' could be implemented as a regexp...
	      (while (looking-at re)
		(forward-line -1))
	      (forward-line 1)
	      (setq p2 (point))
	      ;;(setq fill-prefix (concat "*" fill-prefix))
	      (while (looking-at re)
		;;(insert "*")
		(forward-line 1))
	      (fill-region-as-paragraph p2 (point))
	      ))
	(forward-line 1))
      )))

(setq mail-yank-hooks 'my-mail-yank-hook)


;;; only forward the headers that are visible.

(if (or (not (fboundp 'vm-forward-message))
	(and (consp (symbol-function 'vm-forward-message))
	     (eq 'autoload (car (symbol-function 'vm-forward-message)))))
    (load-library "vm-reply"))

(defun vm-forward-message ()
  "Forward the current message to one or more third parties.
You will be placed in a Mail mode buffer as is usual with replies, but you
must fill in the To: and Subject: headers manually."
  (interactive)
  (vm-follow-summary-cursor)
  (vm-select-folder-buffer)
  (vm-check-for-killed-summary)
  (vm-error-if-folder-empty)
  (if (eq last-command 'vm-next-command-uses-marks)
      (progn (setq this-command 'vm-next-command-uses-marks)
	     (command-execute 'vm-send-digest))
    (let ((b (current-buffer))
	  (dir default-directory)
	  (mp vm-message-pointer)
	  (old-point-min (point-min))
	  start)
      (save-restriction
	(widen)
	(vm-mail-internal
	 (format "forward of %s:%s" (buffer-name)
		 (vm-number-of (car vm-message-pointer)))
	 nil
	 (and vm-forwarding-subject-format
	      (vm-sprintf 'vm-forwarding-subject-format
			  (car mp))))
	(use-local-map (copy-keymap (current-local-map)))
	(local-set-key "\C-c\C-y" 'vm-yank-message)
	(local-set-key "\C-cy" 'vm-yank-message-other-folder)
	(local-set-key "\C-c\C-s" 'vm-mail-send)
	(local-set-key "\C-c\C-c" 'vm-mail-send-and-exit)
	(local-set-key "\C-c\C-v" vm-mode-map)
	(make-local-variable 'vm-forward-list)
	(setq vm-mail-buffer b
	      vm-system-state 'forwarding
	      vm-forward-list (list (car mp))
	      vm-message-pointer mp
	      default-directory dir)
	(goto-char (point-max))
	(insert "------- Start of forwarded message -------\n")
	(setq start (point))
	(let (message-start)
	  (save-excursion
	    (set-buffer b)
	    (let ((exposed (= old-point-min (vm-start-of (car mp)))))
	      (if (not exposed)
		  (setq message-start (vm-vheaders-of (car mp)))
		(goto-char (vm-start-of (car mp)))
		(forward-line 1)
		(setq message-start (point)))))
	  (insert-buffer-substring b message-start
				   (vm-text-end-of (car mp))))
	(if vm-rfc934-forwarding
	    (vm-rfc934-char-stuff-region start (point)))
	(insert "------- End of forwarded message -------\n")
	(goto-char (point-min))
	(end-of-line)))))


(defun vm-send-digest (&optional prefix)
  "Send a digest of all messages in the current folder to recipients.
You will be placed in a *mail* buffer as is usual with replies, but you
must fill in the To: and Subject: headers manually.

Prefix arg means to insert a list of preamble lines at the beginning of
the digest.  One line is generated for each message being digestified.
The variable vm-digest-preamble-format determines the format of the
preamble lines.

If invoked on marked messages (via vm-next-command-uses-marks),
only marked messages will be put into the digest."
  (interactive "P")
  (vm-select-folder-buffer)
  (vm-check-for-killed-summary)
  (vm-error-if-folder-empty)
  (let ((b (current-buffer))
	(dir default-directory)
	(mp vm-message-pointer)
	;; prefix arg doesn't have "normal" meaning here, so only call
	;; vm-select-marked-or-prefixed-messages if we're using marks.
	(mlist (if (eq last-command 'vm-next-command-uses-marks)
		   (vm-select-marked-or-prefixed-messages 0)
		 vm-message-list))
	start)
    (save-restriction
      (widen)
      (vm-mail-internal (format "digest from %s" (buffer-name))
	nil
	(and vm-forwarding-subject-format
	     (vm-sprintf 'vm-forwarding-subject-format
			 (car mlist))))
      (use-local-map (copy-keymap (current-local-map)))
      (local-set-key "\C-c\C-y" 'vm-yank-message)
      (local-set-key "\C-cy" 'vm-yank-message-other-folder)
      (local-set-key "\C-c\C-s" 'vm-mail-send)
      (local-set-key "\C-c\C-c" 'vm-mail-send-and-exit)
      (local-set-key "\C-c\C-v" vm-mode-map)
      (make-local-variable 'vm-forward-list)
      (setq vm-mail-buffer b
	    vm-message-pointer mp
	    vm-system-state 'forwarding
	    vm-forward-list mlist
	    default-directory dir)
      (goto-char (point-max))
      (setq start (point)
	    mp mlist)
      (message "Building digest...")
      (while mp
	(insert "From \n")
	(insert-buffer-substring (marker-buffer (vm-start-of (car mp)))
				 ;; (vm-start-of (car mp))
				 (vm-vheaders-of (car mp))
				 (vm-end-of (car mp)))
	(setq mp (cdr mp)))
      (vm-digestify-region start (point))
      (goto-char start)
      (while (re-search-forward "^\\(---+\n\\)\n+" nil t)
	(delete-region (match-end 1) (match-end 0)))
      (goto-char start)
      (setq mp mlist)
      (if prefix
	  (progn
	    (message "Building digest preamble...")
	    (while mp
	      (insert (vm-sprintf 'vm-digest-preamble-format (car mp)) "\n")
	      (if vm-digest-center-preamble
		  (progn
		    (forward-char -1)
		    (center-line)
		    (forward-char 1)))
	      (setq mp (cdr mp)))))
      (goto-char (point-min))
      (end-of-line)
      (message "Building digest... done"))))

(or (fboundp 'vm-orig-parse-addresses)
    (fset 'vm-orig-parse-addresses (symbol-function 'vm-parse-addresses)))

(defun vm-parse-addresses (string)
  (nreverse (vm-orig-parse-addresses string)))


;;; Changed to fit as many addresses on one line as possible, while 
;;; breaking lines only at commas (instead of in the middle of addresses.)
;;;
;;; Also, the screen is made to contain exactly two windows: one displaying
;;; the message being replied to, and the other in which the message is 
;;; being composed.  If the message being replied to has been automatically
;;; yanked in (for citation) then there is only one window.  See also the 
;;; modifications to vm-mail-send-and-exit.
;;;
(defun vm-do-reply (to-all include-text count)
  (save-restriction
    (widen)
    (let ((mail-buffer (current-buffer))
	  (mlist (vm-select-marked-or-prefixed-messages count))
	  (dir default-directory)
	  (message-pointer vm-message-pointer)
	  to cc subject mp in-reply-to references tmp tmp2 newsgroups)
      (setq mp mlist)
      (while mp 
	(cond
	 ((eq mlist mp)
	  (cond ((setq to (vm-get-header-contents (car mp) "Reply-To")))
		((setq to (vm-get-header-contents (car mp) "From")))
		((setq to (vm-grok-From_-author (car mp))))
		(t (error "No From: or Reply-To: header in message")))
	  (setq subject (vm-get-header-contents (car mp) "Subject")
		in-reply-to (and vm-in-reply-to-format
				 (vm-sprintf 'vm-in-reply-to-format (car mp)))
		in-reply-to (and (not (equal "" in-reply-to)) in-reply-to))
	  (and subject vm-reply-subject-prefix
	       (let ((case-fold-search t))
		 (not
		  (equal
		   (string-match (regexp-quote vm-reply-subject-prefix)
				 subject)
		   0)))
	       (setq subject (concat vm-reply-subject-prefix subject))))
	 (t (cond ((setq tmp (vm-get-header-contents (car mp) "Reply-To"))
		   (setq to (concat to "," tmp)))
		  ((setq tmp (vm-get-header-contents (car mp) "From"))
		   (setq to (concat to "," tmp)))
		  ((setq tmp (vm-grok-From_-author (car mp)))
		   (setq to (concat to "," tmp)))
		  (t (error "No From: or Reply-To: header in message")))))
	(if to-all
	    (progn
	      (setq tmp (vm-get-header-contents (car mp) "To"))
	      (setq tmp2 (vm-get-header-contents (car mp) "Cc"))
	      (if tmp
		  (if cc
		      (setq cc (concat cc "," tmp))
		    (setq cc tmp)))
	      (if tmp2
		  (if cc
		      (setq cc (concat cc "," tmp2))
		    (setq cc tmp2)))))
	(setq references
	      (cons (vm-get-header-contents (car mp) "References")
		    (cons (vm-get-header-contents (car mp) "In-reply-to")
			  (cons (vm-get-header-contents (car mp) "Message-ID")
				references))))
	(setq newsgroups
	      (cons (or (and to-all (vm-get-header-contents (car mp) "Followup-To"))
			(vm-get-header-contents (car mp) "Newsgroups"))
		    newsgroups))
	(setq mp (cdr mp)))
      (if vm-strip-reply-headers
	  (let ((mail-use-rfc822 t))
	    (require 'mail-utils)
	    (and to (setq to (mail-strip-quoted-names to)))
	    (and cc (setq cc (mail-strip-quoted-names cc)))))
      (setq to (vm-parse-addresses to)
	    cc (vm-parse-addresses cc))
      (if vm-reply-ignored-addresses
	  (setq to (vm-strip-ignored-addresses to)
		cc (vm-strip-ignored-addresses cc)))
      (setq to (vm-delete-duplicates to))
      (setq cc (vm-delete-duplicates cc))
      ;; hacky change by jwz to fit as many addresses as possible on one line,
      ;; breaking lines only between addresses.
      (let* ((i 4)
	     (fn (function (lambda (addr)
		   (setq i (+ i (length addr) 2))
		   (if (< i fill-column)
		       addr
		     (setq i (+ (length addr) 6))
		     (concat "\n    " addr))))))
	(and to (setq to (mapconcat fn to ", ")))
	(setq i 4)
	(and cc (setq cc (mapconcat fn cc ", "))))
      (and (null to) (setq to cc cc nil))
      (setq references (delq nil references)
	    references (mapconcat 'identity references " ")
	    references (vm-parse references "[^<]*\\(<[^>]+>\\)")
	    references (vm-delete-duplicates references)
	    references (if references (mapconcat 'identity references "\n\t")))
      (setq newsgroups (delq nil newsgroups)
	    newsgroups (mapconcat 'identity newsgroups ",")
	    newsgroups (vm-parse newsgroups "[ \t\f\r\n,]*\\([^ \t\f\r\n,]+\\)")
	    newsgroups (vm-delete-duplicates newsgroups)
	    newsgroups (if newsgroups (mapconcat 'identity newsgroups ",")))
      (vm-mail-internal
       (format "reply to %s%s" (vm-su-full-name (car mlist))
	       (if (cdr mlist) ", ..." ""))
       to subject in-reply-to cc references newsgroups)
      (use-local-map (copy-keymap (current-local-map)))
      (local-set-key "\C-c\C-y" 'vm-yank-message)
      (local-set-key "\C-cy" 'vm-yank-message-other-folder)
      (local-set-key "\C-c\C-s" 'vm-mail-send)
      (local-set-key "\C-c\C-c" 'vm-mail-send-and-exit)
      (local-set-key "\C-c\C-v" vm-mode-map)
      (make-local-variable 'vm-reply-list)
      (setq vm-mail-buffer mail-buffer
	    vm-system-state 'replying
	    vm-message-pointer message-pointer
	    vm-reply-list mlist
	    default-directory dir)
      (and mail-buffer (delete-other-windows))
      (if include-text
	  (save-excursion
	    (goto-char (point-min))
	    (re-search-forward (concat "^" mail-header-separator "$") nil 0)
	    (forward-char 1)
	    (while mlist
	      (vm-yank-message (car mlist))
	      (goto-char (point-max))
	      (setq mlist (cdr mlist))))
	(and mail-buffer (display-buffer mail-buffer))
	))))

;;; If the mail being sent is in reply to some message, then after the mail
;;; is sent, there is made to be exactly one window displaying the folder
;;; which contains the replied-to message.  If that folder has a summary
;;; buffer, then the summary buffer is displayed as well.
;;;
(defun vm-mail-send-and-exit (arg)
  "Just like mail-send-and-exit except that VM flags the appropriate message(s)
as having been replied to, if appropriate."
  (interactive "P")
  (let ((reply-buf (current-buffer))
	(mail-buf vm-mail-buffer))
    (mail-send-and-exit arg)
    (save-excursion
      (set-buffer reply-buf)
      (cond ((eq vm-system-state 'replying)
	     (vm-mark-replied))
	    ((eq vm-system-state 'forwarding)
	     (vm-mark-forwarded)))
      (vm-rename-current-mail-buffer)
      ;; keep this buffer if the user demands it
      (if (memq (current-buffer) vm-kept-mail-buffers)
	  (setq vm-kept-mail-buffers
		(delq (current-buffer) vm-kept-mail-buffers)))
      (setq vm-kept-mail-buffers (cons (current-buffer) vm-kept-mail-buffers))
      (if (not (eq vm-keep-sent-messages t))
	  (let ((extras (nthcdr (or vm-keep-sent-messages 0) vm-kept-mail-buffers)))
	    (mapcar (function (lambda (b) (and (buffer-name b) (kill-buffer b)))) extras)
	    (and vm-kept-mail-buffers extras
		 (setcdr (memq (car extras) vm-kept-mail-buffers) nil))))
      )
    (if mail-buf
	(progn
	  (switch-to-buffer mail-buf)
	  (delete-other-windows)
	  (if vm-summary-buffer (vm-summarize t))))
    ))



;; one line fix...
(defun vm-su-do-recipients (m)
  (let ((mail-use-rfc822 t) names addresses to cc all list)
    (setq to (or (vm-get-header-contents m "To")
		 (vm-get-header-contents m "Apparently-To")
		 ;; desperation....
		 (user-login-name))
	  cc (vm-get-header-contents m "Cc")
	  all to
	  all (if all (concat all ", " cc) cc)
	  addresses (rfc822-addresses all))
    (setq list (vm-parse-addresses all))
    (while list
      (cond ((string= (car list) ""))
	    ((string-match "^\\(\\([^<]+[^ \t\n]\\)[ \t\n]+\\)?<\\([^>]+\\)>"
			   (car list))
	     (if (match-beginning 2)
		 (setq names
		       (cons
			(substring (car list) (match-beginning 2)
				   (match-end 2))
			names))
	       (setq names
		     (cons
		      (substring (car list) (match-beginning 3)
				 (match-end 3))
		      names))))
	    ((string-match "[\000-\177]*(\\([^)]+\\))[\000-\177]*" (car list))
	     (setq names
		   (cons (substring (car list) (match-beginning 1)
				    (match-end 1))
			 names)))
	    (t (setq names (cons (car list) names))))
      (setq list (cdr list)))
    (setq names (nreverse names)) ;; ## added by jwz
    (if vm-gargle-uucp
	(while list
	  (if (string-match
"\\([^!@:.]+\\)\\(\\.[^!@:]+\\)?!\\([^!@: \t\n]+\\)\\(@\\([^!@:. \t\n]+\\)\\(.[^ \t\n]+\\)?\\)?[ \t\n]*$"
	       (car list))
	      (setcar
	       list
	       (concat
		(substring (car list) (match-beginning 3)
			   (match-end 3))
		"@"
		(if (and (match-beginning 5) (match-beginning 2)
			 (not (match-beginning 6)))
		    (concat (substring (car list) (match-beginning 5)
				       (match-end 5))
			    ".")
		  "")
		(substring (car list) (match-beginning 1)
			   (or (match-end 2) (match-end 1)))
		(if (match-end 2) "" ".UUCP"))))
	  (setq list (cdr list))))
    (vm-set-to-of m (mapconcat 'identity addresses ", "))
    (vm-set-to-names-of m (mapconcat 'identity names ", "))))





(defvar vm-uudecode-file-mode "644"
  "*If non-nil, this overrides the mode specified in the `begin' line of
a uuencoded file being unpacked by vm-uudecode.  This should be a string,
which is the mode desired in octal.")

(defvar vm-uudecode-auto-chmod "u+w"
  "*If non-nil, then when vm-uudecode is untarring a file for you, it will
apply this chmod modifier to each of the unpacked files.  This should be
a string like \"u+w\".")

(defvar vm-uudecode-auto-touch t
  "*If non-nil, then when vm-uudecode is untarring a file for you, it will
cause the write-date of each of the unpacked files to be the current time.
Normally tar unpacks files with the time at which they are packed; this can
cause your `make' commands to fail if you are installing a new version of
a package which you have modified.")

(defun vm-uudecode (directory)
  "Assuming the current message is a uuencoded file, decode it into a
prompted-for directory.  If the encoded file ends in .Z, .tar, or .tar.Z,
you will be asked whether to uncompress/untar it as well.  See also the
variables vm-uudecode-file-mode, vm-uudecode-auto-chmod, and 
vm-uudecode-auto-touch."
  (interactive "Duudecode in directory: ")
  (setq directory (expand-file-name (file-name-as-directory directory)))
  (vm-select-folder-buffer)
  (vm-check-for-killed-summary)
  (vm-error-if-folder-empty)
  (let ((case-fold-search nil)
	(message (current-buffer))
	start end file mode buf)
    (save-excursion
      (goto-char (point-min))
      ;; this can take a while on big messages
      (message "parsing file...")
      (re-search-forward "^begin[ \t]+\\([0-9][0-9][0-9]\\)[ \t]+\\([^ \t\n]*\\)\n")
      (setq start (match-beginning 0))
      (setq file (concat directory
			 (file-name-nondirectory 
			   (buffer-substring (match-beginning 2) (match-end 2))))
	    ;; might want to do something tricky with this if it's not 644.
	    mode (buffer-substring (match-beginning 1) (match-end 1)))
      (re-search-forward "^[^M\n]")
      (re-search-forward "^end$")
      (message "parsing file...done.")
      (forward-line 1)
      (setq end (point)))
    (cond ((and vm-uudecode-file-mode
		(not (string= mode vm-uudecode-file-mode)))
	   (set-buffer (setq buf (get-buffer-create "*uudecode-scratch*")))
	   (erase-buffer)
	   (insert-buffer-substring message start end)
	   (setq start (point-min) end (point-max))
	   (goto-char start)
	   (or (looking-at "^begin[ \t]+") (error "eh, what?"))
	   (goto-char (match-end 0))
	   (delete-char 3)
	   (insert vm-uudecode-file-mode)))
    (let* ((base-file (file-name-nondirectory file))
	   (final-file file)
	   (command (concat "cd " directory " ; uudecode"))
	   tar-p)
      (cond ((string-match "\\.tar\\.Z$" file)
	     (if (y-or-n-p "uncompress/untar? ")
		 (setq command (concat command " && zcat "
				       base-file " | tar -vxf -")
		       final-file nil
		       tar-p t)))
	    ((string-match "\\.tar$" file)
	     (if (y-or-n-p "untar? ")
		 (setq command (concat command " && tar -vxf " base-file)
		       final-file nil
		       tar-p t)))
	    ((string-match "\\.Z$" file)
	     (if (y-or-n-p "uncompress? ")
		 (setq command (concat command " ; uncompress " base-file)
		       final-file (substring file 0 (match-beginning 0))))))
      (let ((str (concat "executing \"" command "\" ...")))
	(message str)
	(shell-command-on-region start end command nil)
	(if final-file
	    (dired-add-entry-all-buffers directory
					 (file-name-nondirectory final-file)))
	(cond (buf
	       (kill-buffer buf)
	       (set-buffer message)))
	(message (concat str " done.")))
      (cond
	(tar-p
	 (set-buffer (get-buffer "*Shell Command Output*"))
	 (let ((all (concat command "\n" (buffer-string)))
	       files files-str)
	   (goto-char (point-min))
	   (while (not (eobp))
	     (if (looking-at "^x \\([^,\n]+\\), ")
		 (setq files (cons (buffer-substring (match-beginning 1) (match-end 1))
				   files)))
	     (forward-line 1))
	   (setq files (nreverse files)
		 files-str (mapconcat 'identity files " "))
	   (cond
	     (files
	      (cond
		(vm-uudecode-auto-chmod
		 (setq command (concat "cd " directory " ; chmod "
				       vm-uudecode-auto-chmod " " files-str))
		 (shell-command command)
		 (setq all (concat all "\n" command "\n" (buffer-string)))))
	      (cond
		(vm-uudecode-auto-touch
		 (setq command (concat "cd " directory " ; touch " files-str))
		 (shell-command command)
		 (setq all (concat all "\n" command "\n" (buffer-string)))))
	      (goto-char (point-min))
	      (insert all "\n")
	      (mapcar (function (lambda (x)
			(dired-add-entry-all-buffers directory x)))
		      files)))))))))

(and (fboundp 'gmhist-make-magic)
     (gmhist-make-magic 'vm-uudecode))


(provide 'vm-hacks)