;;; -*- Mode:Common-Lisp; Package:YW-ZWEI; Base:10 -*-

;;; **********************************************************************
;;; Copyright (c) 1990 Stanford University.
;;; This code was written by James Rice.
;;; Copyright is held by Stanford University except where code has been
;;; modified from TI source code.  In these cases TI code is marked with
;;; a suitable comment.

;;; All Stanford Copyright code is in the public domain.  This code may be
;;; distributed and used without restriction as long as this copyright
;;; notice is included and no fee is charged.  This can be thought of as
;;; being equivalent to the Free Software Foundation's Copyleft policy.

;;; TI source code may only be distributed to users who hold valid TI
;;; software licenses.

;;; The development of this software was assisted by the following grants:
;;; Biomedical Research Technology Program of the National Institutes
;;; of Health under grant RR-00785
;;; Information Systems Technologies office of the Defense Advanced
;;; Research Projects Agency under contract N00039-86-C0033.

;;; **********************************************************************

(defun default-yw-zmacs-size ()
  (Multiple-Value-Bind (Screen-Width Height) (Send tv:Main-Screen :Size)
    (let ((font :Default))
         (tv:coerce-font font tv:default-screen)
	 (values (min screen-width (+ 20 (* 81 (tv:font-char-width font))))
		 height
         )
    )
  )
)


(defun Make-default-yw-zmacs-frame ()
  (Multiple-Value-Bind (zmacs-Width Height) (default-Yw-Zmacs-Size)
    (Let ((New-window
	      (tv:Make-Window
		  'Zwei:Zmacs-Frame
		  :Borders 1
		  :Width Zmacs-width
		  :Height Height
		  :Expose-p nil
		  :Activate-p t
	      )
	  )
	 )
	 New-window
    )
  )
)


(defun all-yw-read-buffers ()
  (remove-if-not #'(lambda (x) (equal :Read (get x :Buffer-Type)))
		 zwei:*zmacs-buffer-list*
  )
)

(defun Load-Up-Mail-Buffer-1
       (select-flag buffer buffer-stream header header-epsilon
	body body-epsilon redisplayed-p add-newline-p
       )
  (when select-flag
    (send buffer :activate)
    (make-buffer-current buffer)
    (multiple-value-bind (header-line-index header-redisplayed)
	(copy-string-to-stream header buffer-stream buffer
		    (if select-flag 0 100000000)
		    (or header-epsilon most-positive-fixnum)
	)
      (if add-newline-p
	  (terpri buffer-stream)
	  nil
      )
      (multiple-value-bind (body-line-index body-redisplayed)
	(Copy-String-To-Stream body buffer-stream buffer header-line-index
	  (or body-epsilon most-positive-fixnum)
	)
	(ignore body-line-index)
	(setq redisplayed-p (or header-redisplayed body-redisplayed))
      )
    )
  )
  nil
)

(defun Load-Up-Mail-Buffer
       (buffer buffer-fonts header body add-newline-p select-flag
	&optional (new-buffer-p t)
       )
  (declare (values redisplayed-p))
  (if select-flag (send *window* :Mouse-Select))
  (send buffer :set-attribute :Fonts buffer-fonts)
  (initialize-buffer-package buffer)
  (let ((redisplayed-p nil))
       (preserve-buffer-point (buffer)
	 (with-read-only-suppressed (buffer)
	   (let ((*batch-undo-save* t))
	     (discard-undo-information buffer)
	     (if new-buffer-p
		 (progn (delete-interval buffer)
			(setf (buffer-tick buffer) (tick))
			(setf (buffer-file-read-tick buffer) *tick*)
		 )
		 nil
	     )
	     (let ((fonts (set-buffer-fonts buffer))
		   fonts-p)
	       (setq fonts-p
		     (or *allow-epsilon-font-shifts-in-incoming-mail-p*
			 (cdr fonts) (send buffer :get-attribute :diagram)))
	       (let ((buffer-stream
		       (interval-stream-into-bp
			 (if new-buffer-p
			     (interval-first-bp buffer)
			     (interval-last-bp  buffer)
			 )
			 fonts-p
		       )
		     )
		     (header-epsilon
		       (and fonts-p
			    (sys:%string-search-char #\epsilon header
						     0 (length header)
			    )
		       )
		     )
		     (body-epsilon
		       (and fonts-p
			    (sys:%string-search-char
			      #\epsilon body 0 (length body)
			    )
		       )
		     )
		    )
		 (let ((result
			 (catch 'do-it-the-slow-way
			   (Load-Up-Mail-Buffer-1 Select-flag buffer
			     buffer-stream header header-epsilon
			     body body-epsilon redisplayed-p
			     add-newline-p
			   )
			 )
		       )
		      )
		      (if result
			  (Copy-String-To-Stream-The-Slow-Way
			    header body buffer add-newline-p
			  )
			  nil
		      )
		 )
	       )
	       (setf (buffer-file-read-tick buffer) *tick*)
	       (not-modified buffer)))))
       (setf (buffer-tick buffer) (tick))
  redisplayed-p
  )
)

(defmethod (zwei:interval-stream-with-fonts :maybe-fontified-string-out)
	   (fontified-p string &optional (start 0) end (original-string string))
  (if fontified-p
      (send self :string-out string start end original-string)
      ;; from :string-out
      (let-if zwei:no-undo-saving ((zwei:*batch-undo-save* t))
	      (let ((bp (zwei:insert (create-bp zwei:*line* zwei:*index*)
				     string start end
			)
		    )
		   )
		   (setq zwei:*line* (bp-line bp)
			 zwei:*index* (bp-index bp)
		   )
		   end
	      )
      )
  )
)

(defvar *windows-not-to-redisplay-twice* nil)

