Path: utzoo!utgpu!jarvis.csri.toronto.edu!rutgers!tut.cis.ohio-state.edu!UUNET.UU.NET!talos!kjones
From: talos!kjones@UUNET.UU.NET (Kyle Jones)
Newsgroups: gnu.emacs
Subject: VM - a mail reader for GNU Emacs (2 of 3)
Message-ID: <8905232131.AA24619@talos.uucp>
Date: 23 May 89 21:31:57 GMT
Sender: daemon@tut.cis.ohio-state.edu
Distribution: gnu
Organization: GNUs Not Usenet
Lines: 1461

#!/bin/sh
# shar:	Shell Archiver  (v1.22)
#
#	Run the following text with /bin/sh to create:
#	  vm-digest.el
#	  vm-group.el
#	  vm-reply.el
#	  vm-search.el
#	  vm-summary.el
#	  vm-undo.el
#
sed 's/^X//' << 'SHAR_EOF' > vm-digest.el &&
X;;; Support code for RFC934 digests
X;;; Copyright (C) 1989 Kyle E. Jones
X;;;
X;;; This program is free software; you can redistribute it and/or modify
X;;; it under the terms of the GNU General Public License as published by
X;;; the Free Software Foundation; either version 1, or (at your option)
X;;; any later version.
X;;;
X;;; This program is distributed in the hope that it will be useful,
X;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
X;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
X;;; GNU General Public License for more details.
X;;;
X;;; You should have received a copy of the GNU General Public License
X;;; along with this program; if not, write to the Free Software
X;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
X
X(require 'vm)
X
X(defun vm-rfc934-char-stuff-region (start end)
X  (setq end (vm-marker end))
X  (save-excursion
X    (goto-char start)
X    (while (and (< (point) end) (re-search-forward "^-" end t))
X      (replace-match "- -" t t)))
X  (set-marker end nil))
X
X(defun vm-rfc934-char-unstuff-region (start end)
X  (setq end (vm-marker end))
X  (save-excursion
X    (goto-char start)
X    (while (and (< (point) end) (re-search-forward "^- "  end t))
X      (replace-match "" t t)
X      (forward-char)))
X  (set-marker end nil))
X
X(defun vm-digestify-region (start end)
X  (setq end (vm-marker end))
X  (save-excursion
X    (vm-rfc934-char-stuff-region start end)
X    (goto-char start)
X    (insert-before-markers "------- Start of digest -------\n")
X    (delete-region (point) (progn (forward-line) (point)))
X    (while (re-search-forward "\n\nFrom .*" end t)
X      (replace-match "\n\n------------------------------\n" t nil))
X    (goto-char end)
X    (insert-before-markers "------- End of digest -------\n"))
X  (set-marker end nil))
X
X(defun vm-burst-digest ()
X  "Burst the current message (a digest) into its individual messages.
XThe digest's messages are assimilated into the folder as new mail would be,
Xe.g. message grouping takes place and if you're not reading a message
Xyou will be moved to the first new or unread message."
X  (interactive)
X  (if vm-mail-buffer
X      (set-buffer vm-mail-buffer))
X  (vm-error-if-mailbox-empty)
X  (let ((inhibit-quit t) start end reg-start
X	(reg-end (vm-marker nil))
X	(text-start (vm-marker nil))
X	(buffer-read-only)
X	(old-buffer-modified-p (buffer-modified-p))
X	(m (car vm-message-pointer)))
X    (save-excursion
X      (vm-save-restriction
X       (condition-case ()
X	   (progn
X	     (widen)
X	     (goto-char (point-max))
X	     (setq start (point))
X	     (insert-buffer-substring (current-buffer)
X				      (vm-text-of (car vm-message-pointer))
X				      (vm-end-of (car vm-message-pointer)))
X	     (if (not
X		  (re-search-backward "\\(^-[^ ].*\n+\\|^-\n+\\)+" start t))
X		 (error "final EB not found")
X	       (setq end (point-marker))
X	       ;; Reverse searchs are odd.  The above expression simply
X	       ;; will not match  more than one message separator despite
X	       ;; the "1 or more" directive at the end.
X	       ;; This will have to suffice.
X	       (while
X		   (and
X		    (save-excursion
X		      (re-search-backward "\\(^-[^ ].*\n+\\|^-\n+\\)+" start t)
X		      (= end (match-end 0))))
X		 (set-marker end (match-beginning 0))
X		 (goto-char end))
X	       (skip-chars-backward "\n")
X	       (set-marker end (point))
X	       (delete-region end (point-max)))
X	     (goto-char start)
X	     (if (not (re-search-forward "^-[^ ]" end t))
X		 (error "start EB not found")
X	       (delete-region start (match-beginning 0)))
X	     (goto-char start)
X	     (while (re-search-forward
X		     "\\(\\(\n+\\)\\|\\(^\\)\\)\\(-[^ ].*\n+\\|-\n+\\)+"
X		     end 0)
X	       ;; Concoct a "From " line for the message
X	       (replace-match
X		(concat (if (match-beginning 2) "\n\n")
X			"From " (vm-from-of m) " " (current-time-string) "\n")
X		t t )
X	       ;; Delete attribute headers so message will appear
X	       ;; brand new to the user
X	       (setq reg-start (point))
X	       (save-excursion
X		 (search-forward "\n\n" nil 0)
X		 (set-marker text-start (point)))
X	       (if (re-search-forward vm-attributes-header-regexp text-start t)
X		   (delete-region (match-beginning 0) (match-end 0)))
X	       (if vm-berkeley-mail-compatibility
X		   (progn
X		     (goto-char reg-start)
X		     (if (re-search-forward vm-berkeley-mail-status-header-regexp
X					    text-start t)
X			 (delete-region (match-beginning 0) (match-end 0)))))
X	       ;; find end of message separator and unstuff the message
X	       (goto-char reg-start)
X	       (set-marker reg-end (if (re-search-forward "\n+-[^ ]" end 0)
X				       (match-beginning 0)
X				     (point)))
X	       (vm-rfc934-char-unstuff-region reg-start reg-end)
X	       (goto-char reg-end))
X	     (goto-char end)
X	     (insert "\n\n")
X	     (set-marker end nil)
X	     (set-marker reg-end nil)
X	     (vm-clear-modification-flag-undos)
X	     (if (vm-assimilate-new-messages)
X		 (progn
X		   (vm-emit-totals-blurb)
X		   (vm-thoughtfully-select-message)
X		   (if vm-summary-buffer
X		       (vm-summarize)))))
X	 (error (and start (delete-region start (point-max)))
X		(set-buffer-modified-p old-buffer-modified-p)
X		(error "Malformed digest")))))))
SHAR_EOF
chmod 0664 vm-digest.el || echo "restore of vm-digest.el fails"
sed 's/^X//' << 'SHAR_EOF' > vm-group.el &&
X;;; Commands to rearrange (group) message presentation
X;;; Copyright (C) 1989 Kyle E. Jones
X;;;
X;;; This program is free software; you can redistribute it and/or modify
X;;; it under the terms of the GNU General Public License as published by
X;;; the Free Software Foundation; either version 1, or (at your option)
X;;; any later version.
X;;;
X;;; This program is distributed in the hope that it will be useful,
X;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
X;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
X;;; GNU General Public License for more details.
X;;;
X;;; You should have received a copy of the GNU General Public License
X;;; along with this program; if not, write to the Free Software
X;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
X
X(require 'vm)
X
X(defun vm-group-by (group-function)
X  (let ((pivot vm-message-list) temp mp tail)
X    (while pivot
X      (setq tail (cdr pivot) mp tail)
X      (while mp
X	(cond ((funcall group-function (car pivot) (car mp))
X	       (cond ((eq mp tail)
X		      (setq tail (cdr tail) mp tail))
X		     (t
X		      (cond ((eq vm-message-pointer mp)
X			     (setq vm-message-pointer tail))
X			    ((eq vm-message-pointer tail)
X			     (setq vm-message-pointer mp)))
X		      (cond ((eq vm-last-message-pointer mp)
X			     (setq vm-last-message-pointer tail))
X			    ((eq vm-last-message-pointer tail)
X			     (setq vm-last-message-pointer mp)))
X		      (setq temp (car tail))
X		      (setcar tail (car mp))
X		      (setcar mp temp)
X		      (setq tail (cdr tail) mp (cdr mp)))))
X	      (t
X	       (setq mp (cdr mp)))))
X      (setq pivot tail))))
X
X(defconst vm-group-by-subject-closure (cons t t))
X
X(defun vm-group-by-subject (m1 m2)
X  (let ((subject (vm-su-subject m1)))
X    (if (eq subject (car vm-group-by-subject-closure))
X	(setq subject (cdr vm-group-by-subject-closure))
X      (setcar vm-group-by-subject-closure subject)
X      (if (string-match "^\\(re: *\\)+" subject)
X	  (setq subject (substring subject (match-end 0))))
X      (setq subject (concat "^\\(re: *\\)*"
X			    (regexp-quote subject)
X			    " *$"))
X      (setcdr vm-group-by-subject-closure subject))
X    (string-match subject (vm-su-subject m2))))
X
X(defun vm-group-by-author (m1 m2)
X  (string= (vm-full-name-of m1) (vm-full-name-of m2)))
X
X(defun vm-group-by-date-sent (m1 m2)
X  (and (string= (vm-monthday-of m1) (vm-monthday-of m2))
X       (string= (vm-month-of m1) (vm-month-of m2))
X       (string= (vm-year-of m1) (vm-year-of m2))))
X
X(defun vm-revert-to-arrival-time-grouping ()
X  (let ((curr (car vm-message-pointer))
X	(last (car vm-last-message-pointer)))
X    (setq vm-message-list
X	  (sort vm-message-list
X		(function
X		 (lambda (p q) (< (vm-start-of p) (vm-start-of q))))))
X    (cond (curr
X	   (setq vm-message-pointer vm-message-list)
X	   (while (not (eq (car vm-message-pointer) curr))
X	     (setq vm-message-pointer (cdr vm-message-pointer)))))
X    (cond (last
X	   (setq vm-last-message-pointer vm-message-list)
X	   (while (not (eq (car vm-last-message-pointer) last))
X	     (setq vm-last-message-pointer (cdr vm-last-message-pointer)))))))
X
X(defun vm-group-messages (grouping)
X  "Group messages by the argument GROUPING.
XInteractively this argument is prompted for in the minibuffer,
Xwith completion."
X  (interactive
X   (list 
X    (completing-read
X     (format "Group messages by (default %s): "
X	     (or vm-group-by "arrival-time"))
X     vm-supported-groupings-alist 'identity t)))
X  (if vm-mail-buffer
X      (set-buffer vm-mail-buffer))
X  (if (equal grouping "")
X      (setq grouping vm-group-by))
X  (cond ((and grouping (not (stringp grouping)))
X	 (error "Unsupported grouping: %s" grouping))
X	((equal grouping "arrival-time")
X	 (setq grouping nil)))
X  (if grouping
X      (let ((group-function (intern (concat "vm-group-by-" grouping))))
X	(if (not (fboundp group-function))
X	    (error "Unsupported grouping: %s" grouping))
X	(vm-revert-to-arrival-time-grouping)
X	(message "Grouping messages by %s..." grouping)
X	(vm-group-by group-function)
X	(message "Grouping messages by %s... done" grouping)
X	(setq vm-current-grouping grouping)
X	(vm-number-messages))
X    (vm-revert-to-arrival-time-grouping)
X    (setq vm-current-grouping grouping)
X    (vm-number-messages)
X    (if (interactive-p)
X	(message "Reverted to arrival time grouping")))
X  (if vm-summary-buffer
X      (vm-do-summary))
X  (if vm-message-pointer
X      (progn
X	(vm-update-summary-and-mode-line)
X	(vm-set-summary-pointer (car vm-message-pointer)))))
SHAR_EOF
chmod 0664 vm-group.el || echo "restore of vm-group.el fails"
sed 's/^X//' << 'SHAR_EOF' > vm-reply.el &&
X;;; Mailing, forwarding, and replying commands for VM
X;;; Copyright (C) 1989 Kyle E. Jones
X;;;
X;;; This program is free software; you can redistribute it and/or modify
X;;; it under the terms of the GNU General Public License as published by
X;;; the Free Software Foundation; either version 1, or (at your option)
X;;; any later version.
X;;;
X;;; This program is distributed in the hope that it will be useful,
X;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
X;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
X;;; GNU General Public License for more details.
X;;;
X;;; You should have received a copy of the GNU General Public License
X;;; along with this program; if not, write to the Free Software
X;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
X
X(require 'vm)
X
X(defun vm-do-reply (to-all include-text)
X  (if vm-mail-buffer
X      (set-buffer vm-mail-buffer))
X  (vm-error-if-mailbox-empty)
X  (save-restriction
X    (widen)
X    (let ((mail-buffer (current-buffer))
X	  (text-start (vm-text-of (car vm-message-pointer)))
X	  (text-end (vm-end-of (car vm-message-pointer)))
X	  (mp vm-message-pointer)
X	  to cc subject message-id tmp)
X      (cond ((setq to (vm-get-header-contents (car mp) "Reply-To")))
X	    ((setq to (vm-get-header-contents (car mp) "From")))
X	    (t (error "Cannot find a From: or Reply-To: header in message")))
X      (setq subject (vm-get-header-contents (car mp) "Subject"))
X      (setq message-id (vm-get-header-contents
X			(car mp) "Message-Id"))
X      (if to-all
X	  (progn
X	    (setq cc (vm-get-header-contents (car mp) "To"))
X	    (setq tmp (vm-get-header-contents (car mp) "Cc"))
X	    (if tmp
X		(if cc
X		    (setq cc (concat cc ",\n\t" tmp))
X		  (setq cc tmp)))))
X      (if (mail nil to subject message-id cc)
X	  (progn
X	    (use-local-map (copy-keymap (current-local-map)))
X	    (local-set-key "\C-c\C-y" 'vm-yank-message)
X	    (local-set-key "\C-c\C-s" 'vm-mail-send)
X	    (local-set-key "\C-c\C-c" 'vm-mail-send-and-exit)
X	    (local-set-key "\C-c\C-v" vm-mode-map)
X	    (setq vm-mail-buffer mail-buffer
X		  vm-message-pointer mp)
X	    (cond (include-text
X		   (goto-char (point-max))
X		   (insert-buffer-substring mail-buffer text-start text-end)
X		   (goto-char (- (point) (- text-end text-start)))
X		   (save-excursion
X		     (if vm-included-text-attribution-format
X			 (insert (vm-message-attribution (car mp))))
X		     (while (and (re-search-forward "^" nil t) (not (eobp)))
X		       (replace-match vm-included-text-prefix t t))))))))))
X
X;; This function's formal parameter must be `vm-su-message'
X;; so vm-compiled-included-text-attribution-sexp will work.
X(defun vm-message-attribution (vm-su-message)
X  (if (not (eq vm-compiled-included-text-attribution-format
X	       vm-included-text-attribution-format))
X      (progn
X	(vm-compile-format vm-included-text-attribution-format
X			   'vm-compiled-included-text-attribution-sexp)
X	(setq vm-compiled-included-text-attribution-format
X	      vm-included-text-attribution-format)))
X  (eval vm-compiled-included-text-attribution-sexp))
X
X(defun vm-yank-message (n dont-prefix)
X  "Yank message number N into the current buffer at point.
XThis command is meant to be used in VM created *mail* buffers;
Xthe yanked message comes from the mail buffer containing the message you are
Xreplying to, forwarding, or invoked VM's mail command.  The visible
Xheaders are yanked along with the text of the message
X
XPrefix arg means don't prepend the included text prefix to each line."
X  (interactive "nYank message number: \nP")
X  (if (not (bufferp vm-mail-buffer))
X      (error "This is not a VM *mail* buffer."))
X  (if (null (buffer-name vm-mail-buffer))
X      (error "The mail buffer containing message %d has been killed." n))
X  (let ((b (current-buffer))
X	(start (point))
X	(mp)
X	(end))
X    (save-restriction
X      (widen)
X      (save-excursion
X	(set-buffer vm-mail-buffer)
X	(setq mp (nthcdr (1- n) vm-message-list))
X	(if (null mp)
X	    (error "No such message."))
X	(save-restriction
X	  (widen)
X	  (append-to-buffer b (vm-vheaders-of (car mp))
X			    (vm-end-of (car mp)))
X	  (setq end
X		(vm-marker (+ start (- (vm-end-of (car mp))
X				       (vm-vheaders-of (car mp)))) b))))
X      (if (not dont-prefix)
X	  (save-excursion
X	    (goto-char start)
X	    (while (and (<= (point) end) (re-search-forward "^" end t))
X	      (replace-match vm-included-text-prefix t t)))))))
X
X(defun vm-mail-send-and-exit (arg)
X  "Just like mail-send-and-exit except that VM marks the appropriate message
Xas having been replied to, if appropriate."
X  (interactive "P")
X  (let ((reply-buf (current-buffer)))
X    (mail-send-and-exit arg)
X    (save-excursion
X      (set-buffer reply-buf)
X      (vm-mark-replied))))
X
X(defun vm-mail-send ()
X  "Just like mail-send except that VM marks the appropriate message
Xas having been replied to, if appropriate."
X  (interactive)
X  (mail-send)
X  (vm-mark-replied))
X
X(defun vm-mark-replied ()
X  (if (and (bufferp vm-mail-buffer) (buffer-name vm-mail-buffer))
X      (save-excursion
X	(let ((mp vm-message-pointer))
X	  (set-buffer vm-mail-buffer)
X	  (cond ((and (memq (car mp) vm-message-list)
X		      (null (vm-replied-flag (car mp))))
X		 (vm-set-replied-flag (car mp) t)
X		 (vm-update-summary-and-mode-line)))))))
X
X(defun vm-reply ()
X  "Reply to the sender of the current message.
XYou will be deposited into a standard Emacs *mail* buffer to compose and
Xsend your message.  See the documentation for the function `mail' for
Xmore info.
X
XNote that the normal binding of C-c C-y in the *mail* buffer is
Xautomatically changed to vm-yank-message during a reply.  This allows
Xyou to yank any message from the current folder into a reply.
X
XNormal VM commands may be accessed in the reply buffer by prefixing them
Xwith C-c C-v."
X  (interactive)
X  (vm-do-reply nil nil))
X
X(defun vm-reply-include-text ()
X  "Reply to the sender (only) of the current message and include text
Xfrom the message.  See the documentation for function vm-reply for details."
X  (interactive)
X  (vm-do-reply nil t))
X
X(defun vm-followup ()
X  "Reply to all recipients of the current message.
XSee the documentation for the function vm-reply for details."
X  (interactive)
X  (vm-do-reply t nil))
X
X(defun vm-followup-include-text ()
X  "Reply to all recipients of the current message and include text from
Xthe message.  See the documentation for the function vm-reply for details."
X  (interactive)
X  (vm-do-reply t t))
X
X(defun vm-forward-message ()
X  "Forward the current message to one or more third parties.
XYou will be placed in a *mail* buffer as is usual with replies, but you
Xmust fill in the To: and Subject: headers manually." 
X  (interactive)
X  (if vm-mail-buffer
X      (set-buffer vm-mail-buffer))
X  (vm-error-if-mailbox-empty)
X  (let ((b (current-buffer))
X	(m (car vm-message-pointer))
X	(start))
X    (save-restriction
X      (widen)
X      (cond ((mail)
X	     (use-local-map (copy-keymap (current-local-map)))
X	     (local-set-key "\C-c\C-y" 'vm-yank-message)
X	     (local-set-key "\C-c\C-v" vm-mode-map)
X	     (setq vm-mail-buffer b)
X	     (goto-char (point-max))
X	     (insert "------- Start of forwarded message -------\n")
X	     (setq start (point))
X	     (insert-buffer-substring b (vm-vheaders-of m) (1- (vm-end-of m)))
X	     (if vm-rfc934-forwarding
X		 (vm-rfc934-char-stuff-region start (point)))
X	     (insert "------- End of forwarded message -------\n")
X	     (goto-char (point-min))
X	     (end-of-line))))))
X
X(defun vm-mail ()
X  "Send a mail message from within VM."
X  (interactive)
X  (if vm-mail-buffer
X      (set-buffer vm-mail-buffer))
X  (let ((mail-buffer (current-buffer)))
X    (cond ((mail)
X	   (use-local-map (copy-keymap (current-local-map)))
X	   (local-set-key "\C-c\C-y" 'vm-yank-message)
X	   (local-set-key "\C-c\C-v" vm-mode-map)
X	   (setq vm-mail-buffer mail-buffer)))))
X
X(defun vm-send-digest ()
X  "Send a digest of all messages in the current folder to recipients.
XYou will be placed in a *mail* buffer as is usual with replies, but you
Xmust fill in the To: and Subject: headers manually." 
X  (interactive)
X  (if vm-mail-buffer
X      (set-buffer vm-mail-buffer))
X  (vm-error-if-mailbox-empty)
X  (let ((b (current-buffer))
X	(start))
X    (save-restriction
X      (widen)
X      (cond
X       ((mail)
X	(use-local-map (copy-keymap (current-local-map)))
X	(local-set-key "\C-c\C-y" 'vm-yank-message)
X	(setq vm-mail-buffer b)
X	(goto-char (point-max))
X	(setq start (point))
X	(insert-buffer-substring b)
X	(vm-digestify-region start (point))
X	(goto-char (point-min))
X	(end-of-line))))))
SHAR_EOF
chmod 0664 vm-reply.el || echo "restore of vm-reply.el fails"
sed 's/^X//' << 'SHAR_EOF' > vm-search.el &&
X;; Incremental search through a mail folder
X;; Copyright (C) 1985, 1986 Free Software Foundation, Inc.
X
X;; This file is part of GNU Emacs.
X
X;; GNU Emacs is distributed in the hope that it will be useful,
X;; but WITHOUT ANY WARRANTY.  No author or distributor
X;; accepts responsibility to anyone for the consequences of using it
X;; or for whether it serves any particular purpose or works at all,
X;; unless he says so in writing.  Refer to the GNU Emacs General Public
X;; License for full details.
X
X;; Everyone is granted permission to copy, modify and redistribute
X;; GNU Emacs, but only under the conditions described in the
X;; GNU Emacs General Public License.   A copy of this license is
X;; supposed to have been given to you along with GNU Emacs so you
X;; can know your rights and responsibilities.  It should be in a
X;; file named COPYING.  Among other things, the copyright notice
X;; and this notice must be preserved on all copies.
X
X
X;; Adapted for the VM mail reader, Kyle Jones, May 1989
X
X
X(require 'vm)
X
X;; This function does all the work of incremental search.
X;; The functions attached to ^R and ^S are trivial,
X;; merely calling this one, but they are always loaded by default
X;; whereas this file can optionally be autoloadable.
X;; This is the only entry point in this file.
X
X(defun vm-isearch (forward &optional regexp)
X  (let ((search-string "")
X	(search-message "")
X	(cmds nil)
X	(success t)
X	(wrapped nil)
X	(barrier (point))
X	adjusted
X	(invalid-regexp nil)
X	(slow-terminal-mode (and (<= (baud-rate) search-slow-speed)
X				 (> (window-height)
X				    (* 4 search-slow-window-lines))))
X	(other-end nil)    ;Start of last match if fwd, end if backwd.
X	(small-window nil)		;if t, using a small window
X	(found-point nil)		;to restore point from a small window
X	;; This is the window-start value found by the search.
X	(found-start nil)
X	(opoint (point))
X	(vm-ml-attributes-string vm-ml-attributes-string)
X	(vm-ml-message-number vm-ml-message-number)
X	(vm-message-pointer vm-message-pointer)
X	(inhibit-quit t))  ;Prevent ^G from quitting immediately.
X    (vm-isearch-push-state)
X    (save-window-excursion
X     (catch 'search-done
X       (while t
X	 (or (>= unread-command-char 0)
X	     (progn
X	       (or (input-pending-p)
X		   (vm-isearch-message))
X	       (if (and slow-terminal-mode
X			(not (or small-window (pos-visible-in-window-p))))
X		   (progn
X		     (setq small-window t)
X		     (setq found-point (point))
X		     (move-to-window-line 0)
X		     (let ((window-min-height 1))
X		       (split-window nil (if (< search-slow-window-lines 0)
X					     (1+ (- search-slow-window-lines))
X					   (- (window-height)
X					      (1+ search-slow-window-lines)))))
X		     (if (< search-slow-window-lines 0)
X			 (progn (vertical-motion (- 1 search-slow-window-lines))
X				(set-window-start (next-window) (point))
X				(set-window-hscroll (next-window)
X						    (window-hscroll))
X				(set-window-hscroll (selected-window) 0))
X		       (other-window 1))
X		     (goto-char found-point)))))
X	 (let ((char (if quit-flag
X			 ?\C-g
X		       (read-char))))
X	   (setq quit-flag nil adjusted nil)
X	   ;; Meta character means exit search.
X	   (cond ((and (>= char 128)
X		       search-exit-option)
X		  (setq unread-command-char char)
X		  (throw 'search-done t))
X		 ((eq char search-exit-char)
X		  ;; Esc means exit search normally.
X		  ;; Except, if first thing typed, it means do nonincremental
X		  (if (= 0 (length search-string))
X		      (vm-nonincremental-search forward regexp))
X		  (throw 'search-done t))
X		 ((= char ?\C-g)
X		  ;; ^G means the user tried to quit.
X		  (ding)
X		  (discard-input)
X		  (if success
X		      ;; If search is successful, move back to starting point
X		      ;; and really do quit.
X		      (progn (goto-char opoint)
X			     (signal 'quit nil))
X		    ;; If search is failing, rub out until it is once more
X		    ;;  successful.
X		    (while (not success) (vm-isearch-pop))))
X		 ((or (eq char search-repeat-char)
X		      (eq char search-reverse-char))
X		  (if (eq forward (eq char search-repeat-char))
X		      ;; C-s in forward or C-r in reverse.
X		      (if (equal search-string "")
X			  ;; If search string is empty, use last one.
X			  (setq search-string
X				(if regexp
X				    search-last-regexp search-last-string)
X				search-message
X				(mapconcat 'text-char-description
X					   search-string ""))
X			;; If already have what to search for, repeat it.
X			(or success
X			    (progn (goto-char (if forward (point-min) (point-max)))
X				   (setq wrapped t))))
X		    ;; C-s in reverse or C-r in forward, change direction.
X		    (setq forward (not forward)))
X		  (setq barrier (point)) ; For subsequent \| if regexp.
X		  (setq success t)
X		  (or (equal search-string "")
X		      (vm-isearch-search))
X		  (vm-isearch-push-state))
X		 ((= char search-delete-char)
X		  ;; Rubout means discard last input item and move point
X		  ;; back.  If buffer is empty, just beep.
X		  (if (null (cdr cmds))
X		      (ding)
X		    (vm-isearch-pop)))
X		 (t
X		  (cond ((or (eq char search-yank-word-char)
X			     (eq char search-yank-line-char))
X			 ;; ^W means gobble next word from buffer.
X			 ;; ^Y means gobble rest of line from buffer.
X			 (let ((word (save-excursion
X				       (and (not forward) other-end
X					    (goto-char other-end))
X				       (buffer-substring
X					(point)
X					(save-excursion
X					  (if (eq char search-yank-line-char)
X					      (end-of-line)
X					    (forward-word 1))
X					  (point))))))
X			   (setq search-string (concat search-string word)
X				 search-message
X				   (concat search-message
X					   (mapconcat 'text-char-description
X						      word "")))))
X			 ;; Any other control char =>
X			 ;;  unread it and exit the search normally.
X			 ((and search-exit-option
X			       (/= char search-quote-char)
X			       (or (= char ?\177)
X				   (and (< char ? ) (/= char ?\t) (/= char ?\r))))
X			  (setq unread-command-char char)
X			  (throw 'search-done t))
X			 (t
X			  ;; Any other character => add it to the
X			  ;;  search string and search.
X			  (cond ((= char search-quote-char)
X				 (setq char (read-quoted-char
X					     (vm-isearch-message t))))
X				((= char ?\r)
X				 ;; unix braindeath
X				 (setq char ?\n)))
X			  (setq search-string (concat search-string
X						      (char-to-string char))
X				search-message (concat search-message
X						       (text-char-description char)))))
X		  (if (and (not success)
X			   ;; unsuccessful regexp search may become
X			   ;;  successful by addition of characters which
X			   ;;  make search-string valid
X			   (not regexp))
X		      nil
X		    ;; If a regexp search may have been made more
X		    ;; liberal, retreat the search start.
X		    ;; Go back to place last successful search started
X		    ;; or to the last ^S/^R (barrier), whichever is nearer.
X		    (and regexp success cmds
X			 (cond ((memq char '(?* ??))
X				(setq adjusted t)
X				(let ((cs (nth (if forward
X						   5 ; other-end
X						 2) ; saved (point)
X					       (car (cdr cmds)))))
X				  ;; (car cmds) is after last search;
X				  ;; (car (cdr cmds)) is from before it.
X				  (setq cs (or cs barrier))
X				  (goto-char
X				   (if forward
X				       (max cs barrier)
X				     (min cs barrier)))))
X			       ((eq char ?\|)
X				(setq adjusted t)
X				(goto-char barrier))))
X		    ;; In reverse regexp search, adding a character at
X		    ;; the end may cause zero or many more chars to be
X		    ;; matched, in the string following point.
X		    ;; Allow all those possibiities without moving point as
X		    ;; long as the match does not extend past search origin.
X		    (if (and regexp (not forward) (not adjusted)
X			     (condition-case ()
X				 (looking-at search-string)
X			       (error nil))
X			     (<= (match-end 0) (min opoint barrier)))
X			(setq success t invalid-regexp nil
X			      other-end (match-end 0))
X		      ;; Not regexp, not reverse, or no match at point.
X		      (if (and other-end (not adjusted))
X			  (goto-char (if forward other-end
X				       (min opoint barrier (1+ other-end)))))
X		      (vm-isearch-search)))
X		  (vm-isearch-push-state))))))
X     (setq found-start (window-start (selected-window)))
X     (setq found-point (point)))
X    (if (> (length search-string) 0)
X	(if regexp
X	    (setq search-last-regexp search-string)
X	    (setq search-last-string search-string)))
X    (message "")
X    (if small-window
X	(goto-char found-point)
X      ;; Exiting the save-window-excursion clobbers this; restore it.
X      (set-window-start (selected-window) found-start t))))
X
X(defun vm-isearch-message (&optional c-q-hack ellipsis)
X  ;; If about to search, and previous search regexp was invalid,
X  ;; check that it still is.  If it is valid now,
X  ;; let the message we display while searching say that it is valid.
X  (and invalid-regexp ellipsis
X       (condition-case ()
X	   (progn (re-search-forward search-string (point) t)
X		  (setq invalid-regexp nil))
X	 (error nil)))
X  ;; If currently failing, display no ellipsis.
X  (or success (setq ellipsis nil))
X  (let ((m (concat (if success "" "failing ")
X		   (if wrapped "wrapped ")
X		   (if regexp "regexp " "")
X		   "VM I-search"
X		   (if forward ": " " backward: ")
X		   search-message
X		   (if c-q-hack "^Q" "")
X		   (if invalid-regexp
X		       (concat " [" invalid-regexp "]")
X		     ""))))
X    (aset m 0 (upcase (aref m 0)))
X    (let ((cursor-in-echo-area ellipsis))
X      (if c-q-hack m (message "%s" m)))))
X
X(defun vm-isearch-pop ()
X  (setq cmds (cdr cmds))
X  (let ((cmd (car cmds)))
X    (setq search-string (car cmd)
X	  search-message (car (cdr cmd))
X	  success (nth 3 cmd)
X	  forward (nth 4 cmd)
X	  other-end (nth 5 cmd)
X	  invalid-regexp (nth 6 cmd)
X	  wrapped (nth 7 cmd)
X	  barrier (nth 8 cmd)
X	  vm-ml-attributes-string (nth 9 cmd)
X	  vm-ml-message-number (nth 10 cmd)
X	  vm-message-pointer (nth 11 cmd))
X    (goto-char (car (cdr (cdr cmd))))
X    (vm-set-summary-pointer (car vm-message-pointer))))
X
X(defun vm-isearch-push-state ()
X  (setq cmds (cons (list search-string search-message (point)
X			 success forward other-end invalid-regexp
X			 wrapped barrier
X			 vm-ml-attributes-string vm-ml-message-number
X			 vm-message-pointer)
X		   cmds)))
X
X(defun vm-isearch-search ()
X  (vm-isearch-message nil t)
X  (condition-case lossage
X      (let ((inhibit-quit nil))
X	(if regexp (setq invalid-regexp nil))
X	(setq success
X	      (funcall
X	       (if regexp
X		   (if forward 're-search-forward 're-search-backward)
X		 (if forward 'search-forward 'search-backward))
X	       search-string nil t))
X	(if success
X	    (setq other-end
X		  (if forward (match-beginning 0) (match-end 0)))))
X    (quit (setq unread-command-char ?\C-g)
X	  (setq success nil))
X    (invalid-regexp (setq invalid-regexp (car (cdr lossage)))
X		    (if (string-match "\\`Premature \\|\\`Unmatched \\|\\`Invalid "
X				      invalid-regexp)
X			(setq invalid-regexp "incomplete input"))))
X  (if success
X      (vm-update-search-position)
X    ;; Ding if failed this time after succeeding last time.
X    (and (nth 3 (car cmds))
X	 (ding))
X    (goto-char (nth 2 (car cmds)))))
X
X;; This is called from incremental-search
X;; if the first input character is the exit character.
X;; The interactive-arg-reader uses free variables `forward' and `regexp'
X;; which are bound by `incremental-search'.
X
X;; We store the search string in `search-string'
X;; which has been bound already by `incremental-search'
X;; so that, when we exit, it is copied into `search-last-string'.
X
X(defun vm-nonincremental-search (forward regexp)
X  (let (message char function string inhibit-quit
X		(cursor-in-echo-area t))
X    ;; Prompt assuming not word search,
X    (setq message (if regexp 
X		      (if forward "VM Regexp search: "
X			"VM Regexp search backward: ")
X		    (if forward "VM Search: " "VM Search backward: ")))
X    (message "%s" message)
X    ;; Read 1 char and switch to word search if it is ^W.
X    (setq char (read-char))
X    (if (eq char search-yank-word-char)
X	(setq message (if forward "VM Word search: " "VM Word search backward: "))
X      ;; Otherwise let that 1 char be part of the search string.
X      (setq unread-command-char char))
X    (setq function
X	  (if (eq char search-yank-word-char)
X	      (if forward 'word-search-forward 'word-search-backward)
X	    (if regexp
X		(if forward 're-search-forward 're-search-backward)
X	      (if forward 'search-forward 'search-backward))))
X    ;; Read the search string with corrected prompt.
X    (setq string (read-string message))
X    ;; Empty means use default.
X    (if (= 0 (length string))
X	(setq string search-last-string)
X      ;; Set last search string now so it is set even if we fail.
X      (setq search-last-string string))
X    ;; Since we used the minibuffer, we should be available for redo.
X    (setq command-history (cons (list function string) command-history))
X    ;; Go ahead and search.
X    (funcall function string)))
X
X(defun vm-update-search-position (&optional record-change)
X  (if (and (>= (point) (vm-start-of (car vm-message-pointer)))
X	   (<= (point) (vm-end-of (car vm-message-pointer))))
X      nil
X    (let ((mp vm-message-list)
X	  (point (point)))
X      (while mp
X	(if (and (>= point (vm-start-of (car mp)))
X		 (<= point (vm-end-of (car mp))))
X	    (if record-change
X		(setq vm-last-message-pointer vm-message-pointer
X		      vm-message-pointer mp mp nil)
X	      (setq vm-message-pointer mp mp nil))
X	  (setq mp (cdr mp))))
X      (vm-update-summary-and-mode-line)
X      (vm-set-summary-pointer (car vm-message-pointer)))))
X
X(defun vm-isearch-forward ()
X  "Incrementally search forward through the current folder's messages.
XUsage is identical to the standard Emacs incremental search.
XWhen the search terminates the message containing point will be selected."
X  (interactive)
X  (if vm-mail-buffer
X      (set-buffer vm-mail-buffer))
X  (if (null (get-buffer-window (current-buffer)))
X      (progn
X	(display-buffer (current-buffer))
X	(vm-proportion-windows)))
X  (vm-error-if-mailbox-empty)
X  (let ((clip-head (point-min))
X	(clip-tail (point-max))
X	(old-w (selected-window)))
X    (unwind-protect
X	(progn (select-window (get-buffer-window (current-buffer)))
X	       (widen)
X	       (vm-isearch t vm-search-using-regexps)
X	       (vm-update-search-position t)
X	       ;; vm-show-current-message only adjusts (point-max)
X	       (narrow-to-region
X		(if (< (point) (vm-vheaders-of (car vm-message-pointer)))
X		    (vm-start-of (car vm-message-pointer))
X		  (vm-vheaders-of (car vm-message-pointer)))
X		(point-max))
X	       (save-excursion
X		 (vm-show-current-message))
X	       (vm-howl-if-eom-visible)
X	       ;; make the clipping unwind a noop
X	       (setq clip-head (point-min))
X	       (setq clip-tail (point-max)))
X      (narrow-to-region clip-head clip-tail)
X      (select-window old-w))))
SHAR_EOF
chmod 0664 vm-search.el || echo "restore of vm-search.el fails"
sed 's/^X//' << 'SHAR_EOF' > vm-summary.el &&
X;;; Summary gathering and formatting routines for VM
X;;; Copyright (C) 1989 Kyle E. Jones
X;;;
X;;; This program is free software; you can redistribute it and/or modify
X;;; it under the terms of the GNU General Public License as published by
X;;; the Free Software Foundation; either version 1, or (at your option)
X;;; any later version.
X;;;
X;;; This program is distributed in the hope that it will be useful,
X;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
X;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
X;;; GNU General Public License for more details.
X;;;
X;;; You should have received a copy of the GNU General Public License
X;;; along with this program; if not, write to the Free Software
X;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
X
X(require 'vm)
X
X(defun vm-summary-mode ()
X  "Major mode for VM folder summaries.
XThis major mode use the same keymap as vm-mode.  See the vm-mode documentation
Xfor a list of available commands."
X  (setq mode-name "VM Summary"
X	major-mode 'vm-summary-mode
X	mode-line-buffer-identification	'("VM " vm-version ":%b")
X	buffer-read-only t
X	overlay-arrow-string "->"
X	overlay-arrow-position nil
X	truncate-lines t)
X  (use-local-map vm-mode-map)
X  (save-excursion
X    (set-buffer vm-mail-buffer)
X    (vm-set-summary-pointer (car vm-message-pointer))))
X
X(put 'vm-summary-mode 'mode-class 'special)
X
X(defun vm-summarize (&optional dont-redo)
X  "Summarize the contents of the folder in a summary buffer. 
XThe format is as described by the variable vm-summary-format.  Generally
Xone line per message is most pleasing to the eye but this is not
Xmandatory."
X  (interactive "p")
X  (if vm-mail-buffer
X      (set-buffer vm-mail-buffer))
X  (vm-error-if-mailbox-empty)
X  (if (or (null vm-summary-buffer) (not dont-redo))
X      (let ((b (current-buffer))
X	    (inhibit-quit t))
X	(setq vm-summary-buffer
X	      (get-buffer-create (format " %s Summary" (buffer-name))))
X	(save-excursion
X	  (set-buffer vm-summary-buffer)
X	  (abbrev-mode 0)
X	  (auto-fill-mode 0)
X	  (setq vm-mail-buffer b))
X	(vm-do-summary)
X	(save-excursion
X	  (set-buffer vm-summary-buffer)
X	  (vm-summary-mode))))
X  (display-buffer vm-summary-buffer)
X  (vm-proportion-windows)
X  (vm-set-summary-pointer (car vm-message-pointer)))
X
X(defun vm-do-summary ()
X  (let ((mp vm-message-list) summary)
X    (save-excursion
X      (set-buffer vm-summary-buffer)
X      (let ((buffer-read-only nil))
X	(erase-buffer)
X	(while mp
X	  (set-buffer vm-mail-buffer)
X	  (setq summary (vm-summarize-message (car mp)))
X	  (set-buffer vm-summary-buffer)
X	  (vm-set-su-start-of (car mp) (point-marker))
X	  ;; the leading spaces are to make room for the overlay-arrow-string
X	  (insert "  " summary)
X	  (vm-set-su-end-of (car mp) (point-marker))
X	  (setq mp (cdr mp)))))))
X
X(defun vm-update-message-summary (mp)
X  (if vm-summary-buffer
X      (let ((summary (vm-summarize-message (car mp))))
X	(save-excursion
X	  (set-buffer vm-summary-buffer)
X	  (let ((inhibit-quit t) buffer-read-only)
X	    (goto-char (vm-su-start-of (car mp)))
X	    ;; We insert a char here and delete it later to avoid
X	    ;; markers clumping at the beginning of the summary,
X	    (insert "*")
X	    (delete-region (point) (vm-su-end-of (car mp)))
X	    (insert-before-markers "  " summary)
X	    (goto-char (vm-su-start-of (car mp)))
X	    (delete-char 1))))))
X
X;; This function's formal parameter must be `vm-su-message'
X;; so vm-compiled-summary-sexp will work.
X(defun vm-summarize-message (vm-su-message)
X  (if (not (eq vm-compiled-summary-format vm-summary-format))
X      (progn
X	(vm-compile-format vm-summary-format 'vm-compiled-summary-sexp)
X	(setq vm-compiled-summary-format vm-summary-format)))
X  (eval vm-compiled-summary-sexp))
X
X(defun vm-set-summary-pointer (m)
X  (setq overlay-arrow-position (vm-su-start-of m))
X  (cond (vm-summary-buffer
X	 (let ((w (get-buffer-window vm-summary-buffer)))
X	   (save-excursion
X	     (set-buffer vm-summary-buffer)
X	     (goto-char overlay-arrow-position))
X	   (and w (set-window-point w overlay-arrow-position))))))
X
X(defun vm-compile-format (format sexp-variable)
X  (let (sexp sexp-fmt conv-spec last-match-end case-fold-search)
X    (store-match-data nil)
X    (while (string-match
X"%\\(-\\)?\\([0-9]\\)*\\(\\.\\([0-9]+\\)\\)?\\([acdfFhilmnswyz%]\\)"
X	    format (match-end 0))
X      (setq conv-spec (aref format (match-beginning 5)))
X      (if (memq conv-spec '(?a ?c ?d ?f ?F ?h ?i ?l ?m ?n ?s ?w ?y ?z))
X	  (progn
X	    (cond ((= conv-spec ?a)
X		   (setq sexp (cons (list 'vm-su-attribute-indicators
X					  'vm-su-message) sexp)))
X		  ((= conv-spec ?c)
X		   (setq sexp (cons (list 'vm-su-byte-count
X					  'vm-su-message) sexp)))
X		  ((= conv-spec ?d)
X		   (setq sexp (cons (list 'vm-su-monthday
X					  'vm-su-message) sexp)))
X		  ((= conv-spec ?f)
X		   (setq sexp (cons (list 'vm-su-from
X					  'vm-su-message) sexp)))
X		  ((= conv-spec ?F)
X		   (setq sexp (cons (list 'vm-su-full-name
X					  'vm-su-message) sexp)))
X		  ((= conv-spec ?h)
X		   (setq sexp (cons (list 'vm-su-hour
X					  'vm-su-message) sexp)))
X		  ((= conv-spec ?i)
X		   (setq sexp (cons (list 'vm-su-message-id
X					  'vm-su-message) sexp)))
X		  ((= conv-spec ?l)
X		   (setq sexp (cons (list 'vm-su-line-count
X					  'vm-su-message) sexp)))
X		  ((= conv-spec ?m)
X		   (setq sexp (cons (list 'vm-su-month
X					  'vm-su-message) sexp)))
X		  ((= conv-spec ?n)
X		   (setq sexp (cons (list 'vm-su-message-number
X					  'vm-su-message) sexp)))
X		  ((= conv-spec ?s)
X		   (setq sexp (cons (list 'vm-su-subject
X					  'vm-su-message) sexp)))
X		  ((= conv-spec ?w)
X		   (setq sexp (cons (list 'vm-su-weekday
X					  'vm-su-message) sexp)))
X		  ((= conv-spec ?y)
X		   (setq sexp (cons (list 'vm-su-year
X					  'vm-su-message) sexp)))
X		  ((= conv-spec ?z)
X		   (setq sexp (cons (list 'vm-su-zone
X					  'vm-su-message) sexp))))
X	    (cond ((match-beginning 1)
X		   (setcar sexp
X			   (list 'vm-left-justify-string (car sexp)
X				 (string-to-int (substring format
X							   (match-beginning 2)
X							   (match-end 2))))))
X		  ((match-beginning 2)
X		   (setcar sexp
X			   (list 'vm-right-justify-string (car sexp)
X				 (string-to-int (substring format
X							   (match-beginning 2)
X							   (match-end 2)))))))
X	    (cond ((match-beginning 3)
X		   (setcar sexp
X			   (list 'vm-truncate-string (car sexp)
X				 (string-to-int (substring format
X							   (match-beginning 4)
X							   (match-end 4)))))))
X	    (setq sexp-fmt
X		  (cons "%s"
X			(cons (substring format
X					 (or last-match-end 0)
X					 (match-beginning 0))
X			      sexp-fmt))))
X	(setq sexp-fmt
X	      (cons "%%"
X		    (cons (substring format
X				     (or last-match-end 0)
X				     (match-beginning 0))
X			  sexp-fmt))))
X      (setq last-match-end (match-end 0)))
X    (setq sexp-fmt 
X	  (cons (substring format
X			   (or last-match-end 0)
X			   (length format))
X		sexp-fmt)
X	  sexp-fmt (apply 'concat (nreverse sexp-fmt))
X	  sexp (cons 'format (cons sexp-fmt (nreverse sexp))))
X    (set sexp-variable sexp)))
X
X(defun vm-get-header-contents (message header-name)
X  (let (contents regexp)
X    (setq regexp (format vm-header-regexp-format header-name))
X    (save-excursion
X      (set-buffer (marker-buffer (vm-start-of message)))
X      (save-restriction
X	(widen)
X	(goto-char (vm-start-of message))
X	(while (re-search-forward regexp (vm-text-of message) t)
X	  (if contents
X	      (setq contents
X		    (concat
X		     contents ",\n\t"
X		     (buffer-substring (match-beginning 1) (match-end 1))))
X	    (setq contents
X		  (buffer-substring (match-beginning 1) (match-end 1)))))
X	contents))))
X
X(defun vm-left-justify-string (string width)
X  (if (>= (length string) width)
X      string
X    (concat string (make-string (- width (length string)) ?\ ))))
X
X(defun vm-right-justify-string (string width)
X  (if (>= (length string) width)
X      string
X    (concat (make-string (- width (length string)) ?\ ) string)))
X
X(defun vm-truncate-string (string width)
X  (if (<= (length string) width)
X      string
X    (substring string 0 width)))
X
X(defun vm-su-attribute-indicators (m)
X  (concat
X   (cond ((vm-deleted-flag m) "D")
X	 ((vm-new-flag m) "N")
X	 ((vm-unread-flag m) "U")
X	 (t " "))
X   (cond ((vm-filed-flag m) "F")
X	 (t " "))
X   (cond ((vm-replied-flag m) "R")
X	 (t " "))))
X
X(defun vm-su-byte-count (m)
X  (or (vm-byte-count-of m)
X      (vm-set-byte-count-of m (int-to-string
X			       (- (vm-end-of m) (vm-text-of m))))))
X
X(defun vm-su-weekday (m)
X  (or (vm-weekday-of m)
X      (progn (vm-su-do-date m) (vm-weekday-of m))))
X
X(defun vm-su-monthday (m)
X  (or (vm-monthday-of m)
X      (progn (vm-su-do-date m) (vm-monthday-of m))))
X
X(defun vm-su-month (m)
X  (or (vm-month-of m)
X      (progn (vm-su-do-date m) (vm-month-of m))))
X
X(defun vm-su-year (m)
X  (or (vm-year-of m)
X      (progn (vm-su-do-date m) (vm-year-of m))))
X
X(defun vm-su-hour (m)
X  (or (vm-hour-of m)
X      (progn (vm-su-do-date m) (vm-hour-of m))))
X
X(defun vm-su-zone (m)
X  (or (vm-zone-of m)
X      (progn (vm-su-do-date m) (vm-zone-of m))))
X
X(defun vm-su-do-date (m)
X  (let (date)
X    (setq date (vm-get-header-contents m "Date"))
X    (cond
X     ((null date)
X      (vm-set-weekday-of m "")
X      (vm-set-monthday-of m "")
X      (vm-set-month-of m "")
X      (vm-set-year-of m "")
X      (vm-set-hour-of m "")
X      (vm-set-zone-of m ""))
X     ((string-match
X;; The date format recognized here is the one specified in RFC 822.
X;; Some slop is allowed e.g. dashes between the monthday, month and year
X;; because such malformed headers headers have been observed,
X"\\(\\([a-z][a-z][a-z]\\),\\)?[ \t\n]*\\([0-9][0-9]?\\)[ \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]\\)"
X       date)
X      (if (match-beginning 2)
X	  (vm-set-weekday-of m (substring date (match-beginning 2)
X					  (match-end 2)))
X	(vm-set-weekday-of m ""))
X      (vm-set-monthday-of m (substring date (match-beginning 3) (match-end 3)))
X      (vm-set-month-of m (substring date (match-beginning 4) (match-end 4)))
X      (vm-set-year-of m (substring date (match-beginning 5) (match-end 5)))
X      (vm-set-hour-of m (substring date (match-beginning 6) (match-end 6)))
X      (vm-set-zone-of m (substring date (match-beginning 7) (match-end 7))))
X     ((string-match
X;; UNIX ctime(3) format with slop allowed in the whitespace and we allow for
X;; the possibility of a timezone at the end.
X"\\([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]\\)?"
X       date)
X      (vm-set-weekday-of m (substring date (match-beginning 1) (match-end 1)))
X      (vm-set-month-of m (substring date (match-beginning 2) (match-end 2)))
X      (vm-set-monthday-of m (substring date (match-beginning 3) (match-end 3)))
X      (vm-set-hour-of m (substring date (match-beginning 4) (match-end 4)))
X      (vm-set-year-of m (substring date (match-beginning 5) (match-end 5)))
X      (if (match-beginning 6)
X	  (vm-set-zone-of m (substring date (match-beginning 6)
X				       (match-end 6)))))
X     (t
X      (vm-set-weekday-of m "")
X      (vm-set-monthday-of m "")
X      (vm-set-month-of m "")
X      (vm-set-year-of m "")
X      (vm-set-hour-of m "")
X      (vm-set-zone-of m "")))))
X
X(defun vm-su-full-name (m)
X  (or (vm-full-name-of m)
X      (progn (vm-su-do-author m) (vm-full-name-of m))))
X
X(defun vm-su-from (m)
X  (or (vm-from-of m)
X      (progn (vm-su-do-author m) (vm-from-of m))))
X
X(defun vm-su-do-author (m)
X  (let (full-name from)
X    (setq full-name (vm-get-header-contents m "Full-Name"))
X    (setq from (vm-get-header-contents m "From"))
X    (cond ((null from)
X	   (setq from "???")
X	   (if (null full-name)
X	       (setq full-name "???")))
X	  ((string-match "^\\(\\([^<]+[^ \t\n]\\)[ \t\n]+\\)?<\\([^>]+\\)>"
X			 from)
X	   (if (and (match-beginning 2) (null full-name))
X	       (setq full-name
X		     (substring from (match-beginning 2) (match-end 2))))
X	   (setq from (substring from (match-beginning 3) (match-end 3))))
X	  ((string-match "[\000-\177]*(\\([^)]+\\))[\000-\177]*" from)
X	   (if (null full-name)
X	       (setq full-name (substring from (match-beginning 1)
X					  (match-end 1))))
X	   (setq from
X		 (concat
X		  (substring from (match-beginning 0) (1- (match-beginning 1)))
X		  (substring from (1+ (match-end 1)) (match-end 0))))))
X    ;; ewe ewe see pee...
X    (if (and vm-gargle-uucp (string-match
X"\\([^!@:.]+\\)\\(\\.[^!@:]+\\)?!\\([^!@: \t\n]+\\)\\(@\\([^!@:. \t\n]+\\)\\(.[^ \t\n]+\\)?\\)?[ \t\n]*$"
X			     from))
X	(setq from
X	      (concat
X	       (substring from (match-beginning 3) (match-end 3)) "@"
X	       (if (and (match-beginning 5) (match-beginning 2)
X			(not (match-beginning 6)))
X		   (concat (substring from (match-beginning 5) (match-end 5))
X			   ".")
X		 "")
X	       (substring from (match-beginning 1)
X			  (or (match-end 2) (match-end 1)))
X	       (if (match-end 2) "" ".UUCP"))))
X    (if (or (null full-name) (string-match "^[ \t\n]*$" full-name))
X	(setq full-name from))
X    (vm-set-full-name-of m full-name)
X    (vm-set-from-of m from)))
X
X(defun vm-su-message-id (m)
X  (or (vm-message-id-of m)
X      (vm-set-message-id-of m
X			    (or (vm-get-header-contents m "Message-Id")
X				""))))
X
X(defun vm-su-line-count (m)
X  (or (vm-line-count-of m)
X      (vm-set-line-count-of
X       m
X       (save-restriction
X	 (widen)
X	 (int-to-string
X	  (count-lines (vm-text-of m) (vm-end-of m)))))))
X
X(defun vm-su-message-number (m)
X  (vm-number-of m))
X
X(defun vm-su-subject (m)
X  (or (vm-subject-of m)
X      (vm-set-subject-of m
X			 (or (vm-get-header-contents m "Subject") ""))))
SHAR_EOF
chmod 0664 vm-summary.el || echo "restore of vm-summary.el fails"
sed 's/^X//' << 'SHAR_EOF' > vm-undo.el &&
X;;; Commands to undo message attribute changes in VM
X;;; Copyright (C) 1989 Kyle E. Jones
X;;;
X;;; This program is free software; you can redistribute it and/or modify
X;;; it under the terms of the GNU General Public License as published by
X;;; the Free Software Foundation; either version 1, or (at your option)
X;;; any later version.
X;;;
X;;; This program is distributed in the hope that it will be useful,
X;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
X;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
X;;; GNU General Public License for more details.
X;;;
X;;; You should have received a copy of the GNU General Public License
X;;; along with this program; if not, write to the Free Software
X;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
X
X(require 'vm)
X
X(defun vm-undo-boundary ()
X  (if (car vm-undo-record-list)
X      (setq vm-undo-record-list (cons nil vm-undo-record-list))))
X
X(defun vm-clear-expunge-invalidated-undos ()
X  (let ((udp vm-undo-record-list) udp-prev)
X    (while udp
X      (cond ((null (car udp))
X	     (setq udp-prev udp))
X	    ((and (not (eq (car (car udp)) 'set-buffer-modified-p))
X		  (vm-deleted-flag (car (cdr (car udp)))))
X	     (cond (udp-prev (setcdr udp-prev (cdr udp)))
X		   (t (setq vm-undo-record-list (cdr udp)))))
X	    (t (setq udp-prev udp)))
X      (setq udp (cdr udp)))
X    (vm-clear-modification-flag-undos))
X  (vm-squeeze-consecutive-undo-boundaries))
X	    
X(defun vm-clear-modification-flag-undos ()
X  (let ((udp vm-undo-record-list) udp-prev)
X    (while udp
X      (cond ((null (car udp))
X	     (setq udp-prev udp))
X	    ((eq (car (car udp)) 'set-buffer-modified-p)
X	     (cond (udp-prev (setcdr udp-prev (cdr udp)))
X		   (t (setq vm-undo-record-list (cdr udp)))))
X	    (t (setq udp-prev udp)))
X      (setq udp (cdr udp))))
X  (vm-squeeze-consecutive-undo-boundaries))
X
X;; squeeze out consecutive record separators left by the deletions
X(defun vm-squeeze-consecutive-undo-boundaries ()
X  (let ((udp vm-undo-record-list) udp-prev)
X    (while udp
X      (cond ((and (null (car udp)) udp-prev (null (car udp-prev)))
X	     (setcdr udp-prev (cdr udp)))
X	    (t (setq udp-prev udp)))
X      (setq udp (cdr udp)))
X    (if (equal '(nil) vm-undo-record-list)
X	(setq vm-undo-record-list nil))))
X	    
X(defun vm-undo-record (sexp)
X  (setq vm-undo-record-list (cons sexp vm-undo-record-list)))
X
X(defun vm-undo ()
X  "Undo last change to message attributes in the current folder.
XConsecutive invocations of this command cause sequentially earlier
Xchanges to be undone.  After an intervening command between undos,
Xthe undos themselves become undoable."
X  (interactive)
X  (if vm-mail-buffer
X      (set-buffer vm-mail-buffer))
X  (let ((inhibit-quit t))
X    (if (not (eq last-command 'vm-undo))
X	(setq vm-undo-record-pointer vm-undo-record-list))
X    (if (not vm-undo-record-pointer)
X	(error "No further VM undo information available"))
X    ;; skip current record boundary
X    (setq vm-undo-record-pointer (cdr vm-undo-record-pointer))
X    (while (car vm-undo-record-pointer)
X      (eval (car vm-undo-record-pointer))
X      (setq vm-undo-record-pointer (cdr vm-undo-record-pointer)))
X    (message "VM Undo!")
X    (vm-update-summary-and-mode-line)))
X
X(defun vm-set-new-flag (m flag)
X  (let ((inhibit-quit t))
X    (cond ((not (buffer-modified-p))
X	   (set-buffer-modified-p t)
X	   (vm-undo-record (list 'set-buffer-modified-p nil))))
X    (vm-undo-record (list 'vm-set-new-flag m (not flag)))
X    (vm-undo-boundary)
X    (aset (aref m 5) 0 flag)
X    (vm-mark-for-display-update m)))
X
X(defun vm-set-unread-flag (m flag)
X  (let ((inhibit-quit t))
X    (cond ((not (buffer-modified-p))
X	   (set-buffer-modified-p t)
X	   (vm-undo-record (list 'set-buffer-modified-p nil))))
X    (vm-undo-record (list 'vm-set-unread-flag m (not flag)))
X    (vm-undo-boundary)
X    (aset (aref m 5) 1 flag)
X    (vm-mark-for-display-update m)))
X
X(defun vm-set-deleted-flag (m flag)
X  (let ((inhibit-quit t))
X    (cond ((not (buffer-modified-p))
X	   (set-buffer-modified-p t)
X	   (vm-undo-record (list 'set-buffer-modified-p nil))))
X    (vm-undo-record (list 'vm-set-deleted-flag m (not flag)))
X    (vm-undo-boundary)
X    (aset (aref m 5) 2 flag)
X    (vm-mark-for-display-update m)))
X
X(defun vm-set-filed-flag (m flag)
X  (let ((inhibit-quit t))
X    (cond ((not (buffer-modified-p))
X	   (set-buffer-modified-p t)
X	   (vm-undo-record (list 'set-buffer-modified-p nil))))
X    (vm-undo-record (list 'vm-set-filed-flag m (not flag)))
X    (vm-undo-boundary)
X    (aset (aref m 5) 3 flag)
X    (vm-mark-for-display-update m)))
X
X(defun vm-set-replied-flag (m flag)
X  (let ((inhibit-quit t))
X    (cond ((not (buffer-modified-p))
X	   (set-buffer-modified-p t)
X	   (vm-undo-record (list 'set-buffer-modified-p nil))))
X    (vm-undo-record (list 'vm-set-replied-flag m (not flag)))
X    (vm-undo-boundary)
X    (aset (aref m 5) 4 flag)
X    (vm-mark-for-display-update m)))
SHAR_EOF
chmod 0664 vm-undo.el || echo "restore of vm-undo.el fails"
exit 0