(defun Copy-String-To-Stream-The-Slow-Way (header body buffer add-newline-p)
  (zwei:kill-interval (interval-first-bp buffer) (interval-last-bp buffer))
  (with-open-stream
    (stream (zwei:interval-stream
	      (interval-first-bp buffer) (interval-last-bp buffer) nil t t
	    )
    )
    (let ((old-sharp-dot #'sys:sharp-dot))
         (letf ((#'sys:sharp-dot
		 #'(lambda (&rest args)
		     (beep 'tv:notify)
		     (if (y-or-n-p "~&Warning:  This message has a #. reader ~
                                    macro hidden in a font shift.~
                                    ~%Should I go ahead and evaluate it?"
                         )
			 (apply old-sharp-dot args)
			 nil
		     )
		   )
		)
	       )
	       (princ header stream)
	       (terpri stream)
	       (if add-newline-p
		   (terpri stream)
		   nil
	       )
	       (princ body stream)
	 )
    )
  )
)

(defun copy-string-to-stream (string stream buffer line-count epsilon-index)
  (if (equal 0 (array-active-length string))
      (values line-count nil)
      (let ((start-index 0)
	    (index 0)
	    (length (array-active-length string))
	    (redisplay-point (+ 5 (window-n-plines *window*)))
	    (redisplayed-p nil)
	    (epsilon-sub-index nil)
	   )
	   (loop until (or (not index) (>= index length))
		 do (setq start-index index)
		    (setq index
			 (sys:%string-search-char #\newline string index length)
		    )
		    (setq epsilon-sub-index
			  (if epsilon-index
			      (sys:%string-search-char
				#\epsilon string start-index index
			      )
			      nil
			  )
		    )
		    (loop while (and epsilon-sub-index
				     (< epsilon-sub-index index)
				)
			  do (if (char= (aref string (+ 1 epsilon-sub-index))
					#\#
				 )
				 (throw 'do-it-the-slow-way start-index)
				 nil
			     )
			     (setq epsilon-sub-index
				   (sys:%string-search-char
				     #\epsilon string (+ 1 epsilon-sub-index)
				     index
				   )
			     )
		    )
		    (setq index (+ index 1))
		 when index
		 do (send stream :Maybe-Fontified-String-Out
			  (>= index epsilon-index) string
			  start-index index
		    )
		    (setq start-index index)
		    (setq line-count (+ 1 line-count))
		 when (= line-count redisplay-point)
		 do (redisplay *window* :start (interval-first-bp buffer) nil)
		    (push *window* *Windows-Not-To-Redisplay-Twice*)
		    (Setq redisplayed-p t)
		 finally
		   (send stream :Maybe-Fontified-String-Out
			 (>= index epsilon-index) string
			 start-index length
		   )
	   )
	   (values line-count redisplayed-p)
      )
  )
)

;(defwhopper (zwei:zmacs-window-pane :Refresh) (&rest args)
;      (lexpr-continue-whopper args)
;)

(defun make-non-read-buffer-name (title-string read-buffer)
  (let ((name-string
	  (if (stringp read-buffer) read-buffer (send read-buffer :name))
	)
       )
       (format nil "~A: ~A" title-string
	       (subseq name-string (+ 1 (or (position #\space name-string) 0)))
       )
  )
)

(defun Open-YW-Buffer (read-buffer title-string buffer-type buffer-type-name)
  (declare (values buffer freshly-created-p))
  (let ((name (make-non-read-buffer-name title-string read-buffer)))
       (let ((existing (find-buffer-named name)))
	    (if (and existing
		     (case *reselect-previous-buffer*
		       (nil nil)
		       (:Ask (y-or-n-p "Use previous buffer for this message ~
                                        as a template?"
			     )
		       )
		       (otherwise t)
		     )
		)
		(values existing nil)
	        (let ((*new-buffer* nil)
		      (was-read-only (node-read-only-p read-buffer))
		      (name
			(if existing
			    (string-append name "-" (symbol-name (gensym "")))
			    name
			)
		      )
		     )
		     (declare (special *new-buffer*))
		     (unwind-protect
			 (progn (make-buffer-not-read-only read-buffer)
				(funcall
				  (get-mail-template-function
				    buffer-type
				  )
				  name
				)
			 )
		       (if was-read-only (make-buffer-read-only read-buffer))
		     )
		     (make-buffer-not-read-only *new-buffer*)
		     (setf (get *new-buffer* :read-buffer) read-buffer)
		     (setf (get *new-buffer* :Buffer-Type) buffer-type-name)
		     (setf (get *new-buffer* :Source-Mailer)
			   (get read-buffer  :Source-Mailer)
		     )
		     (setf (get *new-buffer* :Message-Sequence)
			   (get read-buffer  :Message-Sequence)
		     )
		     (setf (get *new-buffer* :Message-cache-entry)
			   (get read-buffer  :Message-cache-entry)
		     )
		     (if (get read-buffer :Message-cache-entry)
			 (pushnew *new-buffer*
				  (yw:cache-associated-zmacs-buffers
				    (get read-buffer :Message-cache-entry)
				  )
			 )
			 nil
		     )
		     (values *new-buffer* t)
		)
	    )
      )
  )
)


(defun Open-Reply-Buffer (in-reply-to)
  (declare (values buffer freshly-created-p))
  (Open-Yw-Buffer in-reply-to "Reply to" 'default-yw-reply-to-sender-template
		  :Reply
  )
)

(defun Open-digest-Buffer (name sequence)
  (declare (values buffer freshly-created-p))
  (let ((*new-buffer* nil)
	(*sequence* sequence)
       )
       (declare (special *new-buffer* *sequence*))
       (funcall
	 (get-mail-template-function 'default-yw-digest-template) name
       )
       *new-buffer*
  )
)

(defun Open-Forward-Buffer (read-buffer)
  (declare (values buffer freshly-created-p))
  (Open-Yw-Buffer read-buffer "Forward " 'default-yw-forward-template :forward)
)

(defun Open-Remail-Buffer (read-buffer)
  (declare (values buffer freshly-created-p))
  (Open-Yw-Buffer read-buffer "Remail " 'default-yw-remail-template :remail)
)

(defun open-read-buffer (name)
  (let ((*new-buffer* nil))
       (declare (special *new-buffer*))
       (funcall
	 (get-mail-template-function 'default-yw-read-mail-template) name
       )
       *new-buffer*
  )
)

(defun remember-parsed-message (buffer)
  (let ((msg (read-message
	       (interval-stream (send buffer :First-Bp) (send buffer :Last-Bp))
	     )
	)
       )
       (send msg :Set-Superior buffer)
       (putprop buffer msg :parsed-message)
       buffer
  )
)

(defun make-yw-mail-template-buffer
       (buffer-name template-type &optional (selectp t))

  (fs:force-user-to-login)
  (if (find-buffer-named buffer-name)
      (barf "~&Buffer ~S aready exists." buffer-name)
  )
  (let ((buffer (make-instance 'zwei:zmacs-buffer :Name buffer-name)))
    (push buffer *unsent-message-list*)
    (send buffer :set-major-mode 'zwei:text-mode)
    (setf (get buffer :mail-template-type) template-type)
    (when (or (eq template-type :reply)
	      (eq template-type :forward))
      (setf (get buffer :message-object) *msg*))
    (when selectp 
      (send buffer :select)
      (turn-on-mode 'zwei:mail-mode)
      (when *mail-mode-hook*
	(funcall *mail-mode-hook*)))
  buffer))

(defmacro define-yw-mail-template
	  (symbol name-string type doc-string &rest body)
"Define a mail template to initialize the contents of a buffer for sending mail.
SYMBOL is used as an identifier for the template.
NAME-STRING is used for a menu of templates and buffer names
(which may be changed by the template).  TYPE specifies the usage
of the template -- it should normally be :mail, :reply, :Forward
or :bug-from-error-handler.  DOC-STRING is used for who line
documentation within the template menu."
  `(eval-when (load eval)
     (define-mail-template-1 ',symbol ,name-string ',type ,doc-string)
     (defun (:property ,symbol :mail-template-function)
	    (&optional (buffer-name) &aux (zwei:*batch-undo-save* t))
       (declare (special *new-buffer*))
       ,doc-string
       (setq *new-buffer*
	     (Make-Yw-Mail-Template-Buffer
	       (or buffer-name ,name-string) ,type t)
       )
       (progn
	 . ,body)
       (send *interval* :not-modified)
       (discard-undo-information *interval*)
       dis-text)))


(define-yw-mail-template default-yw-read-mail-template "Read" :mail
  "Read a mail message."
  (move-bp (point) (mark)))

(defun get-message-header-all (msg type)
  (let ((result (zwei:get-message-header-all msg type)))
       (loop for x in result
	     collect (if (consp x)
			 (getf x :Header)
			 x
		     )
       )
  )
)

(defun address-of-type-supplied-p (type)
  (let ((headers (get-message-header-all *msg* type)))
       (and headers
	    (loop for head in headers
		  when (send head :Address-List)
		  return t
	    )
       )
  )
)

(define-yw-mail-template default-yw-reply-to-sender-template
		      "Reply To Sender" :reply
  "Reply only to the sender of the current message."
  (assure-message-parsed *msg* t)
  (insert-default-header-fields (point))
  (let* ((to (collect-message-addresses
	       *msg*
	       (if (Address-Of-Type-Supplied-P :Reply-To)
		   ;;; make sure that if we are replying to multiple we
		   ;;; filter out :from field if we have a :reply-to.
		   '(:reply-to :to)
		   '(:From :To)
	       )
	       (not yw:*reply-to-all-by-default*)
	       (list (mail:default-from-address))
	     )
	 )
	 (cc (if yw:*reply-to-all-by-default*
		 (collect-message-addresses *msg* '(:cc) nil
		   (if (or zwei:*default-bcc-string*
			   zwei:*default-fcc-string*
		       )
		       (cons (mail:default-from-address)
			     (cons zwei:*default-bcc-string* to)
		       )
		       nil
		   )
		 )
		 nil
	     )
	 )
	 (subject (get-message-header *msg* :subject :interval)))
    (if to
	(insert-address-list (point) :to to)
	(insert-header-field (point) :to))
    (if cc
	(insert-address-list (point) :Cc cc)
	(insert-header-field (point) :CC))
    (insert-header-field (point) :subject nil nil)
    (when subject 
      (if (not (search (interval-first-bp subject)
		       "RE:" nil nil nil (interval-last-bp subject)
	       )
	  )
	  (insert-moving (point) "Re: "))
      (insert-interval-moving (point) subject))
    (insert-moving (point) #\return)
    (insert-in-reply-to-field *msg*)
    (insert-moving (point) #\return)))

(defvar *digest-separator*
  "----------------------------------------------------------------------

"
)

(defmethod digestify-header ((message t) (sequence t) (mode t))
  (yw:map-fetch-subject (send sequence :Mailstream) message)
)

(defmethod Digestify-Header
	   ((message t) (sequence t) (mode (eql :just-subject)))
  (yw:map-fetch-subject (send sequence :Mailstream) message)
)

(defmethod Digestify-Header
	   ((message t) (sequence t) (mode (eql :like-window)))
  (let ((descriptor (yw:descriptor-of message (send sequence :Mailstream))))
       (yw:without-tabs-1
	 (yw:coerce-to-thin-string
	   (with-output-to-string (*standard-output*) (princ descriptor))
	 )
       )
  )
)

(defmethod Digestify-Header
	   ((message t) (sequence t) (mode (eql :date-from-subject)))
  (let ((descriptor (yw:descriptor-of message (send sequence :Mailstream)))
	(yw:*Message-Header-Display-Specification*
	  (list :Date (getf yw:*Message-Header-Display-Specification* :Date)
		:From (getf yw:*Message-Header-Display-Specification* :From)
		:Subject
		  (getf yw:*Message-Header-Display-Specification* :subject)
	  )
	)
       )
       (yw:without-tabs-1
	 (yw:coerce-to-thin-string
	   (send descriptor :get-and-format-header)
	 )
       )
  )
)

(define-yw-mail-template default-yw-digest-template
		      "Digest" :digest
  "Digest of a number of messages."
  (let ((sequence *sequence*))
       (declare (special *sequence*))
       (insert-default-header-fields (point))
       (insert-header-field (point) :To nil nil)
       (let ((saved-point (copy-bp (point))))
	    (insert-moving (point) #\return)
	    (insert-header-field (point) :CC)
	    (insert-header-field (point) :subject nil nil)
	    (insert-moving (point) (yw:make-digest-buffer-name sequence))
	    (insert-moving (point) #\return)
	    (insert-moving (point) #\return)
	    (insert-moving (point) "Digest of the following messages:")
	    (insert-moving (point) #\return)
	    (let ((messages (send self :Numberise-Messages-In-Order)))
		 (loop for message in messages
		       for descriptor =
			   (yw:descriptor-of
			     message (send sequence :Mailstream)
			   )
		       do
		       (yw:maybe-preempt-envelopes
			 (send sequence :Mailstream) message
		       )
		       (insert-moving (point) "  ")
		       (insert-moving (point)
			 (Digestify-Header message sequence
					   yw:*header-digestification-mode*
			 )
		       )
		       (insert-moving (point) #\return)
		 )
		 (loop for i from 1 to 4 do (insert-moving (point) #\return))
		 (loop for message in messages
		       for descriptor =
			   (yw:descriptor-of
			     message (send sequence :Mailstream)
			   )
		       do
		       (insert-moving (point) *Digest-Separator*)
		       (let ((yw:*filter-headers* t)
			     (yw:*header-types-to-include*
			       '(:Date :From :Reply-To :Subject)
			     )
			     (yw:*post-process-header-actions*
			       (cons '(:From insert->)
				     yw:*post-process-header-actions*
			       )
			     )
			    )
			    (send sequence :Insert-Text-Into-Zmacs
				  'si:null-stream *interval* message
				  (send *window* :Superior) nil
			    )
		       )
		       (move-bp (point) (interval-last-bp *interval*))
		 )
	    )
	    (move-bp (point) saved-point)
	    (move-bp (mark) saved-point)
       )
  )
)  

(defun insert-> (header buffer)
  (ignore buffer)
  (format nil ">~A" (send header :String))
)

(defun named-part-of-address (address)
  (let ((string (zwei:string-interval address)))
       (let ((address-object (mail:parse-address string)))
	    (if (typep address-object 'mail:named-address)
		(let ((name (send address-object :Name)))
		     (if (and name (not (equal "" name)))
			 name
			 nil
		     )
		)
		nil
	    )
       )
  )
)

(defun insert-forward-message-subject (from subject)
  (insert-header-field (point) :subject "[" nil)
  (when from
    (if *use-shortened-from-name-in-forwarded-subject-field-p*
	(let ((named-part (named-part-of-address from)))
	     (if named-part
		 (insert-moving (point) named-part)
		 (insert-interval-moving (point) from)
	     )
	)
	(insert-interval-moving (point) from)
    )
    (insert-moving (point) ":  "))
  (when subject
    (insert-interval-moving (point) subject))
  (insert-moving (point) "]")
)

(Define-yw-mail-template default-yw-forward-template "Forward" :forward
  "Forward the current message to another user.  With a prefix arg, headers
of inserted message are not reformatted."
  
  (or *msg* (barf "There is no message to forward."))

  (insert-default-header-fields (point))
  ;Questionable whether to exclude :FCC and :BCC.
  (assure-message-parsed *msg*)
  (insert-header-field  (point) :to nil nil)
  (move-bp (mark) (point))
  (insert-moving (point) #\return)
  (let ((from    (get-message-header *msg* :from :interval))
	(subject (get-message-header *msg* :subject :interval)))
    (insert-forward-message-subject from subject)
  )
  (insert-moving (point) #\return)
  (insert-moving (point) #\return)
  (when (stringp *forwarded-message-begin*)
    (insert-moving (point) #\return)
    (insert-moving (point) *forwarded-message-begin*)
    (insert-moving (point) #\return)
    (insert-moving (point) #\return))
  ;; insert forwarded message 
  (with-open-stream (out (interval-stream-into-bp (point)))
    (print-formatted-message *msg* out nil nil (not *numeric-arg-p*)))
  (move-bp (point) (interval-last-bp *interval*))
  (insert-moving (point) #\return)
  (when (stringp *forwarded-message-end*)
    (insert-moving (point) *forwarded-message-end*)
    (insert-moving (point) #\return)
    (insert-moving (point) #\return))
  (move-bp (point) (mark))
  dis-none)

(define-yw-mail-template DEFAULT-yw-REmail-TEMPLATE "Remail" :mail
  "Send current message again."

  (or *msg* (barf "There is no message to remail"))
  (insert-default-header-fields (point) :reply-to :bcc :from :fcc)
  (with-open-stream (out (interval-stream-into-bp (point)))
    (let ((*reformat-headers-body-goal-column*
	    *mail-template-header-body-goal-column*))
      (print-formatted-message *msg* out nil :headers)))
  (move-bp (point) (interval-last-bp *interval*))
  (insert-header-field
    (point) :resent-from (send (mail:default-from-address) :string-for-message))
  (insert-header-field (point) :resent-to nil nil)
  (move-bp (mark) (point))
  (insert-moving (point) #\return)
  (insert-moving (point) #\return)
  (with-open-stream (out (interval-stream-into-bp (point)))
    (print-formatted-message *msg* out nil :text))
  (move-bp (point) (mark)))

(defun find-blank-line (buffer bp &optional (use-bp-p nil))
  (do-lines (:Start-Line (if (and (typep buffer 'zwei:node) (not use-bp-p))
			     (bp-line (send buffer :First-Bp))
			     (bp-line bp)
			 )
	     :Stop-Line  (send buffer :Last-Bp)
	    )
    (if (equal "" line) (return (create-bp line 0)) nil)
  )
)

(defun Indent-Message-Text
       (new-buffer &optional (start-point nil) (stop-point nil))
  (if start-point
      (move-bp (mark) start-point)
      (if yw:*include-source-header-in-reply*
	  (move-bp (mark)
	    (find-blank-line new-buffer
	     (find-blank-line new-buffer start-point t) t
	    )
	  )
	  (move-bp (mark) (find-blank-line new-buffer start-point t))
      )
  )
  (if stop-point
      (move-bp (point) stop-point)
      (move-bp (point) (send new-buffer :Last-Bp))
  )
  (If yw:*indent-text-for-message-replies*
      (let ((*numeric-arg-p* nil))
	   (setf (window-mark-p *window*) t)
	   (com-indent-for-mail-reply)
      )
      nil
  )
)

(defun standard-in-message-text (cache-entry)
  (format nil "On ~A, ~A said:" (yw:cache-internaldate cache-entry)
	  (yw:cache-fromtext cache-entry)
  )
)

(defun maybe-include-in-message...-text (source-buffer interval-stream)
  (let ((cache (get source-buffer :Message-Cache-Entry)))
       (if (and yw:*include-in-message...-in-reply* cache)
	   (progn (loop for function
			in yw:*in-message...-components-to-include* do
			(princ (funcall function cache) interval-stream)
			(terpri interval-stream)
		  )
		  (terpri interval-stream)
	   )
	   nil
       )
  )
)

(defun include-message-text (new-buffer in-reply-to &optional (new-line-p nil))
  (let ((top (send in-reply-to :First-Bp))
	(bottom (send in-reply-to :Last-Bp))
	(current (copy-bp (point) :Moves))
       )
       (send new-buffer :Select)
;       (com-goto-end)
       (with-open-stream
	 (ostr (interval-stream (point) (point)))
	 (if new-line-p (progn (terpri ostr) (terpri ostr)) nil)
	 (let ((start-of-text nil)
	       (end-of-header-found nil)
	      )
	      (do-lines (:Start-Line (bp-line top) :Stop-Line (bp-line bottom))
		(if start-of-text
		    (progn (princ line ostr)
			   (terpri ostr)
		    )
		    (if yw:*include-source-header-in-reply*
			(progn (setq start-of-text (create-bp line 0))
			       (Maybe-Include-In-Message...-Text
				 in-reply-to ostr
			       )
			)
			(if (and end-of-header-found (not start-of-text))
			    (progn (setq start-of-text
					 (create-bp (bp-line current) 0 nil)
				   )
				   (Maybe-Include-In-Message...-Text
				     in-reply-to ostr
				   )
				   (princ line ostr)
				   (terpri ostr)
			    )
			    (if (equal line "")
				(setq end-of-header-found t)
				nil
			    )
			)
		    )
		)
	      )
	      (indent-message-text new-buffer start-of-text current)
	 )
	 (move-bp (point) current)
       )
  )
)

(defun user-find-zmacs-window-pane-for-reply (current-window)
  current-window
)

(defun user-find-zmacs-window-pane-for-forward (current-window)
  current-window
)

(defun user-find-zmacs-window-pane-for-remail (current-window)
  current-window
)

(defun coerce-to-window-pane (window)
  (if (typep window 'zwei:zmacs-window-pane)
      window
      (find-if #'(lambda (x) (typep x 'zwei:zmacs-window-pane))
	       (send window :Inferiors)
      )
  )
)

(defun find-zmacs-window-pane-for-reply (current-window)
  (coerce-to-window-pane (User-Find-Zmacs-Window-Pane-For-Reply current-window))
)

(defun find-zmacs-window-pane-for-forward (current-window)
  (Coerce-To-Window-Pane
    (user-find-zmacs-window-pane-for-forward current-window)
  )
)

(defun find-zmacs-window-pane-for-remail (current-window)
  (Coerce-To-Window-Pane
    (user-find-zmacs-window-pane-for-remail current-window)
  )
)

(defun in-yw-read-mode ()
  (assoc 'yw-read-mode (send *interval* :Saved-Mode-List))
)

(defun kill-and-clean-up-buffer (buffer)
  (let ((entry (get buffer :Message-cache-entry)))
       (if entry
	   (setf (yw:cache-associated-zmacs-buffers entry)
		 (remove buffer (yw:cache-associated-zmacs-buffers entry))
	   )
	   nil
       )
  )
  (kill-buffer buffer)
)

(defun maybe-go-back-to-one-window (reply-buffer)
"If we are operating in split screen mode, go back to one screen mode."
  (if (and yw:*split-screen-for-message-replies* (zwei:other-window))
      (progn (if (equal *window* (get reply-buffer :revert-to-frame-on-exit))
		 nil
		 (let ((*numeric-arg-p* nil)) (zwei:com-other-window))
	     )
	     (let ((*numeric-arg-p* t))
	          (com-one-window)
	     )
      )
      nil
  )
)

(defun Reselect-Old-Mail-Buffer
       (reply-buffer &optional (abort-p nil) (kill-reply-buffer-p nil))
  (if (get reply-buffer :revert-to-frame-on-exit)
      (progn
	(send (get reply-buffer :revert-to-frame-on-exit) :Mouse-Select)
	(if (get reply-buffer :replying-to)
	    (if abort-p
		(setf (get reply-buffer :replying-to) nil)
		(if (equal (get reply-buffer :replying-to)
			   (get reply-buffer :revert-to-buffer-on-exit)
		    )
		    (if (get reply-buffer :Message-Cache-Entry)
		        (mark-message-as-answered
			  (get reply-buffer :revert-to-buffer-on-exit)
			)
			(progn (beep)
			       (format *query-io*
				       "~&Cannot mark message as answered, ~
                                        mailstream is closed."
			       )
		        )
		    )
		    nil
		)
	    )
	    nil
	)
	(if (get reply-buffer :revert-to-buffer-on-exit)
	    (make-buffer-current (get reply-buffer :revert-to-buffer-on-exit))
	    nil
	)
	(maybe-go-back-to-one-window reply-buffer)
	(if (or (and kill-reply-buffer-p (not yw:*dont-kill-reply-buffers*))
		(and abort-p
		     (y-or-n-p "~&Kill buffer: ~A" (send reply-buffer :Name))
		)
	    )
	    (kill-and-clean-up-buffer reply-buffer)
	    nil
	)
	(if (not (in-yw-read-mode))
	    (zwei:turn-on-mode 'yw-zwei:yw-read-mode) ; (Com-Yw-Read-Mode)
	    nil
	)
      )
      (if (and (get reply-buffer :Source-Mailer)
	       yw:*reselect-mail-control-window-on-end-of-sequence* 
	  )
	  (send (get reply-buffer :Source-Mailer) :Mouse-Select)
	  nil
      )
  )
)

;(defun parse-alias-entry (entry)
;  (if entry
;      (if (consp entry)
;	  (multiple-value-bind (name host)
;	      (parse-alias-entry (first entry))
;	    (multiple-value-bind (names hosts) (parse-alias-entry (rest entry))
;	      (values (cons name names) (cons host hosts))
;	    )
;	  )
;	  (let ((target-name (first entry))
;		(target-host (second entry))
;	       )
;	       (values target-name
;		       (if (net:parse-host target-host t t)
;			   (send (net:parse-host target-host t t) :Name)
;			   target-host
;		       )
;	       )
;	  )
;      )
;      (values nil nil)
;  )
;)

(defun map-to-alias (name)
  (declare (values user-name target-host))
  (let ((entry (assoc name yw:*address-alias-alist* :Test #'string-equal)))
       (if entry
	   (values (second entry) t)
	   (values nil nil)
       )
  )
)


(defun comma-separate (strings)
  (if strings
      (format nil "~A~{, ~A~}" (first strings) (rest strings))
      ""
  )
)

;(defun flatten (list)
;  (if (consp list)
;      (if (consp (first list))
;	  (append (flatten (first list)) (flatten (rest list)))
;	  (cons (flatten (first list)) (flatten (rest list)))
;      )
;      list
;  )
;)

(defun flatten (list)
  (let ((all nil))
       (labels ((flatten-1 (x)
		  (if (consp x)
		      (progn (flatten-1 (first x))
			     (if (rest x) (flatten-1 (rest x)) nil)
		      )
		      (push x all)
		  )
	        )
	       )
	 (flatten-1 list)
	 (nreverse all)
       )
  )
)

(defun my-parse-all-addresses (addresses)
  (etypecase addresses
    (mail:address (list addresses))
    (string (mail:parse-all-addresses addresses 0 nil nil :Address))
    (cons (etypecase (first addresses)
	    (string (my-parse-all-addresses (Comma-Separate addresses)))
	    (mail:address addresses)
	  )
    )
  )
)

(defun GET-BASIC-ADDRESS-1 (local-part domain &optional comments)
  (mail:get-address-object 'mail:basic-address
			   :local-part local-part :domain domain
			   :comments comments))



(defmethod (mail:address :Basic-String) ()
  mail:basic-string
)

(defmethod (mail:address :Set-Basic-String) (to)
  (setq mail:basic-string to)
)

(defun maybe-upcase-1 (x)
  (typecase x
    (list (mapcar #'Maybe-Upcase-1 x))
    (string (string-upcase x))
    (otherwise x)
  )
)

(defun maybe-upcase (list)
  (mapcar #'Maybe-Upcase-1 List)
)


(defadvise com-send-mail (:Reselect-Old-Mail-Buffer) ()
  (let ((reply-buffer *interval*))
       (let ((result :Do-It))
	    (reselect-old-mail-buffer reply-buffer nil t)
	    result
       )
  )
)

(defadvise zwei:pathname-defaults (:Watch-Out-For-Yw-Buffers) (defaults buffer)
  (if (get (or buffer *interval*) :Buffer-Type)
      (or defaults *pathname-defaults*)
      :Do-It
  )
)

(defadvise com-mail-mode-exit (:Reselect-Old-Mail-Buffer) ()
  (if *use-zmail-abort-key-binding-p*
      (let ((reply-buffer *interval*))
	   (if (get reply-buffer :Source-Mailer)
	       (let ((result :Do-It))
		    (reselect-old-mail-buffer reply-buffer t)
		    result
	       )
	       (if (or (not *query-about-abort-in-send-mail*)
		       (and *query-about-abort-in-send-mail*
			    (y-or-n-p "Bury this buffer?")
		       )
		   )
		   :Do-It
		   (barf "‘ aborted.")
	       )
	   )
      )
      (barf "Aborted.")
  )
)

(defadvise mail:print-address-disposition (:ignore-normal-delivery)
	      (ignore ignore disposition)
  (if (member disposition *address-disposition-notifications-to-suppress*)
      nil
      (if *print-address-dispositions-in-mailer-window*
	  (let ((text (with-output-to-string (stream)
			(setf (first arglist) stream)
			:Do-It
		      )
		)
	       )
	       (yw:format-scroll-window (yw:find-mail-window nil) "~&~A" text)
	  )
	  :Do-It
      )
  )
)

(defadvise unsent-messages (:remove-yw-read-buffers) ()
  :do-it
  (setq *unsent-message-list*
	(delete-if #'(lambda (buf) (eq :Read (get buf :buffer-type)))
		   (the list *unsent-message-list*)
	)
  )
)


(defadvise sent-messages (:remove-yw-read-buffers) ()
  :do-it
  (remove-duplicates 
    (remove-if #'(lambda (buf) (eq :Read (get buf :buffer-type)))
	       (the list *sent-message-list*)
    )
  )
)

(defun yw-read-messages ()
  (remove-duplicates (set-difference *sent-message-list* (Sent-Messages)))
)

(defvar *c-x-c-m-buffer-name-column-width* 45)

(defvar *c-x-c-m-minimum-buffer-name-column-width* 45)



(defun do-any-necessary-redisplays (frame window old-buffer new-buffer)
  (if (not (equal window *window*))
      (progn (send *window* :Select)
	     (zwei:must-redisplay *window* dis-all)
	     (if old-buffer (make-buffer-current old-buffer))
	     (send frame :mouse-Select)
	     (yw:inside-zmacs (frame window)
	       (make-buffer-current new-buffer)
	       (zwei:must-redisplay *window* dis-all)
	       (send *window* :Refresh)
	     )
	     (send frame :mouse-Select)
      )
      (progn (zwei:must-redisplay *window* dis-all)
	     (send *window* :Refresh)
      )
  )
)


(defcom Com-yw-reply
  "Reply to the current message. With numeric arg toggles the default status
of yw:*reply-to-all-by-default*.  If you want to include the message text
from the source message and yw:*reply-inclusive-by-default* is false then
use the Super-I (Com-Include-Message)"
  ()
  (let ((in-reply-to *interval*)
	(*msg* (get *interval* :Parsed-Message))
	(old-window *window*)
       )
       (if yw:*split-screen-for-message-replies*
	   (switch-windows nil 2)
	   nil
       )
       (multiple-value-bind (new-buffer new-p)
	   (let ((yw:*reply-to-all-by-default*
		   (if *numeric-arg-p*
		       (not yw:*reply-to-all-by-default*)
		       nil
		   )
		 )
		)
	        (open-reply-buffer in-reply-to)
	   )
	    (putprop new-buffer old-window  :revert-to-frame-on-exit)
	    (putprop new-buffer in-reply-to :revert-to-buffer-on-exit)
	    (putprop new-buffer in-reply-to :replying-to)
	    (yw:fontify-buffer-to-default-fonts nil new-buffer)
	    (let ((in-reply-to-fonts
		    (or (zwei:window-font-alist *window*)
			(send in-reply-to :get-attribute :Fonts)
			(mapcar #'tv:font-name
				(mapcar #'rest
					(send in-reply-to :saved-font-alist)
				)
			)
		    )
		  )
		 )
	         (yw:do-fontification-of-buffer new-buffer in-reply-to-fonts)
	    )
	    (if (and yw:*reply-inclusive-by-default*
		     new-p
		)
		(include-message-text new-buffer in-reply-to)
		(send new-buffer :Select)
	    )
	    (multiple-value-bind (frame window)
		(let ((window (Find-zmacs-window-pane-for-Reply *window*)))
		     (values (send window :Superior) window)
		)
	      (do-any-necessary-redisplays frame window in-reply-to new-buffer)
	      (let ((*numeric-arg-p* nil)) (com-goto-end))
	    )
       )
       dis-all
  )
)

(defcom Com-yw-forward
  "Forward the current message."
  ()
  (let ((read-buffer *interval*)
	(*msg* (get *interval* :Parsed-Message))
	(old-window *window*)
       )
       (multiple-value-bind (new-buffer new-p) (open-forward-buffer read-buffer)
	    (putprop new-buffer old-window  :revert-to-frame-on-exit)
	    (putprop new-buffer read-buffer :revert-to-buffer-on-exit)
	    (if new-p
		nil
		(progn (send new-buffer :Select)
		       (com-goto-end)
		)
	    )
	    (multiple-value-bind (frame window)
		(let ((window (Find-zmacs-window-pane-for-Forward *window*)))
		     (values (send window :Superior) window)
		)
	      (do-any-necessary-redisplays frame window read-buffer new-buffer)
	    )
       )
       dis-all
  )
)

(defcom com-yw-quit
  "Finish reading the message and go back to the mail control window."
  ()
  (let ((buffer *interval*))
       (Finish-Up-This-Buffer t *kill-read-buffer-on-end-key*)
       (Maybe-End-Of-Zmacs-Hook buffer)
  )
  dis-all
)

(defcom com-yw-abort
  "Finish reading the message and stop mail processing."
  ()
  (Finish-Up-This-Buffer nil t)
)

(defun get-message-number (buffer)
  (let ((entry (get buffer :Message-Cache-Entry)))
       (if entry (yw:cache-msg# entry) nil)
  )
)

(defun finish-up-this-buffer (go-back-to-mailer-p kill-p)
  (if (typep *interval* 'zwei:node)
      (if (get *interval* :source-mailer)
	  (case (get *interval* :source-mailer)
	    (:Closed   (beep) (format *query-io* "~&Mailstream closed."))
	    (:Expunged (beep) (format *query-io* "~&Message Expunged."))
	    (otherwise
	      (let ((sequence (get *interval* :message-sequence))
		    (number   (get-message-number *interval*))
		    (mailer   (get *interval* :source-mailer))
		   )
		   (letf ((#'zwei:select-buffer
			   #'(lambda (prompt allow-create-new)
			       (ignore prompt allow-create-new)
			       (send (previous-buffer) :Select)
			       dis-text
			     )
			  )
			 )
			 (if (or (and yw:*keep-messages-read-by-default*
				      (not *numeric-arg-p*)
				 )
				 (and (not yw:*keep-messages-read-by-default*)
				      *numeric-arg-p*
				 )
			     )
			     (hide-mail-buffer *interval* nil)
			     (if kill-p
				 (kill-and-clean-up-buffer *interval*)
				 (hide-mail-buffer *interval* nil)
			     )
			 )
		   )
		   (if sequence
                       (send sequence :DeHighlight-Message number :read)
                       nil
                   )
		   (if go-back-to-mailer-p
		       (send mailer :Mouse-Select)
		       nil
		   )
	      )
	    )
	  )
	  (format *query-io* "~&No mailer found.")
      )
      (format *query-io* "~&*Interval* is not a Node.  It's ~S." *interval*)
  )
  dis-all
)

(defcom Com-yw-remail
  "Remail the current message."
  ()
  (let ((read-buffer *interval*)
	(*msg* (get *interval* :Parsed-Message))
	(old-window *window*)
       )
       (multiple-value-bind (new-buffer new-p) (open-remail-buffer read-buffer)
	    (putprop new-buffer old-window  :revert-to-frame-on-exit)
	    (putprop new-buffer read-buffer :revert-to-buffer-on-exit)
	    (if new-p
		nil
		(progn (send new-buffer :Select)
		       (com-goto-end)
		)
	    )
	    (multiple-value-bind (frame window)
		(let ((window (Find-zmacs-window-pane-for-Remail *window*)))
		     (values (send window :Superior) window)
		)
	      (do-any-necessary-redisplays frame window read-buffer new-buffer)
	    )
       )
       dis-all
  )
)

(defcom Com-Yw-Remail-sent-message
  "Remail the current message."
  ()
  (if (not (get *interval* :Parsed-Message))
      (Remember-Parsed-Message *interval*)
      nil
  )
  (Com-Yw-Remail)
)

(defun get-another-message (direction in-sequence-p &optional (increment 1))
  (declare (special yw:*edit-server*))
  (if (minusp increment) (barf "Cannot use negative increment.") nil)
  (if (typep *interval* 'zwei:node)
      (if (get *interval* :source-mailer)
	  (case (get *interval* :source-mailer)
	    (:Closed   (beep) (format *query-io* "~&Mailstream closed."))
	    (:Expunged (beep) (format *query-io* "~&Message Expunged."))
	    (otherwise
	      (let ((mailer         (get *interval* :source-mailer))
		    (sequence       (get *interval* :message-sequence))
		    (message-number (get-message-number *interval*))
		    (continuation   (get *interval* :Continuation-Method))
		   )
		   (letf ((#'zwei:select-buffer
			   #'(lambda (prompt allow-create-new)
			       (ignore prompt allow-create-new)
			       (send (previous-buffer) :Select)
			       dis-text
			     )
			  )
			 )
			 (if yw:*keep-messages-read-by-default*
			     (hide-mail-buffer *interval* nil)
			     (kill-and-clean-up-buffer *interval*)
			 )
			 (send sequence :Dehighlight-Message
			       message-number :Read
			 )
			 (if yw:*queue-zmacs-get-next-message-commands-p*
			     (send yw:*edit-server* :Put-Task
				   :get-another-message
				   (list :process-next-message *window*
					 direction in-sequence-p mailer sequence
					 message-number increment continuation
				   )
			     )
			     (let ((result
				     (send yw:*edit-server*
					   :Process-Next-Message
					   *window* direction in-sequence-p
					   mailer sequence message-number
					   increment continuation
				     )
				   )
				  )
				  (Maybe-End-Of-Zmacs-Hook *interval* result)
			     )
			 )
		   )
	      )
	    )
	  )
	  (format *query-io* "~&No mailer found.")
      )
      (format *query-io* "~&*Interval* is not a Node.  It's ~S." *interval*)
  )
  dis-all
)

(defun maybe-end-of-zmacs-hook (buffer &optional (result :No-Message-Found))
  (if (equal result :No-Message-Found)
      (progn (if (get buffer :Message-Sequence)
		 (send (send (get buffer :Message-Sequence) :Mailstream)
		       :Maybe-Invalidate-Computed-Orders
		 )
		 nil
	     )
	     (if (fboundp 'end-of-sequence-in-zmacs-hook)
		 (funcall 'end-of-sequence-in-zmacs-hook
			  *interval* *window* (tv:sheet-superior *window*)
		 )
		 nil
	     )
      )
      nil
  )
)

(defun simple-command-to-edit-server (method-name &rest args)
  (declare (special yw:*edit-server*))
  (if (typep *interval* 'zwei:node)
      (if (get *interval* :source-mailer)
	  (let ((sequence (get *interval* :message-sequence))
		(number   (get-message-number *interval*))
		(mailer   (get *interval* :source-mailer))
	       )
	       (send yw:*edit-server* :Put-Task :simple-command-to-edit-server
		 (append (list method-name sequence mailer)
			 args (list (list number))
		 )
	       )
	  )
	  (format *query-io* "~&No mailer found.")
      )
      (format *query-io* "~&*Interval* is not a Node.  It's ~S." *interval*)
  )
  dis-none
)

(defcom com-yw-mode-delete-this-message
  "Delete this message.  If *move-to-next-message-after-delete-in-zmacs* is
true then move on to the next message."
  ()
  (format *query-io* "~& - delete queued")
  (let ((buffer *interval*))
       (let ((result (if *move-to-next-message-after-delete-in-zmacs*
			 (Com-Yw-Mode-Next-Message-In-Sequence)
			 dis-none
		     )
	     )
	    )
	    (let ((*interval* buffer))
	         (delete/undelete-message t)
	    )
	    result
       )
  )
)

(defcom Com-Yw-Mode-alternate-delete-this-message
  "Toggle deletion of this message.  Does not move on to the next message."
  ()
  (format *query-io* "~& - delete queued")
  (delete/undelete-message :toggle)
)

(defcom com-yw-mode-undelete-this-message
  "Get the next message in the message sequence that caused this message
to be read."
  ()
  (format *query-io* "~& - undelete queued")
  (delete/undelete-message nil)
)

(defun delete/undelete-message (delete-p)
  (Simple-Command-To-Edit-Server :Delete-or-undelete-Sequence delete-p)
)

(defcom com-yw-mode-next-message-in-sequence
  "Get the next message in the message sequence that caused this message
to be read."
  ()
  (get-another-message :Forwards t *numeric-arg*)
)

(defcom com-yw-mode-previous-message-in-sequence
  "Get the next message in the message sequence that caused this message
to be read."
  ()
  (get-another-message :Backwards t *numeric-arg*)
)

(defcom com-yw-mode-next-numerical-message
  "Get the message that is numeric-arg message numbers forward in this mailbox.
This is a trap-door that allows you to view messages in the space of all
messages in the mailbox, rather than the messages in the sequence specified.
Thus, if you are reading message 42 of the sequence UnDeleted, which has
messages 40, 42, 47 and 50, and then use this command then you will be
reading message 43, not 47."
  ()
  (get-another-message :Forwards nil *numeric-arg*)
)

(defcom com-yw-mode-previous-numerical-message
  "Get the message that is numeric-arg message numbers backwards in this
mailbox.  This is a trap-door that allows you to view messages in the space
of all messages in the mailbox, rather than the messages in the sequence
specified.  Thus, if you are reading message 42 of the sequence UnDeleted,
which has messages 40, 42, 47 and 50, and then use this command then you
will be reading message 41, not 40."
  ()
  (get-another-message :Backwards nil *numeric-arg*)
)

(defcom com-yw-mode-maybe-next-numerical-message
  "Get the next message in the message sequence that caused this message to
be read unless yw-zwei:*keep-cursor-keystrokes-as-normal* is true.  If it is
true then just goes to the next line."
  ()
  (if *keep-cursor-keystrokes-as-normal*
      (com-down-real-line)
      (get-another-message :Forwards nil *numeric-arg*)
  )
)

(defcom com-yw-mode-maybe-previous-numerical-message
  "Get the next message in the message sequence that caused this message to be
read unless yw-zwei:*keep-cursor-keystrokes-as-normal* is true.  If it is
true then just goes to the previous line."
  ()
  (if *keep-cursor-keystrokes-as-normal*
      (com-up-real-line)
      (get-another-message :Backwards nil *numeric-arg*)
  )
)

(defun mark-message-as-answered (buffer)
  (let ((*interval* buffer))
       (Simple-Command-To-Edit-Server :mark-sequence-as-answered)
  )
)

(defcom com-yw-mode-toggle-flagged-state
  "Toggle the \Flagged status of the current message."
  ()
  (format *query-io* "~& - toggle flag queued")
  (Simple-Command-To-Edit-Server :toggle-flagged-sequence)
;  (set-mode-line-list (yw-read-mode-line-list (Message-Record)))
  dis-none
)


(defcom com-yw-forward-command
  "Forward a command to the yw prompt window."
  ()
  (let ((command-line (completing-read-from-mini-buffer "YW Command" nil t))
	(prompter (send (get *interval* :source-mailer) :Prompt-Window))
	(mailer (get *interval* :source-mailer))
       )
       (if command-line
	   (let ((old-sequence (send mailer :Current-Sequence))
		 (yw:*mailer* mailer)
		)
	        (unwind-protect
		 (progn
		   (send mailer :set-current-sequence
		     (yw:make-a-sequence
		       'yw:message-sequence
		       :Owner
			 mailer
		       :Mailbox
			 (send (get *interval* :message-sequence) :Mailbox)
		       :Sequence-Specifier
			 (list (get-message-number *interval*))
		     )
		    )
		    (tv:process-reset-and-enable (send mailer :Process))
		    (yw:wait-for-mailer-in-keyboard-state mailer)
		    (loop for ch being the array-elements of command-line do
			  (send prompter :Force-Kbd-Input ch)
		    )
		    (send prompter :Force-Kbd-Input #\newline)
		  )
		  (process-run-function
		    '(:Name "Reset current sequence" :Priority -1)
		    #'(lambda (mailer old-sequence)
			(sleep 1)
			(yw:wait-for-mailer-in-keyboard-state mailer)
			(send mailer :Set-Current-Sequence old-sequence)
		      )
		    mailer old-sequence
		  )
		)
	   )
	   (beep)
       )
  )
  dis-none
)


(defcom com-yw-set-keyword
  "Set a keyword for this message."
  ()
  (set/unset-keyword t)
)

(defcom com-yw-unset-keyword
  "UnSet a keyword for this message."
  ()
  (set/unset-keyword nil)
)

(defun set/unset-keyword (set-p)
  (let ((mailstream (send (get *interval* :message-sequence) :Mailstream))
	(sequence (get *interval* :message-sequence))
	(number   (get-message-number *interval*))
       )
       (let ((all (yw:Keyword-Names mailstream)))
	    (let ((for-message
		    (loop for key in all
			  when (send sequence :Flag-Seen number
				     :\\keyword (first key))
			  collect key
		    )
		  )
		 )
	         (let ((not-set (set-difference all for-message)))
		      (let ((result
			      (completing-read-from-mini-buffer
				(if set-p "Keyword to set" "Keyword to unset")
				(mapcar #'(lambda (x) (list (second x) x))
					(if set-p not-set for-message)
				)
			      )
			    )
			   )
			   (if result
			       (yw:Flag/Unflag-Message
				 Mailstream
				 (list number) (if set-p :Set :Clear)
				 (first (second result))
			       )
			       (beep)
			   )
		      )
		 )
	    )
      )
  )
  dis-none
)

(defun message-record ()
  (let ((mailstream (send (get *interval* :message-sequence) :Mailstream))
	(number   (get-message-number *interval*))
       )
       (if (numberp number)
	   (yw:map-elt (yw:getstreamprop MailStream :MessageArray)
		       number MailStream
	   )
	   nil
       )
  )
)
		
;(defun yw-read-mode-line-list (&optional (message nil))
;  (append (delete-if #'(lambda (x)
;			 (and (stringp x)
;			      (lisp:search "(END" x
;					   :Test #'string-equal
;			      )
;			 )
;		       )
;		     (mode-line-list)
;	  )
;	 '(" (END to finish -- ABORT to kill)")
;  )
;)

(defcom com-include-message
  "Includes a source message into a reply."
  ()
  (if (get *interval* :replying-to)
      (include-message-text *interval* (get *interval* :replying-to) nil)
      (barf "No message to reply to.")
  )
  dis-all
)

(defun give-help-for-comtab (key-commands m-x-commands comtab name)
  (format t "~%~%The following are the keyboard commands supported in ~A.~%"
	  name
  )
  (loop for (char command) on key-commands by #'cddr do
	(ignore command)
	(document-key char comtab)
	(terpri)
  )
  (format t "~%~%The following are the M-x commands supported in ~A.~%" name)
  (loop for (string . command) in m-x-commands do
	(format t "~&~A~20T" string)
	(print-doc :full command)
  )
)

(defun dequote (x)
  (if (and (consp x) (equal 'quote (first x)))
      (second x)
      x
  )
)

(defcom com-yw-help
  "Help for YW Read Mode.  M-† gives normal help."
  ()
  (let ((entry (assoc 'zwei:set-comtab (get 'yw-read-mode 'zwei:mode))))
       (Give-Help-For-Comtab (Dequote (third entry)) (dequote (fourth entry))
			     *mode-comtab* 'yw-read-mode
       )
       (format t "~%~%Hit space to get rid of this text.")
  )
  dis-none
)

(defcom com-yw-print-message
  "Prints the current message."
  ()
  (Simple-Command-To-Edit-Server :Hardcopy-Sequence)
  dis-none
)

(defun copy/move-default-path (mailstream name type &optional (directory nil))
  (multiple-value-bind (file-name host)
      (yw:mailbox-and-host-from-mailbox-name (send mailstream :mailbox))
    (ignore file-name)
    (fs:make-pathname
      :Host host
      :Name name
      :Type type
      :Directory (or directory (yw:default-mailbox-directory))
    )
  )
)

(defun copy/move-message-1 (prompt delete-p name type)
  (if (not (get *interval* :message-sequence))
      (barf "~&No mailstream associated with buffer ~S" (send *interval* :Name))
  )
  (let ((mailstream (send (get *interval* :message-sequence) :Mailstream)))
       (let ((default (copy/move-default-path mailstream name type))
	     (yw:*cache-directory-lists-p* t)
	    )
	    (let ((to-path (read-defaulted-pathname
			     prompt
			     default
			     nil :newest :Read nil nil
			   )
		  )
		 )
	         (let ((real-to-path
			 (if (yw:canonical-mailbox-name-p
			       (send to-path :Name)
			     )
			     (yw:decanonicalize-mailbox-name
			       (send to-path :Name)
			       (send (send to-path :Host) :Name)
			     )
			     (if (or yw:*copy/move-to-non-existent-files-ok-p*
				     (probe-file to-path)
				     (y-or-n-p
				       "~&The file ~S does not exist.  Proceed?"
				       (send to-path :String-For-Host)
				     )
				 )
				 to-path
				 (barf " - Aborted")
			     )
			 )
		       )
		      )
		      (Simple-Command-To-Edit-Server :Copy/Move-Sequence
						     delete-p real-to-path
		      )
		 )
	    )
       )
  )
  (if (and delete-p *move-to-next-message-after-delete-in-zmacs*)
      (Com-Yw-Mode-Next-Message-In-Sequence)
      dis-none
  )
)

(defcom com-yw-move-message
  "Moves the current message to a file."
  ()
  (copy/move-message-1 "Move to file:" t
		       yw:*default-move-to-mailbox-name*
		       yw:*default-move-to-mailbox-type*
  )
)

(defcom com-yw-copy-message
  "Copies the current message to a file."
  ()
  (copy/move-message-1 "Copy to file:" nil
		       yw:*default-copy-to-mailbox-name*
		       yw:*default-copy-to-mailbox-type*
  )
)

(defun is-in-list (string list &optional (end2 nil))
  (if list
      (or (lisp:search (the string string) (the string (first list))
		       :Test #'char-equal :End2 end2
          )
;	  (zlc:string-search string (first list) 0 nil 0 end2 nil)
	  (is-in-list string (rest list) end2)
      )
      nil
  )
)

(defun spell-checks-in-list (string list grace)
  (if list
      (or (w:spell-compare string
			   (string-upcase (first list))
			   grace
	  )
	  (spell-checks-in-list string (rest list) grace)
      )
      nil
  )
)

(defun complete-from-hash-table (string type table access-function)
  (let ((result nil))
       (ecase type
	 (:Recognition
	  (maphash #'(lambda (key address)
		       (let ((strings (funcall access-function key address)))
			    (if (is-in-list string strings (length string))
				(push address result)
				nil
			    )
		       )
		     )
		     table
	  )
	 )
	 (:Apropos
	  (maphash #'(lambda (key address)
		       (let ((strings (funcall access-function key address)))
			    (if (is-in-list string strings)
				(push address result)
				nil
			    )
		       )
		     )
		     table
	  )
	 )
	 (:Spelling-Corrected
	  (let ((length (length string))
		(use-string (string-upcase string))
		(grace 1)
	       )
	       (declare (special grace))
	       (cond ((> length 9) (incf grace 3))
		     ((> length 5) (incf grace 2))
		     ((> length 3) (incf grace 1))
	       )
	       (maphash
		 #'(lambda (key address)
		     (let ((strings (funcall access-function key address)))
			  (if (Spell-Checks-In-List use-string strings
						    grace
			      )
			      (push address result)
			      nil
			  )
		     )
		   )
		 table
	       )
	  )
	 )
       )
       result
  )
)

(defun mixed-case-p (address)
  (let ((local (first (send address :local-part))))
       (and (not (string= local (string-upcase local)))
	    (not (string= local (string-downcase local)))
       )
  )
)

(defun address-equal-1 (a b)
  (let ((p1 (get-printed-address nil a))
	(p2 (get-printed-address nil b))
       )
       (if (xor (rest p1) (rest p2))
	   (if (rest p2)
	       (string-equal (first p1) (second p2))
	       (string-equal (second p1) (first p2))
	   )
	   (if (and (rest p1) (rest p2))
	       (and (string-equal (first p1) (first p2))
		    (string-equal (second p1) (second p2))
	       )
	       (string-equal (first p1) (first p2))
	   )
       )
  )
)

(defun force-into-basic-address (address)
  (apply 'mail:get-basic-address
	 (mapcar #'string-downcase (send address :Local-Part))
	 (string-downcase (Send address :Domain))
	 ;;; Let's ignore comments.
	 nil
;	 (let ((comm (send address :Comments)))
;	      (if comm (list (string-downcase comm)) nil)
;	 )
  )
)

(defun address-equal (a b)
  (or (eq (force-into-basic-address a) (force-into-basic-address b))
      (Address-Equal-1 a b)
  )
)

(defun is-in-list1 (x y)
  (is-in-list y x)
)

(defun completion-clean-up-function (address1 address2)
  (cond ((send address1 :get :ignore-me) :reject1)
        ((send address2 :get :ignore-me) :reject2)
	((address-equal address1 address2)
	 (if (typep address1 'mail:named-address)
	     (if (typep address2 'mail:named-address)
		 (let ((length1 (length (send address1 :address-string)))
		       (length2 (length (send address1 :address-string)))
		      )
		      (cond ((> length1 length2) :Prefer)
			    ((> length2 length1) :Reject1)
			    ((or (and (mixed-case-p address2)
				      (not (mixed-case-p address1))
				 )
				 (and (not (send address1 :Comments))
				      (send address2 :Comments)
				 )
			     )
			     :Reject1
			    )
			    (t :Prefer)
		      )
		 )
		 :Prefer
	     )
	     (if (typep address2 'mail:named-address)
		 :reject1
		 (if (or (mixed-case-p address1)
			 (send address1 :Comments)
		     )
		     :prefer
		     :reject1
		 )
	     )
	 )
	)
	((member (get-printed-address nil address1)
		 *address-substrings-that-cause-ignoring-in-completion*
		 :test 'Is-In-List1
	 )
	 :Reject1
	)
	((member (get-printed-address nil address2)
		 *address-substrings-that-cause-ignoring-in-completion*
		 :test 'Is-In-List1
	 )
	 :Reject2
	)
	((let ((printed1 (second (get-printed-address nil address1)))
	       (printed2 (second (get-printed-address nil address2)))
	      )
	      (cond ((and (< (length printed1) (length printed2))
			  (string-equal printed1 printed2 :End2
					(length printed1)
			  )
		     )
		     :Reject1
		    )
		    ((and (< (length printed2) (length printed1))
			  (string-equal printed2 printed1 :End2
					(length printed2)
			  )
		     )
		     :Reject2
		    )
		    (t nil)
	      )
	 )
	)
	((not (send address1 :Domain)) :Reject1)
	((not (send address2 :Domain)) :Reject2)
	(t nil)
  )
)

(defmethod (mail:named-address :print-self) (stream depth slashify)
  (declare (ignore depth))
  (if slashify
      (format stream "#<~S ~S ~O>"
	      (type-of self) (Get-Printed-Address nil self) (sys:%pointer self))
      (princ (send self :address-string) stream)))

(defun clean-up-completions-1 (this-one others accepted)
  (if others
      (let ((result (find-if
		      #'(lambda (x)
			  (funcall *completion-clean-up-function* this-one x)
			)
		      others
		    )
	    )
	   )
	   (if result
	       (ecase (funcall *completion-clean-up-function* this-one result)
		 (:prefer (Clean-Up-Completions-1
			    this-one (remove result others) accepted
			  )
		 )
		 (:reject1 (Clean-Up-Completions-1
			     (first others) (rest others) accepted
			   )
		 )
		 (:reject2 (Clean-Up-Completions-1
			     this-one (remove result others) accepted
			   )
		 )
	       )
	       (Clean-Up-Completions-1
		 (first others) (rest others) (cons this-one accepted)
	       )
	   )
      )
      (if this-one
	  (cons this-one accepted)
	  accepted
      )
  )
)

(defun clean-up-completions (completions)
  (clean-up-completions-1 (first completions) (rest completions) nil)
)

(defun get-printed-address (key value)
  (ignore key)
  (or (get value :printed-address)
      (let ((address-string (send value :address-string)))
	   (let ((result
		   (if (and (typep value 'mail:named-address)
			    (not (equal "" (send value :Name)))
			    (not (equal "\"\"" (send value :Name)))
		       )
		       (list (or (send value :String-For-Message)
				 (send value :Name)
			     )
			     address-string
		       )
		       (list (or (send value :String-For-Message)
				 address-string
			     )
		       )
		   )
		 )
		)
	        (setf (get value :printed-address) result)
		result
	   )
      )
  )
)

(defun namify-alias (alias-entry)
  (typecase (second alias-entry)
    (cons
     (mail:parse-address (format nil "~A <~{~A~^, ~}>"
				 (first alias-entry) (second alias-entry)
			 )
     )
    )
    (mail:address (second alias-entry))
    (otherwise
     (mail:parse-address
       (if (lisp:search "<" (string (second alias-entry)) :Test #'char=)
	   ;; already named.
	   (format nil "~A (~A)" (second alias-entry) (first alias-entry))
	   (format nil "~A <~A>" (first alias-entry) (second alias-entry))
       )
     )
    )
  )
)

(defun complete-from-aliases (string type)
  (declare (values matching-addresses perfect-match-p))
  (case type
    (:Recognition
     (let ((matches
	     (remove-if-not
	       #'(lambda (x)
		   (lisp:search string (first x) :Test #'string-equal
				:End2 (length string)
		   )
		 )
	       yw:*address-alias-alist*
	     )
	   )
	  )
          (values (mapcar 'Namify-Alias matches)
		  (and (equal (length matches) 1)
		       (string-equal string (first (first matches)))
		  )
	  )
     )
    )
    (:Apropos
     (mapcar
       'Namify-Alias
       (remove-if-not
	 #'(lambda (x) (lisp:search string (first x) :Test #'string-equal))
	 yw:*address-alias-alist*
       )
     )
    )
    (:Spelling-Corrected
     (let ((length (length string))
	   (use-string (string-upcase string))
	   (grace 1)
	  )
	  (declare (special grace))
	  (cond ((> length 9) (incf grace 3))
		((> length 5) (incf grace 2))
		((> length 3) (incf grace 1))
	  )
	  (mapcar 'namify-alias
		   (loop for entry in yw:*address-alias-alist*
			 when (w:spell-compare
				use-string (string-upcase (first entry)) grace
			      )
			 collect entry
		   )
	  )
     )
    )
  )
)

(defun key-for-value (value hash-table)
  (let ((result nil))
       (catch 'found-it
	 (maphash #'(lambda (key val)
		      (if (eq value val)
			  (progn (setq result key)
				 (throw 'found-it nil)
			  )
			  nil
		      )
		    )
		    hash-table
	 )
       )
       result
  )
)

(defun Complete-Address
       (string type &optional (hash-table yw:*address-database*))
  (multiple-value-bind (alias-matches perfect-match-p)
      (complete-from-aliases string type)
    (if perfect-match-p
	alias-matches 
        (append alias-matches
		(Clean-Up-Completions
		  (complete-from-hash-table string type hash-table
					    'Get-Printed-Address
		  )
		)
	)
    )
  )
)

(defun complete-at-point (type)
  (let ((saved-point (copy-bp (point))))
       (loop unless (bp-= (point) (send *interval* :First-Bp))
	     do (com-backward)
	     until (or (bp-= (point) (send *interval* :First-Bp))
		       (and (member (bp-char (point))
				    '(#\tab #\newline #\, #\:)
				    :Test #'char=
			    )
			    (not (member (bp-char (forward-char (point)))
					 '(#\< #\() :Test #'char=
				 )
			    )
		       )
		   )
	     finally (if (not (bp-= (point) (send *interval* :First-Bp)))
			 (loop do (com-forward)
			       while (member (bp-char (point))
					     '(#\space #\tab #\, #\:)
					     :Test #'char=
				     )
			 ) 
			 nil
		     )
       )
       (let ((end-bp
	       (if (= zwei:word-delimiter
		      (zwei:word-syntax (bp-char saved-point))
		   )
		   saved-point
		   (zwei:forward-word (copy-bp saved-point) 1 t)
	       )
	     )
	    )
	    (with-open-stream
	      (stream (interval-stream (copy-bp (point)) end-bp))
	      (move-bp (point) saved-point)
	      (let ((string (read-line stream nil :Eof)))
		   (if (equal :Eof string)
		       (barf "Could not read something to complete.")
		       (progn
			 (move-bp (point) (bp-line end-bp) (bp-index end-bp))
			 (values (complete-address string type) string)
		       )
		   )
	      )
	    )
       )
  )
)

(defun find-longest-matching-address (addresses index)
  (declare (optimize (speed 3) (safety 0)))
  (if (rest addresses)
      (loop for address in (rest addresses)
	    when (>= index (length (Address-Name address)))
	    do (return (Address-Name address) :1)
	    when (>= index (length (Address-Name (first addresses))))
	    do (return (Address-Name (first addresses)) :2)
	    when (not (char-equal
			(aref (Address-Name (first addresses)) index)
			(aref (Address-Name address) index)
		      )
		 )
	    do (return (subseq (Address-Name (first addresses)) 0 index))
	    finally
	     (return (find-longest-matching-address addresses (+ 1 index)))
      )
      (first addresses)
  )
)


(defun address-name (address)
  (if (stringp address)
      address
      (send address :string-for-message)
  )
)

(defun get-rid-of-null-strings (string)
  (string-trim '(#\space #\tab) (yw:String-Subst "" "\"\"" string))
)

(defun best-address-name (address)
  (Get-Rid-Of-Null-Strings
    (or (send address :Send-If-Handles :string-for-message)
	(send address :Name)
    )
  )
)

(defvar *inside-address-menu-choose* nil
"Used for a hackish whopper on w:menu :mouse-buttons-on-item to allow us to
be sensitive to selecting some things with the right button."
)


(defwhopper (w:menu :Mouse-Buttons-On-Item) (bd)
"A rather gross whopper this.  We detect the case of being called from YW and
the button is Mouse-R-1 and then we do an address add/remove for the completion.
"
  (if *inside-address-menu-choose*
      (case (tv:mouse-character-button-encode bd)
	(#\mouse-r-1
	 (let ((address-object (getf (rest w:current-item) :Value)))
	      (cond ((not address-object) (beep))
		    ((member w:current-item w:highlighted-items :test #'eq)
		     (send self :Remove-Highlighted-Item w:current-item)
		     (setf (send address-object :get :ignore-me) nil)
		     (setq yw:*address-database-changed* t)
		    )
		    (t (send self :Add-Highlighted-Item w:current-item)
		       (setf (send address-object :get :ignore-me) t)
		       (setq yw:*address-database-changed* t)
		    )
	      )
	 )
	)
	(otherwise (continue-whopper bd))
      )
      (continue-whopper bd)
  )
)

(defun address-completion-who-line-doc-function (&rest ignore)
  "L,M: Select this address for completion, R: Forget this address"
)

(defun recognition-matching-addresses (addresses prefix menu-p)
  (if menu-p
      (let-globally ((*inside-address-menu-choose* t)
		     (w:*default-menu-item-who-line-documentation-function*
		       'Address-Completion-Who-Line-Doc-Function
		     )
		    )
		    (w:menu-choose
		      (mapcar #'(lambda (x)
				  (list (best-address-name x) :Value x)
				)
				addresses
		      )
		      :Label (format nil "Possible completions of ~S" prefix)
		    )
      )
      (Find-Longest-Matching-address addresses 0)
  )
)

(defun address-apropos-completion (addresses prefix)
  (if addresses
      (let-globally ((*inside-address-menu-choose* t)
		     (w:*default-menu-item-who-line-documentation-function*
		       'Address-Completion-Who-Line-Doc-Function
		     )
		    )
		    (w:menu-choose
		      (mapcar #'(lambda (x)
				  (list (best-address-name x) :Value x)
				)
				addresses
		      )
		      :Label (format nil "Possible completions of ~S" prefix)
		    )
      )
      nil
  )
)

(defun address-recognition-completion (results prefix menu-p)
  (if results
      (let ((all-there
	      (loop for address in results
		    always (string-equal prefix (Address-Name address)
					 :End2 (length prefix)
			   )
	      )
	    )
	   )
	   (Recognition-Matching-Addresses
	     results prefix (if (or (equal (length results) 1) all-there)
				menu-p
				t
			    )
	   )
      )
      (if *try-apropos-completion-if-recognition-completion-fails*
	  (let ((results (complete-at-point :Apropos)))
	       (if results
		   (recognition-matching-addresses results prefix menu-p)
		   nil
	       )
	  )
	  nil
      )
  )
)

(defun yw-complete-1 (type completion-function &optional (menu-p nil))
  (multiple-value-bind (results prefix) (funcall completion-function type)
    (let ((best (ecase type
		  (:Recognition
		   (address-recognition-completion results prefix menu-p)
		  )
		  ((:Apropos :Spelling-Corrected)
		   (address-apropos-completion results prefix)
		  )
		)
	  )
	 )
	 (if best
	     (let ((new-string
		     (if (stringp best) best (Best-Address-Name best))
		   )
		  )
	          (if (> (length new-string) 0)
		      (progn
			(loop for i from 1 to (length prefix) do (com-rubout))
		        (loop for i from 0 to (- (length new-string) 1) do
			      (insert-char (aref new-string i))
			)
		      )
		      (beep)
		  )
	     )
	     (beep 'tv:notify)
	 )
    )
  )
  dis-text
)

(defcom com-yw-complete
  "Tries to complete the thing (address?) at the point."
  ()
  (yw-complete-1 :Recognition 'complete-at-point)
  dis-text
)

(defcom com-yw-menu-recognition-complete
  "Tries to complete the thing (address?) at the point."
  ()
  (yw-complete-1 :Recognition 'Complete-At-Point t)
  dis-text
)

(defcom com-yw-apropos-complete
  "Tries to complete the thing (address?) at the point."
  ()
  (yw-complete-1 :Apropos 'complete-at-point)
  dis-text
)

(defcom Com-Yw-Spelling-Correcting-Complete
  "Tries to complete the thing (address?) at the point."
  ()
  (yw-complete-1 :Spelling-Corrected 'complete-at-point)
  dis-text
)

(defun minibuffer-read-address-1 (prompt)
  (let ((old-apropos #'zwei:com-completion-apropos))
       (letf ((#'zwei:com-complete
	       #'(lambda () (Yw-Complete-1 :Recognition 'complete-at-point))
	      )
	      (#'zwei:complete-line
	       #'(lambda (&rest ignore)
		   (Yw-Complete-1 :Recognition 'complete-at-point)
		 )
	      )
	      (#'zwei:com-completion-apropos
	       #'(lambda ()
		   (multiple-value-bind (results prefix)
		       (complete-at-point :apropos)
		     (ignore prefix)
		     (let ((zwei:*completing-alist*
			     (mapcar
			       #'(lambda (add)
				   (let ((best (best-address-name add)))
					(cons best best)
				   )
				 )
				 results
			     )
			   )
			  )
			  (funcall old-apropos)
		     )
		   )
		 )
	      )
	      ((aref (zwei:comtab-keyboard-array *completing-reader-comtab*)
		     (char-code #\/) 4
	       )
	       'zwei:com-completion-apropos ;;; add super/
	      )
	     )
	     (let ((*completing-impossible-is-ok-p* t)
		   (*completing-alist* nil)
		   (zwei:*completing-help-message*
		     "You are trying to complete an address"
		   )
		  )
		  (edit-in-mini-buffer
		    *completing-reader-comtab* "" 0
		    `(,prompt (:right-flush " (Completion)"))
		  )
	     )
       )
  )
)

(defun minibuffer-read-address (prompt)
  (declare (values address hash-table-key))
  (let ((address (minibuffer-read-address-1 prompt)))
       (if address
	   (let ((result nil))
	        (maphash #'(lambda (key value)
			     (if (member address (Get-Printed-Address key value)
					 :Test #'string-equal
				 )
				 (setq result key)
				 nil
			     )
			   )
			   yw:*address-database*
		)
		(if result
		    (values address result)
		    (let ((matches (Complete-Address address :Recognition)))
		         (case (length matches)
			   (0 (barf "~&Address ~S not found." address))
			   (1 (values
				(first
				  (Get-Printed-Address nil (first matches))
				)
				(key-for-value (first matches)
					       yw:*address-database*
				)
			      )
			   )
			   (otherwise (barf "~&~S is not a unique address."
					    address
				      )
			   )
			 )
		    )
		)
	   )
	   (barf "~&No matching addresses.")
       )
  )
)

(defcom Com-Forget-Address
  "Reads an address and removes it from the address database."
  ()
  (multiple-value-bind (address key)
      (Minibuffer-Read-Address "Address to forget")
    (let ((address-object (gethash key yw:*address-database*)))
         (setf (send address-object :get :ignore-me) T)
	 (setq yw:*address-database-changed* t)
    )
    (format *query-io* "~&Address ~S will be ignored." address)
  )
  dis-none
)

(defcom Com-Remember-Address
  "Reads an address and remembers it in the address database."
  ()
  (multiple-value-bind (nil minibuffer node)
      (edit-in-mini-buffer
	zwei:*mini-buffer-comtab* "" 0
	`("Remember Address:")
      )
    (ignore minibuffer)
    (let ((string (if (typep node 'zwei:node) (string-interval node) nil)))
	 (if (not string) (barf "Read error."))
	 (multiple-value-bind (address error-p)
	     (let ((yw:*save-addresses-in-database-p* t))
		  (catch-error (mail:parse-address string) nil)
	     )
	   (if error-p
	       (barf "~S could not be parsed as an address.")
	       (progn (setf (send address :get :ignore-me) nil)
		      (setq yw:*address-database-changed* t)
		      (format *query-io* "~&Address ~S stored." string)
	       )
	   )
	 )
    )
  )
  dis-none
)

(defun Filter-Address-Database ()
  "Filters the contents of the address database."
  (format t "~&~D addresses to process.~%~%"
	  (hash-table-count yw:*address-database*)
  )
  (maphash
    #'(lambda (key addr)
	(if (or (lisp:search
		  "MAILER-DAEMON"
		  (the string (first (Get-Printed-Address key addr)))
		  :Test #'char-equal
		)
		(lisp:search
		  "MAILER DELIVERY"
		  (the string (first (Get-Printed-Address key addr)))
		  :Test #'char-equal
		) 
	    )
	    (progn (format t "~&Removing ~S" addr)
		   (remhash key yw:*address-database*)
		   (setq yw:*address-database-changed* t)
	    )
	    nil
	)
      )
      yw:*address-database*
  )
  (let ((addresses (maphash-return
		    #'(lambda (key addr)
			(let ((printed (Get-Printed-Address key addr)))
			     (list (or (second printed) (first printed))
				   key addr
			     )
			)
		      )
		    yw:*address-database*
		   )
	)
       )
       (loop for (string key address) in (sortcar addresses #'string-lessp)
	     for matching-addresses
	         = (and string (Complete-Address string :Recognition))
	     for matching-address = (first matching-addresses)
	     do (princ "")
	     when (and (equal (length matching-addresses) 1)
		       (not (eq address matching-address))
		  )
	     do (format t "~&Removing ~S because of ~S "
			address matching-address
		)
	        (remhash key yw:*address-database*)
		(setq yw:*address-database-changed* t)
       )
  )
  (if (and yw:*address-database-changed*
	   (y-or-n-p "~&Save the address database?")
      )
      (yw:maybe-save-address-database t)
      nil
  )
)

(defcom Com-List-Address-Database
  "Lists the contents of the address database."
  ()
  (let ((addresses (maphash-return
		    #'(lambda (key addr) (first (Get-Printed-Address key addr)))
		    yw:*address-database*
		   )
	)
       )
       (format t "~&The address database contains the following addresses.~%~%")
       (loop for address in (sort addresses #'string-lessp) do
	     (format t "~&~A" address)
       )
  )
  dis-none
)

;-------------------------------------------------------------------------------

(defun in-mail-header-p (bp)
  (and (member 'zwei:mail-mode zwei:*mode-list* :test #'eq :key #'car)
       (let ((headers-end-bp
	       (do ((line
		      (bp-line (interval-first-bp *interval*))
		      (line-next line)
		    )
		   )
		   ((zerop (length line))
		    (create-bp line 0)
		   )
	       )
	     )
	    )
	    (not (or (null headers-end-bp) (bp-< headers-end-bp bp)))
       )
  )
)


(defadvise zwei:AUTO-FILL-HOOK (:Not-In-Addresses) (char)
  (if (and (member char zwei:*auto-fill-activation-characters* :test #'eq)
	   (not (in-mail-header-p (point)))
      )
      :Do-It
      nil
  )
)

(defadvise zwei:com-tab-to-tab-stop (:Not-In-Addresses) ()
  (if (and zwei:*mail-template-header-body-goal-column*
	   (member (bp-char (point)) zwei:*auto-fill-activation-characters*
		   :test #'eq
	   )
	   (equal 0 (bp-index (point)))
	   (in-mail-header-p (point))
      )
      (let ((end-bp (create-bp (bp-line (point)) (bp-index (point)) :Moves)))
	   (zwei:insert-chars end-bp (zwei:in-current-font #\space)
			      zwei:*mail-template-header-body-goal-column*
	   )
	   (zwei:tabify-interval (point) end-bp)
	   (move-bp (point) (bp-line end-bp) (bp-index end-bp))
	   dis-text
      )
      :Do-It
  )
)

;-------------------------------------------------------------------------------

(defun replace-with-named-address (address hash-table &optional (key nil))
"Address is some address other than a named address.  Address is replaced with
a named address in the address hash table.  Key is the key into the hash table,
which we might have computed elsewhere, otherwise it is computed here.
"
  (format t "~&Replacing ~S with a named address." address)
  (let ((key (or key (key-for-value address hash-table)))
	(mail:*address-hash-table* hash-table)
       )
       (let ((new-address
	       (mail:get-named-address
		 (get key :Name)
		 (get key :Route)
		 (get key :Local-Part)
		 (get key :Domain)
		 (get key :Comments)
	       )
	     )
	    )
	    (remhash key hash-table)
	    new-address
       )
  )
)


(defun edit-address (address hash-table &optional (key nil))
"Edits sundry fields in the address Address, which is stored in Hash-table.
Key is the key into the hash table, which might have been computed elsewhere.
When the user edits an address it is first removed from the hash table and
then the new address is reinseted.  This makes sure that the address has
the right hash table entry (we don't want to hack on the name field,
e.g., because thia will change the hash position.
"
  (if (not (typep address 'mail:named-address))
      (setq address (replace-with-named-address address hash-table))
      nil
  )
  (let ((key (or key (key-for-value address hash-table))))
       (let ((new-name (get key :name))
	     (new-local-part (first (get key :local-part)))
	     (new-domain (get key :Domain))
	     (new-comments (get key :comments))
	     (mail:*address-hash-table* hash-table)
	    )
	    (let ((result
		    (tv:assign-using-menu
		      ((new-name "Name" :String-Or-Nil)
		       (new-local-part "Mailbox Name" :String)
		       (new-domain "Host" :String)
		       ((get address :Work-Address) "Work Address"
			:String-Or-Nil
		       )
		       ((get address :work-phone-number)
			"Work Phone #" :Number-Or-Nil
		       )
		       ((get address :Home-Address) "Home Address"
			:String-Or-Nil
		       )
		       ((get address :home-phone-number)
			"Home Phone #" :Number-Or-Nil
		       )
		       (new-comments "Comments" :Sexp)
		      )
		      :Label "Edit some attributes of this address."
		    )
		  )
		 )
		 (if (equal result :Abort-Menu)
		     result
		     (progn (remhash key hash-table)
			    (mail:get-named-address
			      new-name (get key :Route) (list new-local-part)
			      new-domain
			      new-comments
			    )
		     )
		 )
	    )
       )
  )
)


(defun edit-address-for (string hash-table &optional (key nil))
"Edits the address associated with the string String in Hash-Table.  Key is
the key into Hash-Table that represents the address denoted by string if we
already know it.
"
  (let ((matches
	  (complete-address string :Recognition hash-table)
	)
       )
       (case (length matches)
	 (0 :No-Matching-Addresses)
	 (1 (Edit-Address (first matches) hash-table key))
	 (otherwise :Not-A-Unique-Address)
       )
  )
)


(defcom Com-Edit-Address
  "Reads an address and edits some attributes of it."
  ()
  (multiple-value-bind (address key) (minibuffer-read-address "Address to edit")
    (let ((result (Edit-Address-For address yw:*address-database* key)))
         (case result
	   (:No-Matching-Addresses (barf "~&No matching addresses."))
	   (:Not-A-Unique-Address
	    (format *query-io* "~&This address it not unique.")
	   )
	   (:Abort-Menu (format *query-io* "~& - aborted."))
	   (otherwise (format *query-io* "~&Address ~S editted." address))
	 )
    )
  )
  dis-none
)

;-------------------------------------------------------------------------------

(defcom com-edit-rule "Edit an existing mailer rule or create a new one." ()
  (let ((rule (zwei:completing-read-from-mini-buffer
		"Rule name:"
		(mapcar #'(lambda (Rule) (cons (yw:Rule-Name Rule) Rule))
			yw:*all-rules*
		)
		t
	      )
	)
       )
       (if (consp Rule)
	   (yw:Edit-rule-with-menu
	     :Label "Edit Rule" :Rule-To-Edit (rest Rule)
	   )
	   (if (y-or-n-p "There is no rule called ~A.  Create one?" rule)
	       (yw:Edit-rule-with-menu
		 :Label "Create new rule" :Name rule
	       )
	       nil
	   )
       )
       dis-none
  )
)

;-------------------------------------------------------------------------------

(defcom com-edit-rule-set
	"Edit an existing mailer rule set or create a new one." ()
  (let ((Rs (zwei:completing-read-from-mini-buffer
	      "Rule set name:"
	      (mapcar #'(lambda (Rs) (cons (yw:Rule-Set-Name Rs) Rs))
		      yw:*all-rule-sets*
	      )
	      t
	    )
	)
       )
       (if (consp Rs)
	   (yw:edit-rule-set
	     :Label "Edit Rule Set" :Rule-Set-To-Edit (rest Rs)
	   )
	   (if (y-or-n-p "There is no rule set called ~A.  Create one?" Rs)
	       (yw:edit-rule-set
		 :Label "Create new rule set" :Name rs
	       )
	       nil
	   )
       )
       dis-none
  )
)

;-------------------------------------------------------------------------------

(defcom com-invoke-rule-set
"Invoke an existing mailer rule set on the message sequence associated with the
current buffer or, if we are not in mail mode, the current sequence/mailbox
in a mail control window.  Note:  If you have multiple mail control
windows then this might be a little confusing." ()
  (let ((Rs (zwei:completing-read-from-mini-buffer
	      "Rule set name:"
	      (mapcar #'(lambda (Rs) (cons (yw:Rule-Set-Name Rs) Rs))
		      yw:*all-rule-sets*
	      )
	      nil
	    )
	)
	(mcw (or (get *interval* :Source-Mailer) (yw:get-mail-control-window)))
       )
       (let ((sequence
	       (or (get *interval* :Message-Sequence)
		   (send mcw :Current-Sequence)
		   (yw:simple-sequence :Sequence-All)
	       )
	     )
	    )
	    (Send sequence :Map-Over-Messages
		  #'(lambda (seq message-number rule-set)
		      (send rule-set :Apply-Self
			    (yw:make-event :Mailbox (send seq :Mailbox)
					   :Message message-number
					   :Type :invoke
			    )
			    t
		      )
		    )
		    (rest Rs)
	    )
       )
       dis-none
  )
)

;-------------------------------------------------------------------------------

(defun do-search (&rest args)
  (apply #'lisp:search args)
)

(defun Yw-Read-Mode-Line-List ()
  (Set-Mode-Line-List
    (remove '("  (END to mail -- ABORT to exit)")
	    (mode-line-list)  :Test #'equal
    )
  )
  (Set-Mode-Line-List
    (remove '("      (END to exit)") (mode-line-list) :Test #'equal)
  )
  (let ((current (position '*sequence-size* (mode-line-list))))
       (if current
	   (mode-line-list)
	   (let ((after (position *put-sequence-after-this-in-mode-line*
				  (mode-line-list) :Test #'equalp
			)
		 )
		)
	        (if (and after
			 (< after (- (length (mode-line-list)) 1))
		    )
		    (append (firstn (+ 1 after) (mode-line-list))
			    '(*sequence-size*)
			    (nthcdr (+ 1 after) (mode-line-list))
		    )
		    (append (mode-line-list) '(*sequence-size*))
		)
	   )
       )
  )
)

(defvar *sequence-size* "")

(defun point-in-sequence (sequence)
  (and (get *interval* :Message-Cache-Entry)
       (position (yw:descriptor-of (get *interval* :Message-Cache-Entry)
				   (send sequence :Mailstream)
		 )
		 (send sequence :Computed-Order)
       )
  )
)

(defun (:property *sequence-size* mode-line-recalculate) ()
 (yw:without-recursion (5) 
  (when (typep *interval* 'zwei:zmacs-buffer)
    (let ((mode-line-length (find-length-of-mode-line *mode-line-list*))
	  (mode-line-window-width (send *mode-line-window* :size-in-characters))
	  (sequence (get *interval* :Message-Sequence))
	 )
         (if sequence
	     (progn (send sequence :Compute-Order)
		    (if (> (length (send sequence :Computed-Order)) 1)
			(let ((position (point-in-sequence sequence)))
			     (if position
				 (let ((new (format
					      nil " {~D of ~D message~P}"
					      (+ 1 position)
					      (length
						(send sequence :Computed-Order)
					      )
					      (send sequence :Computed-Order)
					    )
				       )
				      )
				      (setq *Sequence-Size*
					    (subseq
					      new 0
					      (max (- (length new)
						      (- mode-line-length
							 mode-line-window-width
						      )
						      1
						   )
						   3
					      )
					    )
				      )
				 )
				 (setq *Sequence-Size* "")
			     )
			)
			(setq *Sequence-Size* "")
		    )
	     )
	     (setq *Sequence-Size* "")
	 )
    )
  )
 )
)

;-------------------------------------------------------------------------------

(defun (:Property text-mode pathname-defaulting-function) (defaults buffer)
  (if (equal :Read (get buffer :Buffer-Type))
      (fs:default-pathname defaults)
      nil
  )
)

;-------------------------------------------------------------------------------

(defminor Com-Yw-Read-Mode yw-read-mode "YW Read" 1
	  "Minor mode which can read buffer as a mail message."
	  ()							;
	  (set-comtab
	    *mode-comtab*
	   '(#\m-c-sh-x		com-yw-forward-command
	     #\C		com-yw-copy-message
	     #\c		com-yw-copy-message
	     #\D		com-yw-mode-delete-this-message
	     #\d		Com-Yw-Mode-Delete-This-Message
	     #\c-d		Com-Yw-Mode-Alternate-Delete-This-Message
             #\F		com-yw-forward
             #\f		com-yw-forward
	     #\k		com-yw-set-keyword
	     #\K		com-yw-set-keyword
	     #\m-k		com-yw-unset-keyword
	     #\m-sh-k		Com-Yw-Unset-Keyword
	     #\M		com-yw-move-message
	     #\m		com-yw-move-message
	     #\N		com-yw-mode-next-message-in-sequence
	     #\n		com-yw-mode-next-message-in-sequence
	     #\P		com-yw-mode-previous-message-in-sequence
	     #\p		Com-Yw-Mode-Previous-Message-In-Sequence
	     #\M-sh-P		com-yw-print-message
	     #\r		Com-yw-reply
	     #\R		Com-Yw-Reply
	     #\S		zwei:Com-Mail
	     #\s		zwei:Com-Mail
	     #\U		Com-Yw-Mode-Undelete-This-Message
	     #\u		com-yw-mode-undelete-this-message
	     #\c-n		com-yw-mode-maybe-next-numerical-message
	     #\c-p		Com-Yw-Mode-maybe-Previous-Numerical-Message
	     #\S-n		com-yw-mode-next-numerical-message
	     #\S-p		Com-Yw-Mode-Previous-Numerical-Message
	     #\!		Com-Yw-Mode-Toggle-Flagged-State
	     #\Space		zwei:com-next-screen
	     #\rubout		zwei:com-previous-screen
	     #\” 		Com-yw-quit
	     #\‘		Com-Yw-Abort
	     #\†		com-yw-help
	     #\m-†		zwei:com-documentation
	    )
	   '(("Quit"    . Com-yw-quit)
	     ("Abort"   . Com-yw-abort)
	     ("Reply"   . Com-yw-reply)
	     ("Remail"  . Com-yw-remail)
	     ("Forward" . Com-yw-forward)
	     ("Print Buffer" . Com-Yw-Print-Message)
	     ("Forget Address" . com-forget-address)
	     ("Remember Address" . com-remember-address)
	     ("Edit Address" . com-edit-address)
	    )
	  )
	  (set-mode-line-list (Yw-Read-Mode-Line-List))
)

(set-comtab *standard-comtab* nil
	    (make-command-alist '(com-yw-read-mode))
)
(set-comtab *standard-comtab* nil
	    (make-command-alist '(com-edit-rule))
)
(set-comtab *standard-comtab* nil
	    (make-command-alist '(com-edit-rule-set))
)
(set-comtab *standard-comtab* nil
	    (make-command-alist '(com-invoke-rule-set))
)

(defun add-key-command-to-mode (key command mode)
  (if (getf (second (third (assoc 'zwei:set-comtab (get mode 'zwei:Mode)))) key)
      :already-there
      (nconc (second (third (assoc 'zwei:set-comtab (get mode 'zwei:Mode))))
	     (list key command)
      )
  )
)

(defun add-command-to-mode (command mode &optional (force-p nil))
  (let ((name (if (consp command)
		  (first command)
		  (first (first (make-command-alist (list command))))
	      )
	)
	(list (second (fourth (assoc 'zwei:set-comtab (get mode 'zwei:Mode)))))
	(new (if (consp command)
		 command
		 (first (make-command-alist (list command)))
	     )
	)
       )
       (if (assoc name list :Test #'string=)
	   (if force-p
	       (setf (assoc name list :Test #'string=) new)
	       :Already-There
	   )
	   (nconc
	     (second (fourth (assoc 'zwei:set-comtab (get mode 'zwei:Mode))))
	     (list new)
	   )
       )
  )
)

(Add-Command-To-Mode 'Com-Forget-Address 'zwei:mail-mode)
(Add-Command-To-Mode 'Com-Remember-Address 'zwei:mail-mode)
(Add-Command-To-Mode 'Com-List-Address-Database 'zwei:mail-mode)
(Add-Command-To-Mode 'com-edit-address   'zwei:mail-mode)
(Add-Command-To-Mode '("ReMail" . Com-Yw-Remail-sent-message) 'zwei:mail-mode)
(Add-Key-Command-To-Mode #\   'Com-Yw-Complete 'zwei:mail-mode)
(Add-Key-Command-To-Mode #\C-/ 'Com-Yw-Menu-Recognition-Complete
			 'zwei:mail-mode
)
(Add-Key-Command-To-Mode #\S-/ 'Com-Yw-Apropos-Complete 'zwei:mail-mode)
(Add-Key-Command-To-Mode #\H- 'Com-Yw-Spelling-Correcting-Complete
			 'zwei:mail-mode
)
(Add-Key-Command-To-Mode #\S-i 'Com-Include-Message 'zwei:mail-mode)



;-------------------------------------------------------------------------------

(defun string-already-there (string list)
  (find-if #'(lambda (x)
	       (and (stringp x)
		    (lisp:search string x :Test #'string-equal)
	       )
	     )
	     list
  )
)

(setf (second (get 'zwei:mail-mode 'zwei:mode))
     `(Set-Mode-Line-List
	(let ((addition '("  (END to mail -- ABORT to exit)")))
	     (if (string-already-there (first addition) (mode-line-list))
		 (mode-line-list)
		 (append (mode-line-list) addition)
	     )
        )
      )
)

(setf (nth (position
	     (assoc 'Set-Mode-Line-List (get 'zwei:dired-mode 'zwei:mode))
	     (get 'zwei:dired-mode 'zwei:mode)
	   )
	   (get 'zwei:dired-mode 'zwei:mode)
      )
     `(Set-Mode-Line-List
	(let ((addition '("      (END to exit)")))
	     (if (string-already-there (first addition) (mode-line-list))
		 (mode-line-list)
		 (append (mode-line-list) addition)
	     )
        )
      )
)


(defadvise eval-undo-list (:bind-so-we-know-we-are-inside) ()
  (let ((*inside-undo-eval* t))
       (declare (special *inside-undo-eval*))
       :Do-It
  )
)

;;; This is a horrible kludge, but I'm not sure how else to stop the
;;; horrible end to mail string appearing all over the place.
(defadvise set-mode-line-list (:watch-for-multiple-ends) (new)
  (declare (special *inside-undo-eval*))
  (setf new (remove-duplicates new))
  (if (and (not (keywordp (get *interval* :Buffer-Type)))
	   (or (not (get *interval* :mail-template-type))
	       (and (boundp '*inside-undo-eval*) *inside-undo-eval*)
	   )
	   (lisp:find '"  (END to mail -- ABORT to exit)" new
		      :Test #'equal
	   )
      )
      (setf new
	    (remove '"  (END to mail -- ABORT to exit)" new :Test #'equal)
      )
      nil
  )
  :Do-It
)



;-------------------------------------------------------------------------------